src/module-parse.lisp (code): Hoist complex sub-items out of main parser.

[sod] / src / module-parse.lisp

diff --git a/src/module-parse.lisp b/src/module-parse.lisp
index 747bdf75157c2905b1906b9857ab73a8525dcb4d..fb4903b4f8175cab052d2105bbc5692327f19301 100644 (file)
--- a/src/module-parse.lisp
+++ b/src/module-parse.lisp
@@ -64,23 +64,25 @@ (define-pluggable-parser module code (scanner pset)
             (item ()
               (parse (or (kw)
                          (seq (#\( (names (list (:min 1) (kw))) #\))
-                           names)))))
+                           names))))
+            (constraints ()
+              (parse (seq (#\[
+                           (constraints
+                            (list ()
+                              (list (:min 1)
+                                (error (:ignore-unconsumed t) (item)
+                                  (skip-until () :id #\( #\, #\])))
+                              #\,))
+                           #\])
+                       constraints)))
+            (fragment ()
+              (parse-delimited-fragment scanner #\{ #\})))
       (parse (seq ("code"
                   (reason (must (kw)))
                   (nil (must #\:))
                   (name (must (item)))
-                  (constraints (? (seq (#\[
-                                        (constraints
-                                         (list ()
-                                           (list (:min 1)
-                                             (error (:ignore-unconsumed t)
-                                                 (item)
-                                               (skip-until ()
-                                                 :id #\( #\, #\])))
-                                           #\,))
-                                        #\])
-                                    constraints)))
-                  (fragment (parse-delimited-fragment scanner #\{ #\})))
+                  (constraints (? (constraints)))
+                  (fragment (fragment)))
               (when name
                 (add-to-module *module*
                                (make-instance 'code-fragment-item
@@ -108,9 +110,7 @@ (defun read-module (pathname &key (truename nil truep) location)
   (unless truep (setf truename (truename pathname)))
   (define-module (pathname :location location :truename truename)
     (with-open-file (f-stream pathname :direction :input)
-      (let* ((*readtable* (copy-readtable))
-            (*package* (find-package '#:sod-user))
-            (char-scanner (make-instance 'charbuf-scanner
+      (let* ((char-scanner (make-instance 'charbuf-scanner
                                          :stream f-stream
                                          :filename (namestring pathname)))
             (scanner (make-instance 'sod-token-scanner
@@ -128,20 +128,13 @@   (define-module (pathname :location location :truename truename)
              (declare (ignore consumedp))
              (unless winp (syntax-error scanner result)))))))))
 
-(define-pluggable-parser module test (scanner pset)
-  ;; `demo' string `;'
-  (declare (ignore pset))
-  (with-parser-context (token-scanner-context :scanner scanner)
-    (parse (seq ("demo" (string (must :string)) (nil (must #\;)))
-            (format t ";; DEMO ~S~%" string)))))
-
 (define-pluggable-parser module file (scanner pset)
   ;; `import' string `;'
   ;; `load' string `;'
   (declare (ignore pset))
   (flet ((common (name type what thunk)
           (when name
-            (find-file scanner
+            (find-file (pathname (scanner-filename scanner))
                        (merge-pathnames name
                                         (make-pathname :type type
                                                        :case :common))
@@ -156,6 +149,7 @@ (define-pluggable-parser module file (scanner pset)
                                                            :truename true)))
                                   (when module
                                     (module-import module)
+                                    (pushnew path (module-files *module*))
                                     (pushnew module
                                              (module-dependencies
                                               *module*))))
@@ -170,7 +164,9 @@ (define-pluggable-parser module file (scanner pset)
                   (common name "LISP" "Lisp file"
                           (lambda (path true)
                             (handler-case
-                                (load true :verbose nil :print nil)
+                                (progn
+                                  (pushnew path (module-files *module*))
+                                  (load true :verbose nil :print nil))
                               (error (error)
                                 (cerror* "Error loading Lisp file ~S: ~A"
                                          path error)))))))))))
@@ -226,7 +222,7 @@ (define-pluggable-parser class-item initfrags (scanner class pset)
     (parse (seq ((make (or (seq ("init") #'make-sod-class-initfrag)
                           (seq ("teardown") #'make-sod-class-tearfrag)))
                 (frag (parse-delimited-fragment scanner #\{ #\})))
-            (funcall make class frag pset scanner)))))
+            (funcall make class frag pset :location scanner)))))
 
 (define-pluggable-parser class-item initargs (scanner class pset)
   ;; initarg-item ::= `initarg' declspec+ list[init-declarator]
@@ -243,7 +239,9 @@ (define-pluggable-parser class-item initargs (scanner class pset)
                          (make-sod-user-initarg class
                                                 (cdr declarator)
                                                 (car declarator)
-                                                pset init scanner))
+                                                pset
+                                                :default init
+                                                :location scanner))
                        #\,))
                 (nil (must #\;)))))))
 
@@ -282,7 +280,8 @@ (defun parse-class-body (scanner pset name supers)
                                 (unless (pset-get pset "nick")
                                   (add-property pset "nick" var :type :id))
                                 var)))
-          (class (make-sod-class synthetic-name superclasses pset scanner))
+          (class (make-sod-class synthetic-name superclasses pset
+                                 :location scanner))
           (nick (sod-class-nickname class)))
 
       (labels ((must-id ()
@@ -313,8 +312,8 @@ (defun parse-class-body (scanner pset name supers)
                 ;; Don't allow a method-body here if the message takes a
                 ;; varargs list, because we don't have a name for the
                 ;; `va_list' parameter.
-                (let ((message (make-sod-message class name type
-                                                 sub-pset scanner)))
+                (let ((message (make-sod-message class name type sub-pset
+                                                 :location scanner)))
                   (if (varargs-message-p message)
                       (parse #\;)
                       (parse (or #\; (parse-method-item sub-pset
@@ -330,7 +329,8 @@ (defun parse-class-body (scanner pset name supers)
                                         scanner #\{ #\}))))
                          (restart-case
                              (make-sod-method class sub-nick name type
-                                              body sub-pset scanner)
+                                              body sub-pset
+                                              :location scanner)
                            (continue () :report "Continue")))))
 
               (parse-initializer ()
@@ -350,14 +350,12 @@ (defun parse-class-body (scanner pset name supers)
                 (flet ((make-it (name type init)
                          (restart-case
                              (progn
-                               (make-sod-slot class name type
-                                              sub-pset scanner)
+                               (make-sod-slot class name type sub-pset
+                                              :location scanner)
                                (when init
-                                 (make-sod-instance-initializer class
-                                                                nick name
-                                                                init
-                                                                sub-pset
-                                                                scanner)))
+                                 (make-sod-instance-initializer
+                                  class nick name init sub-pset
+                                  :location scanner)))
                            (continue () :report "Continue"))))
                   (parse (and (error ()
                                   (seq ((init (? (parse-initializer))))
@@ -388,7 +386,8 @@ (defun parse-class-body (scanner pset name supers)
                                       (restart-case
                                           (funcall constructor class
                                                    name-a name-b init
-                                                   sub-pset scanner)
+                                                   sub-pset
+                                                   :location scanner)
                                         (continue () :report "Continue")))
                                   (skip-until () #\, #\;))
                                 #\,)