Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
cells
cells
Commits
8e725cc5
Commit
8e725cc5
authored
Jun 16, 2008
by
Kenny Tilton
Browse files
nothing special
parent
0ee74716
Changes
18
Hide whitespace changes
Inline
Side-by-side
cells-manifesto.txt
View file @
8e725cc5
...
...
@@ -13,8 +13,8 @@ For example, in a text editor application we might have (condensed):
(make-instance 'menu-item
:label "Cut"
:enabled (c? (bwhen (f (focus *window*))
(and (typep f
ocus
'text-widget)
(selection-range f
ocus
)))))
(and (typep f 'text-widget)
(selection-range f)))))
Translated, the enabled state of the Cut menu item follows
whether or not the user is focused on a text-edit widget and
...
...
@@ -102,7 +102,9 @@ way around it, and thus his prediction that a software silver bullet was
in principle impossible.
Which brings us to Cells. See also [axiom] Phillip Eby's developing axiomatic
definition he is developing in support of Ryan Forseth's SoC project.
definition he is developing in support of Ryan Forseth's SoC project. Mr. Eby was
inspired by his involvement to develop Trellis, his own Cells work-alike library
for Python.
DEFMODEL and Slot types
-----------------------
...
...
@@ -351,6 +353,9 @@ PhD Thesis in which he develops a constraint programming language or two:
http://portal.acm.org/citation.cfm?id=889490&dl=ACM&coll=ACM
http://www.cs.utk.edu/~bvz/quickplan.html
Flow-based programming, developed by J. Paul Morrison at IBM, 1971.
http://en.wikipedia.org/wiki/Flow-based_programming
Sutherland, I. Sketchpad: A Man Machine Graphical Communication System. PhD thesis, MIT, 1963.
Steele himself cites Sketchpad as inexplicably unappreciated prior
art to his Constraints system:
...
...
cells.lisp
View file @
8e725cc5
...
...
@@ -150,30 +150,31 @@ a cellular slot (or in a list in such) and then mop those up on not-to-be.
(
break
"~&i say, unhandled <c-enabling>: ~s"
condition
))))
(
define-condition
c-fatal
(
xcell
)
((
name
:initarg
:name
:reader
name
)
(
model
:initarg
:model
:reader
model
)
(
cell
:initarg
:cell
:reader
cell
))
((
name
:initform
:anon
:initarg
:name
:reader
name
)
(
model
:initform
nil
:initarg
:model
:reader
model
)
(
cell
:initform
nil
:initarg
:cell
:reader
cell
))
(
:report
(
lambda
(
condition
stream
)
(
format
stream
"~&fatal cell programming error: ~s"
condition
)
(
format
stream
"~& : ~s"
(
name
condition
))
(
format
stream
"~& : ~s"
(
model
condition
))
(
format
stream
"~& : ~s"
(
cell
condition
)))))
(
define-condition
c-unadopted
(
c-fatal
)
()
(
define-condition
asker-midst-askers
(
c-fatal
)
())
;; "see listener for cell rule cycle diagnotics"
(
define-condition
c-unadopted
(
c-fatal
)
()
(
:report
(
lambda
(
condition
stream
)
(
format
stream
"~&unadopted cell >: ~s"
(
cell
condition
))
(
format
stream
"~& >: often you mis-edit (c? (c? ...)) nesting is error"
))))
(
defun
c-break
(
&rest
args
)
(
unless
*stop*
(
let
((
*print-level*
5
)
(
*print-circle*
t
)
(
args2
(
mapcar
'princ-to-string
args
)))
(
c-stop
args
)
(
format
t
"~&c-break > stopping > ~{~a ~}"
args2
)
(
print
`
(
c-break-args
,@
args2
))
(
c-stop
:c-break
)
;(format t "~&c-break > stopping > ~{~a ~}" args2)
(
apply
'error
args2
))))
\ No newline at end of file
defmodel.lisp
View file @
8e725cc5
...
...
@@ -185,6 +185,8 @@ the defmodel form for ~a" ',class ',class))))
(
list*
`
(
:default-initargs
,@
definitargs
)
(
nreverse
class-options
)))))))))
#+
test
(
progn
(
defclass
md-test-super
()())
...
...
family.lisp
View file @
8e725cc5
...
...
@@ -26,9 +26,13 @@ See the Lisp Lesser GNU Public License for more details.
((
.
md-name
:cell
nil
:initform
nil
:initarg
:md-name
:accessor
md-name
)
(
.
fm-parent
:cell
nil
:initform
nil
:initarg
:fm-parent
:accessor
fm-parent
)
(
.
value
:initform
nil
:accessor
value
:initarg
:value
)
(
register?
:cell
nil
:initform
nil
:initarg
:register?
:reader
register?
)
(
zdbg
:initform
nil
:accessor
dbg
:initarg
:dbg
))
)
(
defmethod
initialize-instance
:after
((
self
model
)
&key
)
(
when
(
register?
self
)
(
fm-register
self
)))
(
defmethod
print-cell-object
((
md
model
))
(
or
(
md-name
md
)
:md?
))
...
...
@@ -92,7 +96,14 @@ See the Lisp Lesser GNU Public License for more details.
(
.
kids
:initform
(
c-in
nil
)
;; most useful
:owning
t
:accessor
kids
:initarg
:kids
)))
:initarg
:kids
)
(
registry?
:cell
nil
:initform
nil
:initarg
:registry?
:accessor
registry?
)
(
registry
:cell
nil
:initform
nil
:accessor
registry
)))
#+
test
(
let
((
c
(
find-class
'family
)))
...
...
@@ -143,14 +154,11 @@ See the Lisp Lesser GNU Public License for more details.
`
(
let
((
,
kid
,
self
))
(
find-prior
,
kid
(
kids
(
fm-parent
,
kid
))))))
(
defun
md-be-adopted
(
self
&aux
(
fm-parent
(
fm-parent
self
))
(
selftype
(
type-of
self
)))
(
defun
md-be-adopted
(
self
&aux
(
fm-parent
(
fm-parent
self
))
(
selftype
(
type-of
self
)))
(
c-assert
self
)
(
c-assert
fm-parent
)
(
c-assert
(
typep
fm-parent
'family
))
(
trc
nil
"md be adopted >"
:kid
self
(
adopt-ct
self
)
:by
fm-parent
)
(
when
(
plusp
(
adopt-ct
self
))
...
...
@@ -209,5 +217,45 @@ See the Lisp Lesser GNU Public License for more details.
(
declare
(
ignorable
self
))
(
list
,@
slot-defs
)))
; --- registry "namespacing" ---
(
defmethod
registry?
(
other
)
(
declare
(
ignore
other
))
nil
)
(
defmethod
initialize-instance
:after
((
self
family
)
&key
)
(
when
(
registry?
self
)
(
setf
(
registry
self
)
(
make-hash-table
:test
'eq
))))
(
defmethod
fm-register
(
self
&optional
(
guest
self
))
(
assert
self
)
(
if
(
registry?
self
)
(
progn
(
trc
"fm-registering"
(
md-name
guest
)
:with
self
)
(
setf
(
gethash
(
md-name
guest
)
(
registry
self
))
guest
))
(
fm-register
(
fm-parent
self
)
guest
)))
(
defmethod
fm-check-out
(
self
&optional
(
guest
self
))
(
assert
self
()
"oops ~a ~a ~a"
self
(
fm-parent
self
)
(
slot-value
self
'.fm-parent
))
(
if
(
registry?
self
)
(
remhash
(
md-name
guest
)
(
registry
self
))
(
bif
(
p
(
fm-parent
self
))
(
fm-check-out
p
guest
)
(
break
"oops ~a ~a ~a"
self
(
fm-parent
self
)
(
slot-value
self
'.fm-parent
)))))
(
defmethod
fm-find-registered
(
id
self
&optional
(
must-find?
self
must-find?-supplied?
))
(
or
(
if
(
registry?
self
)
(
gethash
id
(
registry
self
))
(
bwhen
(
p
(
fm-parent
self
))
(
fm-find-registered
id
p
must-find?
)))
(
when
(
and
must-find?
(
not
must-find?-supplied?
))
(
break
"fm-find-registered failed seeking ~a starting search at node ~a"
id
self
))))
(
export!
rg?
rg!
)
(
defmacro
rg?
(
id
)
`
(
fm-find-registered
,
id
self
nil
))
(
defmacro
rg!
(
id
)
`
(
fm-find-registered
,
id
self
))
\ No newline at end of file
fm-utilities.lisp
View file @
8e725cc5
...
...
@@ -14,7 +14,7 @@ the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
See the Lisp Lesser GNU Public License for more details.
$Header$
$Header
: /project/cells/cvsroot/cells/fm-utilities.lisp,v 1.20 2008/05/24 19:24:05 fgoenninger Exp
$
|#
(
in-package
:cells
)
...
...
@@ -702,7 +702,6 @@ $Header$
:global-search
global-search
))))
(
when
(
and
must-find
(
null
match
))
(
trc
"fm-find-one > erroring fm-not-found, in family: "
family
:seeking
md-name
:global?
global-search
)
;;(inspect family)
(
setq
diag
t
must-find
nil
)
(
fm-traverse
family
#'
matcher
:skip-tree
skip-tree
...
...
gui-geometry/geo-family.lisp
View file @
8e725cc5
...
...
@@ -102,6 +102,7 @@ See the Lisp Lesser GNU Public License for more details.
(
^prior-sib-pr
self
(
spacing
.
parent
)))))))))))
(
defun
^prior-sib-pb
(
self
&optional
(
spacing
0
))
;; just keeping with -pt variant till both converted to defun
(
bif
(
psib
(
find-prior
self
(
kids
.
parent
)
:test
(
lambda
(
sib
)
...
...
@@ -118,23 +119,35 @@ See the Lisp Lesser GNU Public License for more details.
(
c?
(
py-maintain-pt
(
round
(
-
(
l-height
.
parent
)
(
l-height
self
))
-2
))))
;--------------- geo.row.flow ----------------------------
(
export!
geo-row-flow
)
(
export!
geo-row-flow
fixed-col-width
^fixed-col-width
^spacing-hz
spacing-hz
max-per-row
^max-per-row
)
(
defmd
geo-row-flow
(
geo-inline
)
(
spacing-hz
0
)
(
spacing-vt
0
)
(
aligned
:cell
nil
)
fixed-col-width
max-per-row
(
row-flow-layout
(
c?
(
loop
with
max-pb
=
0
and
pl
=
0
and
pt
=
0
for
k
in
(
^kids
)
for
kpr
=
(
+
pl
(
l-width
k
))
for
kn
upfrom
0
for
kw
=
(
or
(
^fixed-col-width
)
(
l-width
k
))
for
kpr
=
(
+
pl
kw
)
when
(
unless
(
=
pl
0
)
(
>
kpr
(
-
(
l-width
self
)
(
outset
self
))))
do
(
if
(
^max-per-row
)
(
zerop
(
mod
kn
(
^max-per-row
)))
(
>
kpr
(
-
(
l-width
self
)
(
outset
self
)))))
do
(
when
(
>
kpr
(
-
(
l-width
self
)
(
outset
self
)))
(
trc
nil
"LR overflow break"
kpr
:gt
(
-
(
l-width
self
)
(
outset
self
))))
(
when
(
zerop
(
mod
kn
(
^max-per-row
)))
(
trc
nil
"max/row break"
kn
(
^max-per-row
)
(
mod
kn
(
^max-per-row
))))
(
setf
pl
0
pt
(
+
max-pb
(
downs
(
^spacing-vt
))))
collect
(
cons
pl
pt
)
into
pxys
do
(
incf
pl
(
+
(
l-width
k
)
(
^spacing-hz
)))
do
(
incf
pl
(
+
kw
(
^spacing-hz
)))
(
setf
max-pb
(
min
max-pb
(
+
pt
(
downs
(
l-height
k
)))))
finally
(
return
(
cons
max-pb
pxys
)))))
:lb
(
c?
(
+
(
bif
(
xys
(
^row-flow-layout
))
...
...
integrity.lisp
View file @
8e725cc5
...
...
@@ -66,6 +66,7 @@ See the Lisp Lesser GNU Public License for more details.
*unfinished-business*
*defer-changes*
)
(
trc
nil
"initiating new UFB!!!!!!!!!!!!"
opcode
defer-info
)
(
when
*c-debug*
(
assert
(
boundp
'*istack*
)))
(
when
(
or
(
zerop
*data-pulse-id*
)
(
eq
opcode
:change
))
(
eko
(
nil
"!!! New pulse, event"
*data-pulse-id*
defer-info
)
...
...
@@ -77,15 +78,17 @@ See the Lisp Lesser GNU Public License for more details.
(
let
((
*istack*
(
list
(
list
opcode
defer-info
)
(
list
:trigger
code
)
(
list
:start-dp
*data-pulse-id*
))))
(
trc
"*istack* bound"
)
(
handler-case
(
go-go
)
(
t
(
c
)
(
xcell
(
c
)
(
if
(
functionp
*c-debug*
)
(
funcall
*c-debug*
c
(
nreverse
*istack*
))
(
loop
for
f
in
(
nreverse
*istack*
)
do
(
format
t
"~&istk> ~(~a~) "
f
)
finally
(
describe
c
)
(
break
"integ backtrace: see listener for deets"
))))))
(
break
"integ backtrace: see listener for deets"
)))))
(
trc
"*istack* unbinding"
))
(
go-go
)))))
(
defun
ufb-queue
(
opcode
)
...
...
@@ -163,7 +166,7 @@ See the Lisp Lesser GNU Public License for more details.
; dependent reverses the arrow and puts the burden on the prosecution to prove nested tells are a problem.
(
bwhen
(
uqp
(
fifo-peek
(
ufb-queue
:tell-dependents
)))
#+
x
42
(
trc
"retelling dependenst, one new one being"
uqp
)
#+
x
xx
(
trc
"retelling dependenst, one new one being"
uqp
)
(
go
tell-dependents
))
;--- process client queue ------------------------------
...
...
link.lisp
View file @
8e725cc5
...
...
@@ -58,8 +58,7 @@ See the Lisp Lesser GNU Public License for more details.
(
defun
c-unlink-unused
(
c
&aux
(
usage
(
cd-usage
c
))
(
usage-size
(
array-dimension
(
cd-usage
c
)
0
))
(
dbg
nil
))
;; #+not (and (typep (c-model c) 'mathx::mx-solver-stack)
;;(eq (c-slot-name c) '.kids))))
(
dbg
nil
))
(
declare
(
ignorable
dbg
usage-size
))
(
when
(
cd-useds
c
)
(
let
(
rev-pos
)
...
...
md-slot-value.lisp
View file @
8e725cc5
...
...
@@ -23,9 +23,11 @@ See the Lisp Lesser GNU Public License for more details.
(
defun
md-slot-value
(
self
slot-name
&aux
(
c
(
md-slot-cell
self
slot-name
)))
(
when
(
and
(
not
*not-to-be*
)
(
mdead
self
))
(
trc
"md-slot-value passed dead self, returning NIL"
self
slot-name
c
)
#-
sbcl
(
inspect
self
)
(
break
"see inspector for dead ~a"
self
)
(
unless
*stop*
(
setf
*stop*
t
)
(
trc
"md-slot-value passed dead self, returning NIL"
self
slot-name
c
)
#-
sbcl
(
inspect
self
)
(
break
"see inspector for dead ~a"
self
))
(
return-from
md-slot-value
nil
))
(
tagbody
retry
...
...
@@ -47,7 +49,7 @@ See the Lisp Lesser GNU Public License for more details.
;; (count-it :md-slot-value slot-name)
(
if
c
(
cell-read
c
)
(
values
(
bd-
slot-value
self
slot-name
)
nil
)))
(
values
(
slot-value
self
slot-name
)
nil
)))
(
defun
cell-read
(
c
)
(
assert
(
typep
c
'cell
))
...
...
@@ -61,12 +63,6 @@ See the Lisp Lesser GNU Public License for more details.
(
when
(
mdead
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))))
(
defvar
*trc-ensure*
nil
)
(
defmethod
ensure-value-is-current
(
c
debug-id
ensurer
)
...
...
@@ -145,6 +141,7 @@ See the Lisp Lesser GNU Public License for more details.
nil
)
v
)))
(
defun
calculate-and-set
(
c
)
(
flet
((
body
()
(
when
(
c-stopped
)
...
...
@@ -154,19 +151,18 @@ See the Lisp Lesser GNU Public License for more details.
#-
its-alive!
(
bwhen
(
x
(
find
c
*call-stack*
))
;; circularity
(
unless
nil
;; *stop*
(
let
((
stack
(
copy-list
*call-stack*
)))
(
trc
"calculating cell ~a appears in call stack: ~a"
c
x
stack
)))
(
setf
*stop*
t
)
(
c-break
"yep"
c
)
(
loop
with
caller-reiterated
for
caller
in
*call-stack*
until
caller-reiterated
do
(
trc
"caller:"
caller
)
;; not necessary (pprint (cr-code c))
(
setf
caller-reiterated
(
eq
caller
c
)))
(
let
()
(
inspect
c
)
(
trc
"calculating cell:"
c
(
cr-code
c
))
(
trc
"appears-in-call-stack (newest first): "
(
length
*call-stack*
))
(
loop
for
caller
in
(
copy-list
*call-stack*
)
for
n
below
(
length
*call-stack*
)
do
(
trc
"caller> "
caller
#+
shhh
(
cr-code
caller
))
when
(
eq
caller
c
)
do
(
loop-finish
))))
(
setf
*stop*
t
)
(
c-break
;; break is problem when testing cells on some CLs
"cell ~a midst askers (see above)"
c
)
(
error
"see listener for cell rule cycle diagnotics"
))
(
error
'asker-midst-askers
:cell
c
))
(
multiple-value-bind
(
raw-value
propagation-code
)
(
calculate-and-link
c
)
...
...
@@ -197,6 +193,20 @@ See the Lisp Lesser GNU Public License for more details.
(
funcall
(
cr-rule
c
)
c
)
(
c-unlink-unused
c
))))
#+
theabove!
(
defun
calculate-and-set
(
c
)
(
multiple-value-bind
(
raw-value
propagation-code
)
(
let
((
*call-stack*
(
cons
c
*call-stack*
))
(
*depender*
c
)
(
*defer-changes*
t
))
(
cd-usage-clear-all
c
)
(
multiple-value-prog1
(
funcall
(
cr-rule
c
)
c
)
(
c-unlink-unused
c
)))
(
unless
(
c-optimized-away-p
c
)
(
md-slot-value-assume
c
raw-value
propagation-code
))))
;-------------------------------------------------------------
(
defun
md-slot-makunbound
(
self
slot-name
...
...
md-utilities.lisp
View file @
8e725cc5
...
...
@@ -54,7 +54,7 @@ See the Lisp Lesser GNU Public License for more details.
(
:method
((
self
model-object
))
(
md-quiesce
self
))
(
:method
:before
((
self
model-object
))
(
loop
for
slot-name
in
(
md-owning-slots
self
)
do
(
not-to-be
(
slot-value
self
slot-name
))))
...
...
@@ -62,8 +62,7 @@ See the Lisp Lesser GNU Public License for more details.
(
:method
:around
((
self
model-object
))
(
declare
(
ignorable
self
))
(
let
((
*not-to-be*
t
)
(
dbg
nil
#+
not
(
or
(
eq
(
md-name
self
)
:eclm-owner
)
(
typep
self
'
(
or
mathx::eclm-2008
clo:ix-form
mathx::a1-panel
mathx::edit-caret
ctk:window
)))))
(
dbg
nil
))
(
flet
((
gok
()
(
unless
(
eq
(
md-state
self
)
:eternal-rest
)
...
...
@@ -85,13 +84,15 @@ See the Lisp Lesser GNU Public License for more details.
(
mapcar
'type-of
(
slot-value
self
'.kids
))))
(
gok
)
(
when
dbg
(
trc
"finished nailing"
self
))))))))
(
defun
md-quiesce
(
self
)
(
trc
nil
"md-quiesce nailing cells"
self
(
type-of
self
))
(
md-map-cells
self
nil
(
lambda
(
c
)
(
trc
nil
"quiescing"
c
)
(
c-assert
(
not
(
find
c
*call-stack*
)))
(
c-quiesce
c
))))
(
c-quiesce
c
)))
(
when
(
register?
self
)
(
fm-check-out
self
)))
(
defun
c-quiesce
(
c
)
(
typecase
c
...
...
@@ -112,3 +113,78 @@ See the Lisp Lesser GNU Public License for more details.
,@
initargs
:fm-parent
(
progn
(
assert
self
)
self
)))
(
export!
self-owned
self-owned?
)
(
defun
(
setf
self-owned
)
(
new-value
self
thing
)
(
if
(
consp
thing
)
(
loop
for
e
in
thing
do
(
setf
(
self-owned
self
e
)
new-value
))
(
if
new-value
(
progn
(
assert
(
not
(
find
thing
(
z-owned
self
))))
(
push
thing
(
z-owned
self
)))
(
progn
(
assert
(
find
thing
(
z-owned
self
)))
(
setf
(
z-owned
self
)(
delete
thing
(
z-owned
self
)))))))
(
defun
self-owned?
(
self
thing
)
(
find
thing
(
z-owned
self
)))
(
defvar
*c-d-d*
)
(
defvar
*max-d-d*
)
(
defun
count-model
(
self
)
(
setf
*c-d-d*
(
make-hash-table
:test
'eq
)
*max-d-d*
0
)
(
with-metrics
(
t
nil
"cells statistics for"
self
)
(
labels
((
cc
(
self
)
(
count-it
:thing
)
(
count-it
:thing
(
type-of
self
))
;(count-it :thing-type (type-of self))
(
loop
for
(
id
.
c
)
in
(
cells
self
)
do
(
count-it
:live-cell
)
;(count-it :live-cell id)
(
typecase
c
(
c-dependent
(
count-it
:dependent-cell
)
(
loop
repeat
(
length
(
c-useds
c
))
do
(
count-it
:cell-useds
)
(
count-it
:dep-depth
(
c-depend-depth
c
))))
(
otherwise
(
if
(
c-inputp
c
)
(
count-it
:c-input
id
)
(
count-it
:c-unknow
))))
(
loop
repeat
(
length
(
c-callers
c
))
do
(
count-it
:cell-callers
)))
(
loop
repeat
(
length
(
cells-flushed
self
))
do
(
count-it
:flushed-cell
#+
toomuchinfo
id
))
(
loop
for
slot
in
(
md-owning-slots
self
)
do
(
loop
for
k
in
(
let
((
sv
(
SLOT-VALUE
self
slot
)))
(
if
(
listp
sv
)
sv
(
list
sv
)))
do
(
cc
k
)))))
(
cc
self
))))
(
defun
c-depend-depth
(
ctop
)
(
if
(
null
(
c-useds
ctop
))
0
(
or
(
gethash
ctop
*c-d-d*
)
(
labels
((
cdd
(
c
&optional
(
depth
1
)
chain
)
(
when
(
and
(
not
(
c-useds
c
))
(
>
depth
*max-d-d*
))
(
setf
*max-d-d*
depth
)
(
trc
"new dd champ from user"
depth
:down-to
c
)
(
when
(
=
depth
41
)
(
trc
"end at"
(
c-slot-name
c
)
:of
(
type-of
(
c-model
c
)))
(
loop
for
c
in
chain
do
(
trc
"called by"
(
c-slot-name
c
)
:of
(
type-of
(
c-model
c
))))))
(
setf
(
gethash
c
*c-d-d*
)
;(break "c-depend-depth ~a" c)
(
progn
;(trc "dd" c)
(
1+
(
loop
for
u
in
(
c-useds
c
)
maximizing
(
cdd
u
(
1+
depth
)
(
cons
c
chain
))))))))
(
cdd
ctop
)))))
\ No newline at end of file
model-object.lisp
View file @
8e725cc5
...
...
@@ -21,15 +21,17 @@ See the Lisp Lesser GNU Public License for more details.
;;; --- model-object ----------------------
(
eval-when
(
:compile-toplevel
:load-toplevel
:execute
)
(
export
'
(
md-name
fm-parent
.
parent
)))
(
export
'
(
md-name
fm-parent
.
parent
z-owned
)))
(
defclass
model-object
()
((
.
md-state
:initform
:nascent
:accessor
md-state
)
; [nil | :nascent | :alive | :doomed]
(
.
awaken-on-init-p
:initform
nil
:initarg
:awaken-on-init-p
:accessor
awaken-on-init-p
)
; [nil | :nascent | :alive | :doomed]
(
.
awaken-on-init-p
:initform
nil
:initarg
:awaken-on-init-p
:accessor
awaken-on-init-p
)
(
.
cells
:initform
nil
:accessor
cells
)
(
.
cells-flushed
:initform
nil
:accessor
cells-flushed
:documentation
"cells supplied but un-whenned or optimized-away"
)
(
adopt-ct
:initform
0
:accessor
adopt-ct
)))
(
adopt-ct
:initform
0
:accessor
adopt-ct
)
(
z-owned
:initform
nil
:accessor
z-owned
;; experimental, not yet operative
:documentation
"Things such as kids to be taken down when self is taken down"
)))
(
defmethod
md-state
((
self
symbol
))
:alive
)
...
...
@@ -202,7 +204,8 @@ See the Lisp Lesser GNU Public License for more details.
(
dolist
(
super
(
class-precedence-list
(
find-class
class-name
))
(
setf
(
md-slot-cell-type
class-name
slot-name
)
nil
))
(
bwhen
(
entry
(
assoc
slot-name
(
get
(
c-class-name
super
)
:cell-types
)))
(
return-from
md-slot-cell-type
(
setf
(
md-slot-cell-type
class-name
slot-name
)
(
cdr
entry
))))))))
(
return-from
md-slot-cell-type
(
setf
(
md-slot-cell-type
class-name
slot-name
)
(
cdr
entry
))))))))
(
defun
(
setf
md-slot-cell-type
)
(
new-type
class-name
slot-name
)
(
assert
class-name
)
...
...
@@ -216,12 +219,6 @@ See the Lisp Lesser GNU Public License for more details.
do
(
setf
(
md-slot-cell-type
(
class-name
c
)
slot-name
)
new-type
)))
(
cdar
(
push
(
cons
slot-name
new-type
)
(
get
class-name
:cell-types
)))))))
#+
hunh
(
md-slot-owning?
'mathx::prb-solver
'.kids
)
#+
hunh
(
cdr
(
assoc
'.value
(
get
'm-index
:indirect-ownings
)))
#+
test
(
md-slot-owning?
'm-index
'.value
)
...
...
@@ -289,6 +286,10 @@ See the Lisp Lesser GNU Public License for more details.
(
defun
(
setf
md-slot-cell
)
(
new-cell
self
slot-name
)
(
if
self
;; not on def-c-variables
(
bif
(
entry
(
assoc
slot-name
(
cells
self
)))
; this next branch guessed it would only occur during kid-slotting,
; before any dependency-ing could have happened, but a math-editor
; is silently switching between implied-multiplication and mixed numbers
; while they type and it
(
let
((
old
(
cdr
entry
)))
;; s/b being supplanted by kid-slotter
(
declare
(
ignorable
old
))
(
c-assert
(
null
(
c-callers
old
)))
...
...
propagate.lisp
View file @
8e725cc5
...
...
@@ -58,12 +58,8 @@ See the Lisp Lesser GNU Public License for more details.
(
setf
(
c-pulse
c
)
*data-pulse-id*
))
;--------------- propagate ----------------------------
; n.b. the cell argument may have been optimized away,
; though it is still receiving final processing here.
;
(
defparameter
*per-cell-handler*
nil
)
...
...
test-propagation.lisp
View file @
8e725cc5
...
...
@@ -22,7 +22,7 @@
(
defun
tcprop
()
(
untrace
)
(
test-prep
)
(
ukt:
test-prep
)
(
LET
((
box
(
make-instance
'tcp
)))
(
trc
"changing top to 10"
*data-pulse-id*
)
(
setf
(
top
box
)
10
)
...
...
trc-eko.lisp
View file @
8e725cc5
...
...
@@ -19,13 +19,12 @@ See the Lisp Lesser GNU Public License for more details.
(
in-package
:cells
)
;----------- trc -------------------------------------------
(
defparameter
*last-trc*
(
get-internal-real-time
))
(
defparameter
*trcdepth*
0
)
(
defun
trcdepth-reset
()
(
setf
*trcdepth*
0
))
(
defmacro
trc
(
tgt-form
&rest
os
)
(
if
(
eql
tgt-form
'nil
)
'
(
progn
)
...
...
@@ -45,8 +44,23 @@ See the Lisp Lesser GNU Public License for more details.
(
count-it
:trcfailed
)))
(
count-it
:tgtnileval
)))))))
(
export!
brk
brkx
.
bgo
)
(
defun
call-trc
(
stream
s
&rest
os
)
;(break)
(
if
#+
cormanlisp
nil
#-
cormanlisp
(
and
(
boundp
'*trcdepth*
)
*trcdepth*
)
(
format
stream
"~&~v,,,'.<~d~>> "
(
mod
*trcdepth*
100
)
*trcdepth*
)
(
format
stream
"~&"
))
;;(format stream " ~a " (round (- (get-internal-real-time) *last-trc*) 10))
(
setf
*last-trc*
(
get-internal-real-time
))
(
format
stream
"~a"
s
)
(
let
(
pkwp
)
(
dolist
(
o
os
)
(
format
stream
(
if
pkwp
" ~(~s~)"
" ~(~s~)"
)
o
)
;; save, used to insert divider, trcx dont like
(
setf
pkwp
(
keywordp
o
))))
(
force-output
stream
)
(
values
))
(
export!
brk
brkx
.
bgo
)
(
define-symbol-macro
.
bgo
(
break
"go"
))
...
...
@@ -68,23 +82,8 @@ See the Lisp Lesser GNU Public License for more details.