Commit dd4f7b5b authored by Dave Cooper's avatar Dave Cooper

added without-redefinition-warnings

parent 6d4376c2
......@@ -11,79 +11,82 @@
NOTE: This patch is superseded by p004.")
(define-object-amendment vanilla-mixin* ()
:functions
(("Void. Uncaches all cached data in slots and objects throughout the instance
(#+allegro
excl:without-redefinition-warnings
#-allegro progn
(define-object-amendment vanilla-mixin* ()
: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))
(let ((all-messages (the (:message-list)))
(methods (the (:message-list :category :functions)))
(immune-messages (list :$$ta2 :$$ta2-object
:$$tatu :$$tatu-object))
;;
;; FLAG -- get rid of special-casing and ignore-errors for root-object-object.
;;
(root-object-object-vt
(when (and (ignore-errors (the root-object-object))
(not (eql (the root-object-object) self)))
(mapcar #'(lambda(path)
(when (consp (rest path))
(cons (append (first path) (list :root-object-object))
(rest path))))
(gdl-acc::%version-tree% (ignore-errors (the root-object-object)))))))
(let ((cached-messages
(set-difference all-messages (append methods immune-messages))))
update!
(&key (replace-bashed-values? t))
(let ((all-messages (the (:message-list)))
(methods (the (:message-list :category :functions)))
(immune-messages (list :$$ta2 :$$ta2-object
:$$tatu :$$tatu-object))
;;
;; FLAG -- get rid of special-casing and ignore-errors for root-object-object.
;;
(root-object-object-vt
(when (and (ignore-errors (the root-object-object))
(not (eql (the root-object-object) self)))
(mapcar #'(lambda(path)
(when (consp (rest path))
(cons (append (first path) (list :root-object-object))
(rest path))))
(gdl-acc::%version-tree% (ignore-errors (the root-object-object)))))))
(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))
(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 (if (and (the parent)
(ignore-errors (the parent root-object-object))
(eql (the parent root-object-object) self))
(remove-if-not #'(lambda(path)
(eql (lastcar (first path))
:root-object-object))
(gdl-acc::%version-tree% (the parent)))
(gdl-acc::%version-tree% (the root))))
(version-tree (if (and (the parent)
(ignore-errors (the parent root-object-object))
(eql (the parent root-object-object) self))
(remove-if-not #'(lambda(path)
(eql (lastcar (first path))
:root-object-object))
(gdl-acc::%version-tree% (the parent)))
(gdl-acc::%version-tree% (the root))))
(version-tree
(when replace-bashed-values?
(append
(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))))
version-tree)
root-object-object-vt))))
(version-tree
(when replace-bashed-values?
(append
(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))))
version-tree)
root-object-object-vt))))
(when *debug?* (print-variables version-tree))
(dolist (version-node version-tree (values))
(let ((root (the root))
(root-path (first version-node)) (value-plist (rest version-node)))
(mapc #'(lambda(key value)
(when *debug?* (print-variables version-tree))
(dolist (version-node version-tree (values))
(let ((root (the 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).
;;
(with-error-handling (:timeout nil)
(the-object root (:follow-root-path root-path)
(:set-slot! key value)))))
(plist-keys value-plist) (plist-values value-plist)))))))))
(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)))))
(plist-keys value-plist) (plist-values value-plist))))))))))
(format t "~&~%Changes in 1588p002:~%~%~a~%~%" *1588p002-doc*)
......
......@@ -4,47 +4,53 @@
"Fix restore-slot-default to blank out version information at the true root
in the case that we are a root-object-object child of true parent.")
(define-object-amendment vanilla-mixin* ()
:functions
(("NIL. Restores the value of the given slot to its default, thus ``undoing'' any forcibly set value
(#+allegro
excl:without-redefinition-warnings
#-allegro progn
(define-object-amendment vanilla-mixin* ()
:functions
(("NIL. Restores the value of the given slot to its default, thus ``undoing'' any forcibly set value
in the slot. 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 to normal Lisp functional evaluation rules.
:arguments (slot \"Keyword Symbol\")
:key (force? \"Boolean. Specify as t if you want to force non-settable slots to recompute (e.g.
reading from databases or external files). Defaults to nil.\")"
restore-slot-default!
(attribute &key (force? *force-restore-slot-default?*))
(when (or force? (eql (the (slot-status attribute)) :set))
(let (*leaf-resets*)
(let ((slot (glisp:intern (symbol-name attribute) :gdl-acc)))
(unless (eq (first (ensure-list (slot-value self slot))) 'gdl-rule::%unbound%)
(unbind-dependent-slots self slot)
(setf (slot-value self slot)
(if *remember-previous-slot-values?*
(list 'gdl-rule::%unbound% nil nil (first (slot-value self slot)))
'gdl-rule::%unbound%))))
(let ((root (let ((maybe-root (the :root)))
(if (the-object maybe-root root?)
maybe-root
(the-object maybe-root parent))))
restore-slot-default!
(attribute &key (force? *force-restore-slot-default?*))
(when (or force? (eql (the (slot-status attribute)) :set))
(let (*leaf-resets*)
(let ((slot (glisp:intern (symbol-name attribute) :gdl-acc)))
(unless (eq (first (ensure-list (slot-value self slot))) 'gdl-rule::%unbound%)
(unbind-dependent-slots self slot)
(setf (slot-value self slot)
(if *remember-previous-slot-values?*
(list 'gdl-rule::%unbound% nil nil (first (slot-value self slot)))
'gdl-rule::%unbound%))))
(let ((root (let ((maybe-root (the :root)))
(if (the-object maybe-root root?)
maybe-root
(the-object maybe-root parent))))
;;(root-path (remove :root-object-object (the root-path)))
(root-path (the root-path))
;;(root-path (remove :root-object-object (the root-path)))
(root-path (the root-path))
)
;;
;; FLAG -- this pushnew should never be necessary...
;;
(pushnew (list root-path)
(gdl-acc::%version-tree% root) :test #'equalp :key #'(lambda(item) (list (first item))))
(setf (rest (assoc root-path (gdl-acc::%version-tree% root) :test #'equalp))
(remove-plist-key (rest (assoc root-path
(gdl-acc::%version-tree% root) :test #'equalp)) attribute)))
(when *eager-setting-enabled?*
(dolist (reset *leaf-resets*)
(the-object (first reset) (evaluate (second reset))))))))))
)
;;
;; FLAG -- this pushnew should never be necessary...
;;
(pushnew (list root-path)
(gdl-acc::%version-tree% root) :test #'equalp :key #'(lambda(item) (list (first item))))
(setf (rest (assoc root-path (gdl-acc::%version-tree% root) :test #'equalp))
(remove-plist-key (rest (assoc root-path
(gdl-acc::%version-tree% root) :test #'equalp)) attribute)))
(when *eager-setting-enabled?*
(dolist (reset *leaf-resets*)
(the-object (first reset) (evaluate (second reset)))))))))))
(format t "~&~%Changes in 1588p003:~%~%~a~%~%" *1588p003-doc*)
This diff is collapsed.
......@@ -4,21 +4,25 @@
" Fix the order of the returned u,v point for the point function of uv-iso-curve.")
(define-object uv-iso-curve ()
(#+allegro
excl:without-redefinition-warnings
#-allegro progn
(define-object uv-iso-curve ()
:documentation (:description "Convenience object to return UV parameter values on surface.")
:documentation (:description "Convenience object to return UV parameter values on surface.")
:input-slots (surface parameter u-or-v)
:input-slots (surface parameter u-or-v)
:functions
(("2D point. The UV surface representation at the given parameter value.
:functions
(("2D point. The UV surface representation at the given parameter value.
:arguments (parameter \"Number. The parameter value you want.\")"
point
(parameter)
(ecase (the u-or-v)
(:v (make-point (the parameter) parameter))
(:u (make-point parameter (the parameter)))))))
point
(parameter)
(ecase (the u-or-v)
(:v (make-point (the parameter) parameter))
(:u (make-point parameter (the parameter))))))))
......@@ -4,108 +4,112 @@
" Keep the items in internal %version-tree% sorted based on root-path length.")
(define-object-amendment vanilla-mixin* ()
(#+allegro
excl:without-redefinition-warnings
#-allegro progn
:functions
(("NIL. Restores the value of the given slot to its default, thus ``undoing'' any forcibly set value
(define-object-amendment vanilla-mixin* ()
:functions
(("NIL. Restores the value of the given slot to its default, thus ``undoing'' any forcibly set value
in the slot. 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 to normal Lisp functional evaluation rules.
:arguments (slot \"Keyword Symbol\")
:key (force? \"Boolean. Specify as t if you want to force non-settable slots to recompute (e.g.
reading from databases or external files). Defaults to nil.\")"
restore-slot-default!
(attribute &key (force? *force-restore-slot-default?*))
(when (or force? (eql (the (slot-status attribute)) :set))
(let (*leaf-resets*)
(let ((slot (glisp:intern (symbol-name attribute) :gdl-acc)))
(unless (eq (first (ensure-list (slot-value self slot))) 'gdl-rule::%unbound%)
(unbind-dependent-slots self slot)
(setf (slot-value self slot)
(if *remember-previous-slot-values?*
(list 'gdl-rule::%unbound% nil nil (first (slot-value self slot)))
'gdl-rule::%unbound%))))
(let ((root (let ((maybe-root (the :root)))
(if (the-object maybe-root root?)
maybe-root
(the-object maybe-root parent))))
restore-slot-default!
(attribute &key (force? *force-restore-slot-default?*))
(when (or force? (eql (the (slot-status attribute)) :set))
(let (*leaf-resets*)
(let ((slot (glisp:intern (symbol-name attribute) :gdl-acc)))
(unless (eq (first (ensure-list (slot-value self slot))) 'gdl-rule::%unbound%)
(unbind-dependent-slots self slot)
(setf (slot-value self slot)
(if *remember-previous-slot-values?*
(list 'gdl-rule::%unbound% nil nil (first (slot-value self slot)))
'gdl-rule::%unbound%))))
(let ((root (let ((maybe-root (the :root)))
(if (the-object maybe-root root?)
maybe-root
(the-object maybe-root parent))))
;;(root-path (remove :root-object-object (the root-path)))
(root-path (the root-path))
;;(root-path (remove :root-object-object (the root-path)))
(root-path (the root-path))
)
;;
;; FLAG -- this pushnew should never be necessary...
;;
(pushnew (list root-path)
(gdl-acc::%version-tree% root) :test #'equalp :key #'(lambda(item) (list (first item))))
(setf (rest (assoc root-path (gdl-acc::%version-tree% root) :test #'equalp))
(remove-plist-key (rest (assoc root-path
(gdl-acc::%version-tree% root) :test #'equalp)) attribute))
)
;;
;; FLAG -- this pushnew should never be necessary...
;;
(pushnew (list root-path)
(gdl-acc::%version-tree% root) :test #'equalp :key #'(lambda(item) (list (first item))))
(setf (rest (assoc root-path (gdl-acc::%version-tree% root) :test #'equalp))
(remove-plist-key (rest (assoc root-path
(gdl-acc::%version-tree% root) :test #'equalp)) attribute))
(setf (gdl-acc::%version-tree% root)
(sort (gdl-acc::%version-tree% root)
#'(lambda(item1 item2)
(< (length (first item1)) (length (first item2)))))))
(setf (gdl-acc::%version-tree% root)
(sort (gdl-acc::%version-tree% root)
#'(lambda(item1 item2)
(< (length (first item1)) (length (first item2)))))))
(when *eager-setting-enabled?*
(dolist (reset *leaf-resets*)
(the-object (first reset) (evaluate (second reset))))))))
(when *eager-setting-enabled?*
(dolist (reset *leaf-resets*)
(the-object (first reset) (evaluate (second reset))))))))
("Void. Writes a file containing the toplevel inputs and modified settable-slots starting from the root of the
("Void. Writes a file containing the toplevel inputs and modified settable-slots starting from the root of the
current instance. Typically this file can be read back into the system using the <tt>read-snapshot</tt> function.
:&key ((filename \"/tmp/snap.gdl\") \"String or pathname. The target file to be written.\"
(root-paths-to-ignore nil) \"List of root-paths or nil. Any objects with matching root-path will be ignored for the snapshot write.\"
)"
write-snapshot
(&key (filename "/tmp/snap.gdl") (root-paths-to-ignore nil))
write-snapshot
(&key (filename "/tmp/snap.gdl") (root-paths-to-ignore nil))
(let (*print-level*
(root-object-object? (and (the parent) (the parent root?)
(defaulting (the parent root-object-object))
(eql (the parent root-object-object) self))))
(let (*print-level*
(root-object-object? (and (the parent) (the parent root?)
(defaulting (the parent root-object-object))
(eql (the parent root-object-object) self))))
(let ((root (if root-object-object? (the root parent) (the root))))
(let ((root (if root-object-object? (the root parent) (the root))))
(setf (gdl-acc::%version-tree% root)
(sort (gdl-acc::%version-tree% root)
#'(lambda(item1 item2)
(< (length (first item1)) (length (first item2))))))
(setf (gdl-acc::%version-tree% root)
(sort (gdl-acc::%version-tree% root)
#'(lambda(item1 item2)
(< (length (first item1)) (length (first item2))))))
(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 (first node)) (value-plist (rest node)))
(unless (or (member root-path root-paths-to-ignore :test #'equalp)
(and root-object-object?
(not (eql (lastcar root-path) :root-object-object))))
(when root-object-object?
(setq root-path (if (consp (rest root-path))
(butlast root-path)
(the type))))
(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))))))
(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 (first node)) (value-plist (rest node)))
(unless (or (member root-path root-paths-to-ignore :test #'equalp)
(and root-object-object?
(not (eql (lastcar root-path) :root-object-object))))
(when root-object-object?
(setq root-path (if (consp (rest root-path))
(butlast root-path)
(the type))))
(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% root) (list nil))))))
filename)))
(or (gdl-acc::%version-tree% root) (list nil))))))
filename))))
......@@ -24,22 +24,26 @@
(#+allegro
excl:without-package-locks #-allegro progn
(#+allegro
excl:without-redefinition-warnings
#-allegro progn
(define-object-amendment stitched-solid ()
(define-object-amendment stitched-solid ()
:input-slots
(("Number. The tolerance to use for creating the brep and for sewing. Larger number is looser tolerance
:input-slots
(("Number. The tolerance to use for creating the brep and for sewing. Larger number is looser tolerance
and more likely to lead to success. Default is 0.0 which uses the SMLib defaults."
tolerance 0.0))
tolerance 0.0))
:computed-slots
((%native-brep% (progn (when (or (the trimmed-surfaces) (the proper-faces))
(error "stitched-solid is currently only implemented for plain untrimmed surfaces"))
(make-stitched-solid-brep *geometry-kernel*
:tolerance (the tolerance)
:surfaces (the plain-surfaces)
:proper-faces nil)))))
:computed-slots
((%native-brep% (progn (when (or (the trimmed-surfaces) (the proper-faces))
(error "stitched-solid is currently only implemented for plain untrimmed surfaces"))
(make-stitched-solid-brep *geometry-kernel*
:tolerance (the tolerance)
:surfaces (the plain-surfaces)
:proper-faces nil)))))
(define-object-amendment boolean-merge ()
......@@ -107,5 +111,5 @@ resulting brep. This defaults to t for merge operation and nil otherwise."
((:difference :union :intersection :merge)
(list :merge-container merge-container :native-brep current-brep))
(:extract_separate (list :merge-container merge-container :native-breps current-breps)))))))))
(:extract_separate (list :merge-container merge-container :native-breps current-breps))))))))))
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