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
c165c14d
Commit
c165c14d
authored
Feb 02, 2008
by
Kenny Tilton
Browse files
make cell (if any) sixth param to slot-value-observe
parent
d73dae1b
Changes
6
Hide whitespace changes
Inline
Side-by-side
cells.lisp
View file @
c165c14d
...
...
@@ -103,14 +103,14 @@ See the Lisp Lesser GNU Public License for more details.
(
define-condition
unbound-cell
(
unbound-slot
)
((
cell
:initarg
:cell
:reader
cell
:initform
nil
)))
(
defgeneric
slot-value-observe
(
slotname
self
new
old
old-boundp
)
(
defgeneric
slot-value-observe
(
slotname
self
new
old
old-boundp
cell
)
#-
(
or
cormanlisp
)
(
:method-combination
progn
))
#-
cells-testing
(
defmethod
slot-value-observe
#-
(
or
cormanlisp
)
progn
(
slot-name
self
new
old
old-boundp
)
(
declare
(
ignorable
slot-name
self
new
old
old-boundp
)))
(
slot-name
self
new
old
old-boundp
cell
)
(
declare
(
ignorable
slot-name
self
new
old
old-boundp
cell
)))
; -------- cell conditions (not much used) ---------------------------------------------
...
...
cells.lpr
View file @
c165c14d
;;
-*-
lisp
-
version
:
"
8.1
[
Windows
]
(
Jan
2
,
2008
9
:
44
)
"
;
cg
:
"
1.103.2.10
"
;
-*-
;;
-*-
lisp
-
version
:
"
8.1
[
Windows
]
(
Feb
1
,
2008
18
:
35
)
"
;
cg
:
"
1.103.2.10
"
;
-*-
(
in
-
package
:
cg
-
user
)
...
...
@@ -23,7 +23,8 @@
(make-instance '
module
:
name
"
md
-
utilities
.
lisp
"
)
(
make
-
instance
'module :name "family.lisp")
(make-instance '
module
:
name
"
fm
-
utilities
.
lisp
"
)
(
make
-
instance
'module :name "family-values.lisp"))
(
make
-
instance
'module :name "family-values.lisp")
(make-instance '
module
:
name
"
test
-
propagation
.
lisp
"
))
:
projects
(
list
(
make
-
instance
'project-module :name
"utils-kt\\utils-kt"))
:libraries nil
...
...
initialize.lisp
View file @
c165c14d
...
...
@@ -35,7 +35,7 @@ See the Lisp Lesser GNU Public License for more details.
(
trc
nil
"awaken cell observing"
c
)
(
when
(
>
*data-pulse-id*
(
c-pulse-observed
c
))
(
setf
(
c-pulse-observed
c
)
*data-pulse-id*
)
(
slot-value-observe
(
c-slot-name
c
)
(
c-model
c
)
(
c-value
c
)
nil
nil
)
(
slot-value-observe
(
c-slot-name
c
)
(
c-model
c
)
(
c-value
c
)
nil
nil
c
)
(
ephemeral-reset
c
)))
(
defmethod
awaken-cell
((
c
c-ruled
))
...
...
model-object.lisp
View file @
c165c14d
...
...
@@ -156,7 +156,7 @@ See the Lisp Lesser GNU Public License for more details.
(
>
*data-pulse-id*
(
c-pulse-observed
flushed
)))
;; unfrickinlikely
(
when
flushed
(
setf
(
c-pulse-observed
flushed
)
*data-pulse-id*
))
;; probably unnecessary
(
slot-value-observe
slot-name
self
(
bd-slot-value
self
slot-name
)
nil
nil
))))
(
slot-value-observe
slot-name
self
(
bd-slot-value
self
slot-name
)
nil
nil
flushed
))))
((
find
(
c-lazy
c
)
'
(
:until-asked
:always
t
))
...
...
propagate.lisp
View file @
c165c14d
...
...
@@ -36,11 +36,11 @@ See the Lisp Lesser GNU Public License for more details.
; --- data pulse (change ID) management -------------------------------------
(
defparameter
*
client-is-propagating
*
nil
)
(
defparameter
*
one-pulse?
*
nil
)
(
defun
data-pulse-next
(
pulse-info
)
(
declare
(
ignorable
pulse-info
))
(
unless
*
client-is-propagating
*
(
unless
*
one-pulse?
*
(
trc
nil
"data-pulse-next > "
(
1+
*data-pulse-id*
)
pulse-info
)
(
incf
*data-pulse-id*
)))
...
...
@@ -66,7 +66,7 @@ See the Lisp Lesser GNU Public License for more details.
(
defparameter
*per-cell-handler*
nil
)
(
defun
c-propagate
(
c
prior-value
prior-value-supplied
)
(
when
*
client-is-propagating
*
(
when
*
one-pulse?
*
(
when
*per-cell-handler*
(
funcall
*per-cell-handler*
c
prior-value
prior-value-supplied
)
(
return-from
c-propagate
)))
...
...
@@ -132,7 +132,7 @@ See the Lisp Lesser GNU Public License for more details.
(
when
t
; breaks algebra (> *data-pulse-id* (c-pulse-observed c))
(
setf
(
c-pulse-observed
c
)
*data-pulse-id*
)
(
slot-value-observe
(
c-slot-name
c
)
(
c-model
c
)
(
c-value
c
)
prior-value
prior-value-supplied
))
(
c-value
c
)
prior-value
prior-value-supplied
c
))
;
...
...
@@ -152,7 +152,7 @@ See the Lisp Lesser GNU Public License for more details.
(
defmacro
defobserver
(
slotname
&rest
args
&aux
(
aroundp
(
eq
:around
(
first
args
))))
(
when
aroundp
(
setf
args
(
cdr
args
)))
(
destructuring-bind
((
&optional
(
self-arg
'self
)
(
new-varg
'new-value
)
(
oldvarg
'old-value
)
(
oldvargboundp
'old-value-boundp
))
(
oldvarg
'old-value
)
(
oldvargboundp
'old-value-boundp
)
(
cell-arg
'c
)
)
&body
output-body
)
args
`
(
progn
(
eval-when
(
:compile-toplevel
:load-toplevel
:execute
)
...
...
@@ -161,24 +161,24 @@ See the Lisp Lesser GNU Public License for more details.
(
let
((
temp1
(
gensym
))
(
loc-self
(
gensym
)))
`
(
defmethod
slot-value-observe
#-
(
or
cormanlisp
)
,
(
if
aroundp
:around
'progn
)
((
slotname
(
eql
',slotname
))
,
self-arg
,
new-varg
,
oldvarg
,
oldvargboundp
)
((
slotname
(
eql
',slotname
))
,
self-arg
,
new-varg
,
oldvarg
,
oldvargboundp
,
cell-arg
)
(
let
((
,
temp1
(
bump-output-count
,
slotname
))
(
,
loc-self
,
(
if
(
listp
self-arg
)
(
car
self-arg
)
self-arg
)))
(
when
(
and
,
oldvargboundp
,
oldvarg
)
(
format
t
"~&output ~d (~a ~a) old: ~a"
,
temp1
',slotname
,
loc-self
,
oldvarg
))
(
format
t
"~&output ~d (~a ~a) new: ~a"
,
temp1
',slotname
,
loc-self
,
new-varg
))))
(
format
t
"~&output ~d (~a ~a) old: ~a"
,
temp1
',slotname
,
loc-self
,
oldvarg
,
cell-arg
))
(
format
t
"~&output ~d (~a ~a) new: ~a"
,
temp1
',slotname
,
loc-self
,
new-varg
,
cell-arg
))))
`
(
defmethod
slot-value-observe
#-
(
or
cormanlisp
)
,
(
if
aroundp
:around
'progn
)
((
slotname
(
eql
',slotname
))
,
self-arg
,
new-varg
,
oldvarg
,
oldvargboundp
)
((
slotname
(
eql
',slotname
))
,
self-arg
,
new-varg
,
oldvarg
,
oldvargboundp
,
cell-arg
)
(
declare
(
ignorable
,@
(
flet
((
arg-name
(
arg-spec
)
(
etypecase
arg-spec
(
list
(
car
arg-spec
))
(
atom
arg-spec
))))
(
list
(
arg-name
self-arg
)(
arg-name
new-varg
)
(
arg-name
oldvarg
)(
arg-name
oldvargboundp
)))))
(
arg-name
oldvarg
)(
arg-name
oldvargboundp
)
(
arg-name
cell-arg
)
))))
,@
output-body
)))))
(
defmacro
bump-output-count
(
slotname
)
;; pure test func
...
...
@@ -256,56 +256,13 @@ See the Lisp Lesser GNU Public License for more details.
;(trace c-propagate ensure-value-is-current)
(
loop
for
(
c
prior-value
prior-value?
)
in
(
nreverse
cs
)
do
(
c-propagate
c
prior-value
prior-value?
)))))
(
assert
(
not
*
client-is-propagating
*
))
(
assert
(
not
*
one-pulse?
*
))
(
data-pulse-next
:client-prop
)
(
trc
"call-with-one-datapulse bumps pulse"
*data-pulse-id*
)
(
funcall
finally
(
let
((
*
client-is-propagating
*
t
)
(
let
((
*
one-pulse?
*
t
)
(
*per-cell-handler*
per-cell
)
(
*the-unpropagated*
nil
))
(
funcall
f
)
*the-unpropagated*
)))
(
defmd
tcp
()
(
left
(
c-in
0
))
(
top
(
c-in
0
))
(
right
(
c-in
0
))
(
bottom
(
c-in
0
))
(
area
(
c?
(
trc
"area running"
)
(
*
(
-
(
^right
)(
^left
))
(
-
(
^top
)(
^bottom
))))))
(
defobserver
area
()
(
TRC
"new area"
new-value
old-value
old-value-boundp
:pulse
*data-pulse-id*
))
(
defobserver
bottom
()
(
TRC
"new bottom"
new-value
old-value
old-value-boundp
:pulse
*data-pulse-id*
)
(
with-integrity
(
:change
'bottom-tells-left
)
(
setf
(
^left
)
new-value
)))
(
defobserver
left
()
(
TRC
"new left"
new-value
old-value
old-value-boundp
:pulse
*data-pulse-id*
))
(
defun
tcprop
()
(
untrace
)
(
test-prep
)
(
LET
((
box
(
make-instance
'tcp
)))
(
trc
"changing top to 10"
*data-pulse-id*
)
(
setf
(
top
box
)
10
)
(
trc
"not changing top"
*data-pulse-id*
)
(
setf
(
top
box
)
10
)
(
trc
"changing right to 10"
*data-pulse-id*
)
(
setf
(
right
box
)
10
)
(
trc
"not changing right"
*data-pulse-id*
)
(
setf
(
right
box
)
10
)
(
trc
"changing bottom to -1"
*data-pulse-id*
)
(
decf
(
bottom
box
))
(
with-one-datapulse
()
(
loop
repeat
20
do
(
trc
"changing bottom by -1"
*data-pulse-id*
)
(
decf
(
bottom
box
))))))
test-propagation.lisp
View file @
c165c14d
(
in-package
:cells
)
(
defmd
tcp
()
...
...
@@ -13,6 +12,14 @@
(
defobserver
area
()
(
TRC
"new area"
new-value
old-value
old-value-boundp
:pulse
*data-pulse-id*
))
(
defobserver
bottom
()
(
TRC
"new bottom"
new-value
old-value
old-value-boundp
:pulse
*data-pulse-id*
)
(
with-integrity
(
:change
'bottom-tells-left
)
(
setf
(
^left
)
new-value
)))
(
defobserver
left
()
(
TRC
"new left"
new-value
old-value
old-value-boundp
:pulse
*data-pulse-id*
))
(
defun
tcprop
()
(
untrace
)
(
test-prep
)
...
...
@@ -27,8 +34,12 @@
(
setf
(
right
box
)
10
)
(
trc
"changing bottom to -1"
*data-pulse-id*
)
(
decf
(
bottom
box
))
(
with-
client-propagation
()
(
loop
repeat
20
do
(
with-
one-datapulse
()
(
loop
repeat
5
do
(
trc
"changing bottom by -1"
*data-pulse-id*
)
(
decf
(
bottom
box
))
(
decf
(
left
box
))))))
(
decf
(
bottom
box
))))))
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment