(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 ((null module))
+ ((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 parsing protocol.
+
+(defgeneric parse-module-declaration (tag lexer pset)
+ (:method (tag lexer pset)
+ (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."
+
+ (loop
+ (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))
+ (: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))
+ (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))
+
+(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.
(defparameter *module-dirs* nil
(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))))))
-;;;--------------------------------------------------------------------------
-;;; 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.
+(defmethod parse-module-declaration ((tag (eql :import)) lexer pset)
+ "module-decl ::= `import' string `;'"
+ (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)
+ "module-decl ::= `load' string `;'"
+ (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 #\;))))
- * 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.
+;;;--------------------------------------------------------------------------
+;;; Lisp escapes.
- 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."
+(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 #\;))
- (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)
+;;;--------------------------------------------------------------------------
+;;; 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)
- (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))))
+ (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.
+
+#+(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.
(: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))
~mdw / sod / blobdiff