lib/keyword.c (kw_parseempty): Use correct variable scanning `kwval' list.

[sod] / src / final.lisp

diff --git a/src/final.lisp b/src/final.lisp
index e7a3eb4..93fafe8 100644 (file)
--- a/src/final.lisp
+++ b/src/final.lisp
@@ -39,39 +39,68 @@
 (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)))
+
+(defmacro with-test-scanner ((scanner string) &body body)
+  "Common machinery for `test-parse-MUMBLE' below.
+
+   This is too specialized to make more widely available."
+  (with-gensyms (in charscan)
+    (once-only (string)
+      `(with-input-from-string (,in ,string)
+        (let* ((*module-type-map* (make-hash-table))
+               (,charscan (make-instance 'charbuf-scanner
+                                         :stream ,in
+                                         :filename "<string>"))
+               (,scanner (make-instance 'sod-token-scanner
+                                        :char-scanner ,charscan
+                                        :filename "<string>")))
+          (with-parser-context (token-scanner-context :scanner ,scanner)
+            ,@body))))))

 
 (export 'test-parse-c-type)
 (defun test-parse-c-type (string)
   "Parse STRING as a C type, with optional kernel, and show the results."
 
 (export 'test-parse-c-type)
 (defun test-parse-c-type (string)
   "Parse STRING as a C type, with optional kernel, and show the results."

-  (with-input-from-string (in string)
-    (let* ((*module-type-map* (make-hash-table))
-          (charscan (make-instance 'charbuf-scanner
-                                   :stream in
-                                   :filename "<string>"))
-          (tokscan (make-instance 'sod-token-scanner
-                                  :char-scanner charscan
-                                  :filename "<string>")))
-      (with-parser-context (token-scanner-context :scanner tokscan)
-       (multiple-value-bind (value winp consumedp)
-           (parse (seq ((decls (parse-c-type tokscan))
-                        (type (parse-declarator tokscan decls :abstractp t))
-                        :eof)
-                    type))
-         (declare (ignore consumedp))
-         (if winp
-             (values t (car value) (cdr value)
-                     (princ-to-string (car value)))
-             (values nil value)))))))
+  (with-test-scanner (scanner string)
+    (multiple-value-bind (value winp consumedp)
+       (parse (seq ((decls (parse-c-type scanner))
+                    (type (parse-declarator scanner decls :abstractp t))
+                    :eof)
+                   type))
+      (declare (ignore consumedp))
+      (if winp
+         (values t (car value) (cdr value)
+                 (princ-to-string (car value)))
+         (values nil value)))))
+
+(export 'test-parse-pset)
+(defun test-parse-pset (string)
+  "Parse STRING as a property set, and show the results."
+  (with-test-scanner (scanner string)
+    (multiple-value-bind (value winp consumedp)
+       (parse-property-set scanner)
+      (declare (ignore consumedp))
+      (values winp value))))

 
 (export 'test-parser)
 (defmacro test-parser ((scanner &key backtrace) parser input)
 
 (export 'test-parser)
 (defmacro test-parser ((scanner &key backtrace) parser input)


@@ -99,16 +128,16 @@
                              ,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 +162,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 --------------------------------------------------