reserved words should be conditionally dependent on use of base-object
Created by: reiniervandijk
For objects where one doesn't use base-object, but only (implicitly) vanilla-mixin, it is wrong to cast errors for some of the so-called reserved-words that are only meaningful for base-object. For example, this will now throw an error:
(define-object A ()
:computed-slots
((vertex nil)))
**Imported comments:**
*By genworks on 2015-01-29 23:49:44 UTC*
Open for submissions: $100
*By reiniervandijk on 2015-01-30 16:00:13 UTC*
Solution rational (code below):
- Constant ``+reserved-words+`` included symbols from the base-object class. So, I took them out and isolated them in a ``+reserved-words-base-object+`` constant.
- For safety, I've now committed code with constant ``+reserved-words-vanilla+``. If you think the list makes sense, rename twice to ``+reserved-words+``.
- It was now required to test at compile-time if ``base-object`` base in the mixin-list explicitly or by inheritance.
- For this purpose, I've added a ``mixin-list`` argument to the ``reserved-word-warning-or-error`` function, which is supplied by the ``%define-object%`` macro.
- Test for ``base-object`` inheritance has been isolated in ``%base-object-subclass?%`` function.
Side note:
The ``+reserved-words+`` parameter seemed to not be up-to-date with ``vanilla-mixin*``. Moreover, I believe ``standard-sequence`` slots should also be protected. I've updated the reserved words list with **all** symbols from ``vanilla-mixin*`` and ``standard-sequence``. Please find some private routines that I made to print all messages at run-time. These functions can be used to update the reserved word constants in the future.
Code in chunks below.
1. updated and new constants
2. updated define-object code and reserved word checking
3. some utilities to generate the reserved symbol lists in the future.
*By reiniervandijk on 2015-01-30 16:00:50 UTC*
new constants:
```lisp
(in-package :gdl)
(glisp:define-constant +reserved-words-vanilla+
;; Use utility function below after bootstrap to obtain current list!
(mapcar #'(lambda(symbol)
(glisp:intern symbol :gdl-acc))
'(active-inputs
aggregate
all-mixins
array
child-types
children
children-uncached
color-hex
direct-mixins
display-controls
documentation
first
first?
follow-root-path
get-member
hidden-children
hidden?
ignore-messages-from
index
instantiated-indices
last
last?
leaf?
leaves
leaves-uncached
list-elements
list-elements-uncached
message-documentation
message-list
message-remarks
mixins
modify-attribute!
modify-attributes!
name-for-display
next
null-part?
number-of-elements
parent
parent-tree
part-documentation
previous
primary?
quantify-box
query-plist
reference-chain
remote-id
restore-all-defaults!
restore-attribute-default!
restore-attribute-defaults!
restore-node!
restore-slot-default!
restore-slot-defaults!
restore-tree!
root
root-path
root-path-local
root-path-string
root?
safe-children
safe-hidden-children
safe-list-elements
set-slot!
set-slot-if-needed!
set-slots!
show-dependency-tree
slot-documentation
slot-source
slot-status
strings-for-display
transitory-slots
type
unbind-remote-slot
update!
viewable-slots
visible-children
write-snapshot
)))
(glisp:define-constant +reserved-words-base-object+
(append +reserved-words-vanilla+
(mapcar #'(lambda(symbol)
(glisp:intern symbol :gdl-acc))
'(color-decimal
edge-center
face-center
face-normal-vector
local-center
obliqueness
vertex
))))
By reiniervandijk on 2015-01-30 16:03:22 UTC
updated define-object code and reserved word checking
(defun %base-object-subclass?% (mixin-list)
(let ((base-object-symbol (find-symbol "base-object" :geom-base)))
(when base-object-symbol
(let ((base-object-class
(find-class base-object-symbol nil)))
(when base-object-class
(some #'(lambda (mixin)
(let ((class (find-class mixin nil)))
(and class
;; RvD: consider using subtypep here
(subtypep class base-object-class))))
mixin-list))))))
(defun reserved-word-warning-or-error (name mixin-list messages)
(unless (and (atom name)
(or (member (symbol-package name) *reserved-word-protected-packages*)))
(let ((reserved-violations
(if (%base-object-subclass?% mixin-list)
(intersection messages +reserved-words-base-object+)
(intersection messages +reserved-words-vanilla+))))
(when reserved-violations
(let ((is-or-are (if (= (length reserved-violations) 1) "is" "are"))
(s-or-blank (if (= (length reserved-violations) 1) "" "s"))
(a-or-blank (if (= (length reserved-violations) 1) "a " "")))
(funcall (if *error-on-reserved-words?*
#'error
#'warn)
"The symbol~a listed below ~a ~areserved word~a and should not be used as ~a
GDL message name~a or child object input name~a.
~a.
~{ ~a~^~%~}
"
s-or-blank
is-or-are
a-or-blank
s-or-blank
a-or-blank
s-or-blank
s-or-blank
(if *error-on-reserved-words?*
"You can override this error (AT YOUR OWN RISK)
by setting *error-on-reserved-words?* to nil."
"NOTE that you are getting a warning instead of an error because
*error-on-reserved-words?* is changed from its default of t and set to nil. This is RISKY
and you should proceed this way only if you really know what you are doing.")
(safe-sort reserved-violations #'string-lessp :key #'string)))))))
(defmacro %define-object% (name mixin-list
&key input-slots
computed-slots
objects
hidden-objects
functions
methods
(no-vanilla-mixin? nil)
documentation
trickle-down-slots
query-slots
)
(with-gdl-message-symbols (:new t)
(reserved-word-warning-or-error name mixin-list messages)
(let ((message-ht (make-hash-table :size (length messages))))
(dolist (message messages)
(push message (gethash message message-ht)))
(let ((duplicates (let (duplicates)
(maphash #'(lambda(key val)(if (consp (rest val)) (push key duplicates))) message-ht) duplicates)))
(let ((duplicates (remove-if #'(lambda(dup) (member dup method-syms)) duplicates)))
(when duplicates
(error "duplicate slot name~p: ~{~a~^, ~}" (length duplicates) (sort duplicates #'string-lessp :key #'symbol-name))))))
`(progn
(defclass ,name ,(if (or no-vanilla-mixin?
(some #'(lambda(mixin)
(let ((class (find-class mixin nil)))
(and class
(member (find-class 'vanilla-mixin)
;; RvD: consider using subtypep here
(all-superclasses class))))) mixin-list))
mixin-list
(append mixin-list (list 'vanilla-mixin)))
(,@(append (make-standard-slots)
(make-accessible-slots computed-slot-syms)
(make-accessible-slots settable-computed-slot-syms)
(make-accessible-slots uncached-computed-slot-syms)
(make-accessible-slots query-slot-syms)
(make-accessible-slots object-syms)
(make-accessible-slots quantified-object-syms)
(make-accessible-slots hidden-object-syms)
(make-accessible-slots quantified-hidden-object-syms)
(make-accessible-slots cached-function-syms)
(make-accessible-slots cached-method-syms)
(make-accessible-slots required-input-slot-syms :inputs? t)
(make-accessible-slots optional-input-slot-syms :inputs? t)
(make-accessible-slots settable-input-slot-syms :inputs? t)
(make-accessible-slots defaulted-input-slot-syms :inputs? t)
(make-accessible-slots settable-defaulted-input-slot-syms :inputs? t))) (:metaclass gdl-class))
(let ((,class-arg (find-class ',name)))
(let ((,old-message-keys (messages ,class-arg))
(,new-message-keys ',messages))
(dolist (key (set-difference ,old-message-keys ,new-message-keys))
(let ((method (ignore-errors
(find-method (symbol-function (glisp:intern (symbol-name key) :gdl-slots)) nil
(list ,class-arg) nil))))
(when method
(when *report-gdl-redefinitions?*
(format t "~%Removing slot: ~a for object definition: ~s~%" key ',name))
(remove-method (symbol-function (glisp:intern (symbol-name key) :gdl-slots)) method)))))
,(when (and *compile-documentation-database?* documentation)
`(when *load-documentation-database?*
(setf (gdl-documentation ,class-arg) ',documentation))))
(when (message-documentation (find-class ',name)) (clrhash (message-documentation (find-class ',name))))
(when (message-source (find-class ',name))(clrhash (message-source (find-class ',name))))
(setf (messages (find-class ',name)) ',messages)
(setf (required-input-slots (find-class ',name)) ',required-input-slot-syms)
(setf (optional-input-slots (find-class ',name)) ',optional-input-slot-syms)
(setf (defaulted-input-slots (find-class ',name)) ',defaulted-input-slot-syms)
(setf (computed-slots (find-class ',name)) ',computed-slot-syms)
(setf (query-slots (find-class ',name)) ',query-slot-syms)
(setf (settable-computed-slots (find-class ',name)) ',settable-computed-slot-syms)
(setf (uncached-computed-slots (find-class ',name)) ',uncached-computed-slot-syms)
(setf (settable-optional-input-slots (find-class ',name)) ',settable-input-slot-syms)
(setf (settable-defaulted-input-slots (find-class ',name)) ',settable-defaulted-input-slot-syms)
(setf (functions (find-class ',name)) ',function-syms)
(setf (methods (find-class ',name)) ',method-syms)
(setf (cached-functions (find-class ',name)) ',cached-function-syms)
(setf (cached-methods (find-class ',name)) ',cached-method-syms)
(setf (objects (find-class ',name)) ',object-syms)
(setf (quantified-objects (find-class ',name)) ',quantified-object-syms)
(setf (hidden-objects (find-class ',name)) ',hidden-object-syms)
(setf (quantified-hidden-objects (find-class ',name)) ',quantified-hidden-object-syms)
(setf (trickle-down-slots (find-class ',name))
',(append object-syms quantified-object-syms hidden-object-syms quantified-hidden-object-syms trickle-down-slot-syms))
(setf (settable-slots (find-class ',name)) ',(append required-input-slot-syms settable-input-slot-syms
settable-defaulted-input-slot-syms settable-computed-slot-syms))
;; FLAG -- consider pre-cooking these expression lists
;;
,@(message-generics (set-difference messages (append method-syms cached-method-syms)))
,(input-slots-generics (append (group-remark-strings (remove-if-not #'(lambda(item)
(or (symbolp item) (stringp item)))
input-slots))
(remove-if-not #'consp input-slots)))
,@(input-slots-section name (group-remark-strings (remove-if-not #'(lambda(item)
(or (symbolp item) (stringp item)))
input-slots)))
,@(optional-input-slots-section
name (remove-if-not #'(lambda(slot) (and (consp slot) (null (rest (rest (strip-strings slot))))))
input-slots))
,@(optional-input-slots-section
name (remove-if-not
#'(lambda(slot)
(and (consp slot)
(member :settable (rest (rest (strip-strings slot))))
(not (member :defaulting (rest (rest (strip-strings slot)))))))
input-slots))
,@(optional-input-slots-section
name (remove-if-not #'(lambda(slot)
(and (consp slot)
(member :defaulting (rest (rest (strip-strings slot))))
(not (member :settable (rest (rest (strip-strings slot)))))))
input-slots) t)
,@(optional-input-slots-section
name (remove-if-not
#'(lambda(slot)
(and (consp slot)
(member :settable (rest (rest (strip-strings slot))))
(member :defaulting (rest (rest (strip-strings slot))))))
input-slots) t)
,@(computed-slots-section
name (remove-if-not #'(lambda(slot) (and (consp slot) (null (rest (rest (strip-strings slot))))))
computed-slots))
,@(computed-slots-section
name (remove-if-not #'(lambda(slot)
(and (consp slot) (eql (first (rest (rest (strip-strings slot))))
:settable)))
computed-slots))
,@(computed-slots-section name query-slots :query? t)
,@(objects-section name (append objects hidden-objects))
,@(functions-section
name (mapcar #'(lambda(slot)
(if (stringp (first slot))
(list (first slot) (second slot) nil (third slot))
(list (first slot) nil (second slot))))
(remove-if-not #'(lambda(slot) (and (consp slot) (eql (first (rest (rest (strip-strings slot))))
:uncached)))
computed-slots)))
,@(functions-section name functions)
,@(methods-section name methods)
,@(trickle-down-slots-section trickle-down-slot-syms)
,@(trickle-down-slots-section (append object-syms quantified-object-syms hidden-object-syms quantified-hidden-object-syms)
:from-objects? t)
#+nil
(defmethod gdl-rule::%object-keywords%
((,self-arg ,name))
(remove-duplicates
(append ',object-syms ',quantified-object-syms
(when (next-method-p) (call-next-method)))))
#+nil
(defmethod gdl-rule::%hidden-object-keywords%
((,self-arg ,name))
(remove-duplicates
(append ',hidden-object-syms ',quantified-hidden-object-syms
(when (next-method-p) (call-next-method)))))
;;
;; FLAG -- maybe some of these others can go away as well.
;;
(let ((,self-arg (find-class ',name nil)))
(when ,self-arg
(setf (trickle-down-effective ,self-arg) nil)))
;;
;; FLAG -- use uiop:list-to-hash-set
;;
(defmethod gdl-rule::%trickle-down-slots%
((,self-arg ,name))
(let ((class (class-of ,self-arg)))
(or (trickle-down-effective class)
(let* ((trickles (remove-duplicates
(mapcar #'make-keyword
(append ',(append object-syms quantified-object-syms hidden-object-syms
quantified-hidden-object-syms trickle-down-slot-syms)
(when (next-method-p) (list-hash (call-next-method)))))))
(ht (glisp:make-sans-value-hash-table :size (length trickles))))
(dolist (trickle trickles ht)
(setf (gethash trickle ht) t))))))
#+nil
(defmethod gdl-rule::%trickle-down-slots%
((,self-arg ,name))
(remove-duplicates
(mapcar #'make-keyword
(append ',(append object-syms quantified-object-syms hidden-object-syms
quantified-hidden-object-syms trickle-down-slot-syms)
(when (next-method-p) (call-next-method))))))
(defmethod gdl-rule::%settable-slot-list%
((,self-arg ,name))
(remove-duplicates
(mapcar #'make-keyword
(append ',(append settable-input-slot-syms
settable-defaulted-input-slot-syms
settable-computed-slot-syms)
(when (next-method-p) (call-next-method))))))
(defmethod gdl-rule::%settable-slots%
((,self-arg ,name))
(let ((,ht-arg (glisp:make-sans-value-hash-table))
(,symbols-arg (gdl-rule::%settable-slot-list% ,self-arg))
(,non-settables-arg (mapcar #'make-keyword
(set-difference (messages (find-class ',name))
(settable-slots (find-class ',name))))))
(dolist (,symbol-arg ,symbols-arg ,ht-arg)
(when (not (member ,symbol-arg ,non-settables-arg))
(setf (gethash ,symbol-arg ,ht-arg) t)))))
(defmethod gdl-rule::%message-source%
((,self-arg ,name) ,message-arg &optional (,depth-arg 0))
(let* ((method (nth ,depth-arg (compute-applicable-methods
#'gdl-rule::%message-source% (list ,self-arg ,message-arg))))
(class (first (glisp:gl-method-specializers method))))
(append (let ((local (let ((ht (message-source class)))
(when ht (gethash ,message-arg ht)))))
(when local (list (glisp:gl-class-name class) local)))
(when (next-method-p) (call-next-method ,self-arg ,message-arg (1+ ,depth-arg))))))
(defmethod gdl-rule::%message-remarks%
((,self-arg ,name) ,message-arg &optional (,depth-arg 0))
(let* ((method (nth ,depth-arg (compute-applicable-methods
#'gdl-rule::%message-remarks% (list ,self-arg ,message-arg))))
(class (first (glisp:gl-method-specializers method))))
(append (let ((local (let ((ht (message-documentation class)))
(when ht (gethash ,message-arg ht)))))
(when local (list (glisp:gl-class-name class) local)))
(when (next-method-p) (call-next-method ,self-arg ,message-arg (1+ ,depth-arg))))))
;;
;; FLAG -- why is this hardcoded to :all when it is first called?
;;
(defmethod gdl-rule::%message-list%
((,self-arg ,name) ,category-arg ,message-type-arg ,base-part-type-arg
&optional (,depth-arg 0))
(append (message-list ,self-arg
;;:all
,category-arg
,depth-arg ,base-part-type-arg)
(when (and (not (eql ,message-type-arg :local)) (next-method-p))
(call-next-method ,self-arg ,category-arg ,message-type-arg ,base-part-type-arg (1+ ,depth-arg)))))
(find-class ',name))))
By reiniervandijk on 2015-01-30 16:04:07 UTC
some utilities to generate the reserved symbol lists in the future.
;;; Some utilities for the updating reserved-words
(defun %print-reserved-words-vanilla% ()
(%print-symbol-list% (%reserved-messages-vanilla%)))
(defun %reserved-messages-vanilla% ()
(let ((messages
(append (gdl::messages (find-class 'vanilla-mixin*))
(gdl::messages (find-class 'standard-sequence)))))
;; filter out those leading "%"
(loop for message in messages
if (not (eq (char (symbol-name message) 0) #\%))
collect message)))
(defun %print-symbol-list% (messages)
"utility to quickly print lisp code for constant definition"
(format t "(mapcar #'(lambda(symbol)
(glisp:intern symbol :gdl-acc))
'(~{~a~% ~}))"
(safe-sort messages #'string< :key 'symbol-name)))
By genworks on 2015-03-18 03:43:44 UTC
An update has been merged to devo branch which implements a more general approach and does not require maintaining any lists of reserved symbols.