Commit b39c1c33 authored by Dave Cooper's avatar Dave Cooper

merged remaining patches from 1588 and 1590

parent 84c8c626
......@@ -753,6 +753,64 @@ file.
:make-object-args make-object-args :keys-to-ignore keys-to-ignore))))))
(defun read-snapshot-from-stream (in &key object keep-bashed-values? make-object-args keys-to-ignore)
(let ((package-form (read in)))
(when (or (null package-form) (not (find-package (second package-form))))
(error "Invalid package specification at beginning of ~a.~%" filename))
(let* ((*package* (find-package (second package-form))) (root-form (read in)))
(when (or (null root-form)
(not (eql (class-of (find-class (first root-form))) (find-class 'gdl-class))))
(error "Invalid object type specifier as first element of second form in ~a.~%" root-form))
(let* ((object (cond ((and object keep-bashed-values?) object)
(object (the-object object restore-tree!) object)
(t (progn
(apply #'make-object (first root-form) make-object-args))))))
(let ((self object) (value-plist (rest root-form)))
(mapc #'(lambda(key expression)
(unless (member key keys-to-ignore)
(when self (the-object self (set-slot! key (eval expression) :re-sort? nil)))))
(plist-keys value-plist) (plist-values value-plist)))
(let (forms)
(do ((form (read in nil nil) (read in nil nil)))
((null form) forms)
(push form forms))
(setq forms (nreverse forms))
(let* ((forms (double-length-sort forms))
(primaries (remove-if-not #'(lambda(item) (or (getf (rest item) :%primary?%)
(getf (rest item) :element-index-list))) forms))
(non-primaries (remove-if #'(lambda(item) (or (getf (rest item) :%primary?%)
(getf (rest item) :element-index-list))) forms))
(forms (append primaries non-primaries)))
(dolist (form forms)
(let ((root-path (first form)) (value-plist (rest form)))
(let ((self
(with-error-handling (:timeout nil)
(the-object object (follow-root-path root-path)))))
(when self
(mapc #'(lambda(key expression)
(unless (member key keys-to-ignore)
(the-object self (set-slot! key (eval `(let ((self ,self)) ,expression)) :re-sort? nil))))
(plist-keys value-plist) (plist-values value-plist))))))))
object))))
#+nil
(defun read-snapshot-from-stream (in &key object keep-bashed-values? make-object-args keys-to-ignore)
(let (forms)
......
......@@ -575,7 +575,7 @@ Note that this behavior may change to error by default in a future GDL release.
"
message))
(cerror "Set the slot anyway." message))))
(cerror "Set the slot anyway." message))))
(when (and warn-on-non-toplevel?
*notify-cons*)
......@@ -611,16 +611,16 @@ make a fresh root-level object, and start again."))
(let ((slot (glisp:intern (symbol-name attribute) :gdl-acc)))
(unbind-dependent-slots self slot)
(setf (slot-value self slot)
(list value nil t)))
(list value nil t)))
(when remember?
(let ((root (let ((maybe-root (the :root)))
(if (the-object maybe-root root?)
maybe-root
(the-object maybe-root parent))))
(the-object maybe-root parent))))
(root-path (the root-path)
;;(remove :root-object-object (the root-path))
;;(the root-path)
))
;;(remove :root-object-object (the root-path))
;;(the root-path)
))
(cond ((and (gdl-acc::%version-tree% root)
(not (find root-path (gdl-acc::%version-tree% root)
......@@ -629,16 +629,16 @@ make a fresh root-level object, and start again."))
(list (list root-path))))
((null (gdl-acc::%version-tree% root))
(setf (gdl-acc::%version-tree% root)
(list (list root-path)))))
(list (list root-path)))))
(when (the primary?)
(setf (getf (rest (assoc root-path (gdl-acc::%version-tree% root) :test #'equalp)) :%primary?%)
t))
t))
(when re-sort?
(setf (gdl-acc::%version-tree% root)
(double-length-sort (gdl-acc::%version-tree% root)))
(double-length-sort (gdl-acc::%version-tree% root)))
(let ((non-root (remove nil (gdl-acc::%version-tree% root) :key #'first))
(root-list (find nil (gdl-acc::%version-tree% root) :key #'first)))
......@@ -651,11 +651,11 @@ make a fresh root-level object, and start again."))
(getf (rest item) :element-index-list)))
non-root)))
(setf (gdl-acc::%version-tree% root)
(cons (or root-list (list nil))
(append primaries non-primaries))))))
(cons (or root-list (list nil))
(append primaries non-primaries))))))
(setf (getf (rest (assoc root-path (gdl-acc::%version-tree% root) :test #'equalp)) attribute)
value)))
value)))
(when *eager-setting-enabled?*
(dolist (reset *leaf-resets*)
......@@ -898,52 +898,52 @@ demanded. This is useful for updating an existing model or part of an existing
model after making changes and recompiling/reloading the code of the underlying
definitions. Any set (modified) slot values will, however, be preserved
by the update."
update!
(&key (replace-bashed-values? t) immune-message-keys)
(let ((all-messages (the (:message-list)))
(methods (the (:message-list :category :functions)))
(immune-messages (append (list :$$ta2 :$$ta2-object
:$$tatu :$$tatu-object)
(ensure-list immune-message-keys)))
(true-root (if (and (the root parent) (the root parent root?)
(defaulting (the root parent root-object-object))
(eql (the root parent root-object-object) self))
(the root parent) (the root))))
(let ((cached-messages
(set-difference all-messages (append methods immune-messages))))
update!
(&key (replace-bashed-values? t) immune-message-keys)
(let ((all-messages (the (:message-list)))
(methods (the (:message-list :category :functions)))
(immune-messages (append (list :$$ta2 :$$ta2-object
:$$tatu :$$tatu-object)
(ensure-list immune-message-keys)))
(true-root (if (and (the root parent) (the root parent root?)
(defaulting (the root parent root-object-object))
(eql (the root parent root-object-object) self))
(the root parent) (the root))))
(let ((cached-messages
(set-difference all-messages (append methods immune-messages))))
(dolist (key cached-messages)
(let ((key (glisp:intern (symbol-name key) :gdl-acc)))
(unbind-dependent-slots self key :updating? t))))
(let* ( ;;(root-path (remove :root-object-object (the root-path)))
(root-path (the root-path))
(root-path-length (length root-path))
(version-tree
(when replace-bashed-values?
(remove-if-not #'(lambda(node)
(let ((local-root-path (first node)))
(and (> (length local-root-path) root-path-length)
(equalp (subseq local-root-path
(- (length local-root-path)
root-path-length))
root-path))))
(gdl-acc::%version-tree% true-root)))))
(dolist (version-node version-tree (values))
(let ((root true-root)
(root-path (first version-node)) (value-plist (rest version-node)))
(mapc #'(lambda(key value)
(dolist (key cached-messages)
(let ((key (glisp:intern (symbol-name key) :gdl-acc)))
(unbind-dependent-slots self key :updating? t))))
(let* ( ;;(root-path (remove :root-object-object (the root-path)))
(root-path (the root-path))
(root-path-length (length root-path))
(version-tree
(when replace-bashed-values?
(remove-if-not #'(lambda(node)
(let ((local-root-path (first node)))
(and (> (length local-root-path) root-path-length)
(equalp (subseq local-root-path
(- (length local-root-path)
root-path-length))
root-path))))
(gdl-acc::%version-tree% true-root)))))
(dolist (version-node version-tree (values))
(let ((root true-root)
(root-path (first version-node)) (value-plist (rest version-node)))
(mapc #'(lambda(key value)
(when (not (eql value 'gdl-acc::%default%))
;;
;; FLAG - make this into a more specific error check for
;; nonexistence of the object (e.g. not handled error).
;;
(when (not (eql value 'gdl-acc::%default%))
;;
;; FLAG - make this into a more specific error check for
;; nonexistence of the object (e.g. not handled error).
;;
(with-error-handling (:timeout nil)
(the-object root (:follow-root-path root-path)
(:set-slot! key value :re-sort? nil)))))
(plist-keys value-plist) (plist-values value-plist)))))))
(with-error-handling (:timeout nil)
(the-object root (:follow-root-path root-path)
(:set-slot! key value :re-sort? nil)))))
(plist-keys value-plist) (plist-values value-plist)))))))
;;
......
......@@ -182,7 +182,7 @@ those dependent objects first. Default is nil.
)
:trickle-down-slots (respondent)
;;:trickle-down-slots (respondent)
:computed-slots
......
......@@ -102,7 +102,10 @@ mixes this in, or in a <tt>main-sheet</tt> output-function in an html-format vi
object.")
:input-slots
((respondent (the bashee) :defaulting)
(
;;(respondent (the bashee) :defaulting)
(respondent (the bashee))
("GDL object. Default object to which control will return with the write-back-link method"
return-object (the :parent))
......
......@@ -19,64 +19,64 @@ and stored in version-tree root data structure")
#-allegro progn
(define-object-amendment vanilla-mixin* ()
(define-object-amendment vanilla-mixin* ()
:functions
(("Void. Uncaches all cached data in slots and objects throughout the instance
:functions
(("Void. Uncaches all cached data in slots and objects throughout the instance
tree from this node, forcing all code to run again the next time values are
demanded. This is useful for updating an existing model or part of an existing
model after making changes and recompiling/reloading the code of the underlying
definitions. Any set (modified) slot values will, however, be preserved
by the update."
update!
(&key (replace-bashed-values? t) immune-message-keys)
(let ((all-messages (the (:message-list)))
(methods (the (:message-list :category :functions)))
(immune-messages (append (list :$$ta2 :$$ta2-object
:$$tatu :$$tatu-object)
(ensure-list immune-message-keys)))
(true-root (if (and (the root parent) (the root parent root?)
(defaulting (the root parent root-object-object))
(eql (the root parent root-object-object) self))
(the root parent) (the root))))
(let ((cached-messages
(set-difference all-messages (append methods immune-messages))))
update!
(&key (replace-bashed-values? t) immune-message-keys)
(let ((all-messages (the (:message-list)))
(methods (the (:message-list :category :functions)))
(immune-messages (append (list :$$ta2 :$$ta2-object
:$$tatu :$$tatu-object)
(ensure-list immune-message-keys)))
(true-root (if (and (the root parent) (the root parent root?)
(defaulting (the root parent root-object-object))
(eql (the root parent root-object-object) self))
(the root parent) (the root))))
(let ((cached-messages
(set-difference all-messages (append methods immune-messages))))
(dolist (key cached-messages)
(let ((key (glisp:intern (symbol-name key) :gdl-acc)))
(unbind-dependent-slots self key :updating? t))))
(let* ( ;;(root-path (remove :root-object-object (the root-path)))
(root-path (the root-path))
(root-path-length (length root-path))
(version-tree
(when replace-bashed-values?
(remove-if-not #'(lambda(node)
(let ((local-root-path (first node)))
(and (> (length local-root-path) root-path-length)
(equalp (subseq local-root-path
(- (length local-root-path)
root-path-length))
root-path))))
(gdl-acc::%version-tree% true-root)))))
(dolist (version-node version-tree (values))
(let ((root true-root)
(root-path (first version-node)) (value-plist (rest version-node)))
(mapc #'(lambda(key value)
(dolist (key cached-messages)
(let ((key (glisp:intern (symbol-name key) :gdl-acc)))
(unbind-dependent-slots self key :updating? t))))
(let* ( ;;(root-path (remove :root-object-object (the root-path)))
(root-path (the root-path))
(root-path-length (length root-path))
(version-tree
(when replace-bashed-values?
(remove-if-not #'(lambda(node)
(let ((local-root-path (first node)))
(and (> (length local-root-path) root-path-length)
(equalp (subseq local-root-path
(- (length local-root-path)
root-path-length))
root-path))))
(gdl-acc::%version-tree% true-root)))))
(dolist (version-node version-tree (values))
(let ((root true-root)
(root-path (first version-node)) (value-plist (rest version-node)))
(mapc #'(lambda(key value)
(when (not (eql value 'gdl-acc::%default%))
;;
;; FLAG - make this into a more specific error check for
;; nonexistence of the object (e.g. not handled error).
;;
(when (not (eql value 'gdl-acc::%default%))
;;
;; FLAG - make this into a more specific error check for
;; nonexistence of the object (e.g. not handled error).
;;
(with-error-handling (:timeout nil)
(the-object root (:follow-root-path root-path)
(:set-slot! key value :re-sort? nil)))))
(plist-keys value-plist) (plist-values value-plist)))))))
(with-error-handling (:timeout nil)
(the-object root (:follow-root-path root-path)
(:set-slot! key value :re-sort? nil)))))
(plist-keys value-plist) (plist-values value-plist)))))))
("NIL. Forcibly sets the value of the given slot to the given value. The slot must be defined
("NIL. Forcibly sets the value of the given slot to the given value. The slot must be defined
as <tt>:settable</tt> for this to work properly. Any dependent slots in the tree will
respond accordingly when they are next demanded. Note that the slot must be specified as a keyword
symbol (i.e. prepended with a colon (``:'')), otherwise it will be evaluated as a variable according
......@@ -116,7 +116,7 @@ Note that this behavior may change to error by default in a future GDL release.
"
message))
(cerror "Set the slot anyway." message))))
(cerror "Set the slot anyway." message))))
(when (and warn-on-non-toplevel?
*notify-cons*)
......@@ -152,16 +152,16 @@ make a fresh root-level object, and start again."))
(let ((slot (glisp:intern (symbol-name attribute) :gdl-acc)))
(unbind-dependent-slots self slot)
(setf (slot-value self slot)
(list value nil t)))
(list value nil t)))
(when remember?
(let ((root (let ((maybe-root (the :root)))
(if (the-object maybe-root root?)
maybe-root
(the-object maybe-root parent))))
(the-object maybe-root parent))))
(root-path (the root-path)
;;(remove :root-object-object (the root-path))
;;(the root-path)
))
;;(remove :root-object-object (the root-path))
;;(the root-path)
))
(cond ((and (gdl-acc::%version-tree% root)
(not (find root-path (gdl-acc::%version-tree% root)
......@@ -170,16 +170,16 @@ make a fresh root-level object, and start again."))
(list (list root-path))))
((null (gdl-acc::%version-tree% root))
(setf (gdl-acc::%version-tree% root)
(list (list root-path)))))
(list (list root-path)))))
(when (the primary?)
(setf (getf (rest (assoc root-path (gdl-acc::%version-tree% root) :test #'equalp)) :%primary?%)
t))
t))
(when re-sort?
(setf (gdl-acc::%version-tree% root)
(double-length-sort (gdl-acc::%version-tree% root)))
(double-length-sort (gdl-acc::%version-tree% root)))
(let ((non-root (remove nil (gdl-acc::%version-tree% root) :key #'first))
(root-list (find nil (gdl-acc::%version-tree% root) :key #'first)))
......@@ -192,11 +192,11 @@ make a fresh root-level object, and start again."))
(getf (rest item) :element-index-list)))
non-root)))
(setf (gdl-acc::%version-tree% root)
(cons (or root-list (list nil))
(append primaries non-primaries))))))
(cons (or root-list (list nil))
(append primaries non-primaries))))))
(setf (getf (rest (assoc root-path (gdl-acc::%version-tree% root) :test #'equalp)) attribute)
value)))
value)))
(when *eager-setting-enabled?*
(dolist (reset *leaf-resets*)
......
......@@ -88,7 +88,7 @@ and trimmed surface also mixes in face, so a trimmed-surface will answer all the
(%native-edges% (get-edges-from-face *geometry-kernel* (the %native-face%)))
(brep-id (the brep unique-id))
(brep-id (the brep %unique-id%))
)
......
......@@ -62,10 +62,10 @@ Defaults to the foreground color specified in <tt>*colors-default*</tt>. This me
(%vertex-array% (append (flatten-lines (the %lines-to-draw%)) (flatten-curves (the %curves-to-draw%))))
(unique-id (or (get-long *geometry-kernel* self)
(let ((id (read-from-string (subseq (string (gensym)) 1))))
(format t "Setting object unique-id on-demand for object ~s.~%" self)
(set-long *geometry-kernel* self id)
id)))))
(%unique-id% (or (get-long *geometry-kernel* self)
(let ((id (read-from-string (subseq (string (gensym)) 1))))
(format t "Setting object %unique-id% on-demand for object ~s.~%" self)
(set-long *geometry-kernel* self id)
id)))))
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