Update of /project/cells/cvsroot/cell-cultures/cells In directory common-lisp.net:/tmp/cvs-serv12564/cells
Modified Files: cells.lpr defpackage.lisp integrity.lisp md-slot-value.lisp test.lisp Log Message: Cello cleanup, but mostly "removing" ffi-extender, which really lives on as the "hello-c" package Date: Fri Apr 8 11:11:13 2005 Author: ktilton
Index: cell-cultures/cells/cells.lpr diff -u cell-cultures/cells/cells.lpr:1.2 cell-cultures/cells/cells.lpr:1.3 --- cell-cultures/cells/cells.lpr:1.2 Sun Jun 27 01:36:49 2004 +++ cell-cultures/cells/cells.lpr Fri Apr 8 11:11:12 2005 @@ -1,11 +1,10 @@ -;; -*- lisp-version: "6.2 [Windows] (May 12, 2004 22:13)"; common-graphics: "1.389.2.105.2.14"; -*- +;; -*- lisp-version: "7.0 [Windows] (Dec 28, 2004 17:34)"; cg: "1.54.2.17"; -*-
-(in-package :common-graphics-user) +(in-package :cg-user)
-(defpackage :cells (:export)) +(defpackage :CELLS)
(define-project :name :cells - :application-type (intern "Standard EXE" (find-package :keyword)) :modules (list (make-instance 'module :name "defpackage.lisp") (make-instance 'module :name "cells.lisp") (make-instance 'module :name "cell-types.lisp") @@ -30,28 +29,20 @@ "../utils-kt/utils-kt")) :libraries nil :distributed-files nil + :internally-loaded-files nil :project-package-name :cells :main-form nil :compilation-unit t :verbose nil - :runtime-modules '(:cg :drag-and-drop :lisp-widget - :multi-picture-button :common-control - :edit-in-place :outline :grid :group-box - :header-control :progress-indicator-control - :common-status-bar :tab-control :trackbar-control - :up-down-control :dde :mci :carets :hotspots - :menu-selection :choose-list :directory-list - :color-dialog :find-dialog :font-dialog - :string-dialog :yes-no-list-dialog - :list-view-control :rich-edit :drawable :ole :www - :aclwin302) + :runtime-modules nil :splash-file-module (make-instance 'build-module :name "") :icon-file-module (make-instance 'build-module :name "") - :include-flags '(:compiler :top-level :local-name-info) + :include-flags '(:local-name-info) :build-flags '(:allow-debug :purify) :autoload-warning t :full-recompile-for-runtime-conditionalizations nil :default-command-line-arguments "+cx +t "Initializing"" + :additional-build-lisp-image-arguments '(:read-init-files nil) :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard
Index: cell-cultures/cells/defpackage.lisp diff -u cell-cultures/cells/defpackage.lisp:1.7 cell-cultures/cells/defpackage.lisp:1.8 --- cell-cultures/cells/defpackage.lisp:1.7 Wed Nov 17 13:31:31 2004 +++ cell-cultures/cells/defpackage.lisp Fri Apr 8 11:11:12 2005 @@ -59,3 +59,4 @@ #+allegro (:shadowing-import-from #:excl #:fasl-write #:fasl-read #:gc) )
+
Index: cell-cultures/cells/integrity.lisp diff -u cell-cultures/cells/integrity.lisp:1.5 cell-cultures/cells/integrity.lisp:1.6 --- cell-cultures/cells/integrity.lisp:1.5 Mon Dec 6 21:26:06 2004 +++ cell-cultures/cells/integrity.lisp Fri Apr 8 11:11:12 2005 @@ -61,7 +61,7 @@ (defun ufb-add (opcode continuation) (fifo-add (ufb-queue opcode) continuation))
-(defconstant-once *ufb-opcodes* '(:user-notify :output :setf :makunbound :finalize)) +(defconstant *ufb-opcodes* '(:user-notify :output :setf :makunbound :finalize))
(define-condition c-opcode-deferred (c-enabling) ((defer-info :initarg :defer-info :reader defer-info)) @@ -76,6 +76,8 @@ (declare (ignorable debug-key)) (assert (or (null opcode) (member opcode *ufb-opcodes*))) (trc nil "call-with-integrity entry *unfinished-business*" *unfinished-business*) + (when *stop* + (return-from call-with-integrity)) (if *unfinished-business* (if defer-info (progn @@ -111,6 +113,7 @@ (tagbody notify-users ;--- notify users ------------------------------ + (when *stop* (return-from finish-business)) (let ((user-q-item (fifo-pop (ufb-queue :user-notify)))) (when user-q-item (destructuring-bind (defer-info . task) user-q-item @@ -122,6 +125,7 @@ (setf some-output nil)
next-output + (when *stop* (return-from finish-business)) ;--- do c-output-slot-name ----------------------- (setf task (cdr (fifo-pop (ufb-queue :output))))
Index: cell-cultures/cells/md-slot-value.lisp diff -u cell-cultures/cells/md-slot-value.lisp:1.5 cell-cultures/cells/md-slot-value.lisp:1.6 --- cell-cultures/cells/md-slot-value.lisp:1.5 Sun Dec 5 05:50:32 2004 +++ cell-cultures/cells/md-slot-value.lisp Fri Apr 8 11:11:12 2005 @@ -60,7 +60,7 @@ (some (lambda (used) (c-value-ensure-current used) (when (and (c-changed used) (> (c-pulse used)(c-pulse c))) - (trc nil "used changed" used :asker c + #+chya (trc nil "used changed" used :asker c :inpulse ip :pulse *data-pulse-id*) t)) (c-useds c)))) @@ -68,33 +68,32 @@ (defun c-calculate-and-set (c) (flet ((body () (when (c-stopped) - (princ #.) - (return-from c-calculate-and-set)) + (princ #.) + (return-from c-calculate-and-set))
- (when (find c *c-calculators*) ;; circularity - (trc "c-calculate-and-set breaking on circularity" c) - (c-break ;; break is problem when testing cells on some CLs - "cell ~a midst askers: ~a" c *c-calculators*)) + (when (find c *c-calculators*) ;; circularity + (trc "c-calculate-and-set breaking on circularity" c) + (c-break ;; break is problem when testing cells on some CLs + "cell ~a midst askers: ~a" c *c-calculators*))
- (count-it :c-calculate-and-set) - ;;; (count-it :c-calculate-and-set (type-of (c-model c))) ;; (c-slot-name c)) + (count-it :c-calculate-and-set) + ;;; (count-it :c-calculate-and-set (type-of (c-model c))) ;; (c-slot-name c))
- (cd-usage-clear-all c) + (cd-usage-clear-all c)
- (let ((raw-value - (progn - (let ((*c-calculators* (cons c *c-calculators*))) - (trc nil "c-calculate-and-set> new *c-calculators*:" - *c-calculators*) - (c-assert (c-model c)) - (funcall (cr-rule c) c))))) - (progn ;; unless (cmdead c) ;; eg, rule includes (nsib), then parent decides (c-model c) is no more - (when (and *c-debug* (typep raw-value 'cell)) - (c-break "new value for cell ~s is itself a cell: ~s. probably nested (c? ... (c? ))" - c raw-value)) + (let ((raw-value + (progn + (let ((*c-calculators* (cons c *c-calculators*))) + (trc nil "c-calculate-and-set> new *c-calculators*:" + *c-calculators*) + (c-assert (c-model c)) + (funcall (cr-rule c) c))))) + (when (and *c-debug* (typep raw-value 'cell)) + (c-break "new value for cell ~s is itself a cell: ~s. probably nested (c? ... (c? ))" + c raw-value))
- (c-unlink-unused c) - (md-slot-value-assume c raw-value))))) + (c-unlink-unused c) + (md-slot-value-assume c raw-value)))) (if nil ;; *dbg* (ukt::wtrc (0 100 "calcnset" c) (body))(body))))
@@ -165,12 +164,10 @@
(defmethod md-slot-value-assume (c raw-value) (assert c) - (trc nil "md-slot-value-assume entry:" c raw-value) (bif (c-pos (position c *causation*)) (bif (cyclic-pos (position-if 'c-cyclicp *causation* :end c-pos)) - (progn ;; let ((cc (nth cyclic-pos *causation*))) + (progn (c-pulse-update c :cyclicity-0) - (trc nil "!!!!!!!! cyclicity handled" c cc) (return-from md-slot-value-assume raw-value)) (c-break "md-slot-value-assume looping ~a ~a" c *causation*)))
Index: cell-cultures/cells/test.lisp diff -u cell-cultures/cells/test.lisp:1.1 cell-cultures/cells/test.lisp:1.2 --- cell-cultures/cells/test.lisp:1.1 Sat Jun 26 20:38:36 2004 +++ cell-cultures/cells/test.lisp Fri Apr 8 11:11:12 2005 @@ -36,6 +36,9 @@
(defparameter *cell-tests* nil)
+#+go +(test-cells) + (defun test-cells () (loop for test in (reverse *cell-tests*) do (cell-test-init test)