src/method-impl.lisp: Initialize `suppliedp' flags properly.

[sod] / src / output-impl.lisp

;;; -*-lisp-*-
;;;
;;; Output scheduling protocol implementation
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Sensible 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.

(defmethod print-object ((item sequencer-item) stream)
  (print-unreadable-object (item stream :type t)
    (prin1 (sequencer-item-name item) stream)))

(defmethod shared-initialize ((sequencer sequencer) slot-names
			      &key (constraints nil constraintsp))
  (call-next-method)
  (when constraintsp
    (setf (slot-value sequencer 'constraints)
	  (mapcar (lambda (constraint)
		    (mapcar (lambda (name)
			      (ensure-sequencer-item sequencer name))
			    constraint))
		  (reverse constraints))))
  sequencer)

(defmethod ensure-sequencer-item ((sequencer sequencer) name)
  (with-slots (table) sequencer
    (or (gethash name table)
	(setf (gethash name table) (make-sequencer-item 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))))

(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)
  #+debug
  (format *debug-io* "~@<;; ~@;Constraints: ~_~
		      ~<~@{~<  * ~;~@{~S~^, ~:_~}~:>~:@_~}~:>~:>"
	  (mapcar (lambda (constraint)
		    (mapcar #'sequencer-item-name constraint))
		  (sequencer-constraints sequencer)))
  (let ((seen (make-hash-table)))
    (dolist (item (merge-lists (reverse (sequencer-constraints sequencer))))
      (setf (gethash item seen) t)
      (dolist (function (reverse (sequencer-item-functions item)))
	(apply function arguments)))
    (maphash (lambda (name item)
	       (unless (gethash item seen)
		 (warn "Unused output item ~S" name)))
	     (sequencer-table sequencer))))

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