src/final.lisp (test-module): Fix egregiously wrong docstring.

[sod] / src / final.lisp

diff --git a/src/final.lisp b/src/final.lisp
index 1b87c26..6b81e3d 100644 (file)
--- a/src/final.lisp
+++ b/src/final.lisp
@@ -40,15 +40,22 @@
 
 (export 'test-module)
 (defun test-module (path reason)
 
 (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)))
+  "Read a module from PATH, to exercise the machinery.
+
+   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."
+  (multiple-value-bind (module nerror nwarning)
+      (count-and-report-errors () (read-module path))
+    (when 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 +81,47 @@
              (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 +140,15 @@
    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 --------------------------------------------------