doc/sod.tex: Don't print the `Index' header in uppercase.

[sod] / src / final.lisp

diff --git a/src/final.lisp b/src/final.lisp
index e7a3eb441c4cc9b6d2594d79dd4d1d9c4c2fe1da..96e9625b3906957a4183cf9e7ae2921da2ab9390 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)


@@ -99,16 +110,16 @@ (defmacro test-parser ((scanner &key backtrace) parser input)
                              ,scanner (make-instance
                                        'sod-token-scanner
                                        :char-scanner ,char-scanner))
                              ,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)))))
+                       (with-default-error-location (,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 ()
                 (if ,backtrace (,body)
                     (count-and-report-errors ()

-                      (with-default-error-location (,scanner)
-                        (,body)))))
+                      (,body))))

             (let ((,where (scanner-capture-place ,char-scanner)))
               (values ,value
                       (list ,nerror ,nwarn)
             (let ((,where (scanner-capture-place ,char-scanner)))
               (values ,value
                       (list ,nerror ,nwarn)


@@ -133,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 --------------------------------------------------