| 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 Sensible 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 'with-module-environment) |
| 61 | (defmacro with-module-environment ((&optional (module '*module*)) &body body) |
| 62 | "Evaluate the BODY with MODULE's variable bindings in scope." |
| 63 | `(call-with-module-environment (lambda () ,@body) ,module)) |
| 64 | |
| 65 | ;;;-------------------------------------------------------------------------- |
| 66 | ;;; The reset switch. |
| 67 | |
| 68 | (defvar *clear-the-decks-alist* nil |
| 69 | "List tracking functions to be called by `clear-the-decks'.") |
| 70 | |
| 71 | (export 'add-clear-the-decks-function) |
| 72 | (defun add-clear-the-decks-function (symbol thunk) |
| 73 | "Add a function to the `clear-the-decks' list. |
| 74 | |
| 75 | If a function tagged by SYMBOL already exists on the list, then that |
| 76 | function is replaced; otherwise a new function is added." |
| 77 | (aif (assoc symbol *clear-the-decks-alist*) |
| 78 | (setf (cdr it) thunk) |
| 79 | (asetf *clear-the-decks-alist* (acons symbol thunk it)))) |
| 80 | |
| 81 | (export 'define-clear-the-decks) |
| 82 | (defmacro define-clear-the-decks (name &body body) |
| 83 | "Add behaviour to `clear-the-decks'. |
| 84 | |
| 85 | When `clear-the-decks' is called, the BODY will be evaluated as a progn. |
| 86 | The relative order of `clear-the-decks' operations is unspecified." |
| 87 | (multiple-value-bind (docs decls body) (parse-body body) |
| 88 | `(add-clear-the-decks-function ',name (lambda () |
| 89 | ,@docs ,@decls |
| 90 | (block ,name ,@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 | During module construction, this is always an instance of `module'. Once |
| 106 | we've finished constructing it, we'll call `change-class' to turn it into |
| 107 | an instance of whatever type is requested in the module's `:module-class' |
| 108 | property.") |
| 109 | |
| 110 | (export 'module-import) |
| 111 | (defgeneric module-import (object) |
| 112 | (:documentation |
| 113 | "Import definitions into the current environment. |
| 114 | |
| 115 | Instructs the OBJECT to import its definitions into the current |
| 116 | environment. Modules pass the request on to their constituents. There's |
| 117 | a default method which does nothing at all. |
| 118 | |
| 119 | It's not usual to modify the current module. Inserting things into the |
| 120 | `*module-type-map*' is a good plan.") |
| 121 | (:method (object) |
| 122 | (declare (ignore object)) |
| 123 | nil)) |
| 124 | |
| 125 | (export 'add-to-module) |
| 126 | (defgeneric add-to-module (module item) |
| 127 | (:documentation |
| 128 | "Add ITEM to the MODULE's list of accumulated items. |
| 129 | |
| 130 | The module items participate in the `module-import' and `hook-output' |
| 131 | protocols.")) |
| 132 | |
| 133 | (export 'finalize-module) |
| 134 | (defgeneric finalize-module (module) |
| 135 | (:documentation |
| 136 | "Finalizes a module, setting everything which needs setting. |
| 137 | |
| 138 | This isn't necessary if you made the module by hand. If you've |
| 139 | constructed it incrementally, then it might be a good plan. In |
| 140 | particular, it will change the class (using `change-class') of the module |
| 141 | according to the class choice set in the module's `:module-class' |
| 142 | property. This has the side effects of calling `shared-initialize', |
| 143 | setting the module's state to `t', and checking for unrecognized |
| 144 | properties. (Therefore subclasses should add a method to |
| 145 | `shared-initialize' taking care of looking at interesting properties, just |
| 146 | to make sure they're ticked off.)")) |
| 147 | |
| 148 | ;;;-------------------------------------------------------------------------- |
| 149 | ;;; Module objects. |
| 150 | |
| 151 | (export '(module module-name module-pset module-items module-dependencies)) |
| 152 | (defclass module () |
| 153 | ((name :initarg :name :type pathname :reader module-name) |
| 154 | (%pset :initarg :pset :initform (make-pset) |
| 155 | :type pset :reader module-pset) |
| 156 | (items :initarg :items :initform nil :type list :accessor module-items) |
| 157 | (dependencies :initarg :dependencies :initform nil |
| 158 | :type list :accessor module-dependencies) |
| 159 | (variables :initarg :variables :type list :accessor module-variables |
| 160 | :initform (mapcar (compose #'cdr #'funcall) |
| 161 | *module-bindings-alist*)) |
| 162 | (state :initarg :state :initform nil :accessor module-state)) |
| 163 | (:documentation |
| 164 | "A module is a container for the definitions made in a source file. |
| 165 | |
| 166 | Modules are the fundamental units of translation. The main job of a |
| 167 | module is to remember which definitions it contains, so that they can be |
| 168 | translated and written to output files. The module contains the following |
| 169 | handy bits of information: |
| 170 | |
| 171 | * A (path) name, which is the filename we used to find it. The default |
| 172 | output filenames are derived from this. (We use the file's truename |
| 173 | as the hash key to prevent multiple inclusion, and that's a different |
| 174 | thing.) |
| 175 | |
| 176 | * A property list containing other useful things. |
| 177 | |
| 178 | * A list of items which the module contains. |
| 179 | |
| 180 | * A list of other modules that this one depends on. |
| 181 | |
| 182 | * A list of module-variable values, in the order in which they're named |
| 183 | in `*module-bindings-alist*'. |
| 184 | |
| 185 | Modules are usually constructed by the `read-module' function, though |
| 186 | there's nothing to stop fancy extensions building modules |
| 187 | programmatically.")) |
| 188 | |
| 189 | (export 'define-module) |
| 190 | (defmacro define-module |
| 191 | ((name &key (truename nil truenamep) (location nil locationp)) |
| 192 | &body body) |
| 193 | "Define and return a new module. |
| 194 | |
| 195 | The module will be called NAME; it will be included in the `*module-map*' |
| 196 | only if it has a TRUENAME (which defaults to the truename of NAME, or nil |
| 197 | if there is no file with that name). The module is populated by |
| 198 | evaluating the BODY in a dynamic environment where `*module*' is bound to |
| 199 | the module under construction, and any other module variables are bound to |
| 200 | appropriate initial values -- see `*module-bindings-alist*' and |
| 201 | `define-module-var'. |
| 202 | |
| 203 | If a module with the same NAME is already known, then it is returned |
| 204 | unchanged: the BODY is not evaluated. |
| 205 | |
| 206 | The LOCATION may be any printable value other than `t' (though |
| 207 | `file-location' objects are most usual) indicating what provoked this |
| 208 | module definition: it gets reported to the user if an import cycle is |
| 209 | detected. This check is made only if a TRUENAME is supplied. |
| 210 | |
| 211 | Evaluation order irregularity: the TRUENAME and LOCATION arguments are |
| 212 | always evaluated in that order, regardless of their order in the macro |
| 213 | call site (which this macro can't detect)." |
| 214 | |
| 215 | `(build-module ,name |
| 216 | (lambda () ,@body) |
| 217 | ,@(and truenamep `(:truename ,truename)) |
| 218 | ,@(and locationp `(:location ,location)))) |
| 219 | |
| 220 | (export 'with-temporary-module) |
| 221 | (defmacro with-temporary-module ((&key) &body body) |
| 222 | "Evaluate BODY within the context of a temporary module." |
| 223 | `(call-with-temporary-module (lambda () ,@body))) |
| 224 | |
| 225 | ;;;----- That's all, folks -------------------------------------------------- |