X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/0c289c54fb0a31491aa1d2b030851337430ccd71..d018d6d87c7a2c3458348f775319b6f9c4a88380:/src/module-parse.lisp

diff --git a/src/module-parse.lisp b/src/module-parse.lisp
index 747bdf7..f025e37 100644
--- a/src/module-parse.lisp
+++ b/src/module-parse.lisp
@@ -64,30 +64,32 @@
 	     (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 ((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 +110,7 @@
   (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 @@
 	      (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 @@
 							    :truename true)))
 				   (when module
 				     (module-import module)
+				     (pushnew path (module-files *module*))
 				     (pushnew module
 					      (module-dependencies
 					       *module*))))
@@ -170,7 +164,9 @@
 		   (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 @@
     (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 @@
 			  (make-sod-user-initarg class
 						 (cdr declarator)
 						 (car declarator)
-						 pset init scanner))
+						 pset
+						 :default init
+						 :location scanner))
 			#\,))
 		 (nil (must #\;)))))))
 
@@ -282,7 +280,8 @@
 				 (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 @@
 		 ;; 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 @@
 					 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 @@
 		 (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 @@
 				       (restart-case
 					   (funcall constructor class
 						    name-a name-b init
-						    sub-pset scanner)
+						    sub-pset
+						    :location scanner)
 					 (continue () :report "Continue")))
 				   (skip-until () #\, #\;))
 				 #\,)