Commit 8a6d5ccd authored by Dave Cooper's avatar Dave Cooper
Browse files

implemented snap/restore, apparently works with tasty.

parent c160e213
......@@ -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)
......
......@@ -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)
......
......@@ -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
......
......@@ -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!)
)
;;
......
......@@ -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)()
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment