From ktilton at common-lisp.net Sun Oct 12 01:21:09 2008 From: ktilton at common-lisp.net (ktilton) Date: Sun, 12 Oct 2008 01:21:09 +0000 Subject: [cells-cvs] CVS cells/cells-test Message-ID: Update of /project/cells/cvsroot/cells/cells-test In directory cl-net:/tmp/cvs-serv22971/cells-test Modified Files: cells-test.asd cells-test.lpr deep-cells.lisp person.lisp test.lisp Log Message: Just trying to get a patch in for record-caller --- /project/cells/cvsroot/cells/cells-test/cells-test.asd 2007/12/02 18:47:20 1.1 +++ /project/cells/cvsroot/cells/cells-test/cells-test.asd 2008/10/12 01:21:09 1.2 @@ -9,21 +9,18 @@ :long-description "Informatively-commented regression tests for Cells" :serial t :depends-on (:cells) - :components ((:module "cells-test" - :serial t - :components ((:file "test") - (:file "hello-world") - (:file "test-kid-slotting") - (:file "test-lazy") - (:file "person") - (:file "df-interference") - (:file "test-family") - (:file "output-setf") - (:file "test-cycle") - (:file "test-ephemeral") - (:file "test-synapse") - (:file "deep-cells"))))) + :components ((:file "test") + (:file "hello-world") + (:file "test-kid-slotting") + (:file "test-lazy") + (:file "person") + (:file "df-interference") + (:file "test-family") + (:file "output-setf") + (:file "test-cycle") + (:file "test-ephemeral") + (:file "test-synapse") + (:file "deep-cells"))) + -(defmethod perform :after ((op load-op) (system (eql (find-system :cells-test)))) - (funcall (find-symbol "TEST-CELLS" "CELLS"))) --- /project/cells/cvsroot/cells/cells-test/cells-test.lpr 2008/04/22 14:50:56 1.10 +++ /project/cells/cvsroot/cells/cells-test/cells-test.lpr 2008/10/12 01:21:09 1.11 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.1 [Windows] (Apr 3, 2008 23:47)"; cg: "1.103.2.10"; -*- +;; -*- lisp-version: "8.1 [Windows] (Oct 11, 2008 17:00)"; cg: "1.103.2.10"; -*- (in-package :cg-user) @@ -16,8 +16,11 @@ (make-instance 'module :name "test-cycle.lisp") (make-instance 'module :name "test-ephemeral.lisp") (make-instance 'module :name "test-synapse.lisp") - (make-instance 'module :name "deep-cells.lisp")) - :projects (list (make-instance 'project-module :name "..\\cells")) + (make-instance 'module :name "deep-cells.lisp") + (make-instance 'module :name "clos-training.lisp") + (make-instance 'module :name "do-req.lisp")) + :projects (list (make-instance 'project-module :name "..\\cells" + :show-modules nil)) :libraries nil :distributed-files nil :internally-loaded-files nil @@ -94,6 +97,7 @@ :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard + :build-number 0 :on-initialization 'cells::test-cells :on-restart 'do-default-restart) --- /project/cells/cvsroot/cells/cells-test/deep-cells.lisp 2007/11/30 16:51:19 1.3 +++ /project/cells/cvsroot/cells/cells-test/deep-cells.lisp 2008/10/12 01:21:09 1.4 @@ -4,9 +4,9 @@ (defvar *obs-1-count*) (defmodel deep () - ((cell-2 :cell :ephemeral :initform (c-in 'two) :accessor :cell-2) - (cell-1 :initform (c? (list 'one (^cell-2) (^cell-3))) :accessor :cell-1) - (cell-3 :initform (c-in 'c3-unset) :accessor :cell-3))) + ((cell-2 :cell :ephemeral :initform (c-in 'two) :accessor cell-2) + (cell-1 :initform (c? (list 'one (^cell-2) (^cell-3))) :accessor cell-1) + (cell-3 :initform (c-in 'c3-unset) :accessor cell-3))) (defobserver cell-1 () (trc "cell-1 observer raw now enqueing client to run first. (new,old)=" new-value old-value) --- /project/cells/cvsroot/cells/cells-test/person.lisp 2007/11/30 22:29:06 1.4 +++ /project/cells/cvsroot/cells/cells-test/person.lisp 2008/10/12 01:21:09 1.5 @@ -36,6 +36,16 @@ (incf *name-ct-calc*) (length (names self)))))) +#+test +(progn + (cells-reset) + (inspect + (make-instance 'person + :names '("speedy" "chill") + :pulse (c-in 60) + :speech (c? (car (names self))) + :thought (c? (when (< (pulse self) 100) (speech self)))))) + (defobserver names ((self person) new-names) (format t "~&you can call me ~a" new-names)) @@ -124,6 +134,8 @@ ;; (ct-assert (null (thought p))))) + + (def-cell-test cv-test-person-3 () ;; ------------------------------------------------------- ;; dynamic dependency graph maintenance @@ -154,6 +166,7 @@ (setf (pulse p) 50) (ct-assert (eql 1 (length (cd-useds (md-slot-cell p 'thought))))))) + (def-cell-test cv-test-person-4 () (let ((p (make-instance 'person :names '("speedy" "chill") @@ -167,8 +180,10 @@ ;; - all cells accessed are constant. ;; (ct-assert (null (md-slot-cell p 'speech))) - (ct-assert (assoc 'speech (cells-flushed p))) - (ct-assert (c-optimized-away-p (cdr (assoc 'speech (cells-flushed p))))) + #-its-alive! + (progn + (ct-assert (assoc 'speech (cells-flushed p))) + (ct-assert (c-optimized-away-p (cdr (assoc 'speech (cells-flushed p)))))) (ct-assert (not (c-optimized-away-p (md-slot-cell p 'thought)))) ;; pulse is variable, so cannot opti (ct-assert (eql 1 (length (cd-useds (md-slot-cell p 'thought))))) ;; but speech is opti, so only 1 used @@ -195,6 +210,8 @@ ;; make sure cyclic dependencies are trapped: ;; (cells-reset) + #+its-alive! t + #-its-alive! (ct-assert (handler-case (progn @@ -205,10 +222,9 @@ (length (names self))))) nil) (t (error) - (describe error) + (describe error) (setf *stop* nil) - t))) - ) + t)))) ;; ;; we'll toss off a quick class to test tolerance of cyclic --- /project/cells/cvsroot/cells/cells-test/test.lisp 2008/02/16 05:04:55 1.12 +++ /project/cells/cvsroot/cells/cells-test/test.lisp 2008/10/12 01:21:09 1.13 @@ -69,15 +69,21 @@ (defun test-cells () - (loop for test in (reverse *cell-tests*) - when t ; (eq 'cv-test-person-5 test) - do (cell-test-init test) - (funcall test)) - (print (make-string 40 :initial-element #\*)) - (print (make-string 40 :initial-element #\*)) - (print "*** Cells-test successfully completed **") - (print (make-string 40 :initial-element #\*)) - (print (make-string 40 :initial-element #\*))) + (dribble "c:/0algebra/cells-test.txt") + (progn ;prof:with-profiling (:type :time) + (time + (progn + (loop for test in (reverse *cell-tests*) + when t ; (eq 'cv-test-person-5 test) + do (cell-test-init test) + (funcall test)) + (print (make-string 40 :initial-element #\*)) + (print (make-string 40 :initial-element #\*)) + (print "*** Cells-test successfully completed **") + (print (make-string 40 :initial-element #\*)) + (print (make-string 40 :initial-element #\*))))) + ;(prof:show-call-graph) + (dribble)) (defun cell-test-init (name) (print (make-string 40 :initial-element #\!)) From ktilton at common-lisp.net Sun Oct 12 01:21:09 2008 From: ktilton at common-lisp.net (ktilton) Date: Sun, 12 Oct 2008 01:21:09 +0000 Subject: [cells-cvs] CVS cells/gui-geometry Message-ID: Update of /project/cells/cvsroot/cells/gui-geometry In directory cl-net:/tmp/cvs-serv22971/gui-geometry Modified Files: defpackage.lisp geo-family.lisp geometer.lisp Log Message: Just trying to get a patch in for record-caller --- /project/cells/cvsroot/cells/gui-geometry/defpackage.lisp 2008/01/29 04:29:54 1.7 +++ /project/cells/cvsroot/cells/gui-geometry/defpackage.lisp 2008/10/12 01:21:09 1.8 @@ -16,7 +16,7 @@ (defpackage #:gui-geometry (:nicknames #:geo) - (:use #:common-lisp #:utils-kt #:cells) + (:use #:common-lisp #:excl #:utils-kt #:cells) (:export #:geometer #:geo-zero-tl #:geo-inline #:a-stack #:a-row #:px #:py #:ll #:lt #:lr #:lb #:pl #:pt #:pr #:pb #:^px #:^py #:^ll #:^lt #:^lr #:^lb #:^lb-height --- /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2008/06/16 12:38:04 1.14 +++ /project/cells/cvsroot/cells/gui-geometry/geo-family.lisp 2008/10/12 01:21:09 1.15 @@ -17,7 +17,7 @@ (in-package :gui-geometry) (export! geo-inline-lazy ^px-self-centered justify py-maintain-pt - ^prior-sib-pb spacing lr-maintain-pr) + ^prior-sib-pb spacing lr-maintain-pr orientation) ;--------------- geo-inline ----------------------------- ; @@ -146,7 +146,10 @@ (setf pl 0 pt (+ max-pb (downs (^spacing-vt)))) - collect (cons pl pt) into pxys + collect (cons (+ pl (case (justify self) + (:center (/ (- kw (l-width k)) 2)) + (:right (- kw (l-width k))) + (otherwise 0))) pt) into pxys do (incf pl (+ kw (^spacing-hz))) (setf max-pb (min max-pb (+ pt (downs (l-height k))))) finally (return (cons max-pb pxys))))) --- /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2008/04/22 10:11:50 1.15 +++ /project/cells/cvsroot/cells/gui-geometry/geometer.lisp 2008/10/12 01:21:09 1.16 @@ -61,7 +61,7 @@ ;---------- gOffset ------------------- -(export! offset-within) +(export! offset-within inset-lb) ; (defun offset-within (inner outer &optional dbg) (declare (ignorable dbg)) @@ -212,6 +212,9 @@ (defun inset-lb (self) (+ (lb self) (outset self))) +(defun inset-lt (self) + (downs (lt self) (outset self))) + (defun inset-height (self) (- (l-height self) (outset self) (outset self))) @@ -219,7 +222,7 @@ ;---------------------------------- -(export! geo-kid-wrap) +(export! geo-kid-wrap inset-lt) (defun geo-kid-wrap (self bound) (funcall (ecase bound ((pl pb) '-)((pr pt) '+)) From ktilton at common-lisp.net Sun Oct 12 01:21:10 2008 From: ktilton at common-lisp.net (ktilton) Date: Sun, 12 Oct 2008 01:21:10 +0000 Subject: [cells-cvs] CVS cells/utils-kt Message-ID: Update of /project/cells/cvsroot/cells/utils-kt In directory cl-net:/tmp/cvs-serv22971/utils-kt Modified Files: core.lisp debug.lisp defpackage.lisp detritus.lisp flow-control.lisp strings.lisp utils-kt.lpr Log Message: Just trying to get a patch in for record-caller --- /project/cells/cvsroot/cells/utils-kt/core.lisp 2008/06/16 12:38:04 1.10 +++ /project/cells/cvsroot/cells/utils-kt/core.lisp 2008/10/12 01:21:10 1.11 @@ -17,6 +17,8 @@ (in-package :utils-kt) + + (defmacro with-gensyms ((&rest symbols) &body body) `(let ,(loop for sym in symbols collecting `(,sym (gensym ,(string sym)))) @@ -47,7 +49,7 @@ ,@(when docstring (list docstring))))) (defun test-setup (&optional drib) - #+(and allegro ide) + #+(and allegro ide (or (not its-alive!) debugging-alive!)) (ide.base::find-new-prompt-command (cg.base::find-window :listener-frame)) (when drib @@ -58,8 +60,9 @@ (export! test-setup test-prep test-init) (export! project-path) (defun project-path () - #+(and allegro ide) - (excl:path-pathname (ide.base::project-file ide.base:*current-project*))) + #+(and allegro ide (not its-alive!)) + (excl:path-pathname (ide.base::project-file ide.base:*current-project*)) + ) #+test (test-setup) --- /project/cells/cvsroot/cells/utils-kt/debug.lisp 2008/06/16 12:38:04 1.20 +++ /project/cells/cvsroot/cells/utils-kt/debug.lisp 2008/10/12 01:21:10 1.21 @@ -40,7 +40,7 @@ `(if ,onp (let ((*counting* (cons t *counting*))) (prog2 - (count-clear , at msg) + (count-clear nil , at msg) (progn , at body) (show-count t , at msg))) (progn , at body))) @@ -48,28 +48,38 @@ (defun count-of (key) (cdr (assoc key *count* :key 'car))) -(defun count-clear (&rest msg) +(defun count-clear (announce &rest msg) (declare (ignorable msg)) - (format t "~&count-clear > ~a" msg) + (when announce (format t "~&count-clear > ~a" msg)) (setf *count* nil)) (defmacro count-it (&rest keys) (declare (ignorable keys)) + #+nahhh `(progn) - #+(or) `(when (car *counting*) + `(when (car *counting*) + (call-count-it , at keys))) + +(export! count-it!) +(defmacro count-it! (&rest keys) + (declare (ignorable keys)) + #+(and its-alive! (not debugging-alive!)) + `(progn) + #-(and its-alive! (not debugging-alive!)) + `(when (car *counting*) (call-count-it , at keys))) (defun call-count-it (&rest keys) (declare (ignorable keys)) #+nahh (when (find (car keys) '(:trcfailed :TGTNILEVAL)) - (break "clean up time ~a" keys)) + (break "clean up time ~a" keys)) (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) +(defun show-count (clearp &rest msg &aux announced) + (let ((res (sort (copy-list *count*) (lambda (v1 v2) (let ((v1$ (symbol-name (caar v1))) (v2$ (symbol-name (caar v2)))) @@ -81,10 +91,11 @@ 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"))) - - + and do (unless announced + (setf announced t) + (format t "~&Counts after: clearp ~a, length ~d: ~s" clearp (length *count*) msg)) + (format t "~&~4d ... ~2d ... ~(~{~a ~}~)" running occs (car entry)))) + (when clearp (count-clear announced "show-count" ))) ;-------------------- timex --------------------------------- --- /project/cells/cvsroot/cells/utils-kt/defpackage.lisp 2008/04/22 11:03:45 1.10 +++ /project/cells/cvsroot/cells/utils-kt/defpackage.lisp 2008/10/12 01:21:10 1.11 @@ -15,14 +15,27 @@ |# + (in-package :cl-user) (eval-when (:compile-toplevel :load-toplevel :execute) - (setf *features* (delete :its-alive! *features*))) + (setf *features* (remove :its-alive! *features*))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (setf *features* (pushnew :gimme-a-break *features*))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (setf *features* (remove :debugging-alive! *features*))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + ;;; #+(and its-alive! (not debugging-alive!)) + ;;; (proclaim '(optimize (speed 3) (safety 1) (space 1) (debug 0))) + ;;; #-(and its-alive! (not debugging-alive!)) + (proclaim '(optimize (speed 2) (safety 1) (space 1) (debug 3)))) (defpackage :utils-kt (:nicknames #:ukt) - (:use #:common-lisp + (:use #:common-lisp #:excl #+(or allegro lispworks clisp) #:clos #+cmu #:mop #+sbcl #:sb-mop --- /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2008/06/16 12:38:04 1.21 +++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2008/10/12 01:21:10 1.22 @@ -20,7 +20,7 @@ (in-package :utils-kt) (eval-when (:compile-toplevel :load-toplevel :execute) - (export '(eval-now! export! assocd rassoca))) + (export '(eval-now! export! assocd rassoca class-proto brk))) (defmacro wdbg (&body body) `(let ((*dbg* t)) @@ -29,11 +29,37 @@ (defun assocd (x y) (cdr (assoc x y))) (defun rassoca (x y) (car (assoc x y))) -;;;(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)) +(defun class-proto (c) + (let ((cc (find-class c))) + (when cc + (finalize-inheritance cc)) + (mop::class-prototype cc))) + + +(defun brk (&rest args) + #+its-alive! (apply 'error args) + #-its-alive! (progn + ;;(setf *ctk-dbg* t) + (apply 'break args))) + +(defun find-after (x l) + (bIf (xm (member x l)) + (cadr xm) + (brk "find-after ~a not member of ~a" x l))) + +(defun find-before (x l) + (loop with prior = nil + for i in l + if (eql i x) + return prior + else do (setf prior i) + finally (brk "find-before ~a not member of ~a" x l))) + +(defun list-insert-after (list after new ) + (let* ((new-list (copy-list list)) + (m (member after new-list))) + (rplacd m (cons new (cdr m))) + new-list)) #+(and mcl (not openmcl-partial-mop)) (defun class-slots (c) @@ -49,7 +75,7 @@ (defun xor (c1 c2) (if c1 (not c2) c2)) -(export! collect collect-if) +(export! collect collect-if find-after find-before list-insert-after) (defun collect (x list &key (key 'identity) (test 'eql)) (loop for i in list @@ -121,6 +147,8 @@ (loop until (fifo-empty q) do (print (fifo-pop q))))) +#+test +(line-count "/openair" t 10 t) #+allegro (defun line-count (path &optional show-files (max-depth most-positive-fixnum) no-semis (depth 0)) @@ -167,14 +195,14 @@ #+(or) (line-count (make-pathname :device "c" - :directory `(:absolute "ALGCOUNT" )) + :directory `(:absolute "0algcount" )) nil 5 t) #+(or) (loop for d1 in '("cl-s3" "kpax" "puri-1.5.1" "s-base64" "s-http-client" "s-http-server" "s-sysdeps" "s-utils" "s-xml") summing (line-count (make-pathname :device "c" - :directory `(:absolute "1-devtools" ,d1)))) + :directory `(:absolute "0Algebra" "1-devtools" ,d1)))) (export! tree-includes tree-traverse tree-intersect) --- /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2008/06/16 12:38:04 1.14 +++ /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2008/10/12 01:21:10 1.15 @@ -131,11 +131,15 @@ ,yup ,nope))) +(defmacro b1 ((bindvar boundform) &body body) + `(let ((,bindvar ,boundform)) + , at body)) + (defmacro maptimes ((nvar count) &body body) `(loop for ,nvar below ,count collecting (progn , at body))) -(export! maphash* hashtable-assoc -1?1 -1?1 prime? b-if b-when) +(export! b1 maphash* hashtable-assoc -1?1 -1?1 prime? b-if b-when) (defun maphash* (f h) (loop for k being the hash-keys of h @@ -213,6 +217,7 @@ (head (let ((v (shuffle all))) (nconc v v)))) (lambda () + ;(print (list "without-repeating-generator sees len all =" len :decent-interval decent-interval)) (if (< len 2) (car all) (prog2 @@ -233,11 +238,17 @@ (export! without-repeating shuffle) -(let ((generators (make-hash-table :test 'equalp))) - (defun reset-without-repeating () - (setf generators (make-hash-table :test 'equalp))) - (defun without-repeating (key all &optional (decent-interval (floor (length all) 2))) - (funcall (or (gethash key generators) - (setf (gethash key generators) +(defparameter *without-repeating-generators* nil) + +(defun reset-without-repeating () + (if *without-repeating-generators* + (clrhash *without-repeating-generators*) + (setf *without-repeating-generators* (make-hash-table :test 'equalp)))) + +(defun without-repeating (key all &optional (decent-interval (floor (length all) 2))) + (funcall (or (gethash key *without-repeating-generators*) + (progn + ;(print (list "without-repeating makes new gen" key :all-len (length all) :int decent-interval)) + (setf (gethash key *without-repeating-generators*) (without-repeating-generator decent-interval all)))))) --- /project/cells/cvsroot/cells/utils-kt/strings.lisp 2007/11/30 16:51:20 1.7 +++ /project/cells/cvsroot/cells/utils-kt/strings.lisp 2008/10/12 01:21:10 1.8 @@ -24,8 +24,8 @@ 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$+))) + min$ numeric$ alpha$ assoc$ member$ starts$ + +return$+ +lf$+ case-string-equal))) (defmacro case$ (string-form &rest cases) (let ((v$ (gensym)) @@ -40,6 +40,19 @@ cases) (t ,@(or (cdr default) `(nil))))))) +(defmacro case-string-equal (string-form &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$ ,string-form)) + (cond + ,@(mapcar (lambda (case-forms) + `((string-equal ,v$ ,(string (car case-forms))) ,@(rest case-forms))) + cases) + (t ,@(or (cdr default) `(nil))))))) + ;-------- (defmethod shortc (other) @@ -200,8 +213,9 @@ (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)))) +(defun starts$ (a b) + (bwhen (s (search b a)) + (zerop s))) (defparameter *return$* (conc$ (char$ #\return) (char$ #\linefeed))) (defparameter *lf$* (string #\linefeed)) --- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2008/03/15 15:18:34 1.24 +++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2008/10/12 01:21:10 1.25 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.1 [Windows] (Feb 1, 2008 18:35)"; cg: "1.103.2.10"; -*- +;; -*- lisp-version: "8.1 [Windows] (Oct 11, 2008 17:00)"; cg: "1.103.2.10"; -*- (in-package :cg-user) @@ -32,6 +32,7 @@ :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard + :build-number 0 :on-initialization 'default-init-function :on-restart 'do-default-restart) From ktilton at common-lisp.net Sun Oct 12 21:22:16 2008 From: ktilton at common-lisp.net (ktilton) Date: Sun, 12 Oct 2008 21:22:16 +0000 Subject: [cells-cvs] CVS cells Message-ID: Update of /project/cells/cvsroot/cells In directory cl-net:/tmp/cvs-serv13916 Added Files: test-cc.lisp Log Message: --- /project/cells/cvsroot/cells/test-cc.lisp 2008/10/12 21:22:16 NONE +++ /project/cells/cvsroot/cells/test-cc.lisp 2008/10/12 21:22:16 1.1 (in-package :cells) (defmd tcc () (tccversion 1) (tcc-a (c-in nil)) (tcc-2a (c-in nil))) (defobserver tcc-a () (case (^tccversion) (1 (when new-value (with-cc :tcc-a-obs (setf (tcc-2a self) (* 2 new-value)) (with-cc :aha!2 (assert (eql (tcc-2a self) (* 2 new-value)) () "one") (trc "one happy"))) (with-cc :aha! (assert (eql (tcc-2a self) (* 2 new-value)) () "two")))) (2 (when new-value (with-cc :tcc-a-obs (setf (tcc-2a self) (* 2 new-value)) (with-cc :aha!2 (assert (eql (tcc-2a self) (* 2 new-value)) () "one") (trc "one happy"))))))) (defun test-with-cc () (let ((self (make-instance 'tcc :tccversion 2 ;:tcc-2a ))) (trcx cool 42) (setf (tcc-a self) 42) (assert (and (numberp (tcc-2a self)) (= (tcc-2a self) 84))))) #+test (test-with-cc)