Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

*** empty log message ***

  • Loading branch information...
commit 8449356c94ed54f8b55db79ed97a6824e0d9ec0d 1 parent 5c69adf
ktilton authored
5 cell-types.lisp
@@ -66,8 +66,9 @@ See the Lisp Lesser GNU Public License for more details.
66 66 (call-next-method)
67 67 (progn
68 68 (c-print-value c stream)
69   - (format stream "=~d/~a/~a]"
  69 + (format stream "=~d/~a/~a/~a]"
70 70 (c-pulse c)
  71 + (c-state c)
71 72 (symbol-name (or (c-slot-name c) :anoncell))
72 73 (print-cell-model (c-model c))))))))
73 74
@@ -92,8 +93,6 @@ See the Lisp Lesser GNU Public License for more details.
92 93 (defun caller-drop (used caller)
93 94 (fifo-delete (c-caller-store used) caller))
94 95
95   -
96   -
97 96 ; --- ephemerality --------------------------------------------------
98 97 ;
99 98 ; Not a type, but an option to the :cell parameter of defmodel
15 cells.lisp
@@ -54,6 +54,7 @@ See the Lisp Lesser GNU Public License for more details.
54 54
55 55 (defun c-stop (&optional why)
56 56 (setf *stop* t)
  57 + (print `(c-stop-entry ,why))
57 58 (format t "~&C-STOP> stopping because ~a" why) )
58 59
59 60 (define-symbol-macro .stop
@@ -151,13 +152,11 @@ See the Lisp Lesser GNU Public License for more details.
151 152
152 153 (defun c-break (&rest args)
153 154 (unless *stop*
154   - (let ((*print-level* 3)
  155 + (let ((*print-level* 5)
155 156 (*print-circle* t)
156   - )
  157 + (args2 (mapcar 'princ-to-string args)))
157 158 (c-stop args)
158   - (format t "c-break > stopping > ~a" args)
159   - (apply 'error args))))
160   -
161   -
162   -
163   -
  159 +
  160 + (format t "~&c-break > stopping > ~{~a ~}" args2)
  161 + (print `(c-break-args ,@args2))
  162 + (apply 'error args2))))
3  fm-utilities.lisp
@@ -33,7 +33,8 @@ See the Lisp Lesser GNU Public License for more details.
33 33 (apply #'make-instance part-class (append initargs (list :md-name partname)))))
34 34
35 35 (defmacro mk-part (md-name (md-class) &rest initargs)
36   - `(make-part ',md-name ',md-class ,@initargs))
  36 + `(make-part ',md-name ',md-class ,@initargs
  37 + :fm-parent (progn (assert self) self)))
37 38
38 39 (defmethod make-part-spec ((part-class symbol))
39 40 (make-part part-class part-class))
3  gui-geometry/defpackage.lisp
@@ -19,7 +19,8 @@ See the Lisp Lesser GNU Public License for more details.
19 19 (:use #:common-lisp #:utils-kt #:cells)
20 20 (:export #:geometer #:geo-zero-tl #:geo-inline #:a-stack #:a-row
21 21 #:px #:py #:ll #:lt #:lr #:lb #:pl #:pt #:pr #:pb
22   - #:^px #:^py #:^ll #:^lt #:^lr #:^lb
  22 + #:^px #:^py #:^ll #:^lt #:^lr #:^lb #:^lb-height
  23 + #:^fill-parent-down
23 24 #:u96ths #:udots #:uinches #:uin #:upoints #:upts #:u8ths #:u16ths #:u32nds
24 25 #:mkr #:v2-nmove #:l-height #:mkv2 #:^offset-within #:inset-lr #:v2-v #:v2-h
25 26 #:r-bounds #:l-box
4 link.lisp
@@ -23,7 +23,9 @@ See the Lisp Lesser GNU Public License for more details.
51 md-slot-value.lisp
@@ -23,6 +23,8 @@ See the Lisp Lesser GNU Public License for more details.
23 23 (defun md-slot-value (self slot-name &aux (c (md-slot-cell self slot-name)))
24 24 (when (mdead self)
25 25 (trc "md-slot-value passed dead self, returning NIL" self)
  26 + (inspect self)
  27 + (break "see inspector for dead ~a" self)
26 28 (return-from md-slot-value nil))
27 29 (tagbody
28 30 retry
@@ -73,7 +75,7 @@ See the Lisp Lesser GNU Public License for more details.
73 75 ;
74 76 (declare (ignorable debug-id ensurer))
75 77 (count-it :ensure-value-is-current)
76   - (trc nil "ensure-value-is-current > entry" c :now-pulse *data-pulse-id* debug-id ensurer)
  78 + ;; (trc c "ensure-value-is-current > entry" c (c-state c) :now-pulse *data-pulse-id* debug-id ensurer)
77 79
78 80 (when (and (not (symbolp (c-model c)))(eq :eternal-rest (md-state (c-model c))))
79 81 (break "model ~a of cell ~a is dead" (c-model c) c))
@@ -110,14 +112,15 @@ See the Lisp Lesser GNU Public License for more details.
110 112 t))))))
111 113 (assert (typep c 'c-dependent))
112 114 (check-reversed (cd-useds c))))
113   - #+slow (trc c "kicking off calc-set of" (c-validp c) (c-slot-name c) :vstate (c-value-state c)
  115 + #+shhh (trc c "kicking off calc-set of" (c-state c) (c-validp c) (c-slot-name c) :vstate (c-value-state c)
114 116 :stamped (c-pulse c) :current-pulse *data-pulse-id*)
115 117 (calculate-and-set c))
116 118
117 119 ((mdead (c-value c))
118   - (trc "ensure-value-is-current> trying recalc of ~a with current but dead value ~a" c (c-value c))
  120 + (trc nil "ensure-value-is-current> trying recalc of ~a with current but dead value ~a" c (c-value c))
119 121 (let ((new-v (calculate-and-set c)))
120   - (trc "ensure-value-is-current> GOT new value ~a" new-v)))
  122 + (trc nil "ensure-value-is-current> GOT new value ~a to replace dead!!" new-v)
  123 + new-v))
121 124
122 125 (t (trc nil "ensuring current decided current, updating pulse" (c-slot-name c) debug-id)
123 126 (c-pulse-update c :valid-uninfluenced)))
@@ -128,7 +131,7 @@ See the Lisp Lesser GNU Public License for more details.
128 131 (bwhen (v (c-value c))
129 132 (if (mdead v)
130 133 (progn
131   - (brk "ensure-value still got and still not returning ~a dead value ~a" c v)
  134 + (brk "on pulse ~a ensure-value still got and still not returning ~a dead value ~a" *data-pulse-id* c v)
132 135 nil)
133 136 v)))
134 137
@@ -162,8 +165,14 @@ See the Lisp Lesser GNU Public License for more details.
162 165 (c-break "new value for cell ~s is itself a cell: ~s. probably nested (c? ... (c? ))"
163 166 c raw-value))
164 167
165   - (md-slot-value-assume c raw-value propagation-code))))
166   - (if nil ;; *dbg*
  168 + (unless (c-optimized-away-p c)
  169 + ; this check for optimized-away-p arose because a rule using without-c-dependency
  170 + ; can be re-entered unnoticed since that clears *call-stack*. If re-entered, a subsequent
  171 + ; re-exit will be of an optimized away cell, which we need not sv-assume on... a better
  172 + ; fix might be a less cutesy way of doing without-c-dependency, and I think anyway
  173 + ; it would be good to lose the re-entrance.
  174 + (md-slot-value-assume c raw-value propagation-code)))))
  175 + (if (trcp c) ;; *dbg*
167 176 (wtrc (0 100 "calcnset" c) (body))
168 177 (body))))
169 178
@@ -171,7 +180,7 @@ See the Lisp Lesser GNU Public License for more details.
171 180 (let ((*call-stack* (cons c *call-stack*))
172 181 (*defer-changes* t))
173 182 (assert (typep c 'c-ruled))
174   - #+slow (trc *c-debug* "calculate-and-link" c)
  183 + #+shhh (trc c "calculate-and-link" c)
175 184 (cd-usage-clear-all c)
176 185 (multiple-value-prog1
177 186 (funcall (cr-rule c) c)
@@ -236,6 +245,7 @@ In brief, initialize ~0@*~a to (c-in ~2@*~s) instead of plain ~:*~s"
236 245 (md-slot-value-assume c new-value nil))
237 246
238 247 (*defer-changes*
  248 + (print `(cweird ,c ,(type-of c)))
239 249 (c-break "SETF of ~a must be deferred by wrapping code in WITH-INTEGRITY" c))
240 250
241 251 (t
@@ -250,6 +260,7 @@ In brief, initialize ~0@*~a to (c-in ~2@*~s) instead of plain ~:*~s"
250 260
251 261 (defmethod md-slot-value-assume (c raw-value propagation-code)
252 262 (assert c)
  263 + #+shhh (trc c "md-slot-value-assume entry" (c-state c))
253 264 (without-c-dependency
254 265 (let ((prior-state (c-value-state c))
255 266 (prior-value (c-value c))
@@ -266,9 +277,12 @@ In brief, initialize ~0@*~a to (c-in ~2@*~s) instead of plain ~:*~s"
266 277 (return-from md-slot-value-assume absorbed-value))
267 278
268 279 ; --- slot maintenance ---
  280 + (when (eq (c-state c) :optimized-away)
  281 + (break "bongo one ~a flush ~a" c (flushed? c)))
269 282 (unless (c-synaptic c)
270 283 (md-slot-value-store (c-model c) (c-slot-name c) absorbed-value))
271   -
  284 + (when (eq (c-state c) :optimized-away)
  285 + (break "bongo two ~a flush ~a" c (flushed? c)))
272 286 ; --- cell maintenance ---
273 287 (setf
274 288 (c-value c) absorbed-value
@@ -299,7 +313,11 @@ In brief, initialize ~0@*~a to (c-in ~2@*~s) instead of plain ~:*~s"
299 313 ;---------- optimizing away cells whose dependents all turn out to be constant ----------------
300 314 ;
301 315
  316 +(defun flushed? (c)
  317 + (rassoc c (cells-flushed (c-model c))))
  318 +
302 319 (defun c-optimize-away?! (c)
  320 + #+shhh (trc c "c-optimize-away?! entry" (c-state c) c)
303 321 (when (and (typep c 'c-dependent)
304 322 (null (cd-useds c))
305 323 (cd-optimize c)
@@ -309,21 +327,27 @@ In brief, initialize ~0@*~a to (c-in ~2@*~s) instead of plain ~:*~s"
309 327 (not (c-inputp c)) ;; yes, dependent cells can be inputp
310 328 )
311 329 ;; (when (trcp c) (break "go optimizing ~a" c))
312   - (trc nil "optimizing away" c (c-state c))
  330 +
  331 + #+shh (when (trcp c)
  332 + (trc "optimizing away" c (c-state c) (rassoc c (cells (c-model c)))(rassoc c (cells-flushed (c-model c))))
  333 + )
  334 +
313 335 (count-it :c-optimized)
314 336
315 337 (setf (c-state c) :optimized-away)
316 338
317 339 (let ((entry (rassoc c (cells (c-model c)))))
318 340 (unless entry
319   - (describe c))
  341 + (describe c)
  342 + (bwhen (fe (rassoc c (cells-flushed (c-model c))))
  343 + (trc "got in flushed thoi!" fe)))
320 344 (c-assert entry)
321   - (trc nil "c-optimize-away?! moving cell to flushed list" c)
  345 + ;(trc (eq (c-slot-name c) 'cgtk::id) "c-optimize-away?! moving cell to flushed list" c)
322 346 (setf (cells (c-model c)) (delete entry (cells (c-model c))))
323 347 #-its-alive! (push entry (cells-flushed (c-model c)))
324 348 )
325 349
326   - (dolist (caller (c-callers c))
  350 + (dolist (caller (c-callers c) )
327 351 ;
328 352 ; example: on window shutdown with a tool-tip displayed, the tool-tip generator got
329 353 ; kicked off and asked about the value of a dead instance. That returns nil, and
@@ -332,6 +356,7 @@ In brief, initialize ~0@*~a to (c-in ~2@*~s) instead of plain ~:*~s"
332 356 ; so we ended up here. where there used to be a break.
333 357 ;
334 358 (setf (cd-useds caller) (delete c (cd-useds caller)))
  359 + ;;; (trc "nested opti" c caller)
335 360 (c-optimize-away?! caller) ;; rare but it happens when rule says (or .cache ...)
336 361 )))
337 362
1  md-utilities.lisp
@@ -40,7 +40,6 @@ See the Lisp Lesser GNU Public License for more details.
40 40 nil))
41 41
42 42 (defgeneric not-to-be (self)
43   -
44 43 (:method ((self model-object))
45 44 (md-quiesce self))
46 45
13 model-object.lisp
@@ -106,6 +106,9 @@ See the Lisp Lesser GNU Public License for more details.
106 106 (when (eql :nascent (md-state self))
107 107 (call-next-method)))
108 108
  109 +#+test
  110 +(md-slot-cell-type 'cgtk::label 'cgtk::container)
  111 +
109 112 (defmethod md-awaken ((self model-object))
110 113 ;
111 114 ; --- debug stuff
@@ -123,7 +126,7 @@ See the Lisp Lesser GNU Public License for more details.
123 126 (setf (md-state self) :awakening)
124 127
125 128 (dolist (esd (class-slots (class-of self)))
126   - (when (md-slot-cell-type (type-of self) (slot-definition-name esd))
  129 + (bwhen (sct (md-slot-cell-type (type-of self) (slot-definition-name esd)))
127 130 (let* ((slot-name (slot-definition-name esd))
128 131 (c (md-slot-cell self slot-name)))
129 132 (when *c-debug*
@@ -146,6 +149,7 @@ See the Lisp Lesser GNU Public License for more details.
146 149 ;; until 2007-10 (unless (cdr (assoc slot-name (cells-flushed self))) ;; make sure not flushed
147 150 ;; but first I worried about it being slow keeping the flushed list /and/ searching, then
148 151 ;; I wondered why a flushed cell should not be observed, constant cells are. So Just Observe It
  152 +
149 153 (slot-value-observe slot-name self (bd-slot-value self slot-name) nil nil))
150 154
151 155
@@ -175,6 +179,9 @@ See the Lisp Lesser GNU Public License for more details.
175 179 (cdr (assoc slot-name (cells self)))
176 180 (get slot-name 'cell)))
177 181
  182 +#+test
  183 +(get 'cgtk::label :cell-types)
  184 +
178 185 (defun md-slot-cell-type (class-name slot-name)
179 186 (assert class-name)
180 187 (if (eq class-name 'null)
@@ -192,11 +199,11 @@ See the Lisp Lesser GNU Public License for more details.
192 199 (setf (get slot-name :cell-type) new-type)
193 200 (let ((entry (assoc slot-name (get class-name :cell-types))))
194 201 (if entry
195   - (progn
  202 + (prog1
196 203 (setf (cdr entry) new-type)
197 204 (loop for c in (class-direct-subclasses (find-class class-name))
198 205 do (setf (md-slot-cell-type (class-name c) slot-name) new-type)))
199   - (push (cons slot-name new-type) (get class-name :cell-types))))))
  206 + (cdar (push (cons slot-name new-type) (get class-name :cell-types)))))))
200 207
201 208 (defun md-slot-owning (class-name slot-name)
202 209 (assert class-name)
2  synapse-types.lisp
@@ -36,7 +36,7 @@ See the Lisp Lesser GNU Public License for more details.
36 36 (defun call-f-sensitivity (synapse-id sensitivity subtypename body-fn)
37 37 (with-synapse synapse-id (prior-fire-value)
38 38 (let ((new-value (funcall body-fn)))
39   - (trc nil "f-sensitivity fire-p decides" prior-fire-value sensitivity)
  39 + ;(trc "f-sensitivity fire-p decides new" new-value :from-prior prior-fire-value :sensi sensitivity)
40 40 (let ((prop-code (if (or (xor prior-fire-value new-value)
41 41 (eko (nil "sens fire-p decides" new-value prior-fire-value sensitivity)
42 42 (delta-greater-or-equal
4 trc-eko.lisp
@@ -33,7 +33,7 @@ See the Lisp Lesser GNU Public License for more details.
33 33 `(without-c-dependency
34 34 (call-trc t ,tgt-form ,@os))
35 35 (let ((tgt (gensym)))
36   - ;(break "slowww? ~a" tgt-form)
  36 + (break "slowww? ~a" tgt-form)
37 37 `(without-c-dependency
38 38 (bif (,tgt ,tgt-form)
39 39 (if (trcp ,tgt)
@@ -64,7 +64,7 @@ See the Lisp Lesser GNU Public License for more details.
64 64 '(progn)
65 65 `(without-c-dependency
66 66 (call-trc t ,(format nil "TX> ~(~s~)" tgt-form)
67   - ,@(loop for obj in os
  67 + ,@(loop for obj in (or os (list tgt-form))
68 68 nconcing (list (intern (format nil "~a" obj) :keyword) obj))))))
69 69
70 70
3  utils-kt/debug.lisp
@@ -61,7 +61,8 @@ See the Lisp Lesser GNU Public License for more details.
61 61
62 62 (defun call-count-it (&rest keys)
63 63 (declare (ignorable keys))
64   - ;;; (when (eql :TGTNILEVAL (car keys))(break))
  64 + (when (find (car keys) '(:trcfailed :TGTNILEVAL))
  65 + (break "clean up time ~a" keys))
65 66 (let ((entry (assoc keys *count* :test #'equal)))
66 67 (if entry
67 68 (setf (cdr entry) (1+ (cdr entry)))
26 utils-kt/detritus.lisp
@@ -59,24 +59,28 @@ See the Lisp Lesser GNU Public License for more details.
59 59 (defun collect-if (test list)
60 60 (remove-if-not test list))
61 61
62   -#-iamnotkenny
63   -(defun test-setup ()
64   - #-its-alive!
  62 +(defun test-setup (&optional drib)
  63 + #-(or iamnotkenny its-alive!)
65 64 (ide.base::find-new-prompt-command
66   - (cg.base::find-window :listener-frame)))
  65 + (cg.base::find-window :listener-frame))
  66 + (when drib
  67 + (dribble (merge-pathnames
  68 + (make-pathname :name drib :type "TXT")
  69 + (project-path)))))
  70 +
  71 +(export! project-path)
  72 +(defun project-path ()
  73 + (excl:path-pathname (ide.base::project-file ide.base:*current-project*)))
67 74
68 75 #+test
69 76 (test-setup)
70 77
71   -#-iamnotkenny
72   -(defun test-prep ()
73   - (test-setup))
  78 +(defun test-prep (&optional drib)
  79 + (test-setup drib))
74 80
75   -#-iamnotkenny
76   -(defun test-init ()
77   - (test-setup))
  81 +(defun test-init (&optional drib)
  82 + (test-setup drib))
78 83
79   -#-iamnotkenny
80 84 (export! test-setup test-prep test-init)
81 85
82 86 ;;; --- FIFO Queue -----------------------------
21 utils-kt/flow-control.lisp
@@ -124,6 +124,27 @@ See the Lisp Lesser GNU Public License for more details.
124 124 `(loop for ,nvar below ,count
125 125 collecting (progn ,@body)))
126 126
  127 +(export! maphash* hashtable-assoc -1?1 -1?1 prime?)
  128 +
  129 +(defun maphash* (f h)
  130 + (loop for k being the hash-keys of h
  131 + using (hash-value v)
  132 + collecting (funcall f k v)))
  133 +
  134 +(defun hashtable-assoc (h)
  135 + (maphash* (lambda (k v) (cons k v)) h))
  136 +
  137 +(define-symbol-macro -1?1 (expt -1 (random 2)))
  138 +
  139 +(defun -1?1 (x) (* -1?1 x))
  140 +
  141 +(defun prime? (n)
  142 + (and (> n 1)
  143 + (or (= 2 n)(oddp n))
  144 + (loop for d upfrom 3 by 2 to (sqrt n)
  145 + when (zerop (mod n d)) return nil
  146 + finally (return t))))
  147 +
127 148 ; --- cloucell support for struct access of slots ------------------------
128 149
129 150 (eval-when (:compile-toplevel :execute :load-toplevel)

0 comments on commit 8449356

Please sign in to comment.
Something went wrong with that request. Please try again.