+;;; 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))
+
+;;;--------------------------------------------------------------------------