--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Module protocol definition
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; SOD is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Module environment.
+
+(defvar *module-bindings-alist* nil
+ "An alist of (SYMBOL . THUNK) pairs.
+
+ During module construction, each SYMBOL is special-bound to the value
+ returned by the corresponding THUNK.")
+
+(export 'add-module-binding)
+(defun add-module-binding (symbol thunk)
+ "Add a new module variable binding.
+
+ During module construction, SYMBOL will be special-bound to the value
+ returned by THUNK. If you can, use `define-module-var' instead."
+ (aif (assoc symbol *module-bindings-alist*)
+ (setf (cdr it) thunk)
+ (asetf *module-bindings-alist* (acons symbol thunk it))))
+
+(export 'define-module-var)
+(defmacro define-module-var (name value-form &optional documentation)
+ "Add a new module variable binding.
+
+ During module construction, NAME will be special-bound to the value of
+ VALUE-FORM. The NAME is proclaimed special, but is initially left
+ unbound."
+ `(progn
+ (defvar ,name)
+ ,@(and documentation
+ `((setf (documentation ',name 'variable) ,documentation)))
+ (add-module-binding ',name (lambda () ,value-form))))
+
+(export 'call-with-module-environment)
+(defun call-with-module-environment (thunk)
+ "Invoke THUNK with a new collection of bindings for the module variables."
+ (progv
+ (mapcar #'car *module-bindings-alist*)
+ (mapcar (compose #'cdr #'funcall) *module-bindings-alist*)
+ (funcall thunk)))
+
+;;;--------------------------------------------------------------------------
+;;; The reset switch.
+
+(defvar *clear-the-decks-alist* nil
+ "List tracking functions to be called by `clear-the-decks'.")
+
+(export 'add-clear-the-decks-function)
+(defun add-clear-the-decks-function (symbol thunk)
+ "Add a function to the `clear-the-decks' list.
+
+ If a function tagged by SYMBOL already exists on the list, then that
+ function is replaced; otherwise a new function is added."
+ (aif (assoc symbol *clear-the-decks-alist*)
+ (setf (cdr it) thunk)
+ (asetf *clear-the-decks-alist* (acons symbol thunk it))))
+
+(export 'define-clear-the-decks)
+(defmacro define-clear-the-decks (name &body body)
+ "Add behaviour to `clear-the-decks'.
+
+ When `clear-the-decks' is called, the BODY will be evaluated as a progn.
+ The relative order of `clear-the-decks' operations is unspecified."
+ `(add-clear-the-decks-function ',name (lambda () ,@body)))
+
+(export 'clear-the-decks)
+(defun clear-the-decks ()
+ "Invoke a sequence of functions to reset the world."
+ (dolist (item *clear-the-decks-alist*)
+ (funcall (cdr item))))
+
+;;;--------------------------------------------------------------------------
+;;; Module construction protocol.
+
+(export '*module*)
+(defparameter *module* nil
+ "The current module under construction.
+
+ During module 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.")
+
+(export 'module-import)
+(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
+ `*module-type-map*' is a good plan.")
+ (:method (object) nil))
+
+(export 'add-to-module)
+(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."))
+
+(export 'finalize-module)
+(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' taking care of looking at interesting properties, just
+ to make sure they're ticked off.)"))
+
+;;;--------------------------------------------------------------------------
+;;; Module objects.
+
+(export '(module module-name module-pset module-items module-dependencies))
+(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 items which the module contains.
+
+ * A list of other modules that this one depends on.
+
+ Modules are usually constructed by the `read-module' function, though
+ there's nothing to stop fancy extensions building modules
+ programmatically."))
+
+(export 'define-module)
+(defmacro define-module
+ ((name &key (truename nil truenamep) (location nil locationp))
+ &body body)
+ "Define and return a new module.
+
+ The module will be called NAME; it will be included in the `*module-map*'
+ only if it has a TRUENAME (which defaults to the truename of NAME, or nil
+ if there is no file with that name). The module is populated by
+ evaluating the BODY in a dynamic environment where `*module*' is bound to
+ the module under construction, and any other module variables are bound to
+ appropriate initial values -- see `*module-bindings-alist*' and
+ `define-module-var'.
+
+ If a module with the same NAME is already known, then it is returned
+ unchanged: the BODY is not evaluated.
+
+ The LOCATION may be any printable value other than `t' (though
+ `file-location' objects are most usual) indicating what provoked this
+ module definition: it gets reported to the user if an import cycle is
+ detected. This check is made only if a TRUENAME is supplied.
+
+ Evaluation order irregularity: the TRUENAME and LOCATION arguments are
+ always evaluated in that order, regardless of their order in the macro
+ call site (which this macro can't detect)."
+
+ `(build-module ,name
+ (lambda () ,@body)
+ ,@(and truenamep `(:truename ,truename))
+ ,@(and locationp `(:location ,location))))
+
+;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff