An actual running implementation, which makes code that compiles.

[sod] / src / output-proto.lisp

;;; -*-lisp-*-
;;;
;;; Output scheduling protocol
;;;
;;; (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)

;;;--------------------------------------------------------------------------
;;; Sequencing machinery.

(export '(sequencer-item make-sequencer-item sequencer-item-p
	  sequencer-item-name sequencer-item-functions))
(defstruct (sequencer-item
	     (:constructor make-sequencer-item (name &optional functions)))
  "Represents a distinct item to be sequenced by a `sequencer'.

   A `sequencer-item' maintains a list of FUNCTIONS which are invoked when
   the sequencer is invoked."
  (name nil :read-only t)
  (functions nil :type list))

(export '(sequencer sequencer-constraints sequencer-table))
(defclass sequencer ()
  ((constraints :initarg :constraints :initform nil
		:type list :accessor sequencer-constraints)
   (table :initform (make-hash-table :test #'equal)
	  :reader sequencer-table))
  (:documentation
   "A sequencer tracks items and invokes them in the proper order.

   The job of a `sequencer' object is threefold.  Firstly, it collects
   sequencer items and stores them in its table indexed by name.  Secondly,
   it gathers CONSTRAINTS, which impose an ordering on the items.  Thirdly,
   it can be instructed to invoke the items in an order compatible with the
   established constraints."))

(export 'ensure-sequencer-item)
(defgeneric ensure-sequencer-item (sequencer name)
  (:documentation
   "Arrange that SEQUENCER has a sequencer-item called NAME.

   Returns the corresponding SEQUENCER-ITEM object.

   Sequencer item names may may any kind of object which can be compared with
   EQUAL.  In particular, symbols, integers and strings are reasonable
   choices for atomic names, and lists work well for compound names -- so
   it's possible to construct a hierarchy."))

(export 'add-sequencer-constraint)
(defgeneric add-sequencer-constraint (sequencer constraint)
  (:documentation
   "Attach the given CONSTRAINT to an SEQUENCER.

   The CONSTRAINT should be a list of sequencer-item names; see
   `ensure-sequencer-item' for what they look like.  Note that the names
   needn't have been declared in advance; indeed, they needn't be mentioned
   anywhere else at all."))

(export 'add-sequencer-item-function)
(defgeneric add-sequencer-item-function (sequencer name function)
  (:documentation
   "Arranges to call FUNCTION when the item called NAME is traversed.

   More than one function can be associated with a given sequencer item.
   They are called in the same order in which they were added.

   Note that an item must be mentioned in at least one constraint in order to
   be traversed by `invoke-sequencer-items'.  If there are no special
   ordering requirments for a particular item, then the trivial
   constraint (NAME) will suffice."))

(export 'invoke-sequencer-items)
(defgeneric invoke-sequencer-items (sequencer &rest arguments)
  (:documentation
   "Invoke functions attached to the SEQUENCER's items in the right order.

   Each function is invoked in turn with the list of ARGUMENTS.  The return
   values of the functions are discarded."))

;;;--------------------------------------------------------------------------
;;; Output preparation.

(export 'hook-output)
(defgeneric hook-output (object reason sequencer)
  (:documentation
   "Announces the intention to write SEQUENCER, with a particular REASON.

   The SEQUENCER is a `sequencer' instance; the REASON will be a symbol which
   can be matched using an `eql'-specializer.  In response, OBJECT should add
   any constraints and item functions that it wishes, and pass the
   announcement to its sub-objects.  It is not uncommon for an object to pass
   a reason to its sub-objects that is different from the REASON with which
   it was itself invoked.")

  (:method-combination progn)
  (:method progn (object reason sequencer)
	   (declare (ignore object reason sequencer))))

;;;--------------------------------------------------------------------------
;;; Useful syntax.

(defmacro sequence-output
    ((streamvar sequencer) &body clauses)
  "Register output behaviour in a convenient manner.

   The full syntax isn't quite as described:

	sequence-output (STREAMVAR SEQUENCER)
	  { :constraint CONSTRAINT }*
	  CLAUSE*

	STREAMVAR ::= a symbol
	SEQUENCER ::= a sequencer object, evaluated
	CONSTRAINT ::= ( ITEM-NAME* )
	CLAUSE ::= (ITEM-NAME FORM*)
	ITEM-NAME ::= an atom or a list of expressions

   An ITEM-NAME may be a self-evaluating atom (in which case it stands for
   itself, clearly), a symbol (in which case the corresponding variable value
   is used), or a list of forms (in which case the name used is the list of
   the corresponding values).

   The behaviour is as follows.  The CONSTRAINTS, if any, are added to the
   sequencer.  Then, for each CLAUSE, a function is attached to the named
   sequencer item whose behaviour is to bind STREAMVAR to the output stream
   and evaluate the FORMs as a progn."

  (let ((seqvar (gensym "SEQ")))
    (labels ((convert-item-name (name)
	       (if (listp name)
		   (cons 'list name)
		   name))
	     (convert-constraint (constraint)
	       (cons 'list (mapcar #'convert-item-name constraint)))
	     (process-body (clauses)
	       (if (eq (car clauses) :constraint)
		   (cons `(add-sequencer-constraint
			   ,seqvar
			   ,(convert-constraint (cadr clauses)))
			 (process-body (cddr clauses)))
		   (mapcar (lambda (clause)
			     (let ((name (car clause))
				   (body (cdr clause)))
			       `(add-sequencer-item-function
				 ,seqvar
				 ,(convert-item-name name)
				 (lambda (,streamvar)
				   ,@body))))
			   clauses))))
      `(let ((,seqvar ,sequencer))
	 ,@(process-body clauses)))))

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