July 2004 - cells-cvs@common-lisp.net - mailman3.common-lisp.net

[cells-cvs] CVS update: cell-cultures/celtic/menu.lisp cell-cultures/celtic/scrolling.lisp cell-cultures/celtic/button.lisp cell-cultures/celtic/canvas.lisp cell-cultures/celtic/celtic.lisp cell-cultures/celtic/celtic.lpr cell-cultures/celtic/frame.lisp cell-cultures/celtic/textual.lisp cell-cultures/celtic/widget-item.lisp
by Kenny Tilton 04 Jul '04

04 Jul '04

Update of /project/cells/cvsroot/cell-cultures/celtic In directory common-lisp.net:/tmp/cvs-serv5472/celtic Modified Files: button.lisp canvas.lisp celtic.lisp celtic.lpr frame.lisp textual.lisp widget-item.lisp Added Files: menu.lisp scrolling.lisp Log Message: Date: Sun Jul 4 11:59:43 2004 Author: ktilton Index: cell-cultures/celtic/button.lisp diff -u cell-cultures/celtic/button.lisp:1.3 cell-cultures/celtic/button.lisp:1.4 --- cell-cultures/celtic/button.lisp:1.3 Sun Jun 27 21:25:14 2004 +++ cell-cultures/celtic/button.lisp Sun Jul 4 11:59:43 2004 @@ -26,13 +26,14 @@ ;-------------------------------------------------------------------------- (def-widget button () - (-activebackground -activeforeground -anchor -background - -bitmap -borderwidth -cursor -disabledforeground - -font -foreground -highlightbackground -highlightcolor - -highlightthickness -image -justify -padx -pady -relief -repeatdelay - -repeatinterval -takefocus -text -textvariable -underline -wraplength - (-command nil) - -compound -default -height -overrelief -state -width)) + () + (-activebackground -activeforeground -anchor -background + -bitmap -borderwidth -cursor -disabledforeground + -font -foreground -highlightbackground -highlightcolor + -highlightthickness -image -justify -padx -pady -relief -repeatdelay + -repeatinterval -takefocus -text -textvariable -underline -wraplength + (-command nil) + -compound -default -height -overrelief -state -width)) (defun test-button () (make-be 'button :text (format nil "Time is ~a" (get-internal-real-time)) @@ -45,6 +46,7 @@ ; http://tmml.sourceforge.net/doc/tk/checkbutton.html ; (def-widget checkbutton () + () (-activebackground -activeforeground -anchor -background -bitmap -borderwidth -cursor -disabledforeground -font -foreground -highlightbackground -highlightcolor @@ -62,6 +64,7 @@ (if new-value 1 0)))) (def-widget radiobutton () + () (-activebackground -activeforeground -anchor -background -bitmap -borderwidth -cursor -disabledforeground -font -foreground -highlightbackground -highlightcolor @@ -74,5 +77,6 @@ -tristatevalue (-tk-variable -variable) -width) (:default-initargs :command (lambda (self) - (setf (selection (upper self selector)) self)))) + (setf (selection (upper self selector)) + (value self))))) Index: cell-cultures/celtic/canvas.lisp diff -u cell-cultures/celtic/canvas.lisp:1.1 cell-cultures/celtic/canvas.lisp:1.2 --- cell-cultures/celtic/canvas.lisp:1.1 Sat Jun 26 11:38:38 2004 +++ cell-cultures/celtic/canvas.lisp Sun Jul 4 11:59:43 2004 @@ -22,6 +22,7 @@ (in-package :celtic) (def-widget canvas () + () (-background -borderwidth -cursor -highlightbackground -highlightcolor -highlightthickness -insertbackground -insertborderwidth -insertofftime -insertontime -insertwidth -relief Index: cell-cultures/celtic/celtic.lisp diff -u cell-cultures/celtic/celtic.lisp:1.2 cell-cultures/celtic/celtic.lisp:1.3 --- cell-cultures/celtic/celtic.lisp:1.2 Sun Jun 27 16:54:28 2004 +++ cell-cultures/celtic/celtic.lisp Sun Jul 4 11:59:43 2004 @@ -84,11 +84,11 @@ ;;; start wish and set *w* (defun tk-start () #+:sbcl (setf *w* (do-execute "/usr/bin/wish" '("-name" "Cells-LTk"))) - #-:sbcl (setf *w* (do-execute "wish" '("-name" "Cells-LTk")))) + #-:sbcl (setf *w* (do-execute "wish84" '("-name" "Visual Apropos")))) (defun tk-send (text) "send a string to wish" - (when *debug-tk* + (when nil ;; (search "pack " text) ;; *debug-tk* (format t "~&tk-send> ~A~%" text) (force-output)) (format *w* "~A~%" text) @@ -114,11 +114,14 @@ (defvar *callbacks* (make-hash-table :test #'equal)) -(defun register-callback(self callback-id fun - &aux (id (conc$ (path self) "." (down$ callback-id)))) - (format t "~&object ~a registering callback ~a: ~A" self id fun) +(defun register-callback (self callback-id fun + &aux (id (widget-callback-id self callback-id))) + ;;(format t "~&object ~a registering callback ~a: ~A" self :id id) (setf (gethash id *callbacks*) (cons fun self))) +(defun widget-callback-id (self callback-id) + (conc$ (path self) "." (down$ callback-id))) + (defun dispatch-callback(sym args) (let ((func-self (gethash sym *callbacks*))) ;(format t "sym:~S fun:~A~%" sym func-self) @@ -126,18 +129,19 @@ (when (not func-self) (format t "~&callback ~a, type ~a, pkg ~a, not found. known callbacks:" sym (type-of sym) (when (typep sym 'symbol) (symbol-package sym))) - #+shhh (maphash (lambda (key func-self) + (maphash (lambda (key func-self) (declare (ignore func-self)) (format t "~&known callback key ~a, type ~a, pkg ~a" key (type-of key)(when (typep key 'symbol) (symbol-package key)))) *callbacks*)) - (when func-self + (when (car func-self) (apply (car func-self) (cdr func-self) args)))) (defun after (self time func) "Usage: (after self <time> <func>)) ...after <time> msec call function <func>" (register-callback self "after" func) - (tk-send (format nil "after ~a {puts -nonewline {(\"~A\") };flush stdout}" time "after"))) + (tk-send (format nil "after ~a {puts -nonewline {(\"~A\") };flush stdout}" + time (widget-callback-id self "after")))) ;; tool functions used by the objects @@ -158,7 +162,7 @@ (defvar *tk-root*) (defun mainloop() - (trc "mainloop !!! *w* is" *w*) + (trc nil "mainloop !!! *w* is" *w*) (let ((*exit-mainloop* nil) (*read-eval* nil)) ;;safety against malicious clients (loop @@ -167,22 +171,17 @@ (trc "sitting on mainloop read") (tk-read)))) (when (null msg) (return)) - (when t ;; *debug-tk* + (when *debug-tk* (format t "~&msg:~A<=~%" msg) (force-output)) (if (consp msg) (progn - (trc "dispatching callback" msg) + (trc nil "dispatching callback" msg) (dispatch-callback (first msg) (rest msg))) (let ((emsg (read-line *w* nil nil))) (trc "error msg:" msg emsg))) - #+not - (if (eql #\( (elt msg 0)) - (let ((l (read-from-string msg))) - (trc "dispatching callback" l) - (dispatch-callback (first l) (rest l))) - (trc "mainloop gets tk error" msg)) + (when *exit-mainloop* (tk-send "exit") (return)))))) @@ -207,10 +206,8 @@ (tk-send (format nil "grid configure ~a -~a {~a}" (path widget) option value))) (defun tk-test (fn) - (trc "input is" *standard-input* *standard-output*) - (trc "debug-io is" *debug-io*) - - (let ((*debug-tk* nil)) + (let ((*debug-tk* nil) + (*callbacks* (make-hash-table :test #'equal))) (cell-reset) (tk-start) (let ((*tk-root* (funcall fn))) Index: cell-cultures/celtic/celtic.lpr diff -u cell-cultures/celtic/celtic.lpr:1.2 cell-cultures/celtic/celtic.lpr:1.3 --- cell-cultures/celtic/celtic.lpr:1.2 Sun Jun 27 16:54:28 2004 +++ cell-cultures/celtic/celtic.lpr Sun Jul 4 11:59:43 2004 @@ -11,9 +11,11 @@ (make-instance 'module :name "frame.lisp") (make-instance 'module :name "canvas.lisp") (make-instance 'module :name "textual.lisp") - (make-instance 'module :name "button.lisp")) + (make-instance 'module :name "button.lisp") + (make-instance 'module :name "menu.lisp") + (make-instance 'module :name "scrolling.lisp")) :projects (list (make-instance 'project-module :name - "c:\\dvl\\cells\\cells")) + "..\\cells\\cells")) :libraries nil :distributed-files nil :project-package-name :celtic Index: cell-cultures/celtic/frame.lisp diff -u cell-cultures/celtic/frame.lisp:1.3 cell-cultures/celtic/frame.lisp:1.4 --- cell-cultures/celtic/frame.lisp:1.3 Sun Jun 27 21:25:14 2004 +++ cell-cultures/celtic/frame.lisp Sun Jul 4 11:59:43 2004 @@ -21,95 +21,49 @@ (in-package :celtic) -(def-widget frame () - (-borderwidth -cursor -highlightbackground -highlightcolor - -highlightthickness -padx -pady -relief - -takefocus -background (tk-class -class) - -colormap -container -height -visual -width)) +;--- group geometry ----------------------------------------- -(defun test-frame () - (make-be 'frame - :kids (loop repeat 2 - collecting (make-instance 'button - :text (format nil "Time is ~a" (floor (get-internal-real-time) 1000)) - :borderwidth 4 - :underline 2 - :cursor "hand2" - :font "Courier")))) - -;------------------------------------------------------- +(defmodel inline-mixin () + ((kids-layout :initarg :kids-layout :accessor kids-layout :initform nil) + (padx :initarg :padx :accessor padx :initform 0) + (pady :initarg :pady :accessor pady :initform 0) + (layout-side :initarg :layout-side :accessor layout-side :initform 'left) + (layout-anchor :initarg :layout-anchor :accessor layout-anchor :initform 'nw)) + (:default-initargs + :kid-slots (lambda (self) + (declare (ignore self)) + (list + (mk-kid-slot (layout :if-missing t) + nil))) ;; suppress default + :kids-layout (c? (format nil "pack~{ ~a~} -side ~a -anchor ~a -padx ~a -pady ~a" + (mapcar 'path (^kids)) + (down$ (^layout-side)) + (down$ (^layout-anchor)) + (^padx)(^pady))))) -(def-widget labelframe () - (-borderwidth -cursor -highlightbackground -highlightcolor - -highlightthickness -padx -pady -relief - -takefocus -background (tk-class -class) -colormap -container -height -visual -width - -text -labelanchor -labelwidget)) +(def-c-output kids-layout () + (when new-value + (tk-send new-value))) -(defmodel stack (frame) +(defmodel row-mixin (inline-mixin) () (:default-initargs - :kid-slots (lambda (self) - (declare (ignore self)) - (list - (mk-kid-slot (layout :if-missing t) - (c? (format nil "pack~{ ~a~} -side {top} -anchor nw" - (path self)))))))) -(defun stack (&rest init-args) - (apply 'make-instance 'stack init-args)) - - -(defun test-labelframe () - (make-be 'labelframe - :text "Considering" - :padx 16 - :pady 16 - :kids (loop repeat 2 - collecting (make-instance 'button - :text (format nil "Time is ~a" (floor (get-internal-real-time) 1000)) - :borderwidth 4 - :padx 8 - :underline 2 - :cursor "hand2" - :font "Courier")))) - -; ------------------------------------------------------------------ + :layout-side 'left)) -(defmodel labelframe-selector (selector labelframe)()) -(defun labelframe-selector (&rest init-args) - (apply 'make-instance 'labelframe-selector init-args)) - -;------------------------------------------------------- +(defmodel stack-mixin (inline-mixin) + () + (:default-initargs + :layout-side 'top)) -(defun layout-row () - (c? (format nil "pack ~a -side {left}; pack~{ ~a~} -side {left}" - (path self) (mapcar 'path (^kids))))) - -(defun layout-stack () - (c? (format nil "pack ~a -side {left}; pack~{ ~a~} -side {top} -anchor nw" - (path self) (mapcar 'path (^kids))))) - -(defmacro frame-row ((&rest options) &rest kids) - `(frame ,@(append options - `(:layout (layout-row) - :kids (c? (list ,@kids)))))) - -(defmacro frame-stack ((&rest options) &rest kids) - `(frame ,@(append options - `(:layout (layout-stack) - :kids (c? (list ,@kids)))))) ;------------------------------------------------------ (defmodel selector () - ((selection :accessor selection :initarg :selection) - (initial-selection :initform nil :reader initial-selection - :initarg :initial-selection) - (tk-variable :cell nil :accessor tk-variable :initarg :tk-variable)) - (:default-initargs - :selection (c-in nil))) - -(def-c-output initial-selection () - (setf (selection self) new-value)) + ((selection :initform nil :accessor selection :initarg :selection) + (tk-variable :accessor tk-variable :initarg :tk-variable)) + (:default-initargs + :selection (c-in nil) + :tk-variable (c? (md-name self)))) (def-c-output selection () (when new-value @@ -117,14 +71,45 @@ (down$ (tk-variable self)) (down$ (md-name new-value)))))) -;--------------------------------------------------------- +;--- f r a m e -------------------------------------------------- -(defmodel radiogroup (selector) - ((tk-variable :accessor tk-variable :initarg :tk-variable)) - (:default-initargs - :tk-variable (c? (md-name self)))) +(def-widget frame () + () + (-borderwidth -cursor -highlightbackground -highlightcolor + -highlightthickness -padx -pady -relief + -takefocus -background (tk-class -class) + -colormap -container -height -visual -width)) + +(defmodel frame-selector (selector frame)()) +(defun frame-selector (&rest init-args) + (apply 'make-instance 'frame-selector init-args)) + +(defmodel frame-stack (stack-mixin frame-selector)()) +(defun frame-stack (&rest init-args) + (apply 'make-instance 'frame-stack init-args)) + +(defmodel frame-row (row-mixin frame-selector)()) +(defun frame-row (&rest init-args) + (apply 'make-instance 'frame-row init-args)) -(defmodel labelframe-radiogroup (radiogroup labelframe)()) -(defun labelframe-radiogroup (&rest init-args) - (apply 'make-instance 'labelframe-radiogroup init-args)) +;--- l a b e l f r a m e ---------------------------------------------- + +(def-widget labelframe () + () + (-borderwidth -cursor -highlightbackground -highlightcolor + -highlightthickness -padx -pady -relief + -takefocus -background (tk-class -class) -colormap -container -height -visual -width + -text -labelanchor -labelwidget)) + +(defmodel labelframe-selector (selector labelframe)()) +(defun labelframe-selector (&rest init-args) + (apply 'make-instance 'labelframe-selector init-args)) + +(defmodel labelframe-stack (stack-mixin labelframe-selector)()) +(defun labelframe-stack (&rest init-args) + (apply 'make-instance 'labelframe-stack init-args)) + +(defmodel labelframe-row (row-mixin labelframe-selector)()) +(defun labelframe-row (&rest init-args) + (apply 'make-instance 'labelframe-row init-args)) Index: cell-cultures/celtic/textual.lisp diff -u cell-cultures/celtic/textual.lisp:1.1 cell-cultures/celtic/textual.lisp:1.2 --- cell-cultures/celtic/textual.lisp:1.1 Sat Jun 26 11:38:38 2004 +++ cell-cultures/celtic/textual.lisp Sun Jul 4 11:59:43 2004 @@ -22,13 +22,14 @@ (in-package :celtic) (def-widget label () - (-activebackground -activeforeground -anchor -background - -bitmap -borderwidth -cursor -disabledforeground - -font -foreground -highlightbackground -highlightcolor - -highlightthickness -image -justify -padx - -pady -relief -takefocus -text - -textvariable -underline -wraplength - -compound -height -state -width)) + () + (-activebackground -activeforeground -anchor -background + -bitmap -borderwidth -cursor -disabledforeground + -font -foreground -highlightbackground -highlightcolor + -highlightthickness -image -justify -padx + -pady -relief -takefocus -text + -textvariable -underline -wraplength + -compound -height -state -width)) (defun test-label () (make-be 'label :text (format nil "Time is ~a" (get-internal-real-time)) @@ -39,6 +40,7 @@ ;-------------------------------------------------------------------------- (def-widget message () + () (-anchor -background -borderwidth -cursor -font -foreground -highlightbackground -highlightcolor -highlightthickness -padx -pady -relief @@ -58,6 +60,7 @@ ;---------------------------------------------------------------------------- (def-widget entry () + ((text :initarg :text :accessor text :initform nil)) (-background -borderwidth -cursor -exportselection -font -foreground -highlightbackground -highlightcolor -highlightthickness -insertbackground -insertborderwidth -insertofftime @@ -66,4 +69,13 @@ -textvariable -xscrollcommand -disabledbackground -disabledforeground -invalidcommand -readonlybackground -show -state - -validate -validatecommand -width)) + -validate -validatecommand -width) + (:default-initargs + :textvariable (c? (md-name self)))) + +(def-c-output text ((self entry)) + (when new-value + (tk-send (eko ("entry sets text var" self new-value) + (format nil "set ~a ~s" + (down$ (textvariable self)) + new-value))))) Index: cell-cultures/celtic/widget-item.lisp diff -u cell-cultures/celtic/widget-item.lisp:1.2 cell-cultures/celtic/widget-item.lisp:1.3 --- cell-cultures/celtic/widget-item.lisp:1.2 Sun Jun 27 21:25:14 2004 +++ cell-cultures/celtic/widget-item.lisp Sun Jul 4 11:59:43 2004 @@ -26,7 +26,7 @@ (defmethod md-awaken :before ((self tk-object)) (make-tk-instance self)) -;;; --- +;;; --- widget ----------------------------------------- (defmodel widget (family tk-object) ((name :initarg :name :accessor name @@ -35,29 +35,50 @@ :initform (c? (format nil "~a.~a" (if (fm-parent self) (path .parent) "") (name self)))) - (layout :reader layout :initarg :layout :initform nil) - (configurations :reader configurations :initarg :configurations :initform nil)) + (layout :reader layout :initarg :layout + :initform (c? (format nil "pack ~a" (path self)))) + (enabled :reader enabled :initarg :enabled :initform t) + (command-is-callback :reader command-is-callback :initarg :command-is-callback + :initform t) + (bindings :reader bindings :initarg :bindings :initform nil) + (selector :reader selector :initarg :selector + :initform (c? (upper self selector)))) (:default-initargs :md-name (create-name))) +(defmethod not-to-be :after ((self widget)) + (trc "whacking true widget" self) + (tk-send (format nil "pack forget ~a" (^path)))) + (def-c-output command ((self widget)) - (let ((id (conc$ (path self) ".command"))) + (when (^command-is-callback) (register-callback self "command" new-value) (configure self "command" - (format nil "puts -nonewline {(~s)};flush stdout" id)))) + (format nil "puts -nonewline {(~s)};flush stdout" + (widget-callback-id self "command"))))) + +(def-c-output bindings () ;;; (w widget) event fun) + (loop for binding in new-value + for name = (create-name) + do (destructuring-bind (event . fn) binding + (declare (ignorable event)) + (register-callback self name fn) + (tk-send (format nil "bind ~a ~a {puts -nonewline {(\"~A\")};flush stdout}" + (^path) event (widget-callback-id self name)))))) (defmethod configure ((self widget) option value) (tk-send (format nil "~A configure -~A {~A}" (path self) option value))) -;;; --- layout -------------------- - (def-c-output layout ((self widget)) (when new-value (tk-send new-value))) -(defmacro def-widget (class (&rest super-classes)(&rest tk-options) &rest defclass-options) - (let ((std-factory t)) - (flet ((de- (sym) (intern (remove #\- (symbol-name sym) :end 1)))) +;;; --- widget -------------------- + +(defmacro def-widget (class (&key (std-factory t)) + (&rest std-slots) + (&rest tk-options) &rest defclass-options) + (flet ((de- (sym) (intern (remove #\- (symbol-name sym) :end 1)))) (multiple-value-bind (slots outputs) (loop for tk-option-def in tk-options for slot-name = (de- (if (atom tk-option-def) @@ -71,12 +92,13 @@ (when new-value (configure self ,(down$ (de- (if (atom tk-option-def) tk-option-def (cadr tk-option-def)))) - (down$ new-value)))) + (if (stringp new-value) + new-value (down$ new-value))))) into outputs finally (return (values slot-defs outputs))) `(progn - (defmodel ,class (,@(append super-classes '(widget))) - (,@slots) + (defmodel ,class (widget) + (,@(append std-slots slots)) ,@defclass-options) (defun ,class (&rest inits) (apply 'make-instance ',class inits)) @@ -84,7 +106,10 @@ `(defmethod make-tk-instance ((self ,class)) (tk-send (format nil ,(concatenate 'string (down$ class) " ~A") (path self))))) - ,@outputs))))) + ,@outputs)))) + +(defmacro pack-layout? (fmt$ &rest args) + `(c? (format nil "pack ~a ~?" (^path) ,fmt$ (list ,@args)))) ;;; --- items ----------------------------------------------------------------------- @@ -102,7 +127,7 @@ (defmethod make-tk-instance :after ((self item)) (setf (id-no self) (let ((msg (tk-read))) - ;;(trc "item msg" msg) + (trc "created item" self :id msg) (read-from-string msg)))) (defmethod configure ((self item) option value)

1 0

[cells-cvs] CVS update: cell-cultures/cl-ftgl/cl-ftgl.lisp
by Kenny Tilton 04 Jul '04

04 Jul '04

Update of /project/cells/cvsroot/cell-cultures/cl-ftgl In directory common-lisp.net:/tmp/cvs-serv5472/cl-ftgl Modified Files: cl-ftgl.lisp Log Message: Date: Sun Jul 4 11:59:44 2004 Author: ktilton Index: cell-cultures/cl-ftgl/cl-ftgl.lisp diff -u cell-cultures/cl-ftgl/cl-ftgl.lisp:1.1 cell-cultures/cl-ftgl/cl-ftgl.lisp:1.2 --- cell-cultures/cl-ftgl/cl-ftgl.lisp:1.1 Sat Jun 26 11:38:39 2004 +++ cell-cultures/cl-ftgl/cl-ftgl.lisp Sun Jul 4 11:59:44 2004 @@ -20,7 +20,7 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -;;; $Header: /project/cells/cvsroot/cell-cultures/cl-ftgl/cl-ftgl.lisp,v 1.1 2004/06/26 18:38:39 ktilton Exp $ +;;; $Header: /project/cells/cvsroot/cell-cultures/cl-ftgl/cl-ftgl.lisp,v 1.2 2004/07/04 18:59:44 ktilton Exp $ (defpackage #:cl-ftgl (:nicknames #:ftgl) @@ -433,7 +433,7 @@ (let ((cf (ftgl-get-metrics-font font))) (assert cf) (unless (ftgl-ready font) - (when clo::*listingp* (cells::c-break "bad time #1 for sizing? ~a ~a" clo::*listingp* font)) + ;;(when *ogl-listing-p* (cells::c-break "bad time #1 for sizing? ~a ~a" *ogl-listing-p* font)) (setf (ftgl-ready font) t) (fgc-set-face-size cf (ftgl-size font) (ftgl-target-res font))) cf))

1 0

[cells-cvs] CVS update: cell-cultures/cells/cells-test/cells-test.asd cell-cultures/cells/cells-test/cells-test.lpr cell-cultures/cells/cells-test/person.lisp
by Kenny Tilton 04 Jul '04

04 Jul '04

Update of /project/cells/cvsroot/cell-cultures/cells/cells-test In directory common-lisp.net:/tmp/cvs-serv5472/cells/cells-test Modified Files: person.lisp Added Files: cells-test.asd cells-test.lpr Log Message: Date: Sun Jul 4 11:59:42 2004 Author: ktilton Index: cell-cultures/cells/cells-test/cells-test.asd diff -u /dev/null cell-cultures/cells/cells-test/cells-test.asd:1.3 --- /dev/null Sun Jul 4 11:59:43 2004 +++ cell-cultures/cells/cells-test/cells-test.asd Sun Jul 4 11:59:42 2004 @@ -0,0 +1,20 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- + +(operate 'load-op :asdf-aclproj) +(use-package :asdf-aclproj) + +#+(or allegro lispworks cmu mcl clisp cormanlispx sbcl scl) + +(asdf:defsystem :cells-test + :name "cells-test" + :author "Kenny Tilton <ktilton(a)nyc.rr.com>" + :version "05-Nov-2003" + :maintainer "Kenny Tilton <ktilton(a)nyc.rr.com>" + :licence "MIT Style" + :description "Cells Regression Test/Documentation" + :long-description "Informatively-commented regression tests for Cells" + :serial t + :components ((lpr-project-file "cells-test"))) + +(defmethod perform :after ((op load-op) (system (eql (find-system :cells-test)))) + (cells::cv-test)) \ No newline at end of file Index: cell-cultures/cells/cells-test/person.lisp diff -u cell-cultures/cells/cells-test/person.lisp:1.2 cell-cultures/cells/cells-test/person.lisp:1.3 --- cell-cultures/cells/cells-test/person.lisp:1.2 Wed Jun 30 20:48:54 2004 +++ cell-cultures/cells/cells-test/person.lisp Sun Jul 4 11:59:42 2004 @@ -287,20 +287,20 @@ (trc "start guarded cyclic") #+not (cv-assert-error - (let ((tk (make-be 'talker))) - (setf (idea tk) "yes") - (cv-assert (string-equal "yes" (words tk))) - (setf (words tk) "no") - (cv-assert (string-equal "no" (idea tk))))) + (let ((tk (make-be 'talker))) + (setf (idea tk) "yes") + (cv-assert (string-equal "yes" (words tk))) + (setf (words tk) "no") + (cv-assert (string-equal "no" (idea tk))))) ;; ;; make sure cells declared to be cyclic are allowed ;; and halt (because after the first cyclic setf the cell in question ;; is being given the same value it already has, and propagation stops. ;; (make-be 'talker8) - #+not (let ((tk (make-be 'talker8))) - (setf (idea8 tk) "yes") - (string-equal "yes" (words8 tk)) - (setf (words8 tk) "no") - (string-equal "no" (idea8 tk))) + #+not (let ((tk (make-be 'talker8))) + (setf (idea8 tk) "yes") + (string-equal "yes" (words8 tk)) + (setf (words8 tk) "no") + (string-equal "no" (idea8 tk))) )

1 0

[cells-cvs] CVS update: cell-cultures/cells/cell-types.lisp cell-cultures/cells/cells.lisp cell-cultures/cells/constructors.lisp cell-cultures/cells/defpackage.lisp cell-cultures/cells/integrity.lisp cell-cultures/cells/md-slot-value.lisp cell-cultures/cells/model-object.lisp cell-cultures/cells/propagate.lisp cell-cultures/cells/synapse.lisp cell-cultures/cells/cells-test.asd cell-cultures/cells/cells-test.lpr cell-cultures/cells/rif.lisp
by Kenny Tilton 04 Jul '04

04 Jul '04

Update of /project/cells/cvsroot/cell-cultures/cells In directory common-lisp.net:/tmp/cvs-serv5472/cells Modified Files: cell-types.lisp cells.lisp constructors.lisp defpackage.lisp integrity.lisp md-slot-value.lisp model-object.lisp propagate.lisp synapse.lisp Removed Files: cells-test.asd cells-test.lpr rif.lisp Log Message: Date: Sun Jul 4 11:59:41 2004 Author: ktilton Index: cell-cultures/cells/cell-types.lisp diff -u cell-cultures/cells/cell-types.lisp:1.1 cell-cultures/cells/cell-types.lisp:1.2 --- cell-cultures/cells/cell-types.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/cell-types.lisp Sun Jul 4 11:59:41 2004 @@ -53,8 +53,8 @@ (defstruct (c-ruled (:include cell) (:conc-name cr-)) - (synapses nil :type list) lazy + (code nil :type list) ;; /// feature this out on production build rule) (defun c-optimized-away-p (c) @@ -73,8 +73,8 @@ (defstruct (c-dependent (:include c-ruled) (:conc-name cd-)) + (synapses nil :type list) (useds nil :type list) - (code nil :type list) ;; /// feature this out on production build (usage (make-array *cd-usagect* :element-type 'bit :initial-element 0) :type vector)) Index: cell-cultures/cells/cells.lisp diff -u cell-cultures/cells/cells.lisp:1.2 cell-cultures/cells/cells.lisp:1.3 --- cell-cultures/cells/cells.lisp:1.2 Tue Jun 29 01:58:49 2004 +++ cell-cultures/cells/cells.lisp Sun Jul 4 11:59:41 2004 @@ -112,6 +112,7 @@ (declare (ignorable slot-name self new old old-boundp))) + ; -------- cell conditions (not much used) --------------------------------------------- (define-condition xcell () ;; new 2k0227 Index: cell-cultures/cells/constructors.lisp diff -u cell-cultures/cells/constructors.lisp:1.1 cell-cultures/cells/constructors.lisp:1.2 --- cell-cultures/cells/constructors.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/constructors.lisp Sun Jul 4 11:59:41 2004 @@ -87,7 +87,7 @@ :code ',forms :value-state :unevaluated :rule (c-lambda ,@forms) - ,@keys)) + ,@keys)) (defmacro c-input ((&rest keys) &optional (value nil valued-p)) `(make-cell Index: cell-cultures/cells/defpackage.lisp diff -u cell-cultures/cells/defpackage.lisp:1.3 cell-cultures/cells/defpackage.lisp:1.4 --- cell-cultures/cells/defpackage.lisp:1.3 Wed Jun 30 14:02:47 2004 +++ cell-cultures/cells/defpackage.lisp Sun Jul 4 11:59:41 2004 @@ -38,15 +38,19 @@ #:class-precedence-list #:class-slots #:slot-definition-name ) - - (:export #:cell #:c-input #:c-in #:c-in8 #:c? #:c?8 #:c?_ #:c?? + #+clisp (:import-from #:clos #:class-slots #:class-precedence-list) + #+cmu (:import-from #:pcl #:class-precedence-list #:class-slots + #:slot-definition-name #:true) + #+lispworks (:import-from #:lw #:true) + (:export #:cell #:c-input #:c-in #:c-in8 + #:c-formula #:c? #:c?8 #:c?_ #:c?? #:with-integrity #:with-deference #:without-c-dependency #:self #:.cache #:c-lambda #:.cause #:defmodel #:c-awaken #:def-c-output #:def-c-unchanged-test #:new-value #:old-value #:c... #:make-be #:mkpart #:the-kids #:nsib #:md-value #:^md-value #:.md-value #:kids #:^kids #:.kids - #:cell-reset #:upper #:fm-max #:nearest #:^fm-min-kid #:^fm-max-kid #:mk-kid-slot + #:cell-reset #:upper #:fm-max #:nearest #:fm-min-kid #:fm-max-kid #:mk-kid-slot #:def-kid-slots #:find-prior #:fm-pos #:kid-no #:fm-includes #:fm-ascendant-common #:fm-kid-containing #:fm-find-if #:fm-ascendant-if #:c-abs #:fm-collect-if #:psib #:to-be #:not-to-be #:ssibno #:md-awaken Index: cell-cultures/cells/integrity.lisp diff -u cell-cultures/cells/integrity.lisp:1.1 cell-cultures/cells/integrity.lisp:1.2 --- cell-cultures/cells/integrity.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/integrity.lisp Sun Jul 4 11:59:41 2004 @@ -24,6 +24,7 @@ (defun data-pulse-next (pulse-info) (declare (ignorable pulse-info)) + (trc nil "data-pulse-next > " (1+ *data-pulse-id*) pulse-info) (if (< *data-pulse-id* most-positive-fixnum) (incf *data-pulse-id*) (progn @@ -93,7 +94,7 @@ (trc nil "!!!!!!!!!! started new *unfinished-business*" key defer-info) (when (or (zerop *data-pulse-id*) (member opcode '(:setf :makunbound))) - (data-pulse-next defer-info) + (data-pulse-next (cons opcode defer-info)) (trc nil "!!! New pulse, event" *data-pulse-id* defer-info)) (prog1 (funcall action) Index: cell-cultures/cells/md-slot-value.lisp diff -u cell-cultures/cells/md-slot-value.lisp:1.1 cell-cultures/cells/md-slot-value.lisp:1.2 --- cell-cultures/cells/md-slot-value.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/md-slot-value.lisp Sun Jul 4 11:59:41 2004 @@ -54,6 +54,7 @@ (defun c-influenced-by-pulse (c); &aux (ip *data-pulse-id*)) (unless (c-currentp c) (count-it :c-influenced-by-pulse) + (trc c "c-influenced-by-pulse> " c (c-useds c)) (some (lambda (used) (c-value-ensure-current used) (when (and (c-changed used) (> (c-pulse used)(c-pulse c))) Index: cell-cultures/cells/model-object.lisp diff -u cell-cultures/cells/model-object.lisp:1.1 cell-cultures/cells/model-object.lisp:1.2 --- cell-cultures/cells/model-object.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/model-object.lisp Sun Jul 4 11:59:41 2004 @@ -96,15 +96,15 @@ (c-model c) self (c-slot-name c) sn (md-slot-cell self sn) c)) - (if (c-unboundp c) - (progn (trc "unbound cell" (type-of c) c) - (bd-slot-makunbound self sn)) - (setf (slot-value self sn) - (if c-isa-cell + + (if c-isa-cell + (if (c-unboundp c) + (bd-slot-makunbound self sn) + (setf (slot-value self sn) (if (c-inputp c) - (c-value c) - nil) - c)))) + (c-value c) + nil))) + (setf (slot-value self sn) c))) ;------------------ md obj initialization ------------------ Index: cell-cultures/cells/propagate.lisp diff -u cell-cultures/cells/propagate.lisp:1.1 cell-cultures/cells/propagate.lisp:1.2 --- cell-cultures/cells/propagate.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/propagate.lisp Sun Jul 4 11:59:41 2004 @@ -56,15 +56,14 @@ (c-output-slot c (c-slot-name c) (c-model c) (c-value c) prior-value prior-value-supplied))) - (defun c-propagate-to-users (c) (trc nil "c-propagate-to-users > queueing" c :cause *causation*) - (let ((causation (list* c *causation*))) ;; in case deferred + (let ((causation (cons c *causation*))) ;; in case deferred (with-integrity (:user-notify :user-notify c) (let ((*causation* causation)) (trc nil "c-propagate-to-users > notifying users of" c) (dolist (user (c-users c)) - (trc nil "c-propagate-to-users> cause, user, c:" *causation* user c) + (trc user "c-propagate-to-users> *data-pulse-id*, user, c:" *data-pulse-id* user c) (when (c-user-cares user) (c-value-ensure-current user))))))) @@ -89,7 +88,7 @@ (c-output-slot nil slot-name self (bd-slot-value self slot-name) nil nil))) (defun c-output-slot (c slot-name self new-value prior-value prior-value-supplied) - (let ((causation (list* c *causation*))) ;; in case deferred + (let ((causation *causation*)) ;; in case deferred (with-integrity (:c-output-slot :output c) (let ((*causation* causation)) (trc nil "c-output-slot > causation" c *causation* causation) Index: cell-cultures/cells/synapse.lisp diff -u cell-cultures/cells/synapse.lisp:1.1 cell-cultures/cells/synapse.lisp:1.2 --- cell-cultures/cells/synapse.lisp:1.1 Sat Jun 26 11:38:36 2004 +++ cell-cultures/cells/synapse.lisp Sun Jul 4 11:59:41 2004 @@ -28,13 +28,13 @@ (defmacro with-synapse (((&rest closure-vars) &key trcp fire-p fire-value) &body body) (declare (ignorable trcp)) (let ((lex-loc-key (gensym "synapse-id"))) - `(let ((synapse (or (cdr (assoc ',lex-loc-key (cr-synapses + `(let ((synapse (or (cdr (assoc ',lex-loc-key (cd-synapses (car *c-calculators*)))) (cdar (push (cons ',lex-loc-key (let (,@closure-vars) (make-synaptic-ruled slot-c (,fire-p ,fire-value) ,@body))) - (cr-synapses + (cd-synapses (car *c-calculators*))))))) (progn ;;let ((*c-calculators* (cons synapse *c-calculators*))) (c-value-ensure-current synapse)))))

1 0

[cells-cvs] CVS update: cell-cultures/cellodemo/cellodemo.lpr
by Kenny Tilton 04 Jul '04

04 Jul '04

Update of /project/cells/cvsroot/cell-cultures/cellodemo In directory common-lisp.net:/tmp/cvs-serv5472/cellodemo Modified Files: cellodemo.lpr Log Message: Date: Sun Jul 4 11:59:41 2004 Author: ktilton Index: cell-cultures/cellodemo/cellodemo.lpr diff -u cell-cultures/cellodemo/cellodemo.lpr:1.1 cell-cultures/cellodemo/cellodemo.lpr:1.2 --- cell-cultures/cellodemo/cellodemo.lpr:1.1 Sat Jun 26 11:38:35 2004 +++ cell-cultures/cellodemo/cellodemo.lpr Sun Jul 4 11:59:40 2004 @@ -11,8 +11,8 @@ (make-instance 'module :name "tutor-geometry.lisp") (make-instance 'module :name "light-panel.lisp") (make-instance 'module :name "hedron-render.lisp") - (make-instance 'module :name "hedron-decoration.lisp") - (make-instance 'module :name "do-list.lisp")) + (make-instance 'module :name + "hedron-decoration.lisp")) :projects (list (make-instance 'project-module :name "..\\cello\\cello")) :libraries nil

1 0

[cells-cvs] CVS update: cell-cultures/cello/cello.lisp cell-cultures/cello/cello.lpr cell-cultures/cello/image.lisp cell-cultures/cello/ix-geometry.lisp cell-cultures/cello/pick.lisp cell-cultures/cello/cellocore.lisp
by Kenny Tilton 04 Jul '04

04 Jul '04

Update of /project/cells/cvsroot/cell-cultures/cello In directory common-lisp.net:/tmp/cvs-serv5472/cello Modified Files: cello.lpr image.lisp ix-geometry.lisp pick.lisp Added Files: cello.lisp Removed Files: cellocore.lisp Log Message: Date: Sun Jul 4 11:59:40 2004 Author: ktilton Index: cell-cultures/cello/cello.lpr diff -u cell-cultures/cello/cello.lpr:1.1 cell-cultures/cello/cello.lpr:1.2 --- cell-cultures/cello/cello.lpr:1.1 Sat Jun 26 11:38:33 2004 +++ cell-cultures/cello/cello.lpr Sun Jul 4 11:59:40 2004 @@ -4,9 +4,9 @@ (defpackage :cello (:export)) -(define-project :name :cellocore +(define-project :name :cello :application-type (intern "Standard EXE" (find-package :keyword)) - :modules (list (make-instance 'module :name "cellocore.lisp") + :modules (list (make-instance 'module :name "cello.lisp") (make-instance 'module :name "datetime.lisp") (make-instance 'module :name "window-macros.lisp") (make-instance 'module :name "clipping.lisp") @@ -55,11 +55,11 @@ (make-instance 'project-module :name "..\\cl-opengl\\cl-opengl") (make-instance 'project-module :name - "c:\\dvl\\cl-ftgl\\cl-ftgl") + "..\\cl-ftgl\\cl-ftgl") (make-instance 'project-module :name - "c:\\dvl\\cl-magick\\cl-magick") + "..\\cl-magick\\cl-magick") (make-instance 'project-module :name - "c:\\dvl\\cl-openal\\cl-openal")) + "..\\cl-openal\\cl-openal")) :libraries nil :distributed-files nil :project-package-name :cello Index: cell-cultures/cello/image.lisp diff -u cell-cultures/cello/image.lisp:1.1 cell-cultures/cello/image.lisp:1.2 --- cell-cultures/cello/image.lisp:1.1 Sat Jun 26 11:38:33 2004 +++ cell-cultures/cello/image.lisp Sun Jul 4 11:59:40 2004 @@ -32,9 +32,8 @@ (defmethod ogl-dsp-list-prep progn (self) (declare (ignore self)) - (assert (not *listingp*))) + (assert (not *ogl-listing-p*))) -(defparameter *listingp* nil) (defvar *window-rendering*) (defmodel ogl-node () @@ -44,9 +43,9 @@ (let ((display-list-name (or .cache (gl-gen-lists 1))) (*window-rendering* (nearest self window))) - (assert (not *listingp*)) + (assert (not *ogl-listing-p*)) (gl-new-list display-list-name gl_compile) - (let ((*listingp* self) + (let ((*ogl-listing-p* self) *selecting* *render-clip-l* *render-clip-r* *render-clip-t* *render-clip-b*) (with-metrics (nil nil "(funcall renderer)" self) (ix-paint self))) Index: cell-cultures/cello/ix-geometry.lisp diff -u cell-cultures/cello/ix-geometry.lisp:1.1 cell-cultures/cello/ix-geometry.lisp:1.2 --- cell-cultures/cello/ix-geometry.lisp:1.1 Sat Jun 26 11:38:33 2004 +++ cell-cultures/cello/ix-geometry.lisp Sun Jul 4 11:59:40 2004 @@ -308,20 +308,6 @@ (:center (floor (- (inset-height .parent) (l-height self)) -2)) (:bottom (- (inset-height .parent) (l-height self)))))) - - - - - - - - -(defmacro ^as-low-as-parent () - `(inset-lb (fm-parent self))) - -(defmacro ^as-right-as-kids () - `(^fm-max-kid pr)) - (defmacro ^fill-parent-right (&optional (inset 0)) `(lr-maintain-pr (- (inset-lr .parent) ,inset))) Index: cell-cultures/cello/pick.lisp diff -u cell-cultures/cello/pick.lisp:1.1 cell-cultures/cello/pick.lisp:1.2 --- cell-cultures/cello/pick.lisp:1.1 Sat Jun 26 11:38:33 2004 +++ cell-cultures/cello/pick.lisp Sun Jul 4 11:59:40 2004 @@ -59,7 +59,7 @@ (glu-perspective 45 aspect 0.1 100.0)) ;;OQ: appropriate for ortho? (gl-matrix-mode gl_model-view) - #+not (let ((*listingp* target) + #+not (let ((*ogl-listing-p* target) *selecting* *render-clip-l* *render-clip-r* *render-clip-t* *render-clip-b*) (with-metrics (nil nil "(funcall renderer)" self) (ix-paint target)))

1 0

[cells-cvs] CVS update: cell-cultures/config.lisp cell-cultures/build.lisp cell-cultures/cello-config.lisp
by Kenny Tilton 04 Jul '04

04 Jul '04

Update of /project/cells/cvsroot/cell-cultures In directory common-lisp.net:/tmp/cvs-serv5472 Modified Files: build.lisp cello-config.lisp Added Files: config.lisp Log Message: Date: Sun Jul 4 11:59:40 2004 Author: ktilton Index: cell-cultures/build.lisp diff -u cell-cultures/build.lisp:1.1 cell-cultures/build.lisp:1.2 --- cell-cultures/build.lisp:1.1 Sat Jun 26 11:38:32 2004 +++ cell-cultures/build.lisp Sun Jul 4 11:59:39 2004 @@ -25,12 +25,15 @@ :type "lisp") *devel-root*)) +;;; --- teach ASDF about LPR files +(let ((d-force t)) + (build-sys d-force "asdf-aclproj")) #-allegro-ide (let ((d-force t)) (pushnew :cells-testing *features*) - (build-sys d-force "cello" "cells") - (build-sys d-force "cello" "cells" "cells-test")) + (build-sys d-force "cells") + (build-sys d-force "cells" "cells-test")) #-allegro-ide (let ((d-force nil)) Index: cell-cultures/cello-config.lisp diff -u cell-cultures/cello-config.lisp:1.1 cell-cultures/cello-config.lisp:1.2 --- cell-cultures/cello-config.lisp:1.1 Sat Jun 26 11:38:32 2004 +++ cell-cultures/cello-config.lisp Sun Jul 4 11:59:39 2004 @@ -1,9 +1,5 @@ (in-package :cl-user) -(defparameter *devel-root* - (make-pathname #+lispworks :host #-lispworks :device "c" - :directory `(:absolute "dvl"))) - (defparameter *cello-directory* (merge-pathnames (make-pathname :directory `(:relative "cello"))

1 0

[cells-cvs] CVS update: cell-cultures/cells/cells-test.asd
by Thomas F. Burdick 01 Jul '04

01 Jul '04

Update of /project/cells/cvsroot/cell-cultures/cells In directory common-lisp.net:/tmp/cvs-serv23904/cells Modified Files: cells-test.asd Log Message: Last fixes, Cells-2 works in SBCL and CMUCL now. Date: Wed Jun 30 20:48:54 2004 Author: tburdick Index: cell-cultures/cells/cells-test.asd diff -u cell-cultures/cells/cells-test.asd:1.2 cell-cultures/cells/cells-test.asd:1.3 --- cell-cultures/cells/cells-test.asd:1.2 Wed Jun 30 13:56:36 2004 +++ cell-cultures/cells/cells-test.asd Wed Jun 30 20:48:54 2004 @@ -1,8 +1,5 @@ ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;(declaim (optimize (debug 2) (speed 1) (safety 1) (compilation-speed 1))) -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) - (operate 'load-op :asdf-aclproj) (use-package :asdf-aclproj)

1 0

[cells-cvs] CVS update: cell-cultures/cells/cells-test/person.lisp cell-cultures/cells/cells-test/test.lisp
by Thomas F. Burdick 01 Jul '04

01 Jul '04

Update of /project/cells/cvsroot/cell-cultures/cells/cells-test In directory common-lisp.net:/tmp/cvs-serv23904/cells/cells-test Modified Files: person.lisp test.lisp Log Message: Last fixes, Cells-2 works in SBCL and CMUCL now. Date: Wed Jun 30 20:48:54 2004 Author: tburdick Index: cell-cultures/cells/cells-test/person.lisp diff -u cell-cultures/cells/cells-test/person.lisp:1.1 cell-cultures/cells/cells-test/person.lisp:1.2 --- cell-cultures/cells/cells-test/person.lisp:1.1 Sat Jun 26 11:38:37 2004 +++ cell-cultures/cells/cells-test/person.lisp Wed Jun 30 20:48:54 2004 @@ -67,7 +67,7 @@ (cv-test-person-3) (cv-test-person-4) (cv-test-person-5) - (cv-test-talker) + ;; (cv-test-talker) ) (defun cv-test-person-1 () @@ -269,6 +269,7 @@ (setf *stop* nil) t)))) +#+(or) ; FIXME: this test is borked (defun cv-test-talker () ;; ;; make sure cyclic setf is trapped Index: cell-cultures/cells/cells-test/test.lisp diff -u cell-cultures/cells/cells-test/test.lisp:1.1 cell-cultures/cells/cells-test/test.lisp:1.2 --- cell-cultures/cells/cells-test/test.lisp:1.1 Sat Jun 26 11:38:37 2004 +++ cell-cultures/cells/cells-test/test.lisp Wed Jun 30 20:48:54 2004 @@ -30,7 +30,7 @@ (assert ,form ,places ,datum ,@(or args (list `',form))) (format t "~&ok: ~a~&" ',form)))) -(defun testing () +(eval-when (:load-toplevel :compile-toplevel :execute) (pushnew :cells-testing *features*)) (defvar *failed-tests* ())

1 0

[cells-cvs] CVS update: cell-cultures/asdf-aclproj/asdf-aclproj.lisp
by Thomas F. Burdick 01 Jul '04

01 Jul '04

Update of /project/cells/cvsroot/cell-cultures/asdf-aclproj In directory common-lisp.net:/tmp/cvs-serv23904/asdf-aclproj Modified Files: asdf-aclproj.lisp Log Message: Last fixes, Cells-2 works in SBCL and CMUCL now. Date: Wed Jun 30 20:48:54 2004 Author: tburdick Index: cell-cultures/asdf-aclproj/asdf-aclproj.lisp diff -u cell-cultures/asdf-aclproj/asdf-aclproj.lisp:1.2 cell-cultures/asdf-aclproj/asdf-aclproj.lisp:1.3 --- cell-cultures/asdf-aclproj/asdf-aclproj.lisp:1.2 Wed Jun 30 14:02:47 2004 +++ cell-cultures/asdf-aclproj/asdf-aclproj.lisp Wed Jun 30 20:48:54 2004 @@ -31,7 +31,10 @@ (defpackage :asdf-aclproj-user (:use :cl) (:import-from :asdf-aclproj - define-project project module project-module)) + asdf-aclproj::define-project + asdf-aclproj::project + asdf-aclproj::module + asdf-aclproj::project-module)) ;;; ;;; Classes for ASDF @@ -155,10 +158,11 @@ (loop with so-far = () for component in list for depends-on = (reverse so-far) - do (setf (slot-value component 'asdf::in-order-to) + do (setf (slot-value component 'asdf::do-first) + `((asdf:compile-op (asdf:load-op ,@depends-on))) + (slot-value component 'asdf::in-order-to) `((asdf:load-op (asdf:load-op ,@depends-on)) - (asdf:compile-op (asdf:load-op ,@depends-on) - (asdf:compile-op ,@depends-on)))) + (asdf:compile-op (asdf:compile-op ,@depends-on)))) (push component so-far) finally (return (reverse so-far))))) (setf *project-modules*

1 0