[sod] / pre-reorg / output.lisp

;;; -*-lisp-*-
;;;
;;; Output driver for SOD translator
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Simple Object Definition system.
;;;
;;; 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.

(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."))

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

(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))))

;;;--------------------------------------------------------------------------
;;; Utility macro.

;;;----- That's all, folks --------------------------------------------------
Commit	Line	Data
dea4d055 MW	1	;;; --lisp--
	2	;;;
	3	;;; Output driver for SOD translator
	4	;;;
	5	;;; (c) 2009 Straylight/Edgeware
	6	;;;
	7
	8	;;;----- Licensing notice ---------------------------------------------------
	9	;;;
	10	;;; This file is part of the Simple Object Definition system.
	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	;;; Sequencing machinery.
	30
	31	(defclass sequencer-item ()
	32	((name :initarg :name :reader sequencer-item-name)
	33	(functions :initarg :functions :initform nil
	34	:type list :accessor sequencer-item-functions))
	35	(:documentation
	36	"Represents a distinct item to be sequenced by a SEQUENCER.
	37
	38	A SEQUENCER-ITEM maintains a list of FUNCTIONS which are invoked when the
	39	sequencer is invoked. This class is not intended to be subclassed."))
	40
	41	;;;--------------------------------------------------------------------------
	42	;;; Output preparation.
	43
	44	(defvar seen-announcement) ;Keep me unbound!
	45	#+hmm
	46	(defmethod add-output-hooks :around (object reason sequencer &rest stuff)
	47	"Arrange not to invoke any object more than once during a particular
	48	announcement."
	49	(declare (ignore stuff))
	50	(cond ((not (boundp 'seen-announcement))
	51	(let ((seen-announcement (make-hash-table)))
	52	(setf (gethash object seen-announcement) t)
	53	(call-next-method)))
	54	((gethash object seen-announcement)
	55	nil)
	56	(t
	57	(setf (gethash object seen-announcement) t)
	58	(call-next-method))))
	59
	60	;;;--------------------------------------------------------------------------
	61	;;; Utility macro.
	62
	63	;;;----- That's all, folks --------------------------------------------------