[cells-cvs] CVS update: cell-cultures/cells/cells.lpr cell-cultures/cells/defpackage.lisp cell-cultures/cells/integrity.lisp cell-cultures/cells/md-slot-value.lisp cell-cultures/cells/test.lisp
Kenny Tilton
ktilton at common-lisp.net
Fri Apr 8 09:11:17 UTC 2005
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)
More information about the Cells-cvs
mailing list