(cl:in-package #:sod)
;;;--------------------------------------------------------------------------
+;;; Sequencing machinery.
+
+(defclass sequencer-item ()
+ ((name :initarg :name
+ :reader sequencer-item-name)
+ (functions :initarg :functions
+ :initform nil
+ :type list
+ :accessor sequencer-item-functions))
+ (:documentation
+ "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. This class is not intended to be subclassed."))
+
+(defmethod print-object ((item sequencer-item) stream)
+ (print-unreadable-object (item stream :type t)
+ (prin1 (sequencer-item-name item) stream)))
+
+(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.
+
+ 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."))
+
+(defgeneric ensure-sequencer-item (sequencer name)
+ (:documentation
+ "Arrange that SEQUENCER has a sequencer-item called NAME.
+
+ Returns the corresponding SEQUENCER-ITEM object."))
+
+(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."))
+
+(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."))
+
+(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."))
+
+(defmethod ensure-sequencer-item ((sequencer sequencer) name)
+ (with-slots (table) sequencer
+ (or (gethash name table)
+ (setf (gethash name table)
+ (make-instance 'sequencer-item :name name)))))
+
+(defmethod add-sequencer-constraint ((sequencer sequencer) (constraint list))
+ (let ((converted-constraint (mapcar (lambda (name)
+ (ensure-sequencer-item sequencer
+ name))
+ constraint)))
+ (with-slots (constraints) sequencer
+ (pushnew converted-constraint constraints :test #'equal))))
+
+(defmethod add-sequencer-item-function ((sequencer sequencer) name function)
+ (let ((item (ensure-sequencer-item sequencer name)))
+ (pushnew function (sequencer-item-functions item))))
+
+(defmethod invoke-sequencer-items ((sequencer sequencer) &rest arguments)
+ (dolist (item (merge-lists (reverse (sequencer-constraints sequencer))))
+ (dolist (function (reverse (sequencer-item-functions item)))
+ (apply function arguments))))
+
+;;;--------------------------------------------------------------------------
+;;; Output preparation.
+
+(defgeneric add-output-hooks (object reason sequencer)
+ (:documentation
+ "Announces the intention to write SEQUENCER, with a particular REASON.
+
+ The SEQUENCER is an SEQUENCER instance; the REASON will be a symbol which
+ can be matched using an EQL-specializer. In response, OBJECT should add
+ any constrains and item functions that it wishes, and pass the
+ announcement to its sub-objects.")
+ (:method-combination progn)
+ (:method progn (object reason sequencer)
+ nil))
+
+(defvar *seen-announcement*) ;Keep me unbound!
+#+hmm
+(defmethod add-output-hooks :around (object reason sequencer &rest stuff)
+ "Arrange not to invoke any object more than once during a particular
+ announcement."
+ (declare (ignore stuff))
+ (cond ((not (boundp '*seen-announcement*))
+ (let ((*seen-announcement* (make-hash-table)))
+ (setf (gethash object *seen-announcement*) t)
+ (call-next-method)))
+ ((gethash object *seen-announcement*)
+ nil)
+ (t
+ (setf (gethash object *seen-announcement*) t)
+ (call-next-method))))
+
+;;;--------------------------------------------------------------------------
;;; Utilities.
(defun banner (title output &key (blank-line-p t))
(when (module-header-fragments module)
(banner "User code" output)
(dolist (frag (module-header-fragments module))
- (write-fragment frag output)))
+ (princ frag output)))
;; The definitions of the necessary structures.
;;
(when (module-source-fragments module)
(banner "User code" output)
(dolist (frag (module-source-fragments module))
- (write-fragment frag output)))
+ (princ frag output)))
;; The definitions of the necessary tables.
;;
~mdw / sod / blobdiff