[sod] / src / proto-module.lisp

;;; -*-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.

   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 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'.

   Evaluation order irregularity: the TRUENAME and LOCATION arguments are
   always evaluated in that order, regardless of their order in the macro
   call site."

  `(build-module ,name
                 (lambda () ,@body)
                 ,@(and truenamep `(:truename ,truename))
                 ,@(and locationp `(:location ,location))))

;;;----- That's all, folks --------------------------------------------------