Commit 648f2235 authored by Dave Cooper's avatar Dave Cooper
Browse files

cleaned out some commented code.

parent 792ffc3e
......@@ -37,17 +37,9 @@
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)))
(gdl-rule::lookup-parameters ,self-arg ,(make-keyword message))))) messages)))
(defun computed-slots-section (name computed-slots &key query?)
(mapcan
#'(lambda(attribute)
......@@ -76,10 +68,6 @@
(with-dependency-tracking (,attr-sym)
,(if query? (error "Query-slots are not supported in this distribution of Genworks GDL.")
attr-expr)))))
;;
;;
;;
(when (and *compile-for-dgdl?* (not (string-equal (symbol-name name) "remote-object")))
`(when (or (not (fboundp ',(glisp:intern attr-sym :gdl-slots)))
......@@ -89,21 +77,6 @@
(the-object ,self-arg (send (:apply (cons ,(make-keyword (symbol-name attr-sym))
,args-arg)))))))
;;
;; FLAG -- duplicated from inputs.lisp and objects.lisp, functions.lisp, and below in this file.
;;
#+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))))
`(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)
......@@ -118,137 +91,55 @@
#+nil
(defun computed-slots-section (name computed-slots &key query?)
(mapcan
#'(lambda(attribute)
(let ((attr-remarks (message-strings attribute))
(attr-sym (intern (symbol-name (message-symbol attribute)) :gdl-acc))
(attr-expr (message-source-code attribute)))
(remove
nil
(list
(when (and name *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 (and name *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) ',attr-expr))))
(when name
`(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-slots) ((self ,name) &rest ,args-arg)
(declare (ignore ,args-arg))
(let ((*error-on-not-handled?* t))
(with-dependency-tracking (,attr-sym)
,(if query? (error "Query-slots are not supported in this distribution of Genworks GDL.")
attr-expr)))))
;;
;;
;;
(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)))))))
`(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)))
(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%)))
(if (null ,parent-arg) (not-handled ,self-arg ,(make-keyword attr-sym))
(let ((,val-arg (let (*error-on-not-handled?*)
(,(glisp:intern (symbol-name attr-sym) :gdl-inputs)
,parent-arg (the-object ,self-arg :%name%) ,self-arg))))
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,self-arg ,(make-keyword attr-sym)) ,val-arg))))))
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:begin-redefinitions-ok))
;;
;; FLAG -- duplicated from inputs.lisp and objects.lisp, functions.lisp, and below in this file.
;;
`(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))))
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok)))))) computed-slots))
;;
;; FLAG -- this can be made much shorter for all but the slots which
;; are only declared as trickle-downs and not otherwise declared (a
;; rare situation).
;;
(defun trickle-down-slots-section (slots &key from-objects?)
(mapcan
#'(lambda(slot)
(let (;; DJC trim effort
;; (result (gensym))
)
(remove
nil
(list
(unless from-objects? ;; DJC trim effort
;;
;; FLAG -- duplicated from objects.lisp, inputs.lisp, functions.lisp, and above in this file.
;;
;; 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)))))
;;
;; 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))))
(remove
nil
(list
(unless from-objects?
;;
;; FLAG -- this is really confusing and should be able to be conditional
;; FLAG -- duplicated from objects.lisp, inputs.lisp, functions.lisp, and above in this file.
;;
`(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 -- this must be get-riddable. Test carefully because trickle-downs are relatively rare.
;;
;; 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)))
`(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)))))
;;
;; 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 (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)))
;;
;; 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)))
))))
)))
slots))
......@@ -86,8 +86,6 @@
(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 -- why is this needed??
;;
......@@ -99,26 +97,7 @@
(let ((,parent-arg (the-object ,self-arg %parent%)))
(if (null ,parent-arg) (not-handled ,self-arg ,(make-keyword attr-sym))
(,(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))
;;
;; 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))
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))))
;;`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok))
)))))
,parent-arg (the-object ,self-arg :%name%) ,self-arg))))))))))
......@@ -179,6 +158,3 @@
(block ,(make-keyword attr-sym)
(let ((*error-on-not-handled?* t))
,@(if has-declare? (rest body) body)))) ,args-arg))))))))))))
......@@ -63,26 +63,11 @@
(when (not (member input special-keys))
(let ((input-sym (glisp:intern (symbol-name input) :gdl-acc)))
(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))
#+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)
(declare (ignore ,args-arg))
(let ((,parent-arg (the-object ,self-arg %parent%)))
(if (null ,parent-arg) (not-handled ,self-arg ,(make-keyword input-sym))
(,(glisp:intern (symbol-name input-sym) :gdl-inputs)
,parent-arg (the-object ,self-arg :%name%) ,self-arg)))))))))
(let ((*error-on-not-handled?* t)) ,expr))))))
keys expressions))))))
......@@ -109,26 +94,6 @@
,part-arg
(,self-arg gdl-basis))
(the-object ,parent-arg (fetch-input ,(make-keyword attr-sym) ,part-arg ,self-arg))))
;;
;; FLAG -- duplicated from objects.lisp and from this file --- make a function for this!
;;
;; 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)
((,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))))
`(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-slots) ((self ,name) &rest ,args-arg)
(declare (ignore ,args-arg))
......@@ -146,8 +111,7 @@
(if (member ,(make-keyword attr-sym) (the-object ,parent-arg :%trickle-down-slots%))
(,(glisp:intern (symbol-name attr-sym) :gdl-slots) ,parent-arg)
(funcall (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-trickle-downs)) ,parent-arg)))
(t (not-handled self ,(make-keyword attr-sym)))))))))))))
input-slots))
(t (not-handled self ,(make-keyword attr-sym))))))))))))) input-slots))
(defun optional-input-slots-section (name input-slots &optional (defaulted? nil))
(mapcan
......@@ -175,10 +139,6 @@
(setf (message-source (find-class ',name)) (make-hash-table)))))
(setf (gethash (make-keyword ',attr-sym) ht) ',attr-expr))))
;;
;; New stuff
;;
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:begin-redefinitions-ok))
(when (and *compile-for-dgdl?* (not (string-equal (symbol-name name) "remote-object") ))
......@@ -194,33 +154,6 @@
(,self-arg gdl-basis))
(the-object ,parent-arg (fetch-input ,(make-keyword attr-sym) ,part-arg ,self-arg))))
;;
;; 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)
,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))))
#+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)
:gdl-trickle-downs))
nil (list (find-class 'gdl-basis)) nil))))
(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-trickle-downs)
((,self-arg gdl-basis) &rest ,args-arg)
(declare (ignore ,args-arg))
(not-handled ,self-arg ,(make-keyword attr-sym))))
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok))
`(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-slots) ((self ,name) &rest ,args-arg)
......@@ -244,9 +177,7 @@
,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))
`(if (eql ,val-arg 'gdl-rule:%not-handled%) ,attr-expr ,val-arg))))))))))) input-slots))
......
......@@ -24,9 +24,7 @@
(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
(let ((object-input-keys (remove-duplicates
(cons :%parameters%
(apply #'append (mapcar #'(lambda(data)
(let ((plist-keys (mapcar #'make-keyword (append (plist-keys (getf data :plist))
......@@ -34,20 +32,12 @@
(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)
......@@ -56,40 +46,7 @@
(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))
object-specs)))
(object-input-keys (remove-duplicates
(append
(set-difference (apply #'append (mapcar #'plist-keys (mapcar #'(lambda(spec) (if (stringp (first spec))
(rest (rest spec))
(rest spec)))
object-specs)))
special-keys)
(apply #'append (mapcar #'(lambda(spec) (getf (rest (strip-strings spec)) :pass-down)) object-specs))))))
`(eval-when (:compile-toplevel :load-toplevel :execute)
,@(append
(mapcar #'(lambda(object-symbol)
`(unless (fboundp ',object-symbol)
(defgeneric ,object-symbol (parent object-name self)))) object-symbols-in-input-package)
(mapcar #'(lambda(key)
`(unless (fboundp ',(glisp:intern key :gdl-inputs))
(defgeneric ,(glisp:intern key :gdl-inputs) (parent object-name self)))) object-input-keys)
(mapcar #'(lambda(key)
`(unless (fboundp ',(glisp:intern key :gdl-slots))
(defgeneric ,(glisp:intern key :gdl-slots) (self &rest args)))) object-input-keys))))
,parent-arg (the-object ,self-arg :%name%) ,self-arg)))))) object-input-keys))))
......@@ -289,21 +246,6 @@ item in the list following the :sequence keyword")))))
(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)))
......@@ -330,232 +272,12 @@ item in the list following the :sequence keyword")))))
))))
#+nil
(defun objects-section (name objects)
(let ((special-keys (list :type :sequence :parameters :pass-down :pseudo-inputs)))
(apply
#'append
(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)))
(let ((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))))
(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
))))))))