(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.
: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)))
;;;--------------------------------------------------------------------------
;;; 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*"
(finalize-sod-class class)
(add-to-module *module* class)))
-;;;--------------------------------------------------------------------------
-;;; Modules.
-
-#+(or)
-(defun parse-module (lexer)
- "Parse a module from the given LEXER.
-
- The newly constructed module is returned. This is the top-level parsing
- function."
-
- (let ((hfrags nil)
- (cfrags nil)
- (classes nil)
- (plist nil)
- (deps nil))
-
- (labels ((fragment (func)
- (next-token lexer)
- (when (require-token lexer #\{ :consumep nil)
- (let ((frag (scan-c-fragment lexer '(#\}))))
- (next-token lexer)
- (require-token lexer #\})
- (funcall func frag)))))
-
- (tagbody
-
- top
- ;; module : empty | module-def module
- ;;
- ;; Just read module-defs until we reach the end of the file.
- (case (token-type lexer)
-
- (:eof
- (go done))
- (#\;
- (next-token lexer)
- (go top))
-
- ;; module-def : `lisp' sexp
- ;;
- ;; Process an in-line Lisp form immediately.
- (:lisp
-
- (next-token lexer)
- (go top))
-
- ;; module-def : `typename' ids `;'
- ;; ids : id | ids `,' id
- ;;
- ;; Add ids as registered type names. We don't need to know what
- ;; they mean at this level.
- (:typename
- (next-token lexer)
- (loop
- (let ((id (require-token lexer :id)))
- (cond ((null id)
- (return))
- ((gethash id *type-map*)
- (cerror* "Type ~A is already defined" id))
- (t
- (setf (gethash id *type-map*)
- (make-instance 'simple-c-type :name id))))
- (unless (eql (token-type lexer) #\,)
- (return))
- (next-token lexer)))
- (go semicolon))
-
- ;; module-def : `source' `{' c-stuff `}'
- ;; module-def : `header' `{' c-stuff `}'
- (:source
- (fragment (lambda (frag) (push frag cfrags)))
- (go top))
- (:header
- (fragment (lambda (frag) (push frag hfrags)))
- (go top))
-
- ;; Anything else is an error.
- (t
- (cerror* "Unexpected token ~A ignored" (format-token lexer))
- (next-token lexer)
- (go top)))
-
- semicolon
- ;; Scan a terminating semicolon.
- (require-token lexer #\;)
- (go top)
-
- done)
-
- ;; Assemble the module and we're done.
- (make-instance 'module
- :name (stream-pathname (lexer-stream lexer))
- :plist plist
- :classes classes
- :header-fragments hfrags
- :source-fragments cfrags
- :dependencies deps))))
-
;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff