Commit 792ffc3e authored by Dave Cooper's avatar Dave Cooper
Browse files

starting to streamline the define-object compiler

parent 704036fa
......@@ -42,6 +42,8 @@
:hidden-objects
((news :type 'news)
(primi-plane :type 'gdl-user::primi-plane)
(robot :type 'robot:assembly))
:objects
......
......@@ -179,7 +179,9 @@ Generative Programming, Dynamic Languages, 3D Geometry, NURBS, Solid Modeling, D
(link-title (the strings-for-display))
(display-list-object-roots (list (the robot)))
;;(display-list-object-roots (list (the robot)))
(display-list-object-roots (list (the primi-plane)))
(x3dom-view-controls? nil)
......
......@@ -22,7 +22,30 @@
(in-package :gdl)
(defun message-generics (messages)
`((eval-when (:compile-toplevel :load-toplevel :execute)
,@(append
(mapcar #'(lambda(message)
`(unless (fboundp ',(glisp:intern message :gdl-slots))
(defgeneric ,(glisp:intern message :gdl-slots) (,self-arg &rest ,args-arg)))) messages)
(mapcar #'(lambda(message)
`(unless (fboundp ',(glisp:intern message :gdl-inputs))
(defgeneric ,(glisp:intern message :gdl-inputs) (,parent-arg ,val-arg ,self-arg)))) messages)))
,@(mapcar #'(lambda(message)
`(unless (find-method (symbol-function ',(glisp:intern message :gdl-inputs))
nil (list (find-class 'gdl-basis) (find-class t) (find-class 'gdl-basis)) nil)
(defmethod ,(glisp:intern message :gdl-inputs) ((,parent-arg gdl-basis) ,part-arg (,self-arg gdl-basis))
(declare (ignore ,part-arg))
;;
;;FLAG -- replace rest of body with function call.
;;
(gdl-rule::lookup-parameters ,self-arg ,(make-keyword message))
#+nil
(let ((,val-arg (getf (the-object ,self-arg %parameters%)
,(make-keyword message) 'gdl-rule:%not-handled%)))
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,self-arg ,(make-keyword message)) ,val-arg))))) messages)))
(defun computed-slots-section (name computed-slots &key query?)
......@@ -69,25 +92,20 @@
;;
;; FLAG -- duplicated from inputs.lisp and objects.lisp, functions.lisp, and below in this file.
;;
`(eval-when (:compile-toplevel :load-toplevel :execute)
(glisp:begin-redefinitions-ok)
(unless nil #+nil (and (fboundp ',(glisp:intern (symbol-name attr-sym) :gdl-inputs))
(find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-inputs))
nil (list (find-class 'gdl-basis) (find-class t) (find-class 'gdl-basis)) nil))
(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-inputs) ((,parent-arg gdl-basis)
,part-arg
(,self-arg gdl-basis))
(declare (ignore ,part-arg))
(let ((,val-arg (getf (the-object ,self-arg %parameters%)
,(make-keyword (symbol-name attr-sym)) 'gdl-rule:%not-handled%)))
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,self-arg ,(make-keyword attr-sym)) ,val-arg))))
#+nil
`(unless (find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-inputs))
nil (list (find-class 'gdl-basis) (find-class t) (find-class 'gdl-basis)) nil)
(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-inputs) ((,parent-arg gdl-basis)
,part-arg
(,self-arg gdl-basis))
(declare (ignore ,part-arg))
(let ((,val-arg (getf (the-object ,self-arg %parameters%)
,(make-keyword (symbol-name attr-sym)) 'gdl-rule:%not-handled%)))
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,self-arg ,(make-keyword attr-sym)) ,val-arg))))
(glisp:end-redefinitions-ok))
`(when (or (not (fboundp ',(glisp:intern (symbol-name attr-sym) :gdl-slots)))
(not (find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-slots))
nil (list (find-class 'gdl-basis)) nil)))
`(unless (find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-slots))
nil (list (find-class 'gdl-basis)) nil)
(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-slots) ((,self-arg gdl-basis) &rest ,args-arg)
(declare (ignore ,args-arg))
(let ((,parent-arg (the-object ,self-arg %parent%)))
......@@ -184,35 +202,53 @@
(remove
nil
(list
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:begin-redefinitions-ok))
(unless from-objects? ;; DJC trim effort
;;
;; FLAG -- duplicated from objects.lisp, inputs.lisp, functions.lisp, and above in this file.
;;
`(unless nil #+nil (and (fboundp ',(glisp:intern (symbol-name slot) :gdl-inputs))
(find-method (symbol-function ',(glisp:intern (symbol-name slot) :gdl-inputs))
nil (list (find-class 'gdl-basis) (find-class t) (find-class 'gdl-basis)) nil))
;; FLAG -- this must be get-riddable. Test carefully because trickle-downs are relatively rare.
;;
`(unless (and (fboundp ',(glisp:intern (symbol-name slot) :gdl-inputs))
(find-method (symbol-function ',(glisp:intern (symbol-name slot) :gdl-inputs))
nil (list (find-class 'gdl-basis) (find-class t) (find-class 'gdl-basis)) nil))
(defmethod ,(glisp:intern (symbol-name slot) :gdl-inputs) ((,parent-arg gdl-basis)
,part-arg
(,self-arg gdl-basis))
(declare (ignore ,part-arg))
(let ((,val-arg (getf (the-object ,self-arg %parameters%)
,(make-keyword (symbol-name slot)) 'gdl-rule:%not-handled%)))
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,parent-arg ,(make-keyword slot)) ,val-arg)))))
(declare (ignore ,part-arg))
(let ((,val-arg (getf (the-object ,self-arg %parameters%)
,(make-keyword (symbol-name slot)) 'gdl-rule:%not-handled%)))
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,parent-arg ,(make-keyword slot)) ,val-arg)))))
;;
;; FLAG -- collect all the trickle-downs and group this at the top in the one eval-when.
;;
`(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (fboundp ',(glisp:intern (symbol-name slot) :gdl-trickle-downs))
(defgeneric ,(glisp:intern (symbol-name slot) :gdl-trickle-downs) (self &rest args))))
`(unless nil #+nil (and (fboundp ',(glisp:intern (symbol-name slot) :gdl-trickle-downs))
(find-method (symbol-function ',(glisp:intern (symbol-name slot) :gdl-trickle-downs))
nil (list (find-class 'gdl-basis)) nil))
;;
;; FLAG -- this is really confusing and should be able to be conditional
;;
`(unless (find-method (symbol-function ',(glisp:intern (symbol-name slot) :gdl-trickle-downs))
nil (list (find-class 'gdl-basis)) nil)
(defmethod ,(glisp:intern (symbol-name slot) :gdl-trickle-downs) ((,self-arg gdl-basis) &rest ,args-arg)
(trickle-down-basis ,self-arg ',slot ,args-arg)))
#+nil
`(defmethod ,(glisp:intern (symbol-name slot) :gdl-trickle-downs) ((,self-arg gdl-basis) &rest ,args-arg)
(trickle-down-basis ,self-arg ',slot ,args-arg))
;;
;; FLAG -- (eval-when (:c- :l- :e) ...) for defgenerics for _all_ messages in header, then remove fboundp from conditional here.
;;
;; FLAG -- maybe don't remove, could have a trickle-down which is not otherwise declared as a message.
`(unless nil #+nil (and (fboundp ',(glisp:intern (symbol-name slot) :gdl-slots))
(find-method (symbol-function ',(glisp:intern (symbol-name slot) :gdl-slots))
nil (list (find-class 'gdl-basis)) nil))
(defmethod ,(glisp:intern (symbol-name slot) :gdl-slots) ((,self-arg gdl-basis) &rest ,args-arg)
(chase-up-trickle-down ',(glisp:intern (symbol-name slot) :gdl-slots) ,self-arg ,args-arg)))
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok))))))
))))
slots))
......@@ -87,6 +87,10 @@
(the-object ,self-arg (send (:apply (cons ,(make-keyword (symbol-name attr-sym)) ,args-arg)))))))
;;
;; FLAG -- why is this needed??
;;
`(when (or (not (fboundp ',(glisp:intern (symbol-name attr-sym) :gdl-slots)))
(not (find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-slots))
nil (list (find-class 'gdl-basis)) nil)))
......@@ -97,10 +101,11 @@
(,(glisp:intern (symbol-name attr-sym) :gdl-inputs)
,parent-arg (the-object ,self-arg :%name%) ,self-arg)))))
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:begin-redefinitions-ok))
;;`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:begin-redefinitions-ok))
;;
;; FLAG -- duplicated from inputs.lisp, objects.lisp, and computed-slots.lisp
;;
#+nil
`(unless nil
#+nil (and (fboundp ',(glisp:intern (symbol-name attr-sym) :gdl-inputs))
(find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-inputs))
......@@ -112,7 +117,8 @@
(let ((,val-arg (getf (the-object ,self-arg %parameters%)
,(make-keyword (symbol-name attr-sym)) 'gdl-rule:%not-handled%)))
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,parent-arg ,(make-keyword attr-sym)) ,val-arg))))
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok)))))))
;;`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok))
)))))
......
......@@ -36,7 +36,7 @@
,@(append
(mapcar #'(lambda(input-sym)
`(unless (fboundp ',input-sym)
(defgeneric ,input-sym (parent object-name self)))) input-slot-syms)))))
(defgeneric ,input-sym (,parent-arg ,val-arg ,self-arg)))) input-slot-syms)))))
(defun input-methods (name attr-sym keys expressions special-keys)
......@@ -62,18 +62,18 @@
#'(lambda(input expr)
(when (not (member input special-keys))
(let ((input-sym (glisp:intern (symbol-name input) :gdl-acc)))
(list
(list
;;
;; New stuff
;;
`(defmethod ,(glisp:intern (symbol-name input-sym) :gdl-inputs)
((self ,name)
(,part-arg (eql ',attr-sym))
(child t))
(let ((*error-on-not-handled?* t)) ,expr))
;;
;; New stuff
;;
`(defmethod ,(glisp:intern (symbol-name input-sym) :gdl-inputs)
((self ,name)
(,part-arg (eql ',attr-sym))
(child t))
(let ((*error-on-not-handled?* t)) ,expr))
#+nil
`(unless (find-method (symbol-function ',(glisp:intern (symbol-name input-sym) :gdl-slots))
nil (list (find-class 'gdl-basis)) nil)
(defmethod ,(glisp:intern (symbol-name input-sym) :gdl-slots) ((,self-arg gdl-basis) &rest ,args-arg)
......@@ -117,6 +117,7 @@
;; FLAG -- avoid duplicate invocation of (glisp:intern (symbol-name ...))
;;
;;
#+nil
`(unless (find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-inputs))
nil (list (find-class 'gdl-basis) (find-class t) (find-class 'gdl-basis)) nil)
(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-inputs)
......@@ -196,6 +197,7 @@
;;
;; FLAG -- duplicated from objects.lisp and from this file --- make a function for this!
;;
#+nil
`(unless (find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-inputs))
nil (list (find-class 'gdl-basis) (find-class t) (find-class 'gdl-basis)) nil)
(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-inputs) ((,parent-arg gdl-basis)
......@@ -206,6 +208,9 @@
,(make-keyword (symbol-name attr-sym)) 'gdl-rule:%not-handled%)))
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,parent-arg ,(make-keyword attr-sym)) ,val-arg))))
#+nil
`(when (and ,defaulted?
(or (not (fboundp ',(glisp:intern (symbol-name attr-sym) :gdl-trickle-downs)))
(not (find-method (symbol-function ',(glisp:intern (symbol-name attr-sym)
......@@ -233,11 +238,13 @@
`(if (eql ,val-arg 'gdl-rule:%not-handled%)
(let ((,val-arg (if ,parent-arg
(let (*error-on-not-handled?*)
(,(glisp:intern (symbol-name attr-sym) :gdl-trickle-downs) self))
(if (fboundp ',(glisp:intern (symbol-name attr-sym) :gdl-trickle-downs))
(,(glisp:intern (symbol-name attr-sym) :gdl-trickle-downs) self)
'gdl-rule:%not-handled%))
,val-arg)))
(if (eql ,val-arg 'gdl-rule:%not-handled%) ,attr-expr ,val-arg))
,val-arg)
`(if (eql ,val-arg 'gdl-rule:%not-handled%) ,attr-expr ,val-arg)))))))))))
,val-arg)
`(if (eql ,val-arg 'gdl-rule:%not-handled%) ,attr-expr ,val-arg)))))))))))
input-slots))
......
......@@ -58,8 +58,20 @@
(let ((ht (or (message-source (find-class ',name))
(setf (message-source (find-class ',name)) (make-hash-table)))))
(setf (gethash (make-keyword ',attr-sym) ht) ',(cons lambda-list body)))))
`(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-slots) ((self ,name) ,@lambda-list)
;;
;; FLAG -- put this in when we know how to derive generic-function lambda-list from the lambda-list.
;;
;; FLAG -- use extract-lambda-list from glisp (make one) or c2mop package of :closer-mop.
;;
#+nil
`(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (fboundp ',(glisp:intern attr-sym :gdl-slots))
(defgeneric ,(glisp:intern attr-sym :gdl-slots) (,self-arg ,@lambda-list))))
`(defmethod ,(glisp:intern attr-sym :gdl-slots) ((self ,name) ,@lambda-list)
,(if has-declare? (first body) `(declare))
,(when *compile-circular-reference-detection?*
......
......@@ -22,7 +22,46 @@
(in-package :gdl)
(defun object-inputs-generics-section (object-specs)
(defun object-inputs-generics-section (cooked-data &key special-keys)
(let (#+nil
(object-symbols-in-input-package (mapcar #'(lambda(data) (glisp:intern (getf data :attr-sym) :gdl-inputs)) cooked-data))
(object-input-keys (remove-duplicates
(cons :%parameters%
(apply #'append (mapcar #'(lambda(data)
(let ((plist-keys (mapcar #'make-keyword (append (plist-keys (getf data :plist))
(getf data :with-attribute-keys)))))
(set-difference plist-keys special-keys))) cooked-data))))))
`((eval-when (:compile-toplevel :load-toplevel :execute)
,@(append
#+nil
(mapcar #'(lambda(object-symbol)
`(unless (fboundp ',object-symbol)
(defgeneric ,object-symbol (,parent-arg ,val-arg ,self-arg)))) object-symbols-in-input-package)
(mapcar #'(lambda(key)
`(unless (fboundp ',(glisp:intern key :gdl-inputs))
(defgeneric ,(glisp:intern key :gdl-inputs) (,parent-arg ,val-arg ,self-arg)))) object-input-keys)
(mapcar #'(lambda(key)
`(unless (fboundp ',(glisp:intern key :gdl-slots))
(defgeneric ,(glisp:intern key :gdl-slots) (,self-arg &rest ,args-arg)))) object-input-keys)))
,@(mapcar #'(lambda(key)
`(unless (find-method (symbol-function ',(glisp:intern key :gdl-slots))
nil (list (find-class 'gdl-basis)) nil)
(defmethod ,(glisp:intern key :gdl-slots) ((,self-arg gdl-basis) &rest ,args-arg)
(declare (ignore ,args-arg))
(let ((,parent-arg (the-object ,self-arg %parent%)))
(if (null ,parent-arg) (not-handled ,self-arg ,(make-keyword key))
(,(glisp:intern key :gdl-inputs)
,parent-arg (the-object ,self-arg :%name%) ,self-arg))))))
object-input-keys))))
#+nil
(let* ((special-keys (list :type :sequence :parameters :pass-down :pseudo-inputs))
(object-symbols-in-input-package (remove-duplicates (mapcar #'(lambda(spec) (glisp:intern (if (stringp (first spec))
(second spec) (first spec)) :gdl-inputs))
......@@ -50,9 +89,248 @@
(mapcar #'(lambda(key)
`(unless (fboundp ',(glisp:intern key :gdl-slots))
(defgeneric ,(glisp:intern key :gdl-slots) (self &rest args)))) object-input-keys)))))
(defgeneric ,(glisp:intern key :gdl-slots) (self &rest args)))) object-input-keys))))
(defun objects-section (name objects)
(let ((special-keys (list :type :sequence :parameters :pass-down :pseudo-inputs)))
(let ((cooked-data
(mapcar
#'(lambda(part)
(let* ((attr-remarks (message-strings part))
(attr-sym (glisp:intern (symbol-name (message-symbol part)) :gdl-acc))
(plist (rest (strip-strings part)))
(plist-orig plist)
(plist (process-radial plist))
(plist (process-matrix plist))
(part-parameters-expression (getf plist :parameters))
(part-type-expr (or (getf plist :type)
`',(glisp:intern (symbol-name attr-sym) (symbol-package name))))
(part-quantify-expr (getf plist :sequence))
(pseudo-inputs (getf plist :pseudo-inputs))
(with-attribute-keys (getf plist :pass-down))
(part-type-symbol
(cond ((and (listp part-type-expr)
(eql (first part-type-expr) 'quote))
(second part-type-expr))
((and (listp part-type-expr)
(eql (first part-type-expr) :sequence)
(listp (second part-type-expr))
(eql (first (second part-type-expr)) 'quote))
(second (second part-type-expr)))
(t nil))))
(list :attr-remarks attr-remarks
:attr-sym attr-sym
:plist plist
:plist-orig plist-orig
:part-parameters-expression part-parameters-expression
:part-type-expr part-type-expr
:part-quantify-expr part-quantify-expr
:pseudo-inputs pseudo-inputs
:with-attribute-keys with-attribute-keys
:part-type-symbol part-type-symbol))) objects)))
(apply #'append
(object-inputs-generics-section cooked-data :special-keys special-keys)
(mapcar #'(lambda(data)
(apply #'object-specific-methods-section (append data (list :name name :special-keys special-keys)))) cooked-data)))))
(defun object-specific-methods-section (&key
attr-remarks
attr-sym
plist
plist-orig
part-parameters-expression
part-type-expr
part-quantify-expr
pseudo-inputs
with-attribute-keys
part-type-symbol
name
special-keys)
(when (and part-type-symbol
(atom part-type-symbol)
(not (eql part-type-symbol 'remote-object)))
(let* ((all-inputs (all-inputs part-type-symbol))
(accepted-inputs (if (listp all-inputs)
(append all-inputs pseudo-inputs)
all-inputs)))
(when (listp accepted-inputs)
(let* ((accepted-inputs (mapcar #'make-keyword accepted-inputs))
(attempted-inputs (mapcar #'make-keyword
(set-difference
(append (plist-keys plist-orig) with-attribute-keys)
special-keys)))
(unrecognized-inputs
(safe-sort (set-difference attempted-inputs accepted-inputs)
#'string-lessp :key #'string)))
(reserved-word-warning-or-error part-type-symbol
(mapcar #'(lambda(symbol)
(glisp:intern symbol :gdl-acc))
attempted-inputs))
(when unrecognized-inputs
(let* ((singular? (= (length unrecognized-inputs) 1))
(s-or-blank (if singular? "" "s"))
(a-or-blank (if singular? "a" "")))
(warn " (from object specification for ~s)
The following ~a not recognized as any category of defined input-slot for
the object type '~s'. ~a will be assumed to be ~a pseudo-input~a.
~{ ~s~^~%~}
You can suppress this warning by including ~a name~a in the :pseudo-inputs
special input keyword for the child object, i.e:
...
:pseudo-inputs (~{~a~^ ~})
...
"
(make-keyword attr-sym)
(if singular? "is" "are")
part-type-symbol
(if singular? "This" "These")
a-or-blank
s-or-blank
unrecognized-inputs
(if singular? "this" "these")
s-or-blank
unrecognized-inputs
)))))))
(append
(input-methods name
attr-sym
(append (cons :%parameters% (plist-keys plist))
with-attribute-keys)
(append (cons part-parameters-expression
(plist-values plist))
(mapcar #'(lambda(key)
`(the ,key))
with-attribute-keys))
special-keys)
(remove
nil
(list
(when (and *compile-documentation-database?* attr-remarks)
`(when *load-documentation-database?*
(let ((ht (or (message-documentation (find-class ',name))
(setf (message-documentation (find-class ',name)) (make-hash-table)))))
(setf (gethash (make-keyword ',attr-sym) ht) ,attr-remarks))))
(when *compile-source-code-database?*
`(when *load-source-code-database?*
(let ((ht (or (message-source (find-class ',name))
(setf (message-source (find-class ',name)) (make-hash-table)))))
(setf (gethash (make-keyword ',attr-sym) ht) ',plist))))
`(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-slots) ((self ,name) &rest ,args-arg)
(cond ((null ,args-arg)
(with-dependency-tracking (,attr-sym)
,(cond
((null part-quantify-expr)
`(if *retain-object-identity-on-type-change?*
(instantiate-part-on-demand self ,part-type-expr ',attr-sym)
(make-object-internal ,part-type-expr
:%name% (list ',attr-sym nil t)
:%parent% (list self nil t)
:%root% (gdl-acc::%root% self))))
((eql (first part-quantify-expr)
:size)
`(make-object-internal 'standard-sequence
:%name% (list ',attr-sym nil t)
:%parent% (list self nil t)
:%root% (gdl-acc::%root% self)))
((eql (first part-quantify-expr) :radial)
`(make-object-internal 'radial-sequence
:%name% (list ',attr-sym nil t)
:%parent% (list self nil t)
:%root% (gdl-acc::%root% self)))
((eql (first part-quantify-expr) :matrix)
`(make-object-internal 'matrix-sequence
:%name% (list ',attr-sym nil t)
:%parent% (list self nil t)
:%root% (gdl-acc::%root% self)))
((eql (first part-quantify-expr)
:indices)
`(make-object-internal 'variable-sequence
:%name% (list ',attr-sym nil t)
:%parent% (list self nil t)
:%root% (gdl-acc::%root% self)))
(t (error "For a sequence object, you must specify one of :size, :radial, :matrix, or :indices as the first
item in the list following the :sequence keyword")))))
((null (rest ,args-arg))
(the-object self ,attr-sym (:get-member (first ,args-arg))))
(t
(the-object self ,attr-sym (:get-member (first ,args-arg)
(second ,args-arg))))))
(when (and *compile-for-dgdl?* (not (string-equal (symbol-name name) "remote-object")))
`(when (or (not (fboundp ',(glisp:intern attr-sym :gdl-slots)))
(not (find-method (symbol-function ',(glisp:intern attr-sym :gdl-slots))
nil (list (find-class 'gdl-remote)) nil)))
(defmethod ,(glisp:intern attr-sym :gdl-slots)
((,self-arg gdl-remote) &rest ,args-arg)
(the-object ,self-arg (send (:apply (cons ,(make-keyword (symbol-name attr-sym))
,args-arg)))))))
;;
;; FLAG -- duplicated from two places in inputs.lisp --- make a function for this!!
;;
#+nil
`(unless (find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-inputs))
nil (list (find-class 'gdl-basis) (find-class t) (find-class 'gdl-basis)) nil)
(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-inputs) ((,parent-arg gdl-basis)
,part-arg
(,self-arg gdl-basis))
(declare (ignore ,part-arg))
(let ((,val-arg (getf (the-object ,self-arg %parameters%)
,(make-keyword (symbol-name attr-sym)) 'gdl-rule:%not-handled%)))
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,parent-arg ,(make-keyword attr-sym))
,val-arg))))
(when (member (first part-quantify-expr) '(:size :radial))
`(defmethod gdl-inputs::number-of-elements ((self ,name) (,part-arg (eql ',attr-sym)) (child t))
,(second part-quantify-expr)))
(when (member (first part-quantify-expr) '(:size :radial :matrix))
`(defmethod gdl-inputs::child-types ((self ,name) (,part-arg (eql ',attr-sym)) (child t))
,(if (eql (first part-type-expr) :sequence)
(second part-type-expr)
`(list ,part-type-expr))))
(when (eql (first part-quantify-expr) :indices)
`(defmethod gdl-inputs::element-index-list ((self ,name) (,part-arg (eql ',attr-sym)) (child t))
,(second part-quantify-expr)))
(when (eql (first part-quantify-expr) :indices)
`(defmethod gdl-inputs::child-types ((self ,name) (,part-arg (eql ',attr-sym)) (child t))
,part-type-expr))