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
be395425
Commit
be395425
authored
Apr 23, 2008
by
Kenny Tilton
Browse files
Oops. Major repairs to handling of the owning property of cell slots.
parent
f521b221
Changes
9
Hide whitespace changes
Inline
Side-by-side
cell-types.lisp
View file @
be395425
...
...
@@ -67,11 +67,12 @@ See the Lisp Lesser GNU Public License for more details.
(
call-next-method
)
(
progn
(
c-print-value
c
stream
)
(
format
stream
"
=
~d
/
~a/~a
/
~a
]
"
(
format
stream
"
<
~d
:~a
~a/~a
=
~a
>
"
(
c-pulse
c
)
(
c-state
c
)
(
subseq
(
string
(
c-state
c
)
)
0
1
)
(
symbol-name
(
or
(
c-slot-name
c
)
:anoncell
))
(
print-cell-model
(
c-model
c
))))))))
(
print-cell-model
(
c-model
c
))
(
c-value
c
)))))))
(
export!
print-cell-model
)
...
...
cells.lisp
View file @
be395425
...
...
@@ -45,6 +45,7 @@ a cellular slot (or in a list in such) and then mop those up on not-to-be.
(
defparameter
*c-debug*
nil
)
(
defparameter
*defer-changes*
nil
)
(
defparameter
*within-integrity*
nil
)
(
defvar
*istack*
)
(
defparameter
*client-queue-handler*
nil
)
(
defparameter
*unfinished-business*
nil
)
(
defparameter
*not-to-be*
nil
)
...
...
defmodel.lisp
View file @
be395425
...
...
@@ -103,7 +103,7 @@ the defmodel form for ~a" ',class ',class))))
`
(
eval-when
(
#-
sbcl
:compile-toplevel
:load-toplevel
:execute
)
; ph -- prevent sbcl warning
(
setf
(
md-slot-cell-type
',class
',slotname
)
,
cell
)
,
(
when
owning
`
(
setf
(
md-slot-owning?
',class
',slotname
)
,
owning
))
`
(
setf
(
md-slot-owning
-direct
?
',class
',slotname
)
,
owning
))
,
(
when
reader-fn
`
(
defmethod
,
reader-fn
((
self
,
class
))
(
md-slot-value
self
',slotname
)))
...
...
family.lisp
View file @
be395425
...
...
@@ -94,6 +94,11 @@ See the Lisp Lesser GNU Public License for more details.
:accessor
kids
:initarg
:kids
)))
#+
test
(
let
((
c
(
find-class
'family
)))
(
mop::finalize-inheritance
c
)
(
class-precedence-list
c
))
(
defmacro
the-kids
(
&rest
kids
)
`
(
let
((
*parent*
self
))
(
packed-flat!
,@
kids
)))
...
...
integrity.lisp
View file @
be395425
...
...
@@ -28,11 +28,14 @@ See the Lisp Lesser GNU Public License for more details.
(
when
opcode
(
assert
(
find
opcode
*ufb-opcodes*
)
()
"Invalid opcode for with-integrity: ~a. Allowed values: ~a"
opcode
*ufb-opcodes*
))
`
(
call-with-integrity
,
opcode
,
defer-info
(
lambda
(
opcode
defer-info
)
(
declare
(
ignorable
opcode
defer-info
))
,
(
when
debug
`
(
trc
"integrity action entry"
opcode
defer-info
',body
))
,@
body
)))
`
(
call-with-integrity
,
opcode
,
defer-info
(
lambda
(
opcode
defer-info
)
(
declare
(
ignorable
opcode
defer-info
))
,
(
when
debug
`
(
trc
"integrity action entry"
opcode
defer-info
',body
))
,@
body
)
(
when
*c-debug*
',body
)))
(
export!
with-cc
)
...
...
@@ -43,7 +46,7 @@ See the Lisp Lesser GNU Public License for more details.
(
defun
integrity-managed-p
()
*within-integrity*
)
(
defun
call-with-integrity
(
opcode
defer-info
action
)
(
defun
call-with-integrity
(
opcode
defer-info
action
code
)
(
when
*stop*
(
return-from
call-with-integrity
))
(
if
*within-integrity*
...
...
@@ -58,17 +61,32 @@ See the Lisp Lesser GNU Public License for more details.
;
:deferred-to-ufb-1
)
(
funcall
action
opcode
defer-info
))
(
let
((
*within-integrity*
t
)
*unfinished-business*
*defer-changes*
)
(
trc
nil
"initiating new UFB!!!!!!!!!!!!"
opcode
defer-info
)
(
when
(
or
(
zerop
*data-pulse-id*
)
(
eq
opcode
:change
))
(
eko
(
nil
"!!! New pulse, event"
*data-pulse-id*
defer-info
)
(
data-pulse-next
(
cons
opcode
defer-info
))))
(
prog1
(
funcall
action
opcode
defer-info
)
(
finish-business
)))))
(
flet
((
go-go
()
(
let
((
*within-integrity*
t
)
*unfinished-business*
*defer-changes*
)
(
trc
nil
"initiating new UFB!!!!!!!!!!!!"
opcode
defer-info
)
(
when
(
or
(
zerop
*data-pulse-id*
)
(
eq
opcode
:change
))
(
eko
(
nil
"!!! New pulse, event"
*data-pulse-id*
defer-info
)
(
data-pulse-next
(
cons
opcode
defer-info
))))
(
prog1
(
funcall
action
opcode
defer-info
)
(
finish-business
)))))
(
if
*c-debug*
(
let
((
*istack*
(
list
(
list
opcode
defer-info
)
(
list
:trigger
code
)
(
list
:start-dp
*data-pulse-id*
))))
(
handler-case
(
go-go
)
(
t
(
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"
))))))
(
go-go
)))))
(
defun
ufb-queue
(
opcode
)
(
cdr
(
assoc
opcode
*unfinished-business*
)))
...
...
@@ -85,14 +103,17 @@ See the Lisp Lesser GNU Public License for more details.
(
trc
nil
"ufb-add deferring"
opcode
(
when
(
eql
opcode
:client
)(
car
continuation
)))
(
fifo-add
(
ufb-queue-ensure
opcode
)
continuation
))
(
defun
just-do-it
(
op-or-q
&aux
(
q
(
if
(
keywordp
op-or-q
)
(
ufb-queue
op-or-q
)
op-or-q
)))
(
defun
just-do-it
(
op-or-q
&optional
(
op-code
op-or-q
)
;; make-better
&aux
(
q
(
if
(
keywordp
op-or-q
)
(
ufb-queue
op-or-q
)
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
)
(
funcall
task
op-or-q
defer-info
)))
(
when
*c-debug*
(
push
(
list
op-code
defer-info
)
*istack*
))
(
funcall
task
op-or-q
defer-info
)))
(
defun
finish-business
()
(
when
*stop*
(
return-from
finish-business
))
...
...
@@ -153,7 +174,7 @@ See the Lisp Lesser GNU Public License for more details.
(
bwhen
(
clientq
(
ufb-queue
:client
))
(
if
*client-queue-handler*
(
funcall
*client-queue-handler*
clientq
)
;; might be empty/not exist, so handlers must check
(
just-do-it
clientq
))
(
just-do-it
clientq
:client
))
(
when
(
fifo-peek
(
ufb-queue
:client
))
#+
shhh
(
ukt::fifo-browse
(
ufb-queue
:client
)
(
lambda
(
entry
)
(
trc
"surprise client"
entry
)))
...
...
md-utilities.lisp
View file @
be395425
...
...
@@ -39,6 +39,7 @@ See the Lisp Lesser GNU Public License for more details.
(
declare
(
ignore
self
))
nil
))
(
defgeneric
not-to-be
(
self
)
(
:method
((
self
list
))
(
dolist
(
s
self
)
...
...
@@ -55,8 +56,7 @@ See the Lisp Lesser GNU Public License for more details.
(
md-quiesce
self
))
(
:method
:before
((
self
model-object
))
(
loop
for
(
slot-name
.
owning?
)
in
(
get
(
type-of
self
)
:ownings
)
when
owning?
(
loop
for
slot-name
in
(
md-owning-slots
self
)
do
(
not-to-be
(
slot-value
self
slot-name
))))
(
:method
:around
((
self
model-object
))
...
...
model-object.lisp
View file @
be395425
...
...
@@ -216,28 +216,55 @@ 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
)
(
defun
md-slot-owning?
(
class-name
slot-name
)
(
assert
class-name
)
(
if
(
eq
class-name
'null
)
(
get
slot-name
:owning
)
(
bif
(
entry
(
assoc
slot-name
(
get
class-name
:ownings
)))
(
get
slot-name
:owning
)
;; might be wrong -- support for specials is unfinished w.i.p.
(
bif
(
entry
(
assoc
slot-name
(
get
class-name
:
direct-
ownings
)))
(
cdr
entry
)
(
dolist
(
super
(
class-precedence-list
(
find-class
class-name
)))
(
bwhen
(
entry
(
assoc
slot-name
(
get
(
c-class-name
super
)
:ownings
)))
(
return
(
setf
(
md-slot-owning?
class-name
slot-name
)
(
cdr
entry
))))))))
(
defun
(
setf
md-slot-owning?
)
(
value
class-name
slot-name
)
(
bif
(
entry
(
assoc
slot-name
(
get
class-name
:indirect-ownings
)))
(
cdr
entry
)
(
cdar
(
push
(
cons
slot-name
(
cdr
(
loop
for
super
in
(
cdr
(
class-precedence-list
(
find-class
class-name
)))
thereis
(
assoc
slot-name
(
get
(
c-class-name
super
)
:direct-ownings
)))))
(
get
class-name
:indirect-ownings
)))))))
(
defun
(
setf
md-slot-owning-direct?
)
(
value
class-name
slot-name
)
(
assert
class-name
)
(
if
(
eq
class-name
'null
)
(
if
(
eq
class-name
'null
)
;; global variables
(
setf
(
get
slot-name
:owning
)
value
)
(
let
((
entry
(
assoc
slot-name
(
get
class-name
:ownings
))))
(
if
entry
(
progn
(
setf
(
cdr
entry
)
value
)
(
loop
for
c
in
(
class-direct-subclasses
(
find-class
class-name
))
do
(
setf
(
md-slot-owning?
(
class-name
c
)
slot-name
)
value
)))
(
push
(
cons
slot-name
value
)
(
get
class-name
:ownings
))))))
(
progn
(
bif
(
entry
(
assoc
slot-name
(
get
class-name
:direct-ownings
)))
(
setf
(
cdr
entry
)
value
)
(
push
(
cons
slot-name
value
)
(
get
class-name
:direct-ownings
)))
; -- propagate to derivatives ...
(
labels
((
clear-subclass-ownings
(
c
)
(
loop
for
sub-c
in
(
class-direct-subclasses
c
)
for
sub-c-name
=
(
c-class-name
sub-c
)
do
(
setf
(
get
sub-c-name
:indirect-ownings
)
(
delete
slot-name
(
get
sub-c-name
:indirect-ownings
)
:key
'car
))
;; forces redecide
(
setf
(
get
sub-c-name
:model-ownings
)
nil
)
;; too much forcing full recalc like this?
(
clear-subclass-ownings
sub-c
))))
(
clear-subclass-ownings
(
find-class
class-name
))))))
(
defun
md-owning-slots
(
self
&aux
(
st
(
type-of
self
)))
(
or
(
get
st
:model-ownings
)
(
setf
(
get
st
:model-ownings
)
(
loop
for
s
in
(
class-slots
(
class-of
self
))
for
sn
=
(
slot-definition-name
s
)
when
(
and
(
md-slot-cell-type
st
sn
)
(
md-slot-owning?
st
sn
))
collect
sn
))))
(
defun
md-slot-value-store
(
self
slot-name
new-value
)
(
trc
nil
"md-slot-value-store"
self
slot-name
new-value
)
...
...
propagate.lisp
View file @
be395425
...
...
@@ -42,6 +42,8 @@ See the Lisp Lesser GNU Public License for more details.
(
declare
(
ignorable
pulse-info
))
(
unless
*one-pulse?*
(
trc
nil
"data-pulse-next > "
(
1+
*data-pulse-id*
)
pulse-info
)
(
when
*c-debug*
(
push
(
list
:data-pulse-next
pulse-info
)
*istack*
))
(
incf
*data-pulse-id*
)))
(
defun
c-currentp
(
c
)
...
...
@@ -106,11 +108,15 @@ See the Lisp Lesser GNU Public License for more details.
(
when
(
and
prior-value-supplied
prior-value
(
md-slot-owning?
(
type-of
(
c-model
c
))
(
c-slot-name
c
)))
(
trc
nil
"c.propagate> contemplating lost"
)
(
trc
nil
"c.propagate> contemplating lost"
c
)
(
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
))
(
loop
for
l
in
lost
when
(
numberp
l
)
do
(
break
"got num ~a"
(
list
l
(
type-of
(
c-model
c
))(
c-slot-name
c
)
(
md-slot-owning?
(
type-of
(
c-model
c
))
(
c-slot-name
c
)))))
(
mapcar
'not-to-be
lost
))
(
trc
nil
"no owned lost!!!!!"
))))
...
...
utils-kt/core.lisp
View file @
be395425
...
...
@@ -18,7 +18,8 @@ See the Lisp Lesser GNU Public License for more details.
(
in-package
:utils-kt
)
(
defmacro
with-gensyms
((
&rest
symbols
)
&body
body
)
`
(
let
,
(
mapcar
#'
(
lambda
(
sym
)
`
(
,
sym
(
gensym
,
(
string
sym
))))
symbols
)
`
(
let
,
(
loop
for
sym
in
symbols
collecting
`
(
,
sym
(
gensym
,
(
string
sym
))))
,@
body
))
(
defmacro
eval-now!
(
&body
body
)
...
...
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