src/utilities.lisp (compose): Handle the case of zero arguments.

[sod] / src / final.lisp

diff --git a/src/final.lisp b/src/final.lisp
index e7a3eb441c4cc9b6d2594d79dd4d1d9c4c2fe1da..93fafe86e65ef3a738bdc4df222bb763e036013e 100644 (file)
--- a/src/final.lisp
+++ b/src/final.lisp
@@ -39,39 +39,68 @@ (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)))
+
+(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 @@ (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 +162,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 --------------------------------------------------