X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/54ea6ee880f52c23279bf58262ca245b531d04b0..refs/heads/mdw/progfmt:/src/module-parse.lisp

diff --git a/src/module-parse.lisp b/src/module-parse.lisp
index 8344281..43a49ad 100644
--- a/src/module-parse.lisp
+++ b/src/module-parse.lisp
@@ -100,7 +100,7 @@
 ;;; External files.
 
 (export 'read-module)
-(defun read-module (pathname &key (truename nil truep) location)
+(defun read-module (pathname &key (truename nil truep) location stream)
   "Parse the file at PATHNAME as a module, returning it.
 
    This is the main entry point for parsing module files.  You may well know
@@ -115,24 +115,29 @@
 				  (make-pathname :type "SOD" :case :common)))
   (unless truep (setf truename (truename pathname)))
   (define-module (pathname :location location :truename truename)
-    (with-open-file (f-stream pathname :direction :input)
-      (let* ((char-scanner (make-instance 'charbuf-scanner
-					  :stream f-stream
-					  :filename (namestring pathname)))
-	     (scanner (make-instance 'sod-token-scanner
-				     :char-scanner char-scanner)))
-	(with-default-error-location (scanner)
-	  (with-parser-context (token-scanner-context :scanner scanner)
-	    (multiple-value-bind (result winp consumedp)
-		(parse (skip-many ()
-			  (seq ((pset (parse-property-set scanner))
-				(nil (error ()
-					 (plug module scanner pset)
-				       (skip-until (:keep-end nil)
-					 #\; #\}))))
-			    (check-unused-properties pset))))
-	      (declare (ignore consumedp))
-	      (unless winp (syntax-error scanner result)))))))))
+    (flet ((parse (f-stream)
+	     (let* ((char-scanner
+		     (make-instance 'charbuf-scanner
+				    :stream f-stream
+				    :filename (namestring pathname)))
+		    (scanner (make-instance 'sod-token-scanner
+					    :char-scanner char-scanner)))
+	       (with-default-error-location (scanner)
+		 (with-parser-context
+		     (token-scanner-context :scanner scanner)
+		   (multiple-value-bind (result winp consumedp)
+		       (parse (skip-many ()
+				(seq ((pset (parse-property-set scanner))
+				      (nil (error ()
+					     (plug module scanner pset)
+					     (skip-until (:keep-end nil)
+							 #\; #\}))))
+				     (check-unused-properties pset))))
+		     (declare (ignore consumedp))
+		     (unless winp (syntax-error scanner result))))))))
+      (if stream (parse stream)
+	  (with-open-file (stream pathname :direction :input)
+	    (parse stream))))))
 
 (define-pluggable-parser module file (scanner pset)
   ;; `import' string `;'
@@ -152,7 +157,10 @@
 			   (lambda (path true)
 			     (handler-case
 				 (let ((module (read-module path
-							    :truename true)))
+							    :truename true
+							    :location
+							      (file-location
+							       scanner))))
 				   (when module
 				     (module-import module)
 				     (pushnew path (module-files *module*))
@@ -217,6 +225,60 @@
 	     (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.
 
 (export 'class-item)