From ktilton at common-lisp.net Sat Mar 15 15:18:34 2008 From: ktilton at common-lisp.net (ktilton) Date: Sat, 15 Mar 2008 10:18:34 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20080315151834.B841168220@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv8605 Modified Files: cells-manifesto.txt cells.lisp defpackage.lisp initialize.lisp link.lisp md-slot-value.lisp propagate.lisp synapse.lisp trc-eko.lisp Log Message: Mostly differentiating new *depender* from CAR of *call-stack* so we can clear former to get without-c-dependency behavior without clearing *call-stack*, in turn to detect cyclic calculation even if doing a without-c-dependency. --- /project/cells/cvsroot/cells/cells-manifesto.txt 2008/02/16 08:00:59 1.12 +++ /project/cells/cvsroot/cells/cells-manifesto.txt 2008/03/15 15:18:34 1.13 @@ -43,7 +43,7 @@ (defobserver enabled ((self menu-item) new-value old-value old-value-bound?) (menu-item-set (c-ptr self) (if new-value 1 0))) -ie, Somr model attributes must be propagated outside the model as they change, and observers +ie, Some model attributes must be propagated outside the model as they change, and observers are callbacks we can provide to handle change. Motivation --- /project/cells/cvsroot/cells/cells.lisp 2008/02/02 00:09:28 1.24 +++ /project/cells/cvsroot/cells/cells.lisp 2008/03/15 15:18:34 1.25 @@ -78,6 +78,11 @@ `(c-break "failed assertion: ~a" ',assertion))))) (defvar *call-stack* nil) +(defvar *depender* nil) +;; 2008-03-15: *depender* let's us differentiate between the call stack and +;; and dependency. The problem with overloading *call-stack* with both roles +;; is that we miss cyclic reentrance when we use without-c-dependency in a +;; rule to get "once" behavior or just when fm-traversing to find someone (defmacro def-c-trace (model-type &optional slot cell-type) `(defmethod trcp ((self ,(case cell-type @@ -92,7 +97,7 @@ `(call-without-c-dependency (lambda () , at body))) (defun call-without-c-dependency (fn) - (let (*call-stack*) + (let (*depender*) (funcall fn))) (export! .cause) --- /project/cells/cvsroot/cells/defpackage.lisp 2007/11/30 16:51:18 1.10 +++ /project/cells/cvsroot/cells/defpackage.lisp 2008/03/15 15:18:34 1.11 @@ -1,6 +1,6 @@ ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*- ;;; -;;; Copyright (c) 1995,2003 by Kenneth William Tilton. +;;; Copyright (c) 2008 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 --- /project/cells/cvsroot/cells/initialize.lisp 2008/02/02 00:09:28 1.10 +++ /project/cells/cvsroot/cells/initialize.lisp 2008/03/15 15:18:34 1.11 @@ -39,13 +39,13 @@ (ephemeral-reset c))) (defmethod awaken-cell ((c c-ruled)) - (let (*call-stack*) + (let (*depender*) (calculate-and-set c))) #+cormanlisp ; satisfy CormanCL bug (defmethod awaken-cell ((c c-dependent)) - (let (*call-stack*) - (trc nil "awaken-cell c-dependent clearing *call-stack*" c) + (let (*depender*) + (trc nil "awaken-cell c-dependent clearing *depender*" c) (calculate-and-set c))) (defmethod awaken-cell ((c c-drifter)) --- /project/cells/cvsroot/cells/link.lisp 2008/01/29 04:29:52 1.25 +++ /project/cells/cvsroot/cells/link.lisp 2008/03/15 15:18:34 1.26 @@ -18,17 +18,17 @@ (in-package :cells) -(defun record-caller (used &aux (caller (car *call-stack*))) +(defun record-caller (used) (when (c-optimized-away-p used) ;; 2005-05-21 removed slow type check that used is cell - (trc nil "caller not being recorded because used optimized away" caller (c-value used) :used used) + (trc nil "depender not being recorded because used optimized away" *depender* (c-value used) :used used) (return-from record-caller nil)) - (trc nil "record-caller entry: used=" used :caller caller) - #+cool (when (and (eq :ccheck (md-name (c-model caller))) + (trc nil "record-caller entry: used=" used :caller *depender*) + #+cool (when (and (eq :ccheck (md-name (c-model *depender*))) (eq :cview (md-name (c-model used)))) (break "bingo")) (multiple-value-bind (used-pos useds-len) (loop with u-pos - for known in (cd-useds caller) + for known in (cd-useds *depender*) counting known into length when (eq used known) do @@ -37,20 +37,20 @@ finally (return (values (when u-pos (- length u-pos)) length))) (when (null used-pos) - (trc nil "c-link > new caller,used " caller used) + (trc nil "c-link > new caller,used " *depender* used) (count-it :new-used) (setf used-pos useds-len) - (push used (cd-useds caller)) - (caller-ensure used caller) ;; 060604 experiment was in unlink + (push used (cd-useds *depender*)) + (caller-ensure used *depender*) ;; 060604 experiment was in unlink ) (handler-case - (setf (sbit (cd-usage caller) used-pos) 1) + (setf (sbit (cd-usage *depender*) used-pos) 1) (type-error (error) (declare (ignorable error)) - (setf (cd-usage caller) - (adjust-array (cd-usage caller) (+ used-pos 16) :initial-element 0)) - (setf (sbit (cd-usage caller) used-pos) 1)))) + (setf (cd-usage *depender*) + (adjust-array (cd-usage *depender*) (+ used-pos 16) :initial-element 0)) + (setf (sbit (cd-usage *depender*) used-pos) 1)))) used) --- /project/cells/cvsroot/cells/md-slot-value.lisp 2008/02/01 03:18:36 1.39 +++ /project/cells/cvsroot/cells/md-slot-value.lisp 2008/03/15 15:18:34 1.40 @@ -53,7 +53,7 @@ (prog1 (with-integrity () (ensure-value-is-current c :c-read nil)) - (when (car *call-stack*) + (when *depender* (record-caller c)))) (defun chk (s &optional (key 'anon)) @@ -131,7 +131,7 @@ (bwhen (v (c-value c)) (if (mdead v) (progn - (brk "on pulse ~a ensure-value still got and still not returning ~a dead value ~a" *data-pulse-id* c v) + (format t "~&on pulse ~a ensure-value still got and still not returning ~a dead value ~a" *data-pulse-id* c v) nil) v))) @@ -178,6 +178,7 @@ (defun calculate-and-link (c) (let ((*call-stack* (cons c *call-stack*)) + (*depender* c) (*defer-changes* t)) (assert (typep c 'c-ruled)) #+shhh (trc c "calculate-and-link" c) --- /project/cells/cvsroot/cells/propagate.lisp 2008/02/02 00:09:28 1.33 +++ /project/cells/cvsroot/cells/propagate.lisp 2008/03/15 15:18:34 1.34 @@ -76,10 +76,10 @@ (when prior-value (assert prior-value-supplied () "How can prior-value-supplied be nil if prior-value is not?!! ~a" c)) - (let (*call-stack* + (let (*depender* *call-stack* ;; I think both need clearing, cuz we are neither depending nor calling when we prop to callers (*c-prop-depth* (1+ *c-prop-depth*)) (*defer-changes* t)) - (trc nil "c.propagate clearing *call-stack*" c) + (trc nil "c.propagate clearing *depender*" c) ;------ debug stuff --------- ; @@ -122,7 +122,7 @@ ; expected to have side-effects, so we want to propagate fully and be sure no rule ; wants a rollback before starting with the side effects. ; - (unless nil #+not (member (c-lazy c) '(t :always :once-asked)) ;; 2006-09-26 still fuzzy on this + (progn ;; unless (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) @@ -218,6 +218,7 @@ #+slow (TRC c "c.propagate-to-callers > queueing notifying callers" (c-callers c)) (with-integrity (:tell-dependents c) (assert (null *call-stack*)) + (assert (null *depender*)) (let ((*causation* causation)) (trc nil "c.propagate-to-callers > actually notifying callers of" c (c-callers c)) #+c-debug (dolist (caller (c-callers c)) @@ -235,7 +236,20 @@ (assert (find c (cd-useds caller))() "Caller ~a of ~a does not have it as used" caller c) #+slow (trc c "propagating to caller is used" c :caller caller (c-currentp c)) (let ((*trc-ensure* (trcp c))) - (ensure-value-is-current caller :prop-from c))))))))) + ; + ; we just c-calculate-and-set? at the first level of dependency because + ; we do not need to check the next level (as ensure-value-is-current does) + ; because we already know /this/ notifying dependency has changed, so yeah, + ; any first-level cell /has to/ recalculate. (As for ensuring other dependents + ; of the first level guy are current, that happens automatically anyway JIT on + ; any read.) This is a minor efficiency enhancement since ensure-value-is-current would + ; very quickly decide it has to re-run, but maybe it makes the logic clearer. + ; + ;(ensure-value-is-current caller :prop-from c) <-- next was this, but see above change reason + ; + (unless (c-currentp caller) ; happens if I changed when caller used me in current pulse + (calculate-and-set caller)) + )))))))) (defparameter *the-unpropagated* nil) --- /project/cells/cvsroot/cells/synapse.lisp 2007/11/30 16:51:18 1.15 +++ /project/cells/cvsroot/cells/synapse.lisp 2008/03/15 15:18:34 1.16 @@ -22,14 +22,13 @@ (export '(mk-synapse f-delta f-sensitivity f-plusp f-zerop fdifferent with-synapse))) (defmacro with-synapse (synapse-id (&rest closure-vars) &body body) - (let ((syn-id (gensym))(syn-caller (gensym))) + (let ((syn-id (gensym))) `(let* ((,syn-id ,synapse-id) - (,syn-caller (car *call-stack*)) - (synapse (or (find ,syn-id (cd-useds ,syn-caller) :key 'c-slot-name) + (synapse (or (find ,syn-id (cd-useds *depender*) :key 'c-slot-name) (let ((new-syn (let (, at closure-vars) (make-c-dependent - :model (c-model ,syn-caller) + :model (c-model *depender*) :slot-name ,syn-id :code ',body :synaptic t @@ -39,7 +38,7 @@ (prog1 (multiple-value-bind (v p) (with-integrity () - (ensure-value-is-current synapse :synapse (car *call-stack*))) + (ensure-value-is-current synapse :synapse *depender*)) (values v p)) (record-caller synapse))))) --- /project/cells/cvsroot/cells/trc-eko.lisp 2008/01/29 20:42:23 1.9 +++ /project/cells/cvsroot/cells/trc-eko.lisp 2008/03/15 15:18:34 1.10 @@ -76,7 +76,7 @@ *trcdepth*) (format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*) (format stream "~&")) - (format stream " ~a " (round (- (get-internal-real-time) *last-trc*) 10)) + ;;(format stream " ~a " (round (- (get-internal-real-time) *last-trc*) 10)) (setf *last-trc* (get-internal-real-time)) (format stream "~a" s) (let (pkwp) From ktilton at common-lisp.net Sat Mar 15 15:18:34 2008 From: ktilton at common-lisp.net (ktilton) Date: Sat, 15 Mar 2008 10:18:34 -0500 (EST) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20080315151834.018786923A@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv8605/utils-kt Modified Files: debug.lisp detritus.lisp flow-control.lisp quad.lisp utils-kt.lpr Log Message: Mostly differentiating new *depender* from CAR of *call-stack* so we can clear former to get without-c-dependency behavior without clearing *call-stack*, in turn to detect cyclic calculation even if doing a without-c-dependency. --- /project/cells/cvsroot/cells/utils-kt/debug.lisp 2008/02/16 09:34:29 1.18 +++ /project/cells/cvsroot/cells/utils-kt/debug.lisp 2008/03/15 15:18:34 1.19 @@ -56,7 +56,7 @@ (defmacro count-it (&rest keys) (declare (ignorable keys)) #+(or) `(progn) - `(when *counting* + `(when (car *counting*) (call-count-it , at keys))) (defun call-count-it (&rest keys) --- /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2008/02/16 05:04:56 1.19 +++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2008/03/15 15:18:34 1.20 @@ -188,21 +188,11 @@ (char= #\; (schar trim 0))))) count 1))) -#+save -(defun source-line-count (path) - (with-open-file (s path) - (loop with lines = 0 - for c = (read-char s nil nil) - while c - when (find c '(#\newline #\return)) - do (incf lines) - finally (return lines)))) - #+(or) (line-count (make-pathname :device "c" - :directory `(:absolute "0Algebra" "Cells")) - nil 1 t) + :directory `(:absolute "ALGCOUNT" )) + 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") --- /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2008/01/29 04:29:55 1.12 +++ /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2008/03/15 15:18:34 1.13 @@ -113,6 +113,11 @@ `(let ((,bindvar ,boundform)) (when ,bindvar , at body))) + +(defmacro b-when (bindvar boundform &body body) + `(let ((,bindvar ,boundform)) + (when ,bindvar + , at body))) (defmacro bif ((bindvar boundform) yup &optional nope) `(let ((,bindvar ,boundform)) @@ -120,11 +125,17 @@ ,yup ,nope))) +(defmacro b-if (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))) -(export! maphash* hashtable-assoc -1?1 -1?1 prime?) +(export! 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 @@ -195,7 +206,7 @@ (defun without-repeating-generator (decent-interval all) (let ((len (length all)) - (head (let ((v (copy-list all))) + (head (let ((v (shuffle all))) (nconc v v)))) (lambda () (if (< len 2) @@ -207,7 +218,16 @@ (car head) (setf head (cdr head))))))) -(export! without-repeating) +(defun shuffle (list &key (test 'identity)) + (if (cdr list) + (loop thereis + (funcall test + (mapcar 'cdr + (sort (loop for e in list collecting (cons (random most-positive-fixnum) e)) + '< :key 'car)))) + (copy-list list))) + +(export! without-repeating shuffle) (let ((generators (make-hash-table :test 'equalp))) (defun reset-without-repeating () --- /project/cells/cvsroot/cells/utils-kt/quad.lisp 2007/12/03 20:11:12 1.3 +++ /project/cells/cvsroot/cells/utils-kt/quad.lisp 2008/03/15 15:18:34 1.4 @@ -86,41 +86,114 @@ |# -(in-package :cells) +(in-package :ukt) ;;;(defstruct (juad jar jbr jcr jdr) (defun qar (q) (car q)) +(defun (setf qar) (v q) (setf (car q) v)) + (defun qbr (q) (cadr q)) +(defun (setf qbr) (v q) (setf (cadr q) v)) + (defun qcr (q) (caddr q)) +(defun (setf qcr) (v q) (setf (caddr q) v)) + (defun qdr (q) (cdddr q)) +(defun (setf qdr) (v q) (setf (cdddr q) v)) + +(defun sub-quads (q) + (loop for childq on (qcr q) by #'qdr + collecting childq)) + +(defun sub-quads-do (q fn) + (loop for childq on (qcr q) by #'qdr + do (funcall fn childq))) (defun quad-traverse (q fn &optional (depth 0)) (funcall fn q depth) - (loop for childq on (qcr q) by #'qdr - do (quad-traverse childq fn (1+ depth)))) + (sub-quads-do q + (lambda (subq) + (quad-traverse subq fn (1+ depth))))) (defun quad (operator parent contents next) (list operator parent contents next)) +(defun quad* (operator parent contents next) + (list operator parent contents next)) + (defun qups (q) (loop for up = (qbr q) then (qbr up) unless up do (loop-finish) collecting up)) +(defun quad-tree (q) + (list* (qar q) + (loop for childq on (qcr q) by #'qdr + while childq + collecting (quad-tree childq)))) + +(defun tree-quad (tree &optional parent) + (let* ((q (quad (car tree) parent nil nil)) + (kids (loop for k in (cdr tree) + collecting (tree-quad k q)))) + (loop for (k n) on kids + do (setf (qdr k) n)) + (setf (qcr q) (car kids)) + q)) + +#+test +(test-qt) + +(defun test-qt () + (print (quad-tree #1='(zot nil (foo #1# ("123" "abc") + . #2=(bar #1# (ding #2# "456" + dong #2# "789"))))))) + +(print #1='(zot nil (foo #1# ("123" "abc") + . #2=(bar #1# (ding #2# "456" + dong #2# "789"))))) +#+xxxx +(test-tq) + +(defun test-tq () + (let ((*print-circle* t) + (tree '(zot (foo ("123")) (bar (ding) (dong))))) + (assert (equal tree (quad-tree (tree-quad tree)))))) + (defun testq () (let ((*print-circle* t)) - (let ((q #1='(zot nil (foo #1# "123" + (let ((q #1='(zot nil (foo #1# ("123" "abc") . #2=(bar #1# (ding #2# "456" dong #2# "789")))))) + (print '(traverse showing each type and data preceded by its depth)) + (quad-traverse q (lambda (q depth) - (print (list depth (qar q)))))) + (print (list depth (qar q)(qcr q))))) + (print `(listify same ,(quad-tree q)))) (let ((q #2='(zot nil (ding #2# "456" dong #2# "789")))) + (print '(traverse showing each "car" and itd parentage preceded by its depth)) + (print '(of data (zot (ding (dong))))) (quad-traverse q (lambda (q depth) (print (list depth (qar q) (mapcar 'qar (qups q))))))))) + +;;;(defun tree-quad (tree) + + +(defun testq2 () + (let ((*print-circle* t)) + (let ((q #2='(zot nil (ding #2# "456" + dong #2# "789")))) + (print '(traverse showing each "car" and itd parentage preceded by its depth)) + (print '(of data (zot (ding (dong))))) + (quad-traverse q (lambda (q depth) + (print (list depth (qar q) + (mapcar 'qar (qups q))))))))) + + \ No newline at end of file --- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2007/11/30 16:51:20 1.23 +++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2008/03/15 15:18:34 1.24 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.1 [Windows] (Sep 29, 2007 20:23)"; cg: "1.103.2.10"; -*- +;; -*- lisp-version: "8.1 [Windows] (Feb 1, 2008 18:35)"; cg: "1.103.2.10"; -*- (in-package :cg-user) From ktilton at common-lisp.net Mon Mar 17 20:33:58 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 17 Mar 2008 15:33:58 -0500 (EST) Subject: [cells-cvs] CVS Celtk Message-ID: <20080317203358.40DD072134@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv4567 Modified Files: CELTK.lpr composites.lisp run.lisp tk-object.lisp togl.lisp widget.lisp Log Message: --- /project/cells/cvsroot/Celtk/CELTK.lpr 2008/01/03 20:23:30 1.23 +++ /project/cells/cvsroot/Celtk/CELTK.lpr 2008/03/17 20:33:57 1.24 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.1 [Windows] (Jan 2, 2008 9:44)"; cg: "1.103.2.10"; -*- +;; -*- lisp-version: "8.1 [Windows] (Mar 4, 2008 15:30)"; cg: "1.103.2.10"; -*- (in-package :cg-user) @@ -32,7 +32,8 @@ (make-instance 'module :name "run.lisp") (make-instance 'module :name "ltktest-ci.lisp") (make-instance 'module :name "lotsa-widgets.lisp") - (make-instance 'module :name "demos.lisp")) + (make-instance 'module :name "demos.lisp") + (make-instance 'module :name "andy-expander.lisp")) :projects (list (make-instance 'project-module :name "..\\cells\\cells") (make-instance 'project-module :name @@ -113,7 +114,7 @@ :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard - :on-initialization 'celtk::tk-test + :on-initialization 'celtk::test-andy-expander :on-restart 'do-default-restart) ;; End of Project Definition --- /project/cells/cvsroot/Celtk/composites.lisp 2008/01/03 20:23:30 1.25 +++ /project/cells/cvsroot/Celtk/composites.lisp 2008/03/17 20:33:57 1.26 @@ -146,6 +146,9 @@ :width (c?n 800) :height (c?n 600)) +(defobserver focus-state ((self window)) + (trc "focus-state" self new-value :old old-value)) + (defmethod (setf cursor) :after (new-value (self window)) (when new-value (tk-format-now ". configure -cursor ~a" (string-downcase (symbol-name new-value))))) --- /project/cells/cvsroot/Celtk/run.lisp 2008/01/03 20:23:30 1.26 +++ /project/cells/cvsroot/Celtk/run.lisp 2008/03/17 20:33:57 1.27 @@ -28,7 +28,7 @@ (defparameter *ctk-dbg* nil) (defun run-window (root-class &optional (resetp t) &rest window-initargs) - (declare (ignorable root-class)) + (assert (symbolp root-class)) (setf *tkw* nil) (when resetp (cells-reset 'tk-user-queue-handler)) @@ -80,13 +80,13 @@ ; (tk-format-now "bind . {do-key-down %W %K}") (tk-format-now "bind . {do-key-up %W %K}") - (bwhen (ifn (start-up-fn *tkw*)) - (funcall ifn *tkw*)) - (CG:kill-splash-screen) - (tcl-do-one-event-loop) - ) - - + (block nil + (bwhen (ifn (start-up-fn *tkw*)) + (funcall ifn *tkw*)) + (CG:kill-splash-screen) + (unless #-rms-s3 nil #+rms-s3 (b-when bail$ (clo::rms-get :login "announce" ) + (not (eval (read-from-string bail$)))) + (tcl-do-one-event-loop)))) (defun ensure-destruction (w key) (declare (ignorable key)) @@ -126,11 +126,8 @@ (:configurenotify (setf (^width) (parse-integer (tk-eval "winfo width ."))) (with-cc :height - (setf (^height) (parse-integer (tk-eval "winfo height .")))) - ) + (setf (^height) (parse-integer (tk-eval "winfo height ."))))) - - (:destroyNotify (pushnew *tkw* *windows-destroyed*) (ensure-destruction *tkw* :destroyNotify)) @@ -159,7 +156,7 @@ (window-destroyed (ensure-destruction *tkw* :window-destroyed)) - + (otherwise (give-to-window))))) (otherwise (give-to-window))) @@ -177,7 +174,6 @@ (loop while (plusp (tk-get-num-main-windows)) do (loop until (zerop (Tcl_DoOneEvent 2)) ;; 2== TCL_DONT_WAIT do (when (and *ctk-dbg* (> (- (now) *doe-last*) 1)) - (trcx doe-loop) (setf *doe-last* (now))) (app-idle *app*)) (app-idle *app*) --- /project/cells/cvsroot/Celtk/tk-object.lisp 2008/01/03 20:23:30 1.13 +++ /project/cells/cvsroot/Celtk/tk-object.lisp 2008/03/17 20:33:57 1.14 @@ -105,8 +105,8 @@ (defun tk-config-option (self slot-name) (second (assoc slot-name (tk-class-options self)))) -(defmethod slot-value-observe progn (slot-name (self tk-object) new-value old-value old-value-boundp) - (declare (ignorable old-value)) +(defmethod slot-value-observe progn (slot-name (self tk-object) new-value old-value old-value-boundp cell) + (declare (ignorable old-value cell)) (when old-value-boundp ;; initial propagation to Tk happens during make-tk-instance (bwhen (tco (tk-config-option self slot-name)) ;; (get slot-name 'tk-config-option)) (tk-configure self (string tco) (or new-value ""))))) --- /project/cells/cvsroot/Celtk/togl.lisp 2008/01/03 20:23:30 1.27 +++ /project/cells/cvsroot/Celtk/togl.lisp 2008/03/17 20:33:57 1.28 @@ -198,11 +198,10 @@ ;;(eval-when (:compile-toplevel :execute) ;; (if (member :cello cl-user::*features*) ;; (progn - ;; (setf cl-ftgl:*ftgl-ogl* togl-ptr) ;; help debug failure to use lazy cells/classes - ;; ;; to defer FTGL till Ogl ready - ;; (kt-opengl:kt-opengl-reset)))) -;;; ^^^^^ above two needed only for cello ^^^^^^ -;;; + (setf cl-ftgl:*ftgl-ogl* togl-ptr) ;; help debug failure to use lazy cells/classes ;; to defer FTGL till Ogl ready + (kt-opengl:kt-opengl-reset) + ;;; ^^^^^ above two needed only for cello ^^^^^^ + ;;; (setf (togl-ptr self) togl-ptr) ;; this cannot be deferred (setf (togl-ptr-set self) togl-ptr) ;; this gets deferred, which is OK (setf (gethash (pointer-address togl-ptr) (tkwins *tkw*)) self)) --- /project/cells/cvsroot/Celtk/widget.lisp 2008/01/03 20:23:30 1.21 +++ /project/cells/cvsroot/Celtk/widget.lisp 2008/03/17 20:33:57 1.22 @@ -31,9 +31,15 @@ xwin)))) (defun tkwin-widget (tkwin) - (assert *tkw*) - (assert (tkwins *tkw*) () "Widget hash NIL for *tkw* ~a" *tkw*) - (gethash (pointer-address tkwin) (tkwins *tkw*))) +;;; (assert *tkw*) +;;; (assert (tkwins *tkw*) () "Widget hash NIL for *tkw* ~a" *tkw*) +;;; (gethash (pointer-address tkwin) (tkwins *tkw*)) + (if (and *tkw* (tkwins *tkw*)) + (gethash (pointer-address tkwin) (tkwins *tkw*)) + (unless .stopped + (trc "tkw issues" *tkw* (when *tkw* (tkwins *tkw*))) + .stop + nil))) (defun xwin-widget (xwin) ;; assignment of xwin is deferred so...all this BS.. (when (plusp xwin) @@ -132,7 +138,7 @@ (bif (self (tkwin-widget client-data)) (widget-event-handle self xe) ;; sometimes I hit the next branch restarting after crash.... - (trc "widget-event-handler > no widget for tkwin ~a" client-data)) + (trc nil "widget-event-handler > no widget for tkwin ~a" client-data)) #+nahhh(handler-case (bif (self (tkwin-widget client-data)) (widget-event-handle self xe) From ktilton at common-lisp.net Mon Mar 17 20:34:45 2008 From: ktilton at common-lisp.net (ktilton) Date: Mon, 17 Mar 2008 15:34:45 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20080317203445.A5AE4330D9@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv4791 Modified Files: defmodel.lisp Log Message: --- /project/cells/cvsroot/cells/defmodel.lisp 2008/02/16 09:40:51 1.17 +++ /project/cells/cvsroot/cells/defmodel.lisp 2008/03/17 20:34:45 1.18 @@ -54,7 +54,7 @@ ; ------- defclass --------------- (^slot-value ,model ',',slotname) ; - (progn + (prog1 (defclass ,class ,(or directsupers '(model-object)) ;; now we can def the class ,(mapcar (lambda (s) (list* (car s) @@ -120,8 +120,7 @@ ) )) )) - slotspecs) - (find-class ',class)))) + slotspecs)))) (defun defmd-canonicalize-slot (slotname &key From qdnm at common-lisp.net Thu Mar 20 23:43:52 2008 From: qdnm at common-lisp.net (Lloyd) Date: Fri, 21 Mar 2008 00:43:52 +0100 Subject: [cells-cvs] Take MBA that you deserve from an Established Prestigious Institution. Message-ID: <47E2F6B8.9070503@common-lisp.net> F A S T T R A C K D E G R E E P R O G R A M Obtain the degree you deserve, based on your present knowledge and life experience. A prosperous future, money earning power, and the Admiration of all. Degrees from an Established, Prestigious, Leading Institution. Your Degree will show exactly what you really can do. Get the Job, Promotion, Business Opportunity and Social Advancement you Desire! Eliminates classrooms and traveling. Achieve your Bachelors, Masters, MBA, or PhD in the field of your expertise Professional and affordable Call now - your Graduation is a phone call away. Please call: +1 206 30 90 336 From fgoenninger at common-lisp.net Sun Mar 23 11:36:43 2008 From: fgoenninger at common-lisp.net (fgoenninger) Date: Sun, 23 Mar 2008 06:36:43 -0500 (EST) Subject: [cells-cvs] CVS Celtk Message-ID: <20080323113643.8517C751B9@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv4140 Modified Files: entry.lisp Log Message: changed: entry widget: in order to detect events reliably the event id is interned as a keyword. --- /project/cells/cvsroot/Celtk/entry.lisp 2007/01/29 06:48:41 1.18 +++ /project/cells/cvsroot/Celtk/entry.lisp 2008/03/23 11:36:42 1.19 @@ -16,7 +16,7 @@ |# -;;; $Header: /project/cells/cvsroot/Celtk/entry.lisp,v 1.18 2007/01/29 06:48:41 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/Celtk/entry.lisp,v 1.19 2008/03/23 11:36:42 fgoenninger Exp $ (in-package :Celtk) @@ -40,21 +40,25 @@ :xscrollcommand (c-in nil) :textvariable (c? (intern (^path))) :event-handler (lambda (self xe) - (TRC nil "ENTRY event-handler" self (xsv type xe) (tk-event-type (xsv type xe))) + (trc nil "ENTRY event-handler" self (xsv type xe) (tk-event-type (xsv type xe))) (case (tk-event-type (xsv type xe)) (:virtualevent - (trc nil "ENTRY virtual event" (xsv name xe)) - (case (read-from-string (string-upcase (xsv name xe))) - (trace - (TRC nil "entry e/h trace" self (when (plusp (xsv user-data xe)) - (tcl-get-string (xsv user-data xe)))) - ;; assuming write op, but data field shows that - (let ((new-value (tcl-get-var *tki* (^path) - (var-flags :TCL-NAMESPACE-ONLY)))) - (unless (string= new-value (^value)) - (setf (^value) new-value)))))))) - - :value (c-in ""))) + (trc "ENTRY virtual event" (xsv name xe)) + (let ((event-id (intern + (read-from-string + (string-upcase (xsv name xe))) + :keyword))) + (case event-id + (:trace + (TRC "entry e/h trace" self + (when (plusp (xsv user-data xe)) + (tcl-get-string (xsv user-data xe)))) + ;; assuming write op, but data field shows that + (let ((new-value (tcl-get-var *tki* (^path) + (var-flags :TCL-NAMESPACE-ONLY)))) + (unless (string= new-value (^value)) + (setf (^value) new-value))))))))) + :value (c-in ""))) (defmethod md-awaken :after ((self entry)) ;; move this to a traces slot on widget (with-integrity (:client `(:trace ,self)) @@ -64,10 +68,12 @@ ;;; those leverage the COMMAND mechanism, which entry lacks ;; (defobserver .value ((self entry)) + (trc nil "ENTRY self new-value old-value" self new-value old-value) (when new-value (unless (string= new-value old-value) - (trc nil "value output" self new-value) - (tcl-set-var *tki* (^path) new-value (var-flags :TCL-NAMESPACE-ONLY))))) + (trc "ENTRY value output self new-value old-value" self new-value old-value) ;; frgo, 2007-11-22 + (tcl-set-var *tki* (^path) new-value (var-flags :TCL-NAMESPACE-ONLY)) + #+frgo (tk-format-now "~a -text ~A" (^path) new-value)))) (deftk text-widget (widget) ((modified :initarg :modified :accessor modified :initform nil)) @@ -97,7 +103,7 @@ (:virtualevent (case (read-from-string (string-upcase (xsv name xe))) (modified - (eko (nil "<> !!TK value for text-widget" self) + (eko (nil "<> !!TK value for text-widget" self) ;; frgo, 2007-11-22 (setf (^modified) t))))) )))) From fgoenninger at common-lisp.net Sun Mar 23 11:38:16 2008 From: fgoenninger at common-lisp.net (fgoenninger) Date: Sun, 23 Mar 2008 06:38:16 -0500 (EST) Subject: [cells-cvs] CVS Celtk Message-ID: <20080323113816.C931817039@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv4313 Modified Files: multichoice.lisp Log Message: Changed: event id handling (see also entry.lisp) --- /project/cells/cvsroot/Celtk/multichoice.lisp 2007/01/29 22:58:41 1.14 +++ /project/cells/cvsroot/Celtk/multichoice.lisp 2008/03/23 11:38:16 1.15 @@ -66,12 +66,22 @@ :event-handler (lambda (self xe) (case (tk-event-type (xsv type xe)) (:virtualevent - (trc ":virtualevent" (xsv name xe)) - (case (read-from-string (string-upcase (xsv name xe))) - (ListboxSelect - (let ((selection (parse-integer (tk-eval "~a curselection" (^path))))) - (setf (selection (tk-selector self)) - (value (elt (^kids) selection))))))))))) + (trc nil "LISTBOX :virtualevent" (xsv name xe)) + (let ((event-id + (intern (read-from-string + (string-upcase (xsv name xe))) + :keyword))) + (case event-id + (:listboxselect + (let ((selection + (parse-integer + (tk-eval "~a curselection" (^path)) + :junk-allowed t))) + (trc nil "LISTBOX :virtualevent => selection: " selection) + (when selection + (setf (selection (tk-selector self)) + (value (elt (^kids) selection)))))))) + ))))) (defmodel listbox-item (tk-object) ((item-text :initarg :item-text :accessor item-text From fgoenninger at common-lisp.net Sun Mar 23 11:43:15 2008 From: fgoenninger at common-lisp.net (fgoenninger) Date: Sun, 23 Mar 2008 06:43:15 -0500 (EST) Subject: [cells-cvs] CVS Celtk Message-ID: <20080323114315.A4E7F3307C@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv6379 Modified Files: scroll.lisp Log Message: Added: scrollbar widget: support for width, activestyle, selectforeground, selectbackground, selectmode --- /project/cells/cvsroot/Celtk/scroll.lisp 2007/11/16 10:01:44 1.5 +++ /project/cells/cvsroot/Celtk/scroll.lisp 2008/03/23 11:43:15 1.6 @@ -38,7 +38,17 @@ ((list-item-keys :initarg :list-item-keys :accessor list-item-keys :initform nil) (list-item-factory :initarg :list-item-factory :accessor list-item-factory :initform nil) (list-height :initarg :list-height :accessor list-height :initform nil) - (tkfont :initarg :tkfont :accessor tkfont :initform (c-in '(courier 9)))) + (tkfont :initarg :tkfont :accessor tkfont :initform (c-in '(courier 9))) + (width :initarg :width :accessor width :initform (c-in 20)) + (activestyle :initarg :activestyle :accessor activestyle :initform (c-in nil)) + (selectforeground :initarg :selectforeground + :accessor selectforeground :initform (c-in "black")) + (selectbackground :initarg :selectbackground + :accessor selectbackground :initform (c-in nil)) + (selectmode :initarg :selectmode + :accessor selectmode :initform (c-in 'single)) + + ) (:default-initargs :list-height (c? (max 1 (length (^list-item-keys)))) :kids-packing nil @@ -48,6 +58,11 @@ (mapcar (list-item-factory .parent) (list-item-keys .parent)))) :tkfont (c? (tkfont .parent)) + :width (c? (width .parent)) + :activestyle (c? (activestyle .parent)) + :selectforeground (c? (selectforeground .parent)) + :selectbackground (c? (selectbackground .parent)) + :selectmode (c? (selectmode .parent)) :state (c? (if (enabled .parent) 'normal 'disabled)) :takefocus (c? (if (enabled .parent) 1 0)) :height (c? (list-height .parent)) @@ -64,6 +79,8 @@ (when new-value (let ((lb (car (^kids))) (item-no (position new-value (^list-item-keys) :test 'equal))) + (trc nil "tk-output selection: lb | item-no | path of lb " lb item-no (path lb)) + (if item-no (tk-format `(:selection ,self) "~(~a~) selection set ~a" (path lb) item-no) (break "~&scrolled-list ~a selection ~a not found in item keys ~a" self new-value (^list-item-keys)))))) From fgoenninger at common-lisp.net Sun Mar 23 11:52:56 2008 From: fgoenninger at common-lisp.net (fgoenninger) Date: Sun, 23 Mar 2008 06:52:56 -0500 (EST) Subject: [cells-cvs] CVS Celtk Message-ID: <20080323115256.A52501705B@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv8667 Modified Files: tk-object.lisp Log Message: added: 1. deftk now automatically export the class of the widget 2. it also exports the mk- macro for that class. fixed: bug in tk-class-options generic function. --- /project/cells/cvsroot/Celtk/tk-object.lisp 2008/03/17 20:33:57 1.14 +++ /project/cells/cvsroot/Celtk/tk-object.lisp 2008/03/23 11:52:56 1.15 @@ -70,12 +70,14 @@ ,@(cdr (find :default-initargs defclass-options :key 'car)))) (defmethod tk-class-options append ((self ,class)) ',tk-options) + (export ',class) (export ',(loop for (slot nil) in tk-options nconcing (list slot (intern (conc$ "^" slot))))) (defmacro ,(intern (conc$ "MK-" (symbol-name class))) (&rest inits) `(make-instance ',',class :fm-parent *parent* - , at inits))))) + , at inits)) + (export ',(intern (conc$ "MK-" (symbol-name class))))))) (defun tk-options-normalize (tk-options) "normalize '(-aaa (tk-bbb -bbb)) => '((aaa -aaa)(tk-bbb -bbb))" @@ -99,7 +101,7 @@ (case (type-of self) (label '(pady padx height indicatoron relief tk-label)) (otherwise '(pady padx #+hmmm height indicatoron relief tk-label))));; - do (setf old (delete old all :key 'car)) + do (setf all (delete old all :key 'car)) finally (return all)))))) (defun tk-config-option (self slot-name) From ktilton at common-lisp.net Sun Mar 23 17:08:00 2008 From: ktilton at common-lisp.net (ktilton) Date: Sun, 23 Mar 2008 12:08:00 -0500 (EST) Subject: [cells-cvs] CVS Celtk Message-ID: <20080323170800.23C2E2D063@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv17817 Modified Files: togl.lisp Log Message: --- /project/cells/cvsroot/Celtk/togl.lisp 2008/03/17 20:33:57 1.28 +++ /project/cells/cvsroot/Celtk/togl.lisp 2008/03/23 17:07:59 1.29 @@ -19,6 +19,7 @@ (in-package :celtk) + (define-foreign-library Togl (:darwin (:or "libTogl1.7.dylib" "/opt/tcltk/togl/lib/Togl1.7/libtogl1.7.dylib")) From ktilton at common-lisp.net Sun Mar 23 23:47:43 2008 From: ktilton at common-lisp.net (ktilton) Date: Sun, 23 Mar 2008 18:47:43 -0500 (EST) Subject: [cells-cvs] CVS Celtk Message-ID: <20080323234743.00A4C32038@common-lisp.net> Update of /project/cells/cvsroot/Celtk In directory clnet:/tmp/cvs-serv29619 Modified Files: CELTK.lpr composites.lisp keysym.lisp run.lisp tk-object.lisp togl.lisp Log Message: Sorting out some confusion after commititng from wrong directory (but a recent backup of the real deal so not too bad). But folks might want to rebuild and test to see if anything got messed up. --- /project/cells/cvsroot/Celtk/CELTK.lpr 2008/03/17 20:33:57 1.24 +++ /project/cells/cvsroot/Celtk/CELTK.lpr 2008/03/23 23:47:42 1.25 @@ -114,7 +114,7 @@ :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard - :on-initialization 'celtk::test-andy-expander + :on-initialization 'celtk::tk-test :on-restart 'do-default-restart) ;; End of Project Definition --- /project/cells/cvsroot/Celtk/composites.lisp 2008/03/17 20:33:57 1.26 +++ /project/cells/cvsroot/Celtk/composites.lisp 2008/03/23 23:47:42 1.27 @@ -117,7 +117,7 @@ (defun app-idle (self) (loop for w in (^kids) - do (when (not (eq :arrow (cursor w))) + do (when (eq :watch (cursor w)) (setf (cursor w) :arrow))) (setf (^app-time) (now)) (loop for task in *app-idle-tasks* @@ -139,18 +139,20 @@ start-up-fn close-fn initial-focus - (focus-state (c-in nil) :documentation "This is about the window having the focus on the desktop, not the key focus. + (focus-state (c-in nil) + :documentation "This is about the window having the focus on the desktop, not the key focus. Actually holds last event code, :focusin or :focusout") on-key-down on-key-up :width (c?n 800) :height (c?n 600)) -(defobserver focus-state ((self window)) - (trc "focus-state" self new-value :old old-value)) +;;;(defobserver focus-state ((self window)) +;;; (trc "focus-state" self new-value :old old-value)) (defmethod (setf cursor) :after (new-value (self window)) (when new-value + (trc nil "configure cursor" self new-value) (tk-format-now ". configure -cursor ~a" (string-downcase (symbol-name new-value))))) (export! .control-key-p .alt-key-p .shift-key-p focus-state ^focus-state) --- /project/cells/cvsroot/Celtk/keysym.lisp 2008/01/03 20:23:30 1.1 +++ /project/cells/cvsroot/Celtk/keysym.lisp 2008/03/23 23:47:42 1.2 @@ -951,6 +951,85 @@ ;;; (at . #\@) ;;; (tab . #\tab))) +(export! *cursors*) +(defparameter *cursors* + (apply 'vector '(X_cursor + arrow + based_arrow_down + based_arrow_up + boat + bogosity + bottom_left_corner + bottom_right_corner + bottom_side + bottom_tee + box_spiral + center_ptr + circle + clock + coffee_mug + cross + cross_reverse + crosshair + diamond_cross + dot + dotbox + double_arrow + draft_large + draft_small + draped_box + exchange + fleur + gobbler + gumby + hand1 + hand2 + heart + icon + iron_cross + left_ptr + left_side + left_tee + leftbutton + ll_angle + lr_angle + man + middlebutton + mouse + pencil + pirate + plus + question_arrow + right_ptr + right_side + right_tee + rightbutton + rtl_logo + sailboat + sb_down_arrow + sb_h_double_arrow + sb_left_arrow + sb_right_arrow + sb_up_arrow + sb_v_double_arrow + shuttle + sizing + spider + spraycan + star + target + tcross + top_left_arrow + top_left_corner + top_right_corner + top_side + top_tee + trek + ul_angle + umbrella + ur_angle + watch + xterm))) (export! keysym-char keysym-sym minus period asciicircum plus backspace delete bar parenleft parenright bracketleft bracketright braceleft braceright less greater --- /project/cells/cvsroot/Celtk/run.lisp 2008/03/17 20:33:57 1.27 +++ /project/cells/cvsroot/Celtk/run.lisp 2008/03/23 23:47:42 1.28 @@ -18,8 +18,6 @@ (in-package :Celtk) - - ;;; --- running a Celtk (window class, actually) -------------------------------------- (eval-now! @@ -45,13 +43,6 @@ #-unix ;;(tk-format-now "package require QuickTimeTcl") (tk-format-now "snack::sound s") -;;; (tk-format-now (conc$ "snack::sound s -load " -;;; (snackify-pathname (make-pathname :directory '(:absolute "sounds") -;;; :name "ahem_x" :type "wav") -;;; #+vs (car (directory (make-pathname :directory '(:absolute "sounds"))))))) -;;; (tk-format-now "s play -blocking yes") -;;; (sleep 2) -;;; (tk-format-now "s play") (tcl-create-command *tki* "do-on-command" (get-callback 'do-on-command) (null-pointer) (null-pointer)) --- /project/cells/cvsroot/Celtk/tk-object.lisp 2008/03/23 11:52:56 1.15 +++ /project/cells/cvsroot/Celtk/tk-object.lisp 2008/03/23 23:47:42 1.16 @@ -50,34 +50,30 @@ ;;; --- deftk -------------------- -(defmacro deftk (class superclasses - (&rest std-slots) - &rest defclass-options) +(defmacro deftk (class superclasses (&rest std-slots) &rest defclass-options) (destructuring-bind (&optional tk-class &rest tk-options) (cdr (find :tk-spec defclass-options :key 'car)) (setf tk-options (tk-options-normalize tk-options)) `(eval-now! - (defmodel ,class ,(or superclasses '(tk-object)) - (,@(append std-slots (loop for (slot-name nil) in tk-options - collecting `(,slot-name :initform nil - :initarg ,(intern (string slot-name) :keyword) - :accessor ,slot-name)))) - ,@(remove-if (lambda (k) (find k '(:default-initargs :tk-spec))) defclass-options :key 'car) - (:default-initargs - ,@(when tk-class `(:tk-class ',tk-class)) - ,@(cdr (find :default-initargs defclass-options :key 'car)))) - (defmethod tk-class-options append ((self ,class)) - ',tk-options) - (export ',class) - (export ',(loop for (slot nil) in tk-options - nconcing (list slot (intern (conc$ "^" slot))))) - (defmacro ,(intern (conc$ "MK-" (symbol-name class))) (&rest inits) - `(make-instance ',',class - :fm-parent *parent* - , at inits)) - (export ',(intern (conc$ "MK-" (symbol-name class))))))) + (defmodel ,class ,(or superclasses '(tk-object)) + (,@(append std-slots (loop for (slot-name nil) in tk-options + collecting `(,slot-name :initform nil + :initarg ,(intern (string slot-name) :keyword) + :accessor ,slot-name)))) + ,@(remove-if (lambda (k) (find k '(:default-initargs :tk-spec))) defclass-options :key 'car) + (:default-initargs + ,@(when tk-class `(:tk-class ',tk-class)) + ,@(cdr (find :default-initargs defclass-options :key 'car)))) + (defmethod tk-class-options append ((self ,class)) + ',tk-options) + (export ',(loop for (slot nil) in tk-options + nconcing (list slot (intern (conc$ "^" slot))))) + (defmacro ,(intern (conc$ "MK-" (symbol-name class))) (&rest inits) + `(make-instance ',',class + :fm-parent *parent* + , at inits))))) (defun tk-options-normalize (tk-options) "normalize '(-aaa (tk-bbb -bbb)) => '((aaa -aaa)(tk-bbb -bbb))" --- /project/cells/cvsroot/Celtk/togl.lisp 2008/03/23 17:07:59 1.29 +++ /project/cells/cvsroot/Celtk/togl.lisp 2008/03/23 23:47:42 1.30 @@ -191,6 +191,8 @@ (call-next-method))) (defmethod ,(intern uc$) ((self togl)))))) + + (def-togl-callback create () (trc "___________________ TOGL SET UP _________________________________________" togl-ptr ) ;; @@ -199,8 +201,13 @@ ;;(eval-when (:compile-toplevel :execute) ;; (if (member :cello cl-user::*features*) ;; (progn - (setf cl-ftgl:*ftgl-ogl* togl-ptr) ;; help debug failure to use lazy cells/classes ;; to defer FTGL till Ogl ready - (kt-opengl:kt-opengl-reset) + + (when (find-package "CL-FTGL") + (set (find-symbol "*FTGL-OGL*" "CL-FTGL") togl-ptr)) ;; help debug failure to use lazy cells/classes ;; to defer FTGL till Ogl ready + + (when (find-package "KT-OPENGL") + (funcall (symbol-function (find-symbol "KT-OPENGL-RESET" "CL-FTGL")))) + ;;; ^^^^^ above two needed only for cello ^^^^^^ ;;; (setf (togl-ptr self) togl-ptr) ;; this cannot be deferred From khs at common-lisp.net Mon Mar 31 18:06:17 2008 From: khs at common-lisp.net (Candice) Date: Mon, 31 Mar 2008 19:06:17 +0100 Subject: [cells-cvs] 100% Safe To Take, With NO Side Effects. Message-ID: <47F11A09.60407@common-lisp.net> Men are going to stand up and clap their hands at these penis enlargement capsules. It has produced remarkable results that have never been seen before with NO negative side effects. These penis enlargement capsules offer women what they really want, more to play with! Those extra inches really do make the difference! http://yutoutye.com regards,