X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/blobdiff_plain/71ecc48e20c8651175b16f37ee66ca08a36cc1c6..a07d8d005f69c0f9f5da2e09c6ee39cb1e1801aa:/module.lisp

diff --git a/module.lisp b/module.lisp
index 5d05365..6f8aeec 100644
--- a/module.lisp
+++ b/module.lisp
@@ -166,9 +166,10 @@ (defun read-module (pathname &key (truename (truename pathname)) location)
    PROBE-FILE or similar, which drops the truename into your lap."
 
   ;; Deal with a module which is already in the map.  If its state is a
-  ;; file-location then it's in progress and we have a cyclic dependency.
+  ;; FILE-LOCATION then it's in progress and we have a cyclic dependency.
   (let ((module (gethash truename *module-map*)))
-    (cond ((typep (module-state module) 'file-location)
+    (cond ((null module))
+	  ((typep (module-state module) 'file-location)
 	   (error "Module ~A already being imported at ~A"
 		  pathname (module-state module)))
 	  (module
@@ -186,46 +187,50 @@   (define-module (pathname :location location :truename truename)
 	  (with-default-error-location (lexer)
 	    (next-char lexer)
 	    (next-token lexer)
-	    (parse-module lexer *module*)))))))
+	    (parse-module lexer)))))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Module parsing protocol.
 
 (defgeneric parse-module-declaration (tag lexer pset)
   (:method (tag lexer pset)
-    (error "Unexpected module declaration ~(~A~)" tag)))
+    (error "Unexpected module declaration ~(~A~)" tag))
+  (:method :before (tag lexer pset)
+    (next-token lexer)))
 
 (defun parse-module (lexer)
   "Main dispatching for module parser.
 
    Calls PARSE-MODULE-DECLARATION for the identifiable declarations."
 
-  ;; A little fancy footwork is required because `class' is a reserved word.
   (loop
-    (flet ((dispatch (tag pset)
-	     (next-token lexer)
-	     (parse-module-declaration tag lexer pset)
-	     (check-unused-properties pset)))
-      (restart-case
-	  (case (token-type lexer)
-	    (:eof (return))
-	    (#\; (next-token lexer))
-	    (t (let ((pset (parse-property-set lexer)))
-		 (case (token-type lexer)
-		   (:id (dispatch (string-to-symbol (token-value lexer)
-						    :keyword)
-				  pset))
-		   (t (error "Unexpected token ~A: ignoring"
-			     (format-token lexer)))))))
-	(continue ()
-	  :report "Ignore the error and continue parsing."
-	  nil)))))
+    (restart-case
+	(case (token-type lexer)
+	  (:eof (return))
+	  (#\; (next-token lexer))
+	  (t (let ((pset (parse-property-set lexer)))
+	       (case (token-type lexer)
+		 (:id (let ((tag (intern (frob-case (token-value lexer))
+					 :keyword)))
+			(parse-module-declaration tag lexer pset)
+			(check-unused-properties pset)))
+		 (t (error "Unexpected token ~A: ignoring"
+			   (format-token lexer)))))))
+      (continue ()
+	:report "Ignore the error and continue parsing."
+	nil))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Type definitions.
 
 (defclass type-item ()
-  ((name :initarg :name :type string :reader type-name)))
+  ((name :initarg :name :type string :reader type-name))
+  (:documentation
+   "A note that a module exports a type.
+
+   We can only export simple types, so we only need to remember the name.
+   The magic simple-type cache will ensure that we get the same type object
+   when we do the import."))
 
 (defmethod module-import ((item type-item))
   (let* ((name (type-name item))
@@ -239,6 +244,82 @@ 	 (def (gethash name *type-map*))
 (defmethod module-import ((class sod-class))
   (record-sod-class class))
 
+(defmethod parse-module-declaration ((tag (eql :typename)) lexer pset)
+  "module-decl ::= `typename' id-list `;'"
+  (loop (let ((name (require-token lexer :id)))
+	  (unless name (return))
+	  (if (gethash name *type-map*)
+	      (cerror* "Type `~A' already defined" name)
+	      (add-to-module *module* (make-instance 'type-item :name name)))
+	  (unless (require-token lexer #\, :errorp nil) (return))))
+  (require-token lexer #\;))
+
+;;;--------------------------------------------------------------------------
+;;; Fragments.
+
+(defclass code-fragment-item ()
+  ((fragment :initarg :fragment :type c-fragment :reader code-fragment)
+   (reason :initarg :reason :type keyword :reader code-fragment-reason)
+   (name :initarg :name :type t :reader code-fragment-name)
+   (constraints :initarg :constraints :type list
+		:reader code-fragment-constraints))
+  (:documentation
+   "A plain fragment of C to be dropped in at top-level."))
+
+(defmacro define-fragment ((reason name) &body things)
+  (categorize (thing things)
+      ((constraints (listp thing))
+       (frags (typep thing '(or string c-fragment))))
+    (when (null frags)
+      (error "Missing code fragment"))
+    (when (cdr frags)
+      (error "Multiple code fragments"))
+    `(add-to-module
+      *module*
+      (make-instance 'code-fragment-item
+		     :fragment ',(car frags)
+		     :name ,name
+		     :reason ,reason
+		     :constraints (list ,@(mapcar (lambda (constraint)
+						    (cons 'list constraint))
+						  constraints))))))
+
+(defmethod parse-module-declaration ((tag (eql :code)) lexer pset)
+  "module-decl ::= `code' id `:' id [constraint-list] `{' c-fragment `}'
+   constraint ::= id*"
+  (labels ((parse-constraint ()
+	     (let ((list nil))
+	       (loop (let ((id (require-token lexer :id
+					      :errorp (null list))))
+		       (unless id (return))
+		       (push id list)))
+	       (nreverse list)))
+	   (parse-constraints ()
+	     (let ((list nil))
+	       (when (require-token lexer #\[ :errorp nil)
+		 (loop (let ((constraint (parse-constraint)))
+			 (push constraint list)
+			 (unless (require-token lexer #\, :errorp nil)
+			   (return))))
+		 (require-token lexer #\]))
+	       (nreverse list)))
+	   (keywordify (id)
+	     (and id (intern (substitute #\- #\_ (frob-case id)) :keyword))))
+    (let* ((reason (prog1 (keywordify (require-token lexer :id))
+		   (require-token lexer #\:)))
+	   (name (keywordify (require-token lexer :id)))
+	   (constraints (parse-constraints)))
+      (when (require-token lexer #\{ :consumep nil)
+	(let ((frag (scan-c-fragment lexer '(#\}))))
+	  (next-token lexer)
+	  (require-token lexer #\})
+	  (add-to-module *module*
+			 (make-instance 'code-fragment-item
+					:name name
+					:reason reason
+					:constraints constraints
+					:fragment frag)))))))
+
 ;;;--------------------------------------------------------------------------
 ;;; File searching.
 
@@ -281,11 +362,12 @@ (defun find-file (lexer name what thunk)
       (error "Error searching for ~A ~S: ~A" what (namestring name) error))
     (:no-error (path probe)
       (cond ((null path)
-	     (error "Failed to find ~A ~S" what name))
+	     (error "Failed to find ~A ~S" what (namestring name)))
 	    (t
 	     (funcall thunk path probe))))))
 
 (defmethod parse-module-declaration ((tag (eql :import)) lexer pset)
+  "module-decl ::= `import' string `;'"
   (let ((name (require-token lexer :string)))
     (when name
       (find-file lexer
@@ -304,6 +386,7 @@ (defmethod parse-module-declaration ((tag (eql :import)) lexer pset)
       (require-token lexer #\;))))
 
 (defmethod parse-module-declaration ((tag (eql :load)) lexer pset)
+  "module-decl ::= `load' string `;'"
   (let ((name (require-token lexer :string)))
     (when name
       (find-file lexer
@@ -317,6 +400,163 @@ (defmethod parse-module-declaration ((tag (eql :load)) lexer pset)
 				path error)))))
       (require-token lexer #\;))))
 
+;;;--------------------------------------------------------------------------
+;;; Lisp escapes.
+
+(defmethod parse-module-declaration :around ((tag (eql :lisp)) lexer pset)
+  "module-decl ::= `lisp' s-expression `;'"
+  (let ((form (with-lexer-stream (stream lexer) (read stream t))))
+    (eval form))
+  (next-token lexer)
+  (require-token lexer #\;))
+
+;;;--------------------------------------------------------------------------
+;;; Class declarations.
+
+(defmethod parse-module-declaration ((tag (eql :class)) lexer pset)
+  "module-decl ::= `class' id [`:' id-list] `{' class-item* `}'"
+  (let* ((location (file-location lexer))
+	 (name (let ((name (require-token lexer :id)))
+		 (make-class-type name location)
+		 (when (require-token lexer #\; :errorp nil)
+		   (return-from parse-module-declaration))
+		 name))
+	 (supers (when (require-token lexer #\: :errorp nil)
+		   (let ((list nil))
+		     (loop (let ((id (require-token lexer :id)))
+			     (unless id (return))
+			     (push id list)
+			     (unless (require-token lexer #\, :errorp nil)
+			       (return))))
+		     (nreverse list))))
+	 (class (make-sod-class name (mapcar #'find-sod-class supers)
+				pset location))
+	 (nick (sod-class-nickname class)))
+    (require-token lexer #\{)
+
+    (labels ((parse-item ()
+	       "Try to work out what kind of item this is.  Messy."
+	       (let* ((pset (parse-property-set lexer))
+		      (location (file-location lexer)))
+		 (cond ((declaration-specifier-p lexer)
+			(let ((declspec (parse-c-type lexer)))
+			  (multiple-value-bind (type name)
+			      (parse-c-declarator lexer declspec :dottedp t)
+			    (cond ((null type)
+				   nil)
+				  ((consp name)
+				   (parse-method type (car name) (cdr name)
+						 pset location))
+				  ((typep type 'c-function-type)
+				   (parse-message type name pset location))
+				  (t
+				   (parse-slots declspec type name
+						pset location))))))
+		       ((not (eq (token-type lexer) :id))
+			(cerror* "Expected <class-item>; found ~A (skipped)"
+				 (format-token lexer))
+			(next-token lexer))
+		       ((string= (token-value lexer) "class")
+			(next-token lexer)
+			(parse-initializers #'make-sod-class-initializer
+					    pset location))
+		       (t
+			(parse-initializers #'make-sod-instance-initializer
+					    pset location)))))
+
+	     (parse-method (type nick name pset location)
+	       "class-item ::= declspec+ dotted-declarator -!- method-body
+
+		method-body ::= `{' c-fragment `}' | `extern' `;'
+
+		The dotted-declarator must describe a function type."
+	       (let ((body (cond ((eq (token-type lexer) #\{)
+				  (prog1 (scan-c-fragment lexer '(#\}))
+				    (next-token lexer)
+				    (require-token lexer #\})))
+				 ((and (eq (token-type lexer) :id)
+				       (string= (token-value lexer)
+						"extern"))
+				  (next-token lexer)
+				  (require-token lexer #\;)
+				  nil)
+				 (t
+				  (cerror* "Expected <method-body>; ~
+					    found ~A"
+					   (format-token lexer))))))
+		 (make-sod-method class nick name type body pset location)))
+
+	     (parse-message (type name pset location)
+	       "class-item ::= declspec+ declarator -!- (method-body | `;')
+
+		The declarator must describe a function type."
+	       (make-sod-message class name type pset location)
+	       (unless (require-token lexer #\; :errorp nil)
+		 (parse-method type nick name nil location)))
+
+	     (parse-initializer-body ()
+	       "initializer ::= `=' `{' c-fragment `}' | `=' c-fragment"
+	       (let ((char (lexer-char lexer)))
+		 (loop
+		   (when (or (null char) (not (whitespace-char-p char)))
+		     (return))
+		   (setf char (next-char lexer)))
+		 (cond ((eql char #\{)
+			(next-char lexer)
+			(let ((frag (scan-c-fragment lexer '(#\}))))
+			  (next-token lexer)
+			  (require-token lexer #\})
+			  (values :compound frag)))
+		       (t
+			(let ((frag (scan-c-fragment lexer '(#\, #\;))))
+			  (next-token lexer)
+			  (values :simple frag))))))
+
+	     (parse-slots (declspec type name pset location)
+	       "class-item ::=
+		  declspec+ init-declarator [`,' init-declarator-list] `;'
+
+		init-declarator ::= declarator -!- [initializer]"
+	       (loop
+		 (make-sod-slot class name type pset location)
+		 (when (eql (token-type lexer) #\=)
+		   (multiple-value-bind (kind form) (parse-initializer-body)
+		     (make-sod-instance-initializer class nick name
+						    kind form nil
+						    location)))
+		 (unless (require-token lexer #\, :errorp nil)
+		   (return))
+		 (setf (values type name)
+		       (parse-c-declarator lexer declspec)
+		       location (file-location lexer)))
+	       (require-token lexer #\;))
+
+	     (parse-initializers (constructor pset location)
+	       "class-item ::= [`class'] -!- slot-initializer-list `;'
+
+		slot-initializer ::= id `.' id initializer"
+	       (loop
+		 (let ((nick (prog1 (require-token lexer :id)
+			       (require-token lexer #\.)))
+		       (name (require-token lexer :id)))
+		   (require-token lexer #\=)
+		   (multiple-value-bind (kind form)
+		       (parse-initializer-body)
+		     (funcall constructor class nick name kind form
+			      pset location)))
+		 (unless (require-token lexer #\, :errorp nil)
+		   (return))
+		 (setf location (file-location lexer)))
+	       (require-token lexer #\;)))
+
+      (loop
+	(when (require-token lexer #\} :errorp nil)
+	  (return))
+	(parse-item)))
+
+    (finalize-sod-class class)
+    (add-to-module *module* class)))
+
 ;;;--------------------------------------------------------------------------
 ;;; Modules.
 
@@ -359,12 +599,7 @@ (defun parse-module (lexer)
 	   ;;
 	   ;; Process an in-line Lisp form immediately.
 	   (:lisp
-	    (let ((form (with-lexer-stream (stream lexer)
-			  (read stream t))))
-	      (handler-case
-		  (eval form)
-		(error (error)
-		  (cerror* "Error in Lisp form: ~A" error))))
+	    
 	    (next-token lexer)
 	    (go top))