cells-cvs

cells-cvs@common-lisp.net

721 discussions

[cells-cvs] CVS kennysarc2
by ktilton 03 Feb '08

03 Feb '08

Update of /project/cells/cvsroot/kennysarc2 In directory clnet:/tmp/cvs-serv14068 Log Message: Status: Vendor Tag: tcvs-vendor Release Tags: tcvs-release No conflicts created by this import

1 0

[cells-cvs] CVS kennysarc
by ktilton 03 Feb '08

03 Feb '08

Update of /project/cells/cvsroot/kennysarc In directory clnet:/tmp/cvs-serv13806 Removed Files: struct.arc Log Message:

1 0

[cells-cvs] CVS kennysarc
by ktilton 02 Feb '08

02 Feb '08

Update of /project/cells/cvsroot/kennysarc In directory clnet:/tmp/cvs-serv27932 Modified Files: struct.arc Log Message: better --- /project/cells/cvsroot/kennysarc/struct.arc 2008/02/02 22:19:28 1.1 +++ /project/cells/cvsroot/kennysarc/struct.arc 2008/02/02 23:30:56 1.2 @@ -3,10 +3,12 @@ (mac struct ((name (o pfx (string name "-"))) . slot-defs) (with (maker (coerce (+ "mk-" (string name)) 'sym) defmaker (coerce (+ "mk-def-" (string name)) 'sym) - fsd (map [if (acons _) _ (list _ nil)] slot-defs)) + ;typdef (cons 'typ name) + ) `(do (def ,defmaker () - (listtab ',fsd)) + ;(prn 'defmakersees ',(keep acons slot-defs)) + (listtab ',(cons (list 'typ name) (keep acons slot-defs)))) (def ,maker initargs (aif (keep [~find _ ',(map carif slot-defs)] (map car (pair initargs))) @@ -17,17 +19,41 @@ ,@(map (fn (sd) `(def ,(coerce (+ (string pfx) (string sd)) 'sym) (self) + (unless (is (self 'typ) ',name) + (prn "This " self " is not a " ',name) + (ero "Wrong struct for accessor")) ;; this was a wild guess and acts weird (self ',sd))) (map carif slot-defs))))) -(prn (macex '(struct (cell c-) awake rule (pulse 0)))) +;;; debug by viewing the macro-expansion... -(struct (cell c-) +;;; (prn (macex '(struct (cell c-) awake rule (pulse 0)))) + +;;; now actually try it.. + +(struct (cell c-) ;; the c- gets prefixed to all accessor names awake rule - (pulse 0)) + (pulse 0)) ;; that zero is a default value + +;;;(prn (mk-def-cell)) + +(= c123 (mk-cell 'awake 1 'rule 2 'pulse 3)) -(prn (map [_ (mk-cell 'awake 1 'rule 2 'pulse 3)] (list c-awake c-rule c-pulse))) +(prn "(1 2 3)? " (map [_ c123] (list c-awake c-rule c-pulse))) + +(prn "(1 2 0)? " (map [_ (mk-cell 'awake 1 'rule 2)] (list c-awake c-rule c-pulse))) + +(struct (cell2) ;; no prefix supplied means you auto-get cell2- + (pulse 0) + awake + rule + ) +(= c2 (mk-cell2 'awake 3 'rule 4)) +(prn "(3 4 0)? " (map [_ c2] (list cell2-awake cell2-rule cell2-pulse))) - \ No newline at end of file +(prn "please fail on wrong type...") + +(prn (c-pulse c2)) +

1 0

[cells-cvs] CVS kennysarc
by ktilton 02 Feb '08

02 Feb '08

Update of /project/cells/cvsroot/kennysarc In directory clnet:/tmp/cvs-serv12716 Added Files: struct.arc Log Message: defstruct lite in Arc --- /project/cells/cvsroot/kennysarc/struct.arc 2008/02/02 22:19:28 NONE +++ /project/cells/cvsroot/kennysarc/struct.arc 2008/02/02 22:19:28 1.1 ;; Same license as Arc (mac struct ((name (o pfx (string name "-"))) . slot-defs) (with (maker (coerce (+ "mk-" (string name)) 'sym) defmaker (coerce (+ "mk-def-" (string name)) 'sym) fsd (map [if (acons _) _ (list _ nil)] slot-defs)) `(do (def ,defmaker () (listtab ',fsd)) (def ,maker initargs (aif (keep [~find _ ',(map carif slot-defs)] (map car (pair initargs))) (do (ero "Invalid initargs to " ',maker " supplied: " it ". Allowed are " ',slot-defs) nil) (let self (,defmaker) (map [= (self (car _)) (cadr _)] (pair initargs)) self))) ,@(map (fn (sd) `(def ,(coerce (+ (string pfx) (string sd)) 'sym) (self) (self ',sd))) (map carif slot-defs))))) (prn (macex '(struct (cell c-) awake rule (pulse 0)))) (struct (cell c-) awake rule (pulse 0)) (prn (map [_ (mk-cell 'awake 1 'rule 2 'pulse 3)] (list c-awake c-rule c-pulse)))

1 0

[cells-cvs] CVS kennysarc
by ktilton 02 Feb '08

02 Feb '08

Update of /project/cells/cvsroot/kennysarc In directory clnet:/tmp/cvs-serv12526 Log Message: Status: Vendor Tag: tcvs-vendor Release Tags: tcvs-release No conflicts created by this import

1 0

[cells-cvs] CVS cells
by ktilton 02 Feb '08

02 Feb '08

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv19896 Modified Files: cells.lisp cells.lpr initialize.lisp model-object.lisp propagate.lisp test-propagation.lisp Log Message: make cell (if any) sixth param to slot-value-observe --- /project/cells/cvsroot/cells/cells.lisp 2008/01/29 04:29:52 1.23 +++ /project/cells/cvsroot/cells/cells.lisp 2008/02/02 00:09:28 1.24 @@ -103,14 +103,14 @@ (define-condition unbound-cell (unbound-slot) ((cell :initarg :cell :reader cell :initform nil))) -(defgeneric slot-value-observe (slotname self new old old-boundp) +(defgeneric slot-value-observe (slotname self new old old-boundp cell) #-(or cormanlisp) (:method-combination progn)) #-cells-testing (defmethod slot-value-observe #-(or cormanlisp) progn - (slot-name self new old old-boundp) - (declare (ignorable slot-name self new old old-boundp))) + (slot-name self new old old-boundp cell) + (declare (ignorable slot-name self new old old-boundp cell))) ; -------- cell conditions (not much used) --------------------------------------------- --- /project/cells/cvsroot/cells/cells.lpr 2008/02/01 03:18:35 1.29 +++ /project/cells/cvsroot/cells/cells.lpr 2008/02/02 00:09:28 1.30 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.1 [Windows] (Jan 2, 2008 9:44)"; cg: "1.103.2.10"; -*- +;; -*- lisp-version: "8.1 [Windows] (Feb 1, 2008 18:35)"; cg: "1.103.2.10"; -*- (in-package :cg-user) @@ -23,7 +23,8 @@ (make-instance 'module :name "md-utilities.lisp") (make-instance 'module :name "family.lisp") (make-instance 'module :name "fm-utilities.lisp") - (make-instance 'module :name "family-values.lisp")) + (make-instance 'module :name "family-values.lisp") + (make-instance 'module :name "test-propagation.lisp")) :projects (list (make-instance 'project-module :name "utils-kt\\utils-kt")) :libraries nil --- /project/cells/cvsroot/cells/initialize.lisp 2008/01/31 03:30:17 1.9 +++ /project/cells/cvsroot/cells/initialize.lisp 2008/02/02 00:09:28 1.10 @@ -35,7 +35,7 @@ (trc nil "awaken cell observing" c) (when (> *data-pulse-id* (c-pulse-observed c)) (setf (c-pulse-observed c) *data-pulse-id*) - (slot-value-observe (c-slot-name c) (c-model c) (c-value c) nil nil) + (slot-value-observe (c-slot-name c) (c-model c) (c-value c) nil nil c) (ephemeral-reset c))) (defmethod awaken-cell ((c c-ruled)) --- /project/cells/cvsroot/cells/model-object.lisp 2008/01/31 03:30:17 1.18 +++ /project/cells/cvsroot/cells/model-object.lisp 2008/02/02 00:09:28 1.19 @@ -156,7 +156,7 @@ (> *data-pulse-id* (c-pulse-observed flushed))) ;; unfrickinlikely (when flushed (setf (c-pulse-observed flushed) *data-pulse-id*)) ;; probably unnecessary - (slot-value-observe slot-name self (bd-slot-value self slot-name) nil nil)))) + (slot-value-observe slot-name self (bd-slot-value self slot-name) nil nil flushed)))) ((find (c-lazy c) '(:until-asked :always t)) --- /project/cells/cvsroot/cells/propagate.lisp 2008/02/01 20:41:54 1.32 +++ /project/cells/cvsroot/cells/propagate.lisp 2008/02/02 00:09:28 1.33 @@ -36,11 +36,11 @@ ; --- data pulse (change ID) management ------------------------------------- -(defparameter *client-is-propagating* nil) +(defparameter *one-pulse?* nil) (defun data-pulse-next (pulse-info) (declare (ignorable pulse-info)) - (unless *client-is-propagating* + (unless *one-pulse?* (trc nil "data-pulse-next > " (1+ *data-pulse-id*) pulse-info) (incf *data-pulse-id*))) @@ -66,7 +66,7 @@ (defparameter *per-cell-handler* nil) (defun c-propagate (c prior-value prior-value-supplied) - (when *client-is-propagating* + (when *one-pulse?* (when *per-cell-handler* (funcall *per-cell-handler* c prior-value prior-value-supplied) (return-from c-propagate))) @@ -132,7 +132,7 @@ (when t ; breaks algebra (> *data-pulse-id* (c-pulse-observed c)) (setf (c-pulse-observed c) *data-pulse-id*) (slot-value-observe (c-slot-name c) (c-model c) - (c-value c) prior-value prior-value-supplied)) + (c-value c) prior-value prior-value-supplied c)) ; @@ -152,7 +152,7 @@ (defmacro defobserver (slotname &rest args &aux (aroundp (eq :around (first args)))) (when aroundp (setf args (cdr args))) (destructuring-bind ((&optional (self-arg 'self) (new-varg 'new-value) - (oldvarg 'old-value) (oldvargboundp 'old-value-boundp)) + (oldvarg 'old-value) (oldvargboundp 'old-value-boundp) (cell-arg 'c)) &body output-body) args `(progn (eval-when (:compile-toplevel :load-toplevel :execute) @@ -161,24 +161,24 @@ (let ((temp1 (gensym)) (loc-self (gensym))) `(defmethod slot-value-observe #-(or cormanlisp) ,(if aroundp :around 'progn) - ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp) + ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp ,cell-arg) (let ((,temp1 (bump-output-count ,slotname)) (,loc-self ,(if (listp self-arg) (car self-arg) self-arg))) (when (and ,oldvargboundp ,oldvarg) - (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)))) + (format t "~&output ~d (~a ~a) old: ~a" ,temp1 ',slotname ,loc-self ,oldvarg ,cell-arg)) + (format t "~&output ~d (~a ~a) new: ~a" ,temp1 ',slotname ,loc-self ,new-varg ,cell-arg)))) `(defmethod slot-value-observe #-(or cormanlisp) ,(if aroundp :around 'progn) - ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp) + ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp ,cell-arg) (declare (ignorable ,@(flet ((arg-name (arg-spec) (etypecase arg-spec (list (car arg-spec)) (atom arg-spec)))) (list (arg-name self-arg)(arg-name new-varg) - (arg-name oldvarg)(arg-name oldvargboundp))))) + (arg-name oldvarg)(arg-name oldvargboundp) (arg-name cell-arg))))) ,@output-body))))) (defmacro bump-output-count (slotname) ;; pure test func @@ -256,56 +256,13 @@ ;(trace c-propagate ensure-value-is-current) (loop for (c prior-value prior-value?) in (nreverse cs) do (c-propagate c prior-value prior-value?))))) - (assert (not *client-is-propagating*)) + (assert (not *one-pulse?*)) (data-pulse-next :client-prop) (trc "call-with-one-datapulse bumps pulse" *data-pulse-id*) (funcall finally - (let ((*client-is-propagating* t) + (let ((*one-pulse?* t) (*per-cell-handler* per-cell) (*the-unpropagated* nil)) (funcall f) *the-unpropagated*))) -(defmd tcp () - (left (c-in 0)) - (top (c-in 0)) - (right (c-in 0)) - (bottom (c-in 0)) - (area (c? (trc "area running") - (* (- (^right)(^left)) - (- (^top)(^bottom)))))) - -(defobserver area () - (TRC "new area" new-value old-value old-value-boundp :pulse *data-pulse-id*)) - -(defobserver bottom () - (TRC "new bottom" new-value old-value old-value-boundp :pulse *data-pulse-id*) - (with-integrity (:change 'bottom-tells-left) - (setf (^left) new-value))) - -(defobserver left () - (TRC "new left" new-value old-value old-value-boundp :pulse *data-pulse-id*)) - -(defun tcprop () - (untrace) - (test-prep) - (LET ((box (make-instance 'tcp))) - (trc "changing top to 10" *data-pulse-id*) - (setf (top box) 10) - (trc "not changing top" *data-pulse-id*) - (setf (top box) 10) - (trc "changing right to 10" *data-pulse-id*) - (setf (right box) 10) - (trc "not changing right" *data-pulse-id*) - (setf (right box) 10) - (trc "changing bottom to -1" *data-pulse-id*) - (decf (bottom box)) - (with-one-datapulse () - (loop repeat 20 do - (trc "changing bottom by -1" *data-pulse-id*) - (decf (bottom box)))))) - - - - - --- /project/cells/cvsroot/cells/test-propagation.lisp 2008/02/01 15:52:49 1.1 +++ /project/cells/cvsroot/cells/test-propagation.lisp 2008/02/02 00:09:28 1.2 @@ -1,4 +1,3 @@ - (in-package :cells) (defmd tcp () @@ -13,6 +12,14 @@ (defobserver area () (TRC "new area" new-value old-value old-value-boundp :pulse *data-pulse-id*)) +(defobserver bottom () + (TRC "new bottom" new-value old-value old-value-boundp :pulse *data-pulse-id*) + (with-integrity (:change 'bottom-tells-left) + (setf (^left) new-value))) + +(defobserver left () + (TRC "new left" new-value old-value old-value-boundp :pulse *data-pulse-id*)) + (defun tcprop () (untrace) (test-prep) @@ -27,8 +34,12 @@ (setf (right box) 10) (trc "changing bottom to -1" *data-pulse-id*) (decf (bottom box)) - (with-client-propagation () - (loop repeat 20 do + (with-one-datapulse () + (loop repeat 5 do (trc "changing bottom by -1" *data-pulse-id*) - (decf (bottom box)) - (decf (left box)))))) + (decf (bottom box)))))) + + + + +

1 0

[cells-cvs] CVS cells
by ktilton 01 Feb '08

01 Feb '08

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv25649 Modified Files: propagate.lisp Log Message: tougher test for with-one-datapulse (the new name) --- /project/cells/cvsroot/cells/propagate.lisp 2008/02/01 15:52:49 1.31 +++ /project/cells/cvsroot/cells/propagate.lisp 2008/02/01 20:41:54 1.32 @@ -239,12 +239,14 @@ (defparameter *the-unpropagated* nil) -(defmacro with-client-propagation ((&key (per-cell nil per-cell?) (finally nil finally?)) &body body) - `(call-with-client-propagation (lambda () ,@body) - ,@(when per-cell? `(:per-cell (lambda (c) (declare (ignorable c)) ,per-cell))) +(defmacro with-one-datapulse ((&key (per-cell nil per-cell?) (finally nil finally?)) &body body) + `(call-with-one-datapulse (lambda () ,@body) + ,@(when per-cell? `(:per-cell (lambda (c prior-value prior-value-boundp) + (declare (ignorable c prior-value prior-value-boundp)) + ,per-cell))) ,@(when finally? `(:finally (lambda (cs) (declare (ignorable cs)) ,finally))))) -(defun call-with-client-propagation +(defun call-with-one-datapulse (f &key (per-cell (lambda (c prior-value prior-value?) (unless (find c *the-unpropagated* :key 'car) @@ -256,15 +258,54 @@ (c-propagate c prior-value prior-value?))))) (assert (not *client-is-propagating*)) (data-pulse-next :client-prop) - (trc "call-with-client-propagation bumps pulse" *data-pulse-id*) + (trc "call-with-one-datapulse bumps pulse" *data-pulse-id*) (funcall finally (let ((*client-is-propagating* t) (*per-cell-handler* per-cell) (*the-unpropagated* nil)) (funcall f) *the-unpropagated*))) - - + +(defmd tcp () + (left (c-in 0)) + (top (c-in 0)) + (right (c-in 0)) + (bottom (c-in 0)) + (area (c? (trc "area running") + (* (- (^right)(^left)) + (- (^top)(^bottom)))))) + +(defobserver area () + (TRC "new area" new-value old-value old-value-boundp :pulse *data-pulse-id*)) + +(defobserver bottom () + (TRC "new bottom" new-value old-value old-value-boundp :pulse *data-pulse-id*) + (with-integrity (:change 'bottom-tells-left) + (setf (^left) new-value))) + +(defobserver left () + (TRC "new left" new-value old-value old-value-boundp :pulse *data-pulse-id*)) + +(defun tcprop () + (untrace) + (test-prep) + (LET ((box (make-instance 'tcp))) + (trc "changing top to 10" *data-pulse-id*) + (setf (top box) 10) + (trc "not changing top" *data-pulse-id*) + (setf (top box) 10) + (trc "changing right to 10" *data-pulse-id*) + (setf (right box) 10) + (trc "not changing right" *data-pulse-id*) + (setf (right box) 10) + (trc "changing bottom to -1" *data-pulse-id*) + (decf (bottom box)) + (with-one-datapulse () + (loop repeat 20 do + (trc "changing bottom by -1" *data-pulse-id*) + (decf (bottom box)))))) + +

1 0

[cells-cvs] CVS cells
by phildebrandt 01 Feb '08

01 Feb '08

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv1246 Modified Files: cells.asd defmodel.lisp propagate.lisp Added Files: test-propagation.lisp Log Message: moved propagation test to test-propagation.lisp --- /project/cells/cvsroot/cells/cells.asd 2007/12/02 18:44:18 1.8 +++ /project/cells/cvsroot/cells/cells.asd 2008/02/01 15:52:49 1.9 @@ -39,7 +39,8 @@ (:file "md-utilities") (:file "family") (:file "fm-utilities") - (:file "family-values"))) + (:file "family-values") + (:file "test-propagation"))) (defmethod perform ((o load-op) (c (eql (find-system :cells)))) (pushnew :cells *features*)) --- /project/cells/cvsroot/cells/defmodel.lisp 2007/11/30 16:51:18 1.13 +++ /project/cells/cvsroot/cells/defmodel.lisp 2008/02/01 15:52:49 1.14 @@ -25,72 +25,72 @@ (setf (get ',class :cell-types) nil) (setf (get ',class 'slots-excluded-from-persistence) ',(loop for slotspec in slotspecs - unless (and (getf (cdr slotspec) :ps t) - (getf (cdr slotspec) :persistable t)) - collect (car slotspec)))) + unless (and (getf (cdr slotspec) :ps t) + (getf (cdr slotspec) :persistable t)) + collect (car slotspec)))) ;; define slot macros before class so they can appear in ;; initforms and default-initargs ,@(delete nil - (loop for slotspec in slotspecs - nconcing (destructuring-bind - (slotname &rest slotargs - &key (cell t) owning (accessor slotname) reader - &allow-other-keys) - slotspec + (loop for slotspec in slotspecs + nconcing (destructuring-bind + (slotname &rest slotargs + &key (cell t) owning (accessor slotname) reader + &allow-other-keys) + slotspec - (declare (ignorable slotargs owning)) - (list - (when cell - (let* ((reader-fn (or reader accessor)) - (deriver-fn (intern$ "^" (symbol-name reader-fn)))) - `(eval-when (:compile-toplevel :execute :load-toplevel) - (unless (macro-function ',deriver-fn) - (defmacro ,deriver-fn () - `(,',reader-fn self)))))))))) + (declare (ignorable slotargs owning)) + (list + (when cell + (let* ((reader-fn (or reader accessor)) + (deriver-fn (intern$ "^" (symbol-name reader-fn)))) + `(eval-when (:compile-toplevel :execute :load-toplevel) + (unless (macro-function ',deriver-fn) + (defmacro ,deriver-fn () + `(,',reader-fn self)))))))))) - ; - ; ------- defclass --------------- (^slot-value ,model ',',slotname) - ; + ; + ; ------- 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 :persistable) - (remf ias :ps) - ;; We handle accessor below - (when (getf ias :cell t) - (remf ias :reader) - (remf ias :writer) - (remf ias :accessor)) - (remf ias :cell) - (remf ias :owning) - (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 (cadr (find :metaclass options :key #'car)) - 'standard-class))) + (defclass ,class ,(or directsupers '(model-object)) ;; now we can def the class + ,(mapcar (lambda (s) + (list* (car s) + (let ((ias (cdr s))) + (remf ias :persistable) + (remf ias :ps) + ;; We handle accessor below + (when (getf ias :cell t) + (remf ias :reader) + (remf ias :writer) + (remf ias :accessor)) + (remf ias :cell) + (remf ias :owning) + (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 (cadr (find :metaclass options :key #'car)) + 'standard-class))) (defmethod shared-initialize :after ((self ,class) slot-names &rest iargs &key) (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 + `(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... - ; + ; + ; slot accessors once class is defined... + ; ,@(mapcar (lambda (slotspec) (destructuring-bind - (slotname &rest slotargs - &key (cell t) owning unchanged-if (accessor slotname) reader writer type - &allow-other-keys) + (slotname &rest slotargs + &key (cell t) owning unchanged-if (accessor slotname) reader writer type + &allow-other-keys) slotspec (declare (ignorable slotargs)) @@ -102,24 +102,24 @@ (setf (md-slot-cell-type ',class ',slotname) ,cell) ,(when owning - `(setf (md-slot-owning ',class ',slotname) ,owning)) + `(setf (md-slot-owning ',class ',slotname) ,owning)) ,(when reader-fn - `(defmethod ,reader-fn ((self ,class)) - (md-slot-value self ',slotname))) + `(defmethod ,reader-fn ((self ,class)) + (md-slot-value self ',slotname))) ,(when writer-fn - `(defmethod (setf ,writer-fn) (new-value (self ,class)) - (setf (md-slot-value self ',slotname) - ,(if type - `(coerce new-value ',type) - 'new-value)))) + `(defmethod (setf ,writer-fn) (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)) + `(def-c-unchanged-test (,class ,slotname) ,unchanged-if)) ) )) )) - slotspecs) + slotspecs) (find-class ',class)))) (defun defmd-canonicalize-slot (slotname --- /project/cells/cvsroot/cells/propagate.lisp 2008/02/01 03:18:36 1.30 +++ /project/cells/cvsroot/cells/propagate.lisp 2008/02/01 15:52:49 1.31 @@ -264,39 +264,7 @@ (funcall f) *the-unpropagated*))) - -(defmd tcp () - (left (c-in 0)) - (top (c-in 0)) - (right (c-in 0)) - (bottom (c-in 0)) - (area (c? (trc "area running") - (* (- (^right)(^left)) - (- (^top)(^bottom)))))) - -(defobserver area () - (TRC "new area" new-value old-value old-value-boundp :pulse *data-pulse-id*)) - -(defun tcprop () - (untrace) - (test-prep) - (LET ((box (make-instance 'tcp))) - (trc "changing top to 10" *data-pulse-id*) - (setf (top box) 10) - (trc "not changing top" *data-pulse-id*) - (setf (top box) 10) - (trc "changing right to 10" *data-pulse-id*) - (setf (right box) 10) - (trc "not changing right" *data-pulse-id*) - (setf (right box) 10) - (trc "changing bottom to -1" *data-pulse-id*) - (decf (bottom box)) - (with-client-propagation () - (loop repeat 20 do - (trc "changing bottom by -1" *data-pulse-id*) - (decf (bottom box)) - (decf (left box)))))) - + --- /project/cells/cvsroot/cells/test-propagation.lisp 2008/02/01 15:52:49 NONE +++ /project/cells/cvsroot/cells/test-propagation.lisp 2008/02/01 15:52:49 1.1 (in-package :cells) (defmd tcp () (left (c-in 0)) (top (c-in 0)) (right (c-in 0)) (bottom (c-in 0)) (area (c? (trc "area running") (* (- (^right)(^left)) (- (^top)(^bottom)))))) (defobserver area () (TRC "new area" new-value old-value old-value-boundp :pulse *data-pulse-id*)) (defun tcprop () (untrace) (test-prep) (LET ((box (make-instance 'tcp))) (trc "changing top to 10" *data-pulse-id*) (setf (top box) 10) (trc "not changing top" *data-pulse-id*) (setf (top box) 10) (trc "changing right to 10" *data-pulse-id*) (setf (right box) 10) (trc "not changing right" *data-pulse-id*) (setf (right box) 10) (trc "changing bottom to -1" *data-pulse-id*) (decf (bottom box)) (with-client-propagation () (loop repeat 20 do (trc "changing bottom by -1" *data-pulse-id*) (decf (bottom box)) (decf (left box))))))

1 0

[cells-cvs] CVS cells/utils-kt
by phildebrandt 01 Feb '08

01 Feb '08

Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv1246/utils-kt Modified Files: core.lisp Log Message: moved propagation test to test-propagation.lisp --- /project/cells/cvsroot/cells/utils-kt/core.lisp 2008/01/30 14:33:49 1.5 +++ /project/cells/cvsroot/cells/utils-kt/core.lisp 2008/02/01 15:52:49 1.6 @@ -23,23 +23,23 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro export! (&rest symbols) - `(eval-when ( :compile-toplevel :load-toplevel :execute) - #+sbssscl (export (list ,@(mapcar #'(lambda (x) (list 'quote x)) symbols))) - #-sbclss (export ',symbols)))) + `(eval-when ( :compile-toplevel :load-toplevel :execute) + (export ',symbols)))) -(defmacro define-constant (name value &optional docstring) - "Define a constant properly. If NAME is unbound, DEFCONSTANT +(eval-now! + (defmacro define-constant (name value &optional docstring) + "Define a constant properly. If NAME is unbound, DEFCONSTANT it to VALUE. If it is already bound, and it is EQUAL to VALUE, reuse the SYMBOL-VALUE of NAME. Otherwise, DEFCONSTANT it again, resulting in implementation-specific behavior." - `(defconstant ,name - (if (not (boundp ',name)) - ,value - (let ((value ,value)) - (if (equal value (symbol-value ',name)) - (symbol-value ',name) - value))) - ,@(when docstring (list docstring)))) + `(defconstant ,name + (if (not (boundp ',name)) + ,value + (let ((value ,value)) + (if (equal value (symbol-value ',name)) + (symbol-value ',name) + value))) + ,@(when docstring (list docstring))))) (export! exe-path exe-dll font-path)

1 0

[cells-cvs] CVS cells
by ktilton 01 Feb '08

01 Feb '08

Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv4024 Modified Files: cells.lpr integrity.lisp md-slot-value.lisp propagate.lisp Log Message: version 1.0 of multiple updates in one datapulse --- /project/cells/cvsroot/cells/cells.lpr 2007/11/30 16:51:18 1.28 +++ /project/cells/cvsroot/cells/cells.lpr 2008/02/01 03:18:35 1.29 @@ -1,8 +1,8 @@ -;; -*- lisp-version: "8.0 [Windows] (Sep 14, 2007 21:56)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.1 [Windows] (Jan 2, 2008 9:44)"; cg: "1.103.2.10"; -*- (in-package :cg-user) -(defpackage :cells) +(defpackage :CELLS) (define-project :name :cells :modules (list (make-instance 'module :name "defpackage.lisp") @@ -36,16 +36,17 @@ :runtime-modules nil :splash-file-module (make-instance 'build-module :name "") :icon-file-module (make-instance 'build-module :name "") - :include-flags '(:local-name-info) - :build-flags '(:allow-debug :purify) + :include-flags (list :local-name-info) + :build-flags (list :allow-debug :purify) :autoload-warning t :full-recompile-for-runtime-conditionalizations nil + :include-manifest-file-for-visual-styles t :default-command-line-arguments "+cx +t \"Initializing\"" - :additional-build-lisp-image-arguments '(:read-init-files nil) + :additional-build-lisp-image-arguments (list :read-init-files nil) :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard - :on-initialization 'cells::test + :on-initialization 'cells::tcprop :on-restart 'do-default-restart) ;; End of Project Definition --- /project/cells/cvsroot/cells/integrity.lisp 2007/11/30 22:29:06 1.19 +++ /project/cells/cvsroot/cells/integrity.lisp 2008/02/01 03:18:36 1.20 @@ -27,7 +27,7 @@ (defmacro with-integrity ((&optional opcode defer-info debug) &rest body) (when opcode (assert (find opcode *ufb-opcodes*) () - "Invalid second value to with-integrity: ~a" opcode)) + "Invalid opcode for with-integrity: ~a. Allowed values: ~a" opcode *ufb-opcodes*)) `(call-with-integrity ,opcode ,defer-info (lambda (opcode defer-info) (declare (ignorable opcode defer-info)) ,(when debug @@ -55,8 +55,7 @@ *defer-changes*) (trc nil "initiating new UFB!!!!!!!!!!!!" opcode defer-info) (when (or (zerop *data-pulse-id*) - (eq opcode :change) - ) + (eq opcode :change)) (eko (nil "!!! New pulse, event" *data-pulse-id* defer-info) (data-pulse-next (cons opcode defer-info)))) (prog1 --- /project/cells/cvsroot/cells/md-slot-value.lisp 2008/01/31 03:30:17 1.38 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2008/02/01 03:18:36 1.39 @@ -218,8 +218,6 @@ ; ; --- data flow propagation ----------- ; - - (setf (c-pulse-last-changed c) *data-pulse-id*) (without-c-dependency (c-propagate c prior-value t))))))) @@ -245,7 +243,6 @@ (md-slot-value-assume c new-value nil)) (*defer-changes* - (print `(cweird ,c ,(type-of c))) (c-break "SETF of ~a must be deferred by wrapping code in WITH-INTEGRITY" c)) (t @@ -277,12 +274,10 @@ (return-from md-slot-value-assume absorbed-value)) ; --- slot maintenance --- - (when (eq (c-state c) :optimized-away) - (break "bongo one ~a flush ~a" c (flushed? c))) + (unless (c-synaptic c) (md-slot-value-store (c-model c) (c-slot-name c) absorbed-value)) - (when (eq (c-state c) :optimized-away) - (break "bongo two ~a flush ~a" c (flushed? c))) + ; --- cell maintenance --- (setf (c-value c) absorbed-value @@ -298,7 +293,6 @@ ; --- data flow propagation ----------- (unless (eq propagation-code :no-propagate) (trc nil "md-slot-value-assume flagging as changed: prior state, value:" prior-state prior-value ) - (setf (c-pulse-last-changed c) *data-pulse-id*) (c-propagate c prior-value (cache-state-bound-p prior-state))) ;; until 06-02-13 was (not (eq prior-state :unbound)) absorbed-value))) --- /project/cells/cvsroot/cells/propagate.lisp 2008/01/31 03:30:17 1.29 +++ /project/cells/cvsroot/cells/propagate.lisp 2008/02/01 03:18:36 1.30 @@ -36,10 +36,13 @@ ; --- data pulse (change ID) management ------------------------------------- +(defparameter *client-is-propagating* nil) + (defun data-pulse-next (pulse-info) (declare (ignorable pulse-info)) - (trc nil "data-pulse-next > " (1+ *data-pulse-id*) pulse-info) - (incf *data-pulse-id*)) + (unless *client-is-propagating* + (trc nil "data-pulse-next > " (1+ *data-pulse-id*) pulse-info) + (incf *data-pulse-id*))) (defun c-currentp (c) (eql (c-pulse c) *data-pulse-id*)) @@ -59,28 +62,37 @@ ; though it is still receiving final processing here. ; + +(defparameter *per-cell-handler* nil) + (defun c-propagate (c prior-value prior-value-supplied) - - (count-it :c-propagate) + (when *client-is-propagating* + (when *per-cell-handler* + (funcall *per-cell-handler* c prior-value prior-value-supplied) + (return-from c-propagate))) + + (count-it :cpropagate) + (setf (c-pulse-last-changed c) *data-pulse-id*) + (when prior-value (assert prior-value-supplied () "How can prior-value-supplied be nil if prior-value is not?!! ~a" c)) (let (*call-stack* (*c-prop-depth* (1+ *c-prop-depth*)) (*defer-changes* t)) - (trc nil "c-propagate clearing *call-stack*" c) + (trc nil "c.propagate clearing *call-stack*" c) ;------ debug stuff --------- ; (when *stop* (princ #\.)(princ #\!) (return-from c-propagate)) - (trc nil "c-propagate> !!!!!!! propping" c (c-value c) :caller-ct (length (c-callers c))) - #+slow (trc c "c-propagate> !!!! new value" (c-value c) :prior-value prior-value :caller-ct (length (c-callers c)) c) + (trc nil "c.propagate> !!!!!!! propping" c (c-value c) :caller-ct (length (c-callers c))) + #+slow (trc c "c.propagate> !!!! new value" (c-value c) :prior-value prior-value :caller-ct (length (c-callers c)) c) (when *c-debug* (when (> *c-prop-depth* 250) - (trc nil "c-propagate deep" *c-prop-depth* (c-model c) (c-slot-name c) #+nah c)) + (trc nil "c.propagate deep" *c-prop-depth* (c-model c) (c-slot-name c) #+nah c)) (when (> *c-prop-depth* 300) - (c-break "c-propagate looping ~c" c))) + (c-break "c.propagate looping ~c" c))) ; --- manifest new value as needed --- ; @@ -94,7 +106,7 @@ (when (and prior-value-supplied prior-value (md-slot-owning (type-of (c-model c)) (c-slot-name c))) - (trc nil "c-propagate> contemplating lost") + (trc nil "c.propagate> contemplating lost") (flet ((listify (x) (if (listp x) x (list x)))) (bif (lost (set-difference (listify prior-value) (listify (c-value c)))) (progn @@ -113,7 +125,7 @@ (unless nil #+not (member (c-lazy c) '(t :always :once-asked)) ;; 2006-09-26 still fuzzy on this (c-propagate-to-callers c)) - (trc nil "c-propagate observing" c) + (trc nil "c.propagate observing" c) ; this next assertion is just to see if we can ever come this way twice. If so, just ; make it a condition on whether to observe @@ -177,6 +189,14 @@ ; --- recalculate dependents ---------------------------------------------------- +(defmacro cll-outer (val &body body) + `(let ((outer-val ,val)) + ,@body)) + +(defmacro cll-inner (expr) + `(,expr outer-val)) + +(export! cll-outer cll-inner) (defun c-propagate-to-callers (c) ; @@ -195,11 +215,11 @@ (member (c-lazy caller) '(t :always :once-asked)))) (c-callers c)) (let ((causation (cons c *causation*))) ;; in case deferred - #+slow (TRC c "c-propagate-to-callers > queueing notifying callers" (c-callers c)) + #+slow (TRC c "c.propagate-to-callers > queueing notifying callers" (c-callers c)) (with-integrity (:tell-dependents c) (assert (null *call-stack*)) (let ((*causation* causation)) - (trc nil "c-propagate-to-callers > actually notifying callers of" c (c-callers c)) + (trc nil "c.propagate-to-callers > actually notifying callers of" c (c-callers c)) #+c-debug (dolist (caller (c-callers c)) (assert (find c (cd-useds caller)) () "test 1 failed ~a ~a" c caller)) #+c-debug (dolist (caller (copy-list (c-callers c))) ;; following code may modify c-callers list... @@ -217,6 +237,66 @@ (let ((*trc-ensure* (trcp c))) (ensure-value-is-current caller :prop-from c))))))))) +(defparameter *the-unpropagated* nil) + +(defmacro with-client-propagation ((&key (per-cell nil per-cell?) (finally nil finally?)) &body body) + `(call-with-client-propagation (lambda () ,@body) + ,@(when per-cell? `(:per-cell (lambda (c) (declare (ignorable c)) ,per-cell))) + ,@(when finally? `(:finally (lambda (cs) (declare (ignorable cs)) ,finally))))) + +(defun call-with-client-propagation + (f &key + (per-cell (lambda (c prior-value prior-value?) + (unless (find c *the-unpropagated* :key 'car) + (pushnew (list c prior-value prior-value?) *the-unpropagated*)))) + (finally (lambda (cs) + (print `(finally sees ,*data-pulse-id* ,cs)) + ;(trace c-propagate ensure-value-is-current) + (loop for (c prior-value prior-value?) in (nreverse cs) do + (c-propagate c prior-value prior-value?))))) + (assert (not *client-is-propagating*)) + (data-pulse-next :client-prop) + (trc "call-with-client-propagation bumps pulse" *data-pulse-id*) + (funcall finally + (let ((*client-is-propagating* t) + (*per-cell-handler* per-cell) + (*the-unpropagated* nil)) + (funcall f) + *the-unpropagated*))) + + +(defmd tcp () + (left (c-in 0)) + (top (c-in 0)) + (right (c-in 0)) + (bottom (c-in 0)) + (area (c? (trc "area running") + (* (- (^right)(^left)) + (- (^top)(^bottom)))))) + +(defobserver area () + (TRC "new area" new-value old-value old-value-boundp :pulse *data-pulse-id*)) + +(defun tcprop () + (untrace) + (test-prep) + (LET ((box (make-instance 'tcp))) + (trc "changing top to 10" *data-pulse-id*) + (setf (top box) 10) + (trc "not changing top" *data-pulse-id*) + (setf (top box) 10) + (trc "changing right to 10" *data-pulse-id*) + (setf (right box) 10) + (trc "not changing right" *data-pulse-id*) + (setf (right box) 10) + (trc "changing bottom to -1" *data-pulse-id*) + (decf (bottom box)) + (with-client-propagation () + (loop repeat 20 do + (trc "changing bottom by -1" *data-pulse-id*) + (decf (bottom box)) + (decf (left box)))))) +

1 0

← Newer
1
...
12
13
14
15
16
17
18
...
73
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

2003

cells-cvs