chiark - git - mdw - sod/blob - src/proto-module.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Module protocol definition
   4 ;;;
   5 ;;; (c) 2009 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This file is part of the Sensble Object Design, an object system for C.
  11 ;;;
  12 ;;; SOD is free software; you can redistribute it and/or modify
  13 ;;; it under the terms of the GNU General Public License as published by
  14 ;;; the Free Software Foundation; either version 2 of the License, or
  15 ;;; (at your option) any later version.
  16 ;;;
  17 ;;; SOD is distributed in the hope that it will be useful,
  18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;;; GNU General Public License for more details.
  21 ;;;
  22 ;;; You should have received a copy of the GNU General Public License
  23 ;;; along with SOD; if not, write to the Free Software Foundation,
  24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  25
  26 (cl:in-package #:sod)
  27
  28 ;;;--------------------------------------------------------------------------
  29 ;;; Module environment.
  30
  31 (defvar *module-bindings-alist* nil
  32   "An alist of (SYMBOL . THUNK) pairs.
  33
  34    During module construction, each SYMBOL is special-bound to the value
  35    returned by the corresponding THUNK.")
  36
  37 (export 'add-module-binding)
  38 (defun add-module-binding (symbol thunk)
  39   "Add a new module variable binding.
  40
  41    During module construction, SYMBOL will be special-bound to the value
  42    returned by THUNK.  If you can, use `define-module-var' instead."
  43   (aif (assoc symbol *module-bindings-alist*)
  44        (setf (cdr it) thunk)
  45        (asetf *module-bindings-alist* (acons symbol thunk it))))
  46
  47 (export 'define-module-var)
  48 (defmacro define-module-var (name value-form &optional documentation)
  49   "Add a new module variable binding.
  50
  51    During module construction, NAME will be special-bound to the value of
  52    VALUE-FORM.  The NAME is proclaimed special, but is initially left
  53    unbound."
  54   `(progn
  55      (defvar ,name)
  56      ,@(and documentation
  57             `((setf (documentation ',name 'variable) ,documentation)))
  58      (add-module-binding ',name (lambda () ,value-form))))
  59
  60 (export 'call-with-module-environment)
  61 (defun call-with-module-environment (thunk)
  62   "Invoke THUNK with a new collection of bindings for the module variables."
  63   (progv
  64       (mapcar #'car *module-bindings-alist*)
  65       (mapcar (compose #'cdr #'funcall) *module-bindings-alist*)
  66     (funcall thunk)))
  67
  68 ;;;--------------------------------------------------------------------------
  69 ;;; The reset switch.
  70
  71 (defvar *clear-the-decks-alist* nil
  72   "List tracking functions to be called by `clear-the-decks'.")
  73
  74 (export 'add-clear-the-decks-function)
  75 (defun add-clear-the-decks-function (symbol thunk)
  76   "Add a function to the `clear-the-decks' list.
  77
  78    If a function tagged by SYMBOL already exists on the list, then that
  79    function is replaced; otherwise a new function is added."
  80   (aif (assoc symbol *clear-the-decks-alist*)
  81        (setf (cdr it) thunk)
  82        (asetf *clear-the-decks-alist* (acons symbol thunk it))))
  83
  84 (export 'define-clear-the-decks)
  85 (defmacro define-clear-the-decks (name &body body)
  86   "Add behaviour to `clear-the-decks'.
  87
  88    When `clear-the-decks' is called, the BODY will be evaluated as a progn.
  89    The relative order of `clear-the-decks' operations is unspecified."
  90   `(add-clear-the-decks-function ',name (lambda () ,@body)))
  91
  92 (export 'clear-the-decks)
  93 (defun clear-the-decks ()
  94   "Invoke a sequence of functions to reset the world."
  95   (dolist (item *clear-the-decks-alist*)
  96     (funcall (cdr item))))
  97
  98 ;;;--------------------------------------------------------------------------
  99 ;;; Module construction protocol.
 100
 101 (export '*module*)
 102 (defparameter *module* nil
 103   "The current module under construction.
 104
 105    This is always an instance of MODULE.  Once we've finished constructing
 106    it, we'll call `change-class' to turn it into an instance of whatever type
 107    is requested in the module's `:lisp-class' property.")
 108
 109 (export 'module-import)
 110 (defgeneric module-import (object)
 111   (:documentation
 112    "Import definitions into the current environment.
 113
 114    Instructs the OBJECT to import its definitions into the current
 115    environment.  Modules pass the request on to their constituents.  There's
 116    a default method which does nothing at all.
 117
 118    It's not usual to modify the current module.  Inserting things into the
 119    `*module-type-map*' is a good plan.")
 120   (:method (object) nil))
 121
 122 (export 'add-to-module)
 123 (defgeneric add-to-module (module item)
 124   (:documentation
 125    "Add ITEM to the MODULE's list of accumulated items.
 126
 127    The module items participate in the `module-import' and `add-output-hooks'
 128    protocols."))
 129
 130 (export 'finalize-module)
 131 (defgeneric finalize-module (module)
 132   (:documentation
 133    "Finalizes a module, setting everything which needs setting.
 134
 135    This isn't necessary if you made the module by hand.  If you've
 136    constructed it incrementally, then it might be a good plan.  In
 137    particular, it will change the class (using `change-class') of the module
 138    according to the class choice set in the module's `:lisp-class' property.
 139    This has the side effects of calling `shared-initialize', setting the
 140    module's state to T, and checking for unrecognized properties.  (Therefore
 141    subclasses should add a method to `shared-initialize' taking care of
 142    looking at interesting properties, just to make sure they're ticked
 143    off.)"))
 144
 145 ;;;--------------------------------------------------------------------------
 146 ;;; Module objects.
 147
 148 (export '(module module-name module-pset module-items module-dependencies))
 149 (defclass module ()
 150   ((name :initarg :name :type pathname :reader module-name)
 151    (pset :initarg :pset :initform (make-pset) :type pset :reader module-pset)
 152    (items :initarg :items :initform nil :type list :accessor module-items)
 153    (dependencies :initarg :dependencies :initform nil
 154                  :type list :accessor module-dependencies)
 155    (state :initarg :state :initform nil :accessor module-state))
 156   (:documentation
 157    "A module is a container for the definitions made in a source file.
 158
 159    Modules are the fundamental units of translation.  The main job of a
 160    module is to remember which definitions it contains, so that they can be
 161    translated and written to output files.  The module contains the following
 162    handy bits of information:
 163
 164      * A (path) name, which is the filename we used to find it.  The default
 165        output filenames are derived from this.  (We use the file's truename
 166        as the hash key to prevent multiple inclusion, and that's a different
 167        thing.)
 168
 169      * A property list containing other useful things.
 170
 171      * A list of items which the module contains.
 172
 173      * A list of other modules that this one depends on.
 174
 175    Modules are usually constructed by the `read-module' function, though
 176    there's nothing to stop fancy extensions building modules
 177    programmatically."))
 178
 179 (export 'define-module)
 180 (defmacro define-module
 181     ((name &key (truename nil truenamep) (location nil locationp))
 182      &body body)
 183   "Define a new module.
 184
 185    The module will be called NAME; it will be included in the *module-map*
 186    only if it has a TRUENAME (which defaults to the truename of NAME, or nil
 187    if there is no file with that name).  The module is populated by
 188    evaluating the BODY in a dynamic environment where *module* is bound to
 189    the module under construction, and any other module variables are bound to
 190    appropriate initial values -- see `*module-bindings-alist*' and
 191    `define-module-var'.
 192
 193    Evaluation order irregularity: the TRUENAME and LOCATION arguments are
 194    always evaluated in that order, regardless of their order in the macro
 195    call site."
 196
 197   `(build-module ,name
 198                  (lambda () ,@body)
 199                  ,@(and truenamep `(:truename ,truename))
 200                  ,@(and locationp `(:location ,location))))
 201
 202 ;;;----- That's all, folks --------------------------------------------------