[cells-cvs] CVS update: cells/build-sys.lisp cells/build.lisp cells/calc-n-set.lisp cells/cell-types.lisp cells/cells.asd cells/cells.lisp cells/dataflow-management.lisp cells/debug.lisp cells/defmodel.lisp cells/detritus.lisp cells/family-values.lisp cells/family.lisp cells/flow-control.lisp cells/fm-utilities.lisp cells/initialize.lisp cells/link.lisp cells/md-slot-value.lisp cells/md-utilities.lisp cells/model-object.lisp cells/optimization.lisp cells/propagate.lisp cells/qells.lisp cells/qrock.lisp cells/slot-utilities.lisp cells/strings.lisp cells/strudel-object.lisp cells/synapse.lisp cells/buildold.lisp cells/cells-read-me.txt cells/datetime.lisp
Kenny Tilton
ktilton at common-lisp.net
Tue Dec 16 15:03:02 UTC 2003
Update of /project/cells/cvsroot/cells
In directory common-lisp.net:/tmp/cvs-serv6620
Modified Files:
build.lisp calc-n-set.lisp cell-types.lisp cells.asd
cells.lisp dataflow-management.lisp debug.lisp defmodel.lisp
detritus.lisp family-values.lisp family.lisp flow-control.lisp
fm-utilities.lisp initialize.lisp link.lisp md-slot-value.lisp
md-utilities.lisp model-object.lisp optimization.lisp
propagate.lisp qells.lisp qrock.lisp slot-utilities.lisp
strings.lisp strudel-object.lisp synapse.lisp
Added Files:
build-sys.lisp
Removed Files:
buildold.lisp cells-read-me.txt datetime.lisp
Log Message:
Preparing for first CVS of Cello
Date: Tue Dec 16 10:02:59 2003
Author: ktilton
Index: cells/build.lisp
diff -u cells/build.lisp:1.1.1.1 cells/build.lisp:1.2
--- cells/build.lisp:1.1.1.1 Sat Nov 8 18:43:38 2003
+++ cells/build.lisp Tue Dec 16 10:02:58 2003
@@ -1,102 +1,71 @@
-;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-user; -*-
-;;;
-;;; Copyright © 1995,2003 by Kenneth William Tilton.
-;;;
-;;; Permission is hereby granted, free of charge, to any person obtaining a copy
-;;; of this software and associated documentation files (the "Software"), to deal
-;;; in the Software without restriction, including without limitation the rights
-;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-;;; copies of the Software, and to permit persons to whom the Software is furnished
-;;; to do so, subject to the following conditions:
-;;;
-;;; The above copyright notice and this permission notice shall be included in
-;;; all copies or substantial portions of the Software.
-;;;
-;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
-;;; IN THE SOFTWARE.
-
-(defpackage #:cells-build-package
- (:use #:cl))
-(in-package :cl-user) ;;#:cells-build-package)
-
-;;; ***********************************************************************
-;;; Begin configuration section
-;;;
-;;; Step 1
-;;; ------
-;;; Edit the definition of *CELLS-SOURCE-DIRECTORY* so the build script
-;;; knows where to find its source. For example:
-;;;
-;;; Unix:
-;;; (defvar *cells-source-directory* #p"/usr/local/src/cells/")
-;;;
-;;; Windows:
-;;;
-;;;(defparameter *cells-source-directory*
-;;; (make-pathname #+lispworks :host #-lispworks :device "C"
-;;; :directory "/dev/cells"))
-
-;;; Validation of *cells-source-directory*
-;;;
-(unless (boundp '*cells-source-directory*)
- (error "*CELLS-SOURCE-DIRECTORY* not supplied, please edit build.lisp to specify the location of the source."))
-
-(unless (probe-file (merge-pathnames "cells.asd" *cells-source-directory*))
- (error "cells.asd not found in:~& *CELLS-SOURCE-DIRECTORY* => ~a"
- *cells-source-directory*))
-
-;;; Step 2
-;;; ------
-;;; Help the build script find ASDF if not already loaded
-#-asdf
-(load (merge-pathnames (make-pathname :name "asdf" :type "lisp")
- *cells-source-directory*))
-
-;;; Step 3
-;;; ------
-;;; Decide if you want to run the Cells regression test suite [optional]
-(defparameter *test-cells* t)
-
-;;; Yer done
-;;;
-;;; End configuration section
-;;; ***********************************************************************
-
-
-(defparameter *cells-test-directory*
- (merge-pathnames (make-pathname :directory '(:relative "cells-test"))
- *cells-source-directory*))
-
-;;;
-;;; Implementation-specific weirdness goes here
-;;;
-
-(let (;; Let's assume this is fixed in CMUCL 19a, and fix it later if need be.
- #+cmu18
- (ext:*derive-function-types* nil)
-
- #+lispworks
- (hcl::*handle-existing-defpackage* (list :add))
- )
-
-;;;
-;;; Now, build the system
-;;;
-
- (push *cells-source-directory* asdf:*central-registry*)
- (asdf:operate 'asdf:load-op :cells)
-
- (when *test-cells*
- (push *cells-test-directory* asdf:*central-registry*)
- (asdf:operate 'asdf:load-op :cells-test)
- (format t "~&~%Warning on refined c-echo-slot-name is expected because")
- (format t "~&cells-test is loaded. To run the test suite, evaluate:")
- (format t "~&~% (cells::cv-test)")
- (format t "~&~%and simply confirm it runs to completion.")))
-
-(delete-package '#:cells-build-package)
\ No newline at end of file
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-user; -*-
+
+(in-package :cl-user)
+
+;;; ***********************************************************************
+;;; Begin configuration section
+;;;
+;;; Before building Cells, review and customize the following settings:
+;;;
+(let (
+ ;; Step 1
+ ;; ------
+ ;; The path to ASDF. This is only necessary if it's not already loaded.
+ ;;
+ ;; Examples:
+ ;; Unix: (asdf-path (pathname "/usr/local/src/asdf.lisp"))
+ ;; Windows: (asdf-path (pathname "C:\\dev\\asdf.lisp"))
+ ;; Windows: (asdf-path (make-pathname :directory '(:absolute "dev")
+ ;; :name "asdf" :type "lisp"))
+ (asdf-path nil)
+
+ ;; Step 2
+ ;; ------
+ ;; The path to the Cells source directory.
+ ;;
+ ;; Examples:
+ ;; Unix: (cells-path (pathname "/usr/local/src/cells/"))
+ ;; Windows: (cells-path (pathname "C:\\dev\\cells\\"))
+ ;; Windows: (cells-path (make-pathname
+ ;; :directory '(:absolute "dev" "cells")
+ ;; #+lispworks :host #-lispworks :device
+ ;; "C"))
+ (cells-path nil)
+
+ ;; Step 3
+ ;; ------
+ ;; Decide if you want to load and run the regression test suite.
+ ;; If you want to validate the system or explore the test suite,
+ ;; some of which is heavily annotated, set TESTP to T
+ (testp t)
+ )
+
+;;; Yer done
+;;;
+;;; End configuration section
+;;; ***********************************************************************
+
+
+ ;; Ensure ASDF is loaded
+ #-asdf
+ (progn (assert (not (null asdf-path))
+ (asdf-path)
+ "ASDF is not loaded, and ASDF-PATH was not supplied. Please edit build.lisp")
+ (load asdf-path))
+
+ ;; Build Cells.
+ (load (merge-pathnames "build-sys.lisp" cells-path))
+ (funcall (intern "BUILD-SYS" "CELLS-BUILD-PACKAGE")
+ :force t :source-directory cells-path)
+
+ ;; Load and run the test suite, if requested.
+ (when testp
+ (funcall (intern "BUILD-SYS" "CELLS-BUILD-PACKAGE")
+ :force t
+ :source-directory (merge-pathnames
+ (make-pathname :directory '(:wild "cells-test"))
+ cells-path))
+ (funcall (intern "CV-TEST" "CELLS")))
+
+ ;; Remove build package
+ (delete-package "CELLS-BUILD-PACKAGE"))
Index: cells/calc-n-set.lisp
diff -u cells/calc-n-set.lisp:1.1.1.1 cells/calc-n-set.lisp:1.2
--- cells/calc-n-set.lisp:1.1.1.1 Sat Nov 8 18:43:48 2003
+++ cells/calc-n-set.lisp Tue Dec 16 10:02:58 2003
@@ -1,108 +1,103 @@
-;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
-;;;
-;;; Copyright © 1995,2003 by Kenneth William Tilton.
-;;;
-;;; Permission is hereby granted, free of charge, to any person obtaining a copy
-;;; of this software and associated documentation files (the "Software"), to deal
-;;; in the Software without restriction, including without limitation the rights
-;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-;;; copies of the Software, and to permit persons to whom the Software is furnished
-;;; to do so, subject to the following conditions:
-;;;
-;;; The above copyright notice and this permission notice shall be included in
-;;; all copies or substantial portions of the Software.
-;;;
-;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
-;;; IN THE SOFTWARE.
-
-(in-package :cells)
-
-;____________________________ cell calculate and set ___________________
-;
-
-(defun c-calculate-and-set (c)
- (when *stop*
- (princ #\.)
- (return-from c-calculate-and-set))
-
- (assert (not (cmdead c)))
-
- (when (find c *c-calculators*) ;; circularity
- (if (unst-cyclic-p c)
- (progn
- (trc "md-slot-value cyclic defaulting" c (unst-cyclic-value c))
- (return-from c-calculate-and-set (unst-cyclic-value c)))
- (progn
- (setf *stop* t)
- (trc "md-slot-value breaking on circularity" c *c-calculators*)
- (break ;; problem when testing cells on some CLs
- "cell ~a midst askers: ~a" c *c-calculators*))))
-
- (count-it :c-calculate-and-set )
- ;;; (count-it :c-calculate-and-set (type-of (c-model c))) ;; (c-slot-name c))
-
- ;;(with-metrics (nil nil () "calc n set" (c-slot-name c) (c-model c))
- (progn ;; wtrc (0 200 "calc n set" (c-slot-name c) (c-model c))
- (cd-usage-clear-all c)
-
- (let ((mycalc (incf (cr-rethinking c) 1))
- (newvalue (let ((*c-calculators* (cons c *c-calculators*))
- *synapse-factory* ;; clear, then if desired each access to potential other cell must estab. *synapse-factory*
- )
- (assert (c-model c))
- #+not (when (plusp *trcdepth*)
- (format t "ccalcnset> calcing ~a calcers ~a" c *c-calculators*))
- (funcall (cr-rule c) c))))
-
- #+notso (assert (not (typep newvalue 'cell)) ()
- "new value for cell ~s is itself a cell: ~s. probably nested (c? ... (c? ))"
- c newvalue)
- (when (and *c-debug* (typep newvalue 'cell))
- (trc "new value for cell ~s is itself a cell: ~s. probably nested (c? ... (c? ))"
- c newvalue))
- (when (< mycalc (cr-rethinking c))
- ;;
- ;; means we re-entered rule and managed to compute without re-entering under new circumstances
- ;; of later entry. use later calculation result..
- (trc nil "calc-n-set > breaking off, not lg" c)
- ;;
- (assert (c-validp c))
- (return-from c-calculate-and-set (c-value c)))
-
- (c-unlink-unused c)
-
- (md-slot-value-assume (c-model c)
- (c-slot-spec c)
- (c-absorb-value c newvalue)))))
-
-#+test
-(loop for useds on '(1 2 3 4 5)
- for used = (car useds)
- for mapn upfrom 5
- when (oddp used)
- do (print (list useds mapn))(print used))
-
-(defun c-unlink-unused (c &aux (usage (cd-usage c)))
- (loop for useds on (cd-useds c)
- for used = (car useds)
- for mapn upfrom (- *cd-usagect* (length (cd-useds c)))
- when (zerop (sbit usage mapn))
- do
- (assert (not (minusp mapn)))
- (assert (< mapn *cd-usagect*))
- (if (typep used 'synapse)
- (progn
- (setf (syn-relevant used) nil) ;; 030826synfix
- )
- (progn
- (trc nil "dropping unused" used :mapn-usage mapn usage)
- (c-unlink-user used c)
- (rplaca useds nil))))
- (setf (cd-useds c) (delete-if #'null (cd-useds c))))
-
-
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+;____________________________ cell calculate and set ___________________
+;
+
+(defun c-calculate-and-set (c)
+ (when (c-stopped)
+ (princ #\.)
+ (return-from c-calculate-and-set))
+
+ (c-assert (not (cmdead c)))
+
+ (when (find c *c-calculators*) ;; circularity
+ (c-stop :c-calculate-and-set-circ-ask)
+ (trc "md-slot-value breaking on circularity" c *c-calculators*)
+ (break ;; problem when testing cells on some CLs
+ "cell ~a midst askers: ~a" c *c-calculators*))
+
+ (count-it :c-calculate-and-set )
+ ;;; (count-it :c-calculate-and-set (type-of (c-model c))) ;; (c-slot-name c))
+
+ ;;(with-metrics (nil nil () "calc n set" (c-slot-name c) (c-model c))
+ (progn ;; wtrc (0 200 "calc n set" (c-slot-name c) (c-model c))
+ (cd-usage-clear-all c)
+
+ (let ((mycalc (incf (cr-rethinking c) 1))
+ (newvalue (let ((*c-calculators* (cons c *c-calculators*))
+ *synapse-factory* ;; clear, then if desired each access to potential other cell must estab. *synapse-factory*
+ )
+ (c-assert (c-model c))
+ #+not (when (plusp *trcdepth*)
+ (format t "ccalcnset> calcing ~a calcers ~a" c *c-calculators*))
+ (funcall (cr-rule c) c))))
+
+ #+notso (c-assert (not (typep newvalue 'cell)) ()
+ "new value for cell ~s is itself a cell: ~s. probably nested (c? ... (c? ))"
+ c newvalue)
+ (when (and *c-debug* (typep newvalue 'cell))
+ (trc "new value for cell ~s is itself a cell: ~s. probably nested (c? ... (c? ))"
+ c newvalue))
+ (when (< mycalc (cr-rethinking c))
+ ;;
+ ;; means we re-entered rule and managed to compute without re-entering under new circumstances
+ ;; of later entry. use later calculation result..
+ (trc nil "calc-n-set > breaking off, not lg" c)
+ ;;
+ (c-assert (c-validp c))
+ (return-from c-calculate-and-set (c-value c)))
+
+ (c-unlink-unused c)
+
+ (md-slot-value-assume (c-model c)
+ (c-slot-spec c)
+ (c-absorb-value c newvalue)))))
+
+#+test
+(loop for useds on '(1 2 3 4 5)
+ for used = (car useds)
+ for mapn upfrom 5
+ when (oddp used)
+ do (print (list useds mapn))(print used))
+
+(defun c-unlink-unused (c &aux (usage (cd-usage c)))
+ (loop for useds on (cd-useds c)
+ for used = (car useds)
+ for mapn upfrom (- *cd-usagect* (length (cd-useds c)))
+ when (zerop (sbit usage mapn))
+ do
+ (c-assert (not (minusp mapn)))
+ (c-assert (< mapn *cd-usagect*))
+ (if (typep used 'synapse)
+ (progn
+ (setf (syn-relevant used) nil) ;; 030826synfix
+ )
+ (progn
+ (trc nil "dropping unused" used :mapn-usage mapn usage)
+ (c-unlink-user used c)
+ (rplaca useds nil))))
+ (setf (cd-useds c) (delete-if #'null (cd-useds c))))
+
+
Index: cells/cell-types.lisp
diff -u cells/cell-types.lisp:1.1.1.1 cells/cell-types.lisp:1.2
--- cells/cell-types.lisp:1.1.1.1 Sat Nov 8 18:43:48 2003
+++ cells/cell-types.lisp Tue Dec 16 10:02:58 2003
@@ -1,293 +1,257 @@
-;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
-;;;
-;;; Copyright © 1995,2003 by Kenneth William Tilton.
-;;;
-;;; Permission is hereby granted, free of charge, to any person obtaining a copy
-;;; of this software and associated documentation files (the "Software"), to deal
-;;; in the Software without restriction, including without limitation the rights
-;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-;;; copies of the Software, and to permit persons to whom the Software is furnished
-;;; to do so, subject to the following conditions:
-;;;
-;;; The above copyright notice and this permission notice shall be included in
-;;; all copies or substantial portions of the Software.
-;;;
-;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
-;;; IN THE SOFTWARE.
-
-(in-package :cells)
-
-(defun slot-spec-name (slot-spec)
- slot-spec)
-
-(cc-defstruct (cell (:conc-name c-))
- waking-state
- model
- slot-spec
- value
- )
-
-(defun c-slot-name (c)
- (slot-spec-name (c-slot-spec c)))
-
-(defun c-validate (self c)
- (when (not (and (c-slot-spec c) (c-model c)))
-;;; (setf *stop* t)
- (format t "~&unadopted cell: ~s md:~s, awake:~s" c self (c-waking-state self))
- (error 'c-unadopted :cell c)))
-
-(defmethod c-when (other)
- (declare (ignorable other)) nil) ;; /// needs work
-
-(cc-defstruct (synapse
- (:include cell)
- (:conc-name syn-))
- user
- used
- (relevant t) ;; not if unused during subsequent eval. but keep to preserve likely state
- fire-p
- relay-value)
-
-(defmacro mksynapse ((&rest closeovervars) &key trcp fire-p relay-value)
- (let ((used (copy-symbol 'used)) (user (copy-symbol 'user)))
- `(lambda (,used ,user)
- ,(when trcp
- `(trc "making synapse between user" ',trcp ,user :and :used ,used))
- (let (, at closeovervars)
- (make-synapse
- :used ,used
- ;;; 210207kt why? use (c-model (syn-used <syn>)) :c-model (c-model ,used)
- :user ,user
- :fire-p ,fire-p
- :relay-value ,relay-value)))))
-
-(defmethod print-object ((syn synapse) stream)
- (format stream "{syn ~s ==> ~s" (syn-used syn) (syn-user syn)))
-
-
-(defmethod c-true-stalep ((syn synapse))
- (cd-stale-p (syn-user syn)))
-
-(cc-defstruct (c-user-notifying
- (:include cell)
- (:conc-name un-))
- (users nil :type list))
-
-(cc-defstruct (c-unsteady
- (:include c-user-notifying)
- (:conc-name unst-))
- cyclic-p
- cyclic-value
- delta-p
- setting-p)
-
-(cc-defstruct (c-variable
- (:include c-unsteady)))
-
-(cc-defstruct (c-ruled
- (:include c-unsteady)
- (:conc-name cr-))
- (state :unbound :type symbol)
- (rethinking 0 :type number)
- lazy
- rule)
-
-(defmethod c-lazy-p ((c c-ruled)) (cr-lazy c))
-(defmethod c-lazy-p (c) (declare (ignore c)) nil)
-
-(defun c-optimized-away-p (c)
- (eql :optimized-away (c-state c)))
-
-;----------------------------
-
-
-(defmethod c-true-stalep (c)
- (declare (ignore c)))
-
-(cc-defstruct (c-independent
- ;;
- ;; these do not optimize away, because also these can be set after initial evaluation of the rule,
- ;; so users better stay tuned.
- ;; the whole idea here is that the old idea of having cv bodies evaluated immediately finally
- ;; broke down when we wanted to say :kids (cv (list (fm-other vertex)))
- ;;
- (:include c-ruled)))
-
-(defmethod trcp-slot (self slot-name)
- (declare (ignore self slot-name)))
-
-(defconstant *cd-usagect* 64)
-
-(cc-defstruct (c-dependent
- (:include c-ruled)
- (:conc-name cd-))
- (useds nil :type list)
- (code nil :type list) ;; /// feature this out on production build
- (usage (make-array *cd-usagect* :element-type 'bit
- :initial-element 0) :type vector)
- stale-p
- )
-
-;;;(defmethod trcp ((c c-dependent))
-;;; (or (trcp-slot (c-model c) (c-slot-name c))
-;;; ;;(c-lazy-p c)
-;;; nil))
-
-(defmethod c-true-stalep ((c c-dependent))
- (cd-stale-p c))
-
-(cc-defstruct (c-stream
- (:include c-ruled)
- (:conc-name cs-))
- values)
-
-;;; (defmacro cell~ (&body body)
-;;; `(make-c-stream
-;;; :rule (lambda ,@*c-lambda*
-;;; , at body)))
-
-(cc-defstruct (c-drifter
- (:include c-dependent)))
-
-(cc-defstruct (c-drifter-absolute
- (:include c-drifter)))
-
-;_____________________ accessors __________________________________
-
-
-(defun (setf c-state) (new-value c)
- (if (typep c 'c-ruled)
- (setf (cr-state c) new-value)
- new-value))
-
-(defun c-state (c)
- (if (typep c 'c-ruled)
- (cr-state c)
- :valid))
-
-(defun c-unboundp (c)
- (eql :unbound (c-state c)))
-
-(defun c-validp (c)
- (find (c-state c) '(:valid :optimized-away)))
-
-;_____________________ print __________________________________
-
-(defmethod print-object :before ((c c-variable) stream)
- (declare (ignorable c))
- (format stream "[var:"))
-
-(defmethod print-object :before ((c c-dependent) stream)
- (declare (ignorable c))
- (format stream "[dep~a:" (cond
- ((null (c-model c)) #\0)
- ((eq :eternal-rest (md-state (c-model c))) #\_)
- ((cd-stale-p c) #\#)
- ((sw-pending c) #\?)
- (t #\space))))
-
-(defmethod print-object :before ((c c-independent) stream)
- (declare (ignorable c))
- (format stream "[ind:"))
-
-(defmethod print-object ((c cell) stream)
- (c-print-value c stream)
- (format stream "=~a/~a]"
- (symbol-name (or (c-slot-name c) :anoncell))
- (or (c-model c) :anonmd))
-;;; #+dfdbg (unless *stop*
-;;; (assert (find c (cells (c-model c)) :key #'cdr)))
- )
-
-;__________________
-
-(defmethod c-print-value ((c c-ruled) stream)
- (format stream "~a" (cond ((unst-setting-p c) "<^^^>")
- ((c-validp c) "<vld>")
- ((c-unboundp c) "<unb>")
- ((cd-stale-p c) "<obs>")
- (t "<err>"))))
-
-(defmethod c-print-value (c stream)
- (declare (ignore c stream)))
-
-;____________________ constructors _______________________________
-
-(defmacro c-lambda (&body body)
- (let ((c (gensym)))
- `(lambda (,c &aux (self (c-model ,c))
- (.cache (c-value ,c)))
- (declare (ignorable .cache self))
- (assert (not (cmdead ,c))() "cell dead entering rule ~a" ,c)
- , at body)))
-
-(defmacro c? (&body body)
- `(make-c-dependent
- :code ',body
- :rule (c-lambda , at body)))
-
-(defmacro c?_ (&body body)
- `(make-c-dependent
- :code ',body
- :lazy t
- :rule (c-lambda , at body)))
-
-(defmacro c?? ((&key (tagp nil) (in nil) (trigger nil) (out t))&body body)
- (let ((result (copy-symbol 'result))
- (thetag (gensym)))
- `(make-c-dependent
- :code ',body
- :rule (c-lambda
- (let ((,thetag (gensym "tag"))
- (*trcdepth* (1+ *trcdepth*))
- )
- (declare (ignorable self ,thetag))
- ,(when in
- `(trc "c??> entry" (c-slot-name c) (c-model c) (when ,tagp ,thetag)))
- ,(when trigger `(trc "c??> trigger" *cause* c))
- (count-it :c?? (c-slot-name c) (md-name (c-model c)))
- (let ((,result (progn , at body)))
- ,(when out `(trc "c?? result:" ,result (c-slot-name c) (when ,tagp ,thetag)))
- ,result))))))
-
-(defmacro cv (defn)
- `(make-c-variable
- :value ,defn)) ;; use c-independent if need deferred execution
-
-(defmacro cv8 (defn)
- `(make-c-variable
- :cyclic-p t
- :value ,defn)) ;; use c-independent if need deferred execution
-
-(defmacro c... ((value) &body body)
- `(make-c-drifter
- :code ',body
- :value ,value
- :rule (c-lambda , at body)))
-
-(defmacro c-abs (value &body body)
- `(make-c-drifter-absolute
- :code ',body
- :value ,value
- :rule (lambda (c &aux (self (c-model c)))
- (declare (ignorable self c))
- , at body)))
-
-
-(defmacro c-envalue (&body body)
- `(make-c-envaluer
- :envaluerule (lambda (self)
- (declare (ignorable self))
- , at body)))
-
-(defmacro c8 ((&optional cyclic-value) &body body)
- `(make-c-dependent
- :code ',body
- :cyclic-p t
- :cyclic-value ,cyclic-value
- :rule (c-lambda , at body)))
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+(defun slot-spec-name (slot-spec)
+ slot-spec)
+
+
+(defstruct (cell (:conc-name c-))
+ waking-state
+ model
+ slot-spec
+ value
+ (users nil :type list))
+
+(defun test ()
+ (let (x)
+ (makunbound x)
+ x))
+
+(defun c-slot-name (c)
+ (slot-spec-name (c-slot-spec c)))
+
+(defun c-validate (self c)
+ (when (not (and (c-slot-spec c) (c-model c)))
+ (format t "~&unadopted cell: ~s md:~s, awake:~s" c self (c-waking-state self))
+ (c-break "unadopted cell ~a ~a" self c)
+ (error 'c-unadopted :cell c)))
+
+(defmethod c-when (other)
+ (declare (ignorable other)) nil) ;; /// needs work
+
+(defstruct (synapse
+ (:conc-name syn-))
+ user
+ used
+ (relevant t) ;; not if unused during subsequent eval. but keep to preserve any state
+ fire-p
+ relay-value)
+
+(defmacro mksynapse ((&rest closeovervars) &key trcp fire-p relay-value)
+ (let ((used (copy-symbol 'used)) (user (copy-symbol 'user)))
+ `(lambda (,used ,user)
+ ,(when trcp
+ `(trc "making synapse between user" ',trcp ,user :and :used ,used))
+ (let (, at closeovervars)
+ (make-synapse
+ :used ,used
+ :user ,user
+ :fire-p ,fire-p
+ :relay-value ,relay-value)))))
+
+(defmethod print-object ((syn synapse) stream)
+ (format stream "{syn ~s ==> ~s" (syn-used syn) (syn-user syn)))
+
+(defmethod c-true-stalep ((syn synapse))
+ (cd-stale-p (syn-user syn)))
+
+(defstruct (c-variable
+ (:include cell)
+ (:conc-name cv-))
+ cyclic-p
+ setting-p)
+
+(defstruct (c-ruled
+ (:include cell)
+ (:conc-name cr-))
+ (state :unbound :type symbol)
+ (rethinking 0 :type number)
+ lazy
+ rule)
+
+(defmethod c-lazy-p ((c c-ruled)) (cr-lazy c))
+(defmethod c-lazy-p (c) (declare (ignore c)) nil)
+
+(defun c-optimized-away-p (c)
+ (eql :optimized-away (c-state c)))
+
+;----------------------------
+
+(defmethod c-true-stalep (c)
+ (declare (ignore c)))
+
+(defmethod trcp-slot (self slot-name)
+ (declare (ignore self slot-name)))
+
+(defconstant *cd-usagect* 64)
+
+(defstruct (c-dependent
+ (:include c-ruled)
+ (:conc-name cd-))
+ (useds nil :type list)
+ (code nil :type list) ;; /// feature this out on production build
+ (usage (make-array *cd-usagect* :element-type 'bit
+ :initial-element 0) :type vector)
+ stale-p
+ )
+
+;;;(defmethod trcp ((c c-dependent))
+;;; (or (trcp-slot (c-model c) (c-slot-name c))
+;;; ;;(c-lazy-p c)
+;;; nil))
+
+(defmethod c-true-stalep ((c c-dependent))
+ (cd-stale-p c))
+
+(defstruct (c-stream
+ (:include c-ruled)
+ (:conc-name cs-))
+ values)
+
+;;; (defmacro cell~ (&body body)
+;;; `(make-c-stream
+;;; :rule (lambda ,@*c-lambda*
+;;; , at body)))
+
+(defstruct (c-drifter
+ (:include c-dependent)))
+
+(defstruct (c-drifter-absolute
+ (:include c-drifter)))
+
+;_____________________ accessors __________________________________
+
+
+(defun (setf c-state) (new-value c)
+ (if (typep c 'c-ruled)
+ (setf (cr-state c) new-value)
+ new-value))
+
+(defun c-state (c)
+ (if (typep c 'c-ruled)
+ (cr-state c)
+ :valid))
+
+(defun c-unboundp (c)
+ (eql :unbound (c-state c)))
+
+(defun c-validp (c)
+ (find (c-state c) '(:valid :optimized-away)))
+
+;_____________________ print __________________________________
+
+(defmethod print-object :before ((c c-variable) stream)
+ (declare (ignorable c))
+ (format stream "[var:"))
+
+(defmethod print-object :before ((c c-dependent) stream)
+ (declare (ignorable c))
+ (format stream "[dep~a:" (cond
+ ((null (c-model c)) #\0)
+ ((eq :eternal-rest (md-state (c-model c))) #\_)
+ ((cd-stale-p c) #\#)
+ ((sw-pending c) #\?)
+ (t #\space))))
+
+(defmethod print-object ((c cell) stream)
+ (c-print-value c stream)
+ (format stream "=~a/~a]"
+ (symbol-name (or (c-slot-name c) :anoncell))
+ (or (c-model c) :anonmd)))
+
+;__________________
+
+(defmethod c-print-value ((c c-ruled) stream)
+ (format stream "~a" (cond ((c-validp c) "<vld>")
+ ((c-unboundp c) "<unb>")
+ ((cd-stale-p c) "<obs>")
+ (t "<err>"))))
+
+(defmethod c-print-value (c stream)
+ (declare (ignore c stream)))
+
+;____________________ constructors _______________________________
+
+(defmacro c-lambda (&body body)
+ (let ((c (gensym)))
+ `(lambda (,c &aux (self (c-model ,c))
+ (.cache (c-value ,c)))
+ (declare (ignorable .cache self))
+ (c-assert (not (cmdead ,c)) "cell dead entering rule ~a" ,c)
+ , at body)))
+
+(defmacro c? (&body body)
+ `(make-c-dependent
+ :code ',body
+ :rule (c-lambda , at body)))
+
+(defmacro c?_ (&body body)
+ `(make-c-dependent
+ :code ',body
+ :lazy t
+ :rule (c-lambda , at body)))
+
+(defmacro c?? ((&key (tagp nil) (in nil) (trigger nil) (out t))&body body)
+ (let ((result (copy-symbol 'result))
+ (thetag (gensym)))
+ `(make-c-dependent
+ :code ',body
+ :rule (c-lambda
+ (let ((,thetag (gensym "tag"))
+ (*trcdepth* (1+ *trcdepth*))
+ )
+ (declare (ignorable self ,thetag))
+ ,(when in
+ `(trc "c??> entry" (c-slot-name c) (c-model c) (when ,tagp ,thetag)))
+ ,(when trigger `(trc "c??> trigger" *cause* c))
+ (count-it :c?? (c-slot-name c) (md-name (c-model c)))
+ (let ((,result (progn , at body)))
+ ,(when out `(trc "c?? result:" ,result (c-slot-name c) (when ,tagp ,thetag)))
+ ,result))))))
+
+(defmacro cv (defn)
+ `(make-c-variable
+ :value ,defn))
+
+(defmacro cv8 (defn)
+ `(make-c-variable
+ :cyclic-p t
+ :value ,defn))
+
+(defmacro c... ((value) &body body)
+ `(make-c-drifter
+ :code ',body
+ :value ,value
+ :rule (c-lambda , at body)))
+
+(defmacro c-abs (value &body body)
+ `(make-c-drifter-absolute
+ :code ',body
+ :value ,value
+ :rule (c-lambda , at body)))
+
+
+(defmacro c-envalue (&body body)
+ `(make-c-envaluer
+ :envaluerule (c-lambda , at body)))
Index: cells/cells.asd
diff -u cells/cells.asd:1.1.1.1 cells/cells.asd:1.2
--- cells/cells.asd:1.1.1.1 Sat Nov 8 18:43:48 2003
+++ cells/cells.asd Tue Dec 16 10:02:58 2003
@@ -1,36 +1,36 @@
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-
-#+(or allegro lispworks cmu mcl cormanlisp sbcl scl)
-
-(asdf:defsystem :cells
- :name "cells"
- :author "Kenny Tilton <ktilton at nyc.rr.com>"
- :version "05-Nov-2003"
- :maintainer "Kenny Tilton <ktilton at nyc.rr.com>"
- :licence "MIT Style"
- :description "Cells"
- :long-description "The Cells dataflow extension to CLOS."
- :components
- ((:file "cells")
- (:file "flow-control" :depends-on ("cells"))
- (:file "strings" :depends-on ("flow-control"))
- (:file "detritus" :depends-on ("flow-control"))
- (:file "cell-types" :depends-on ("cells"))
- (:file "debug" :depends-on ("cells"))
- (:file "initialize" :depends-on ("debug"))
- (:file "dataflow-management" :depends-on ("debug"))
- (:file "md-slot-value" :depends-on ("debug"))
- (:file "calc-n-set" :depends-on ("debug"))
- (:file "slot-utilities" :depends-on ("debug"))
- (:file "optimization" :depends-on ("debug"))
- (:file "link" :depends-on ("debug"))
- (:file "propagate" :depends-on ("debug"))
- (:file "synapse" :depends-on ("debug" "cell-types"))
- (:file "model-object" :depends-on ("debug"))
- (:file "defmodel" :depends-on ("model-object"))
- (:file "md-utilities" :depends-on ("defmodel"))
- (:file "family" :depends-on ("propagate" "model-object" "defmodel"))
- (:file "fm-utilities" :depends-on ("family"))
- (:file "family-values" :depends-on ("fm-utilities"))))
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+
+#+(or allegro lispworks cmu mcl clisp cormanlisp sbcl scl)
+
+(asdf:defsystem :cells
+ :name "cells"
+ :author "Kenny Tilton <ktilton at nyc.rr.com>"
+ :version "05-Nov-2003"
+ :maintainer "Kenny Tilton <ktilton at nyc.rr.com>"
+ :licence "MIT Style"
+ :description "Cells"
+ :long-description "The Cells dataflow extension to CLOS."
+ :components
+ ((:file "cells")
+ (:file "flow-control" :depends-on ("cells"))
+ (:file "strings" :depends-on ("flow-control"))
+ (:file "detritus" :depends-on ("flow-control"))
+ (:file "cell-types" :depends-on ("cells"))
+ (:file "debug" :depends-on ("cells"))
+ (:file "initialize" :depends-on ("debug"))
+ (:file "dataflow-management" :depends-on ("debug"))
+ (:file "md-slot-value" :depends-on ("debug"))
+ (:file "calc-n-set" :depends-on ("debug"))
+ (:file "slot-utilities" :depends-on ("debug"))
+ (:file "optimization" :depends-on ("debug"))
+ (:file "link" :depends-on ("debug"))
+ (:file "propagate" :depends-on ("debug"))
+ (:file "synapse" :depends-on ("debug" "cell-types"))
+ (:file "model-object" :depends-on ("debug"))
+ (:file "defmodel" :depends-on ("model-object"))
+ (:file "md-utilities" :depends-on ("defmodel"))
+ (:file "family" :depends-on ("propagate" "model-object" "defmodel"))
+ (:file "fm-utilities" :depends-on ("family"))
+ (:file "family-values" :depends-on ("fm-utilities"))))
Index: cells/cells.lisp
diff -u cells/cells.lisp:1.2 cells/cells.lisp:1.3
--- cells/cells.lisp:1.2 Thu Nov 13 00:54:53 2003
+++ cells/cells.lisp Tue Dec 16 10:02:58 2003
@@ -1,111 +1,128 @@
-;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
-;;;
-;;; Copyright © 1995,2003 by Kenneth William Tilton.
-;;;
-;;; Permission is hereby granted, free of charge, to any person obtaining a copy
-;;; of this software and associated documentation files (the "Software"), to deal
-;;; in the Software without restriction, including without limitation the rights
-;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-;;; copies of the Software, and to permit persons to whom the Software is furnished
-;;; to do so, subject to the following conditions:
-;;;
-;;; The above copyright notice and this permission notice shall be included in
-;;; all copies or substantial portions of the Software.
-;;;
-;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
-;;; IN THE SOFTWARE.
-
-(eval-when (compile load)
- (proclaim '(optimize (speed 2) (safety 1) (space 1) (debug 3))))
-
-(defpackage :cells
- (:use "COMMON-LISP"
- #+allegro "EXCL"
- #-(or cormanlisp cmu sbcl) "CLOS"
- #+sbcl "SB-MOP"
- #+mcl "CCL"
- )
- #+clisp (:import-from #:clos "CLASS-SLOTS" "CLASS-PRECEDENCE-LIST")
- #+cmu (:import-from "PCL" "CLASS-PRECEDENCE-LIST" "CLASS-SLOTS"
- "SLOT-DEFINITION-NAME")
- (:export "CELL" "CV" "C?" "C?_" "C??" "WITHOUT-C-DEPENDENCY" "SELF" "*SYNAPSE-FACTORY*"
- ".CACHE" "C-LAMBDA" ".CAUSE"
- "DEFMODEL" "CELLBRK" "C-AWAKEN" "DEF-C-ECHO" "DEF-C-UNCHANGED-TEST"
- "NEW-VALUE" "OLD-VALUE" "C..."
- "MKPART" "THEKIDS" "NSIB" "MDVALUE" "^MDVALUE" ".MDVALUE" "KIDS" "^KIDS" ".KIDS"
- "CELL-RESET" "UPPER" "FM-MAX" "NEAREST" "^FM-MIN-KID" "^FM-MAX-KID" "MK-KID-SLOT"
- "DEF-KID-SLOTS" "FIND-PRIOR" "FM-POS" "KIDNO" "FM-INCLUDES" "FM-ASCENDANT-COMMON"
- "FM-KID-CONTAINING" "FM-FIND-IF" "FM-ASCENDANT-IF" "C-ABS" "FM-COLLECT-IF" "CV8" "PSIB"
- "TO-BE" "NOT-TO-BE" "SSIBNO" "MD-AWAKEN"
- #:delta-diff
- )
- #+allegro (:shadowing-import-from #:excl #:fasl-write #:fasl-read #:gc)
- )
-
-(in-package :cells)
-
-(defconstant *c-optimizep* t)
-(defvar *c-prop-depth* 0)
-(defvar *cause* nil)
-(defvar *rethink-deferred* nil)
-(defvar *synapse-factory* nil)
-(defvar *sw-looping* nil)
-(defparameter *to-be-awakened* nil)
-(defvar *trcdepth* 0)
-
-(defparameter *c-debug*
- #+runtime-system nil
- #-runtime-system t)
-
-(defvar *stop* nil)
-
-(defun stop ()
- (setf *stop* t))
-
-(defvar *c-calculators* nil)
-
-(defmacro ssibno () `(position self (^kids .parent)))
-
-(defmacro gpar ()
- `(fm-grandparent self))
-
-(defmacro nearest (selfform type)
- (let ((self (gensym)))
- `(bwhen (,self ,selfform)
- (if (typep ,self ',type) ,self (upper ,self ,type)))))
-
-(defmacro def-c-trace (model-type &optional slot cell-type)
- `(defmethod trcp ((self ,(case cell-type
- (:c? 'c-dependent)
- (otherwise 'cell))))
- (and (typep (c-model self) ',model-type)
- ,(if slot
- `(eq (c-slot-name self) ',slot)
- `t))))
-
-(defmacro with-dataflow-management ((c-originating) &body body)
- (let ((fn (gensym)))
- `(let ((,fn (lambda () , at body)))
- (declare (dynamic-extent ,fn))
- (call-with-dataflow-management ,c-originating ,fn))))
-
-(defmacro without-c-dependency (&body body)
- `(let (*c-calculators*) , at body))
-
-(defmacro without-propagating ((slotname objxpr) &body body)
- (let ((c (gensym))
- (c-delta (gensym)))
- `(let ((,c (slot-value ,objxpr ',slotname)))
- (push (cons ,c nil) *c-noprop*)
- (progn , at body)
- (let ((,c-delta (assoc ,c *c-noprop*)))
- (assert ,c-delta)
- (setf *c-noprop* (delete ,c-delta *c-noprop*))
- (when (cdr ,c-delta) ;; if changed, will be set to /list/ containing priorvalue
- (,c (cadr ,c-delta) (caddr ,c-delta)))))))
-
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(eval-when (compile load)
+ (proclaim '(optimize (speed 2) (safety 3) (space 1) (debug 3))))
+
+(defpackage :cells
+ (:use "COMMON-LISP"
+ #+allegro "EXCL"
+ #-(or cormanlisp cmu sbcl) "CLOS"
+ #+sbcl "SB-MOP"
+ #+mcl "CCL"
+ )
+ #+clisp (:import-from #:clos "CLASS-SLOTS" "CLASS-PRECEDENCE-LIST")
+ #+cmu (:import-from "PCL" "CLASS-PRECEDENCE-LIST" "CLASS-SLOTS"
+ "SLOT-DEFINITION-NAME" "TRUE")
+ (:export "CELL" "CV" "C?" "C?_" "C??" "WITHOUT-C-DEPENDENCY" "SELF" "*SYNAPSE-FACTORY*"
+ ".CACHE" "C-LAMBDA" ".CAUSE"
+ "DEFMODEL" "CELLBRK" "C-AWAKEN" "DEF-C-ECHO" "DEF-C-UNCHANGED-TEST"
+ "NEW-VALUE" "OLD-VALUE" "C..."
+ "MKPART" "THEKIDS" "NSIB" "MD-VALUE" "^MD-VALUE" ".MD-VALUE" "KIDS" "^KIDS" ".KIDS"
+ "CELL-RESET" "UPPER" "FM-MAX" "NEAREST" "^FM-MIN-KID" "^FM-MAX-KID" "MK-KID-SLOT"
+ "DEF-KID-SLOTS" "FIND-PRIOR" "FM-POS" "KID-NO" "FM-INCLUDES" "FM-ASCENDANT-COMMON"
+ "FM-KID-CONTAINING" "FM-FIND-IF" "FM-ASCENDANT-IF" "C-ABS" "FM-COLLECT-IF" "CV8" "PSIB"
+ "TO-BE" "NOT-TO-BE" "SSIBNO" "MD-AWAKEN"
+ "C-BREAK" "C-ASSERT" "C-STOP" "C-STOPPED" "C-ASSERT"
+ #:delta-diff
+ )
+ #+allegro (:shadowing-import-from #:excl #:fasl-write #:fasl-read #:gc)
+ )
+
+(in-package :cells)
+
+(defconstant *c-optimizep* t)
+(defvar *c-prop-depth* 0)
+(defvar *cause* nil)
+(defvar *rethink-deferred* nil)
+(defvar *synapse-factory* nil)
+(defvar *sw-looping* nil)
+(defparameter *to-be-awakened* nil)
+(defvar *trcdepth* 0)
+
+(defparameter *c-debug*
+ #+runtime-system nil
+ #-runtime-system t)
+
+(defvar *stop* nil)
+
+(defun c-stop (why)
+ (format t "~&C-STOP> stopping because ~a" why)
+ (setf *stop* t))
+
+(defun c-stopped ()
+ *stop*)
+
+(defmacro c-assert (assertion &optional places fmt$ &rest fmtargs)
+ (declare (ignore places))
+
+ `(unless *stop*
+ (unless ,assertion
+ (setf *stop* t)
+ ,(if fmt$
+ `(c-break ,fmt$ , at fmtargs)
+ `(c-break "failed assertion:" ',assertion)))))
+
+(defvar *c-calculators* nil)
+
+(defmacro ssibno () `(position self (^kids .parent)))
+
+(defmacro gpar ()
+ `(fm-grandparent self))
+
+(defmacro nearest (selfform type)
+ (let ((self (gensym)))
+ `(bwhen (,self ,selfform)
+ (if (typep ,self ',type) ,self (upper ,self ,type)))))
+
+(defmacro def-c-trace (model-type &optional slot cell-type)
+ `(defmethod trcp ((self ,(case cell-type
+ (:c? 'c-dependent)
+ (otherwise 'cell))))
+ (and (typep (c-model self) ',model-type)
+ ,(if slot
+ `(eq (c-slot-name self) ',slot)
+ `t))))
+
+(defmacro with-dataflow-management ((c-originating) &body body)
+ (let ((fn (gensym)))
+ `(let ((,fn (lambda () , at body)))
+ (declare (dynamic-extent ,fn))
+ (call-with-dataflow-management ,c-originating ,fn))))
+
+(defmacro without-c-dependency (&body body)
+ `(let (*c-calculators*) , at body))
+
+(defmacro without-propagating ((slotname objxpr) &body body)
+ (let ((c (gensym))
+ (c-delta (gensym)))
+ `(let ((,c (slot-value ,objxpr ',slotname)))
+ (push (cons ,c nil) *c-noprop*)
+ (progn , at body)
+ (let ((,c-delta (assoc ,c *c-noprop*)))
+ (c-assert ,c-delta)
+ (setf *c-noprop* (delete ,c-delta *c-noprop*))
+ (when (cdr ,c-delta) ;; if changed, will be set to /list/ containing priorvalue
+ (,c (cadr ,c-delta) (caddr ,c-delta)))))))
+
+(define-symbol-macro .cause
+ *cause*)
Index: cells/dataflow-management.lisp
diff -u cells/dataflow-management.lisp:1.1.1.1 cells/dataflow-management.lisp:1.2
--- cells/dataflow-management.lisp:1.1.1.1 Sat Nov 8 18:44:00 2003
+++ cells/dataflow-management.lisp Tue Dec 16 10:02:58 2003
@@ -1,223 +1,229 @@
-;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
-;;;
-;;; Copyright © 1995,2003 by Kenneth William Tilton.
-;;;
-;;; Permission is hereby granted, free of charge, to any person obtaining a copy
-;;; of this software and associated documentation files (the "Software"), to deal
-;;; in the Software without restriction, including without limitation the rights
-;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-;;; copies of the Software, and to permit persons to whom the Software is furnished
-;;; to do so, subject to the following conditions:
-;;;
-;;; The above copyright notice and this permission notice shall be included in
-;;; all copies or substantial portions of the Software.
-;;;
-;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
-;;; IN THE SOFTWARE.
-
-(in-package :cells)
-
-(defparameter *df-interference-detection* t)
-
-(eval-when (compile eval load)
- (export '(*df-interference-detection*)))
-
-(defmethod sw-detect-interference (user trigger)
- (declare (ignorable trigger))
- (when #+runtime-system t #-runtime-system *df-interference-detection*
- (trc nil "detect entry" user (cd-useds user))
- (dolist (used (cd-useds user))
- (do ((deep-stale (cd-deep-stale used)(cd-deep-stale used)))
- ((null deep-stale))
- ;;(trc nil "sw-detect-interference trying deep stale" deep-stale)
- (c-rethink deep-stale)
- (cond
- ((c-true-stalep deep-stale)
- (trc "!! true deep stalep: user>" user)
- (trc "!! true deep stalep: used>" used)
- (trc "!! true deep stalep: deepstale>" deep-stale)
- (return-from sw-detect-interference deep-stale #+debugging (list user used deep-stale)))
-
- ((not (c-true-stalep user))
- (return-from sw-detect-interference nil)))))))
-
-(defmethod sw-detect-interference ((user c-variable) trigger)
- (declare (ignore trigger)))
-
-(defmethod sw-detect-interference ((user synapse) trigger)
- (sw-detect-interference (syn-used user) trigger))
-
-(defmethod cd-deep-stale ((c c-dependent))
- (trc nil "cd-deep-stale entry" c)
- (if (cd-stale-p c)
- c ;; (eko ("deep stalep bingo !!!!!!") c)
- (some #'cd-deep-stale (cd-useds c))))
-
-(defmethod cd-deep-stale ((syn synapse))
- (cd-deep-stale (syn-used syn)))
-
-(defmethod cd-deep-stale (c)
- (declare (ignore c)))
-
-(defparameter *sw-pending* nil)
-(defparameter *dataflowing* nil)
-
-(defun dump-pending ()
- (dotimes (x (length *sw-pending*))
- (let ((p (nth x *sw-pending*)))
- (destructuring-bind (heldup . holdup) p
- (declare (ignorable holdup))
- (trc heldup " pending!!!!!!!!!!" p)
- )))
- )
-
-;; mo better diags: holdup (c-true-stalep holdup) heldup (c-true-stalep heldup))))))
-
-(defun call-with-dataflow-management (c-originating bodyfn)
- (declare (ignorable c-originating))
- (if *dataflowing*
- (funcall bodyfn)
- (let ((*dataflowing* t)
- *sw-pending*)
- #+dfdbg (trc nil ">>>>> with-dataflow-management: 001" c-originating)
- (setf (unst-setting-p c-originating) t)
- (prog1
- (funcall bodyfn)
-
- (while (and *sw-pending*
- (not *sw-looping*))
-
- #+dfdbg
- (progn
- (trc nil "we have pending!!!!!!!!!!" (length *sw-pending*))
- (dump-pending))
-
- (let ((pct (length *sw-pending*))
- (oldpending (copy-list *sw-pending*)))
- ;;(trace c-rethink)
- (labels ((do-last (pending)
- (when pending
- (do-last (cdr pending))
- ;;(trace c-rethink cd-deep-stale sw-detect-interference)
- (destructuring-bind (heldup . holdup) (car pending)
- (trc heldup "pending sweep sees held up" heldup :holdup holdup)
- (assert (find heldup (cells (c-model heldup)) :key #'cdr))
- (assert (find holdup (cells (c-model holdup)) :key #'cdr))
- ;; (unless (c-true-stalep holdup)
- ;; (trc nil "dataflow sees freed blocker" holdup))
- (if (c-true-stalep holdup)
- (if (eq :eternal-rest (md-state (c-model holdup)))
- (progn (trc "holdup is no more!!!!!!!" holdup (c-true-stalep heldup) heldup))
- (progn
- (trc holdup "dataflow retrying blocker" holdup)
- (c-rethink holdup)))
- (progn
- (trc heldup "holdup not stale!!!" holdup :heldup> heldup)
- (c-pending-set heldup nil :holdup-unstale) ))
- ;;(unless (c-true-stalep heldup)
- ;; (trc nil "dataflow sees freed blocked" heldup))
- (when (c-true-stalep heldup)
- (trc heldup "dataflow retrying blocked" heldup)
- (c-rethink heldup))))))
- ;; (trace c-rethink cd-deep-stale sw-detect-interference)
- (do-last *sw-pending*)
- ;; (trc "post sweep pending leftovers:" (length *sw-pending*))
- ;; (untrace c-rethink cd-deep-stale sw-detect-interference)
- )
- ;;(untrace c-rethink)
- (when (and (equal oldpending *sw-pending*)
- (eql pct (length *sw-pending*))
- (not *sw-looping*))
- (setf *sw-looping* t)
- #+nah (dolist (p *sw-pending*)
- (destructuring-bind (heldup . holdup) p
- (dump-dependency-path holdup heldup)))
- #+nah (dolist (p *sw-pending*)
- (destructuring-bind (heldup . holdup) p
- (declare (ignorable heldup))
- (when t ;; (trcp holdup)
- (dump-stale-path holdup))))
- (break "trigger ~a stuck; cant lose pendings ~a"
- c-originating
- *sw-pending*))
-
- ;; (trc "after sweep sw-pending" *sw-pending*)
- ;; (cellbrk)
- (when c-originating
- (setf (unst-setting-p c-originating) nil))))
- (trc nil "<<<< with-dataflow-management:" c-originating)))))
-
-(defun dump-stale-path (used)
- (assert used)
- (when (typep used 'c-dependent)
- (loop with any
- for used-used in (cd-useds used)
- when (dump-stale-path used-used)
- do (progn
- (setf any t)
- (trc "stale-path" used :uses... used-used))
- finally
- (when (or any (cd-stale-p used))
- (trc "stale" used)
- (return any)))))
-
-(defun dump-dependency-path (used user)
- (assert (and used user))
- (if (eql used user)
- (progn
- (trc "bingo---------------")
- (trc "user" user :uses...)
- t)
- (let (any)
- (dolist (used-user (cd-users used) any)
- (when (dump-dependency-path used-user user)
- (setf any t)
- (trc "user" used-user :uses... used))))))
-
-(defun c-pending-set (c newvalue debug-tag)
- (declare (ignorable debug-tag))
- (assert (find c (cells (c-model c)) :key #'cdr))
- (when newvalue (trc nil "still pending!!!!!!!!!!!!!!!!!!" c newvalue debug-tag))
- (if newvalue
- (bif (known (assoc c *sw-pending*))
- (cond
- ((eq newvalue (cdr known))
- (break "hunh? re-pending ~a on same holdup ~a?" c (cdr known)))
- ((c-true-stalep (cdr known))
- (break "hunh? pending ~a on second holdup ~a as well as ~a?" c newvalue (cdr known)))
- (t
- (trc nil "re-pending ~a on new holdup ~a, last ok: ~a" c newvalue (assoc c *sw-pending*))
- (rplacd known newvalue))) ;; risky business, might need whole new assoc entry
- (let ((newpending (cons c newvalue)))
- (progn
- (assert (typep c 'c-dependent))
- (assert (not (eq :eternal-rest (md-state (c-model c)))))
- ;;(trc nil "pending on, genealogy holdup: held, holder:" debug-tag c newvalue)
- ;;(dump-pending)
- )
- ;;; hunh?> (pushnew newpending *sw-pending* :test #'equal)
- (push newpending *sw-pending*)))
- (bwhen (p (assoc c *sw-pending*))
- (trc nil "clear from sw-pending" debug-tag c (remove-if (lambda (p)
- (not (eql c (car p))))
- *sw-pending*))
- (setf *sw-pending* (delete (assoc c *sw-pending*) *sw-pending*))
- (progn
- (trc nil "pending off, genealogy holdup: held, holder:" debug-tag p
- (count c *sw-pending* :key #'car))
- (dump-pending))
- ))
- newvalue)
-
-(defmethod sw-pending ((c cell))
- (assoc c *sw-pending*))
-
-(defmethod sw-pending ((s synapse))
- (sw-pending (syn-used s)))
-
-
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+(defparameter *df-interference-detection* t)
+
+(eval-when (compile eval load)
+ (export '(*df-interference-detection*)))
+
+(defmethod sw-detect-interference (user trigger)
+ (declare (ignorable trigger))
+ (when #+runtime-system t #-runtime-system *df-interference-detection*
+ (trc nil "detect entry" user (cd-useds user))
+ (dolist (used (cd-useds user))
+ (do ((deep-stale (cd-deep-stale used)(cd-deep-stale used)))
+ ((null deep-stale))
+ ;;(trc nil "sw-detect-interference trying deep stale" deep-stale)
+ (c-rethink deep-stale)
+ (cond
+ ((c-true-stalep deep-stale)
+ (trc "!! true deep stalep: user>" user)
+ (trc "!! true deep stalep: used>" used)
+ (trc "!! true deep stalep: deepstale>" deep-stale)
+ (return-from sw-detect-interference deep-stale #+debugging (list user used deep-stale)))
+
+ ((not (c-true-stalep user))
+ (return-from sw-detect-interference nil)))))))
+
+(defmethod sw-detect-interference ((user c-variable) trigger)
+ (declare (ignore trigger)))
+
+(defmethod sw-detect-interference ((user synapse) trigger)
+ (sw-detect-interference (syn-used user) trigger))
+
+(defmethod cd-deep-stale ((c c-dependent))
+ (trc nil "cd-deep-stale entry" c)
+ (if (cd-stale-p c)
+ c ;; (eko ("deep stalep bingo !!!!!!") c)
+ (some #'cd-deep-stale (cd-useds c))))
+
+(defmethod cd-deep-stale ((syn synapse))
+ (cd-deep-stale (syn-used syn)))
+
+(defmethod cd-deep-stale (c)
+ (declare (ignore c)))
+
+(defparameter *sw-pending* nil)
+(defparameter *dataflowing* nil)
+
+(defun dump-pending ()
+ (dotimes (x (length *sw-pending*))
+ (let ((p (nth x *sw-pending*)))
+ (destructuring-bind (heldup . holdup) p
+ (declare (ignorable holdup))
+ (trc heldup " pending!!!!!!!!!!" p)
+ )))
+ )
+
+;; mo better diags: holdup (c-true-stalep holdup) heldup (c-true-stalep heldup))))))
+
+(defun call-with-dataflow-management (c-originating bodyfn)
+ (declare (ignorable c-originating))
+ (if *dataflowing*
+ (progn
+ (setf (cv-setting-p c-originating) t)
+ (prog1
+ (funcall bodyfn)
+ (setf (cv-setting-p c-originating) nil)))
+
+ (let ((*dataflowing* t)
+ *sw-pending*)
+ #+dfdbg (trc nil ">>>>> with-dataflow-management: 001" c-originating)
+ (setf (cv-setting-p c-originating) t)
+ (prog1
+ (funcall bodyfn)
+
+ (while (and *sw-pending*
+ (not *sw-looping*))
+
+ #+dfdbg
+ (progn
+ (trc nil "we have pending!!!!!!!!!!" (length *sw-pending*))
+ (dump-pending))
+
+ (let ((pct (length *sw-pending*))
+ (oldpending (copy-list *sw-pending*)))
+ ;;(trace c-rethink)
+ (labels ((do-last (pending)
+ (when pending
+ (do-last (cdr pending))
+ ;;(trace c-rethink cd-deep-stale sw-detect-interference)
+ (destructuring-bind (heldup . holdup) (car pending)
+ (trc heldup "pending sweep sees held up" heldup :holdup holdup)
+ (c-assert (find heldup (cells (c-model heldup)) :key #'cdr))
+ (c-assert (find holdup (cells (c-model holdup)) :key #'cdr))
+ ;; (unless (c-true-stalep holdup)
+ ;; (trc nil "dataflow sees freed blocker" holdup))
+ (if (c-true-stalep holdup)
+ (if (eq :eternal-rest (md-state (c-model holdup)))
+ (progn (trc "holdup is no more!!!!!!!" holdup (c-true-stalep heldup) heldup))
+ (progn
+ (trc holdup "dataflow retrying blocker" holdup)
+ (c-rethink holdup)))
+ (progn
+ (trc heldup "holdup not stale!!!" holdup :heldup> heldup)
+ (c-pending-set heldup nil :holdup-unstale) ))
+ ;;(unless (c-true-stalep heldup)
+ ;; (trc nil "dataflow sees freed blocked" heldup))
+ (when (c-true-stalep heldup)
+ (trc heldup "dataflow retrying blocked" heldup)
+ (c-rethink heldup))))))
+ ;; (trace c-rethink cd-deep-stale sw-detect-interference)
+ (do-last *sw-pending*)
+ ;; (trc "post sweep pending leftovers:" (length *sw-pending*))
+ ;; (untrace c-rethink cd-deep-stale sw-detect-interference)
+ )
+ ;;(untrace c-rethink)
+ (when (and (equal oldpending *sw-pending*)
+ (eql pct (length *sw-pending*))
+ (not *sw-looping*))
+ (setf *sw-looping* t)
+ #+nah (dolist (p *sw-pending*)
+ (destructuring-bind (heldup . holdup) p
+ (dump-dependency-path holdup heldup)))
+ #+nah (dolist (p *sw-pending*)
+ (destructuring-bind (heldup . holdup) p
+ (declare (ignorable heldup))
+ (when t ;; (trcp holdup)
+ (dump-stale-path holdup))))
+ (break "trigger ~a stuck; cant lose pendings ~a"
+ c-originating
+ *sw-pending*))
+
+ ;; (trc "after sweep sw-pending" *sw-pending*)
+ ;; (cellbrk)
+ ))
+ (when c-originating
+ (setf (cv-setting-p c-originating) nil))
+ (trc nil "<<<< with-dataflow-management:" c-originating)))))
+
+(defun dump-stale-path (used)
+ (c-assert used)
+ (when (typep used 'c-dependent)
+ (loop with any
+ for used-used in (cd-useds used)
+ when (dump-stale-path used-used)
+ do (progn
+ (setf any t)
+ (trc "stale-path" used :uses... used-used))
+ finally
+ (when (or any (cd-stale-p used))
+ (trc "stale" used)
+ (return any)))))
+
+(defun dump-dependency-path (used user)
+ (c-assert (and used user))
+ (if (eql used user)
+ (progn
+ (trc "bingo---------------")
+ (trc "user" user :uses...)
+ t)
+ (let (any)
+ (dolist (used-user (cd-users used) any)
+ (when (dump-dependency-path used-user user)
+ (setf any t)
+ (trc "user" used-user :uses... used))))))
+
+(defun c-pending-set (c newvalue debug-tag)
+ (declare (ignorable debug-tag))
+ (c-assert (find c (cells (c-model c)) :key #'cdr))
+ (when newvalue (trc nil "still pending!!!!!!!!!!!!!!!!!!" c newvalue debug-tag))
+ (if newvalue
+ (bif (known (assoc c *sw-pending*))
+ (cond
+ ((eq newvalue (cdr known))
+ (break "hunh? re-pending ~a on same holdup ~a?" c (cdr known)))
+ ((c-true-stalep (cdr known))
+ (break "hunh? pending ~a on second holdup ~a as well as ~a?" c newvalue (cdr known)))
+ (t
+ (trc nil "re-pending ~a on new holdup ~a, last ok: ~a" c newvalue (assoc c *sw-pending*))
+ (rplacd known newvalue))) ;; risky business, might need whole new assoc entry
+ (let ((newpending (cons c newvalue)))
+ (progn
+ (c-assert (typep c 'c-dependent))
+ (c-assert (not (eq :eternal-rest (md-state (c-model c)))))
+ ;;(trc nil "pending on, genealogy holdup: held, holder:" debug-tag c newvalue)
+ ;;(dump-pending)
+ )
+ ;;; hunh?> (pushnew newpending *sw-pending* :test #'equal)
+ (push newpending *sw-pending*)))
+ (bwhen (p (assoc c *sw-pending*))
+ (trc nil "clear from sw-pending" debug-tag c (remove-if (lambda (p)
+ (not (eql c (car p))))
+ *sw-pending*))
+ (setf *sw-pending* (delete (assoc c *sw-pending*) *sw-pending*))
+ (progn
+ (trc nil "pending off, genealogy holdup: held, holder:" debug-tag p
+ (count c *sw-pending* :key #'car))
+ (dump-pending))
+ ))
+ newvalue)
+
+(defmethod sw-pending ((c cell))
+ (assoc c *sw-pending*))
+
+(defmethod sw-pending ((s synapse))
+ (sw-pending (syn-used s)))
+
+
Index: cells/debug.lisp
diff -u cells/debug.lisp:1.1.1.1 cells/debug.lisp:1.2
--- cells/debug.lisp:1.1.1.1 Sat Nov 8 18:44:00 2003
+++ cells/debug.lisp Tue Dec 16 10:02:58 2003
@@ -1,268 +1,263 @@
-;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
-;;;
-;;; Copyright © 1995,2003 by Kenneth William Tilton.
-;;;
-;;; Permission is hereby granted, free of charge, to any person obtaining a copy
-;;; of this software and associated documentation files (the "Software"), to deal
-;;; in the Software without restriction, including without limitation the rights
-;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-;;; copies of the Software, and to permit persons to whom the Software is furnished
-;;; to do so, subject to the following conditions:
-;;;
-;;; The above copyright notice and this permission notice shall be included in
-;;; all copies or substantial portions of the Software.
-;;;
-;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
-;;; IN THE SOFTWARE.
-
-(in-package :cells)
-
-(defun cellstop ()
- ;; (break "in-cell-stop")
- (setf *stop* t))
-
-(defun cellbrk (&optional (tag :anon))
- (unless (or *stop*)
- ;; daring move, hoping having handler at outside stops the game (cellstop)
- (print `(cell break , tag))
- (break)))
-
-;----------- trc -------------------------------------------
-
-(defun trcdepth-reset ()
- (setf *trcdepth* 0))
-
-(defmacro trc (tgtform &rest os)
- (if (eql tgtform 'nil)
- '(progn)
- (if (stringp tgtform)
- `(without-c-dependency
- (call-trc t ,tgtform , at os))
- (let ((tgt (gensym)))
- `(without-c-dependency
- (bif (,tgt ,tgtform)
- (if (trcp ,tgt)
- (progn
- (assert (stringp ,(car os)))
- (call-trc t , at os)) ;;,(car os) ,tgt ,@(cdr os)))
- (progn
- (break)
- (count-it :trcfailed)))
- (count-it :tgtnileval)))))))
-
-(defun call-trc (stream s &rest os)
- (if #+cormanlisp nil #-cormanlisp (and (boundp '*trcdepth*)
- *trcdepth*)
- (format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*)
- (format stream "~&"))
-
- (format stream "~a" s)
- (let (pkwp)
- (dolist (o os)
- (format stream (if pkwp " ~s" " | ~s") o)
- (setf pkwp (keywordp o))))
- (values))
-
-(defun call-trc-to-string (fmt$ &rest fmtargs)
- (let ((o$ (make-array '(0) :element-type 'base-char
- :fill-pointer 0 :adjustable t)))
- (with-output-to-string (ostream o$)
- (apply 'call-trc ostream fmt$ fmtargs))
- o$))
-
-#+findtrcevalnils
-(defmethod trcp :around (other)
- (unless (call-next-method other)(break)))
-
-(defmethod trcp (other)
- (eq other t))
-
-(defmethod trcp (($ string))
- t)
-
-(defun trcdepth-incf ()
- (incf *trcdepth*))
-
-(defun trcdepth-decf ()
- (format t "decrementing trc depth" *trcdepth*)
- (decf *trcdepth*))
-
-(defmacro wtrc ((&optional (min 1) (max 50) &rest banner) &body body )
- `(let ((*trcdepth* (if *trcdepth*
- (1+ *trcdepth*)
- 0)))
- ,(when banner `(when (>= *trcdepth* ,min)
- (if (< *trcdepth* ,max)
- (trc , at banner)
- (progn
- (break "excess trace notttt!!! ~d" *trcdepth*) ;; , at banner)
- nil))))
- (when (< *trcdepth* ,max)
- , at body)))
-
-(defmacro wnotrc ((&optional (min 1) (max 50) &rest banner) &body body )
- (declare (ignore min max banner))
- `(progn , at body))
-
-;------ eko --------------------------------------
-
-
-(defmacro eko ((&rest trcargs) &rest body)
- (let ((result (gensym)))
- `(let ((,result , at body))
- (trc ,(car trcargs) :=> ,result ,@(cdr trcargs))
- ,result)))
-
-(defmacro ek (label &rest body)
- (let ((result (gensym)))
- `(let ((,result (, at body)))
- (when ,label
- (trc ,label ,result))
- ,result)))
-
-;------------- counting ---------------------------
-(defvar *count* nil)
-(defvar *counting* nil)
-
-(defmacro with-counts ((onp &rest msg) &body body)
- `(if ,onp
- (prog2
- (progn
- (count-clear , at msg)
- (push t *counting*))
- (progn , at body)
- (pop *counting*)
- (show-count t , at msg))
- (progn , at body)))
-
-(defun count-clear (&rest msg)
- (declare (ignorable msg))
- (format t "~&count-clear > ~a" msg)
- (setf *count* nil))
-
-(defmacro count-it (&rest keys)
- `(when *counting*
- (call-count-it , at keys)))
-
-(defun call-count-it (&rest keys)
- (declare (ignorable keys))
- ;;; (when (eql :TGTNILEVAL (car keys))(break))
- (let ((entry (assoc keys *count* :test #'equal)))
- (if entry
- (setf (cdr entry) (1+ (cdr entry)))
- (push (cons keys 1) *count*))))
-
-(defun show-count (clearp &rest msg)
- (format t "~&Counts after: clearp ~a, length ~d: ~s" clearp (length *count*) msg)
- (let ((res (sort (copy-list *count*) (lambda (v1 v2)
- (let ((v1$ (symbol-name (caar v1)))
- (v2$ (symbol-name (caar v2))))
- (if (string= v1$ v2$)
- (< (cdr v1) (cdr v2))
- (string< v1$ v2$))))))
- )
- (loop for entry in res
- for occs = (cdr entry)
- when (plusp occs)
- sum occs into running
- and do (format t "~&~4d ... ~2d ... ~s" running occs (car entry))))
- (when clearp (count-clear "show-count")))
-
-#+test
-(loop for entry in '((a . 10)(b . 5)(c . 0)(e . -20)(d . 2))
- for occs = (cdr entry)
- when (plusp occs)
- sum occs into running
- and do (print (list entry occs running)))
-
-
-;-------------------- timex ---------------------------------
-
-;;;(defmacro timex ((onp &rest trcArgs) &body body)
-;;; `(if ,onp
-;;; (prog1
-;;; (time
-;;; (progn , at body))
-;;; (trc "timing was of" , at trcARgs))
-;;; (progn , at body)))
-
-
-;---------------- Metrics -------------------
-
-(defmacro with-metrics ((countp timep &rest trcargs) &body body)
- `(with-counts (,countp , at trcargs)
- (timex (,timep , at trcargs)
- , at body)))
-
-
-; -------- cell conditions (not much used) ---------------------------------------------
-
-(define-condition xcell () ;; new 2k0227
- ((cell :initarg :cell :reader cell :initform nil)
- (appfunc :initarg :appfunc :reader appfunc :initform 'badcell)
- (errortext :initarg :errortext :reader errortext :initform "<???>")
- (otherdata :initarg :otherdata :reader otherdata :initform "<nootherdata>"))
- (:report (lambda (c s)
- (format s "~& trouble with cell ~a in function ~s,~s: ~s"
- (cell c) (appfunc c) (errortext c) (otherdata c)))))
-
-(define-condition c-enabling ()
- ((name :initarg :name :reader name)
- (model :initarg :model :reader model)
- (cell :initarg :cell :reader cell))
- (:report (lambda (condition stream)
- (format stream "~&unhandled <c-enabling>: ~s" condition)
- (break "~&i say, unhandled <c-enabling>: ~s" condition))))
-
-(define-condition c-fatal (xcell)
- ((name :initarg :name :reader name)
- (model :initarg :model :reader model)
- (cell :initarg :cell :reader cell))
- (:report (lambda (condition stream)
- (format stream "~&fatal cell programming error: ~s" condition)
- (format stream "~& : ~s" (name condition))
- (format stream "~& : ~s" (model condition))
- (format stream "~& : ~s" (cell condition)))))
-
-(define-condition c-unadopted (c-fatal)
- ()
- (:report
- (lambda (condition stream)
- (format stream "~&unadopted cell >: ~s" (cell condition))
- (format stream "~& >: often you mis-edit (c? (c? ...)) nesting is error"))))
-
-
-;----------------------------- link debugging -----------------------
-
-
-(defun dump-users (c &optional (depth 0))
- (format t "~&~v,4t~s" depth c)
- (dolist (user (un-users c))
- (dump-users user (+ 1 depth))))
-
-(defun dump-useds (c &optional (depth 0))
- ;(c.trc "dump-useds> entry " c (+ 1 depth))
- (when (zerop depth)
- (format t "x~&"))
- (format t "~&|usd> ~v,8t~s" depth c)
- (when (typep c 'c-ruled)
- ;(c.trc "its ruled" c)
- (dolist (used (cd-useds c))
- (dump-useds used (+ 1 depth)))))
-
-
-(defun cell-reset ()
- (setf *count* nil
- *stop* nil
- *dbg* nil
- *mybreak* nil
- *c-prop-depth* 0
- *sw-looping* nil
- *to-be-awakened* nil
- *trcdepth* 0))
-
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+(defun cellbrk (&optional (tag :anon))
+ (unless (or (c-stopped))
+ ;; daring move, hoping having handler at outside stops the game (cellstop)
+ (print `(cell break , tag))
+ (break)))
+
+;----------- trc -------------------------------------------
+
+(defun trcdepth-reset ()
+ (setf *trcdepth* 0))
+
+(defmacro trc (tgtform &rest os)
+ (if (eql tgtform 'nil)
+ '(progn)
+ (if (stringp tgtform)
+ `(without-c-dependency
+ (call-trc t ,tgtform , at os))
+ (let ((tgt (gensym)))
+ `(without-c-dependency
+ (bif (,tgt ,tgtform)
+ (if (trcp ,tgt)
+ (progn
+ (c-assert (stringp ,(car os)))
+ (call-trc t , at os)) ;;,(car os) ,tgt ,@(cdr os)))
+ (progn
+ ;;; (break)
+ (count-it :trcfailed)))
+ (count-it :tgtnileval)))))))
+
+(defun call-trc (stream s &rest os)
+ (if #+cormanlisp nil #-cormanlisp (and (boundp '*trcdepth*)
+ *trcdepth*)
+ (format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*)
+ (format stream "~&"))
+
+ (format stream "~a" s)
+ (let (pkwp)
+ (dolist (o os)
+ (format stream (if pkwp " ~s" " | ~s") o)
+ (setf pkwp (keywordp o))))
+ (values))
+
+(defun call-trc-to-string (fmt$ &rest fmtargs)
+ (let ((o$ (make-array '(0) :element-type 'base-char
+ :fill-pointer 0 :adjustable t)))
+ (with-output-to-string (ostream o$)
+ (apply 'call-trc ostream fmt$ fmtargs))
+ o$))
+
+#+findtrcevalnils
+(defmethod trcp :around (other)
+ (unless (call-next-method other)(break)))
+
+(defmethod trcp (other)
+ (eq other t))
+
+(defmethod trcp (($ string))
+ t)
+
+(defun trcdepth-incf ()
+ (incf *trcdepth*))
+
+(defun trcdepth-decf ()
+ (format t "decrementing trc depth" *trcdepth*)
+ (decf *trcdepth*))
+
+(defmacro wtrc ((&optional (min 1) (max 50) &rest banner) &body body )
+ `(let ((*trcdepth* (if *trcdepth*
+ (1+ *trcdepth*)
+ 0)))
+ ,(when banner `(when (>= *trcdepth* ,min)
+ (if (< *trcdepth* ,max)
+ (trc , at banner)
+ (progn
+ (break "excess trace notttt!!! ~d" *trcdepth*) ;; , at banner)
+ nil))))
+ (when (< *trcdepth* ,max)
+ , at body)))
+
+(defmacro wnotrc ((&optional (min 1) (max 50) &rest banner) &body body )
+ (declare (ignore min max banner))
+ `(progn , at body))
+
+;------ eko --------------------------------------
+
+
+(defmacro eko ((&rest trcargs) &rest body)
+ (let ((result (gensym)))
+ `(let ((,result , at body))
+ (trc ,(car trcargs) :=> ,result ,@(cdr trcargs))
+ ,result)))
+
+(defmacro ek (label &rest body)
+ (let ((result (gensym)))
+ `(let ((,result (, at body)))
+ (when ,label
+ (trc ,label ,result))
+ ,result)))
+
+;------------- counting ---------------------------
+(defvar *count* nil)
+(defvar *counting* nil)
+
+(defmacro with-counts ((onp &rest msg) &body body)
+ `(if ,onp
+ (prog2
+ (progn
+ (count-clear , at msg)
+ (push t *counting*))
+ (progn , at body)
+ (pop *counting*)
+ (show-count t , at msg))
+ (progn , at body)))
+
+(defun count-clear (&rest msg)
+ (declare (ignorable msg))
+ (format t "~&count-clear > ~a" msg)
+ (setf *count* nil))
+
+(defmacro count-it (&rest keys)
+ `(when *counting*
+ (call-count-it , at keys)))
+
+(defun call-count-it (&rest keys)
+ (declare (ignorable keys))
+ ;;; (when (eql :TGTNILEVAL (car keys))(break))
+ (let ((entry (assoc keys *count* :test #'equal)))
+ (if entry
+ (setf (cdr entry) (1+ (cdr entry)))
+ (push (cons keys 1) *count*))))
+
+(defun show-count (clearp &rest msg)
+ (format t "~&Counts after: clearp ~a, length ~d: ~s" clearp (length *count*) msg)
+ (let ((res (sort (copy-list *count*) (lambda (v1 v2)
+ (let ((v1$ (symbol-name (caar v1)))
+ (v2$ (symbol-name (caar v2))))
+ (if (string= v1$ v2$)
+ (< (cdr v1) (cdr v2))
+ (string< v1$ v2$))))))
+ )
+ (loop for entry in res
+ for occs = (cdr entry)
+ when (plusp occs)
+ sum occs into running
+ and do (format t "~&~4d ... ~2d ... ~s" running occs (car entry))))
+ (when clearp (count-clear "show-count")))
+
+#+test
+(loop for entry in '((a . 10)(b . 5)(c . 0)(e . -20)(d . 2))
+ for occs = (cdr entry)
+ when (plusp occs)
+ sum occs into running
+ and do (print (list entry occs running)))
+
+
+;-------------------- timex ---------------------------------
+
+(defmacro timex ((onp &rest trcArgs) &body body)
+ `(if ,onp
+ (prog1
+ (time
+ (progn , at body))
+ (trc "timing was of" , at trcARgs))
+ (progn , at body)))
+
+
+;---------------- Metrics -------------------
+
+(defmacro with-metrics ((countp timep &rest trcargs) &body body)
+ `(with-counts (,countp , at trcargs)
+ (timex (,timep , at trcargs)
+ , at body)))
+
+
+; -------- cell conditions (not much used) ---------------------------------------------
+
+(define-condition xcell () ;; new 2k0227
+ ((cell :initarg :cell :reader cell :initform nil)
+ (appfunc :initarg :appfunc :reader appfunc :initform 'badcell)
+ (errortext :initarg :errortext :reader errortext :initform "<???>")
+ (otherdata :initarg :otherdata :reader otherdata :initform "<nootherdata>"))
+ (:report (lambda (c s)
+ (format s "~& trouble with cell ~a in function ~s,~s: ~s"
+ (cell c) (appfunc c) (errortext c) (otherdata c)))))
+
+(define-condition c-enabling ()
+ ((name :initarg :name :reader name)
+ (model :initarg :model :reader model)
+ (cell :initarg :cell :reader cell))
+ (:report (lambda (condition stream)
+ (format stream "~&unhandled <c-enabling>: ~s" condition)
+ (break "~&i say, unhandled <c-enabling>: ~s" condition))))
+
+(define-condition c-fatal (xcell)
+ ((name :initarg :name :reader name)
+ (model :initarg :model :reader model)
+ (cell :initarg :cell :reader cell))
+ (:report (lambda (condition stream)
+ (format stream "~&fatal cell programming error: ~s" condition)
+ (format stream "~& : ~s" (name condition))
+ (format stream "~& : ~s" (model condition))
+ (format stream "~& : ~s" (cell condition)))))
+
+(define-condition c-unadopted (c-fatal)
+ ()
+ (:report
+ (lambda (condition stream)
+ (format stream "~&unadopted cell >: ~s" (cell condition))
+ (format stream "~& >: often you mis-edit (c? (c? ...)) nesting is error"))))
+
+
+;----------------------------- link debugging -----------------------
+
+
+(defun dump-users (c &optional (depth 0))
+ (format t "~&~v,4t~s" depth c)
+ (dolist (user (c-users c))
+ (dump-users user (+ 1 depth))))
+
+(defun dump-useds (c &optional (depth 0))
+ ;(c.trc "dump-useds> entry " c (+ 1 depth))
+ (when (zerop depth)
+ (format t "x~&"))
+ (format t "~&|usd> ~v,8t~s" depth c)
+ (when (typep c 'c-ruled)
+ ;(c.trc "its ruled" c)
+ (dolist (used (cd-useds c))
+ (dump-useds used (+ 1 depth)))))
+
+
+(defun cell-reset ()
+ (setf *count* nil
+ *stop* nil
+ *dbg* nil
+ *c-break* nil
+ *c-prop-depth* 0
+ *sw-looping* nil
+ *to-be-awakened* nil
+ *trcdepth* 0))
\ No newline at end of file
Index: cells/defmodel.lisp
diff -u cells/defmodel.lisp:1.1.1.1 cells/defmodel.lisp:1.2
--- cells/defmodel.lisp:1.1.1.1 Sat Nov 8 18:44:00 2003
+++ cells/defmodel.lisp Tue Dec 16 10:02:58 2003
@@ -1,121 +1,121 @@
-;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
-;;;
-;;; Copyright © 1995,2003 by Kenneth William Tilton.
-;;;
-;;; Permission is hereby granted, free of charge, to any person obtaining a copy
-;;; of this software and associated documentation files (the "Software"), to deal
-;;; in the Software without restriction, including without limitation the rights
-;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-;;; copies of the Software, and to permit persons to whom the Software is furnished
-;;; to do so, subject to the following conditions:
-;;;
-;;; The above copyright notice and this permission notice shall be included in
-;;; all copies or substantial portions of the Software.
-;;;
-;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
-;;; IN THE SOFTWARE.
-
-(in-package :cells)
-
-(defmacro defmodel (class directsupers slotspecs &rest options)
- ;;(print `(defmodel sees directsupers ,directsupers using ,(or directsupers :model-object)))
- `(progn
- (eval-when (:compile-toplevel :execute :load-toplevel)
- (setf (get ',class :cell-defs) nil))
- ;
- ; define slot macros before class so they can appear in initforms and default-initargs
- ;
- ,@(mapcar (lambda (slotspec)
- (destructuring-bind
- (slotname &rest slotargs
- &key (cell t) accessor reader
- &allow-other-keys)
- slotspec
- (declare (ignorable slotargs))
- (when cell
- (let* ((readerfn (or reader accessor))
- (deriverfn (intern$ "^" (symbol-name readerfn)))
- )
- ;
- ; may as well do this here...
- ;
- ;;(trc nil "slot, deriverfn would be" slotname deriverfn)
- `(eval-when (:compile-toplevel :execute :load-toplevel)
- (setf (md-slot-cell-type ',class ',slotname) ,cell)
- (unless (macro-function ',deriverfn)
- (defmacro ,deriverfn (&optional (model 'self) synfactory)
- `(let ((*synapse-factory* ,synfactory))
- (,',readerfn ,model))))
- )
- ))
- ))
- slotspecs)
-
- ;
- ; ------- defclass --------------- (^slot-value ,model ',',slotname)
- ;
-
- (progn
- (defclass ,class ,(or directsupers '(model-object));; now we can def the class
- ,(mapcar (lambda (s)
- (list* (car s)
- (let ((ias (cdr s)))
- (remf ias :cell)
- (remf ias :cwhen)
- (remf ias :unchanged-if)
- ias))) (mapcar #'copy-list slotspecs))
- (:documentation
- ,@(or (cdr (find :documentation options :key #'car))
- '("chya")))
- (:default-initargs ;; nil ok and needed: acl oddity in re not clearing d-i's sans this
- ,@(cdr (find :default-initargs options :key #'car)))
- (:metaclass ,(or (find :metaclass options :key #'car)
- 'standard-class)))
-
- (defmethod shared-initialize :after ((self ,class) slot-names &rest iargs)
- (declare (ignore slot-names iargs))
- ,(when (and directsupers (not (member 'model-object directsupers)))
- `(unless (typep self 'model-object)
- (error "If no superclass of ~a inherits directly
-or indirectly from model-object, model-object must be included as a direct super-class in
-the defmodel form for ~a" ',class ',class))))
- ;
- ; slot accessors once class is defined...
- ;
- ,@(mapcar (lambda (slotspec)
- (destructuring-bind
- (slotname &rest slotargs
- &key (cell t) unchanged-if accessor reader writer type
- &allow-other-keys)
- slotspec
- (declare (ignorable slotargs))
- (when cell
- (let* ((readerfn (or reader accessor))
- (writerfn (or writer accessor))
- )
- (setf (md-slot-cell-type class slotname) cell)
-
- `(progn
- ,(when readerfn
- `(defmethod ,readerfn ((self ,class))
- (md-slot-value self ',slotname)))
-
- ,(when writerfn
- `(defmethod (setf ,writerfn) (new-value (self ,class))
- (setf (md-slot-value self ',slotname)
- ,(if type
- `(coerce new-value ',type)
- 'new-value))))
-
- ,(when unchanged-if
- `(def-c-unchanged-test (,class ,slotname)))
- )
- ))
- ))
- slotspecs)
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+(defmacro defmodel (class directsupers slotspecs &rest options)
+ ;;(print `(defmodel sees directsupers ,directsupers using ,(or directsupers :model-object)))
+ `(progn
+ (eval-when (:compile-toplevel :execute :load-toplevel)
+ (setf (get ',class :cell-types) nil))
+ ;
+ ; define slot macros before class so they can appear in initforms and default-initargs
+ ;
+ ,@(mapcar (lambda (slotspec)
+ (destructuring-bind
+ (slotname &rest slotargs
+ &key (cell t) accessor reader
+ &allow-other-keys)
+ slotspec
+ (declare (ignorable slotargs))
+ (when cell
+ (let* ((readerfn (or reader accessor))
+ (deriverfn (intern$ "^" (symbol-name readerfn)))
+ )
+ ;
+ ; may as well do this here...
+ ;
+ ;;(trc nil "slot, deriverfn would be" slotname deriverfn)
+ `(eval-when (:compile-toplevel :execute :load-toplevel)
+ (setf (md-slot-cell-type ',class ',slotname) ,cell)
+ (unless (macro-function ',deriverfn)
+ (defmacro ,deriverfn (&optional (model 'self) synfactory)
+ `(let ((*synapse-factory* ,synfactory))
+ (,',readerfn ,model))))
+ )
+ ))
+ ))
+ slotspecs)
+
+ ;
+ ; ------- defclass --------------- (^slot-value ,model ',',slotname)
+ ;
+
+ (progn
+ (defclass ,class ,(or directsupers '(model-object));; now we can def the class
+ ,(mapcar (lambda (s)
+ (list* (car s)
+ (let ((ias (cdr s)))
+ (remf ias :cell)
+ (remf ias :cwhen)
+ (remf ias :unchanged-if)
+ ias))) (mapcar #'copy-list slotspecs))
+ (:documentation
+ ,@(or (cdr (find :documentation options :key #'car))
+ '("chya")))
+ (:default-initargs ;; nil ok and needed: acl oddity in re not clearing d-i's sans this
+ ,@(cdr (find :default-initargs options :key #'car)))
+ (:metaclass ,(or (find :metaclass options :key #'car)
+ 'standard-class)))
+
+ (defmethod shared-initialize :after ((self ,class) slot-names &rest iargs)
+ (declare (ignore slot-names iargs))
+ ,(when (and directsupers (not (member 'model-object directsupers)))
+ `(unless (typep self 'model-object)
+ (error "If no superclass of ~a inherits directly
+or indirectly from model-object, model-object must be included as a direct super-class in
+the defmodel form for ~a" ',class ',class))))
+ ;
+ ; slot accessors once class is defined...
+ ;
+ ,@(mapcar (lambda (slotspec)
+ (destructuring-bind
+ (slotname &rest slotargs
+ &key (cell t) unchanged-if accessor reader writer type
+ &allow-other-keys)
+ slotspec
+ (declare (ignorable slotargs))
+ (when cell
+ (let* ((readerfn (or reader accessor))
+ (writerfn (or writer accessor))
+ )
+ (setf (md-slot-cell-type class slotname) cell)
+
+ `(progn
+ ,(when readerfn
+ `(defmethod ,readerfn ((self ,class))
+ (md-slot-value self ',slotname)))
+
+ ,(when writerfn
+ `(defmethod (setf ,writerfn) (new-value (self ,class))
+ (setf (md-slot-value self ',slotname)
+ ,(if type
+ `(coerce new-value ',type)
+ 'new-value))))
+
+ ,(when unchanged-if
+ `(def-c-unchanged-test (,class ,slotname) ,unchanged-if))
+ )
+ ))
+ ))
+ slotspecs)
(find-class ',class))))
Index: cells/detritus.lisp
diff -u cells/detritus.lisp:1.1.1.1 cells/detritus.lisp:1.2
--- cells/detritus.lisp:1.1.1.1 Sat Nov 8 18:44:05 2003
+++ cells/detritus.lisp Tue Dec 16 10:02:58 2003
@@ -1,49 +1,49 @@
-;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
-;;;
-;;; Copyright © 1995,2003 by Kenneth William Tilton.
-;;;
-;;; Permission is hereby granted, free of charge, to any person obtaining a copy
-;;; of this software and associated documentation files (the "Software"), to deal
-;;; in the Software without restriction, including without limitation the rights
-;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-;;; copies of the Software, and to permit persons to whom the Software is furnished
-;;; to do so, subject to the following conditions:
-;;;
-;;; The above copyright notice and this permission notice shall be included in
-;;; all copies or substantial portions of the Software.
-;;;
-;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
-;;; IN THE SOFTWARE.
-
-(in-package :cells)
-
-(defvar *dbg*)
-
-(defmacro wdbg (&body body)
- `(let ((*dbg* t))
- , at body))
-
-#+clisp
-(defun slot-definition-name (slot)
- (clos::slotdef-name slot))
-
-(defmethod class-slot-named ((classname symbol) slotname)
- (class-slot-named (find-class classname) slotname))
-
-(defmethod class-slot-named (class slotname)
- (find slotname (class-slots class) :key #'slot-definition-name))
-
-#+mcl
-(defun class-slots (c)
- (nconc (copy-list (class-class-slots c))
- (copy-list (class-instance-slots c))))
-
-(defun true (it) (declare (ignore it)) t)
-(defun false (it) (declare (ignore it)))
-(defun xor (c1 c2)
- (if c1 (not c2) c2))
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+(defvar *dbg*)
+
+(defmacro wdbg (&body body)
+ `(let ((*dbg* t))
+ , at body))
+
+#+clisp
+(defun slot-definition-name (slot)
+ (clos::slotdef-name slot))
+
+(defmethod class-slot-named ((classname symbol) slotname)
+ (class-slot-named (find-class classname) slotname))
+
+(defmethod class-slot-named (class slotname)
+ (find slotname (class-slots class) :key #'slot-definition-name))
+
+#+mcl
+(defun class-slots (c)
+ (nconc (copy-list (class-class-slots c))
+ (copy-list (class-instance-slots c))))
+
+(defun true (it) (declare (ignore it)) t)
+(defun false (it) (declare (ignore it)))
+(defun xor (c1 c2)
+ (if c1 (not c2) c2))
Index: cells/family-values.lisp
diff -u cells/family-values.lisp:1.1.1.1 cells/family-values.lisp:1.2
--- cells/family-values.lisp:1.1.1.1 Sat Nov 8 18:44:05 2003
+++ cells/family-values.lisp Tue Dec 16 10:02:58 2003
@@ -1,105 +1,105 @@
-;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
-;;;
-;;; Copyright © 1995,2003 by Kenneth William Tilton.
-;;;
-;;; Permission is hereby granted, free of charge, to any person obtaining a copy
-;;; of this software and associated documentation files (the "Software"), to deal
-;;; in the Software without restriction, including without limitation the rights
-;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-;;; copies of the Software, and to permit persons to whom the Software is furnished
-;;; to do so, subject to the following conditions:
-;;;
-;;; The above copyright notice and this permission notice shall be included in
-;;; all copies or substantial portions of the Software.
-;;;
-;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
-;;; IN THE SOFTWARE.
-
-(in-package :cells)
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(family-values family-values-sorted
- sortindex sortdirection sortpredicate sortkey
- ^sortindex ^sortdirection ^sortpredicate ^sortkey)))
-
-(defmodel family-values (family)
- (
- (kvcollector :initarg :kvcollector
- :initform #'identity
- :reader kvcollector)
-
- (kidvalues :cell t
- :initform (c? (when (kvcollector self)
- (funcall (kvcollector self) (^mdvalue))))
- :accessor kidvalues
- :initarg :kidvalues)
-
- (kvkey :initform #'identity
- :initarg :kvkey
- :reader kvkey)
-
- (kvkeytest :initform #'equal
- :initarg :kvkeytest
- :reader kvkeytest)
-
- (kidfactory :cell t
- :initform #'identity
- :initarg :kidfactory
- :reader kidfactory)
-
- (.kids :cell t
- :initform (c? (assert (listp (kidvalues self)))
- (let ((newkids (mapcan (lambda (kidvalue)
- (list (or (find kidvalue .cache
- :key (kvkey self)
- :test (kvkeytest self))
- (trc nil "family-values forced to make new kid"
- self .cache kidvalue)
- (funcall (kidfactory self) self kidvalue))))
- (^kidvalues))))
- (nconc (mapcan (lambda (oldkid)
- (unless (find oldkid newkids)
- (when (fv-kid-keep self oldkid)
- (list oldkid))))
- .cache)
- newkids)))
- :accessor kids
- :initarg :kids)))
-
-(defmethod fv-kid-keep (family oldkid)
- (declare (ignorable family oldkid))
- nil)
-
-(defmodel family-values-sorted (family-values)
- ((sortedkids :initarg :sortedkids :accessor sortedkids
- :initform nil)
- (sortmap :initform (cv nil) :initarg :sortmap :accessor sortmap)
- (.kid-slots :cell t
- :initform (c? (assert (listp (kidvalues self)))
- (mapsort (^sortmap)
- (thekids
- (mapcar (lambda (kidvalue)
- (trc "making kid" kidvalue)
- (or (find kidvalue .cache :key (kvkey self) :test (kvkeytest self))
- (trc nil "family-values forced to make new kid" self .cache kidvalue)
- (funcall (kidfactory self) self kidvalue)))
- (^kidvalues)))))
- :accessor kid-slots
- :initarg :kid-slots)))
-
-(defun mapsort (map data)
- ;;(trc "mapsort map" map)
- (if map
- (stable-sort data #'< :key (lambda (datum) (or (position datum map)
- ;(trc "mapsort datum not in map" datum)
- (1+ (length data)))))
- data))
-
-(def-c-echo sortedkids ()
- (setf (sortmap self) new-value)) ;; cellular trick to avoid cyclicity
-
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(family-values family-values-sorted
+ sortindex sortdirection sortpredicate sortkey
+ ^sortindex ^sortdirection ^sortpredicate ^sortkey)))
+
+(defmodel family-values (family)
+ (
+ (kvcollector :initarg :kvcollector
+ :initform #'identity
+ :reader kvcollector)
+
+ (kidvalues :cell t
+ :initform (c? (when (kvcollector self)
+ (funcall (kvcollector self) (^md-value))))
+ :accessor kidvalues
+ :initarg :kidvalues)
+
+ (kvkey :initform #'identity
+ :initarg :kvkey
+ :reader kvkey)
+
+ (kvkeytest :initform #'equal
+ :initarg :kvkeytest
+ :reader kvkeytest)
+
+ (kidfactory :cell t
+ :initform #'identity
+ :initarg :kidfactory
+ :reader kidfactory)
+
+ (.kids :cell t
+ :initform (c? (c-assert (listp (kidvalues self)))
+ (let ((newkids (mapcan (lambda (kidvalue)
+ (list (or (find kidvalue .cache
+ :key (kvkey self)
+ :test (kvkeytest self))
+ (trc nil "family-values forced to make new kid"
+ self .cache kidvalue)
+ (funcall (kidfactory self) self kidvalue))))
+ (^kidvalues))))
+ (nconc (mapcan (lambda (oldkid)
+ (unless (find oldkid newkids)
+ (when (fv-kid-keep self oldkid)
+ (list oldkid))))
+ .cache)
+ newkids)))
+ :accessor kids
+ :initarg :kids)))
+
+(defmethod fv-kid-keep (family oldkid)
+ (declare (ignorable family oldkid))
+ nil)
+
+(defmodel family-values-sorted (family-values)
+ ((sortedkids :initarg :sortedkids :accessor sortedkids
+ :initform nil)
+ (sortmap :initform (cv nil) :initarg :sortmap :accessor sortmap)
+ (.kids :cell t
+ :initform (c? (c-assert (listp (kidvalues self)))
+ (mapsort (^sortmap)
+ (thekids
+ (mapcar (lambda (kidvalue)
+ (trc "making kid" kidvalue)
+ (or (find kidvalue .cache :key (kvkey self) :test (kvkeytest self))
+ (trc nil "family-values forced to make new kid" self .cache kidvalue)
+ (funcall (kidfactory self) self kidvalue)))
+ (^kidvalues)))))
+ :accessor kids
+ :initarg :kids)))
+
+(defun mapsort (map data)
+ ;;(trc "mapsort map" map)
+ (if map
+ (stable-sort data #'< :key (lambda (datum) (or (position datum map)
+ ;(trc "mapsort datum not in map" datum)
+ (1+ (length data)))))
+ data))
+
+(def-c-echo sortedkids ()
+ (setf (sortmap self) new-value)) ;; cellular trick to avoid cyclicity
+
Index: cells/family.lisp
diff -u cells/family.lisp:1.1.1.1 cells/family.lisp:1.2
--- cells/family.lisp:1.1.1.1 Sat Nov 8 18:44:05 2003
+++ cells/family.lisp Tue Dec 16 10:02:58 2003
@@ -1,240 +1,261 @@
-;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
-;;;
-;;; Copyright © 1995,2003 by Kenneth William Tilton.
-;;;
-;;; Permission is hereby granted, free of charge, to any person obtaining a copy
-;;; of this software and associated documentation files (the "Software"), to deal
-;;; in the Software without restriction, including without limitation the rights
-;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-;;; copies of the Software, and to permit persons to whom the Software is furnished
-;;; to do so, subject to the following conditions:
-;;;
-;;; The above copyright notice and this permission notice shall be included in
-;;; all copies or substantial portions of the Software.
-;;;
-;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
-;;; IN THE SOFTWARE.
-
-(in-package :cells)
-
-(eval-when (:compile-toplevel :execute :load-toplevel)
- (export '(model mdvalue family kids kid1 perishable)))
-
-(defmodel model ()
- ((.mdvalue :initform nil :accessor mdvalue :initarg :mdvalue)))
-
-(defmodel perishable ()
- ((expiration :initform nil :accessor expiration :initarg :expiration)))
-
-(def-c-echo expiration ()
- (when new-value
- (not-to-be self)))
-
-(defmodel family (model)
- ((.kids :cell t
- :initform (cv nil) ;; most useful
- :accessor kids
- :initarg :kids)
- (.kid-slots :cell t
- :initform nil
- :accessor kid-slots
- :initarg :kid-slots)))
-
-(defmacro thekids (&rest kids)
- `(packed-flat! ,@(mapcar (lambda (kid)
- (typecase kid
- (keyword `(make-instance ',(intern$ (symbol-name kid))))
- (t `,kid)))
- kids)))
-
-(defmacro thekids2 (&rest kids)
- `(packed-flat! ,@(mapcar (lambda (kid)
- (typecase kid
- (keyword `(make-instance ',(intern$ (symbol-name kid))))
- (t `,kid)))
- kids)))
-
-(defun kid1 (self) (car (kids self)))
-
-;; /// redundancy in following
-
-(defmacro psib (&optional (selfform 'self))
- (let ((self (gensym)))
- `(bwhen (,self ,selfform)
- (find-prior ,self (kids (fmparent ,self))))))
-
-(defmacro nsib (&optional (selfform 'self))
- (let ((self (gensym)))
- `(bwhen (,self ,selfform)
- (cadr (member ,self (kids (fmparent ,self)))))))
-
-(defmacro ^priorSib (self)
- (let ((kid (gensym)))
- `(let* ((,kid ,self))
- (find-prior ,kid (^kids (fmParent ,kid))))))
-
-(defmacro ^firstKidP (self)
- (let ((kid (gensym)))
- `(let ((,kid ,self))
- (eql ,kid (car (^kids (fmParent ,kid)))))))
-
-(defmacro ^lastKidP (self)
- (let ((kid (gensym)))
- `(let ((,kid ,self))
- (null (cdr (member ,kid (^kids (fmParent ,kid))))))))
-
-(defun md-adopt (fmparent self)
- (assert self)
- (assert fmparent)
- (assert (typep fmparent 'family))
-
- (trc nil "md-adopt >" :by fmparent)
-
- (let ((currparent (fmparent self))
- (selftype (type-of self)))
- (assert (or (null currparent)
- (eql fmparent currparent)))
- (unless (plusp (adopt-ct self))
- (incf (adopt-ct self))
- (setf (fmparent self) fmparent)
-
- (bwhen (kid-slots-fn (kid-slots (fmparent self)))
- (dolist (ksdef (funcall kid-slots-fn self) self)
- (let ((slot-name (ksname ksdef)))
- (trc nil "got ksdef " slot-name)
- (when (md-slot-cell-type selftype slot-name)
- (trc nil "got cell type " slot-name)
- (when (or (not (ksifmissing ksdef))
- (and (null (c-slot-value self slot-name))
- (null (md-slot-cell self slot-name))))
- (trc nil "ks missing ok " slot-name)
- (multiple-value-bind (c-or-value suppressp)
- (funcall (ksrule ksdef) self)
- (unless suppressp
- (trc nil "c-install " slot-name c-or-value)
- (c-install self slot-name c-or-value))))))))
-
- ; new for 12/02...
- (md-adopt-kids self)))
- self)
-
-(defmethod md-adopt-kids (self) (declare (ignorable self)))
-(defmethod md-adopt-kids ((self family))
- (when (slot-boundp self '.kids)
- (dolist (k (slot-value self '.kids))
- (unless (fmParent k)
- (md-adopt self k)))))
-
-
-
-
-(defmethod c-slot-value ((self model-object) slot)
- (slot-value self slot))
-
-(defun md-kids-change (self new-kids old-kids usage)
- (assert (listp new-kids))
- (assert (listp old-kids))
- (assert (not (member nil old-kids)))
- (assert (not (member nil new-kids)))
-
- (trc nil "md-kids-change > entry" usage new-kids old-kids)
- #+nah (when (and (trcp (car new-kids))
- (eql usage :md-slot-value-assume))
- (break "how here? ~a" self))
-
- (dolist (k old-kids)
- (unless (member k new-kids)
- (trc nil "kids change nailing lost kid" k)
- (not-to-be k)
- (setf (fmparent k) nil) ;; 020302kt unnecessary? anyway, after not-to-be since that might require fmparent
- ))
-
- (dolist (k new-kids)
- (unless (member k old-kids)
- (if (eql :nascent (md-state k))
- (progn
- #+dfdbg (trc k "adopting par,k:" self k)
- (md-adopt self k))
- (unless (eql self (fmParent k))
- ;; 230126 recent changes to kids handling leads to dup kids-change calls
- (trc "feature not yet implemented: adopting previously adopted: parent, kid" self (type-of k))
- (trc "old" old-kids)
- (trc "new" new-kids)
- (break "bad state extant nkid ~a ~a ~a" usage k (md-state k))
- )))))
-
-(def-c-echo .kids ((self family))
- (dolist (k new-value)
- (to-be k)))
-
-(defun md-reinitialize (self)
- (unless (eql (md-state self) :nascent)
- (setf (md-state self) :nascent)
- (md-reinitialize-primary self)))
-
-(defmethod md-reinitialize-primary :after ((self family))
- (dolist (kid (slot-value self '.kids)) ;; caused re-entrance to c? (kids self))
- (md-reinitialize kid)))
-
-(defmethod md-reinitialize-primary (self)
- (cellbrk)
- (md-map-cells self nil (lambda (c)
- (setf (c-waking-state c) nil)
- (when (typep c 'c-ruled)
- (setf (c-state c) :unbound)))))
-
-(defmethod kids ((other model-object)) nil)
-
-(defmethod not-to-be :before ((fm family))
- (unless (md-untouchable fm)
- (trc nil "(not-to-be :before family) not closed stream, backdooropen; kids c-awake; kids c-state"
- *svuc-backdoor-open*
- (if (md-slot-cell fm '.kids)
- (c-waking-state (md-slot-cell fm '.kids))
- :no-kids-cell)
- (when (md-slot-cell fm '.kids)
- (c-state (md-slot-cell fm 'kids))))
- ;; use backdoor so if kids not yet ruled into
- ;; existence they won't be now just to not-to-be them
- (let ((svkids (slot-value fm '.kids)))
- (when (listp svkids)
- (dolist ( kid svkids)
- (not-to-be kid)))))
-
- (trc nil "(not-to-be :before family) exit, kids state" (when (md-slot-cell fm 'kids)
- (c-state (md-slot-cell fm 'kids)))))
-
-
-;------------------ kid slotting ----------------------------
-;
-(cc-defstruct (kid-slotdef
- (:conc-name nil))
- ksname
- ksrule
- (ksifmissing t))
-
-(defmacro mk-kid-slot ((ksname &key ifmissing) ksrule)
- `(make-kid-slotdef
- :ksname ',ksname
- :ksrule (lambda (self)
- (declare (ignorable self))
- ,ksrule)
- :ksifmissing ,ifmissing))
-
-(defmacro def-kid-slots (&rest slot-defs)
- `(lambda (self)
- (declare (ignorable self))
- (list , at slot-defs)))
-
-(defmethod md-name (symbol)
- symbol)
-
-(defmethod md-name ((nada null))
- (unless *stop*
- (setq *stop* t)
- (break "md-name called on nil")))
\ No newline at end of file
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+(eval-when (:compile-toplevel :execute :load-toplevel)
+ (export '(model md-value family kids kid1 perishable)))
+
+(defmodel model ()
+ ((.md-name :cell nil :initform nil :initarg :md-name :accessor md-name)
+ (.fm-parent :cell nil :initform nil :initarg :fm-parent :accessor fm-parent)
+ (.md-value :initform nil :accessor md-value :initarg :md-value)))
+
+(defmethod print-object ((self model) s)
+ (format s "~a" (or (md-name self) (type-of self))))
+
+(define-symbol-macro .parent (fm-parent self))
+
+(defmethod md-initialize :around ((self model))
+ (when (slot-boundp self '.md-name)
+ (unless (md-name self)
+ (setf (md-name self) (c-class-name (class-of self)))))
+
+ (when (fm-parent self)
+ (md-adopt (fm-parent self) self))
+
+ (call-next-method))
+
+(defmodel perishable ()
+ ((expiration :initform nil :accessor expiration :initarg :expiration)))
+
+(def-c-echo expiration ()
+ (when new-value
+ (not-to-be self)))
+
+(defmodel family (model)
+ ((.kid-slots :cell nil
+ :initform nil
+ :accessor kid-slots
+ :initarg :kid-slots)
+ (.kids :initform (cv nil) ;; most useful
+ :accessor kids
+ :initarg :kids)
+ ))
+
+(defmacro thekids (&rest kids)
+ `(packed-flat! ,@(mapcar (lambda (kid)
+ (typecase kid
+ (keyword `(make-instance ',(intern$ (symbol-name kid))))
+ (t `,kid)))
+ kids)))
+
+(defmacro thekids2 (&rest kids)
+ `(packed-flat! ,@(mapcar (lambda (kid)
+ (typecase kid
+ (keyword `(make-instance ',(intern$ (symbol-name kid))))
+ (t `,kid)))
+ kids)))
+
+(defun kid1 (self) (car (kids self)))
+(defun lastkid (self) (last1 (kids self)))
+
+;; /// redundancy in following
+
+(defmacro psib (&optional (selfform 'self))
+ (let ((self (gensym)))
+ `(bwhen (,self ,selfform)
+ (find-prior ,self (kids (fm-parent ,self))))))
+
+(defmacro nsib (&optional (selfform 'self))
+ (let ((self (gensym)))
+ `(bwhen (,self ,selfform)
+ (cadr (member ,self (kids (fm-parent ,self)))))))
+
+(defmacro ^priorSib (self)
+ (let ((kid (gensym)))
+ `(let* ((,kid ,self))
+ (find-prior ,kid (^kids (fm-parent ,kid))))))
+
+(defmacro ^firstKidP (self)
+ (let ((kid (gensym)))
+ `(let ((,kid ,self))
+ (eql ,kid (car (^kids (fm-parent ,kid)))))))
+
+(defmacro ^lastKidP (self)
+ (let ((kid (gensym)))
+ `(let ((,kid ,self))
+ (null (cdr (member ,kid (^kids (fm-parent ,kid))))))))
+
+(defun md-adopt (fm-parent self)
+ (c-assert self)
+ (c-assert fm-parent)
+ (c-assert (typep fm-parent 'family))
+
+
+ (trc nil "md-adopt >" :kid self (adopt-ct self) :by fm-parent)
+
+ (let ((currparent (fm-parent self))
+ (selftype (type-of self)))
+ (c-assert (or (null currparent)
+ (eql fm-parent currparent)))
+ ;; (when (plusp (adopt-ct self))(c-break "2nd adopt ~a, by ~a" self fm-parent))
+ (unless (plusp (adopt-ct self))
+ (incf (adopt-ct self))
+ (setf (fm-parent self) fm-parent)
+
+ (bwhen (kid-slots-fn (kid-slots (fm-parent self)))
+ (dolist (ksdef (funcall kid-slots-fn self) self)
+ (let ((slot-name (ksname ksdef)))
+ (trc nil "got ksdef " slot-name)
+ (when (md-slot-cell-type selftype slot-name)
+ (trc fm-parent "got cell type " slot-name)
+ (when (or (not (ksifmissing ksdef))
+ (and (null (c-slot-value self slot-name))
+ (null (md-slot-cell self slot-name))))
+ (trc fm-parent "ks missing ok " slot-name)
+ (multiple-value-bind (c-or-value suppressp)
+ (funcall (ksrule ksdef) self)
+ (unless suppressp
+ (trc fm-parent "c-install " slot-name c-or-value)
+ (c-install self slot-name c-or-value))))))))
+
+ ; new for 12/02...
+ (md-adopt-kids self)))
+ self)
+
+(defmethod md-adopt-kids (self) (declare (ignorable self)))
+(defmethod md-adopt-kids ((self family))
+ (when (slot-boundp self '.kids)
+ (dolist (k (slot-value self '.kids))
+ (unless (fm-parent k)
+ (md-adopt self k)))))
+
+
+
+
+(defmethod c-slot-value ((self model-object) slot)
+ (slot-value self slot))
+
+(defun md-kids-change (self new-kids old-kids usage)
+ (c-assert (listp new-kids))
+ (c-assert (listp old-kids))
+ (c-assert (not (member nil old-kids)))
+ (c-assert (not (member nil new-kids)))
+
+ (trc nil "md-kids-change > entry" usage new-kids old-kids)
+ #+nah (when (and (trcp (car new-kids))
+ (eql usage :md-slot-value-assume))
+ (break "how here? ~a" self))
+
+ (dolist (k old-kids)
+ (unless (member k new-kids)
+ (trc nil "kids change nailing lost kid" k)
+ (not-to-be k)
+ (setf (fm-parent k) nil) ;; 020302kt unnecessary? anyway, after not-to-be since that might require fm-parent
+ ))
+
+ (dolist (k new-kids)
+ (unless (member k old-kids)
+ (if (eql :nascent (md-state k))
+ (progn
+ #+dfdbg (trc k "adopting par,k:" self k)
+ (md-adopt self k))
+ (unless (eql self (fm-parent k))
+ ;; 230126 recent changes to kids handling leads to dup kids-change calls
+ (trc "feature not yet implemented: adopting previously adopted: parent, kid" self (type-of k))
+ (trc "old" old-kids)
+ (trc "new" new-kids)
+ (break "bad state extant nkid ~a ~a ~a" usage k (md-state k))
+ )))))
+
+(def-c-echo .kids ((self family))
+ (dolist (k new-value)
+ (to-be k)))
+
+(defun md-reinitialize (self)
+ (unless (eql (md-state self) :nascent)
+ (setf (md-state self) :nascent)
+ (md-reinitialize-primary self)))
+
+(defmethod md-reinitialize-primary :after ((self family))
+ (dolist (kid (slot-value self '.kids)) ;; caused re-entrance to c? (kids self))
+ (md-reinitialize kid)))
+
+(defmethod md-reinitialize-primary (self)
+ (cellbrk)
+ (md-map-cells self nil (lambda (c)
+ (setf (c-waking-state c) nil)
+ (when (typep c 'c-ruled)
+ (setf (c-state c) :unbound)))))
+
+(defmethod kids ((other model-object)) nil)
+
+(defmethod not-to-be :before ((fm family))
+ (unless (md-untouchable fm)
+ (trc nil "(not-to-be :before family) not closed stream, backdooropen; kids c-awake; kids c-state"
+ *svuc-backdoor-open*
+ (if (md-slot-cell fm '.kids)
+ (c-waking-state (md-slot-cell fm '.kids))
+ :no-kids-cell)
+ (when (md-slot-cell fm '.kids)
+ (c-state (md-slot-cell fm 'kids))))
+ ;; use backdoor so if kids not yet ruled into
+ ;; existence they won't be now just to not-to-be them
+ (let ((svkids (slot-value fm '.kids)))
+ (when (listp svkids)
+ (dolist ( kid svkids)
+ (not-to-be kid)))))
+
+ (trc nil "(not-to-be :before family) exit, kids state" (when (md-slot-cell fm 'kids)
+ (c-state (md-slot-cell fm 'kids)))))
+
+
+;------------------ kid slotting ----------------------------
+;
+(defstruct (kid-slotdef
+ (:conc-name nil))
+ ksname
+ ksrule
+ (ksifmissing t))
+
+(defmacro mk-kid-slot ((ksname &key ifmissing) ksrule)
+ `(make-kid-slotdef
+ :ksname ',ksname
+ :ksrule (lambda (self)
+ (declare (ignorable self))
+ ,ksrule)
+ :ksifmissing ,ifmissing))
+
+(defmacro def-kid-slots (&rest slot-defs)
+ `(lambda (self)
+ (declare (ignorable self))
+ (list , at slot-defs)))
+
+(defmethod md-name (symbol)
+ symbol)
+
+(defmethod md-name ((nada null))
+ (unless (c-stopped)
+ (c-stop :md-name-on-null)
+ (break "md-name called on nil")))
+
Index: cells/flow-control.lisp
diff -u cells/flow-control.lisp:1.1.1.1 cells/flow-control.lisp:1.2
--- cells/flow-control.lisp:1.1.1.1 Sat Nov 8 18:44:17 2003
+++ cells/flow-control.lisp Tue Dec 16 10:02:58 2003
@@ -1,169 +1,155 @@
-;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
-;;;
-;;;
-;;; Copyright © 1995,2003 by Kenneth William Tilton.
-;;;
-;;; Permission is hereby granted, free of charge, to any person obtaining a copy
-;;; of this software and associated documentation files (the "Software"), to deal
-;;; in the Software without restriction, including without limitation the rights
-;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-;;; copies of the Software, and to permit persons to whom the Software is furnished
-;;; to do so, subject to the following conditions:
-;;;
-;;; The above copyright notice and this permission notice shall be included in
-;;; all copies or substantial portions of the Software.
-;;;
-;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
-;;; IN THE SOFTWARE.
-
-(in-package :cells)
-
-(defmacro maxf (place &rest othervalues)
- `(setf ,place (max ,place , at othervalues)))
-
-(defun last1 (thing)
- (car (last thing)))
-
-(defun max-if (&rest values)
- (loop for x in values when x maximize x))
-
-(defun min-max-of (v1 v2)
- (values (min-if v1 v2) (max-if v1 v2)))
-
-(defun min-if (v1 v2)
- (if v1 (if v2 (min v1 v2) v1) v2))
-
-(defun list-flatten! (&rest list)
- (if (consp list)
- (let (head work visited)
- (labels ((link (cell)
- ;;(format t "~&Link > cons: ~s . ~s" (car cell) (cdr cell))
- (when (and (consp cell)
- (member cell visited))
- (break "list-flatten! detects infinite list: cell ~a, visited ~a" cell visited))
- (push cell visited)
-
- (when cell
- (if (consp (car cell))
- (link (car cell))
- (progn
- (setf head (or head cell))
- (when work
- (rplacd work cell))
- (setf work cell)))
- (link (rest cell)))))
- (link list))
- head)
- list))
-
-(defun packed-flat! (&rest uNameit)
- (delete-if #'null (list-flatten! uNameIt)))
-
-(defmacro with-dynamic-fn ((fnName (&rest fnArgs) &body fnBody) &body body)
- `(let ((,fnName (lambda ,fnArgs , at fnBody)))
- (declare (dynamic-extent ,fnname))
- , at body))
-
-(eval-when (compile load eval)
- (export 'myAssert))
-
-(defmacro myAssert (assertion &optional places fmt$ &rest fmtargs)
- (declare (ignore places))
-
- `(unless *stop*
- (unless ,assertion
- (setf *stop* t)
- ,(if fmt$
- `(mybreak ,fmt$ , at fmtargs)
- `(mybreak "failed assertion:" ',assertion)))))
-
-(defvar *mybreak*)
-
-(defun mybreak (&rest args)
- (unless (or *mybreak* *stop*)
- (setf *mybreak* t)
- (setf *stop* t)
- (format t "mybreak > stopping > ~a" args)
- (apply #'break args)))
-
-(defun assocv (sym assoc)
- (cdr (assoc sym assoc)))
-
-(defmacro assocv-setf (assoc-place sym-form v)
- (let ((sym (gensym))(entry (gensym)))
- `(let ((,sym ,sym-form))
- (bIf (,entry (assoc ,sym ,assoc-place))
- (rplacd ,entry ,v)
- (push (cons ,sym ,v) ,assoc-place)))))
-
-(defun intern$ (&rest strings)
- (intern (apply #'concatenate 'string (mapcar #'string-upcase strings))))
-
-#-allegro
-(defmacro until (test &body body)
- `(LOOP (WHEN ,test (RETURN)) , at body))
-
-#-allegro
-(defmacro while (test &body body)
- `(LOOP (unless ,test (RETURN)) , at body))
-
-(defmacro bwhen ((bindvar boundform) &body body)
- `(let ((,bindvar ,boundform))
- (when ,bindvar
- , at body)))
-
-(defmacro bif ((bindvar boundform) yup &optional nope)
- `(let ((,bindvar ,boundform))
- (if ,bindvar
- ,yup
- ,nope)))
-
-(defmacro maptimes ((nvar count) &body body)
- `(loop for ,nvar below ,count
- collecting (progn , at body)))
-
-; --- cloucell support for struct access of slots ------------------------
-
-(eval-when (:compile-toplevel :execute :load-toplevel)
- (export '(cc-defstruct instance-slots)))
-
-(defmacro cc-defstruct (header &rest slots)
- (let (name concname (cache (gensym)))
- (if (consp header)
- (destructuring-bind (hname &rest options)
- header
- (setf name hname)
- (setf concname (bIf (concoption (find :conc-name options :key #'car))
- (unless (eql (second concoption) 'nil)
- (second concoption))
- (intern (concatenate 'string
- (symbol-name hname)
- "-")))))
- (progn
- (setf name header)
- (setf concname (intern (concatenate 'string
- (symbol-name header) "-")))))
-
- (let ((cc-info (mapcar (lambda (s)
- (let ((sn (if (consp s)
- (car s) s)))
- (cons sn
- (intern (concatenate 'string
- (when concname (symbol-name concname))
- (symbol-name sn))))))
- slots)))
- `(progn
- (defstruct ,header , at slots)
- (let (,cache)
- (defmethod instance-slots ((self ,name))
- (or ,cache (setf ,cache (append (call-next-method) ',cc-info)))))
- ))))
-
-(defmethod instance-slots (root)
- (declare (ignorable root)))
-
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+(defmacro maxf (place &rest othervalues)
+ `(setf ,place (max ,place , at othervalues)))
+
+(defun last1 (thing)
+ (car (last thing)))
+
+(defun max-if (&rest values)
+ (loop for x in values when x maximize x))
+
+(defun min-max-of (v1 v2)
+ (values (min-if v1 v2) (max-if v1 v2)))
+
+(defun min-if (v1 v2)
+ (if v1 (if v2 (min v1 v2) v1) v2))
+
+(defun list-flatten! (&rest list)
+ (if (consp list)
+ (let (head work visited)
+ (labels ((link (cell)
+ ;;(format t "~&Link > cons: ~s . ~s" (car cell) (cdr cell))
+ (when (and (consp cell)
+ (member cell visited))
+ (break "list-flatten! detects infinite list: cell ~a, visited ~a" cell visited))
+ (push cell visited)
+
+ (when cell
+ (if (consp (car cell))
+ (link (car cell))
+ (progn
+ (setf head (or head cell))
+ (when work
+ (rplacd work cell))
+ (setf work cell)))
+ (link (rest cell)))))
+ (link list))
+ head)
+ list))
+
+(defun packed-flat! (&rest uNameit)
+ (delete-if #'null (list-flatten! uNameIt)))
+
+(defmacro with-dynamic-fn ((fnName (&rest fnArgs) &body fnBody) &body body)
+ `(let ((,fnName (lambda ,fnArgs , at fnBody)))
+ (declare (dynamic-extent ,fnname))
+ , at body))
+
+(defvar *c-break*)
+
+(defun c-break (&rest args)
+ (unless (or *c-break* *stop*)
+ (setf *c-break* t)
+ (c-stop args)
+ (format t "c-break > stopping > ~a" args)
+ (apply #'break args)))
+
+(defmacro assocv-setf (assoc-place sym-form v-form)
+ (let ((sym (gensym))(entry (gensym))(v (gensym)))
+ `(let* ((,sym ,sym-form)
+ (,v ,v-form))
+ (bIf (,entry (assoc ,sym ,assoc-place))
+ (rplacd ,entry ,v)
+ (push (cons ,sym ,v) ,assoc-place))
+ ,v)))
+
+(defun intern$ (&rest strings)
+ (intern (apply #'concatenate 'string (mapcar #'string-upcase strings))))
+
+#-allegro
+(defmacro until (test &body body)
+ `(LOOP (WHEN ,test (RETURN)) , at body))
+
+#-allegro
+(defmacro while (test &body body)
+ `(LOOP (unless ,test (RETURN)) , at body))
+
+(defmacro bwhen ((bindvar boundform) &body body)
+ `(let ((,bindvar ,boundform))
+ (when ,bindvar
+ , at body)))
+
+(defmacro bif ((bindvar boundform) yup &optional nope)
+ `(let ((,bindvar ,boundform))
+ (if ,bindvar
+ ,yup
+ ,nope)))
+
+(defmacro maptimes ((nvar count) &body body)
+ `(loop for ,nvar below ,count
+ collecting (progn , at body)))
+
+; --- cloucell support for struct access of slots ------------------------
+
+(eval-when (:compile-toplevel :execute :load-toplevel)
+ (export '(cc-defstruct instance-slots)))
+
+(defmacro cc-defstruct (header &rest slots)
+ (let (name concname (cache (gensym)))
+ (if (consp header)
+ (destructuring-bind (hname &rest options)
+ header
+ (setf name hname)
+ (setf concname (bIf (concoption (find :conc-name options :key #'car))
+ (unless (eql (second concoption) 'nil)
+ (second concoption))
+ (intern (concatenate 'string
+ (symbol-name hname)
+ "-")))))
+ (progn
+ (setf name header)
+ (setf concname (intern (concatenate 'string
+ (symbol-name header) "-")))))
+
+ (let ((cc-info (mapcar (lambda (s)
+ (let ((sn (if (consp s)
+ (car s) s)))
+ (cons sn
+ (intern (concatenate 'string
+ (when concname (symbol-name concname))
+ (symbol-name sn))))))
+ slots)))
+ `(progn
+ (defstruct ,header , at slots)
+ (let (,cache)
+ (defmethod instance-slots ((self ,name))
+ (or ,cache (setf ,cache (append (call-next-method) ',cc-info)))))
+ ))))
+
+(defmethod instance-slots (root)
+ (declare (ignorable root)))
+
Index: cells/fm-utilities.lisp
diff -u cells/fm-utilities.lisp:1.1.1.1 cells/fm-utilities.lisp:1.2
--- cells/fm-utilities.lisp:1.1.1.1 Sat Nov 8 18:44:17 2003
+++ cells/fm-utilities.lisp Tue Dec 16 10:02:58 2003
@@ -1,557 +1,557 @@
-;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
-;;;
-;;; Copyright © 1995,2003 by Kenneth William Tilton.
-;;;
-;;; Permission is hereby granted, free of charge, to any person obtaining a copy
-;;; of this software and associated documentation files (the "Software"), to deal
-;;; in the Software without restriction, including without limitation the rights
-;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-;;; copies of the Software, and to permit persons to whom the Software is furnished
-;;; to do so, subject to the following conditions:
-;;;
-;;; The above copyright notice and this permission notice shall be included in
-;;; all copies or substantial portions of the Software.
-;;;
-;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
-;;; IN THE SOFTWARE.
-
-(in-package :cells)
-
-(defparameter *fmdbg* nil)
-
-(eval-when (compile eval load)
- (export '(make-part mkpart fm-other fm-traverse fm-descendant-typed do-like-fm-parts
- container-typed *fmdbg*)))
-
-(defun make-part (partname partclass &rest initargs)
- ;;(trc "make-part > name class" partname partclass)
- (when partclass ;;a little programmer friendliness
- (apply #'make-instance partclass :md-name partname initargs)))
-
-(defmacro mkpart (md-name (mdclass) &rest initargs)
- `(make-part ',md-name ',mdclass , at initargs))
-
-(defmethod make-partspec ((partclass symbol))
- (make-part partclass partclass))
-
-(defmethod make-partspec ((part model))
- part)
-
-(defmacro upper (self &optional (type t))
- `(container-typed ,self ',type))
-
-(defmethod container (self) (fmparent self))
-
-(defmethod container-typed ((self model-object) type)
- (assert self)
- (let ((parent (container self))) ;; fm- or ps-parent
- (cond
- ((null parent) nil)
- ((typep parent type) parent)
- (t (container-typed parent type)))))
-
-(defun fm-descendant-typed (self type)
- (when self
- (or (find-if (lambda (k) (typep k type)) (kids self))
- (some (lambda (k)
- (fm-descendant-typed k type)) (kids self)))))
-
-(defun fm-descendant-named (parent name &key (must-find t))
- (fm-find-one parent name :must-find must-find :global-search nil))
-
-(defun fm-ascendant-named (parent name)
- (when parent
- (or (when (eql (md-name parent) name)
- parent)
- (fm-ascendant-named (fmparent parent) name))))
-
-(defun fm-ascendant-typed (parent name)
- (when parent
- (or (when (typep parent name)
- parent)
- (fm-ascendant-typed (fmparent parent) name))))
-
-(defun fm-ascendant-some (parent somefunction)
- (when (and parent somefunction)
- (or (funcall somefunction parent)
- (fm-ascendant-some (fmparent parent) somefunction))))
-
-(defun fm-ascendant-if (self iffunction)
- (when (and self iffunction)
- (or (when (funcall iffunction self)
- self)
- (fm-ascendant-if .parent iffunction))))
-
-(defun fm-ascendant-common (d1 d2)
- (fm-ascendant-some d1 (lambda (node)
- (when (fm-includes node d2)
- node))))
-
-(defun fm-collect-if (tree test)
- (let (collection)
- (fm-traverse tree (lambda (node)
- (when (funcall test node)
- (push node collection))))
- (nreverse collection)))
-
-(defun fm-max (tree key)
- (let (max)
- (fm-traverse tree (lambda (node)
- (if max
- (setf max (max max (funcall key node)))
- (setf max (funcall key node))))
- :global-search nil)
- max))
-
-
-(defun fm-traverse (family applied-fn &key skipnode skiptree (global-search t) (opaque nil))
- (progn ;; wtrc (0 1600 "fm-traverse2" family)
- (labels ((tv-family (fm skippee)
- (when *fmdbg* (trc "tv-family" fm))
-
- (when (and (typep fm 'model-object)
- (not (eql fm skippee)))
- (let ((outcome (unless (eql skipnode fm)
- (funcall applied-fn fm))))
- (unless (and outcome opaque)
- (dolist (kid (sub-nodes fm))
- (tv-family kid nil)))))
- (when (and (typep fm 'model-object)
- (not (eql fm skippee)))
- (let ((outcome (and (not (eql skipnode fm))
- (funcall applied-fn fm))))
- (unless (and outcome opaque)
- (dolist (kid (sub-nodes fm))
- (tv-family kid nil)))))))
-
- (loop for fm = family then (when global-search (fmparent fm))
- and skip = skiptree then fm
- unless fm return nil
- do (when *fmdbg* (print `(fm-traverse using :fm , fm :skip ,skip)))
- (tv-family fm skip)))))
-
-(defmethod sub-nodes (other)
- (declare (ignore other)))
-
-(defmethod sub-nodes ((self family))
- (kids self))
-
-(defmethod fm-ps-parent ((self model-object))
- (fmparent self))
-
-(defmacro with-like-fm-parts ((partsvar (self likeclass)) &body body)
- `(let (,partsvar)
- (fm-traverse ,self (lambda (node)
- ;;(trc "with like sees node" node (type-of node) ',likeclass)
- (when (typep node ',likeclass)
- (push node ,partsvar)))
- :skipnode ,self
- :global-search nil
- :opaque t)
- (setf ,partsvar (nreverse ,partsvar))
- (progn , at body)))
-
-(defmacro do-like-fm-parts ((partvar (self likeclass) &optional returnvar) &body body)
- `(progn
- (fm-traverse ,self (lambda (,partvar)
- (when (typep ,partvar ',likeclass)
- , at body))
- :skipnode ,self
- :global-search nil
- :opaque t)
- ,returnvar)
- )
-
-;;
-;; family member finding
-;;
-
-#|
- (defun fm-member-named (kidname kids)
- (member kidname kids :key #'md-name))
- |#
-
-(defun true-that (that) (declare (ignore that)) t)
-;;
-;; eventually fm-find-all needs a better name (as does fm-collect) and they
-;; should be modified to go through 'gather', which should be the real fm-find-all
-;;
-(defun fm-gather (family &key (test #'true-that))
- (packed-flat!
- (cons (when (funcall test family) family)
- (mapcar (lambda (fm)
- (fm-gather fm :test test))
- (kids family)))))
-
-(defun fm-find-all (family md-name &key (must-find t) (global-search t))
- (let ((matches (catch 'fm-find-all
- (with-dynamic-fn
- (traveller (family)
- (with-dynamic-fn
- (filter (kid) (eql md-name (md-name kid)))
- (let ((matches (remove-if-not filter (kids family))))
- (when matches
- (throw 'fm-find-all matches)))))
- (fm-traverse family traveller :global-search global-search)))))
- (when (and must-find (null matches))
- (setf *stop* t)
- (break "fm-find-all > *stop*ping...did not find ~a ~a ~a" family md-name global-search)
- ;; (error 'fm-not-found (list md-name family global-search))
- )
- matches))
-
-(defun fm-find-next (fm test-fn)
- (fm-find-next-within fm test-fn))
-
-(defun fm-find-next-within (fm test-fn &optional upperbound &aux (fmparent (unless (eql upperbound fm)
- (fmparent fm))))
- (let ((sibs (and fmparent (rest (member fm (kids fmparent))))))
- (or (dolist (s sibs)
- (let ((winner (fm-find-if s test-fn)))
- (when winner (return winner))))
- (if fmparent
- (fm-find-next-within fmparent test-fn upperbound)
- (fm-find-if fm test-fn)))))
-
-(defun fm-find-prior (fm test-fn)
- (fm-find-prior-within fm test-fn))
-
-(defun fm-find-prior-within (fm test-fn &optional upperbound &aux (fmparent (unless (eql upperbound fm)
- (fmparent fm))))
- (let ((sibs (and fmparent (kids fmparent))))
- (or (loop with next-ok
- for s on sibs
- for last-ok = nil then (or next-ok last-ok)
- when (eql fm (first s)) do (loop-finish)
- finally (return last-ok)
- do (setf next-ok (fm-find-last-if (car s) test-fn)))
- (if fmparent
- (fm-find-prior-within fmparent test-fn upperbound)
- (fm-find-last-if fm test-fn)))))
-
- (defun fm-find-last-if (family test-fn)
- (let ((last))
- (or (and (kids family)
- (dolist (k (kids family) last)
- (setf last (or (fm-find-last-if k test-fn) last))))
- (when (funcall test-fn family)
- family))))
-
-(defun fm-prior-sib (self &optional (test-fn #'true-that)
- &aux (kids (kids (fmparent self))))
- "Find nearest preceding sibling passing TEST-FN"
- (find-if test-fn kids :end (position self kids) :from-end t))
-
-(defun fm-next-sib-if (self test-fn)
- (some test-fn (cdr (member self (kids (fmparent self))))))
-
-(defun fm-next-sib (self)
- (car (cdr (member self (kids (fmparent self))))))
-
-(defmacro ^fm-next-sib (&optional (self 'self))
- (let ((s (gensym)))
- `(let ((,s ,self))
- (car (cdr (member ,s (^kids (fmparent ,s))))))))
-
-(defun find-prior (self sibs &key (test #'true-that))
- (assert (member self sibs)) ;; got this by accidentally having toolbar kids dependent..on second calc,
- ;; all newkids got over, and when old kids tried to recalculate...not in sibs!!
- (unless (eql self (car sibs))
- (labels
- ((fpsib (rsibs &aux (psib (car rsibs)))
- (assert rsibs () "~&find-prior > fpsib > self ~s not found to prior off" self)
- (if (eql self (cadr rsibs))
- (when (funcall test psib) psib)
- (or (fpsib (cdr rsibs))
- (when (funcall test psib) psib)))))
- (fpsib sibs))))
-
-(defun fm-find-if (family test-fn &key skiptopp) ;; 99-03 kt why is thsi depth-first?
- (assert test-fn)
- (when family
- (or (dolist (b (sub-nodes family))
- (let ((match (fm-find-if b test-fn)))
- (when match (return match))))
- (when (and (not skiptopp)
- (funcall test-fn family))
- family))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;
-;;;; family ordering
-;;;;
-(defun fm-kid-add (fmparent kid &optional before)
- (assert (or (null (fmparent kid)) (eql fmparent (fmparent kid))))
- (assert (typep fmparent 'family))
- (setf (fmparent kid) fmparent)
- (fm-kid-insert kid before))
-
-(defun fm-kid-insert-last (goal &aux (fmparent (fmparent goal)))
- (setf (kids fmparent) (nconc (kids fmparent) (list goal))))
-
-(defun fm-kid-insert-first (goal &aux (fmparent (fmparent goal)))
- (setf (kids fmparent) (cons goal (kids fmparent))))
-
-(defun fm-kid-insert (kid &optional before &aux (dakids (kids (fmparent kid))))
- (assert (or (null before) (eql (fmparent kid) (fmparent before))))
- (setf (kids (fmparent kid))
- (if before
- (if (eql before (car dakids))
- (cons kid dakids)
- (let ((cell (member before dakids)))
- (rplaca cell kid)
- (rplacd cell (cons before (cdr cell)))
- (cons (car dakids) (rest dakids))))
- (if dakids
- (progn
- (rplacd (last dakids) (cons kid nil))
- (cons (car dakids) (rest dakids)))
- (cons kid dakids)))))
-
-(defun fm-kid-remove (kid &key (quiesce t) &aux (parent (fmparent kid)))
- (when quiesce
- (fm-quiesce-all kid))
- (when parent
- (setf (kids parent) (remove kid (kids parent)))
- ;; (setf (fmparent kid) nil) gratuitous housekeeping caused ensuing focus echo
- ;; image-invalidate to fail since no access to containing window via fmparent chain
- ))
-
-(defun fm-quiesce-all (md)
- (md-quiesce md)
- (dolist (kid (kids md))
- (when (and kid (not (md-untouchable kid)))
- (fm-quiesce-all kid)))
- md)
-
-
-(defun fm-kid-replace (oldkid newkid &aux (fmparent (fmparent oldkid)))
- (assert (member oldkid (kids fmparent)) ()
- "~&oldkid ~s not amongst kids of its fmparent ~s"
- oldkid fmparent)
- (when fmparent ;; silly test given above assert--which is right?
- (assert (typep fmparent 'family))
- (setf (fmparent newkid) fmparent)
- (setf (kids fmparent) (substitute newkid oldkid (kids fmparent)))
- ;;(rplaca (member oldkid (kids fmparent)) newkid)
- newkid))
-
-;----------------------------------------------------------
-;;
-;; h i g h - o r d e r f a m i l y o p s
-;;
-;; currently not in use...someday?
-(defmacro ^fm-min-max-kid (min-max slot-name &key (default 0) test (fmparent 'self))
- (let ((best (copy-symbol 'best))
- (kid (copy-symbol 'kid))
- )
- `(let ((,best ,default))
- (dolist (,kid (^kids ,fmparent) ,best)
- ,(if test
- `(when (funcall ,test ,kid)
- (setf ,best (funcall ,min-max ,best (,slot-name ,kid))))
- `(bif (slotvalue (,slot-name ,kid))
- (setf ,best (funcall ,min-max ,best slotvalue))
- (break "nil slotvalue ~a in kid ~a of parent ~a"
- ',slot-name ,kid ,fmparent)))))))
-
-(defmacro ^fm-min-kid (slot-name &key (default 0) test (fmparent 'self))
- `(^fm-min-max-kid #'min-if ,slot-name
- :default ,default
- :test ,test
- :fmparent ,fmparent))
-
-(defmacro ^fm-max-kid (slot-name &key (default 0) test (fmparent 'self))
- `(^fm-min-max-kid #'max-if ,slot-name
- :default ,default
- :test ,test
- :fmparent ,fmparent))
-
-(defmacro ^fm-max-sib (slot-name &key (default 0) test)
- `(^fm-max-kid ,slot-name :default ,default
- :test ,test
- :fmparent (fmparent self)))
-
-(defmacro ^fm-max-sib-other (slot-name &key (default 0))
- `(with-dynamic-fn (tester (sib) (not (eql self sib)))
- (^fm-max-kid ,slot-name :default ,default
- :test tester
- :fmparent (fmparent self))))
-
-(defmacro ^sib-named (name)
- `(find ,name (^kids (fmparent self)) :key #'md-name))
-
-
-(defmacro fm-other (md-name &key (starting 'self) skiptree (test '#'true-that))
- `(fm-find-one ,starting ,(if (consp md-name)
- `(list ',(car md-name) ,(cadr md-name))
- `',md-name)
- :must-find t
- :skiptree ,skiptree
- :global-search t
- :test ,test))
-
-(defmacro fm-otherx (md-name &key (starting 'self) skiptree)
- (if (eql starting 'self)
- `(or (fm-find-one ,starting ,(if (consp md-name)
- `(list ',(car md-name) ,(cadr md-name))
- `',md-name)
- :must-find t
- :skiptree ,skiptree
- :global-search t))
- `(fm-find-one ,starting ,(if (consp md-name)
- `(list ',(car md-name) ,(cadr md-name))
- `',md-name)
- :must-find t
- :skiptree ,skiptree
- :global-search t)))
-
-(defun fm-other-v (md-name starting &optional (global-search t))
- (break)
- (fm-find-one starting md-name
- :must-find nil
- :global-search global-search))
-
-(defmacro fm-otherv? (md-name &optional (starting 'self) (global-search t))
- `(fm-other-v ,md-name ,starting ,global-search))
-
-(defmacro fm-other? (md-name &optional (starting 'self) (global-search t))
- `(fm-find-one ,starting ,(if (consp md-name)
- `(list ',(car md-name) ,(cadr md-name))
- `',md-name)
- :must-find nil
- :global-search ,global-search))
-
-(defun fm! (starting md-name &optional (global-search t))
- (fm-find-one starting md-name
- :must-find t
- :global-search global-search))
-
-(defmacro fm? (md-name &optional (starting 'self) (global-search t))
- `(fm-find-one ,starting ,(if (consp md-name)
- `(list ',(car md-name) ,(cadr md-name))
- `',md-name)
- :must-find nil
- :global-search ,global-search))
-
-(defmacro fm-other! (md-name &optional (starting 'self))
- `(fm-find-one ,starting ,(if (consp md-name)
- `(list ',(car md-name) ,(cadr md-name))
- `',md-name)
- :must-find t
- :global-search nil))
-
-(defmacro fm-other?! (md-name &optional (starting 'self))
- `(fm-find-one ,starting ,(if (consp md-name)
- `(list ',(car md-name) ,(cadr md-name))
- `',md-name)
- :must-find nil
- :global-search nil))
-
-(defmacro fm-collect (md-name &key (must-find t))
- `(fm-find-all self ',md-name :must-find ,must-find)) ;deliberate capture
-
-(defmacro fm-map (fn md-name)
- `(mapcar ,fn (fm-find-all self ',md-name))) ;deliberate capture
-
-(defmacro fm-mapc (fn md-name)
- `(mapc ,fn (fm-find-all self ',md-name))) ;deliberate capture
-
-(defun fm-pos (goal &aux (fmparent (fmparent goal)))
- (when fmparent
- (or (position goal (kids fmparent))
- (length (kids fmparent))))) ;; ?!!
-
-(defmacro fm-count-named (family md-name &key (global-search t))
- `(length (fm-find-all ,family ,md-name
- :must-find nil
- :global-search ,global-search)))
-;---------------------------------------------------------------
-
-(defun fm-top (fm &optional (test #'true-that) &aux (fmparent (fmparent fm)))
- (cond ((null fmparent) fm)
- ((not (funcall test fmparent)) fm)
- (t (fm-top fmparent test))))
-
-(defun fm-first-above (fm &key (test #'true-that) &aux (fmparent (fmparent fm)))
- (cond ((null fmparent) nil)
- ((funcall test fmparent) fmparent)
- (t (fm-first-above fmparent :test test))))
-
-(defun fm-nearest-if (test fm)
- (when fm
- (if (funcall test fm)
- fm
- (fm-nearest-if test (fmparent fm)))))
-
-(defun fm-includes (fm sought)
- (fm-ancestorp fm sought))
-
-(defun fm-ancestorp (fm sought)
- (assert fm)
- (when sought
- (or (eql fm sought)
- (fm-includes fm (fmparent sought)))))
-
-(defun fm-kid-containing (fmparent descendant)
- (with-dynamic-fn (finder (node) (not (eql fmparent node)))
- (fm-top descendant finder)))
-
-(defun make-name (root &optional subscript)
- (if subscript (list root subscript) root))
-
-(defun name-root (md-name)
- (if (atom md-name) md-name (car md-name)))
-
-(defun name-subscript (md-name)
- (when (consp md-name) (cadr md-name)))
-
-(defun fm-find-one (family md-name &key (must-find t)
- (global-search t) skiptree (test #'true-that))
- (flet ((matcher (fm)
- (trc nil "fm-find-one matcher sees" md-name fm (md-name fm))
- (when (and (eql (name-root md-name)
- (or (md-name fm) (c-class-name (class-of fm))))
- (or (null (name-subscript md-name))
- (eql (name-subscript md-name) (fm-pos fm)))
- (funcall test fm))
- (throw 'fm-find-one fm))))
- #-lispworks (declare (dynamic-extent matcher))
- (trc nil "fm-find-one> entry " md-name family)
- (let ((match (catch 'fm-find-one
- (fm-traverse family #'matcher
- :skiptree skiptree
- :global-search global-search))))
- (when (and must-find (null match))
- (trc nil "fm-find-one > erroring fm-not-found" family md-name must-find global-search)
- ;;(inspect family)
- (let ((*fmdbg* family))
- (fm-find-one family md-name :must-find nil :global-search global-search)
- (setf *stop* t)
- ;;(trc "fm-find-one > *stop*ping...did not find" family md-name global-search)
- (break "fm-find-one > *stop*ping...did not find ~a ~a ~a" family md-name global-search)
-
- ))
- match)))
-
-(defun fm-find-kid (self name)
- (find name (kids self) :key #'md-name))
-
-(defun fm-kid-typed (self type)
- (assert self)
- (find type (kids self) :key #'type-of))
-
-(defun kidno (self)
- (unless (typep self 'model-object)
- (break "not a model object ~a" self))
- (when (and self (fmparent self))
- (assert (member self (kids (fmparent self))))
- (position self (kids (fmparent self)))))
-
-
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+(defparameter *fmdbg* nil)
+
+(eval-when (compile eval load)
+ (export '(make-part mkpart fm-other fm-traverse fm-descendant-typed do-like-fm-parts
+ container-typed *fmdbg*)))
+
+(defun make-part (partname partclass &rest initargs)
+ ;;(trc "make-part > name class" partname partclass)
+ (when partclass ;;a little programmer friendliness
+ (apply #'make-instance partclass :md-name partname initargs)))
+
+(defmacro mkpart (md-name (mdclass) &rest initargs)
+ `(make-part ',md-name ',mdclass , at initargs))
+
+(defmethod make-partspec ((partclass symbol))
+ (make-part partclass partclass))
+
+(defmethod make-partspec ((part model))
+ part)
+
+(defmacro upper (self &optional (type t))
+ `(container-typed ,self ',type))
+
+(defmethod container (self) (fm-parent self))
+
+(defmethod container-typed ((self model-object) type)
+ (c-assert self)
+ (let ((parent (container self))) ;; fm- or ps-parent
+ (cond
+ ((null parent) nil)
+ ((typep parent type) parent)
+ (t (container-typed parent type)))))
+
+(defun fm-descendant-typed (self type)
+ (when self
+ (or (find-if (lambda (k) (typep k type)) (kids self))
+ (some (lambda (k)
+ (fm-descendant-typed k type)) (kids self)))))
+
+(defun fm-descendant-named (parent name &key (must-find t))
+ (fm-find-one parent name :must-find must-find :global-search nil))
+
+(defun fm-ascendant-named (parent name)
+ (when parent
+ (or (when (eql (md-name parent) name)
+ parent)
+ (fm-ascendant-named (fm-parent parent) name))))
+
+(defun fm-ascendant-typed (parent name)
+ (when parent
+ (or (when (typep parent name)
+ parent)
+ (fm-ascendant-typed (fm-parent parent) name))))
+
+(defun fm-ascendant-some (parent somefunction)
+ (when (and parent somefunction)
+ (or (funcall somefunction parent)
+ (fm-ascendant-some (fm-parent parent) somefunction))))
+
+(defun fm-ascendant-if (self iffunction)
+ (when (and self iffunction)
+ (or (when (funcall iffunction self)
+ self)
+ (fm-ascendant-if .parent iffunction))))
+
+(defun fm-ascendant-common (d1 d2)
+ (fm-ascendant-some d1 (lambda (node)
+ (when (fm-includes node d2)
+ node))))
+
+(defun fm-collect-if (tree test)
+ (let (collection)
+ (fm-traverse tree (lambda (node)
+ (when (funcall test node)
+ (push node collection))))
+ (nreverse collection)))
+
+(defun fm-max (tree key)
+ (let (max)
+ (fm-traverse tree (lambda (node)
+ (if max
+ (setf max (max max (funcall key node)))
+ (setf max (funcall key node))))
+ :global-search nil)
+ max))
+
+
+(defun fm-traverse (family applied-fn &key skipnode skiptree (global-search t) (opaque nil))
+ (progn ;; wtrc (0 1600 "fm-traverse2" family)
+ (labels ((tv-family (fm skippee)
+ (when *fmdbg* (trc "tv-family" fm))
+
+ (when (and (typep fm 'model-object)
+ (not (eql fm skippee)))
+ (let ((outcome (unless (eql skipnode fm)
+ (funcall applied-fn fm))))
+ (unless (and outcome opaque)
+ (dolist (kid (sub-nodes fm))
+ (tv-family kid nil)))))
+ (when (and (typep fm 'model-object)
+ (not (eql fm skippee)))
+ (let ((outcome (and (not (eql skipnode fm))
+ (funcall applied-fn fm))))
+ (unless (and outcome opaque)
+ (dolist (kid (sub-nodes fm))
+ (tv-family kid nil)))))))
+
+ (loop for fm = family then (when global-search (fm-parent fm))
+ and skip = skiptree then fm
+ unless fm return nil
+ do (when *fmdbg* (print `(fm-traverse using :fm , fm :skip ,skip)))
+ (tv-family fm skip)))))
+
+(defmethod sub-nodes (other)
+ (declare (ignore other)))
+
+(defmethod sub-nodes ((self family))
+ (kids self))
+
+(defmethod fm-ps-parent ((self model-object))
+ (fm-parent self))
+
+(defmacro with-like-fm-parts ((partsvar (self likeclass)) &body body)
+ `(let (,partsvar)
+ (fm-traverse ,self (lambda (node)
+ ;;(trc "with like sees node" node (type-of node) ',likeclass)
+ (when (typep node ',likeclass)
+ (push node ,partsvar)))
+ :skipnode ,self
+ :global-search nil
+ :opaque t)
+ (setf ,partsvar (nreverse ,partsvar))
+ (progn , at body)))
+
+(defmacro do-like-fm-parts ((partvar (self likeclass) &optional returnvar) &body body)
+ `(progn
+ (fm-traverse ,self (lambda (,partvar)
+ (when (typep ,partvar ',likeclass)
+ , at body))
+ :skipnode ,self
+ :global-search nil
+ :opaque t)
+ ,returnvar)
+ )
+
+;;
+;; family member finding
+;;
+
+#|
+ (defun fm-member-named (kidname kids)
+ (member kidname kids :key #'md-name))
+ |#
+
+(defun true-that (that) (declare (ignore that)) t)
+;;
+;; eventually fm-find-all needs a better name (as does fm-collect) and they
+;; should be modified to go through 'gather', which should be the real fm-find-all
+;;
+(defun fm-gather (family &key (test #'true-that))
+ (packed-flat!
+ (cons (when (funcall test family) family)
+ (mapcar (lambda (fm)
+ (fm-gather fm :test test))
+ (kids family)))))
+
+(defun fm-find-all (family md-name &key (must-find t) (global-search t))
+ (let ((matches (catch 'fm-find-all
+ (with-dynamic-fn
+ (traveller (family)
+ (with-dynamic-fn
+ (filter (kid) (eql md-name (md-name kid)))
+ (let ((matches (remove-if-not filter (kids family))))
+ (when matches
+ (throw 'fm-find-all matches)))))
+ (fm-traverse family traveller :global-search global-search)))))
+ (when (and must-find (null matches))
+ (setf *stop* t)
+ (break "fm-find-all > *stop*ping...did not find ~a ~a ~a" family md-name global-search)
+ ;; (error 'fm-not-found (list md-name family global-search))
+ )
+ matches))
+
+(defun fm-find-next (fm test-fn)
+ (fm-find-next-within fm test-fn))
+
+(defun fm-find-next-within (fm test-fn &optional upperbound &aux (fm-parent (unless (eql upperbound fm)
+ (fm-parent fm))))
+ (let ((sibs (and fm-parent (rest (member fm (kids fm-parent))))))
+ (or (dolist (s sibs)
+ (let ((winner (fm-find-if s test-fn)))
+ (when winner (return winner))))
+ (if fm-parent
+ (fm-find-next-within fm-parent test-fn upperbound)
+ (fm-find-if fm test-fn)))))
+
+(defun fm-find-prior (fm test-fn)
+ (fm-find-prior-within fm test-fn))
+
+(defun fm-find-prior-within (fm test-fn &optional upperbound &aux (fm-parent (unless (eql upperbound fm)
+ (fm-parent fm))))
+ (let ((sibs (and fm-parent (kids fm-parent))))
+ (or (loop with next-ok
+ for s on sibs
+ for last-ok = nil then (or next-ok last-ok)
+ when (eql fm (first s)) do (loop-finish)
+ finally (return last-ok)
+ do (setf next-ok (fm-find-last-if (car s) test-fn)))
+ (if fm-parent
+ (fm-find-prior-within fm-parent test-fn upperbound)
+ (fm-find-last-if fm test-fn)))))
+
+ (defun fm-find-last-if (family test-fn)
+ (let ((last))
+ (or (and (kids family)
+ (dolist (k (kids family) last)
+ (setf last (or (fm-find-last-if k test-fn) last))))
+ (when (funcall test-fn family)
+ family))))
+
+(defun fm-prior-sib (self &optional (test-fn #'true-that)
+ &aux (kids (kids (fm-parent self))))
+ "Find nearest preceding sibling passing TEST-FN"
+ (find-if test-fn kids :end (position self kids) :from-end t))
+
+(defun fm-next-sib-if (self test-fn)
+ (some test-fn (cdr (member self (kids (fm-parent self))))))
+
+(defun fm-next-sib (self)
+ (car (cdr (member self (kids (fm-parent self))))))
+
+(defmacro ^fm-next-sib (&optional (self 'self))
+ (let ((s (gensym)))
+ `(let ((,s ,self))
+ (car (cdr (member ,s (^kids (fm-parent ,s))))))))
+
+(defun find-prior (self sibs &key (test #'true-that))
+ (c-assert (member self sibs)) ;; got this by accidentally having toolbar kids dependent..on second calc,
+ ;; all newkids got over, and when old kids tried to recalculate...not in sibs!!
+ (unless (eql self (car sibs))
+ (labels
+ ((fpsib (rsibs &aux (psib (car rsibs)))
+ (c-assert rsibs () "~&find-prior > fpsib > self ~s not found to prior off" self)
+ (if (eql self (cadr rsibs))
+ (when (funcall test psib) psib)
+ (or (fpsib (cdr rsibs))
+ (when (funcall test psib) psib)))))
+ (fpsib sibs))))
+
+(defun fm-find-if (family test-fn &key skiptopp) ;; 99-03 kt why is thsi depth-first?
+ (c-assert test-fn)
+ (when family
+ (or (dolist (b (sub-nodes family))
+ (let ((match (fm-find-if b test-fn)))
+ (when match (return match))))
+ (when (and (not skiptopp)
+ (funcall test-fn family))
+ family))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; family ordering
+;;;;
+(defun fm-kid-add (fm-parent kid &optional before)
+ (c-assert (or (null (fm-parent kid)) (eql fm-parent (fm-parent kid))))
+ (c-assert (typep fm-parent 'family))
+ (setf (fm-parent kid) fm-parent)
+ (fm-kid-insert kid before))
+
+(defun fm-kid-insert-last (goal &aux (fm-parent (fm-parent goal)))
+ (setf (kids fm-parent) (nconc (kids fm-parent) (list goal))))
+
+(defun fm-kid-insert-first (goal &aux (fm-parent (fm-parent goal)))
+ (setf (kids fm-parent) (cons goal (kids fm-parent))))
+
+(defun fm-kid-insert (kid &optional before &aux (dakids (kids (fm-parent kid))))
+ (c-assert (or (null before) (eql (fm-parent kid) (fm-parent before))))
+ (setf (kids (fm-parent kid))
+ (if before
+ (if (eql before (car dakids))
+ (cons kid dakids)
+ (let ((cell (member before dakids)))
+ (rplaca cell kid)
+ (rplacd cell (cons before (cdr cell)))
+ (cons (car dakids) (rest dakids))))
+ (if dakids
+ (progn
+ (rplacd (last dakids) (cons kid nil))
+ (cons (car dakids) (rest dakids)))
+ (cons kid dakids)))))
+
+(defun fm-kid-remove (kid &key (quiesce t) &aux (parent (fm-parent kid)))
+ (when quiesce
+ (fm-quiesce-all kid))
+ (when parent
+ (setf (kids parent) (remove kid (kids parent)))
+ ;; (setf (fm-parent kid) nil) gratuitous housekeeping caused ensuing focus echo
+ ;; image-invalidate to fail since no access to containing window via fm-parent chain
+ ))
+
+(defun fm-quiesce-all (md)
+ (md-quiesce md)
+ (dolist (kid (kids md))
+ (when (and kid (not (md-untouchable kid)))
+ (fm-quiesce-all kid)))
+ md)
+
+
+(defun fm-kid-replace (oldkid newkid &aux (fm-parent (fm-parent oldkid)))
+ (c-assert (member oldkid (kids fm-parent)) ()
+ "~&oldkid ~s not amongst kids of its fm-parent ~s"
+ oldkid fm-parent)
+ (when fm-parent ;; silly test given above assert--which is right?
+ (c-assert (typep fm-parent 'family))
+ (setf (fm-parent newkid) fm-parent)
+ (setf (kids fm-parent) (substitute newkid oldkid (kids fm-parent)))
+ ;;(rplaca (member oldkid (kids fm-parent)) newkid)
+ newkid))
+
+;----------------------------------------------------------
+;;
+;; h i g h - o r d e r f a m i l y o p s
+;;
+;; currently not in use...someday?
+(defmacro ^fm-min-max-kid (min-max slot-name &key (default 0) test (fm-parent 'self))
+ (let ((best (copy-symbol 'best))
+ (kid (copy-symbol 'kid))
+ )
+ `(let ((,best ,default))
+ (dolist (,kid (^kids ,fm-parent) ,best)
+ ,(if test
+ `(when (funcall ,test ,kid)
+ (setf ,best (funcall ,min-max ,best (,slot-name ,kid))))
+ `(bif (slotvalue (,slot-name ,kid))
+ (setf ,best (funcall ,min-max ,best slotvalue))
+ (break "nil slotvalue ~a in kid ~a of parent ~a"
+ ',slot-name ,kid ,fm-parent)))))))
+
+(defmacro ^fm-min-kid (slot-name &key (default 0) test (fm-parent 'self))
+ `(^fm-min-max-kid #'min-if ,slot-name
+ :default ,default
+ :test ,test
+ :fm-parent ,fm-parent))
+
+(defmacro ^fm-max-kid (slot-name &key (default 0) test (fm-parent 'self))
+ `(^fm-min-max-kid #'max-if ,slot-name
+ :default ,default
+ :test ,test
+ :fm-parent ,fm-parent))
+
+(defmacro ^fm-max-sib (slot-name &key (default 0) test)
+ `(^fm-max-kid ,slot-name :default ,default
+ :test ,test
+ :fm-parent (fm-parent self)))
+
+(defmacro ^fm-max-sib-other (slot-name &key (default 0))
+ `(with-dynamic-fn (tester (sib) (not (eql self sib)))
+ (^fm-max-kid ,slot-name :default ,default
+ :test tester
+ :fm-parent (fm-parent self))))
+
+(defmacro ^sib-named (name)
+ `(find ,name (^kids (fm-parent self)) :key #'md-name))
+
+
+(defmacro fm-other (md-name &key (starting 'self) skiptree (test '#'true-that))
+ `(fm-find-one ,starting ,(if (consp md-name)
+ `(list ',(car md-name) ,(cadr md-name))
+ `',md-name)
+ :must-find t
+ :skiptree ,skiptree
+ :global-search t
+ :test ,test))
+
+(defmacro fm-otherx (md-name &key (starting 'self) skiptree)
+ (if (eql starting 'self)
+ `(or (fm-find-one ,starting ,(if (consp md-name)
+ `(list ',(car md-name) ,(cadr md-name))
+ `',md-name)
+ :must-find t
+ :skiptree ,skiptree
+ :global-search t))
+ `(fm-find-one ,starting ,(if (consp md-name)
+ `(list ',(car md-name) ,(cadr md-name))
+ `',md-name)
+ :must-find t
+ :skiptree ,skiptree
+ :global-search t)))
+
+(defun fm-other-v (md-name starting &optional (global-search t))
+ (break)
+ (fm-find-one starting md-name
+ :must-find nil
+ :global-search global-search))
+
+(defmacro fm-otherv? (md-name &optional (starting 'self) (global-search t))
+ `(fm-other-v ,md-name ,starting ,global-search))
+
+(defmacro fm-other? (md-name &optional (starting 'self) (global-search t))
+ `(fm-find-one ,starting ,(if (consp md-name)
+ `(list ',(car md-name) ,(cadr md-name))
+ `',md-name)
+ :must-find nil
+ :global-search ,global-search))
+
+(defun fm! (starting md-name &optional (global-search t))
+ (fm-find-one starting md-name
+ :must-find t
+ :global-search global-search))
+
+(defmacro fm? (md-name &optional (starting 'self) (global-search t))
+ `(fm-find-one ,starting ,(if (consp md-name)
+ `(list ',(car md-name) ,(cadr md-name))
+ `',md-name)
+ :must-find nil
+ :global-search ,global-search))
+
+(defmacro fm-other! (md-name &optional (starting 'self))
+ `(fm-find-one ,starting ,(if (consp md-name)
+ `(list ',(car md-name) ,(cadr md-name))
+ `',md-name)
+ :must-find t
+ :global-search nil))
+
+(defmacro fm-other?! (md-name &optional (starting 'self))
+ `(fm-find-one ,starting ,(if (consp md-name)
+ `(list ',(car md-name) ,(cadr md-name))
+ `',md-name)
+ :must-find nil
+ :global-search nil))
+
+(defmacro fm-collect (md-name &key (must-find t))
+ `(fm-find-all self ',md-name :must-find ,must-find)) ;deliberate capture
+
+(defmacro fm-map (fn md-name)
+ `(mapcar ,fn (fm-find-all self ',md-name))) ;deliberate capture
+
+(defmacro fm-mapc (fn md-name)
+ `(mapc ,fn (fm-find-all self ',md-name))) ;deliberate capture
+
+(defun fm-pos (goal &aux (fm-parent (fm-parent goal)))
+ (when fm-parent
+ (or (position goal (kids fm-parent))
+ (length (kids fm-parent))))) ;; ?!!
+
+(defmacro fm-count-named (family md-name &key (global-search t))
+ `(length (fm-find-all ,family ,md-name
+ :must-find nil
+ :global-search ,global-search)))
+;---------------------------------------------------------------
+
+(defun fm-top (fm &optional (test #'true-that) &aux (fm-parent (fm-parent fm)))
+ (cond ((null fm-parent) fm)
+ ((not (funcall test fm-parent)) fm)
+ (t (fm-top fm-parent test))))
+
+(defun fm-first-above (fm &key (test #'true-that) &aux (fm-parent (fm-parent fm)))
+ (cond ((null fm-parent) nil)
+ ((funcall test fm-parent) fm-parent)
+ (t (fm-first-above fm-parent :test test))))
+
+(defun fm-nearest-if (test fm)
+ (when fm
+ (if (funcall test fm)
+ fm
+ (fm-nearest-if test (fm-parent fm)))))
+
+(defun fm-includes (fm sought)
+ (fm-ancestorp fm sought))
+
+(defun fm-ancestorp (fm sought)
+ (c-assert fm)
+ (when sought
+ (or (eql fm sought)
+ (fm-includes fm (fm-parent sought)))))
+
+(defun fm-kid-containing (fm-parent descendant)
+ (with-dynamic-fn (finder (node) (not (eql fm-parent node)))
+ (fm-top descendant finder)))
+
+(defun make-name (root &optional subscript)
+ (if subscript (list root subscript) root))
+
+(defun name-root (md-name)
+ (if (atom md-name) md-name (car md-name)))
+
+(defun name-subscript (md-name)
+ (when (consp md-name) (cadr md-name)))
+
+(defun fm-find-one (family md-name &key (must-find t)
+ (global-search t) skiptree (test #'true-that))
+ (flet ((matcher (fm)
+ (trc nil "fm-find-one matcher sees" md-name fm (md-name fm))
+ (when (and (eql (name-root md-name)
+ (or (md-name fm) (c-class-name (class-of fm))))
+ (or (null (name-subscript md-name))
+ (eql (name-subscript md-name) (fm-pos fm)))
+ (funcall test fm))
+ (throw 'fm-find-one fm))))
+ #-lispworks (declare (dynamic-extent matcher))
+ (trc nil "fm-find-one> entry " md-name family)
+ (let ((match (catch 'fm-find-one
+ (fm-traverse family #'matcher
+ :skiptree skiptree
+ :global-search global-search))))
+ (when (and must-find (null match))
+ (trc nil "fm-find-one > erroring fm-not-found" family md-name must-find global-search)
+ ;;(inspect family)
+ (let ((*fmdbg* family))
+ (fm-find-one family md-name :must-find nil :global-search global-search)
+ (setf *stop* t)
+ ;;(trc "fm-find-one > *stop*ping...did not find" family md-name global-search)
+ (break "fm-find-one > *stop*ping...did not find ~a ~a ~a" family md-name global-search)
+
+ ))
+ match)))
+
+(defun fm-find-kid (self name)
+ (find name (kids self) :key #'md-name))
+
+(defun fm-kid-typed (self type)
+ (c-assert self)
+ (find type (kids self) :key #'type-of))
+
+(defun kid-no (self)
+ (unless (typep self 'model-object)
+ (break "not a model object ~a" self))
+ (when (and self (fm-parent self))
+ (c-assert (member self (kids (fm-parent self))))
+ (position self (kids (fm-parent self)))))
+
+
Index: cells/initialize.lisp
diff -u cells/initialize.lisp:1.1.1.1 cells/initialize.lisp:1.2
--- cells/initialize.lisp:1.1.1.1 Sat Nov 8 18:44:17 2003
+++ cells/initialize.lisp Tue Dec 16 10:02:58 2003
@@ -1,105 +1,105 @@
-;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
-;;;
-;;; Copyright © 1995,2003 by Kenneth William Tilton.
-;;;
-;;; Permission is hereby granted, free of charge, to any person obtaining a copy
-;;; of this software and associated documentation files (the "Software"), to deal
-;;; in the Software without restriction, including without limitation the rights
-;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-;;; copies of the Software, and to permit persons to whom the Software is furnished
-;;; to do so, subject to the following conditions:
-;;;
-;;; The above copyright notice and this permission notice shall be included in
-;;; all copies or substantial portions of the Software.
-;;;
-;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
-;;; IN THE SOFTWARE.
-
-(in-package :cells)
-
-(eval-when (compile eval load)
- (export '(c-envalue)))
-
-(cc-defstruct (c-envaluer (:conc-name nil))
- envaluerule
- )
-
-(defun c-awaken (c)
- (when *stop*
- (princ #\.)
- (return-from c-awaken))
-
- (assert (c-model c) () "c-awaken sees uninstalled cell" c)
-
- ; re-entry happen's normally
- ; nop it...
- ;
- (when (c-waking-state c)
- ;;(count-it :c-awaken :already)
- ;;(trc "c-awaken > already awake" c)
- (return-from c-awaken))
-
- ;;(trc "c-awaken > awakening" c)
- ;;(count-it :c-awaken)
- (setf (c-waking-state c) :awakening)
- (c-awaken-cell c)
- (setf (c-waking-state c) :awake)
- c)
-
-(defun c-ephemeral-p (c)
- (eql :ephemeral (md-slot-cell-type (type-of (c-model c)) (c-slot-name c))))
-
-(defmethod c-awaken-cell (c)
- (declare (ignorable c)))
-
-(defmethod c-awaken-cell ((c c-variable))
- (when (and (c-ephemeral-p c)
- (c-value c))
- (error "Feature not yet supported: initializing ephemeral to other than nil: [~a]"
- (c-value c)))
- ;
- ; nothing to calculate, but every cellular slot should be echoed
- ;
- (let ((v (c-value c)))
- ;;(trc (c-model c) "c-awaken > calling echo" c v (slot-value (c-model c)(c-slot-name c)))
- (when (eql '.kids (c-slot-name c))
- (md-kids-change (c-model c) v nil :c-awaken-variable))
- (c-echo-slot-name (c-slot-name c) (c-model c) v nil nil)
- (c-ephemeral-reset c)))
-
-(defmethod c-awaken-cell ((c c-ruled))
- ;
- ; ^svuc (with askers supplied) calls c-awaken, and now we call ^svuc crucially without askers
- ; this oddity comes from an incident in which an asker-free invocation of ^svuc
- ; successfully calculated when the call passing askers failed, i guess because askers not
- ; actually to be consulted given the algorithm still were detected as self-referential
- ; since the self-ref detector could not anticipate the algorithm's branching.
- ;
- (let (*c-calculators*)
- (c-calculate-and-set c)))
-
-(defmethod c-awaken-cell ((c c-dependent))
- ;
- ; satisfy CormanCL bug
- ;
- (let (*c-calculators*)
- (c-calculate-and-set c)))
-
-(defmethod c-awaken-cell ((c c-drifter))
- ;
- ; drifters *begin* valid, so the derived version's test for unbounditude
- ; would keep (drift) rule ever from being evaluated. correct solution
- ; (for another day) is to separate awakening (ie, linking to independent
- ; cs) from evaluation, tho also evaluating if necessary during
- ; awakening, because awakening's other role is to get an instance up to speed
- ; at once upon instantiation
- ;
- (c-calculate-and-set c)
- (cond ((c-validp c) (c-value c))
- ((c-unboundp c) nil)
- (t "illegal state!!!")))
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+(eval-when (compile eval load)
+ (export '(c-envalue)))
+
+(defstruct (c-envaluer (:conc-name nil))
+ envaluerule
+ )
+
+(defun c-awaken (c)
+ (when *stop*
+ (princ #\.)
+ (return-from c-awaken))
+
+ (c-assert (c-model c) () "c-awaken sees uninstalled cell" c)
+
+ ; re-entry happen's normally
+ ; nop it...
+ ;
+ (when (c-waking-state c)
+ ;;(count-it :c-awaken :already)
+ ;;(trc "c-awaken > already awake" c)
+ (return-from c-awaken))
+
+ ;;(trc "c-awaken > awakening" c)
+ ;;(count-it :c-awaken)
+ (setf (c-waking-state c) :awakening)
+ (c-awaken-cell c)
+ (setf (c-waking-state c) :awake)
+ c)
+
+(defun c-ephemeral-p (c)
+ (eql :ephemeral (md-slot-cell-type (type-of (c-model c)) (c-slot-name c))))
+
+(defmethod c-awaken-cell (c)
+ (declare (ignorable c)))
+
+(defmethod c-awaken-cell ((c c-variable))
+ (when (and (c-ephemeral-p c)
+ (c-value c))
+ (c-break "Feature not yet supported: initializing ephemeral to other than nil: [~a]"
+ (c-value c)))
+ ;
+ ; nothing to calculate, but every cellular slot should be echoed
+ ;
+ (let ((v (c-value c)))
+ ;;(trc (c-model c) "c-awaken > calling echo" c v (slot-value (c-model c)(c-slot-name c)))
+ (when (eql '.kids (c-slot-name c))
+ (md-kids-change (c-model c) v nil :c-awaken-variable))
+ (c-echo-slot-name (c-slot-name c) (c-model c) v nil nil)
+ (c-ephemeral-reset c)))
+
+(defmethod c-awaken-cell ((c c-ruled))
+ ;
+ ; ^svuc (with askers supplied) calls c-awaken, and now we call ^svuc crucially without askers
+ ; this oddity comes from an incident in which an asker-free invocation of ^svuc
+ ; successfully calculated when the call passing askers failed, i guess because askers not
+ ; actually to be consulted given the algorithm still were detected as self-referential
+ ; since the self-ref detector could not anticipate the algorithm's branching.
+ ;
+ (let (*c-calculators*)
+ (c-calculate-and-set c)))
+
+(defmethod c-awaken-cell ((c c-dependent))
+ ;
+ ; satisfy CormanCL bug
+ ;
+ (let (*c-calculators*)
+ (c-calculate-and-set c)))
+
+(defmethod c-awaken-cell ((c c-drifter))
+ ;
+ ; drifters *begin* valid, so the derived version's test for unbounditude
+ ; would keep (drift) rule ever from being evaluated. correct solution
+ ; (for another day) is to separate awakening (ie, linking to independent
+ ; cs) from evaluation, tho also evaluating if necessary during
+ ; awakening, because awakening's other role is to get an instance up to speed
+ ; at once upon instantiation
+ ;
+ (c-calculate-and-set c)
+ (cond ((c-validp c) (c-value c))
+ ((c-unboundp c) nil)
+ (t "illegal state!!!")))
Index: cells/link.lisp
diff -u cells/link.lisp:1.1.1.1 cells/link.lisp:1.2
--- cells/link.lisp:1.1.1.1 Sat Nov 8 18:44:28 2003
+++ cells/link.lisp Tue Dec 16 10:02:58 2003
@@ -1,226 +1,226 @@
-;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
-;;;
-;;; Copyright © 1995,2003 by Kenneth William Tilton.
-;;;
-;;; Permission is hereby granted, free of charge, to any person obtaining a copy
-;;; of this software and associated documentation files (the "Software"), to deal
-;;; in the Software without restriction, including without limitation the rights
-;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-;;; copies of the Software, and to permit persons to whom the Software is furnished
-;;; to do so, subject to the following conditions:
-;;;
-;;; The above copyright notice and this permission notice shall be included in
-;;; all copies or substantial portions of the Software.
-;;;
-;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
-;;; IN THE SOFTWARE.
-
-(in-package :cells)
-
-
-(defun c-link-ex (used &aux (user (car *c-calculators*)))
-
- (cond
- ((cmdead user) (return-from c-link-ex nil))
- ((null used)
- ;
- ; no cell on used value so it is constant, but if a synapse is involved the constant
- ; must still be filtered thru that, albeit only this once
- ;
- (when *synapse-factory*
- (assert (car *c-calculators*)) ;; sanity-check
- (funcall *synapse-factory* nil (car *c-calculators*))))
-
- ((or (not (typep used 'c-user-notifying))
- (and (typep used 'c-dependent)
- (c-optimized-away-p used)))
- (return-from c-link-ex nil))
-
- (t
- ;
- ; --------- debug stuff --------------
- (assert user)
- (assert (not (cmdead user)) () "dead user in link-ex ~a, used being ~a" user used)
- (assert (not (cmdead used)) () "dead used in link-ex ~a, user being ~a" used user)
-
- #+dfdbg (trc user "c-link > user, used" user used)
- (assert (not (eq :eternal-rest (md-state (c-model user)))))
- (assert (not (eq :eternal-rest (md-state (c-model used)))))
- (count-it :c-link-entry)
- (when *c-debug*
- (assert (or (null *synapse-factory*)
- (functionp *synapse-factory*))
- ()
- "~s is not a function, but was supplied as a synapse factory between ~s and ~s. probably parentheses wrong, as in (- (^lr x 96))"
- *synapse-factory* used user))
-
- (let ((used-link
- (or
- ;; check if linked already
- ;; /// looks like a bug: cannot have two synaptic dependencies on same
- ;; /// cell slot...probably need to "name" the synapses just for this purpose
- ;;
- (c-find-used-link user used)
- ;;
- ;; following may have been a goof, but i like it: let synapse factory
- ;; decide not to produce a synapse, in which case dumb direct c-cell link
- ;; gets created.
- ;;
- (bwhen (syn (and *synapse-factory*
- (funcall *synapse-factory* used user)))
- (c-add-user used syn)
- (c-add-used user syn)
- ;;(trc used "c-link> users now:" (mapcar #'celltrueuser (un-users used)))
- (trc nil "setting used to syn" syn used)
- syn)
- ;;
- ;; make dumb link: used just tells user to rethink.
- ;;
- (progn
- (trc nil "c-link > new user,used " user used)
- (c-add-user used user)
- (c-add-used user used)
- used))))
-
- (assert used-link)
- (assert (position used-link (cd-useds user))
- ()
- "used-link ~a does not appear in useds ~a of user ~a"
- used-link (cd-useds user) user)
-
- (let ((mapn (- *cd-usagect*
- (- (length (cd-useds user))
- (or (position used-link (cd-useds user)) 0)))))
- ;; (trc user "c-link> setting usage bit" user mapn used-link)
- (if (minusp mapn)
- (break "whoa. more than ~d used? i see ~d" *cd-usagect* (length (cd-useds user)))
- (cd-usage-set user mapn)))
- used-link))))
-
-(defun cd-usage-set (c mapn)
- (when (typep c 'synapse)
- (setf (syn-relevant c) t))
- (setf (sbit (cd-usage c) mapn) 1))
-
-(defun cd-usage-clear-all (c)
- (bit-and (cd-usage c)
- #*0000000000000000000000000000000000000000000000000000000000000000
- t))
-
-(defun c-find-used-link (user-cell used)
- "find any existing link to user-cell, the cell itself if direct or a synapse leading to it"
- (some (lambda (user)
- (if (typep user 'synapse)
- (when (eql user-cell (syn-user user))
- user) ;; the synapse is the used link
- (when (eql user-cell user)
- used))) ;; the link to used is direct (non-synaptic)
- (un-users used)))
-
-(defun c-add-user (used user)
- (count-it :c-adduser)
-
- (typecase used
- (c-user-notifying
- (trc nil "c-add-user conventional > user, used" user used)
- (pushnew user (un-users used)))
-
- (synapse (setf (syn-user used) user)))
-
- used)
-
-(defun c-user-path-exists-p (from-used to-user)
- (typecase from-used
- (synapse (c-user-path-exists-p (syn-user from-used) to-user))
- (c-user-notifying
- (or (find to-user (un-users from-used))
- (find-if (lambda (from-used-user)
- (c-user-path-exists-p (c-user-true from-used-user) to-user))
- (un-users from-used))))))
-
-; -----------
-
-(defun c-add-used (user used)
- (count-it :c-used)
- #+ucount (unless (member used (cd-useds user))
- (incf *cd-useds*)
- (when (zerop (mod *cd-useds* 100))
- (trc "useds count = " *cd-useds*)))
- (pushnew used (cd-useds user))
- (trc nil "c-add-used> user <= used" user used (length (cd-useds user)))
- (mapcar 'c-users-resort (cd-useds user))
- (cd-useds user))
-
-(defun c-users-resort (used)
- (typecase used
- (synapse (c-users-resort (syn-used used)))
- (c-user-notifying
- (when (second (un-users used))
- (setf (un-users used) (sort (un-users used) 'c-user-path-exists-p))
- (trc nil "c-users-resort resorted users > used" used (mapcar 'c-slot-name (un-users used)))
- (mapcar 'c-users-resort (c-useds used))))))
-
-(defmethod c-useds (other) (declare (ignore other)))
-(defmethod c-useds ((c c-dependent)) (cd-useds c))
-
-
-(defun c-quiesce (c)
- (typecase c
- (cell
- (trc nil "c-quiesce unlinking" c)
- (c-unlink-from-used c)
- (when (typep c 'c-user-notifying)
- (dolist (user (un-users c))
- (c-unlink-user c user)))
- (c-pending-set c nil :c-quiesce)
- ;;; (setf (c-waking-state c) nil)
- ;;; (when (eql :rpthead (c-model c))
- (trc nil "cell quiesce nulled cell awake" c))))
-
-;-------------------------
-
-(defmethod c-unlink-from-used ((user c-dependent))
- (dolist (used (cd-useds user))
- #+dfdbg (trc user "unlinking from used" user used)
- (c-unlink-user used user))
- ;; shouldn't be necessary (setf (cd-useds user) nil)
- )
-
-(defmethod c-unlink-from-used (other)
- (declare (ignore other)))
-
-;----------------------------------------------------------
-
-(defmethod c-unlink-user ((used c-user-notifying) user)
- #+dfdbg (trc user "user unlinking from used" user used)
- (setf (un-users used) (delete user (un-users used)))
- (c-unlink-used user used))
-
-(defmethod c-unlink-user ((syn synapse) user)
- (assert (eq user (syn-user syn)))
- (c-unlink-user (syn-used syn) syn)
- (setf (syn-user syn) nil) ;; gc-paranoia?
- )
-
-;-----------------------------------------------------------
-
-
-(defmethod c-unlink-used ((user c-dependent) used)
- (setf (cd-useds user) (delete used (cd-useds user))))
-
-(defmethod c-unlink-used ((syn synapse) used)
- (assert (eq used (syn-used syn)))
- (setf (syn-used syn) nil)
- (c-unlink-used (syn-user syn) syn))
-
-; --- very low-vel abstraction
-
-(defmethod c-user-true (c) c)
-(defmethod c-user-true ((syn synapse)) (syn-user syn))
-(defmethod c-used-true (c) c)
-(defmethod c-used-true ((syn synapse)) (syn-used syn))
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+
+(defun c-link-ex (used &aux (user (car *c-calculators*)))
+ (c-assert user)
+ (cond
+ ((cmdead user) (return-from c-link-ex nil))
+ ((null used)
+ ;
+ ; no cell on used value so it is constant, but if a synapse is involved the constant
+ ; must still be filtered thru that, albeit only this once
+ ;
+ (when *synapse-factory*
+ (c-assert (car *c-calculators*)) ;; sanity-check
+ (funcall *synapse-factory* nil (car *c-calculators*))))
+
+ ((or (not (typep used 'cell))
+ (and (typep used 'c-dependent)
+ (c-optimized-away-p used)))
+ (return-from c-link-ex nil))
+
+ (t
+ ;
+ ; --------- debug stuff --------------
+ (c-assert user)
+ (c-assert (not (cmdead user)) () "dead user in link-ex ~a, used being ~a" user used)
+ (c-assert (not (cmdead used)) () "dead used in link-ex ~a, user being ~a" used user)
+
+ #+dfdbg (trc user "c-link > user, used" user used)
+ (c-assert (not (eq :eternal-rest (md-state (c-model user)))))
+ (c-assert (not (eq :eternal-rest (md-state (c-model used)))))
+ (count-it :c-link-entry)
+ (when *c-debug*
+ (c-assert (or (null *synapse-factory*)
+ (functionp *synapse-factory*))
+ ()
+ "~s is not a function, but was supplied as a synapse factory between ~s and ~s. probably parentheses wrong, as in (- (^lr x 96))"
+ *synapse-factory* used user))
+
+ (let ((used-link
+ (or
+ ;; check if linked already
+ ;; /// looks like a bug: cannot have two synaptic dependencies on same
+ ;; /// cell slot...probably need to "name" the synapses just for this purpose
+ ;;
+ (c-find-used-link user used)
+ ;;
+ ;; following may have been a goof, but i like it: let synapse factory
+ ;; decide not to produce a synapse, in which case dumb direct c-cell link
+ ;; gets created.
+ ;;
+ (bwhen (syn (and *synapse-factory*
+ (funcall *synapse-factory* used user)))
+ (c-add-user used syn)
+ (c-add-used user syn)
+ ;;(trc used "c-link> users now:" (mapcar #'celltrueuser (c-users used)))
+ (trc nil "setting used to syn" syn used)
+ syn)
+ ;;
+ ;; make dumb link: used just tells user to rethink.
+ ;;
+ (progn
+ (trc nil "c-link > new user,used " user used)
+ (c-add-user used user)
+ (c-add-used user used)
+ used))))
+
+ (c-assert used-link)
+ (c-assert (position used-link (cd-useds user))
+ ()
+ "used-link ~a does not appear in useds ~a of user ~a"
+ used-link (cd-useds user) user)
+
+ (let ((mapn (- *cd-usagect*
+ (- (length (cd-useds user))
+ (or (position used-link (cd-useds user)) 0)))))
+ ;; (trc user "c-link> setting usage bit" user mapn used-link)
+ (if (minusp mapn)
+ (break "whoa. more than ~d used? i see ~d" *cd-usagect* (length (cd-useds user)))
+ (cd-usage-set user mapn)))
+ used-link))))
+
+(defun cd-usage-set (c mapn)
+ (when (typep c 'synapse)
+ (setf (syn-relevant c) t))
+ (setf (sbit (cd-usage c) mapn) 1))
+
+(defun cd-usage-clear-all (c)
+ (bit-and (cd-usage c)
+ #*0000000000000000000000000000000000000000000000000000000000000000
+ t))
+
+(defun c-find-used-link (user-cell used)
+ "find any existing link to user-cell, the cell itself if direct or a synapse leading to it"
+ (some (lambda (user)
+ (if (typep user 'synapse)
+ (when (eql user-cell (syn-user user))
+ user) ;; the synapse is the used link
+ (when (eql user-cell user)
+ used))) ;; the link to used is direct (non-synaptic)
+ (c-users used)))
+
+(defun c-add-user (used user)
+ (count-it :c-adduser)
+
+ (typecase used
+ (cell
+ (trc nil "c-add-user conventional > user, used" user used)
+ (pushnew user (c-users used)))
+
+ (synapse (setf (syn-user used) user)))
+
+ used)
+
+(defun c-user-path-exists-p (from-used to-user)
+ (typecase from-used
+ (synapse (c-user-path-exists-p (syn-user from-used) to-user))
+ (cell
+ (or (find to-user (c-users from-used))
+ (find-if (lambda (from-used-user)
+ (c-user-path-exists-p (c-user-true from-used-user) to-user))
+ (c-users from-used))))))
+
+; -----------
+
+(defun c-add-used (user used)
+ (count-it :c-used)
+ #+ucount (unless (member used (cd-useds user))
+ (incf *cd-useds*)
+ (when (zerop (mod *cd-useds* 100))
+ (trc "useds count = " *cd-useds*)))
+ (pushnew used (cd-useds user))
+ (trc nil "c-add-used> user <= used" user used (length (cd-useds user)))
+ (mapcar 'c-users-resort (cd-useds user))
+ (cd-useds user))
+
+(defun c-users-resort (used)
+ (typecase used
+ (synapse (c-users-resort (syn-used used)))
+ (cell
+ (when (second (c-users used))
+ (setf (c-users used) (sort (c-users used) 'c-user-path-exists-p))
+ (trc nil "c-users-resort resorted users > used" used (mapcar 'c-slot-name (c-users used)))
+ (mapcar 'c-users-resort (c-useds used))))))
+
+(defmethod c-useds (other) (declare (ignore other)))
+(defmethod c-useds ((c c-dependent)) (cd-useds c))
+
+
+(defun c-quiesce (c)
+ (typecase c
+ (cell
+ (trc nil "c-quiesce unlinking" c)
+ (c-unlink-from-used c)
+ (when (typep c 'cell)
+ (dolist (user (c-users c))
+ (c-unlink-user c user)))
+ (c-pending-set c nil :c-quiesce)
+ ;;; (setf (c-waking-state c) nil)
+ ;;; (when (eql :rpthead (c-model c))
+ (trc nil "cell quiesce nulled cell awake" c))))
+
+;-------------------------
+
+(defmethod c-unlink-from-used ((user c-dependent))
+ (dolist (used (cd-useds user))
+ #+dfdbg (trc user "unlinking from used" user used)
+ (c-unlink-user used user))
+ ;; shouldn't be necessary (setf (cd-useds user) nil)
+ )
+
+(defmethod c-unlink-from-used (other)
+ (declare (ignore other)))
+
+;----------------------------------------------------------
+
+(defmethod c-unlink-user ((used cell) user)
+ #+dfdbg (trc user "user unlinking from used" user used)
+ (setf (c-users used) (delete user (c-users used)))
+ (c-unlink-used user used))
+
+(defmethod c-unlink-user ((syn synapse) user)
+ (c-assert (eq user (syn-user syn)))
+ (c-unlink-user (syn-used syn) syn)
+ (setf (syn-user syn) nil) ;; gc-paranoia?
+ )
+
+;-----------------------------------------------------------
+
+
+(defmethod c-unlink-used ((user c-dependent) used)
+ (setf (cd-useds user) (delete used (cd-useds user))))
+
+(defmethod c-unlink-used ((syn synapse) used)
+ (c-assert (eq used (syn-used syn)))
+ (setf (syn-used syn) nil)
+ (c-unlink-used (syn-user syn) syn))
+
+; --- very low-vel abstraction
+
+(defmethod c-user-true (c) c)
+(defmethod c-user-true ((syn synapse)) (syn-user syn))
+(defmethod c-used-true (c) c)
+(defmethod c-used-true ((syn synapse)) (syn-used syn))
Index: cells/md-slot-value.lisp
diff -u cells/md-slot-value.lisp:1.1.1.1 cells/md-slot-value.lisp:1.2
--- cells/md-slot-value.lisp:1.1.1.1 Sat Nov 8 18:44:28 2003
+++ cells/md-slot-value.lisp Tue Dec 16 10:02:58 2003
@@ -1,153 +1,150 @@
-;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
-;;;
-;;; Copyright © 1995,2003 by Kenneth William Tilton.
-;;;
-;;; Permission is hereby granted, free of charge, to any person obtaining a copy
-;;; of this software and associated documentation files (the "Software"), to deal
-;;; in the Software without restriction, including without limitation the rights
-;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-;;; copies of the Software, and to permit persons to whom the Software is furnished
-;;; to do so, subject to the following conditions:
-;;;
-;;; The above copyright notice and this permission notice shall be included in
-;;; all copies or substantial portions of the Software.
-;;;
-;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
-;;; IN THE SOFTWARE.
-
-(in-package :cells)
-
-(defun md-slot-cell-flushed (self slot-spec)
- (assocv (slot-spec-name slot-spec) (cells-flushed self)))
-
-(defun md-slot-value (self slot-spec &aux (slot-c (md-slot-cell self slot-spec)))
- (when *stop*
- (princ #\.)
- (return-from md-slot-value))
- ;; (count-it :md-slot-value (slot-spec-name slot-spec))
- #+badidea(when (mdead self)
- (trc "md-slot-value> model dead" (type-of self) slot-spec)
- (return-from md-slot-value nil))
- (when (eql :nascent (md-state self))
- (md-awaken self))
-
- ; this next bit is not written (c-relay-value <link> (etypecase slot-c...))
- ; because that would link before accessing possibly an invalid ruled slot
- ; (during md-awaken), and after calculating it would propagate to users and
- ; re-enter this calculation. Switching the order of the parameters would
- ; also work, but we need to document this very specific order of operations
- ; anyway, can't just leave that to the left-right thing.
- ;
- (let ((slot-value (etypecase slot-c
- (null (bd-slot-value self slot-spec))
- (c-variable (c-value slot-c))
- (c-ruled (c-ruled-slot-value slot-c)))))
- (c-relay-value
- (when (car *c-calculators*)
- (c-link-ex slot-c))
- slot-value)))
-
-(defun c-ruled-slot-value (slot-c)
- (trc nil "c-ruled-slot-value entry" slot-c)
- (assert (not (cmdead slot-c)))
-
- (cond
- ((c-validp slot-c)
- (if (c-true-stalep slot-c)
- (c-calculate-and-set slot-c) ;; new for 2003-09-14
- (bif (deep (cd-deep-stale slot-c))
- (progn
- (trc nil "valid ~a :but-deepstale ~a, cause: ~a. calcing"
- slot-c deep *cause*)
- (c-calculate-and-set slot-c))
- #+worked (progn
- (trc "valid ~a :but-deepstale ~a, cause: ~a. calcing"
- slot-c deep *cause*)
- (c-calculate-and-set deep)
- (bIf (deep2 (cd-deep-stale slot-c))
- (break "deep, deep trouble ~a :deep2 ~a :deep1 ~a, cause: ~a."
- slot-c deep2 deep *cause*)
- (progn
- (trc "cleared valid with deep stale" slot-c)
- (c-calculate-and-set slot-c))))
- (c-value slot-c)))) ;; good to go
-
- (t (let ((*cause* :on-demand)) ; normal path first time asked
- (trc (plusp *trcdepth*) "md-slot-value calc" slot-c *c-calculators*)
- (c-calculate-and-set slot-c)))))
-
-;-------------------------------------------------------------
-
-(defun (setf md-slot-value) (newvalue self slot-spec)
- (when (mdead self)
- (return-from md-slot-value))
- (let ((c (md-slot-cell self slot-spec)))
-
- (when *c-debug*
- (c-setting-debug self slot-spec c newvalue))
-
- (unless c
- (cellstop)
- (error "(setf md-slot-value)> cellular slot ~a of ~a cannot be setf unless initialized to c-variable"
- slot-spec self)
- )
-
- (if (unst-setting-p c)
- (if (unst-cyclic-p c)
- newvalue
- (error "setf of ~a propagated back; declare as cyclic (cv8...)" c))
- (let ((absorbedvalue (c-absorb-value c newvalue)))
- ;;(assert (not (mdead self)))
- (with-dataflow-management (c)
- (md-slot-value-assume self slot-spec absorbedvalue)) ;; /// uh-oh. calc-n-set uses this return value
- absorbedvalue))))
-
-;;;(defmethod trcp ((c c-ruled))
-;;; ;;(trc "trcp ruled" (c-slot-name c) (md-name (c-model c)))
-;;; (and (eql 'clo::px (c-slot-name c))
-;;; (eql :mklabel (md-name (c-model c)))))
-
-
-(defun md-slot-value-assume (self slot-spec absorbedvalue
- &aux
- (c (md-slot-cell self slot-spec))
- (priorstate (when c (c-state c)))
- (priorvalue (when c (c-value c)))
- )
- (when (mdead self)
- (return-from md-slot-value-assume nil))
- (md-slot-value-store self (slot-spec-name slot-spec)
- (if c
- (setf (c-value c) absorbedvalue)
- absorbedvalue))
-
- (when (typep c 'c-ruled)
- (trc nil " setting cellstate :valid" c)
- (setf (c-state c) :valid)
- (setf (cd-stale-p c) nil)
- (setf (c-waking-state c) :awake)
- (c-pending-set c nil :sv-assume)
- (c-optimize-away?! c)) ;;; put optimize as early as possible
-
- ;--- propagation -----------
- ;
- (unwind-protect
- (if (and (eql priorstate :valid) ;; ie, priorvalue meaningful (nil is ambiguous)
- (c-no-news c absorbedvalue priorvalue))
- (progn
- (trc nil "(setf md-slot-value) >no-news" priorstate (c-no-news c absorbedvalue priorvalue))
- #+not (count-it :no-news))
- (progn
- (when (eql '.kids (slot-spec-name slot-spec))
- #+dfdbg (dolist (K absorbedvalue) (trc k "md-slot-value-assume -> kids change" k self))
- (md-kids-change self absorbedvalue priorvalue :md-slot-value-assume))
- (md-propagate self slot-spec absorbedvalue priorvalue (not (eql :unbound priorstate)))))
- (when c
- (setf (unst-setting-p c) nil)))
- absorbedvalue)
-
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+(defun md-slot-cell-flushed (self slot-spec)
+ (cdr (assoc (slot-spec-name slot-spec) (cells-flushed self))))
+
+(defun md-slot-value (self slot-spec &aux (slot-c (md-slot-cell self slot-spec)))
+ (when *stop*
+ (princ #\.)
+ (return-from md-slot-value))
+ ;; (count-it :md-slot-value (slot-spec-name slot-spec))
+ #+badidea(when (mdead self)
+ (trc "md-slot-value> model dead" (type-of self) slot-spec)
+ (return-from md-slot-value nil))
+ (when (eql :nascent (md-state self))
+ (md-awaken self))
+
+ ; this next bit is not written (c-relay-value <link> (etypecase slot-c...))
+ ; because that would link before accessing possibly an invalid ruled slot
+ ; (during md-awaken), and after calculating it would propagate to users and
+ ; re-enter this calculation. Switching the order of the parameters would
+ ; also work, but we need to document this very specific order of operations
+ ; anyway, can't just leave that to the left-right thing.
+ ;
+ (let ((slot-value (etypecase slot-c
+ (null (bd-slot-value self slot-spec))
+ (c-variable (c-value slot-c))
+ (c-ruled (c-ruled-slot-value slot-c)))))
+ (c-relay-value
+ (when (car *c-calculators*)
+ (c-link-ex slot-c))
+ slot-value)))
+
+(defun c-ruled-slot-value (slot-c)
+ (trc nil "c-ruled-slot-value entry" slot-c)
+ (c-assert (not (cmdead slot-c)))
+
+ (cond
+ ((c-validp slot-c)
+ (if (c-true-stalep slot-c)
+ (c-calculate-and-set slot-c) ;; new for 2003-09-14
+ (bif (deep (cd-deep-stale slot-c))
+ (progn
+ (trc nil "valid ~a :but-deepstale ~a, cause: ~a. calcing"
+ slot-c deep *cause*)
+ (c-calculate-and-set slot-c))
+ #+worked (progn
+ (trc "valid ~a :but-deepstale ~a, cause: ~a. calcing"
+ slot-c deep *cause*)
+ (c-calculate-and-set deep)
+ (bIf (deep2 (cd-deep-stale slot-c))
+ (break "deep, deep trouble ~a :deep2 ~a :deep1 ~a, cause: ~a."
+ slot-c deep2 deep *cause*)
+ (progn
+ (trc "cleared valid with deep stale" slot-c)
+ (c-calculate-and-set slot-c))))
+ (c-value slot-c)))) ;; good to go
+
+ (t (let ((*cause* :on-demand)) ; normal path first time asked
+ (trc (plusp *trcdepth*) "md-slot-value calc" slot-c *c-calculators*)
+ (c-calculate-and-set slot-c)))))
+
+;-------------------------------------------------------------
+
+(defun (setf md-slot-value) (newvalue self slot-spec)
+ (when (mdead self)
+ (return-from md-slot-value))
+ (let ((c (md-slot-cell self slot-spec)))
+
+ (when *c-debug*
+ (c-setting-debug self slot-spec c newvalue))
+
+ (unless c
+ (c-stop :setf-md-slot-value)
+ (c-break "(setf md-slot-value)> cellular slot ~a of ~a cannot be setf unless initialized to c-variable"
+ slot-spec self)
+ )
+
+ (if (cv-setting-p c)
+ (if (cv-cyclic-p c)
+ newvalue
+ (c-break "setf of ~a propagated back; declare as cyclic (cv8...)" c))
+ (let ((absorbedvalue (c-absorb-value c newvalue)))
+ ;;(c-assert (not (mdead self)))
+ (with-dataflow-management (c)
+ (md-slot-value-assume self slot-spec absorbedvalue)) ;; /// uh-oh. calc-n-set uses this return value
+ absorbedvalue))))
+
+;;;(defmethod trcp ((c c-ruled))
+;;; ;;(trc "trcp ruled" (c-slot-name c) (md-name (c-model c)))
+;;; (and (eql 'clo::px (c-slot-name c))
+;;; (eql :mklabel (md-name (c-model c)))))
+
+
+(defun md-slot-value-assume (self slot-spec absorbedvalue
+ &aux
+ (c (md-slot-cell self slot-spec))
+ (priorstate (when c (c-state c)))
+ (priorvalue (when c (c-value c)))
+ )
+ (when (mdead self)
+ (return-from md-slot-value-assume nil))
+ (md-slot-value-store self (slot-spec-name slot-spec)
+ (if c
+ (setf (c-value c) absorbedvalue)
+ absorbedvalue))
+
+ (when (typep c 'c-ruled)
+ (trc nil " setting cellstate :valid" c)
+ (setf (c-state c) :valid)
+ (setf (cd-stale-p c) nil)
+ (setf (c-waking-state c) :awake)
+ (c-pending-set c nil :sv-assume)
+ (c-optimize-away?! c)) ;;; put optimize as early as possible
+
+ ;--- propagation -----------
+ ;
+ (if (and (eql priorstate :valid) ;; ie, priorvalue meaningful (nil is ambiguous)
+ (c-no-news c absorbedvalue priorvalue))
+ (progn
+ (trc nil "(setf md-slot-value) >no-news" priorstate (c-no-news c absorbedvalue priorvalue))
+ #+not (count-it :no-news))
+ (progn
+ (when (eql '.kids (slot-spec-name slot-spec))
+ #+dfdbg (dolist (K absorbedvalue) (trc k "md-slot-value-assume -> kids change" k self))
+ (md-kids-change self absorbedvalue priorvalue :md-slot-value-assume))
+ (md-propagate self slot-spec absorbedvalue priorvalue (not (eql :unbound priorstate)))))
+ absorbedvalue)
+
Index: cells/md-utilities.lisp
diff -u cells/md-utilities.lisp:1.1.1.1 cells/md-utilities.lisp:1.2
--- cells/md-utilities.lisp:1.1.1.1 Sat Nov 8 18:44:28 2003
+++ cells/md-utilities.lisp Tue Dec 16 10:02:58 2003
@@ -1,111 +1,111 @@
-;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
-;;;
-;;; Copyright © 1995,2003 by Kenneth William Tilton.
-;;;
-;;; Permission is hereby granted, free of charge, to any person obtaining a copy
-;;; of this software and associated documentation files (the "Software"), to deal
-;;; in the Software without restriction, including without limitation the rights
-;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-;;; copies of the Software, and to permit persons to whom the Software is furnished
-;;; to do so, subject to the following conditions:
-;;;
-;;; The above copyright notice and this permission notice shall be included in
-;;; all copies or substantial portions of the Software.
-;;;
-;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
-;;; IN THE SOFTWARE.
-
-(in-package :cells)
-
-;;;(defmethod update-instance-for-redefined-class ((self model-object) added lost plist &key)
-;;; (declare (ignorable added lost plist))
-;;; (when (slot-boundp self '.md-state) (call-next-method)))
-
-(defmethod occurence ((self model-object))
- ;
- ; whether multiply occuring or not, return index of self
- ; within list of likenamed siblings, perhaps mixed amongst others
- ; of diff names
- ;
- (let ((selfindex -1))
- (dolist (kid (kids (fmparent self)))
- (when (eql (md-name kid) (md-name self))
- (incf selfindex)
- (when (eql self kid)
- (return-from occurence selfindex))))))
-
-
-(defun md-awake (self) (eql :awake (md-state self)))
-
-
-(defun fm-grandparent (md)
- (fmparent (fmparent md)))
-
-
-(defmethod md-release (other)
- (declare (ignorable other)))
-
-;___________________ birth / death__________________________________
-
-(defmethod not-to-be :around (self)
- (trc nil "not-to-be clearing 1 fmparent, eternal-rest" self)
- (assert (not (eq (md-state self) :eternal-rest)))
-
- (call-next-method)
-
- (setf (fmparent self) nil
- (md-state self) :eternal-rest)
- (trc nil "not-to-be cleared 2 fmparent, eternal-rest" self))
-
-(defmethod not-to-be ((self model-object))
- (trc nil "not to be!!!" self)
- (unless (md-untouchable self)
- (md-quiesce self)))
-
-(defmethod md-untouchable (self) ;; would be t for closed-stream under acl
- (declare (ignore self))
- nil)
-
-(defun md-quiesce (self)
- (trc nil "md-quiesce doing" self)
- (md-map-cells self nil (lambda (c)
- (trc nil "quiescing" c)
- (assert (not (find c *c-calculators*)))
- (c-quiesce c))))
-
-
-(defmethod not-to-be (other)
- other)
-
-
-
-(defparameter *to-be-dbg* nil)
-
-(defun to-be (self)
- (trc nil "to-be> entry" self (md-state self))
-
- (progn ;;wtrc (0 100 "to-be> entry" self (md-state self) (length *to-be-awakened*))
- (when (eql :nascent (md-state self)) ;; formwithview to-be-primary :after => rv-stitch! => side-effects
- (let ((already *to-be-awakened*))
- (setf *to-be-awakened* (nconc *to-be-awakened* (list self)))
- (trc nil "to-be deferring awaken" self)
- (kids self) ;; sick, just for side effect
- (unless already
- (trc nil "top to-be awakening deferred" self (length *to-be-awakened*))
- (do* ((mds *to-be-awakened* (cdr mds))
- (md (car mds) (car mds)))
- ((null mds))
- (if (eql :nascent (md-state md))
- (md-awaken md)
- (trc nil "not md-awakening non-nascent" md)))
- (setf *to-be-awakened* nil)))))
- self)
-
-(defun md-make (class &rest kwps)
- (to-be (apply #'make-instance class kwps)))
-
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+;;;(defmethod update-instance-for-redefined-class ((self model-object) added lost plist &key)
+;;; (declare (ignorable added lost plist))
+;;; (when (slot-boundp self '.md-state) (call-next-method)))
+
+(defmethod occurence ((self model-object))
+ ;
+ ; whether multiply occuring or not, return index of self
+ ; within list of likenamed siblings, perhaps mixed amongst others
+ ; of diff names
+ ;
+ (let ((selfindex -1))
+ (dolist (kid (kids (fm-parent self)))
+ (when (eql (md-name kid) (md-name self))
+ (incf selfindex)
+ (when (eql self kid)
+ (return-from occurence selfindex))))))
+
+
+(defun md-awake (self) (eql :awake (md-state self)))
+
+
+(defun fm-grandparent (md)
+ (fm-parent (fm-parent md)))
+
+
+(defmethod md-release (other)
+ (declare (ignorable other)))
+
+;___________________ birth / death__________________________________
+
+(defmethod not-to-be :around (self)
+ (trc nil "not-to-be clearing 1 fm-parent, eternal-rest" self)
+ (c-assert (not (eq (md-state self) :eternal-rest)))
+
+ (call-next-method)
+
+ (setf (fm-parent self) nil
+ (md-state self) :eternal-rest)
+ (trc nil "not-to-be cleared 2 fm-parent, eternal-rest" self))
+
+(defmethod not-to-be ((self model-object))
+ (trc nil "not to be!!!" self)
+ (unless (md-untouchable self)
+ (md-quiesce self)))
+
+(defmethod md-untouchable (self) ;; would be t for closed-stream under acl
+ (declare (ignore self))
+ nil)
+
+(defun md-quiesce (self)
+ (trc nil "md-quiesce doing" self)
+ (md-map-cells self nil (lambda (c)
+ (trc nil "quiescing" c)
+ (c-assert (not (find c *c-calculators*)))
+ (c-quiesce c))))
+
+
+(defmethod not-to-be (other)
+ other)
+
+
+
+(defparameter *to-be-dbg* nil)
+
+(defun to-be (self)
+ (trc nil "to-be> entry" self (md-state self))
+
+ (progn ;;wtrc (0 100 "to-be> entry" self (md-state self) (length *to-be-awakened*))
+ (when (eql :nascent (md-state self)) ;; formwithview to-be-primary :after => rv-stitch! => side-effects
+ (let ((already *to-be-awakened*))
+ (setf *to-be-awakened* (nconc *to-be-awakened* (list self)))
+ (trc nil "to-be deferring awaken" self)
+ (kids self) ;; sick, just for side effect
+ (unless already
+ (trc nil "top to-be awakening deferred" self (length *to-be-awakened*))
+ (do* ((mds *to-be-awakened* (cdr mds))
+ (md (car mds) (car mds)))
+ ((null mds))
+ (if (eql :nascent (md-state md))
+ (md-awaken md)
+ (trc nil "not md-awakening non-nascent" md)))
+ (setf *to-be-awakened* nil)))))
+ self)
+
+(defun md-make (class &rest kwps)
+ (to-be (apply #'make-instance class kwps)))
+
Index: cells/model-object.lisp
diff -u cells/model-object.lisp:1.1.1.1 cells/model-object.lisp:1.2
--- cells/model-object.lisp:1.1.1.1 Sat Nov 8 18:44:28 2003
+++ cells/model-object.lisp Tue Dec 16 10:02:58 2003
@@ -1,193 +1,175 @@
-;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
-;;;
-;;; Copyright © 1995,2003 by Kenneth William Tilton.
-;;;
-;;; Permission is hereby granted, free of charge, to any person obtaining a copy
-;;; of this software and associated documentation files (the "Software"), to deal
-;;; in the Software without restriction, including without limitation the rights
-;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-;;; copies of the Software, and to permit persons to whom the Software is furnished
-;;; to do so, subject to the following conditions:
-;;;
-;;; The above copyright notice and this permission notice shall be included in
-;;; all copies or substantial portions of the Software.
-;;;
-;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
-;;; IN THE SOFTWARE.
-
-(in-package :cells)
-
-;----------------- model-object ----------------------
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(md-name mdwhen fmparent .parent)))
-
-(defclass model-object ()
- ((.md-state :initform nil :accessor md-state) ; [nil | :nascent | :alive | :doomed]
- (.md-name :initform nil :initarg :md-name :accessor md-name)
- (.mdwhen :initform nil :initarg :mdwhen :accessor mdwhen)
- (.fmparent :initform nil :initarg :fmparent :accessor fmparent)
- (.cells :initform nil :initarg :cells :accessor cells)
- (.cells-flushed :initform nil :initarg cells :accessor cells-flushed
- :documentation "cells supplied but un-whenned or optimized-away")
- (adopt-ct :initform 0 :accessor adopt-ct)))
-
-(defmethod print-object ((self model-object) s)
- (format s "~a" (or (md-name self) (type-of self))))
-
-(define-symbol-macro .parent (fmparent self))
-
-(defun md-cell-defs (self)
- (get (type-of self) :cell-defs))
-
-(defmethod md-slot-cell (self slot-spec)
- (assocv (slot-spec-name slot-spec) (cells self)))
-
-(defun md-slot-cell-type (class-name slot-spec)
- (bif (entry (assoc (slot-spec-name slot-spec) (get class-name :cell-defs)))
- (cdr entry)
- (dolist (super (class-precedence-list (find-class class-name)))
- (bIf (entry (assoc (slot-spec-name slot-spec) (get (c-class-name super) :cell-defs)))
- (return (cdr entry))))))
-
-
-(defun (setf md-slot-cell-type) (new-type class-name slot-spec)
- (assocv-setf (get class-name :cell-defs) (slot-spec-name slot-spec) new-type))
-
-(defmethod md-slot-value-store ((self model-object) slot-spec new-value)
- (setf (slot-value self (slot-spec-name slot-spec)) new-value))
-
-;----------------- navigation: slot <> initarg <> esd <> cell -----------------
-
-#+cmu
-(defmethod c-class-name ((class pcl::standard-class))
- (pcl::class-name class))
-
-(defmethod c-class-name (other) (declare (ignore other)) nil)
-
-(defmethod c-class-name ((class standard-class))
- (class-name class))
-
-(defmethod cellwhen (other) (declare (ignorable other)) nil)
-
-(defun (setf md-slot-cell) (newcell self slot-spec)
- (bif (entry (assoc (slot-spec-name slot-spec) (cells self)))
- (let ((old (cdr entry))) ;; s/b being supplanted by kid-slotter
- (assert (null (un-users old)))
- (assert (null (cd-useds old)))
- (trc nil "replacing in model .cells" old newcell self)
- (rplacd entry newcell))
- (progn
- (trc nil "adding to model .cells" newcell self)
- (push (cons (slot-spec-name slot-spec) newcell)
- (cells self)))))
-
-(defun md-map-cells (self type celldo)
- (map type (lambda (cellentry)
- (bwhen (cell (cdr cellentry))
- (unless (listp cell)
- (funcall celldo cell))))
- (cells self)))
-
-(defun c-install (self sn c)
- (assert (typep c 'cell))
- (trc nil "installing cell" sn c)
- (setf
- (c-model c) self
- (c-slot-spec c) sn
- (md-slot-cell self sn) c
- (slot-value self sn) (when (typep c 'c-variable)
- (c-value c))))
-
-;------------------ md obj initialization ------------------
-
-(defmethod shared-initialize :after ((self model-object) slotnames
- &rest initargs &key fmparent mdwhen
- &allow-other-keys)
- (declare (ignorable initargs slotnames fmparent mdwhen))
-
- (dolist (esd (class-slots (class-of self)))
- (let* ((sn (slot-definition-name esd))
- (sv (when (slot-boundp self sn)
- (slot-value self sn))))
- (when (typep sv 'cell)
- (if (md-slot-cell-type (type-of self) sn)
- (c-install self sn sv)
- (when *c-debug*
- (trc "cell ~a offered for non-cellular model/slot ~a/~a" sv self sn))))))
-
- (md-initialize self))
-
-;;;(defun pick-if-when-slot (esd mdwhen &aux (cellwhen (cellwhen esd)))
-;;; (or (null cellwhen)
-;;; (some-x-is-in-y cellwhen mdwhen)))
-
-(defmethod md-initialize (self)
- (when (slot-boundp self '.md-name)
- (unless (md-name self)
- (setf (md-name self) (c-class-name (class-of self)))))
-
- (when (fmparent self)
- (md-adopt (fmparent self) self))
-
- (setf (md-state self) :nascent))
-
-(defun cells-clear (self)
- "allow gc"
- ;;
- ;; too extreme? 'close-device went after slot when a class
- ;; ended up without cells--should not be a crime 2k0320kt
- ;; (slot-makunbound self '.cells)
- ;; ...
- (setf (cells self) nil) ;; try instead
- )
-
-
-;--------- awaken only when ready (in family, for models) --------
-
-
-(defmethod md-awaken ((self model-object))
- (trc nil "md-awaken entry" self (md-state self))
- (assert (eql :nascent (md-state self)))
- ;; (trc nil "awaken doing")
- (count-it :md-awaken)
- ;;(count-it 'mdawaken (type-of self))
- (setf (md-state self) :awakening)
- ;; (trc "md-awaken entry" self)
- (dolist (esd (class-slots (class-of self)))
- (trc nil "md-awaken scoping slot" self (slot-definition-name esd))
- (when (md-slot-cell-type (type-of self) (slot-definition-name esd))
- (let ((slot-name (slot-definition-name esd)))
- (if (not (c-echo-defined slot-name))
- (progn ;; (count-it :md-awaken :no-echo-slot slot-name)
- (trc nil "md-awaken deferring cell-awaken since no echo" self esd))
-
- (let ((cell (md-slot-cell self slot-name)))
- (trc nil "md-awaken finds md-esd-cell " cell)
- (when *c-debug*
- ;
- ; check to see if cell snuck into actual slot value...
- ;
- (bwhen (sv (slot-value self slot-name))
- (when (typep sv 'cell)
- (error "md-awaken ~a found cell ~a in slot ~a" self sv esd))))
-
- (if cell
- (if (c-lazy-p cell)
- (progn
- (trc nil "md-awaken deferring cell-awaken since lazy" self esd))
- (c-awaken cell))
- (progn ;; next bit revised to avoid double-echo of optimized cells
- (when (eql '.kids slot-name)
- (bwhen (sv (slot-value self '.kids))
- (md-kids-change self sv nil :md-awaken-slot)))
- (c-echo-initially self slot-name))))))))
-
- (setf (md-state self) :awake)
- self)
-
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+;----------------- model-object ----------------------
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(md-name mdwhen fm-parent .parent)))
+
+(defclass model-object ()
+ ((.md-state :initform nil :accessor md-state) ; [nil | :nascent | :alive | :doomed]
+ (.mdwhen :initform nil :initarg :mdwhen :accessor mdwhen)
+ (.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 md-slot-cell (self slot-spec)
+ (cdr (assoc (slot-spec-name slot-spec) (cells self))))
+
+(defun md-slot-cell-type (class-name slot-spec)
+ (bif (entry (assoc (slot-spec-name slot-spec) (get class-name :cell-types)))
+ (cdr entry)
+ (dolist (super (class-precedence-list (find-class class-name)))
+ (bWhen (entry (assoc (slot-spec-name slot-spec) (get (c-class-name super) :cell-types)))
+ (return (setf (md-slot-cell-type class-name slot-spec) (cdr entry)))))))
+
+(defun (setf md-slot-cell-type) (new-type class-name slot-spec)
+ (assocv-setf (get class-name :cell-types) (slot-spec-name slot-spec) new-type))
+
+(defmethod md-slot-value-store ((self model-object) slot-spec new-value)
+ (setf (slot-value self (slot-spec-name slot-spec)) new-value))
+
+;----------------- navigation: slot <> initarg <> esd <> cell -----------------
+
+#+cmu
+(defmethod c-class-name ((class pcl::standard-class))
+ (pcl::class-name class))
+
+(defmethod c-class-name (other) (declare (ignore other)) nil)
+
+(defmethod c-class-name ((class standard-class))
+ (class-name class))
+
+(defmethod cellwhen (other) (declare (ignorable other)) nil)
+
+(defun (setf md-slot-cell) (newcell self slot-spec)
+ (bif (entry (assoc (slot-spec-name slot-spec) (cells self)))
+ (let ((old (cdr entry))) ;; s/b being supplanted by kid-slotter
+ (c-assert (null (c-users old)))
+ (c-assert (null (cd-useds old)))
+ (trc nil "replacing in model .cells" old newcell self)
+ (rplacd entry newcell))
+ (progn
+ (trc nil "adding to model .cells" newcell self)
+ (push (cons (slot-spec-name slot-spec) newcell)
+ (cells self)))))
+
+(defun md-map-cells (self type celldo)
+ (map type (lambda (cellentry)
+ (bwhen (cell (cdr cellentry))
+ (unless (listp cell)
+ (funcall celldo cell))))
+ (cells self)))
+
+(defun c-install (self sn c)
+ (c-assert (typep c 'cell))
+ (trc nil "installing cell" sn c)
+ (setf
+ (c-model c) self
+ (c-slot-spec c) sn
+ (md-slot-cell self sn) c
+ (slot-value self sn) (when (typep c 'c-variable)
+ (c-value c))))
+
+;------------------ md obj initialization ------------------
+
+(defmethod shared-initialize :after ((self model-object) slotnames
+ &rest initargs &key fm-parent mdwhen
+ &allow-other-keys)
+ (declare (ignorable initargs slotnames fm-parent mdwhen))
+
+ (dolist (esd (class-slots (class-of self)))
+ (let* ((sn (slot-definition-name esd))
+ (sv (when (slot-boundp self sn)
+ (slot-value self sn))))
+ (when (typep sv 'cell)
+ (if (md-slot-cell-type (type-of self) sn)
+ (c-install self sn sv)
+ (when *c-debug*
+ (trc "warning: cell ~a offered for non-cellular model/slot ~a/~a" sv self sn))))))
+
+ (md-initialize self))
+
+;;;(defun pick-if-when-slot (esd mdwhen &aux (cellwhen (cellwhen esd)))
+;;; (or (null cellwhen)
+;;; (some-x-is-in-y cellwhen mdwhen)))
+
+(defmethod md-initialize (self)
+ (setf (md-state self) :nascent))
+
+(defun cells-clear (self)
+ "allow gc"
+ ;;
+ ;; too extreme? 'close-device went after slot when a class
+ ;; ended up without cells--should not be a crime 2k0320kt
+ ;; (slot-makunbound self '.cells)
+ ;; ...
+ (setf (cells self) nil) ;; try instead
+ )
+
+
+;--------- awaken only when ready (in family, for models) --------
+
+
+(defmethod md-awaken ((self model-object))
+ (trc nil "md-awaken entry" self (md-state self))
+ (c-assert (eql :nascent (md-state self)))
+ ;; (trc nil "awaken doing")
+ (count-it :md-awaken)
+ ;;(count-it 'mdawaken (type-of self))
+ (setf (md-state self) :awakening)
+ ;; (trc "md-awaken entry" self)
+ (dolist (esd (class-slots (class-of self)))
+ (trc nil "md-awaken scoping slot" self (slot-definition-name esd))
+ (when (md-slot-cell-type (type-of self) (slot-definition-name esd))
+ (let ((slot-name (slot-definition-name esd)))
+ (if (not (c-echo-defined slot-name))
+ (progn ;; (count-it :md-awaken :no-echo-slot slot-name)
+ (trc nil "md-awaken deferring cell-awaken since no echo" self esd))
+
+ (let ((cell (md-slot-cell self slot-name)))
+ (trc nil "md-awaken finds md-esd-cell " cell)
+ (when *c-debug*
+ ;
+ ; check to see if cell snuck into actual slot value...
+ ;
+ (bwhen (sv (slot-value self slot-name))
+ (when (typep sv 'cell)
+ (c-break "md-awaken ~a found cell ~a in slot ~a" self sv esd))))
+
+ (if cell
+ (if (c-lazy-p cell)
+ (progn
+ (trc nil "md-awaken deferring cell-awaken since lazy" self esd))
+ (c-awaken cell))
+ (progn ;; next bit revised to avoid double-echo of optimized cells
+ (when (eql '.kids slot-name)
+ (bwhen (sv (slot-value self '.kids))
+ (md-kids-change self sv nil :md-awaken-slot)))
+ (c-echo-initially self slot-name))))))))
+
+ (setf (md-state self) :awake)
+ self)
+
Index: cells/optimization.lisp
diff -u cells/optimization.lisp:1.1.1.1 cells/optimization.lisp:1.2
--- cells/optimization.lisp:1.1.1.1 Sat Nov 8 18:44:28 2003
+++ cells/optimization.lisp Tue Dec 16 10:02:58 2003
@@ -1,83 +1,83 @@
-;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
-;;;
-;;; Copyright © 1995,2003 by Kenneth William Tilton.
-;;;
-;;; Permission is hereby granted, free of charge, to any person obtaining a copy
-;;; of this software and associated documentation files (the "Software"), to deal
-;;; in the Software without restriction, including without limitation the rights
-;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-;;; copies of the Software, and to permit persons to whom the Software is furnished
-;;; to do so, subject to the following conditions:
-;;;
-;;; The above copyright notice and this permission notice shall be included in
-;;; all copies or substantial portions of the Software.
-;;;
-;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
-;;; IN THE SOFTWARE.
-
-(in-package :cells)
-
-;____________ cell when ____________________
-
-(defparameter *c-whentime* nil)
-
-(defun call-with-when-time? (whentimes function &aux old)
- (rotatef old *c-whentime* whentimes)
- ;; (trc "setting *c-whentime* to" *c-whentime*)
- (unwind-protect
- (funcall function)
- (setf *c-whentime* old)))
-
-;---------- optimizing away cells whose dependents all turn out to be constant ----------------
-;
-
-(defun c-optimize-away?! (c)
-
- (typecase c
- #+old-code
- (c-nested (trc nil "optimize-away nested")
- (when (and (null (cd-useds c)))
- (rplaca (member c (cellnestedcells (cellaggregatecell c))) (c-value c))
- t))
- (c-dependent
- (if (and *c-optimizep*
- (c-validp c)
- (null (cd-useds c)))
-
- (progn
- (trc nil "optimizing away" c)
- (count-it :c-optimized)
-
- (setf (c-state c) :optimized-away)
-
- (let ((entry (rassoc c (cells (c-model c))))) ; move from cells to cells-flushed
- (assert entry)
- (setf (cells (c-model c)) (delete entry (cells (c-model c))))
- (push entry (cells-flushed (c-model c))))
-
- (dolist (user (un-users c))
- (setf (cd-useds user) (delete c (cd-useds user)))
- (trc nil "checking opti2" c :user> user)
- (when (c-optimize-away?! user)
- (trc "Wow!!! optimizing chain reaction, first:" c :then user)))
-
- (setf ; drop foreign refs to aid gc (gc paranoia?)
- (c-model c) nil
- (un-users c) nil)
-
- t)
-
- (progn
- (trc nil "not optimizing away" *c-optimizep* (car (cd-useds c)) (c-validp c))
- #+no (dolist (used (cd-useds c))
- (assert (member c (un-users used)))
- ;;; (trc nil "found as user of" used)
- )
- ; (count-it :c-not-optimize)
- ; (count-it (intern-keyword "noopti-" #+nah (c-model c) "-" (symbol-name (c-slot-name c))))
- )))))
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+;____________ cell when ____________________
+
+(defparameter *c-whentime* nil)
+
+(defun call-with-when-time? (whentimes function &aux old)
+ (rotatef old *c-whentime* whentimes)
+ ;; (trc "setting *c-whentime* to" *c-whentime*)
+ (unwind-protect
+ (funcall function)
+ (setf *c-whentime* old)))
+
+;---------- optimizing away cells whose dependents all turn out to be constant ----------------
+;
+
+(defun c-optimize-away?! (c)
+
+ (typecase c
+ #+old-code
+ (c-nested (trc nil "optimize-away nested")
+ (when (and (null (cd-useds c)))
+ (rplaca (member c (cellnestedcells (cellaggregatecell c))) (c-value c))
+ t))
+ (c-dependent
+ (if (and *c-optimizep*
+ (c-validp c)
+ (null (cd-useds c)))
+
+ (progn
+ (trc nil "optimizing away" c)
+ (count-it :c-optimized)
+
+ (setf (c-state c) :optimized-away)
+
+ (let ((entry (rassoc c (cells (c-model c))))) ; move from cells to cells-flushed
+ (c-assert entry)
+ (setf (cells (c-model c)) (delete entry (cells (c-model c))))
+ (push entry (cells-flushed (c-model c))))
+
+ (dolist (user (c-users c))
+ (setf (cd-useds user) (delete c (cd-useds user)))
+ (trc nil "checking opti2" c :user> user)
+ (when (c-optimize-away?! user)
+ (trc "Wow!!! optimizing chain reaction, first:" c :then user)))
+
+ (setf ; drop foreign refs to aid gc (gc paranoia?)
+ (c-model c) nil
+ (c-users c) nil)
+
+ t)
+
+ (progn
+ (trc nil "not optimizing away" *c-optimizep* (car (cd-useds c)) (c-validp c))
+ #+no (dolist (used (cd-useds c))
+ (c-assert (member c (c-users used)))
+ ;;; (trc nil "found as user of" used)
+ )
+ ; (count-it :c-not-optimize)
+ ; (count-it (intern-keyword "noopti-" #+nah (c-model c) "-" (symbol-name (c-slot-name c))))
+ )))))
Index: cells/propagate.lisp
diff -u cells/propagate.lisp:1.1.1.1 cells/propagate.lisp:1.2
--- cells/propagate.lisp:1.1.1.1 Sat Nov 8 18:44:34 2003
+++ cells/propagate.lisp Tue Dec 16 10:02:58 2003
@@ -1,310 +1,308 @@
-;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
-;;;
-;;; Copyright © 1995,2003 by Kenneth William Tilton.
-;;;
-;;; Permission is hereby granted, free of charge, to any person obtaining a copy
-;;; of this software and associated documentation files (the "Software"), to deal
-;;; in the Software without restriction, including without limitation the rights
-;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-;;; copies of the Software, and to permit persons to whom the Software is furnished
-;;; to do so, subject to the following conditions:
-;;;
-;;; The above copyright notice and this permission notice shall be included in
-;;; all copies or substantial portions of the Software.
-;;;
-;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
-;;; IN THE SOFTWARE.
-
-(in-package :cells)
-
-(defparameter *echodone* nil)
-
-(defun c-echo-defined (slot-name)
- (getf (symbol-plist slot-name) :echo-defined))
-
-(defmethod (setf c-true-stalep) (newvalue (user c-ruled))
- #+dfdbg (trc user "setting c-true-stalep" user newvalue)
- (assert (find user (cells (c-model user)) :key #'cdr))
- (setf (cd-stale-p user) newvalue))
-
-(defmethod (setf c-true-stalep) (newvalue (usersyn synapse))
- #+dfdbg (trc (syn-user usersyn) "synapse setting c-true-stalep" (syn-user usersyn) newvalue usersyn)
- (setf (cd-stale-p (syn-user usersyn)) newvalue))
-
-(defmethod (setf c-true-stalep) (newvalue other)
- (declare (ignore other))
- newvalue)
-
-(defun c-echo-initially (self slot-spec)
- "call during instance init. if echo is defined for slot, and value is non-nil (controversial) force initial echo."
- (trc nil "c-echo-initially" self slot-spec
- (c-echo-defined (slot-spec-name slot-spec))
- (md-slot-cell self slot-spec))
- (if (c-echo-defined (slot-spec-name slot-spec))
- (bif (c (md-slot-cell self slot-spec))
- (etypecase c
- (c-variable (md-propagate self slot-spec (c-value c) nil nil))
- (c-ruled (md-slot-value self slot-spec))) ;; this will echo after calculating if not nil
- ;
- ; new for 22-03-07: echo even if slot value is nil...
- (c-echo-slot-name (slot-spec-name slot-spec)
- self
- (bd-slot-value self slot-spec)
- nil nil))
- (bwhen (c (md-slot-cell self slot-spec))
- (c-ephemeral-reset c))))
-
-#-(or cormanlisp clisp)
-(defgeneric c-echo-slot-name (slotname self new old old-boundp) (:method-combination progn))
-
-
-(defmethod c-echo-slot-name
- #-(or cormanlisp clisp) progn
- #+(or cormanlisp clisp) :before
- (slot-name self new old old-boundp)
- (declare (ignorable slot-name self new old old-boundp)))
-
-#+(or cormanlisp clisp)
-(defmethod c-echo-slot-name (slot-name self new old old-boundp)
- (declare (ignorable slot-name self new old old-boundp)))
-
-;--------------- propagate ----------------------------
-;
-; n.b. 990414kt the cell argument may have been optimized away,
-; though it is still receiving final processing here.
-;
-
-(defun md-propagate (self slot-spec newvalue priorvalue priorvalue-supplied)
- (when (mdead self)
- (trc nil "md-propagate n-opping dead" self)
- (return-from md-propagate nil))
-
- (let (*c-calculators*
- (*c-prop-depth* (1+ *c-prop-depth*))
- (c (md-slot-cell self slot-spec)))
- ;
- ;------ debug stuff ---------
- ;
- (when *stop*
- (princ #\.)(princ #\!)
- (return-from md-propagate))
-
- (when c
- (trc nil "md-propagate> propping" self slot-spec (length (un-users c)) c)
- )
-
- (when *c-debug*
- (when (> *c-prop-depth* 250)
- (trc "md-propagate deep" *c-prop-depth* self (slot-spec-name slot-spec) #+nah c))
- (when (> *c-prop-depth* 300)
- (break "md-propagate looping" c)
- ))
-
- (when c
- ; ------ flag dependents as stale ------------
- ; do before echo in case echo gets back to some user
- ;
- (dolist (user (un-users c))
- #+dfdbg (trc user "md-prop now setting stale (changer, stale):" c user)
- (when (c-user-cares user)
- (setf (c-true-stalep user) c))))
-
- ; --- manifest new value as needed -----------
- (when (c-echo-defined (slot-spec-name slot-spec)) ;; /// faster than just dispatching?
- (when c (trc nil "md-prop now echoing" c))
- (c-echo-slot-name (slot-spec-name slot-spec)
- self
- newvalue
- priorvalue
- priorvalue-supplied)
- (when (mdead self) ;; hopefully expiration on perishable class
- (return-from md-propagate)))
-
- (when c ; --- now propagate to dependents ------------
- (trc nil "md-prop checking dependents" c (un-users c))
- (let ((*cause* c))
- (dolist (user (un-users c))
- (unless (cmdead user)
- (when (c-user-cares user)
- (if (c-user-lazy user)
- (progn
- (trc nil "lazy user not being propagated to" user :by c)
- (dolist (u (un-users user))
- (c-propagate-staleness u)))
- (progn
- (c-rethink user)
- (when (mdead self)
- (trc nil "md-propagate> self now dead after rethink user: ~a" self user)
- (return-from md-propagate nil))
- )))))
- (c-ephemeral-reset c)))))
-
-(defmethod c-propagate-staleness ((c c-ruled))
- (trc nil "inheriting staleness" c)
- (dolist (u (cr-users c))
- (c-propagate-staleness u)))
-
-(defmethod c-propagate-staleness ((s synapse))
- (trc "I hope this synapse isn't for efficiency" s)
- (break)
- (c-propagate-staleness (syn-user s)))
-
-(defmethod c-propagate-staleness (c)
- (declare (ignorable c))
- (trc "not inheriting or proagating staleness" c)
- )
-
-(defmethod c-user-cares (c) c) ;; ie, t
-(defmethod c-user-cares ((s synapse))
- (syn-relevant s))
-
-(defmethod c-user-lazy (c) (declare (ignore c)) nil)
-(defmethod c-user-lazy ((c c-ruled))
- (cr-lazy c))
-
-
-(defun c-ephemeral-reset (c)
- (when c
- (when (c-ephemeral-p c)
- (trc nil "c-ephemeral-reset resetting:" c)
- (setf (c-value c) nil)))) ;; good q: what does (setf <ephem> 'x) return? historically nil, but...?
-
-;----------------- change detection ---------------------------------
-
-(defun c-no-news (c newvalue oldvalue)
- ;;; (trc nil "c-no-news > checking news between" newvalue oldvalue)
-
- (if (unst-delta-p c)
- (c-identity-p newvalue)
- (bIf (test (c-unchanged-test (c-model c) (c-slot-name c)))
- (funcall test newvalue oldvalue)
- (eql newvalue oldvalue))))
-
-(defmacro def-c-unchanged-test ((class slotname) &body test)
- `(defmethod c-unchanged-test ((self ,class) (slotname (eql ',slotname)))
- , at test))
-
-(defmethod c-unchanged-test (self slotname)
- (declare (ignore self slotname))
- nil)
-
-(defmethod c-identity-p ((value null)) t)
-(defmethod c-identity-p ((value number)) (zerop value))
-(defmethod c-identity-p ((value cons))
- ;; this def a little suspect?
- (and (c-identity-p (car value))
- (c-identity-p (cdr value))))
-
-
-;------------------- re think ---------------------------------
-
-(defun cmdead (c)
- (if (typep c 'synapse)
- (cmdead (syn-user c))
- (if (null (c-model c))
- (not (c-optimized-away-p c))
- (mdead (c-model c)))))
-
-(defun mdead (m) (eq :eternal-rest (md-state m)))
-
-(defun c-rethink (c)
- (when *stop*
- (princ #\.)
- (return-from c-rethink))
- ;;(trc "rethink entry: c, true-stale" c (c-true-stalep c))
- (assert (not (cmdead c))() "rethink entry cmdead ~a" c)
- (unless (c-true-stalep c)
- (return-from c-rethink))
-
- (when *rethink-deferred*
- (trc nil "bingo!!!!!! rethink deferring" c *cause*)
- (push (list c *cause*) *rethink-deferred*)
- (return-from c-rethink))
-
- (assert (not (cmdead c))() "rethink here?? cmdead ~a" c)
-
- ; looking ahead for interference avoids JIT detection, which where a dependency
- ; already exists causes re-entrance into the rule, which should calculate the same
- ; value twice and echo only once, but still seems like something to avoid since
- ; we do already have the technology.
- ;
-
- (bIf (interf (sw-detect-interference c nil))
- (progn
- (trc "!!!!!!!!!! rethink of " c :held-up-by interf)
- (c-pending-set c interf :interfered)
- #+dfdbg (when (trcp c)
- (trc "!!!!!!!!!! rethink of " c :held-up-by interf)
- #+nah (dump-stale-path interf)
- )
- (return-from c-rethink))
- (when (sw-pending c)
- (trc nil "no interference now for " c)
- (c-pending-set c nil :dis-interfered)))
-
- (when (cmdead c)
- (trc nil "woohoo!!! interference checking finished model off" c)
- (return-from c-rethink))
-
- (unless (c-true-stalep c)
- (trc nil "woohoo!!! interference checking refreshed" c)
- (return-from c-rethink))
-
- (typecase c
- (c-ruled (c-calculate-and-set c))
-
- (synapse
- (trc nil "c-rethink > testing rethink of: syn,salv,valu" c salvage (c-value (syn-used c)))
- (if (funcall (syn-fire-p c) c (c-value (syn-used c)))
- (progn
- (trc nil "c-rethink> decide yes on rethink on syn, valu" c (c-value (syn-used c)))
- (c-rethink (syn-user c)))
- (trc nil "c-rethink> decide nooooo on rethink on synapse" c (syn-user c) salvage)))
- ))
-
-(defmacro def-c-echo (slotname
- (&optional (selfarg 'self) (newvarg 'new-value)
- (oldvarg 'old-value) (oldvargboundp 'old-value-boundp))
- &body echobody)
- ;;;(trc "echo body" echobody)
- `(progn
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (setf (get ',slotname :echo-defined) t))
- ,(if (eql (last1 echobody) :test)
- (let ((temp1 (gensym))
- (loc-self (gensym)))
- `(defmethod c-echo-slot-name #-(or clisp cormanlisp) progn ((slotname (eql ',slotname)) ,selfarg ,newvarg ,oldvarg ,oldvargboundp)
- (let ((,temp1 (bump-echo-count ,slotname))
- (,loc-self ,(if (listp selfarg)
- (car selfarg)
- selfarg)))
- (when (and ,oldvargboundp ,oldvarg)
- (format t "~&echo ~d (~a ~a) old: ~a" ,temp1 ',slotname ,loc-self ,oldvarg))
- (format t "~&echo ~d (~a ~a) new: ~a" ,temp1 ',slotname ,loc-self ,newvarg))))
- `(defmethod c-echo-slot-name
- #-(or clisp cormanlisp) progn
- ((slotname (eql ',slotname)) ,selfarg ,newvarg ,oldvarg ,oldvargboundp)
- (declare (ignorable ,(etypecase selfarg
- (list (car selfarg))
- (atom selfarg))
- ,(etypecase newvarg
- (list (car newvarg))
- (atom newvarg))
- ,(etypecase oldvarg
- (list (car oldvarg))
- (atom oldvarg))
- ,(etypecase oldvargboundp
- (list (car oldvargboundp))
- (atom oldvargboundp))))
- , at echobody))))
-
-(defmacro bump-echo-count (slotname) ;; pure test func
- `(if (get ',slotname :echos)
- (incf (get ',slotname :echos))
- (setf (get ',slotname :echos) 1)))
-
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+(defparameter *echodone* nil)
+
+(defun c-echo-defined (slot-name)
+ (getf (symbol-plist slot-name) :echo-defined))
+
+(defmethod (setf c-true-stalep) (newvalue (user c-ruled))
+ #+dfdbg (trc user "setting c-true-stalep" user newvalue)
+ (c-assert (find user (cells (c-model user)) :key #'cdr))
+ (setf (cd-stale-p user) newvalue))
+
+(defmethod (setf c-true-stalep) (newvalue (usersyn synapse))
+ #+dfdbg (trc (syn-user usersyn) "synapse setting c-true-stalep" (syn-user usersyn) newvalue usersyn)
+ (setf (cd-stale-p (syn-user usersyn)) newvalue))
+
+(defmethod (setf c-true-stalep) (newvalue other)
+ (declare (ignore other))
+ newvalue)
+
+(defun c-echo-initially (self slot-spec)
+ "call during instance init. if echo is defined for slot, and value is non-nil (controversial) force initial echo."
+ (trc nil "c-echo-initially" self slot-spec
+ (c-echo-defined (slot-spec-name slot-spec))
+ (md-slot-cell self slot-spec))
+ (if (c-echo-defined (slot-spec-name slot-spec))
+ (bif (c (md-slot-cell self slot-spec))
+ (etypecase c
+ (c-variable (md-propagate self slot-spec (c-value c) nil nil))
+ (c-ruled (md-slot-value self slot-spec))) ;; this will echo after calculating if not nil
+ ;
+ ; new for 22-03-07: echo even if slot value is nil...
+ (c-echo-slot-name (slot-spec-name slot-spec)
+ self
+ (bd-slot-value self slot-spec)
+ nil nil))
+ (bwhen (c (md-slot-cell self slot-spec))
+ (c-ephemeral-reset c))))
+
+#-(or cormanlisp clisp)
+(defgeneric c-echo-slot-name (slotname self new old old-boundp) (:method-combination progn))
+
+
+(defmethod c-echo-slot-name
+ #-(or cormanlisp clisp) progn
+ #+(or cormanlisp clisp) :before
+ (slot-name self new old old-boundp)
+ (declare (ignorable slot-name self new old old-boundp)))
+
+#+(or cormanlisp clisp)
+(defmethod c-echo-slot-name (slot-name self new old old-boundp)
+ (declare (ignorable slot-name self new old old-boundp)))
+
+;--------------- propagate ----------------------------
+;
+; n.b. 990414kt the cell argument may have been optimized away,
+; though it is still receiving final processing here.
+;
+
+(defun md-propagate (self slot-spec newvalue priorvalue priorvalue-supplied)
+ (when (mdead self)
+ (trc nil "md-propagate n-opping dead" self)
+ (return-from md-propagate nil))
+
+ (let (*c-calculators*
+ (*c-prop-depth* (1+ *c-prop-depth*))
+ (c (md-slot-cell self slot-spec)))
+ ;
+ ;------ debug stuff ---------
+ ;
+ (when *stop*
+ (princ #\.)(princ #\!)
+ (return-from md-propagate))
+
+ (when c
+ (trc nil "md-propagate> propping" self slot-spec (length (c-users c)) c)
+ )
+
+ (when *c-debug*
+ (when (> *c-prop-depth* 250)
+ (trc "md-propagate deep" *c-prop-depth* self (slot-spec-name slot-spec) #+nah c))
+ (when (> *c-prop-depth* 300)
+ (c-break "md-propagate looping ~c" c)
+ ))
+
+ (when c
+ ; ------ flag dependents as stale ------------
+ ; do before echo in case echo gets back to some user
+ ;
+ (dolist (user (c-users c))
+ #+dfdbg (trc user "md-prop now setting stale (changer, stale):" c user)
+ (when (c-user-cares user)
+ (setf (c-true-stalep user) c))))
+
+ ; --- manifest new value as needed -----------
+ (when (c-echo-defined (slot-spec-name slot-spec)) ;; /// faster than just dispatching?
+ (when c (trc nil "md-prop now echoing" c))
+ (c-echo-slot-name (slot-spec-name slot-spec)
+ self
+ newvalue
+ priorvalue
+ priorvalue-supplied)
+ (when (mdead self) ;; hopefully expiration on perishable class
+ (return-from md-propagate)))
+
+ (when c ; --- now propagate to dependents ------------
+ (trc nil "md-prop checking dependents" c (c-users c))
+ (let ((*cause* c))
+ (dolist (user (c-users c))
+ (unless (cmdead user)
+ (when (c-user-cares user)
+ (if (c-user-lazy user)
+ (progn
+ (trc nil "lazy user not being propagated to" user :by c)
+ (dolist (u (c-users user))
+ (c-propagate-staleness u)))
+ (progn
+ (c-rethink user)
+ (when (mdead self)
+ (trc nil "md-propagate> self now dead after rethink user: ~a" self user)
+ (return-from md-propagate nil))
+ )))))
+ (c-ephemeral-reset c)))))
+
+(defmethod c-propagate-staleness ((c c-ruled))
+ (trc nil "inheriting staleness" c)
+ (dolist (u (cr-users c))
+ (c-propagate-staleness u)))
+
+(defmethod c-propagate-staleness ((s synapse))
+ (trc "I hope this synapse isn't for efficiency" s)
+ (break)
+ (c-propagate-staleness (syn-user s)))
+
+(defmethod c-propagate-staleness (c)
+ (declare (ignorable c))
+ (trc "not inheriting or proagating staleness" c)
+ )
+
+(defmethod c-user-cares (c) c) ;; ie, t
+(defmethod c-user-cares ((s synapse))
+ (syn-relevant s))
+
+(defmethod c-user-lazy (c) (declare (ignore c)) nil)
+(defmethod c-user-lazy ((c c-ruled))
+ (cr-lazy c))
+
+
+(defun c-ephemeral-reset (c)
+ (when c
+ (when (c-ephemeral-p c)
+ (trc nil "c-ephemeral-reset resetting:" c)
+ (setf (c-value c) nil)))) ;; good q: what does (setf <ephem> 'x) return? historically nil, but...?
+
+;----------------- change detection ---------------------------------
+
+(defun c-no-news (c newvalue oldvalue)
+ ;;; (trc nil "c-no-news > checking news between" newvalue oldvalue)
+
+ (bIf (test (c-unchanged-test (c-model c) (c-slot-name c)))
+ (funcall test newvalue oldvalue)
+ (eql newvalue oldvalue)))
+
+(defmacro def-c-unchanged-test ((class slotname) &body test)
+ `(defmethod c-unchanged-test ((self ,class) (slotname (eql ',slotname)))
+ , at test))
+
+(defmethod c-unchanged-test (self slotname)
+ (declare (ignore self slotname))
+ nil)
+
+(defmethod c-identity-p ((value null)) t)
+(defmethod c-identity-p ((value number)) (zerop value))
+(defmethod c-identity-p ((value cons))
+ ;; this def a little suspect?
+ (and (c-identity-p (car value))
+ (c-identity-p (cdr value))))
+
+
+;------------------- re think ---------------------------------
+
+(defun cmdead (c)
+ (if (typep c 'synapse)
+ (cmdead (syn-user c))
+ (if (null (c-model c))
+ (not (c-optimized-away-p c))
+ (mdead (c-model c)))))
+
+(defun mdead (m) (eq :eternal-rest (md-state m)))
+
+(defun c-rethink (c)
+ (when *stop*
+ (princ #\.)
+ (return-from c-rethink))
+ ;;(trc "rethink entry: c, true-stale" c (c-true-stalep c))
+ (c-assert (not (cmdead c))() "rethink entry cmdead ~a" c)
+ (unless (c-true-stalep c)
+ (return-from c-rethink))
+
+ (when *rethink-deferred*
+ (trc nil "bingo!!!!!! rethink deferring" c *cause*)
+ (push (list c *cause*) *rethink-deferred*)
+ (return-from c-rethink))
+
+ (c-assert (not (cmdead c))() "rethink here?? cmdead ~a" c)
+
+ ; looking ahead for interference avoids JIT detection, which where a dependency
+ ; already exists causes re-entrance into the rule, which should calculate the same
+ ; value twice and echo only once, but still seems like something to avoid since
+ ; we do already have the technology.
+ ;
+
+ (bIf (interf (sw-detect-interference c nil))
+ (progn
+ (trc "!!!!!!!!!! rethink of " c :held-up-by interf)
+ (c-pending-set c interf :interfered)
+ #+dfdbg (when (trcp c)
+ (trc "!!!!!!!!!! rethink of " c :held-up-by interf)
+ #+nah (dump-stale-path interf)
+ )
+ (return-from c-rethink))
+ (when (sw-pending c)
+ (trc nil "no interference now for " c)
+ (c-pending-set c nil :dis-interfered)))
+
+ (when (cmdead c)
+ (trc nil "woohoo!!! interference checking finished model off" c)
+ (return-from c-rethink))
+
+ (unless (c-true-stalep c)
+ (trc nil "woohoo!!! interference checking refreshed" c)
+ (return-from c-rethink))
+
+ (typecase c
+ (c-ruled (c-calculate-and-set c))
+
+ (synapse
+ (trc nil "c-rethink > testing rethink of: syn,salv,valu" c salvage (c-value (syn-used c)))
+ (if (funcall (syn-fire-p c) c (c-value (syn-used c)))
+ (progn
+ (trc nil "c-rethink> decide yes on rethink on syn, valu" c (c-value (syn-used c)))
+ (c-rethink (syn-user c)))
+ (trc nil "c-rethink> decide nooooo on rethink on synapse" c (syn-user c) salvage)))
+ ))
+
+(defmacro def-c-echo (slotname
+ (&optional (selfarg 'self) (newvarg 'new-value)
+ (oldvarg 'old-value) (oldvargboundp 'old-value-boundp))
+ &body echobody)
+ ;;;(trc "echo body" echobody)
+ `(progn
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf (get ',slotname :echo-defined) t))
+ ,(if (eql (last1 echobody) :test)
+ (let ((temp1 (gensym))
+ (loc-self (gensym)))
+ `(defmethod c-echo-slot-name #-(or clisp cormanlisp) progn ((slotname (eql ',slotname)) ,selfarg ,newvarg ,oldvarg ,oldvargboundp)
+ (let ((,temp1 (bump-echo-count ,slotname))
+ (,loc-self ,(if (listp selfarg)
+ (car selfarg)
+ selfarg)))
+ (when (and ,oldvargboundp ,oldvarg)
+ (format t "~&echo ~d (~a ~a) old: ~a" ,temp1 ',slotname ,loc-self ,oldvarg))
+ (format t "~&echo ~d (~a ~a) new: ~a" ,temp1 ',slotname ,loc-self ,newvarg))))
+ `(defmethod c-echo-slot-name
+ #-(or clisp cormanlisp) progn
+ ((slotname (eql ',slotname)) ,selfarg ,newvarg ,oldvarg ,oldvargboundp)
+ (declare (ignorable ,(etypecase selfarg
+ (list (car selfarg))
+ (atom selfarg))
+ ,(etypecase newvarg
+ (list (car newvarg))
+ (atom newvarg))
+ ,(etypecase oldvarg
+ (list (car oldvarg))
+ (atom oldvarg))
+ ,(etypecase oldvargboundp
+ (list (car oldvargboundp))
+ (atom oldvargboundp))))
+ , at echobody))))
+
+(defmacro bump-echo-count (slotname) ;; pure test func
+ `(if (get ',slotname :echos)
+ (incf (get ',slotname :echos))
+ (setf (get ',slotname :echos) 1)))
+
Index: cells/qells.lisp
diff -u cells/qells.lisp:1.1.1.1 cells/qells.lisp:1.2
--- cells/qells.lisp:1.1.1.1 Sat Nov 8 18:44:34 2003
+++ cells/qells.lisp Tue Dec 16 10:02:58 2003
@@ -1,326 +1,326 @@
-;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
-;;;
-;;; Copyright © 1995,2003 by Kenneth William Tilton.
-;;;
-;;; Permission is hereby granted, free of charge, to any person obtaining a copy
-;;; of this software and associated documentation files (the "Software"), to deal
-;;; in the Software without restriction, including without limitation the rights
-;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-;;; copies of the Software, and to permit persons to whom the Software is furnished
-;;; to do so, subject to the following conditions:
-;;;
-;;; The above copyright notice and this permission notice shall be included in
-;;; all copies or substantial portions of the Software.
-;;;
-;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
-;;; IN THE SOFTWARE.
-
-(in-package :cells)
-
-
-(defconstant *c-optimizep* t)
-(defvar *c-prop-depth* 0)
-(defvar *rethinker* nil)
-(defvar *rethink-deferred* nil)
-(defvar *synapse-factory* nil)
-(defvar *sw-looping* nil)
-
-(defun cell-reset ()
- (kwt-reset)
- (setf
- *c-prop-depth* 0
- *sw-looping* nil
- *to-be-awakened* nil
- ))
-
-
-(defun cellstop ()
- (break :in-cell-stop)
- (setf *stop* t))
-
-(defun cellbrk (&optional (tag :anon))
- (unless (or *stop*)
- ;; daring move, hoping having handler at outside stops the game (cellstop)
- (print `(cell break , tag))
- (break)))
-
-(defparameter *c-debug*
- #+runtime-system nil
- #-runtime-system nil) ;; make latter t when in trouble
-
-
-(defvar *c-calculators* nil)
-
-(defmacro without-c-dependency (&body body)
- `(let (*c-calculators*) , at body))
-
-(defun slot-spec-name (slot-spec)
- slot-spec)
-
-(cc-defstruct (cell (:conc-name c-))
- waking-state
- model
- slot-spec
- value
- )
-
-(defun c-slot-name (c)
- (slot-spec-name (c-slot-spec c)))
-
-(defun c-validate (self c)
- (when (not (and (c-slot-spec c) (c-model c)))
-;;; (setf *stop* t)
- (format t "~&unadopted cell: ~s md:~s, awake:~s" c self (c-waking-state self))
- (error 'c-unadopted :cell c)))
-
-(defmethod c-when (other)
- (declare (ignorable other)) nil) ;; /// needs work
-
-(cc-defstruct (synapse
- (:include cell)
- (:conc-name syn-))
- user
- used
- fire-p
- relay-value)
-
-(defmacro mksynapse ((&rest closeovervars) &key fire-p relay-value)
- (let ((used (copy-symbol 'used)) (user (copy-symbol 'user)))
- `(lambda (,used ,user)
- ;; (trc "making synapse between user" ,user :and :used ,used)
- (let (, at closeovervars)
- (make-synapse
- :used ,used
- ;;; 210207kt why? use (c-model (syn-used <syn>)) :c-model (c-model ,used)
- :user ,user
-
- :fire-p ,fire-p
- :relay-value ,relay-value)))))
-
-(defmethod print-object ((syn synapse) stream)
- (format stream "{syn ~s ==> ~s" (syn-used syn) (syn-user syn)))
-
-
-(defmethod c-true-stalep ((syn synapse))
- (cd-stale-p (syn-user syn)))
-
-(cc-defstruct (c-user-notifying
- (:include cell)
- (:conc-name un-))
- (users nil :type list))
-
-(cc-defstruct (c-unsteady
- (:include c-user-notifying)
- (:conc-name unst-))
- cyclic-p
- delta-p
- setting-p)
-
-(cc-defstruct (c-variable
- (:include c-unsteady)))
-
-(cc-defstruct (c-ruled
- (:include c-unsteady)
- (:conc-name cr-))
- (state :unbound :type symbol)
- (rethinking 0 :type number)
- rule)
-
-(defun c-optimized-away-p (c)
- (eql :optimized-away (c-state c)))
-
-;----------------------------
-
-
-(defmethod c-true-stalep (c)
- (declare (ignore c)))
-
-(cc-defstruct (c-independent
- ;;
- ;; these do not optimize away, because also these can be set after initial evaluation of the rule,
- ;; so users better stay tuned.
- ;; the whole idea here is that the old idea of having cv bodies evaluated immediately finally
- ;; broke down when we wanted to say :kids (cv (list (fm-other vertex)))
- ;;
- (:include c-ruled)))
-
-;;;(defmethod trcp ((c c-dependent))
-;;; (trcp (c-model c)))
-
-(cc-defstruct (c-dependent
- (:include c-ruled)
- (:conc-name cd-))
- (useds nil :type list)
- (code nil :type list) ;; /// feature this out on production build
- (usage (make-array *cd-usagect* :element-type 'bit
- :initial-element 0) :type vector)
- stale-p
- )
-
-
-(defmethod c-true-stalep ((c c-dependent))
- (cd-stale-p c))
-
-(cc-defstruct (c-stream
- (:include c-ruled)
- (:conc-name cs-))
- values)
-
-;;; (defmacro cell~ (&body body)
-;;; `(make-c-stream
-;;; :rule (lambda ,@*c-lambda*
-;;; , at body)))
-
-(cc-defstruct (c-drifter
- (:include c-dependent)))
-
-(cc-defstruct (c-drifter-absolute
- (:include c-drifter)))
-
-;_____________________ accessors __________________________________
-
-
-(defun (setf c-state) (new-value c)
- (if (typep c 'c-ruled)
- (setf (cr-state c) new-value)
- new-value))
-
-(defun c-state (c)
- (if (typep c 'c-ruled)
- (cr-state c)
- :valid))
-
-(defun c-unboundp (c)
- (eql :unbound (c-state c)))
-
-(defun c-validp (c)
- (find (c-state c) '(:valid :optimized-away)))
-
-;_____________________ print __________________________________
-
-(defmethod print-object :before ((c c-variable) stream)
- (declare (ignorable c))
- (format stream "[var:"))
-
-(defmethod print-object :before ((c c-dependent) stream)
- (declare (ignorable c))
- (format stream "[dep~a:" (cond
- ((null (c-model c)) #\0)
- ((eq :eternal-rest (md-state (c-model c))) #\_)
- ((cd-stale-p c) #\#)
- ((sw-pending c) #\?)
- (t #\space))))
-
-(defmethod print-object :before ((c c-independent) stream)
- (declare (ignorable c))
- (format stream "[ind:"))
-
-(defmethod print-object ((c cell) stream)
- (c-print-value c stream)
- (format stream "=~a/~a]"
- (symbol-name (or (c-slot-name c) :anoncell))
- (or (c-model c) :anonmd))
- #+dfdbg (unless *stop*
- (assert (find c (cells (c-model c)) :key #'cdr)))
- )
-
-
-;__________________
-
-(defmethod c-print-value ((c c-ruled) stream)
- (format stream "~a" (cond ((unst-setting-p c) "<^^^>")
- ((c-validp c) "<vld>")
- ((c-unboundp c) "<unb>")
- ((cd-stale-p c) "<obs>")
- (t "<err>"))))
-
-(defmethod c-print-value (c stream)
- (declare (ignore c stream)))
-
-
-;____________________ constructors _______________________________
-
-(defmacro c? (&body body)
- `(make-c-dependent
- :code ',body
- :rule (lambda (c &aux (self (c-model c)))
- (declare (ignorable self c))
- , at body)))
- (define-symbol-macro .cache. (c-value c))
-
-(defmacro c?? ((&key (tagp nil) (in nil) (trigger nil) (out t))&body body)
- (let ((result (copy-symbol 'result))
- (thetag (gensym)))
- `(make-c-dependent
- :code ',body
- :rule (lambda (c &aux (self (c-model c)))
- (declare (ignorable self c))
- (let ((,thetag (gensym "tag"))
- (*trcdepth* (1+ *trcdepth*))
- )
- (declare (ignorable self ,thetag))
- ,(when in
- `(trc "c??> entry" (c-slot-name c) (c-model c) (when ,tagp ,thetag)))
- ,(when trigger `(trc "c??> trigger" *rethinker* c))
- (count-it :c?? (c-slot-name c) (md-name (c-model c)))
- (let ((,result (progn , at body)))
- ,(when out `(trc "c?? result:" ,result (c-slot-name c) (when ,tagp ,thetag)))
- ,result))))))
-
-
-(defmacro cv (defn)
- `(make-c-variable
- :value ,defn)) ;; use c-independent if need deferred execution
-
-(defmacro cv8 (defn)
- `(make-c-variable
- :cyclic-p t
- :value ,defn)) ;; use c-independent if need deferred execution
-
-
-(defmacro c... ((value) &body body)
- `(make-c-drifter
- :code ',body
- :value ,value
- :rule (lambda (c &aux (self (c-model c)))
- (declare (ignorable self c))
- , at body)))
-
-(defmacro c-abs (value &body body)
- `(make-c-drifter-absolute
- :code ',body
- :value ,value
- :rule (lambda (c &aux (self (c-model c)))
- (declare (ignorable self c))
- , at body)))
-
-
-;;; (defmacro c?v (&body body)
-;;; `(make-c-independent
-;;; :rule (lambda ,@*c-lambda*
-;;; (declare (ignorable self askingcells))
-;;; , at body)))
-;;;
-;;; (defmacro cvpi ((&body options) defn)
-;;; `(make-c-variable :value ,defn
-;;; , at options))
-;;;
-;;; (defmacro ts? (&body body)
-;;; `(lambda (self)
-;;; (declare (ignorable self))
-;;; , at body))
-;;;
-(defmacro c8 (&body body)
- `(make-c-dependent
- :cyclic-p t
- :rule (lambda (c)
- (let ((self (c-model c))
- (*c-calculators* (cons c *c-calculators*))
- *synapse-factory* ;; clear then re-estab via with-synapse on specific dependencies
- )
- , at body))))
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+
+(defconstant *c-optimizep* t)
+(defvar *c-prop-depth* 0)
+(defvar *rethinker* nil)
+(defvar *rethink-deferred* nil)
+(defvar *synapse-factory* nil)
+(defvar *sw-looping* nil)
+
+(defun cell-reset ()
+ (kwt-reset)
+ (setf
+ *c-prop-depth* 0
+ *sw-looping* nil
+ *to-be-awakened* nil
+ ))
+
+
+(defun cellstop ()
+ (break :in-cell-stop)
+ (setf *stop* t))
+
+(defun cellbrk (&optional (tag :anon))
+ (unless (or *stop*)
+ ;; daring move, hoping having handler at outside stops the game (cellstop)
+ (print `(cell break , tag))
+ (break)))
+
+(defparameter *c-debug*
+ #+runtime-system nil
+ #-runtime-system nil) ;; make latter t when in trouble
+
+
+(defvar *c-calculators* nil)
+
+(defmacro without-c-dependency (&body body)
+ `(let (*c-calculators*) , at body))
+
+(defun slot-spec-name (slot-spec)
+ slot-spec)
+
+(cc-defstruct (cell (:conc-name c-))
+ waking-state
+ model
+ slot-spec
+ value
+ )
+
+(defun c-slot-name (c)
+ (slot-spec-name (c-slot-spec c)))
+
+(defun c-validate (self c)
+ (when (not (and (c-slot-spec c) (c-model c)))
+;;; (setf *stop* t)
+ (format t "~&unadopted cell: ~s md:~s, awake:~s" c self (c-waking-state self))
+ (error 'c-unadopted :cell c)))
+
+(defmethod c-when (other)
+ (declare (ignorable other)) nil) ;; /// needs work
+
+(cc-defstruct (synapse
+ (:include cell)
+ (:conc-name syn-))
+ user
+ used
+ fire-p
+ relay-value)
+
+(defmacro mksynapse ((&rest closeovervars) &key fire-p relay-value)
+ (let ((used (copy-symbol 'used)) (user (copy-symbol 'user)))
+ `(lambda (,used ,user)
+ ;; (trc "making synapse between user" ,user :and :used ,used)
+ (let (, at closeovervars)
+ (make-synapse
+ :used ,used
+ ;;; 210207kt why? use (c-model (syn-used <syn>)) :c-model (c-model ,used)
+ :user ,user
+
+ :fire-p ,fire-p
+ :relay-value ,relay-value)))))
+
+(defmethod print-object ((syn synapse) stream)
+ (format stream "{syn ~s ==> ~s" (syn-used syn) (syn-user syn)))
+
+
+(defmethod c-true-stalep ((syn synapse))
+ (cd-stale-p (syn-user syn)))
+
+(cc-defstruct (c-user-notifying
+ (:include cell)
+ (:conc-name un-))
+ (users nil :type list))
+
+(cc-defstruct (c-unsteady
+ (:include c-user-notifying)
+ (:conc-name unst-))
+ cyclic-p
+ delta-p
+ setting-p)
+
+(cc-defstruct (c-variable
+ (:include c-unsteady)))
+
+(cc-defstruct (c-ruled
+ (:include c-unsteady)
+ (:conc-name cr-))
+ (state :unbound :type symbol)
+ (rethinking 0 :type number)
+ rule)
+
+(defun c-optimized-away-p (c)
+ (eql :optimized-away (c-state c)))
+
+;----------------------------
+
+
+(defmethod c-true-stalep (c)
+ (declare (ignore c)))
+
+(cc-defstruct (c-independent
+ ;;
+ ;; these do not optimize away, because also these can be set after initial evaluation of the rule,
+ ;; so users better stay tuned.
+ ;; the whole idea here is that the old idea of having cv bodies evaluated immediately finally
+ ;; broke down when we wanted to say :kids (cv (list (fm-other vertex)))
+ ;;
+ (:include c-ruled)))
+
+;;;(defmethod trcp ((c c-dependent))
+;;; (trcp (c-model c)))
+
+(cc-defstruct (c-dependent
+ (:include c-ruled)
+ (:conc-name cd-))
+ (useds nil :type list)
+ (code nil :type list) ;; /// feature this out on production build
+ (usage (make-array *cd-usagect* :element-type 'bit
+ :initial-element 0) :type vector)
+ stale-p
+ )
+
+
+(defmethod c-true-stalep ((c c-dependent))
+ (cd-stale-p c))
+
+(cc-defstruct (c-stream
+ (:include c-ruled)
+ (:conc-name cs-))
+ values)
+
+;;; (defmacro cell~ (&body body)
+;;; `(make-c-stream
+;;; :rule (lambda ,@*c-lambda*
+;;; , at body)))
+
+(cc-defstruct (c-drifter
+ (:include c-dependent)))
+
+(cc-defstruct (c-drifter-absolute
+ (:include c-drifter)))
+
+;_____________________ accessors __________________________________
+
+
+(defun (setf c-state) (new-value c)
+ (if (typep c 'c-ruled)
+ (setf (cr-state c) new-value)
+ new-value))
+
+(defun c-state (c)
+ (if (typep c 'c-ruled)
+ (cr-state c)
+ :valid))
+
+(defun c-unboundp (c)
+ (eql :unbound (c-state c)))
+
+(defun c-validp (c)
+ (find (c-state c) '(:valid :optimized-away)))
+
+;_____________________ print __________________________________
+
+(defmethod print-object :before ((c c-variable) stream)
+ (declare (ignorable c))
+ (format stream "[var:"))
+
+(defmethod print-object :before ((c c-dependent) stream)
+ (declare (ignorable c))
+ (format stream "[dep~a:" (cond
+ ((null (c-model c)) #\0)
+ ((eq :eternal-rest (md-state (c-model c))) #\_)
+ ((cd-stale-p c) #\#)
+ ((sw-pending c) #\?)
+ (t #\space))))
+
+(defmethod print-object :before ((c c-independent) stream)
+ (declare (ignorable c))
+ (format stream "[ind:"))
+
+(defmethod print-object ((c cell) stream)
+ (c-print-value c stream)
+ (format stream "=~a/~a]"
+ (symbol-name (or (c-slot-name c) :anoncell))
+ (or (c-model c) :anonmd))
+ #+dfdbg (unless *stop*
+ (assert (find c (cells (c-model c)) :key #'cdr)))
+ )
+
+
+;__________________
+
+(defmethod c-print-value ((c c-ruled) stream)
+ (format stream "~a" (cond ((unst-setting-p c) "<^^^>")
+ ((c-validp c) "<vld>")
+ ((c-unboundp c) "<unb>")
+ ((cd-stale-p c) "<obs>")
+ (t "<err>"))))
+
+(defmethod c-print-value (c stream)
+ (declare (ignore c stream)))
+
+
+;____________________ constructors _______________________________
+
+(defmacro c? (&body body)
+ `(make-c-dependent
+ :code ',body
+ :rule (lambda (c &aux (self (c-model c)))
+ (declare (ignorable self c))
+ , at body)))
+ (define-symbol-macro .cache. (c-value c))
+
+(defmacro c?? ((&key (tagp nil) (in nil) (trigger nil) (out t))&body body)
+ (let ((result (copy-symbol 'result))
+ (thetag (gensym)))
+ `(make-c-dependent
+ :code ',body
+ :rule (lambda (c &aux (self (c-model c)))
+ (declare (ignorable self c))
+ (let ((,thetag (gensym "tag"))
+ (*trcdepth* (1+ *trcdepth*))
+ )
+ (declare (ignorable self ,thetag))
+ ,(when in
+ `(trc "c??> entry" (c-slot-name c) (c-model c) (when ,tagp ,thetag)))
+ ,(when trigger `(trc "c??> trigger" *rethinker* c))
+ (count-it :c?? (c-slot-name c) (md-name (c-model c)))
+ (let ((,result (progn , at body)))
+ ,(when out `(trc "c?? result:" ,result (c-slot-name c) (when ,tagp ,thetag)))
+ ,result))))))
+
+
+(defmacro cv (defn)
+ `(make-c-variable
+ :value ,defn)) ;; use c-independent if need deferred execution
+
+(defmacro cv8 (defn)
+ `(make-c-variable
+ :cyclic-p t
+ :value ,defn)) ;; use c-independent if need deferred execution
+
+
+(defmacro c... ((value) &body body)
+ `(make-c-drifter
+ :code ',body
+ :value ,value
+ :rule (lambda (c &aux (self (c-model c)))
+ (declare (ignorable self c))
+ , at body)))
+
+(defmacro c-abs (value &body body)
+ `(make-c-drifter-absolute
+ :code ',body
+ :value ,value
+ :rule (lambda (c &aux (self (c-model c)))
+ (declare (ignorable self c))
+ , at body)))
+
+
+;;; (defmacro c?v (&body body)
+;;; `(make-c-independent
+;;; :rule (lambda ,@*c-lambda*
+;;; (declare (ignorable self askingcells))
+;;; , at body)))
+;;;
+;;; (defmacro cvpi ((&body options) defn)
+;;; `(make-c-variable :value ,defn
+;;; , at options))
+;;;
+;;; (defmacro ts? (&body body)
+;;; `(lambda (self)
+;;; (declare (ignorable self))
+;;; , at body))
+;;;
+(defmacro c8 (&body body)
+ `(make-c-dependent
+ :cyclic-p t
+ :rule (lambda (c)
+ (let ((self (c-model c))
+ (*c-calculators* (cons c *c-calculators*))
+ *synapse-factory* ;; clear then re-estab via with-synapse on specific dependencies
+ )
+ , at body))))
Index: cells/qrock.lisp
diff -u cells/qrock.lisp:1.1.1.1 cells/qrock.lisp:1.2
--- cells/qrock.lisp:1.1.1.1 Sat Nov 8 18:44:46 2003
+++ cells/qrock.lisp Tue Dec 16 10:02:58 2003
@@ -1,83 +1,83 @@
-;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
-;;;
-;;;
-;;; Copyright © 1995,2003 by Kenneth William Tilton.
-;;;
-;;; Permission is hereby granted, free of charge, to any person obtaining a copy
-;;; of this software and associated documentation files (the "Software"), to deal
-;;; in the Software without restriction, including without limitation the rights
-;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-;;; copies of the Software, and to permit persons to whom the Software is furnished
-;;; to do so, subject to the following conditions:
-;;;
-;;; The above copyright notice and this permission notice shall be included in
-;;; all copies or substantial portions of the Software.
-;;;
-;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
-;;; IN THE SOFTWARE.
-
-
-(in-package :cells)
-
-(defstruct (qrock (:include strudel-object)(:conc-name nil))
- (.accel 32)
- (.elapsed (cv 0))
- (.dist (c? (floor (* (qaccel self)(expt (elapsed self) 2)) 2))))
-
-(defun qaccel (self)
- (q-slot-value (.accel self)))
-
-(defun (setf qaccel) (newvalue self)
- (setf (md-slot-value self '.accel) newvalue))
-
-(defun elapsed (self)
- (q-slot-value (.elapsed self)))
-
-(defun (setf elapsed) (newvalue self)
- (setf (md-slot-value self '.elapsed) newvalue))
-
-(defun dist (self)
- (q-slot-value (.dist self)))
-
-(defun (setf dist) (newvalue self)
- (setf (md-slot-value self '.dist) newvalue))
-
-(def-c-echo .accel () (trc ".accel" self new-value old-value))
-(def-c-echo .elapsed ()
- (when (typep new-value 'cell) (break))
- (trc ".elapsed" self new-value old-value))
-(def-c-echo .dist () (trc ".dist" self new-value old-value))
-
-(progn
- (setf (md-slot-cell-type 'qrock '.accel) t)
- (setf (md-slot-cell-type 'qrock '.elapsed) t)
- (setf (md-slot-cell-type 'qrock '.dist) t))
-
-(defun make-cell-qrock (&rest iargs)
- (let ((self (apply #'make-qrock iargs)))
- (strudel-initialize self)
- (trc "qcs" (q-cells self))
- self))
-
-#+test
-(let (*to-be-awakened*)
- (let ((r (to-be (make-cell-qrock))))
- (dotimes (n 5)
- (trc "--------------- time " n)
- (setf (elapsed r) n))))
-
-(defmethod strudel-initialize :around ((self qrock))
- (flet ((ci (sn sv)
- (when (typep sv 'cell)
- (q-install self sn sv))))
- (ci '.accel (.accel self))
- (ci '.elapsed (.elapsed self))
- (ci '.dist (.dist self)))
- (call-next-method))
-
-
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+
+(in-package :cells)
+
+(defstruct (qrock (:include strudel-object)(:conc-name nil))
+ (.accel 32)
+ (.elapsed (cv 0))
+ (.dist (c? (floor (* (qaccel self)(expt (elapsed self) 2)) 2))))
+
+(defun qaccel (self)
+ (q-slot-value (.accel self)))
+
+(defun (setf qaccel) (newvalue self)
+ (setf (md-slot-value self '.accel) newvalue))
+
+(defun elapsed (self)
+ (q-slot-value (.elapsed self)))
+
+(defun (setf elapsed) (newvalue self)
+ (setf (md-slot-value self '.elapsed) newvalue))
+
+(defun dist (self)
+ (q-slot-value (.dist self)))
+
+(defun (setf dist) (newvalue self)
+ (setf (md-slot-value self '.dist) newvalue))
+
+(def-c-echo .accel () (trc ".accel" self new-value old-value))
+(def-c-echo .elapsed ()
+ (when (typep new-value 'cell) (break))
+ (trc ".elapsed" self new-value old-value))
+(def-c-echo .dist () (trc ".dist" self new-value old-value))
+
+(progn
+ (setf (md-slot-cell-type 'qrock '.accel) t)
+ (setf (md-slot-cell-type 'qrock '.elapsed) t)
+ (setf (md-slot-cell-type 'qrock '.dist) t))
+
+(defun make-cell-qrock (&rest iargs)
+ (let ((self (apply #'make-qrock iargs)))
+ (strudel-initialize self)
+ (trc "qcs" (q-cells self))
+ self))
+
+#+test
+(let (*to-be-awakened*)
+ (let ((r (to-be (make-cell-qrock))))
+ (dotimes (n 5)
+ (trc "--------------- time " n)
+ (setf (elapsed r) n))))
+
+(defmethod strudel-initialize :around ((self qrock))
+ (flet ((ci (sn sv)
+ (when (typep sv 'cell)
+ (q-install self sn sv))))
+ (ci '.accel (.accel self))
+ (ci '.elapsed (.elapsed self))
+ (ci '.dist (.dist self)))
+ (call-next-method))
+
+
Index: cells/slot-utilities.lisp
diff -u cells/slot-utilities.lisp:1.1.1.1 cells/slot-utilities.lisp:1.2
--- cells/slot-utilities.lisp:1.1.1.1 Sat Nov 8 18:44:46 2003
+++ cells/slot-utilities.lisp Tue Dec 16 10:02:58 2003
@@ -1,91 +1,95 @@
-;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
-;;;
-;;; Copyright © 1995,2003 by Kenneth William Tilton.
-;;;
-;;; Permission is hereby granted, free of charge, to any person obtaining a copy
-;;; of this software and associated documentation files (the "Software"), to deal
-;;; in the Software without restriction, including without limitation the rights
-;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-;;; copies of the Software, and to permit persons to whom the Software is furnished
-;;; to do so, subject to the following conditions:
-;;;
-;;; The above copyright notice and this permission notice shall be included in
-;;; all copies or substantial portions of the Software.
-;;;
-;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
-;;; IN THE SOFTWARE.
-
-(in-package :cells)
-
-(defun c-setting-debug (self slot-spec c newvalue)
- (declare (ignorable newvalue))
- (if (null c)
- (progn
- (format t "c-setting-debug > constant ~a in ~a may not be altered..init to (cv nil)"
- slot-spec self)
- (error "setting-const-cell"))
- (let ((self (c-model c))
- (slot-spec (c-slot-spec c)))
- ;(trc "c-setting-debug sees" c newvalue self slot-spec)
- (when (and c (not (and slot-spec self)))
- ;; cv-test handles errors, so don't set *stop* (cellstop)
- (error 'c-unadopted :cell c))
- (typecase c
- (c-variable)
- (c-independent)
- (c-dependent
- ;(trc "setting c-dependent" c newvalue)
- (format t "c-setting-debug > ruled ~a in ~a may not be setf'ed"
- (c-slot-name c) self)
- (error "setting-ruled-cell"))
- ))))
-
-(defun c-absorb-value (c value)
- (typecase c
- (c-drifter-absolute (c-value-incf c value 0)) ;; strange but true
- (c-drifter (c-value-incf c (c-value c) value))
- (t value)))
-
-(defmethod c-value-incf (c (envaluer c-envaluer) delta)
- (assert (c-model c))
- (c-value-incf c (funcall (envaluerule envaluer) (c-model c))
- delta))
-
-(defmethod c-value-incf (c (base number) delta)
- (declare (ignore c))
- (if delta
- (+ base delta)
- base))
-
-
-;----------------------------------------------------------------------
-
-(defun bd-slot-value (self slot-spec)
- (slot-value self (slot-spec-name slot-spec)))
-
-(defun (setf bd-slot-value) (newvalue self slot-spec)
- (setf (slot-value self (slot-spec-name slot-spec)) newvalue))
-
-(defun bd-bound-slot-value (self slot-spec callerid)
- (declare (ignorable callerid))
- (when (bd-slot-boundp self (slot-spec-name slot-spec))
- (bd-slot-value self (slot-spec-name slot-spec))))
-
-(defun bd-slot-boundp (self slot-spec)
- (slot-boundp self (slot-spec-name slot-spec)))
-
-(defun bd-slot-makunbound (self slot-spec)
- (slot-makunbound self (slot-spec-name slot-spec)))
-
-#| sample incf
-(defmethod c-value-incf ((base fpoint) delta)
- (declare (ignore model))
- (if delta
- (fp-add base delta)
- base))
-|#
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+(defun c-setting-debug (self slot-spec c newvalue)
+ (declare (ignorable newvalue))
+ (if (null c)
+ (progn
+ (format t "c-setting-debug > constant ~a in ~a may not be altered..init to (cv nil)"
+ slot-spec self)
+
+ (c-break "setting-const-cell")
+ (error "setting-const-cell"))
+ (let ((self (c-model c))
+ (slot-spec (c-slot-spec c)))
+ ;(trc "c-setting-debug sees" c newvalue self slot-spec)
+ (when (and c (not (and slot-spec self)))
+ ;; cv-test handles errors, so don't set *stop* (c-stop)
+ (c-break "unadopted ~a for self ~a spec ~a" c self slot-spec)
+ (error 'c-unadopted :cell c))
+ (typecase c
+ (c-variable)
+ (c-dependent
+ ;(trc "setting c-dependent" c newvalue)
+ (format t "c-setting-debug > ruled ~a in ~a may not be setf'ed"
+ (c-slot-name c) self)
+
+ (c-break "setting-ruled-cell")
+ (error "setting-ruled-cell"))
+ ))))
+
+(defun c-absorb-value (c value)
+ (typecase c
+ (c-drifter-absolute (c-value-incf c value 0)) ;; strange but true
+ (c-drifter (c-value-incf c (c-value c) value))
+ (t value)))
+
+(defmethod c-value-incf (c (envaluer c-envaluer) delta)
+ (c-assert (c-model c))
+ (c-value-incf c (funcall (envaluerule envaluer) c)
+ delta))
+
+(defmethod c-value-incf (c (base number) delta)
+ (declare (ignore c))
+ (if delta
+ (+ base delta)
+ base))
+
+
+;----------------------------------------------------------------------
+
+(defun bd-slot-value (self slot-spec)
+ (slot-value self (slot-spec-name slot-spec)))
+
+(defun (setf bd-slot-value) (newvalue self slot-spec)
+ (setf (slot-value self (slot-spec-name slot-spec)) newvalue))
+
+(defun bd-bound-slot-value (self slot-spec callerid)
+ (declare (ignorable callerid))
+ (when (bd-slot-boundp self (slot-spec-name slot-spec))
+ (bd-slot-value self (slot-spec-name slot-spec))))
+
+(defun bd-slot-boundp (self slot-spec)
+ (slot-boundp self (slot-spec-name slot-spec)))
+
+(defun bd-slot-makunbound (self slot-spec)
+ (slot-makunbound self (slot-spec-name slot-spec)))
+
+#| sample incf
+(defmethod c-value-incf ((base fpoint) delta)
+ (declare (ignore model))
+ (if delta
+ (fp-add base delta)
+ base))
+|#
Index: cells/strings.lisp
diff -u cells/strings.lisp:1.1.1.1 cells/strings.lisp:1.2
--- cells/strings.lisp:1.1.1.1 Sat Nov 8 18:44:46 2003
+++ cells/strings.lisp Tue Dec 16 10:02:58 2003
@@ -1,204 +1,204 @@
-;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
-;;;
-;;; Copyright © 1995,2003 by Kenneth William Tilton.
-;;;
-;;; Permission is hereby granted, free of charge, to any person obtaining a copy
-;;; of this software and associated documentation files (the "Software"), to deal
-;;; in the Software without restriction, including without limitation the rights
-;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-;;; copies of the Software, and to permit persons to whom the Software is furnished
-;;; to do so, subject to the following conditions:
-;;;
-;;; The above copyright notice and this permission notice shall be included in
-;;; all copies or substantial portions of the Software.
-;;;
-;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
-;;; IN THE SOFTWARE.
-
-(in-package :cells)
-
-(eval-when (compile load eval)
- (export '(case$ strloc$ make$ space$ char$ conclist$ conc$
- left$ mid$ seg$ right$ insert$ remove$
- trim$ trunc$ abbrev$ empty$ find$ num$
- normalize$ down$ lower$ up$ upper$ equal$
- min$ numeric$ alpha$ assoc$ member$ match-left$
- +return$+ +LF$+)))
-
-(defmacro case$ (stringForm &rest cases)
- (let ((v$ (gensym))
- (default (or (find 'otherwise cases :key #'car)
- (find 'otherwise cases :key #'car))))
- (when default
- (setf cases (delete default cases)))
- `(let ((,v$ ,stringForm))
- (cond
- ,@(mapcar (lambda (caseForms)
- `((string-equal ,v$ ,(car caseForms)) ,@(rest caseForms)))
- cases)
- (t ,@(or (cdr default) `(nil)))))))
-
-;--------
-
-(defmethod shortc (other)
- (declare (ignorable other))
- (concatenate 'string "noshortc" (symbol-name (class-name (class-of other)))))
-
-(defmethod longc (other) (shortc other))
-
-(defmethod shortc ((nada null)) nil)
-(defmethod shortc ((many list))
- (if (consp (cdr many))
- (mapcar #'shortc many)
- (conc$ (shortc (car many)) " " (shortc (cdr many)))))
-(defmethod shortc ((self string)) self)
-(defmethod shortc ((self symbol)) (string self))
-(defmethod shortc ((self number)) (num$ self))
-(defmethod shortc ((self character)) (string self))
-
-;-----------------------
-
-(defun strloc$ (substr str)
- (when (and substr str (not (string= substr "")))
- (search substr str)))
-
-(defun make$ (&optional (size 0) (char #\space))
- (make-string size :initial-element (etypecase char
- (character char)
- (number (code-char char)))))
-
-(DEFUN space$ (size)
- (make$ size))
-
-(defun char$ (char)
- (make$ 1 char))
-
-(defun conclist$ (ss)
- (when ss
- (reduce (lambda (s1 s2) (concatenate 'string s1 s2)) ss)))
-
-(defun conc$ (&rest ss)
- (with-output-to-string (stream)
- (dolist (s ss)
- (when s
- (princ (shortc s) stream)))))
-
-(defun left$ (s n)
- (subseq s 0 (max (min n (length s)) 0)))
-
-(defun mid$ (s offset length)
- (let* ((slen (length s))
- (start (min slen (max offset 0)))
- (end (max start (min (+ offset length) slen))))
- (subseq s start end)))
-
-(defun seg$ (s offset end)
- (let* ((slen (length s))
- (start (min slen (max offset 0)))
- (end (max start (min end slen))))
- (subseq s start end)))
-
-(defun right$ (s n)
- (subseq s (min n (length s))))
-
-(defun insert$ (s c &optional (offset (length s)))
- (conc$ (subseq s 0 offset)
- (string c)
- (subseq s offset)))
-
-(defun remove$ (s offset)
- (conc$ (subseq s 0 (1- offset))
- (subseq s offset)))
-
-(defun trim$ (s)
- (assert (or (null s) (stringp s)))
- (string-trim '(#\space) s))
-
-(defun trunc$ (s char)
- (let ((pos (position char s)))
- (if pos
- (subseq s 0 pos)
- s)))
-
-(defun abbrev$ (long$ max)
- (if (<= (length long$) max)
- long$
- (conc$ (left$ long$ (- max 3)) "...")))
-
-(defmethod empty ((nada null)) t)
-(defmethod empty ((c cons))
- (and (empty (car c))
- (empty (cdr c))))
-(defmethod empty ((s string)) (empty$ s))
-(defmethod empty (other) (declare (ignorable other)) nil)
-
-(defun empty$ (s)
- (or (null s)
- (if (stringp s)
- (string-equal "" (trim$ s))
- #+not (trc nil "empty$> sees non-string" (type-of s)))
- ))
-
-(defmacro find$ (it where &rest args)
- `(find ,it ,where , at args :test #'string-equal))
-
-(defmethod num$ ((n number))
- (format nil "~d" n))
-
-(defmethod num$ (n)
- (format nil "~d" n))
-
-(defun normalize$ (s)
- (etypecase s
- (null "")
- (string (string-downcase s))
- (symbol (string-downcase (symbol-name s)))))
-
-(defun down$ (s)
- (string-downcase s))
-
-(defun lower$ (s)
- (string-downcase s))
-
-(defun up$ (s)
- (string-upcase s))
-
-(defun upper$ (s)
- (string-upcase s))
-
-(defun equal$ (s1 s2)
- (if (empty$ s1)
- (empty$ s2)
- (when s2
- (string-equal s1 s2))))
-
-(defun min$ (&rest ss)
- (cond
- ((null ss) nil)
- ((null (cdr ss)) (car ss))
- (t (let ((rmin$ (apply #'min$ (cdr ss))))
- (if (string< (car ss) rmin$)
- (car ss) rmin$)))))
-
-(defun numeric$ (s &optional trimmed)
- (every (lambda (c) (digit-char-p c)) (if trimmed (Trim$ s) s)))
-
-(defun alpha$ (s)
- (every (lambda (c) (alpha-char-p c)) s))
-
-(defmacro assoc$ (item alist &rest kws)
- `(assoc ,item ,alist :test #'equal , at kws))
-
-(defmacro member$ (item list &rest kws)
- `(member ,item ,list :test #'string= , at kws))
-
-(defun match-left$ (a b)
- (string-equal a (subseq b 0 (length a))))
-
-(defparameter *return$* (conc$ (char$ #\return) (char$ #\linefeed)))
-(defparameter *LF$* (string #\linefeed))
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+(eval-when (compile load eval)
+ (export '(case$ strloc$ make$ space$ char$ conclist$ conc$
+ left$ mid$ seg$ right$ insert$ remove$
+ trim$ trunc$ abbrev$ empty$ find$ num$
+ normalize$ down$ lower$ up$ upper$ equal$
+ min$ numeric$ alpha$ assoc$ member$ match-left$
+ +return$+ +LF$+)))
+
+(defmacro case$ (stringForm &rest cases)
+ (let ((v$ (gensym))
+ (default (or (find 'otherwise cases :key #'car)
+ (find 'otherwise cases :key #'car))))
+ (when default
+ (setf cases (delete default cases)))
+ `(let ((,v$ ,stringForm))
+ (cond
+ ,@(mapcar (lambda (caseForms)
+ `((string-equal ,v$ ,(car caseForms)) ,@(rest caseForms)))
+ cases)
+ (t ,@(or (cdr default) `(nil)))))))
+
+;--------
+
+(defmethod shortc (other)
+ (declare (ignorable other))
+ (concatenate 'string "noshortc" (symbol-name (class-name (class-of other)))))
+
+(defmethod longc (other) (shortc other))
+
+(defmethod shortc ((nada null)) nil)
+(defmethod shortc ((many list))
+ (if (consp (cdr many))
+ (mapcar #'shortc many)
+ (conc$ (shortc (car many)) " " (shortc (cdr many)))))
+(defmethod shortc ((self string)) self)
+(defmethod shortc ((self symbol)) (string self))
+(defmethod shortc ((self number)) (num$ self))
+(defmethod shortc ((self character)) (string self))
+
+;-----------------------
+
+(defun strloc$ (substr str)
+ (when (and substr str (not (string= substr "")))
+ (search substr str)))
+
+(defun make$ (&optional (size 0) (char #\space))
+ (make-string size :initial-element (etypecase char
+ (character char)
+ (number (code-char char)))))
+
+(DEFUN space$ (size)
+ (make$ size))
+
+(defun char$ (char)
+ (make$ 1 char))
+
+(defun conclist$ (ss)
+ (when ss
+ (reduce (lambda (s1 s2) (concatenate 'string s1 s2)) ss)))
+
+(defun conc$ (&rest ss)
+ (with-output-to-string (stream)
+ (dolist (s ss)
+ (when s
+ (princ (shortc s) stream)))))
+
+(defun left$ (s n)
+ (subseq s 0 (max (min n (length s)) 0)))
+
+(defun mid$ (s offset length)
+ (let* ((slen (length s))
+ (start (min slen (max offset 0)))
+ (end (max start (min (+ offset length) slen))))
+ (subseq s start end)))
+
+(defun seg$ (s offset end)
+ (let* ((slen (length s))
+ (start (min slen (max offset 0)))
+ (end (max start (min end slen))))
+ (subseq s start end)))
+
+(defun right$ (s n)
+ (subseq s (min n (length s))))
+
+(defun insert$ (s c &optional (offset (length s)))
+ (conc$ (subseq s 0 offset)
+ (string c)
+ (subseq s offset)))
+
+(defun remove$ (s offset)
+ (conc$ (subseq s 0 (1- offset))
+ (subseq s offset)))
+
+(defun trim$ (s)
+ (c-assert (or (null s) (stringp s)))
+ (string-trim '(#\space) s))
+
+(defun trunc$ (s char)
+ (let ((pos (position char s)))
+ (if pos
+ (subseq s 0 pos)
+ s)))
+
+(defun abbrev$ (long$ max)
+ (if (<= (length long$) max)
+ long$
+ (conc$ (left$ long$ (- max 3)) "...")))
+
+(defmethod empty ((nada null)) t)
+(defmethod empty ((c cons))
+ (and (empty (car c))
+ (empty (cdr c))))
+(defmethod empty ((s string)) (empty$ s))
+(defmethod empty (other) (declare (ignorable other)) nil)
+
+(defun empty$ (s)
+ (or (null s)
+ (if (stringp s)
+ (string-equal "" (trim$ s))
+ #+not (trc nil "empty$> sees non-string" (type-of s)))
+ ))
+
+(defmacro find$ (it where &rest args)
+ `(find ,it ,where , at args :test #'string-equal))
+
+(defmethod num$ ((n number))
+ (format nil "~d" n))
+
+(defmethod num$ (n)
+ (format nil "~d" n))
+
+(defun normalize$ (s)
+ (etypecase s
+ (null "")
+ (string (string-downcase s))
+ (symbol (string-downcase (symbol-name s)))))
+
+(defun down$ (s)
+ (string-downcase s))
+
+(defun lower$ (s)
+ (string-downcase s))
+
+(defun up$ (s)
+ (string-upcase s))
+
+(defun upper$ (s)
+ (string-upcase s))
+
+(defun equal$ (s1 s2)
+ (if (empty$ s1)
+ (empty$ s2)
+ (when s2
+ (string-equal s1 s2))))
+
+(defun min$ (&rest ss)
+ (cond
+ ((null ss) nil)
+ ((null (cdr ss)) (car ss))
+ (t (let ((rmin$ (apply #'min$ (cdr ss))))
+ (if (string< (car ss) rmin$)
+ (car ss) rmin$)))))
+
+(defun numeric$ (s &optional trimmed)
+ (every (lambda (c) (digit-char-p c)) (if trimmed (Trim$ s) s)))
+
+(defun alpha$ (s)
+ (every (lambda (c) (alpha-char-p c)) s))
+
+(defmacro assoc$ (item alist &rest kws)
+ `(assoc ,item ,alist :test #'equal , at kws))
+
+(defmacro member$ (item list &rest kws)
+ `(member ,item ,list :test #'string= , at kws))
+
+(defun match-left$ (a b)
+ (string-equal a (subseq b 0 (length a))))
+
+(defparameter *return$* (conc$ (char$ #\return) (char$ #\linefeed)))
+(defparameter *LF$* (string #\linefeed))
Index: cells/strudel-object.lisp
diff -u cells/strudel-object.lisp:1.1.1.1 cells/strudel-object.lisp:1.2
--- cells/strudel-object.lisp:1.1.1.1 Sat Nov 8 18:44:46 2003
+++ cells/strudel-object.lisp Tue Dec 16 10:02:58 2003
@@ -1,145 +1,145 @@
-;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
-;;;
-;;;
-;;; Copyright © 1995,2003 by Kenneth William Tilton.
-;;;
-;;; Permission is hereby granted, free of charge, to any person obtaining a copy
-;;; of this software and associated documentation files (the "Software"), to deal
-;;; in the Software without restriction, including without limitation the rights
-;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-;;; copies of the Software, and to permit persons to whom the Software is furnished
-;;; to do so, subject to the following conditions:
-;;;
-;;; The above copyright notice and this permission notice shall be included in
-;;; all copies or substantial portions of the Software.
-;;;
-;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
-;;; IN THE SOFTWARE.
-
-(in-package :cells)
-
-;----------------- model-object ----------------------
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(strudel-object)))
-
-(cc-defstruct (strudel-object (:conc-name nil))
- (q-state :nascent :type keyword) ; [nil | :nascent | :alive | :doomed]
- (q-name nil :type symbol)
- (q-parent nil)
- (q-cells nil :type list)
- (q-cells-flushed nil :type list)
- (q-adopt-ct 0 :type fixnum))
-
-(defmethod strudel-initialize (self)
- (unless (q-name self)
- (setf (q-name self) (class-name (class-of self))))
-
- #+wait (when (q-parent self)
- (q-adopt (q-parent self) self))
- self)
-
-(defmethod cells ((self strudel-object))
- (q-cells self))
-
-(defmethod (setf cells) (new-value (self strudel-object))
- (setf (q-cells self) new-value))
-
-(defmethod kids ((other strudel-object)) nil)
-
-(defun q-install (self sn c)
- (assert (typep c 'cell))
- (trc nil "installing cell" sn c)
- (setf
- (c-model c) self
- (c-slot-spec c) sn
- (md-slot-cell self sn) c))
-
-(defmethod (setf md-state) (newv (self strudel-object))
- (setf (q-state self) newv))
-
-(defmethod md-state ((self strudel-object))
- (q-state self))
-
-(defmethod md-name ((self strudel-object)) (q-name self))
-(defmethod fmparent ((self strudel-object)) (q-parent self))
-
-(defmethod print-object ((self strudel-object) s)
- (format s "~a" (or (md-name self) (type-of self))))
-
-(defun q-slot-value (slot-c)
- (when *stop*
- (princ #\.)
- (return-from q-slot-value))
- ;; (count-it :q-slot-value slot-name slot-spec))
-
-;;; (when (eql :nascent (q-state self))
-;;; (md-awaken self))
-
- (let ((slot-value (typecase slot-c
- (c-variable (c-value slot-c))
-
- (c-ruled (cond
- ((c-validp slot-c) (c-value slot-c)) ;; good to go
-
- ((find slot-c *c-calculators*) ;; circularity
- (setf *stop* t)
- (trc "q-slot-value breaking on circlularity" slot-c *c-calculators*)
- (error "cell ~a midst askers: ~a" slot-c *c-calculators*))
-
- (t (let ((*cause* :on-demand)) ; normal path first time asked
- (trc nil "md-slot-value calc" self slot-spec *c-calculators*)
- (c-calculate-and-set slot-c)))))
- (otherwise (return-from q-slot-value slot-c)))))
-
- (bif (synapse (when (car *c-calculators*)
- (c-link-ex slot-c)))
- (c-relay-value synapse slot-value)
- slot-value)))
-
-
-
-
-(defmethod md-awaken :around ((self strudel-object))
- (trc nil "md-awaken entry" self (md-state self))
- (assert (eql :nascent (md-state self)))
- ;; (trc nil "awaken doing")
- (count-it :md-awaken)
- ;;(count-it 'mdawaken (type-of self))
- (setf (md-state self) :awakening)
- ;; (trc "md-awaken entry" self)
- (dolist (esd (class-slots (class-of self)))
- ;;(trc "md-awaken scoping slot" self (slot-definition-name esd))
- (when (md-slot-cell-type (type-of self) (slot-definition-name esd))
- (let ((slot-name (slot-definition-name esd)))
- (if (not (c-echo-defined slot-name))
- (progn ;; (count-it :md-awaken :no-echo-slot slot-name)
- (trc nil "md-awaken deferring cell-awaken since no echo" self esd))
-
- (let ((cell (md-slot-cell self slot-name)))
- (trc nil "md-awaken finds md-esd-cell " self slot-name cell)
-
-
- (if cell
- (c-awaken cell)
- ;
- ; next bit revised to avoid double-echo of optimized cells
- ;
- (progn
- (when (eql '.kids slot-name)
- (bwhen (sv (slot-value self '.kids))
- (md-kids-change self sv nil :md-awaken-slot)))
- (c-echo-initially self slot-name)))))))
- )
-
- (setf (md-state self) :awake)
- self)
-
-(defmethod md-slot-value-store ((self strudel-object) slot-spec new-value)
- (declare (ignorable slot-spec))
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+;----------------- model-object ----------------------
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(strudel-object)))
+
+(cc-defstruct (strudel-object (:conc-name nil))
+ (q-state :nascent :type keyword) ; [nil | :nascent | :alive | :doomed]
+ (q-name nil :type symbol)
+ (q-parent nil)
+ (q-cells nil :type list)
+ (q-cells-flushed nil :type list)
+ (q-adopt-ct 0 :type fixnum))
+
+(defmethod strudel-initialize (self)
+ (unless (q-name self)
+ (setf (q-name self) (class-name (class-of self))))
+
+ #+wait (when (q-parent self)
+ (q-adopt (q-parent self) self))
+ self)
+
+(defmethod cells ((self strudel-object))
+ (q-cells self))
+
+(defmethod (setf cells) (new-value (self strudel-object))
+ (setf (q-cells self) new-value))
+
+(defmethod kids ((other strudel-object)) nil)
+
+(defun q-install (self sn c)
+ (assert (typep c 'cell))
+ (trc nil "installing cell" sn c)
+ (setf
+ (c-model c) self
+ (c-slot-spec c) sn
+ (md-slot-cell self sn) c))
+
+(defmethod (setf md-state) (newv (self strudel-object))
+ (setf (q-state self) newv))
+
+(defmethod md-state ((self strudel-object))
+ (q-state self))
+
+(defmethod md-name ((self strudel-object)) (q-name self))
+(defmethod fm-parent ((self strudel-object)) (q-parent self))
+
+(defmethod print-object ((self strudel-object) s)
+ (format s "~a" (or (md-name self) (type-of self))))
+
+(defun q-slot-value (slot-c)
+ (when *stop*
+ (princ #\.)
+ (return-from q-slot-value))
+ ;; (count-it :q-slot-value slot-name slot-spec))
+
+;;; (when (eql :nascent (q-state self))
+;;; (md-awaken self))
+
+ (let ((slot-value (typecase slot-c
+ (c-variable (c-value slot-c))
+
+ (c-ruled (cond
+ ((c-validp slot-c) (c-value slot-c)) ;; good to go
+
+ ((find slot-c *c-calculators*) ;; circularity
+ (setf *stop* t)
+ (trc "q-slot-value breaking on circlularity" slot-c *c-calculators*)
+ (error "cell ~a midst askers: ~a" slot-c *c-calculators*))
+
+ (t (let ((*cause* :on-demand)) ; normal path first time asked
+ (trc nil "md-slot-value calc" self slot-spec *c-calculators*)
+ (c-calculate-and-set slot-c)))))
+ (otherwise (return-from q-slot-value slot-c)))))
+
+ (bif (synapse (when (car *c-calculators*)
+ (c-link-ex slot-c)))
+ (c-relay-value synapse slot-value)
+ slot-value)))
+
+
+
+
+(defmethod md-awaken :around ((self strudel-object))
+ (trc nil "md-awaken entry" self (md-state self))
+ (assert (eql :nascent (md-state self)))
+ ;; (trc nil "awaken doing")
+ (count-it :md-awaken)
+ ;;(count-it 'mdawaken (type-of self))
+ (setf (md-state self) :awakening)
+ ;; (trc "md-awaken entry" self)
+ (dolist (esd (class-slots (class-of self)))
+ ;;(trc "md-awaken scoping slot" self (slot-definition-name esd))
+ (when (md-slot-cell-type (type-of self) (slot-definition-name esd))
+ (let ((slot-name (slot-definition-name esd)))
+ (if (not (c-echo-defined slot-name))
+ (progn ;; (count-it :md-awaken :no-echo-slot slot-name)
+ (trc nil "md-awaken deferring cell-awaken since no echo" self esd))
+
+ (let ((cell (md-slot-cell self slot-name)))
+ (trc nil "md-awaken finds md-esd-cell " self slot-name cell)
+
+
+ (if cell
+ (c-awaken cell)
+ ;
+ ; next bit revised to avoid double-echo of optimized cells
+ ;
+ (progn
+ (when (eql '.kids slot-name)
+ (bwhen (sv (slot-value self '.kids))
+ (md-kids-change self sv nil :md-awaken-slot)))
+ (c-echo-initially self slot-name)))))))
+ )
+
+ (setf (md-state self) :awake)
+ self)
+
+(defmethod md-slot-value-store ((self strudel-object) slot-spec new-value)
+ (declare (ignorable slot-spec))
new-value)
Index: cells/synapse.lisp
diff -u cells/synapse.lisp:1.1.1.1 cells/synapse.lisp:1.2
--- cells/synapse.lisp:1.1.1.1 Sat Nov 8 18:44:46 2003
+++ cells/synapse.lisp Tue Dec 16 10:02:58 2003
@@ -1,213 +1,213 @@
-;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
-;;;
-;;; Copyright © 1995,2003 by Kenneth William Tilton.
-;;;
-;;; Permission is hereby granted, free of charge, to any person obtaining a copy
-;;; of this software and associated documentation files (the "Software"), to deal
-;;; in the Software without restriction, including without limitation the rights
-;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-;;; copies of the Software, and to permit persons to whom the Software is furnished
-;;; to do so, subject to the following conditions:
-;;;
-;;; The above copyright notice and this permission notice shall be included in
-;;; all copies or substantial portions of the Software.
-;;;
-;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
-;;; IN THE SOFTWARE.
-
-(in-package :cells)
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(mksynapse fDelta fSensitivity fPlusp fZerop fDifferent)))
-
-; ___________________________ cell relay value ___________________________________
-
-(defparameter *relayspeak* nil)
-(defmethod c-relay-value ((syn synapse) value)
- ;(trc "c-relay-value> syn, raw value:" syn value)
- (let ((res (funcall (syn-relay-value syn) syn value)))
- ;(trc "c-relay-value> cell, filtered value:" syn res)
- res))
-
-(defmethod c-relay-value (cell value)
- (declare (ignorable cell))
- (when *relayspeak*
- (trc "c-relay-value unspecial > cell value" cell value)
- (setf *relayspeak* nil))
- value)
-
-;__________________________________________________________________________________
-;
-(defmethod delta-diff ((new number) (old number) subtypename)
- (declare (ignore subtypename))
- (- new old))
-
-(defmethod delta-identity ((dispatcher number) subtypename)
- (declare (ignore subtypename))
- 0)
-
-(defmethod delta-abs ((n number) subtypename)
- (declare (ignore subtypename))
- (abs n))
-
-(defmethod delta-exceeds ((d1 number) (d2 number) subtypename)
- (declare (ignore subtypename))
- (> d1 d2))
-
-(defmethod delta-greater-or-equal ((d1 number) (d2 number) subtypename)
- (declare (ignore subtypename))
- (>= d1 d2))
-
-;_________________________________________________________________________________
-;
-(defmethod delta-diff (new old (subtypename (eql 'boolean)))
- (if new
- (if old
- :unchanged
- :on)
- (if old
- :off
- :unchanged)))
-
-
-(defmethod delta-identity (dispatcher (subtypename (eql 'boolean)))
- (declare (ignore dispatcher))
- :unchanged)
-
-;______________________________________________________________
-
-(defun fdeltalist (&key (test #'true))
- (mksynapse (priorlist)
- :fire-p (lambda (syn newlist)
- (declare (ignorable syn))
- (or (find-if (lambda (new)
- ;--- gaining one? ----
- (and (not (member new priorlist))
- (funcall test new)))
- newlist)
- (find-if (lambda (old)
- ;--- losing one? ----
- (not (member old newlist))) ;; all olds have passed test, so skip test here
- priorlist)))
-
- :relay-value (lambda (syn newlist)
- (declare (ignorable syn))
- ;/// excess consing on long lists
- (setf priorlist (remove-if-not test newlist)))))
-
-;_______________________________________________________________
-
-(defun ffindonce (finderfn)
- (mksynapse (bingo bingobound)
-
- :fire-p (lambda (syn newlist)
- (declare (ignorable syn))
- (unless bingo ;; once found, yer done
- (setf bingobound t
- bingo (find-if finderfn newlist))))
-
- :relay-value (lambda (syn newlist)
- (declare (ignorable syn))
- (or bingo
- (and (not bingobound) ;; don't bother if fire? already looked
- (find-if finderfn newlist))))))
-
-;___________________________________________________________________
-
-(defun fsensitivity (sensitivity &optional subtypename)
- (mksynapse (priorrelayvalue)
- :fire-p (lambda (syn newvalue)
- (declare (ignorable syn))
- (trc nil "fire-p decides" priorrelayvalue sensitivity)
- (or (xor priorrelayvalue newvalue)
- (eko (nil "fire-p decides" newvalue priorrelayvalue sensitivity)
- (delta-greater-or-equal
- (delta-abs (delta-diff newvalue priorrelayvalue subtypename) subtypename)
- (delta-abs sensitivity subtypename)
- subtypename))))
-
- :relay-value (lambda (syn newvalue)
- (declare (ignorable syn))
- (eko (nil "fsensitivity relays")
- (setf priorrelayvalue newvalue)) ;; no modulation of value, but do record for next time
- )))
-
-(defun fPlusp ()
- (mksynapse (priorrelayvalue)
- :fire-p (lambda (syn new-basis)
- (declare (ignorable syn))
- (eko (nil "fPlusp fire-p decides" priorrelayvalue sensitivity)
- (xor priorrelayvalue (plusp new-basis))))
-
- :relay-value (lambda (syn new-basis)
- (declare (ignorable syn))
- (eko (nil "fPlusp relays")
- (setf priorrelayvalue (plusp new-basis))) ;; no modulation of value, but do record for next time
- )))
-
-(defun fZerop ()
- (mksynapse (priorrelayvalue)
- :fire-p (lambda (syn new-basis)
- (declare (ignorable syn))
- (eko (nil "fZerop fire-p decides")
- (xor priorrelayvalue (zerop new-basis))))
-
- :relay-value (lambda (syn new-basis)
- (declare (ignorable syn))
- (eko (nil "fZerop relays")
- (setf priorrelayvalue (zerop new-basis)))
- )))
-
-(defun fDifferent ()
- (mksynapse (prior-object)
- :fire-p (lambda (syn new-object)
- (declare (ignorable syn))
- (trc nil "fDiff: prior,new" (not (eql new-object prior-object))
- prior-object new-object)
- (not (eql new-object prior-object)))
-
- :relay-value (lambda (syn new-object)
- (declare (ignorable syn))
- (unless (eql new-object prior-object)
- (setf prior-object new-object)))
- ))
-;
-;____________________ synapse constructors _______________________________
-;
-(defun fdelta (&key sensitivity (type 'number))
- (mksynapse (lastrelaybasis lastboundp)
- :fire-p (lambda (syn newbasis)
- (declare (ignorable syn))
- (eko (nil "delta fire-p")
- (or (null sensitivity)
- (let ((delta (delta-diff newbasis lastrelaybasis type)))
- (delta-exceeds delta sensitivity type)))))
-
- :relay-value (lambda (syn newbasis)
- (declare (ignorable syn))
- (prog1
- (if lastboundp
- (delta-diff newbasis lastrelaybasis type)
- (delta-identity newbasis type))
- ;(trc "filter yields to user, value" (c-slot-name user) (c-slot-spec syn) relayvalue)
- ;(trc "fdelta > ********************* new lastrelay! " syn lastrelaybasis)
- (setf lastboundp t)
- (setf lastrelaybasis newbasis)))
- ))
-
-
-
-(defmethod delta-exceeds (booldelta sensitivity (subtypename (eql 'boolean)))
- (unless (eql booldelta :unchanged)
- (or (eq sensitivity t)
- (eq sensitivity booldelta))))
-
-(defun fboolean (&optional (sensitivity 't))
- (fdelta :sensitivity sensitivity :type 'boolean))
-
-
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(mksynapse fDelta fSensitivity fPlusp fZerop fDifferent)))
+
+; ___________________________ cell relay value ___________________________________
+
+(defparameter *relayspeak* nil)
+(defmethod c-relay-value ((syn synapse) value)
+ ;(trc "c-relay-value> syn, raw value:" syn value)
+ (let ((res (funcall (syn-relay-value syn) syn value)))
+ ;(trc "c-relay-value> cell, filtered value:" syn res)
+ res))
+
+(defmethod c-relay-value (cell value)
+ (declare (ignorable cell))
+ (when *relayspeak*
+ (trc "c-relay-value unspecial > cell value" cell value)
+ (setf *relayspeak* nil))
+ value)
+
+;__________________________________________________________________________________
+;
+(defmethod delta-diff ((new number) (old number) subtypename)
+ (declare (ignore subtypename))
+ (- new old))
+
+(defmethod delta-identity ((dispatcher number) subtypename)
+ (declare (ignore subtypename))
+ 0)
+
+(defmethod delta-abs ((n number) subtypename)
+ (declare (ignore subtypename))
+ (abs n))
+
+(defmethod delta-exceeds ((d1 number) (d2 number) subtypename)
+ (declare (ignore subtypename))
+ (> d1 d2))
+
+(defmethod delta-greater-or-equal ((d1 number) (d2 number) subtypename)
+ (declare (ignore subtypename))
+ (>= d1 d2))
+
+;_________________________________________________________________________________
+;
+(defmethod delta-diff (new old (subtypename (eql 'boolean)))
+ (if new
+ (if old
+ :unchanged
+ :on)
+ (if old
+ :off
+ :unchanged)))
+
+
+(defmethod delta-identity (dispatcher (subtypename (eql 'boolean)))
+ (declare (ignore dispatcher))
+ :unchanged)
+
+;______________________________________________________________
+
+(defun fdeltalist (&key (test #'true))
+ (mksynapse (priorlist)
+ :fire-p (lambda (syn newlist)
+ (declare (ignorable syn))
+ (or (find-if (lambda (new)
+ ;--- gaining one? ----
+ (and (not (member new priorlist))
+ (funcall test new)))
+ newlist)
+ (find-if (lambda (old)
+ ;--- losing one? ----
+ (not (member old newlist))) ;; all olds have passed test, so skip test here
+ priorlist)))
+
+ :relay-value (lambda (syn newlist)
+ (declare (ignorable syn))
+ ;/// excess consing on long lists
+ (setf priorlist (remove-if-not test newlist)))))
+
+;_______________________________________________________________
+
+(defun ffindonce (finderfn)
+ (mksynapse (bingo bingobound)
+
+ :fire-p (lambda (syn newlist)
+ (declare (ignorable syn))
+ (unless bingo ;; once found, yer done
+ (setf bingobound t
+ bingo (find-if finderfn newlist))))
+
+ :relay-value (lambda (syn newlist)
+ (declare (ignorable syn))
+ (or bingo
+ (and (not bingobound) ;; don't bother if fire? already looked
+ (find-if finderfn newlist))))))
+
+;___________________________________________________________________
+
+(defun fsensitivity (sensitivity &optional subtypename)
+ (mksynapse (priorrelayvalue)
+ :fire-p (lambda (syn newvalue)
+ (declare (ignorable syn))
+ (trc nil "fire-p decides" priorrelayvalue sensitivity)
+ (or (xor priorrelayvalue newvalue)
+ (eko (nil "fire-p decides" newvalue priorrelayvalue sensitivity)
+ (delta-greater-or-equal
+ (delta-abs (delta-diff newvalue priorrelayvalue subtypename) subtypename)
+ (delta-abs sensitivity subtypename)
+ subtypename))))
+
+ :relay-value (lambda (syn newvalue)
+ (declare (ignorable syn))
+ (eko (nil "fsensitivity relays")
+ (setf priorrelayvalue newvalue)) ;; no modulation of value, but do record for next time
+ )))
+
+(defun fPlusp ()
+ (mksynapse (priorrelayvalue)
+ :fire-p (lambda (syn new-basis)
+ (declare (ignorable syn))
+ (eko (nil "fPlusp fire-p decides" priorrelayvalue sensitivity)
+ (xor priorrelayvalue (plusp new-basis))))
+
+ :relay-value (lambda (syn new-basis)
+ (declare (ignorable syn))
+ (eko (nil "fPlusp relays")
+ (setf priorrelayvalue (plusp new-basis))) ;; no modulation of value, but do record for next time
+ )))
+
+(defun fZerop ()
+ (mksynapse (priorrelayvalue)
+ :fire-p (lambda (syn new-basis)
+ (declare (ignorable syn))
+ (eko (nil "fZerop fire-p decides")
+ (xor priorrelayvalue (zerop new-basis))))
+
+ :relay-value (lambda (syn new-basis)
+ (declare (ignorable syn))
+ (eko (nil "fZerop relays")
+ (setf priorrelayvalue (zerop new-basis)))
+ )))
+
+(defun fDifferent ()
+ (mksynapse (prior-object)
+ :fire-p (lambda (syn new-object)
+ (declare (ignorable syn))
+ (trc nil "fDiff: prior,new" (not (eql new-object prior-object))
+ prior-object new-object)
+ (not (eql new-object prior-object)))
+
+ :relay-value (lambda (syn new-object)
+ (declare (ignorable syn))
+ (unless (eql new-object prior-object)
+ (setf prior-object new-object)))
+ ))
+;
+;____________________ synapse constructors _______________________________
+;
+(defun fdelta (&key sensitivity (type 'number))
+ (mksynapse (lastrelaybasis lastboundp)
+ :fire-p (lambda (syn newbasis)
+ (declare (ignorable syn))
+ (eko (nil "delta fire-p")
+ (or (null sensitivity)
+ (let ((delta (delta-diff newbasis lastrelaybasis type)))
+ (delta-exceeds delta sensitivity type)))))
+
+ :relay-value (lambda (syn newbasis)
+ (declare (ignorable syn))
+ (prog1
+ (if lastboundp
+ (delta-diff newbasis lastrelaybasis type)
+ (delta-identity newbasis type))
+ ;(trc "filter yields to user, value" (c-slot-name user) (c-slot-spec syn) relayvalue)
+ ;(trc "fdelta > ********************* new lastrelay! " syn lastrelaybasis)
+ (setf lastboundp t)
+ (setf lastrelaybasis newbasis)))
+ ))
+
+
+
+(defmethod delta-exceeds (booldelta sensitivity (subtypename (eql 'boolean)))
+ (unless (eql booldelta :unchanged)
+ (or (eq sensitivity t)
+ (eq sensitivity booldelta))))
+
+(defun fboolean (&optional (sensitivity 't))
+ (fdelta :sensitivity sensitivity :type 'boolean))
+
+
More information about the Cells-cvs
mailing list