src/final.lisp (test-module): By default, just report and count up errors.

[sod] / src / final.lisp

diff --git a/src/final.lisp b/src/final.lisp
index 1b87c26cc2b4090dc05cc7fa98e86913b4bd6fa5..8cd42f83478d5834dd8424276a36a00d5c7a86f6 100644 (file)
--- a/src/final.lisp
+++ b/src/final.lisp
@@ -39,16 +39,27 @@ (export '*debugout-pathname*)
 (defvar *debugout-pathname* #p"debugout.c")
 
 (export 'test-module)
 (defvar *debugout-pathname* #p"debugout.c")
 
 (export 'test-module)

-(defun test-module (path reason)
-  "Reset the translator's state, read a module from PATH and output it with
-   REASON, returning the result as a string."
-  (clear-the-decks)
-  (setf *module-map* (make-hash-table :test #'equal))
-  (with-open-file (out *debugout-pathname*
-                  :direction :output
-                  :if-exists :supersede
-                  :if-does-not-exist :create)
-    (output-module (read-module path) reason out)))
+(defun test-module (path &key reason clear backtrace)
+  "Read a module from PATH, to exercise the machinery.
+
+   If CLEAR is non-nil, then reset the translator's state before proceeding.
+
+   If REASON is non-nil, then output the module to `*debugout-pathname*' with
+   that REASON.
+
+   Return a two-element list (NERROR NWARNING) of the number of errors and
+   warnings encountered while processing the module."
+  (when clear (clear-the-decks))
+  (multiple-value-bind (module nerror nwarning)
+      (if backtrace (read-module path)
+         (count-and-report-errors () (read-module path)))
+    (when (and module reason)
+      (with-open-file (out *debugout-pathname*
+                      :direction :output
+                      :if-exists :supersede
+                      :if-does-not-exist :create)
+       (output-module module reason out)))
+    (list nerror nwarning)))

 
 (export 'test-parse-c-type)
 (defun test-parse-c-type (string)
 
 (export 'test-parse-c-type)
 (defun test-parse-c-type (string)


@@ -74,29 +85,47 @@ (defun test-parse-c-type (string)
              (values nil value)))))))
 
 (export 'test-parser)
              (values nil value)))))))
 
 (export 'test-parser)

-(defmacro test-parser ((scanner &key) parser input)
+(defmacro test-parser ((scanner &key backtrace) parser input)

   "Convenient macro for testing parsers at the REPL.
 
    This is a macro so that the parser can use the fancy syntax.  The name
    SCANNER is bound to a `sod-token-scanner' reading tokens from the INPUT
   "Convenient macro for testing parsers at the REPL.
 
    This is a macro so that the parser can use the fancy syntax.  The name
    SCANNER is bound to a `sod-token-scanner' reading tokens from the INPUT

-   string.  Then the PARSER is invoked and three values are returned: a
-   `successp' flag indicating whether the parser succeeded; the result,
-   output or error indicator, of the parser; and a list consisting of the
-   lookahead token type and value, and a string containing the untokenized
-   remaining input."
+   string.  Then the PARSER is invoked and three values are returned: the
+   result of the parse, or `nil' if the main parse failed; a list containing
+   the number of errors and warnings (respectively) reported during the
+   parse; and a list consisting of the lookahead token type and value, and a
+   string containing the untokenized remaining input.
+
+   If BACKTRACE is nil (the default) then leave errors to the calling
+   environment to sort out (e.g., by entering the Lisp debugger); otherwise,
+   catch and report them as they happen so that you can test error recovery
+   strategies."

   (once-only (input)
   (once-only (input)

-    (with-gensyms (char-scanner value winp consumedp where)
-      `(let* ((,char-scanner (make-string-scanner ,input))
-             (,scanner (make-instance 'sod-token-scanner
-                                      :char-scanner ,char-scanner
-                                      :filename "<test-input>")))
+    (with-gensyms (char-scanner value winp body consumedp where nerror nwarn)
+      `(let ((,char-scanner nil) (,scanner nil))

         (with-parser-context (token-scanner-context :scanner ,scanner)
         (with-parser-context (token-scanner-context :scanner ,scanner)

-          (multiple-value-bind (,value ,winp ,consumedp) (parse ,parser)
-            (declare (ignore ,consumedp))
+          (multiple-value-bind (,value ,nerror ,nwarn)
+              (flet ((,body ()
+                       (setf ,char-scanner (make-string-scanner ,input)
+                             ,scanner (make-instance
+                                       'sod-token-scanner
+                                       :char-scanner ,char-scanner))
+                       (multiple-value-bind (,value ,winp ,consumedp)
+                           (parse ,parser)
+                         (declare (ignore ,consumedp))
+                         (cond (,winp ,value)
+                               (t (syntax-error ,scanner ,value)
+                                  nil)))))
+                (if ,backtrace (,body)
+                    (count-and-report-errors ()
+                      (with-default-error-location (,scanner)
+                        (,body)))))

             (let ((,where (scanner-capture-place ,char-scanner)))
             (let ((,where (scanner-capture-place ,char-scanner)))

-              (values ,winp ,value
-                      (list (token-type ,scanner) (token-value ,scanner)
-                            (subseq ,input ,where))))))))))
+              (values ,value
+                      (list ,nerror ,nwarn)
+                      (and ,scanner (list (token-type ,scanner)
+                                          (token-value ,scanner)
+                                          (subseq ,input ,where)))))))))))

 
 ;;;--------------------------------------------------------------------------
 ;;; Calisthenics.
 
 ;;;--------------------------------------------------------------------------
 ;;; Calisthenics.


@@ -115,11 +144,15 @@ (defun exercise ()
    That's the theory anyway.  Call this function before you dump an image and
    see what happens."
 
    That's the theory anyway.  Call this function before you dump an image and
    see what happens."
 

-  (clear-the-decks)

   (dolist (reason '(:h :c))
     (with-output-to-string (bitbucket)
       (output-module *builtin-module* reason bitbucket)))
 
   (clear-the-decks))
 
   (dolist (reason '(:h :c))
     (with-output-to-string (bitbucket)
       (output-module *builtin-module* reason bitbucket)))
 
   (clear-the-decks))
 

+;;;--------------------------------------------------------------------------
+;;; Make sure things work after loading the system.
+
+(clear-the-decks)
+

 ;;;----- That's all, folks --------------------------------------------------
 ;;;----- That's all, folks --------------------------------------------------