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

diff --git a/src/module-parse.lisp b/src/module-parse.lisp
index f025e37..eff4af7 100644
--- a/src/module-parse.lisp
+++ b/src/module-parse.lisp
@@ -52,6 +52,7 @@
 
 (define-pluggable-parser module code (scanner pset)
   ;; `code' id `:' item-name [constraints] `{' c-fragment `}'
+  ;; `code' id `:' constraints `;'
   ;;
   ;; constraints ::= `[' list[constraint] `]'
   ;; constraint ::= item-name+
@@ -80,7 +81,12 @@
       (parse (seq ("code"
 		   (reason (must (kw)))
 		   (nil (must #\:))
-		   (item (or (seq ((name (must (item)))
+		   (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
@@ -211,6 +217,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)