[cells-cvs] CVS update: cell-cultures/cells/cell-types.lisp cell-cultures/cells/cells.asd cell-cultures/cells/md-slot-value.lisp cell-cultures/cells/md-utilities.lisp cell-cultures/cells/optimization.lisp cell-cultures/cells/propagate.lisp
Kenny Tilton
ktilton at common-lisp.net
Sun Dec 5 04:50:42 UTC 2004
Update of /project/cells/cvsroot/cell-cultures/cells
In directory common-lisp.net:/tmp/cvs-serv7571/cells
Modified Files:
cell-types.lisp cells.asd md-slot-value.lisp md-utilities.lisp
optimization.lisp propagate.lisp
Log Message:
Cleaning up
Date: Sun Dec 5 05:50:33 2004
Author: ktilton
Index: cell-cultures/cells/cell-types.lisp
diff -u cell-cultures/cells/cell-types.lisp:1.2 cell-cultures/cells/cell-types.lisp:1.3
--- cell-cultures/cells/cell-types.lisp:1.2 Sun Jul 4 20:59:41 2004
+++ cell-cultures/cells/cell-types.lisp Sun Dec 5 05:50:32 2004
@@ -79,14 +79,51 @@
:initial-element 0) :type vector))
(defstruct (c-stream
- (:include c-ruled)
+ (:include c-dependent)
(:conc-name cs-))
values)
-;;; (defmacro cell~ (&body body)
-;;; `(make-c-stream
-;;; :rule (lambda ,@*c-lambda*
-;;; , at body)))
+(defstruct streamer from stepper donep to)
+
+#+notyet
+(defmacro c~~~ (&key (from 0)
+ stepper
+ (donep (c-lambda (> .cache (streamer-to slot-c))))
+ to)
+ `(make-c-stream
+ :rule (c-lambda (make-streamer
+ :from ,from
+ :stepper ,stepper
+ :to ,to :donep ,donep))))
+
+(defmethod md-slot-value-assume :around ((c c-stream) (s streamer))
+ (bif (to (streamer-to s))
+ (loop for slot-value = (streamer-from s)
+ then (bIf (stepper (streamer-stepper s))
+ (funcall stepper c)
+ (incf slot-value))
+ until (bIf (to (streamer-to s))
+ (> slot-value to)
+ (bwhen (donep-test (streamer-donep s))
+ (funcall donep-test c)))
+ do (progn
+ (print `(assume doing ,slot-value))
+ (call-next-method c slot-value))))
+ (c-optimize-away?! c))
+
+#+test
+(progn
+ (defmodel streamertest ()
+ ((val :accessor val :initform (c~~~ :from 0 :to (^oval)))
+ (oval :initarg :oval :accessor oval :initform (c-in 0))))
+
+ (def-c-output val ((self streamertest))
+ (print `(streamertest old ,old-value new ,new-value)))
+
+ (cell-reset)
+ (let ((it (make-be 'streamertest :oval 5)))
+ ;;(setf (oval it) 5)
+ it))
(defstruct (c-drifter
(:include c-dependent)))
Index: cell-cultures/cells/cells.asd
diff -u cell-cultures/cells/cells.asd:1.3 cell-cultures/cells/cells.asd:1.4
--- cell-cultures/cells/cells.asd:1.3 Thu Oct 28 02:09:13 2004
+++ cell-cultures/cells/cells.asd Sun Dec 5 05:50:32 2004
@@ -18,9 +18,9 @@
(:file "defpackage")
(:file "cells" :depends-on ("defpackage"))
(:file "cell-types" :depends-on ("defpackage"))
- (:file "integrity" :depends-on ("defpackage"))
+ (:file "integrity" :depends-on ("cell-types"))
(:file "constructors" :depends-on ("integrity" "cells"))
- (:file "initialize" :depends-on ("cells"))
+ (:file "initialize" :depends-on ("cells" "cell-types"))
(:file "md-slot-value" :depends-on ("integrity" "cell-types"))
(:file "slot-utilities" :depends-on ("cells"))
(:file "optimization" :depends-on ("cells"))
@@ -33,7 +33,7 @@
(:file "md-utilities" :depends-on ("cells"))
(:file "family" :depends-on ("defmodel"))
(:file "fm-utilities" :depends-on ("cells"))
- (:file "family-values" :depends-on ("propagate" "defmodel" ))
+ (:file "family-values" :depends-on ("family" "propagate" "defmodel" ))
(:file "test" :depends-on ("family"))
))
Index: cell-cultures/cells/md-slot-value.lisp
diff -u cell-cultures/cells/md-slot-value.lisp:1.4 cell-cultures/cells/md-slot-value.lisp:1.5
--- cell-cultures/cells/md-slot-value.lisp:1.4 Wed Sep 29 04:50:13 2004
+++ cell-cultures/cells/md-slot-value.lisp Sun Dec 5 05:50:32 2004
@@ -140,12 +140,15 @@
(if c
(when (find c *causation*)
- (if (c-cyclicp c)
+ (case (c-cyclicp c)
+ (:run-on (trc "cyclicity running on" c))
+ ((t)
(progn
- (trc nil "cyclicity handled gracefully" c)
+ (trc "cyclicity handled gracefully" c)
(c-pulse-update c :cyclicity-1)
- (return-from md-slot-value new-value))
- (c-break "(setf md-slot-value) setf looping ~a ~a" c *causation*)))
+ (return-from md-slot-value new-value)))
+ (otherwise
+ (c-break "(setf md-slot-value) setf looping ~a ~a" c *causation*))))
(progn
(c-break "(setf md-slot-value)> cellular slot ~a of ~a cannot be setf unless initialized as inputp"
slot-name self)))
@@ -158,7 +161,9 @@
new-value)
-(defun md-slot-value-assume (c raw-value)
+
+
+(defmethod md-slot-value-assume (c raw-value)
(assert c)
(trc nil "md-slot-value-assume entry:" c raw-value)
(bif (c-pos (position c *causation*))
@@ -185,7 +190,8 @@
(c-value-state c) :valid
(c-state c) :awake)
- (c-optimize-away?! c) ;;; put optimize test here to avoid needless linking
+ (unless (typep c 'c-stream) ;; c-stream needs to run out first stream at least
+ (c-optimize-away?! c)) ;;; put optimize test here to avoid needless linking
; --- data flow propagation -----------
Index: cell-cultures/cells/md-utilities.lisp
diff -u cell-cultures/cells/md-utilities.lisp:1.3 cell-cultures/cells/md-utilities.lisp:1.4
--- cell-cultures/cells/md-utilities.lisp:1.3 Thu Oct 28 02:09:13 2004
+++ cell-cultures/cells/md-utilities.lisp Sun Dec 5 05:50:32 2004
@@ -102,4 +102,5 @@
self)
(defun make-be (class &rest initargs)
- (to-be (apply 'make-instance class initargs)))
\ No newline at end of file
+ (to-be (apply 'make-instance class initargs)))
+
Index: cell-cultures/cells/optimization.lisp
diff -u cell-cultures/cells/optimization.lisp:1.1 cell-cultures/cells/optimization.lisp:1.2
--- cell-cultures/cells/optimization.lisp:1.1 Sat Jun 26 20:38:36 2004
+++ cell-cultures/cells/optimization.lisp Sun Dec 5 05:50:32 2004
@@ -31,12 +31,13 @@
(typecase c
(c-dependent
(if (and *c-optimizep*
+ (not (c-optimized-away-p c)) ;; c-streams come this way repeatedly even if optimized away
(c-validp c)
(not (c-synaptic c)) ;; no slot to cache invariant result, so they have to stay around)
(null (cd-useds c)))
(progn
- (trc nil "optimizing away" c)
+ (trc nil "optimizing away" c (c-state c))
(count-it :c-optimized)
(setf (c-state c) :optimized-away)
Index: cell-cultures/cells/propagate.lisp
diff -u cell-cultures/cells/propagate.lisp:1.4 cell-cultures/cells/propagate.lisp:1.5
--- cell-cultures/cells/propagate.lisp:1.4 Wed Sep 29 04:50:13 2004
+++ cell-cultures/cells/propagate.lisp Sun Dec 5 05:50:32 2004
@@ -161,7 +161,7 @@
(format t "~&output ~d (~a ~a) old: ~a" ,temp1 ',slotname ,loc-self ,oldvarg))
(format t "~&output ~d (~a ~a) new: ~a" ,temp1 ',slotname ,loc-self ,new-varg))))
`(defmethod c-output-slot-name
- #-(or clisp cormanlisp) progn
+ #-(or clisp cormanlisp) progn #+(or clisp cormanlisp) :around
((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp)
(declare (ignorable
,@(flet ((arg-name (arg-spec)
@@ -170,7 +170,8 @@
(atom arg-spec))))
(list (arg-name self-arg)(arg-name new-varg)
(arg-name oldvarg)(arg-name oldvargboundp)))))
- , at output-body))))
+ , at output-body
+ #+(or clisp cormanlisp) (call-next-method)))))
(defmacro bump-output-count (slotname) ;; pure test func
`(if (get ',slotname :outputs)
More information about the Cells-cvs
mailing list