Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Some interesting changes

  • Loading branch information...
commit 3b95fb755f18511ef5072e5de859a2518e5fc593 1 parent 87deb17
ktilton authored
View
4 cell-types.lisp
@@ -87,9 +87,7 @@ See the Lisp Lesser GNU Public License for more details.
(defun caller-drop (used caller)
(fifo-delete (c-caller-store used) caller))
-;;;(defmethod trcp ((c cell))
-;;; (and (typep (c-model c) 'index)
-;;; (find (c-slot-name c) '(mathx::line-breaks mathx::phrases))))
+
; --- ephemerality --------------------------------------------------
;
View
4 cells.lisp
@@ -17,7 +17,7 @@ See the Lisp Lesser GNU Public License for more details.
|#
(eval-when (compile load)
- (proclaim '(optimize (speed 2) (safety 3) (space 1) (debug 3))))
+ (proclaim '(optimize (speed 2) (safety 1) (space 1) (debug 3))))
(in-package :cells)
@@ -79,7 +79,7 @@ See the Lisp Lesser GNU Public License for more details.
`(call-without-c-dependency (lambda () ,@body)))
(defun call-without-c-dependency (fn)
- (let (*call-stack*); *no-tell*)
+ (let (*call-stack*)
(funcall fn)))
(export! .cause)
View
2  cells.lpr
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (Dec 9, 2006 20:44)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (Jan 22, 2007 8:01)"; cg: "1.81"; -*-
(in-package :cg-user)
View
7 constructors.lisp
@@ -26,10 +26,13 @@ See the Lisp Lesser GNU Public License for more details.
(defmacro c-lambda (&body body)
`(c-lambda-var (slot-c) ,@body))
+(export! .cache-bound-p)
+
(defmacro c-lambda-var ((c) &body body)
`(lambda (,c &aux (self (c-model ,c))
- (.cache (c-value ,c)))
- (declare (ignorable .cache self))
+ (.cache (c-value ,c))
+ (.cache-bound-p (cache-bound-p ,c)))
+ (declare (ignorable .cache .cache-bound-p self))
,@body))
(defmacro with-c-cache ((fn) &body body)
View
3  family.lisp
@@ -39,7 +39,8 @@ See the Lisp Lesser GNU Public License for more details.
(defmethod print-object ((self model) s)
#+shhh (format s "~a" (type-of self))
- (format s "~a" (or (md-name self) (type-of self))))
+ (format s "~a~a" (if (mdead self) "DEAD!" "")
+ (or (md-name self) (type-of self))))
(define-symbol-macro .parent (fm-parent self))
View
15 fm-utilities.lisp
@@ -44,7 +44,7 @@ See the Lisp Lesser GNU Public License for more details.
(defmacro upper (self &optional (type t))
`(container-typed ,self ',type))
-(export! u^)
+(export! u^ fm-descendant-if)
(defmacro u^ (type)
`(upper self ,type))
@@ -93,6 +93,13 @@ See the Lisp Lesser GNU Public License for more details.
self)
(fm-ascendant-if .parent if-function))))
+(defun fm-descendant-if (self test)
+ (when (and self test)
+ (or (when (funcall test self)
+ self)
+ (loop for k in (^kids)
+ thereis (fm-descendant-if k test)))))
+
(defun fm-ascendant-common (d1 d2)
(fm-ascendant-some d1 (lambda (node)
(when (fm-includes node d2)
@@ -440,11 +447,11 @@ See the Lisp Lesser GNU Public License for more details.
:must-find t
:global-search global-search))
-(defmacro fm^ (md-name &key (skip-tree 'self))
+(defmacro fm^ (md-name &key (skip-tree 'self) (must-find t))
`(without-c-dependency
(fm-find-one (fm-parent self) ,md-name
:skip-tree ,skip-tree
- :must-find t
+ :must-find ,must-find
:global-search t)))
(defmacro fm^v (id)
@@ -494,7 +501,7 @@ See the Lisp Lesser GNU Public License for more details.
:must-find nil
:global-search ,global-search)))
;---------------------------------------------------------------
-
+(export! fm-top)
(defun fm-top (fm &optional (test #'true-that) &aux (fm-parent (fm-parent fm)))
(cond ((null fm-parent) fm)
((not (funcall test fm-parent)) fm)
View
2  gui-geometry/gui-geometry.lpr
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (Nov 6, 2006 16:43)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (Jan 22, 2007 8:01)"; cg: "1.81"; -*-
(in-package :cg-user)
View
5 integrity.lisp
@@ -84,7 +84,7 @@ See the Lisp Lesser GNU Public License for more details.
(defun just-do-it (op-or-q &aux (q (if (keywordp op-or-q)
(ufb-queue op-or-q)
op-or-q)))
- (trc nil "just do it doing" op-or-q)
+ (trc nil "----------------------------just do it doing---------------------" op-or-q)
(loop for (defer-info . task) = (fifo-pop q)
while task
do (trc nil "unfin task is" opcode task)
@@ -165,7 +165,7 @@ See the Lisp Lesser GNU Public License for more details.
(bwhen (task-info (fifo-pop (ufb-queue :change)))
(trc nil "!!! finbiz --- CHANGE ---- (first of)" (fifo-length (ufb-queue :change)))
(destructuring-bind (defer-info . task-fn) task-info
- (trc nil "finbiz: deferred state change" defer-info)
+ (trc nil "finbiz: deferred state change" defer-info)
(data-pulse-next (list :finbiz defer-info))
(funcall task-fn :change defer-info)
;
@@ -178,3 +178,4 @@ See the Lisp Lesser GNU Public License for more details.
;
(go tell-dependents)))))
+
View
12 link.lisp
@@ -18,21 +18,11 @@ See the Lisp Lesser GNU Public License for more details.
(in-package :cells)
-#+(or)
-(eval-when (compile load)
- (proclaim '(optimize (speed 3) (safety 0) (space 0) (debug 0))))
-
-
(defun record-caller (used &aux (caller (car *call-stack*)))
(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)
(return-from record-caller nil))
(trc nil "record-caller entry: used=" used :caller caller)
-;;; (when (trcp caller)
-;;;
-;;; ;;(when (eq (c-slot-name caller) 'mathx::phrases)
-;;; (when (eq (c-slot-name used) 'mathx::opnds)
-;;; (break "bingo")))
(multiple-value-bind (used-pos useds-len)
(loop with u-pos
@@ -121,7 +111,7 @@ See the Lisp Lesser GNU Public License for more details.
;----------------------------------------------------------
(defun c-unlink-caller (used caller)
- (trc caller "(1) caller unlinking from (2) used" caller used)
+ (trc nil "(1) caller unlinking from (2) used" caller used)
(caller-drop used caller)
(c-unlink-used caller used))
View
28 md-slot-value.lisp
@@ -21,6 +21,9 @@ See the Lisp Lesser GNU Public License for more details.
(defparameter *ide-app-hard-to-kill* t)
(defun md-slot-value (self slot-name &aux (c (md-slot-cell self slot-name)))
+ (when (mdead self)
+ (trc "md-slot-value passed dead self, returning NIL" self)
+ (return-from md-slot-value nil))
(tagbody
retry
(when *stop*
@@ -55,6 +58,12 @@ See the Lisp Lesser GNU Public License for more details.
(when (eq :eternal-rest (md-state s))
(break "model ~a is dead at ~a" s key)))
+;;;(defmethod trcp ((c cell))
+;;; (and *dbg*
+;;; (case (c-slot-name c)
+;;; (mathx::show-time t)
+;;; (ctk::app-time t))))
+
(defun ensure-value-is-current (c debug-id ensurer)
;
; ensurer can be used cell propagating to callers, or an existing caller who wants to make sure
@@ -69,7 +78,7 @@ See the Lisp Lesser GNU Public License for more details.
(cond
((c-currentp c)
- (trc c "c-currentp" c)) ;; used to follow c-inputp, but I am toying with letting ephemerals (inputs) fall obsolete
+ (trc nil "c-currentp" c)) ;; used to follow c-inputp, but I am toying with letting ephemerals (inputs) fall obsolete
;; and then get reset here (ie, ((c-input-p c) (ephemeral-reset c))). ie, do not assume inputs are never obsolete
;;
((and (c-inputp c)
@@ -106,7 +115,12 @@ See the Lisp Lesser GNU Public License for more details.
(when (c-unboundp c)
(error 'unbound-cell :cell c :instance (c-model c) :name (c-slot-name c)))
- (c-value c))
+ (bwhen (v (c-value c))
+ (if (mdead v)
+ (progn
+ (trc "ensure-value not returning dead model object value" v)
+ nil)
+ v)))
(defun calculate-and-set (c)
(flet ((body ()
@@ -260,11 +274,17 @@ In brief, initialize ~0@*~a to (c-in ~2@*~s) instead of plain ~:*~s"
(unless (eq propagation-code :no-propagate)
(trc nil "md-slot-value-assume flagging as changed: prior state, value:" prior-state prior-value )
(setf (c-pulse-last-changed c) *data-pulse-id*)
- (c-propagate c prior-value (or (eq prior-state :valid)
- (eq prior-state :uncurrent)))) ;; until 06-02-13 was (not (eq prior-state :unbound))
+ (c-propagate c prior-value (cache-state-bound-p prior-state))) ;; until 06-02-13 was (not (eq prior-state :unbound))
absorbed-value)))
+(defun cache-bound-p (c)
+ (cache-state-bound-p (c-value-state c)))
+
+(defun cache-state-bound-p (value-state)
+ (or (eq value-state :valid)
+ (eq value-state :uncurrent)))
+
;---------- optimizing away cells whose dependents all turn out to be constant ----------------
;
View
45 md-utilities.lisp
@@ -27,29 +27,39 @@ See the Lisp Lesser GNU Public License for more details.
(defmethod md-release (other)
(declare (ignorable other)))
-(export! md-dead)
-(defun md-dead (SELF)
- (eq :eternal-rest (md-state SELF)))
+(export! mdead)
;___________________ birth / death__________________________________
-(defmethod not-to-be :around (self)
- (trc nil "not-to-be nailing")
- (c-assert (not (eq (md-state self) :eternal-rest)))
+(defgeneric mdead (self)
- (call-next-method)
+ (:method ((self model-object))
+ (eq :eternal-rest (md-state SELF)))
- (setf (fm-parent self) nil
- (md-state self) :eternal-rest)
+ (:method (self)
+ (declare (ignore self))
+ nil))
- (md-map-cells self nil
- (lambda (c)
- (c-assert (eq :quiesced (c-state c))))) ;; fails if user obstructs not-to-be with primary method (use :before etc)
+(defgeneric not-to-be (self)
- (trc nil "not-to-be cleared 2 fm-parent, eternal-rest" self))
+ (:method ((self model-object))
+ (md-quiesce self))
-(defmethod not-to-be ((self model-object))
- (trc nil "not to be!!!" self)
- (md-quiesce self))
+ (:method :around ((self model-object))
+ (declare (ignorable self))
+ (trc nil #+not (typep self '(or mathx::problem mathx::prb-solvers mathx::prb-solver))
+ "not-to-be nailing" self)
+ (c-assert (not (eq (md-state self) :eternal-rest)))
+
+ (call-next-method)
+
+ (setf (fm-parent self) nil
+ (md-state self) :eternal-rest)
+
+ (md-map-cells self nil
+ (lambda (c)
+ (c-assert (eq :quiesced (c-state c))))) ;; fails if user obstructs not-to-be with primary method (use :before etc)
+
+ (trc nil "not-to-be cleared 2 fm-parent, eternal-rest" self)))
(defun md-quiesce (self)
(trc nil "md-quiesce nailing cells" self (type-of self))
@@ -70,8 +80,7 @@ See the Lisp Lesser GNU Public License for more details.
(setf (c-state c) :quiesced) ;; 20061024 for debugging for now, might break some code tho
)))
-(defmethod not-to-be (other)
- other)
+
(defparameter *to-be-dbg* nil)
View
2  model-object.lisp
@@ -116,7 +116,7 @@ See the Lisp Lesser GNU Public License for more details.
(trc nil "md-awaken entry" self (md-state self))
(c-assert (eql :nascent (md-state self)))
(count-it :md-awaken)
- (count-it 'mdawaken)
+ ;(count-it 'mdawaken (type-of self))
; ---
View
41 propagate.lisp
@@ -46,7 +46,7 @@ See the Lisp Lesser GNU Public License for more details.
(defun c-pulse-update (c key)
(declare (ignorable key))
- (trc nil "c-pulse-update updating" *data-pulse-id* c key :prior-pulse (c-pulse c))
+ (trc nil "!!!!!!! c-pulse-update updating !!!!!!!!!!" *data-pulse-id* c key :prior-pulse (c-pulse c))
(assert (>= *data-pulse-id* (c-pulse c)) ()
"Current DP ~a not GE pulse ~a of cell ~a" *data-pulse-id* (c-pulse c) c)
(setf (c-pulse c) *data-pulse-id*))
@@ -59,7 +59,7 @@ See the Lisp Lesser GNU Public License for more details.
;
(defun c-propagate (c prior-value prior-value-supplied)
-
+
(count-it :c-propagate)
(when prior-value
(assert prior-value-supplied () "How can prior-value-supplied be nil if prior-value is not?!! ~a" c))
@@ -67,13 +67,13 @@ See the Lisp Lesser GNU Public License for more details.
(*c-prop-depth* (1+ *c-prop-depth*))
(*defer-changes* t))
(trc nil "c-propagate clearing *call-stack*" c)
-
+
;------ debug stuff ---------
;
(when *stop*
(princ #\.)(princ #\!)
(return-from c-propagate))
- (trc c "c-propagate> !!!!!!! propping" c (c-value c) :caller-ct (length (c-callers c)) c)
+ (trc nil "c-propagate> !!!!!!! propping" c (c-value c) :caller-ct (length (c-callers c)))
(trc nil "c-propagate> !!!! new value" (c-value c) :prior-value prior-value :caller-ct (length (c-callers c)) c)
(when *c-debug*
(when (> *c-prop-depth* 250)
@@ -97,10 +97,10 @@ See the Lisp Lesser GNU Public License for more details.
(flet ((listify (x) (if (listp x) x (list x))))
(bIf (lost (set-difference (listify prior-value) (listify (c-value c))))
(progn
- (trc nil "prop nailing owned" c :lost lost :leaving (c-value c))
+ (trc nil "prop nailing owned!!!!!!!!!!!" c :lost lost :leaving (c-value c))
(mapcar 'not-to-be lost))
(trc nil "no owned lost!!!!!"))))
-
+
; propagation to callers jumps back in front of client slot-value-observe handling in cells3
; because model adopting (once done by the kids change handler) can now be done in
; shared-initialize (since one is now forced to supply the parent to make-instance).
@@ -111,10 +111,10 @@ See the Lisp Lesser GNU Public License for more details.
;
(unless nil #+not (member (c-lazy c) '(t :always :once-asked)) ;; 2006-09-26 still fuzzy on this
(c-propagate-to-callers c))
-
+
(slot-value-observe (c-slot-name c) (c-model c)
(c-value c) prior-value prior-value-supplied)
-
+
;
; with propagation done, ephemerals can be reset. we also do this in c-awaken, so
@@ -185,21 +185,26 @@ See the Lisp Lesser GNU Public License for more details.
(and (c-lazy caller) ;; slight optimization
(member (c-lazy caller) '(t :always :once-asked))))
(c-callers c))
- (let ((causation (cons c *causation*)) ;; in case deferred
- )
- (TRC c "c-propagate-to-callers > queueing notifying callers" (mapcar 'c-slot-name (c-callers c)))
+ (let ((causation (cons c *causation*))) ;; in case deferred
+ (TRC nil "c-propagate-to-callers > queueing notifying callers" (c-callers c))
(with-integrity (:tell-dependents c)
(assert (null *call-stack*))
(let ((*causation* causation))
- (trc c "c-propagate-to-callers > actually notifying callers of" c (mapcar 'c-slot-name (c-callers c)))
- (dolist (caller (c-callers c))
- (assert (find c (cd-useds caller)) () "test 1 failed ~a ~a" c caller))
-
- (dolist (caller (c-callers c)) ;; following code may modify c-callers list...
+ (trc nil "c-propagate-to-callers > actually notifying callers of" c (c-callers c))
+ #+c-debug (dolist (caller (c-callers c))
+ (assert (find c (cd-useds caller)) () "test 1 failed ~a ~a" c caller))
+ (dolist (caller (copy-list (c-callers c))) ;; following code may modify c-callers list...
+ (trc nil "PRE-prop-CHECK " c :caller caller (c-state caller) (c-lazy caller))
+ (unless (or (eq (c-state caller) :quiesced) ;; ..so watch for quiesced
+ (member (c-lazy caller) '(t :always :once-asked)))
+ (assert (find c (cd-useds caller))() "Precheck Caller ~a of ~a does not have it as used" caller c)
+ ))
+ (dolist (caller (progn #+not copy-list (c-callers c))) ;; following code may modify c-callers list...
+ (trc nil "propagating to caller iterates" c :caller caller (c-state caller) (c-lazy caller))
(unless (or (eq (c-state caller) :quiesced) ;; ..so watch for quiesced
(member (c-lazy caller) '(t :always :once-asked)))
- (assert (find c (cd-useds caller)))
- (trc caller "propagating to caller is caller:" caller)
+ (assert (find c (cd-useds caller))() "Caller ~a of ~a does not have it as used" caller c)
+ (trc nil "propagating to caller is used" c :caller caller)
(ensure-value-is-current caller :prop-from c))))))))
View
2  slot-utilities.lisp
@@ -36,7 +36,7 @@ See the Lisp Lesser GNU Public License for more details.
;; cv-test handles errors, so don't set *stop* (c-stop)
(c-break "unadopted ~a for self ~a spec ~a" c self slot-name)
(error 'c-unadopted :cell c))
- (typecase c
+ #+whocares (typecase c
(c-dependent
;(trc "setting c-dependent" c newvalue)
(format t "c-setting-debug > ruled ~a in ~a may not be setf'ed"
View
4 trc-eko.lisp
@@ -52,9 +52,9 @@ See the Lisp Lesser GNU Public License for more details.
(if (eql tgt-form 'nil)
'(progn)
`(without-c-dependency
- (call-trc t ,(format nil "TX> ~(~a~)" tgt-form)
+ (call-trc t ,(format nil "TX> ~(~s~)" tgt-form)
,@(loop for obj in os
- nconcing (list (format nil "~a:" obj) obj))))))
+ nconcing (list (intern (format nil "~a" obj) :keyword) obj))))))
(defparameter *last-trc* (get-internal-real-time))
View
6 utils-kt/debug.lisp
@@ -30,6 +30,7 @@ See the Lisp Lesser GNU Public License for more details.
(setf *count* nil
*stop* nil
*dbg* nil)
+
(print "----------UTILSRESET----------------------------------"))
@@ -93,9 +94,10 @@ See the Lisp Lesser GNU Public License for more details.
(defmacro timex ((onp &rest trcargs) &body body)
`(if ,onp
- (prog1
+ (prog2
+ (format t "~&Starting timing run of ~{ ~a~}" (list ,@trcargs))
(time (progn ,@body))
- (format t "timing was of ~{ ~a~}" ,@trcargs))
+ (format t "~&Above timing was of ~{ ~a~}" (list ,@trcargs)))
(progn ,@body)))
#+save
View
9 utils-kt/detritus.lisp
@@ -170,16 +170,15 @@ See the Lisp Lesser GNU Public License for more details.
(typecase tree
(null)
(atom (funcall test sought tree))
- (cons (loop for subtree in tree
- when (tree-includes sought subtree :test test)
- do (return-from tree-includes t)))))
+ (cons (or (tree-includes sought (car tree) :test test)
+ (tree-includes sought (cdr tree) :test test)))))
(defun tree-traverse (tree fn)
(typecase tree
(null)
(atom (funcall fn tree))
- (cons (loop for subtree in tree
- do (tree-traverse subtree fn))))
+ (cons (tree-traverse (car tree) fn)
+ (tree-traverse (cdr tree) fn)))
(values))
(defun tree-intersect (t1 t2 &key (test 'eql))
View
14 utils-kt/flow-control.lisp
@@ -31,7 +31,7 @@ See the Lisp Lesser GNU Public License for more details.
(defun min-if (v1 v2)
(if v1 (if v2 (min v1 v2) v1) v2))
-(export! list-flatten! tree-flatten list-insertf subseq-contiguous-p)
+(export! list-flatten! tree-flatten list-insertf subseq-contiguous-p pair-off)
(defun list-flatten! (&rest list)
(if (consp list)
@@ -59,6 +59,17 @@ See the Lisp Lesser GNU Public License for more details.
(defun tree-flatten (tree)
(list-flatten! (copy-tree tree)))
+(defun pair-off (list &optional (test 'eql))
+ (loop with pairs and copy = (copy-list list)
+ while (cdr copy)
+ do (let ((pair (find (car copy) (cdr copy) :test test)))
+ (if pair
+ (progn
+ (push-end (cons (car copy) pair) pairs)
+ (setf copy (delete pair (cdr copy) :count 1)))
+ (setf copy (cdr copy))))
+ finally (return pairs)))
+
(defun packed-flat! (&rest u-nameit)
(delete nil (list-flatten! u-nameit)))
@@ -173,6 +184,7 @@ See the Lisp Lesser GNU Public License for more details.
(export! without-repeating)
+
(let ((generators (make-hash-table :test 'equalp)))
(defun without-repeating (key all &optional (decent-interval (floor (length all) 2)))
(funcall (or (gethash key generators)
View
2  utils-kt/utils-kt.lpr
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (Nov 6, 2006 16:43)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (Jan 22, 2007 8:01)"; cg: "1.81"; -*-
(in-package :cg-user)
View
1  variables.lisp
@@ -60,6 +60,7 @@ See the Lisp Lesser GNU Public License for more details.
#+test
(def-c-variable *kenny* (c-in nil))
+
#+test
(defmd kenny-watcher ()
(twice (c? (bwhen (k *kenny*)
Please sign in to comment.
Something went wrong with that request. Please try again.