(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
(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.
(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.
~mdw / sod / blobdiff