Find file
Fetching contributors…
Cannot retrieve contributors at this time
332 lines (277 sloc) 12.3 KB
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
Cells -- Automatic Dataflow Managememnt
Copyright (C) 1995, 2006 by Kenneth Tilton
This library is free software; you can redistribute it and/or
modify it under the terms of the Lisp Lesser GNU Public License
(, known as the LLGPL.
This library is distributed WITHOUT ANY WARRANTY; without even
See the Lisp Lesser GNU Public License for more details.
(in-package :cells)
;;; --- model-object ----------------------
(eval-when (:compile-toplevel :load-toplevel :execute)
(export '(md-name fm-parent .parent )))
(defclass model-object ()
((.md-state :initform :nascent :accessor md-state) ; [nil | :nascent | :alive | :doomed]
(.awaken-on-init-p :initform nil :initarg :awaken-on-init-p :accessor awaken-on-init-p)
(.cells :initform nil :accessor cells)
(.cells-flushed :initform nil :accessor cells-flushed
:documentation "cells supplied but un-whenned or optimized-away")
(adopt-ct :initform 0 :accessor adopt-ct)))
(defmethod register? ((self model-object)))
(defmethod md-state ((self symbol))
;;; --- md obj initialization ------------------
(defmethod shared-initialize :after ((self model-object) slotnames
&rest initargs &key fm-parent)
(declare (ignorable initargs slotnames fm-parent))
(setf (md-census-count self) 1) ;; bad idea if we get into reinitializing
; for convenience and transparency of mechanism we allow client code
; to intialize a slot to a cell, but we want the slot to hold the functional
; value, partly for ease of inspection, partly for performance, mostly
; because sometimes we are a slave to other libraries, such as a persistence
; library that does interesting things automatically based on the slot value.
; here we shuttle cells out of the slots and into a per-instance dictionary of cells,
; as well as tell the cells what slot and instance they are mediating.
(when (slot-boundp self '.md-state)
(loop for esd in (class-slots (class-of self))
for sn = (slot-definition-name esd)
for sv = (when (slot-boundp self sn)
(slot-value self sn))
;; do (print (list (type-of self) sn sv (typep sv 'cell)))
when (typep sv 'cell)
do (if (md-slot-cell-type (type-of self) sn)
(md-install-cell self sn sv)
(when *c-debug*
(break "warning: cell ~a offered for non-cellular model/slot ~a/~a" sv sn (type-of self)))))
; queue up for awakening
(if (awaken-on-init-p self)
(md-awaken self)
(with-integrity (:awaken self)
(md-awaken self)))
(defun md-install-cell (self slot-name c &aux (c-isa-cell (typep c 'cell)))
; iff cell, init and move into dictionary
(when c-isa-cell
(count-it :md-install-cell)
(c-model c) self
(c-slot-name c) slot-name
(md-slot-cell self slot-name) c))
; now have the slot really be the slot
(if c-isa-cell
(if (c-unboundp c)
(bd-slot-makunbound self slot-name)
(if self
(setf (slot-value self slot-name)
(when (c-inputp c) (c-value c)))
(setf (symbol-value slot-name)
(when (c-inputp c) (c-value c)))))
;; note that in this else branch "c" is a misnomer since
;; the value is not actually a cell
(if self
(setf (slot-value self slot-name) c)
(setf (symbol-value slot-name) c))))
;;; --- awaken --------
; -- do initial evaluation of all ruled slots
; -- call observers of all slots
(export! md-awake-ct md-awake-ct-ct)
(defun md-awake-ct ()
(defun md-awake-ct-ct ()
(reduce '+ *awake-ct* :key 'cdr))
(defmethod md-awaken :around ((self model-object))
(when (eql :nascent (md-state self))
#+nahh (bif (a (assoc (type-of self) *awake-ct*))
(incf (cdr a))
(push (cons (type-of self) 1) *awake-ct*))
;(trc "awake" (type-of self))
#+chya (push self *awake*)
(md-slot-cell-type 'cgtk::label 'cgtk::container)
(defmethod md-awaken ((self model-object))
; --- debug stuff
(when *stop*
(princ #\.)
(return-from md-awaken))
(trc nil "md-awaken entry" self (md-state self))
(c-assert (eql :nascent (md-state self)))
(count-it :md-awaken)
;(count-it 'mdawaken (type-of self))
; ---
(setf (md-state self) :awakening)
(dolist (esd (class-slots (class-of self)))
(bwhen (sct (md-slot-cell-type (type-of self) (slot-definition-name esd)))
(let* ((slot-name (slot-definition-name esd))
(c (md-slot-cell self slot-name)))
(when *c-debug*
(bwhen (sv (and (slot-boundp self slot-name)
(slot-value self slot-name)))
(when (typep sv 'cell)
(c-break "md-awaken ~a found cell ~a in slot ~a" self sv esd))))
((not c)
;; all slots must hit any change handlers as instances come into existence to get
;; models fully connected to the outside world they are controlling. that
;; happens in awaken-cell for slots in fact mediated by cells, but as an
;; optimization we allow raw literal values to be specified for a slot, in
;; which case heroic measures are needed to get the slot to the change handler
;; next is an indirect and brittle way to determine that a slot has already been output,
;; but I think anything better creates a run-time hit.
;; until 2007-10 (unless (cdr (assoc slot-name (cells-flushed self))) ;; make sure not flushed
;; but first I worried about it being slow keeping the flushed list /and/ searching, then
;; I wondered why a flushed cell should not be observed, constant cells are. So Just Observe It
(let ((flushed (md-slot-cell-flushed self slot-name)))
(when (or (null flushed) ;; constant, ie, never any cell provided for this slot
(> *data-pulse-id* (c-pulse-observed flushed))) ;; unfrickinlikely
(when flushed
(setf (c-pulse-observed flushed) *data-pulse-id*)) ;; probably unnecessary
(slot-value-observe slot-name self (bd-slot-value self slot-name) nil nil flushed))))
((find (c-lazy c) '(:until-asked :always t))
(trc nil "md-awaken deferring c-awaken since lazy"
self esd))
((eq :nascent (c-state c))
(c-assert (c-model c) () "c-awaken sees uninstalled cell" c)
(c-assert (eq :nascent (c-state c)))
(trc nil "c-awaken > awakening" c)
(count-it :c-awaken)
(setf (c-state c) :awake)
(awaken-cell c))))))
(setf (md-state self) :awake)
;;; --- utilities, accessors, etc --------------------------------------
(defmethod c-slot-value ((self model-object) slot)
(slot-value self slot))
(defmethod md-slot-cell (self slot-name)
(if self
(cdr (assoc slot-name (cells self)))
(get slot-name 'cell)))
(defmethod md-slot-cell-flushed (self slot-name)
(if self
(cdr (assoc slot-name (cells-flushed self)))
(get slot-name 'cell)))
(get 'cgtk::label :cell-types)
(defun md-slot-cell-type (class-name slot-name)
(assert class-name)
(if (eq class-name 'null)
(get slot-name :cell-type)
(bif (entry (assoc slot-name (get class-name :cell-types)))
(cdr entry)
(dolist (super (class-precedence-list (find-class class-name))
(setf (md-slot-cell-type class-name slot-name) nil))
(bwhen (entry (assoc slot-name (get (c-class-name super) :cell-types)))
(return-from md-slot-cell-type
(setf (md-slot-cell-type class-name slot-name) (cdr entry))))))))
(defun (setf md-slot-cell-type) (new-type class-name slot-name)
(assert class-name)
(if (eq class-name 'null) ;; not def-c-variable
(setf (get slot-name :cell-type) new-type)
(let ((entry (assoc slot-name (get class-name :cell-types))))
(if entry
(setf (cdr entry) new-type)
(loop for c in (class-direct-subclasses (find-class class-name))
do (setf (md-slot-cell-type (class-name c) slot-name) new-type)))
(cdar (push (cons slot-name new-type) (get class-name :cell-types)))))))
(md-slot-owning? 'm-index '.value)
(defun md-slot-owning? (class-name slot-name)
(assert class-name)
(if (eq class-name 'null)
(get slot-name :owning) ;; might be wrong -- support for specials is unfinished w.i.p.
(bif (entry (assoc slot-name (get class-name :direct-ownings)))
(cdr entry)
(bif (entry (assoc slot-name (get class-name :indirect-ownings)))
(cdr entry)
(push (cons slot-name
(cdr (loop for super in (cdr (class-precedence-list (find-class class-name)))
thereis (assoc slot-name (get (c-class-name super) :direct-ownings)))))
(get class-name :indirect-ownings)))))))
(defun (setf md-slot-owning-direct?) (value class-name slot-name)
(assert class-name)
(if (eq class-name 'null) ;; global variables
(setf (get slot-name :owning) value)
(bif (entry (assoc slot-name (get class-name :direct-ownings)))
(setf (cdr entry) value)
(push (cons slot-name value) (get class-name :direct-ownings)))
; -- propagate to derivatives ...
(labels ((clear-subclass-ownings (c)
(loop for sub-c in (class-direct-subclasses c)
for sub-c-name = (c-class-name sub-c)
do (setf (get sub-c-name :indirect-ownings)
(delete slot-name (get sub-c-name :indirect-ownings) :key 'car)) ;; forces redecide
(setf (get sub-c-name :model-ownings) nil) ;; too much forcing full recalc like this?
(clear-subclass-ownings sub-c))))
(clear-subclass-ownings (find-class class-name))))))
(defun md-owning-slots (self &aux (st (type-of self)))
(or (get st :model-ownings)
(setf (get st :model-ownings)
(loop for s in (class-slots (class-of self))
for sn = (slot-definition-name s)
when (and (md-slot-cell-type st sn)
(md-slot-owning? st sn))
collect sn))))
(md-slot-owning? 'cells::family '.kids)
(defun md-slot-value-store (self slot-name new-value)
(trc nil "md-slot-value-store" self slot-name new-value)
(if self
(setf (slot-value self slot-name) new-value)
(setf (symbol-value slot-name) new-value)))
;----------------- navigation: slot <> initarg <> esd <> cell -----------------
(defmethod c-class-name ((class pcl::standard-class))
(pcl::class-name class))
(defmethod c-class-name (other) (declare (ignore other)) nil)
;; why not #-cmu?
(defmethod c-class-name ((class standard-class))
(class-name class))
(defmethod cell-when (other) (declare (ignorable other)) nil)
(defun (setf md-slot-cell) (new-cell self slot-name)
(if self ;; not on def-c-variables
(bif (entry (assoc slot-name (cells self)))
; this next branch guessed it would only occur during kid-slotting,
; before any dependency-ing could have happened, but a math-editor
; is silently switching between implied-multiplication and mixed numbers
; while they type and it
(trc nil "second cell same slot:" slot-name :old entry :new new-cell)
(let ((old (cdr entry))) ;; s/b being supplanted by kid-slotter
(declare (ignorable old))
(c-assert (null (c-callers old)))
(when (typep entry 'c-dependent)
(c-assert (null (cd-useds old))))
(trc nil "replacing in model .cells" old new-cell self)
(rplacd entry new-cell)))
(trc nil "adding to model .cells" new-cell self)
(push (cons slot-name new-cell)
(cells self))))
(setf (get slot-name 'cell) new-cell)))
(defun md-map-cells (self type celldo)
(map type (lambda (cell-entry)
(bwhen (cell (cdr cell-entry))
(unless (listp cell)
(funcall celldo cell))))
(cells self)))