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
gendl
gendl
Commits
8a6d5ccd
Commit
8a6d5ccd
authored
Apr 07, 2013
by
Dave Cooper
Browse files
implemented snap/restore, apparently works with tasty.
parent
c160e213
Changes
5
Hide whitespace changes
Inline
Side-by-side
base/rest/source/utilities.lisp
View file @
8a6d5ccd
...
...
@@ -505,15 +505,18 @@ CL \"fround\" function.
(
defmethod
readable-expression
((
object
hash-table
)
&optional
self
)
(
declare
(
ignore
self
))
(
warn
"Hash Tables cannot currently be written out and read back into GDL reliably.
Please do not use hash tables as the value for toplevel inputs or settable slots."
)
:%unreadable%
)
(
defmethod
readable-expression
((
object
cons
)
&optional
self
)
(
declare
(
ignore
self
))
(
with-error-handling
(
:timeout
nil
)
`
(
list
,@
(
mapcar
#'
readable-expression
object
))))
(
let
(
keys
vals
)
(
maphash
#'
(
lambda
(
key
val
)
(
push
key
keys
)
(
push
val
vals
))
object
)
`
(
let
((
ht
(
make-hash-table
)))
(
mapc
#'
(
lambda
(
key
val
)
(
setf
(
gethash
key
ht
)
val
))
,
(
readable-expression
(
nreverse
keys
)
self
)
,
(
readable-expression
(
nreverse
vals
)
self
))
ht
)))
(
defmethod
readable-expression
((
object
cons
)
&optional
self
)
(
with-error-handling
(
:timeout
nil
)
`
(
list
,@
(
mapcar
#'
(
lambda
(
expr
)
(
readable-expression
expr
self
))
object
))))
(
defmethod
readable-expression
((
object
number
)
&optional
self
)
(
declare
(
ignore
self
))
object
)
(
defmethod
readable-expression
((
object
string
)
&optional
self
)
(
declare
(
ignore
self
))
object
)
...
...
base/rest/source/vanilla-mixin.lisp
View file @
8a6d5ccd
...
...
@@ -471,11 +471,15 @@ make a fresh root-level object, and start again."))
(
setf
(
slot-value
self
slot
)
(
list
value
nil
t
)))
(
when
remember?
(
let
((
root
(
the
:root
))
(
root-path
(
remove
:root-object-object
(
the
root-path
))
;;(the root-path)
))
(
let
((
root
(
let
((
maybe-root
(
the
:root
)))
(
if
(
the-object
maybe-root
root?
)
maybe-root
(
the-object
maybe-root
parent
))))
(
root-path
(
the
root-path
)
;;(remove :root-object-object (the root-path))
;;(the root-path)
))
(
pushnew
(
list
root-path
)
(
gdl-acc::%version-tree%
root
)
:test
#'
equalp
...
...
@@ -701,34 +705,35 @@ current instance. Typically this file can be read back into the system using the
)"
write-snapshot
(
&key
(
filename
"/tmp/snap.gdl"
)
(
root-paths-to-ignore
nil
))
(
with-open-file
(
out
filename
:direction
:output
:if-exists
:supersede
:if-does-not-exist
:create
)
(
print
`
(
in-package
,
(
make-keyword
(
package-name
*package*
)))
out
)
(
mapcar
#'
(
lambda
(
node
)
(
let
((
root-path
(
or
(
first
node
)
(
the
type
)))
(
value-plist
(
rest
node
)))
(
unless
(
member
root-path
root-paths-to-ignore
:test
#'
equalp
)
(
let
((
keys
(
plist-keys
value-plist
))
(
values
(
plist-values
value-plist
)))
(
let
((
snap
(
cons
root-path
(
append
(
when
(
atom
root-path
)
(
let
(
result
)
(
let*
((
toplevel-inputs
(
remove-plist-key
(
the
root
active-inputs
)
:remote-id
))
(
toplevel-input-keys
(
plist-keys
toplevel-inputs
))
(
toplevel-input-values
(
plist-values
toplevel-inputs
)))
(
mapc
#'
(
lambda
(
key
value
)
(
when
(
not
(
member
key
keys
))
(
push
key
result
)
(
push
value
result
)))
toplevel-input-keys
toplevel-input-values
))
(
nreverse
result
)))
(
mapcan
#'
(
lambda
(
key
val
)
(
let
((
expression
(
readable-expression
val
self
)))
(
unless
(
eql
expression
:%unreadable%
)
(
list
key
expression
))))
keys
values
)))))
(
print
snap
out
))))))
(
or
(
gdl-acc::%version-tree%
(
the
root
))
(
list
nil
))))
(
values
))
(
let
(
*print-level*
)
(
with-open-file
(
out
filename
:direction
:output
:if-exists
:supersede
:if-does-not-exist
:create
)
(
print
`
(
in-package
,
(
make-keyword
(
package-name
*package*
)))
out
)
(
mapcar
#'
(
lambda
(
node
)
(
let
((
root-path
(
or
(
first
node
)
(
the
type
)))
(
value-plist
(
rest
node
)))
(
unless
(
member
root-path
root-paths-to-ignore
:test
#'
equalp
)
(
let
((
keys
(
plist-keys
value-plist
))
(
values
(
plist-values
value-plist
)))
(
let
((
snap
(
cons
root-path
(
append
(
when
(
atom
root-path
)
(
let
(
result
)
(
let*
((
toplevel-inputs
(
remove-plist-key
(
the
root
active-inputs
)
:remote-id
))
(
toplevel-input-keys
(
plist-keys
toplevel-inputs
))
(
toplevel-input-values
(
plist-values
toplevel-inputs
)))
(
mapc
#'
(
lambda
(
key
value
)
(
when
(
not
(
member
key
keys
))
(
push
key
result
)
(
push
value
result
)))
toplevel-input-keys
toplevel-input-values
))
(
nreverse
result
)))
(
mapcan
#'
(
lambda
(
key
val
)
(
let
((
expression
(
readable-expression
val
self
)))
(
unless
(
eql
expression
:%unreadable%
)
(
list
key
expression
))))
keys
values
)))))
(
print
snap
out
))))))
(
or
(
gdl-acc::%version-tree%
(
the
root
))
(
list
nil
)))))
filename
)
...
...
base/source/utilities.lisp
View file @
8a6d5ccd
...
...
@@ -212,6 +212,10 @@ You have a dependency on caffeine. Your children are your dependants.
(
let
((
value
(
gensym
))
(
need?
(
gensym
)))
(
defmacro
with-dependency-tracking
((
message-symbol
&optional
(
self-sym
'self
))
&rest
body
)
`
(
let
((
,
value
(
,
message-symbol
,
self-sym
))
;;
;; FLAG - this gets invoked far too often - must analyze this. Also, *root-checking-enabled*
; should result in need defaulting to t, not nil, and the same-tree check being skipped.
;;
(
,
need?
(
and
*run-with-dependency-tracking?*
*notify-cons*
*root-checking-enabled?*
;;
;; FLAG -- check that remotes are effectively from same tree as well
...
...
gwl/ajax/source/ajax.lisp
View file @
8a6d5ccd
...
...
@@ -59,12 +59,11 @@
(
the-object
new-self
set-instantiation-time!
)
(
the-object
new-self
set-time-last-touched!
)
;;
;;(defaulting (the-object self custom-restore-function))
;;
(
format
t
"~%~%*************** Session ~a Restarted! ***************~%~%"
(
the-object
new-self
instance-id
))
(
the-object
new-self
tree-manager
restore-design-state!
)
(
format
t
"~%~%*************** Session ~a Restarted! ***************~%~%"
(
the-object
new-self
instance-id
))
(
the-object
new-self
custom-snap-restore!
)
)
;;
...
...
gwl/ajax/source/base-ajax-sheet.lisp
View file @
8a6d5ccd
...
...
@@ -297,7 +297,16 @@ interface. Defaults to nil."
(
progn
(
set-self
self
)
(
let
((
*package*
(
symbol-package
(
the
type
))))
(
break
)))
(
progn
(
set-self
self
))))))
(
set-self
self
))))
(
"Void. This is a hook function which applications can use to restore automatically
from a saved snapshot file."
custom-snap-restore!
()
)
))
(
define-lens
(
html-format
base-ajax-sheet
)()
...
...
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