configure.ac: Complicate ASDF version-number generation.

[sod] / src / module-parse.lisp

diff --git a/src/module-parse.lisp b/src/module-parse.lisp
index 81a39565d32bbbc51c1036df6e2b54d68692e4b6..eff4af7d40fbc2b344d8e509d2e629380af1805d 100644 (file)
--- a/src/module-parse.lisp
+++ b/src/module-parse.lisp
@@ -52,6 +52,7 @@ (define-pluggable-parser module typename (scanner pset)
 
 (define-pluggable-parser module code (scanner pset)
   ;; `code' id `:' item-name [constraints] `{' c-fragment `}'
+  ;; `code' id `:' constraints `;'
   ;;
   ;; constraints ::= `[' list[constraint] `]'
   ;; constraint ::= item-name+
@@ -64,30 +65,37 @@ (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 #\{ #\})))
-              (when name
-                (add-to-module *module*
-                               (make-instance 'code-fragment-item
-                                              :fragment fragment
-                                              :constraints constraints
-                                              :reason reason
-                                              :name name))))))))
+                  (item (or (seq ((constraints (constraints))
+                                  (nil (must #\;)))
+                              (make-instance 'code-fragment-item
+                                             :reason reason
+                                             :constraints constraints))
+                            (seq ((name (must (item)))
+                                  (constraints (? (constraints)))
+                                  (fragment (fragment)))
+                              (and name
+                                   (make-instance 'code-fragment-item
+                                                  :reason reason
+                                                  :constraints constraints
+                                                  :name name
+                                                  :fragment fragment))))))
+              (when item (add-to-module *module* item)))))))
 
 ;;; External files.
 
@@ -108,9 +116,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 +134,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 +155,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 +170,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)))))))))))
@@ -214,6 +216,60 @@ (define-pluggable-parser module lisp (scanner pset)
                 (nil (must #\;)))
             (eval sexp)))))
 
+;;;--------------------------------------------------------------------------
+;;; Static instances.
+
+(define-pluggable-parser module instance (scanner pset)
+  ;; `instance' id id list[slot-initializer] `;'
+  (with-parser-context (token-scanner-context :scanner scanner)
+    (let ((duff nil)
+         (floc nil)
+         (empty-pset (make-property-set)))
+      (parse (seq ("instance"
+                  (class (seq ((class-name (must :id)))
+                           (setf floc (file-location scanner))
+                           (restart-case (find-sod-class class-name)
+                             (continue ()
+                               (setf duff t)
+                               nil))))
+                  (name (must :id))
+                  (inits (? (seq (#\:
+                                  (inits (list (:min 0)
+                                           (seq ((nick (must :id))
+                                                 #\.
+                                                 (name (must :id))
+                                                 (value
+                                                  (parse-delimited-fragment
+                                                   scanner #\= '(#\, #\;)
+                                                   :keep-end t)))
+                                             (make-sod-instance-initializer
+                                              class nick name value
+                                              empty-pset
+                                              :add-to-class nil
+                                              :location scanner))
+                                           #\,)))
+                              inits)))
+                  #\;)
+              (unless duff
+                (acond ((find-if (lambda (item)
+                                   (and (typep item 'static-instance)
+                                        (string= (static-instance-name item)
+                                                 name)))
+                                 (module-items *module*))
+                        (cerror*-with-location floc
+                                               "Instance with name `~A' ~
+                                                already defined."
+                                               name)
+                        (info-with-location (file-location it)
+                                            "Previous definition was ~
+                                             here."))
+                       (t
+                        (add-to-module *module*
+                                       (make-static-instance class name
+                                                             inits
+                                                             pset
+                                                             floc))))))))))
+
 ;;;--------------------------------------------------------------------------
 ;;; Class declarations.