X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/1f1d88f5234188f70548a04fd117ac6e251fe8de..71ecc48e20c8651175b16f37ee66ca08a36cc1c6:/module.lisp

diff --git a/module.lisp b/module.lisp
index bcfc912..5d05365 100644
--- a/module.lisp
+++ b/module.lisp
@@ -26,6 +26,220 @@
 (cl:in-package #:sod)
 
 ;;;--------------------------------------------------------------------------
+;;; Module basics.
+
+(defclass module ()
+  ((name :initarg :name :type pathname :reader module-name)
+   (pset :initarg :pset :initform (make-pset) :type pset :reader module-pset)
+   (items :initarg :items :initform nil :type list :accessor module-items)
+   (dependencies :initarg :dependencies :initform nil
+		 :type list :accessor module-dependencies)
+   (state :initarg :state :initform nil :accessor module-state))
+  (:documentation
+   "A module is a container for the definitions made in a source file.
+
+   Modules are the fundamental units of translation.  The main job of a
+   module is to remember which definitions it contains, so that they can be
+   translated and written to output files.  The module contains the following
+   handy bits of information:
+
+     * A (path) name, which is the filename we used to find it.  The default
+       output filenames are derived from this.  (We use the file's truename
+       as the hash key to prevent multiple inclusion, and that's a different
+       thing.)
+
+     * A property list containing other useful things.
+
+     * A list of the classes defined in the source file.
+
+     * Lists of C fragments to be included in the output header and C source
+       files.
+
+     * A list of other modules that this one depends on.
+
+   Modules are usually constructed by the PARSE-MODULE function, which is in
+   turn usually invoked by IMPORT-MODULE, though there's nothing to stop
+   fancy extensions building modules programmatically."))
+
+(defparameter *module* nil
+  "The current module under construction.
+
+   This is always an instance of MODULE.  Once we've finished constructing
+   it, we'll call CHANGE-CLASS to turn it into an instance of whatever type
+   is requested in the module's :LISP-CLASS property.")
+
+(defgeneric module-import (object)
+  (:documentation
+   "Import definitions into the current environment.
+
+   Instructs the OBJECT to import its definitions into the current
+   environment.  Modules pass the request on to their constituents.  There's
+   a default method which does nothing at all.
+
+   It's not usual to modify the current module.  Inserting things into the
+   *TYPE-MAP* is a good plan.")
+  (:method (object) nil))
+
+(defgeneric add-to-module (module item)
+  (:documentation
+   "Add ITEM to the MODULE's list of accumulated items.
+
+   The module items participate in the MODULE-IMPORT and ADD-OUTPUT-HOOKS
+   protocols."))
+
+(defgeneric finalize-module (module)
+  (:documentation
+   "Finalizes a module, setting everything which needs setting.
+
+   This isn't necessary if you made the module by hand.  If you've
+   constructed it incrementally, then it might be a good plan.  In
+   particular, it will change the class (using CHANGE-CLASS) of the module
+   according to the class choice set in the module's :LISP-CLASS property.
+   This has the side effects of calling SHARED-INITIALIZE, setting the
+   module's state to T, and checking for unrecognized properties.  (Therefore
+   subclasses should add a method to SHARED-INITIALIZE should take care of
+   looking at interesting properties, just to make sure they're ticked
+   off.)"))
+
+(defmethod module-import ((module module))
+  (dolist (item (module-items module))
+    (module-import item)))
+
+(defmethod add-to-module ((module module) item)
+  (setf (module-items module)
+	(nconc (module-items module) (list item)))
+  (module-import item))
+
+(defmethod shared-initialize :after ((module module) slot-names &key pset)
+  "Tick off known properties on the property set."
+  (declare (ignore slot-names))
+  (when pset
+    (dolist (prop '(:guard))
+      (get-property pset prop nil))))
+
+(defmethod finalize-module ((module module))
+  (let* ((pset (module-pset module))
+	 (class (get-property pset :lisp-class :symbol 'module)))
+
+    ;; Always call CHANGE-CLASS, even if it's the same one; this will
+    ;; exercise the property-set fiddling in SHARED-INITIALIZE and we can
+    ;; catch unknown-property errors.
+    (change-class module class :state t :pset pset)
+    (check-unused-properties pset)
+    module))
+
+;;;--------------------------------------------------------------------------
+;;; Module importing.
+
+(defun build-module
+    (name body-func &key (truename (probe-file name)) location)
+  (let ((*module* (make-instance 'module
+				 :name (pathname name)
+				 :state (file-location location)))
+	(*type-map* (make-hash-table :test #'equal)))
+    (module-import *builtin-module*)
+    (when truename
+      (setf (gethash truename *module-map*) *module*))
+    (unwind-protect
+	 (progn
+	   (funcall body-func)
+	   (finalize-module *module*))
+      (when (and truename (not (eq (module-state *module*) t)))
+	(remhash truename *module-map*)))))
+
+(defmacro define-module
+    ((name &key (truename nil truenamep) (location nil locationp))
+     &body body)
+  `(build-module ,name
+		 (lambda () ,@body)
+		 ,@(and truenamep `(:truename ,truename))
+		 ,@(and locationp `(:location ,location))))
+
+(defun read-module (pathname &key (truename (truename pathname)) location)
+  "Reads a module.
+
+   The module is returned if all went well; NIL is returned if an error
+   occurred.
+
+   The PATHNAME argument is the file to read.  TRUENAME should be the file's
+   truename, if known: often, the file will have been searched for using
+   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.
+  (let ((module (gethash truename *module-map*)))
+    (cond ((typep (module-state module) 'file-location)
+	   (error "Module ~A already being imported at ~A"
+		  pathname (module-state module)))
+	  (module
+	   (return-from read-module module))))
+
+  ;; Make a new module.  Be careful to remove the module from the map if we
+  ;; didn't succeed in constructing it.
+  (define-module (pathname :location location :truename truename)
+    (let ((*readtable* (copy-readtable)))
+      (with-open-file (f-stream pathname :direction :input)
+	(let* ((pai-stream (make-instance 'position-aware-input-stream
+					  :stream f-stream
+					  :file pathname))
+	       (lexer (make-instance 'sod-lexer :stream pai-stream)))
+	  (with-default-error-location (lexer)
+	    (next-char lexer)
+	    (next-token lexer)
+	    (parse-module lexer *module*)))))))
+
+;;;--------------------------------------------------------------------------
+;;; Module parsing protocol.
+
+(defgeneric parse-module-declaration (tag lexer pset)
+  (:method (tag lexer pset)
+    (error "Unexpected module declaration ~(~A~)" tag)))
+
+(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)))))
+
+;;;--------------------------------------------------------------------------
+;;; Type definitions.
+
+(defclass type-item ()
+  ((name :initarg :name :type string :reader type-name)))
+
+(defmethod module-import ((item type-item))
+  (let* ((name (type-name item))
+	 (def (gethash name *type-map*))
+	 (type (make-simple-type name)))
+    (cond ((not def)
+	   (setf (gethash name *type-map*) type))
+	  ((not (eq def type))
+	   (error "Conflicting types `~A'" name)))))
+
+(defmethod module-import ((class sod-class))
+  (record-sod-class class))
+
+;;;--------------------------------------------------------------------------
 ;;; File searching.
 
 (defparameter *module-dirs* nil
@@ -71,114 +285,42 @@
 	    (t
 	     (funcall thunk path probe))))))
 
+(defmethod parse-module-declaration ((tag (eql :import)) lexer pset)
+  (let ((name (require-token lexer :string)))
+    (when name
+      (find-file lexer
+		 (merge-pathnames name
+				  (make-pathname :type "SOD" :case :common))
+		 "module"
+		 (lambda (path true)
+		   (handler-case
+		       (let ((module (read-module path :truename true)))
+			 (when module
+			   (module-import module)
+			   (pushnew module (module-dependencies *module*))))
+		     (file-error (error)
+		       (cerror* "Error reading module ~S: ~A"
+				path error)))))
+      (require-token lexer #\;))))
+
+(defmethod parse-module-declaration ((tag (eql :load)) lexer pset)
+  (let ((name (require-token lexer :string)))
+    (when name
+      (find-file lexer
+		 (merge-pathnames name
+				  (make-pathname :type "LISP" :case :common))
+		 "Lisp file"
+		 (lambda (path true)
+		   (handler-case (load true :verbose nil :print nil)
+		     (error (error)
+		       (cerror* "Error loading Lisp file ~S: ~A"
+				path error)))))
+      (require-token lexer #\;))))
+
 ;;;--------------------------------------------------------------------------
 ;;; Modules.
 
-(defclass module ()
-  ((name :initarg :name
-	 :type pathname
-	 :accessor module-name)
-   (plist :initform nil
-	  :initarg :plist
-	  :type list
-	  :accessor module-plist)
-   (classes :initform nil
-	    :initarg :classes
-	    :type list
-	    :accessor module-classes)
-   (source-fragments :initform nil
-		     :initarg :source-fragments
-		     :type list
-		     :accessor module-source-fragments)
-   (header-fragments :initform nil
-		     :initarg :header-fragments
-		     :type list
-		     :accessor module-header-fragments)
-   (dependencies :initform nil
-		 :initarg :dependencies
-		 :type list
-		 :accessor module-dependencies))
-  (:documentation
-   "A module is a container for the definitions made in a source file.
-
-   Modules are the fundamental units of translation.  The main job of a
-   module is to remember which definitions it contains, so that they can be
-   translated and written to output files.  The module contains the following
-   handy bits of information:
-
-     * A (path) name, which is the filename we used to find it.  The default
-       output filenames are derived from this.  (We use the file's truename
-       as the hash key to prevent multiple inclusion, and that's a different
-       thing.)
-
-     * A property list containing other useful things.
-
-     * A list of the classes defined in the source file.
-
-     * Lists of C fragments to be included in the output header and C source
-       files.
-
-     * A list of other modules that this one depends on.
-
-   Modules are usually constructed by the PARSE-MODULE function, which is in
-   turn usually invoked by IMPORT-MODULE, though there's nothing to stop
-   fancy extensions building modules programmatically."))
-
-(defun import-module (pathname &key (truename (truename pathname)))
-  "Import a module.
-
-   The module is returned if all went well; NIL is returned if an error
-   occurred.
-
-   The PATHNAME argument is the file to read.  TRUENAME should be the file's
-   truename, if known: often, the file will have been searched for using
-   PROBE-FILE or similar, which drops the truename into your lap."
-
-  (let ((module (gethash truename *module-map*)))
-    (cond
-
-      ;; The module's not there.  (The *MODULE-MAP* never maps things to
-      ;; NIL.)
-      ((null module)
-
-       ;; Mark the module as being in progress.  Another attempt to import it
-       ;; will fail.
-       (setf (gethash truename *module-map*) :in-progress)
-
-       ;; Be careful to restore the state of the module map on exit.
-       (unwind-protect
-
-	    ;; Open the module file and parse it.
-	    (with-open-file (f-stream pathname :direction :input)
-	      (let* ((pai-stream (make-instance 'position-aware-input-stream
-						:stream f-stream
-						:file pathname))
-		     (lexer (make-instance 'sod-lexer :stream pai-stream)))
-		(with-default-error-location (lexer)
-		  (restart-case
-		      (progn
-			(next-char lexer)
-			(next-token lexer)
-			(setf module (parse-module lexer)))
-		    (continue ()
-		      :report "Ignore the import and continue"
-		      nil))))))
-
-	 ;; If we successfully parsed the module, then store it in the table;
-	 ;; otherwise remove it because we might want to try again.  (That
-	 ;; might not work very well, but it could be worth a shot.)
-	 (if module
-	     (setf (gethash truename *module-map*) module)
-	     (remhash truename *module-map*)))
-
-      ;; A module which is being read can't be included again.
-      ((eql module :in-progress)
-       (error "Cyclic module dependency involving module ~A" pathname))
-
-      ;; A module which was successfully read.  Just return it.
-      (t
-       module))))
-
+#+(or)
 (defun parse-module (lexer)
   "Parse a module from the given LEXER.
 
@@ -213,50 +355,6 @@
 	    (next-token lexer)
 	    (go top))
 
-	   ;; module-def : `import' string `;'
-	   ;;
-	   ;; Read another module of definitions from a file.
-	   (:import
-	    (next-token lexer)
-	    (let ((name (require-token lexer :string)))
-	      (when name
-		(find-file lexer
-			   (merge-pathnames name (make-pathname
-						  :type "SOD"
-						  :case :common))
-			   "module"
-			   (lambda (path true)
-			     (handler-case
-				 (let ((module (import-module path
-							    :truename true)))
-				   (when module
-				     (push module deps)))
-			       (file-error (error)
-				 (cerror* "Error reading module ~S: ~A"
-					  path error)))))))
-	    (go semicolon))
-
-	   ;; module-def : `load' string `;'
-	   ;;
-	   ;; Load a Lisp extension from a file.
-	   (:load
-	    (next-token lexer)
-	    (let ((name (require-token lexer :string)))
-	      (when name
-		(find-file lexer
-			   (merge-pathnames name
-					    (make-pathname :type "LISP"
-							   :case :common))
-			   "Lisp file"
-			   (lambda (path true)
-			     (handler-case (load true
-						 :verbose nil
-						 :print nil)
-			       (error (error)
-				 (cerror* "Error loading Lisp file ~S: ~A"
-					  path error)))))))
-	    (go semicolon))
-
 	   ;; module-def : `lisp' sexp
 	   ;;
 	   ;; Process an in-line Lisp form immediately.