Commit 46bc6c63 authored by Dave Cooper's avatar Dave Cooper
Browse files

added wire-world demo and cleaned up SBCL compile warnings

parent d506336b
...@@ -32,7 +32,7 @@ or <tt>:enterprise</tt>. ...@@ -32,7 +32,7 @@ or <tt>:enterprise</tt>.
Indicates which level of application should be made. Defaults to :development." Indicates which level of application should be made. Defaults to :development."
application-class :runtime) application-class :runtime)
(lisp-heap-size 500000000) (lisp-heap-size 900000000)
(implementation-identifier (glisp:implementation-identifier)) (implementation-identifier (glisp:implementation-identifier))
...@@ -97,7 +97,8 @@ temporary directory, returned by <tt>(glisp:temporary-folder)</tt>." ...@@ -97,7 +97,8 @@ temporary directory, returned by <tt>(glisp:temporary-folder)</tt>."
(let ((self (apply #'make-object 'app args))) (let ((self (apply #'make-object 'app args)))
(the make!))) (the make!)))
(defun gdl ()
(defun gdl-runtime ()
(let ((destination-directory (let ((destination-directory
(let ((implementation-identifier (glisp:implementation-identifier)) (let ((implementation-identifier (glisp:implementation-identifier))
;;(prefix (merge-pathnames "../../staging/" glisp:*genworks-source-home*)) ;;(prefix (merge-pathnames "../../staging/" glisp:*genworks-source-home*))
...@@ -107,6 +108,31 @@ temporary directory, returned by <tt>(glisp:temporary-folder)</tt>." ...@@ -107,6 +108,31 @@ temporary directory, returned by <tt>(glisp:temporary-folder)</tt>."
(list :relative (list :relative
(format nil "~a-~a" implementation-identifier (format nil "~a-~a" implementation-identifier
(glisp:next-datestamp prefix implementation-identifier)))) prefix)))) (glisp:next-datestamp prefix implementation-identifier)))) prefix))))
(app :application-name "gdl-runtime"
:application-class :runtime
:destination-directory destination-directory
:modules (list :agraph)
:restart-init-function '(lambda()
(setq glisp:*gdl-home* (glisp:current-directory))
(setq glisp:*genworks-source-home* (merge-pathnames "src/" glisp:*gdl-home*))
(setq ql:*quicklisp-home* (merge-pathnames "quicklisp/" glisp:*gdl-home*))
(asdf:initialize-output-translations)
(gdl:start-gdl :edition :trial)
(glisp:set-gs-path (merge-pathnames "gpl/gs/gs8.63/bin/gswin32c.exe" glisp:*gdl-home*))))
destination-directory))
(defun gdl ()
(let ((destination-directory
(let ((implementation-identifier (glisp:implementation-identifier))
;;(prefix (merge-pathnames "../../staging/" glisp:*genworks-source-home*))
(prefix (merge-pathnames #+mswindows "c:/staging/" #-mswindows "~/share/staging/")))
(merge-pathnames
(make-pathname :directory
(list :relative
(format nil "~a-~a" implementation-identifier
(glisp:next-datestamp prefix implementation-identifier)))) prefix))))
(app :application-name "gdl" (app :application-name "gdl"
:application-class :development :application-class :development
:destination-directory destination-directory :destination-directory destination-directory
......
...@@ -21,7 +21,7 @@ ...@@ -21,7 +21,7 @@
(in-package :com.genworks.lisp) (in-package :com.genworks.lisp)
(eval-when (compile load eval) (glisp:without-package-variance-warnings
(defpackage :com.genworks.lisp (defpackage :com.genworks.lisp
(:use :common-lisp) (:use :common-lisp)
(:export #:copy-directory (:export #:copy-directory
...@@ -94,7 +94,7 @@ ...@@ -94,7 +94,7 @@
(let ((class (getf args :application-class))) (let ((class (getf args :application-class)))
(list :runtime (case class (list :runtime (case class
(:development :partners) (:development :partners)
(otherwise nil)) (otherwise :standard))
:include-compiler (case class :include-compiler (case class
(:development t) (:development t)
......
...@@ -37,6 +37,7 @@ ...@@ -37,6 +37,7 @@
:radius 1.5 :radius 1.5
:length (the :height) :length (the :height)
:center (the (:face-center (ecase (the-child :index) (0 :front) (1 :rear)))) :center (the (:face-center (ecase (the-child :index) (0 :front) (1 :rear))))
:pseudo-inputs (transformation-matrix)
:transformation-matrix :transformation-matrix
(alignment :front (alignment :front
(rotate-vector-d (the (rotate-vector-d (the
......
...@@ -21,7 +21,7 @@ ...@@ -21,7 +21,7 @@
(in-package :genworks.demos.bus) (in-package :genworks.demos.bus)
(define-view (html-format assembly) () (define-lens (html-format assembly) ()
:output-functions :output-functions
((model-inputs ((model-inputs
......
...@@ -21,7 +21,7 @@ ...@@ -21,7 +21,7 @@
(in-package :genworks.demos.bus) (in-package :genworks.demos.bus)
(define-view (html-format body) nil (define-lens (html-format body) nil
:output-functions :output-functions
((model-inputs ((model-inputs
......
...@@ -21,7 +21,7 @@ ...@@ -21,7 +21,7 @@
(in-package :genworks.demos.bus) (in-package :genworks.demos.bus)
(define-view (html-format interior) nil (define-lens (html-format interior) nil
:output-functions :output-functions
((model-inputs ((model-inputs
......
...@@ -22,7 +22,7 @@ ...@@ -22,7 +22,7 @@
(in-package :genworks.demos.bus) (in-package :genworks.demos.bus)
(define-view (html-format rule-ackermann) nil (define-lens (html-format rule-ackermann) nil
:output-functions :output-functions
((bottom-user-area ((bottom-user-area
......
...@@ -80,6 +80,7 @@ ...@@ -80,6 +80,7 @@
(translate (the :center) :up (half (the-child :width))))) (translate (the :center) :up (half (the-child :width)))))
(rotate-point-d nominal-center (the :center) (the :y-vector) (rotate-point-d nominal-center (the :center) (the :y-vector)
:angle (the :reclined-angle))) :angle (the :reclined-angle)))
:pseudo-inputs (transformation-matrix)
:transformation-matrix (alignment :right :transformation-matrix (alignment :right
(rotate-vector-d (the :z-vector) (rotate-vector-d (the :z-vector)
(the :reclined-angle) (the :reclined-angle)
......
...@@ -47,6 +47,7 @@ ...@@ -47,6 +47,7 @@
((seats :type 'seat ((seats :type 'seat
:sequence (:size (the number-of-rows)) :sequence (:size (the number-of-rows))
:pass-down (:reclined-angle :max-reclined-angle :x-vector) :pass-down (:reclined-angle :max-reclined-angle :x-vector)
:pseudo-inputs (transformation-matrix)
:transformation-matrix :transformation-matrix
(alignment :rear (the-child y-vector) :right (alignment :rear (the-child y-vector) :right
(the-child x-vector) :top (the-child x-vector) :top
......
(asdf:defsystem #:gdl-demos :description (asdf:defsystem #:gdl-demos
"Auto-generated asdf defsys from Genworks GDL cl-lite." :description
:author "Auto-generated asdf defsys from Genworks GDL cl-lite."
"Genworks and Dave Cooper unless otherwise indicated" :author
:license "AGPL unless otherwise indicated" :serial t "Genworks and Dave Cooper unless otherwise indicated"
:version "2011112000" :depends-on (:gdl-gwl-graphics) :license
:components "AGPL unless otherwise indicated"
((:file "bus/source/package") :serial
(:file "bus/source/assembly") t
(:file "bus/source/body") :version
(:file "bus/source/chassis") "2012030300"
(:file "bus/source/interior") :depends-on
(:file "bus/source/rule-ackermann") (:gdl-gwl-graphics)
(:file "bus/source/axle") (:file "bus/source/fleet") :components
(:file "bus/source/frame-rail") ((:file "aero-demo-1/source/package")
(:file "bus/source/frame") (:file "aero-demo-1/source/interior-ref-surf")
(:file "bus/source/html-writer-assembly") (:file "aero-demo-1/source/material")
(:file "bus/source/html-writer-body") (:file "aero-demo-1/source/parameters")
(:file "bus/source/html-writer-chassis") (:file "aero-demo-1/source/ref-surface")
(:file "bus/source/html-writer-interior") (:file "aero-demo-1/source/surface-trim")
(:file "bus/source/html-writer-rule-ackermann") (:file "aero-demo-1/source/utilities")
(:file "bus/source/inter-seat-clearance-check") (:file "bus/source/package") (:file "bus/source/assembly")
(:file "bus/source/inter-seat-spacing") (:file "bus/source/body") (:file "bus/source/chassis")
(:file "bus/source/knuckle") (:file "bus/source/interior") (:file "bus/source/rule-ackermann")
(:file "bus/source/parameters") (:file "bus/source/axle") (:file "bus/source/fleet")
(:file "bus/source/publish") (:file "bus/source/frame-rail") (:file "bus/source/frame")
(:file "bus/source/rear-axle") (:file "bus/source/html-writer-assembly")
(:file "bus/source/seat") (:file "bus/source/html-writer-body")
(:file "bus/source/seating-section") (:file "bus/source/html-writer-chassis")
(:file "bus/source/seating-side") (:file "bus/source/html-writer-interior")
(:file "bus/source/wheel") (:file "bus/source/html-writer-rule-ackermann")
(:file "glassbox/source/assembly") (:file "bus/source/inter-seat-clearance-check")
(:file "glassbox/source/eco-tree") (:file "bus/source/inter-seat-spacing")
(:file "ledger/source/package") (:file "bus/source/knuckle") (:file "bus/source/parameters")
(:file "ledger/source/assembly") (:file "bus/source/publish") (:file "bus/source/rear-axle")
(:file "ledger/source/html") (:file "bus/source/seat") (:file "bus/source/seating-section")
(:file "robot/source/package") (:file "bus/source/seating-side") (:file "bus/source/wheel")
(:file "robot/source/assembly") (:file "glassbox/source/assembly")
(:file "site/source/package") (:file "glassbox/source/eco-tree") (:file "ledger/source/package")
(:file "site/source/assembly") (:file "ledger/source/assembly") (:file "ledger/source/html")
(:file "site/source/contact") (:file "robot/source/package") (:file "robot/source/assembly")
(:file "site/source/demos") (:file "site/source/package") (:file "site/source/assembly")
(:file "site/source/glossary") (:file "site/source/contact") (:file "site/source/demos")
(:file "site/source/index") (:file "site/source/glossary") (:file "site/source/index")
(:file "site/source/landing") (:file "site/source/landing") (:file "site/source/licensing")
(:file "site/source/licensing") (:file "site/source/maintenance") (:file "site/source/make")
(:file "site/source/maintenance") (:file "site/source/mixins") (:file "site/source/new")
(:file "site/source/make") (:file "site/source/opportunities") (:file "site/source/options")
(:file "site/source/mixins") (:file "site/source/people") (:file "site/source/pricing")
(:file "site/source/new") (:file "site/source/products") (:file "site/source/publish")
(:file "site/source/opportunities") (:file "site/source/security")
(:file "site/source/options") (:file "wire-world/source/assembly")
(:file "site/source/people") (:file "wire-world/source/package")))
(:file "site/source/pricing") \ No newline at end of file
(:file "site/source/products")
(:file "site/source/publish")
(:file "site/source/security")))
\ No newline at end of file
...@@ -54,7 +54,7 @@ ...@@ -54,7 +54,7 @@
(dependency-pairs (dependency-pairs
(let ((*pairs-hash* (make-hash-table :test #'equalp :values nil))) (let ((*pairs-hash* (glisp:make-sans-value-hash-table :test #'equalp)))
(the %dependency-pairs%))) (the %dependency-pairs%)))
(%dependency-pairs% (%dependency-pairs%
......
...@@ -52,6 +52,7 @@ ...@@ -52,6 +52,7 @@
:make-instance-function #'(lambda(type) (the (make-root-instance type)))) :make-instance-function #'(lambda(type) (the (make-root-instance type))))
(tree :type 'object-tree (tree :type 'object-tree
:pseudo-inputs (length width)
:tatu-root self :tatu-root self
:length (getf (the tree-dimensions) :length) :length (getf (the tree-dimensions) :length)
:width (getf (the tree-dimensions) :width) :width (getf (the tree-dimensions) :width)
...@@ -81,6 +82,7 @@ ...@@ -81,6 +82,7 @@
:tatu-root self) :tatu-root self)
(inspector :type 'inspector (inspector :type 'inspector
:pseudo-inputs (length width)
:pass-down (root-object colors-default) :pass-down (root-object colors-default)
:length (getf (the inspector-dimensions) :length) :length (getf (the inspector-dimensions) :length)
:width (getf (the inspector-dimensions) :width) :width (getf (the inspector-dimensions) :width)
...@@ -161,7 +163,8 @@ The error was: ~a~%~%" kids-error) "") ...@@ -161,7 +163,8 @@ The error was: ~a~%~%" kids-error) "")
object))) object)))
(:uh (the viewport (set-sheet-object! object))))))) ;;(:uh (the viewport (set-sheet-object! object)))
))))
(define-lens (html-format assembly)() (define-lens (html-format assembly)()
......
...@@ -56,6 +56,7 @@ ...@@ -56,6 +56,7 @@
(color-chooser :type 'color-chooser) (color-chooser :type 'color-chooser)
(line-thickness-selectors :type 'vanilla-mixin (line-thickness-selectors :type 'vanilla-mixin
:pseudo-inputs (line-thickness)
:sequence (:size 5) :sequence (:size 5)
:line-thickness (nth (the-child index) (list 0.5 1.0 2.0 3.0 4.0)) :line-thickness (nth (the-child index) (list 0.5 1.0 2.0 3.0 4.0))
) )
......
...@@ -427,6 +427,7 @@ ...@@ -427,6 +427,7 @@
:form-controls (list-elements (the form-fields))))) :form-controls (list-elements (the form-fields)))))
(form-fields :type 'text-form-control (form-fields :type 'text-form-control
:pseudo-inputs (keyword)
:sequence (:size (length (the settables))) :sequence (:size (length (the settables)))
;; ;;
;; FLAG -- precompute this in a slot, and allow for unbound until clicked. ;; FLAG -- precompute this in a slot, and allow for unbound until clicked.
......
...@@ -21,7 +21,7 @@ ...@@ -21,7 +21,7 @@
(in-package :com.genworks.lisp) (in-package :com.genworks.lisp)
(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:without-package-variance-warnings
(defpackage :com.genworks.lisp (defpackage :com.genworks.lisp
(:use :common-lisp) (:use :common-lisp)
(:nicknames :glisp) (:nicknames :glisp)
......
...@@ -22,7 +22,7 @@ ...@@ -22,7 +22,7 @@
(in-package :gdl) (in-package :gdl)
#-(or allegro lispworks sbcl) (error "Need package for mop:validate-superclass for currently running lisp.~%") #-(or allegro lispworks sbcl) (error "Need package for mop:validate-superclass for currently running lisp.~%")
(eval-when (compile load eval) (eval-when (:compile-toplevel :load-toplevel :execute)
(defpackage :com.genworks.lisp (defpackage :com.genworks.lisp
(:use :common-lisp) (:use :common-lisp)
(:shadow #:intern) (:shadow #:intern)
...@@ -58,7 +58,8 @@ ...@@ -58,7 +58,8 @@
#:w-o-interrupts #:w-o-interrupts
#:xref-off #:xref-off
#:xref-on #:xref-on
#:validate-superclass))) #:validate-superclass
#:without-package-variance-warnings)))
(in-package :com.genworks.lisp) (in-package :com.genworks.lisp)
...@@ -87,16 +88,17 @@ ...@@ -87,16 +88,17 @@
#-(or allegro lispworks sbcl) #-(or allegro lispworks sbcl)
(error "Need parameter for redefinition warnings for currently running lisp.~%") (error "Need parameter for redefinition warnings for currently running lisp.~%")
(let ((original-redefinition-warnings (let (#+(or allegro lispworks)
#+allegro excl:*redefinition-warnings* (original-redefinition-warnings
#+lispworks lw:*redefinition-action*)) #+allegro excl:*redefinition-warnings*
#+lispworks lw:*redefinition-action*))
(defun begin-redefinitions-ok () (defun begin-redefinitions-ok ()
#+sbcl (declaim (sb-ext:muffle-conditions sb-ext:compiler-note)) #+sbcl (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
#+(or allegro lispworks) #+(or allegro lispworks)
(setq #+allegro excl:*redefinition-warnings* (setq #+allegro excl:*redefinition-warnings*
#+lispworks lw:*redefinition-action* nil)) #+lispworks lw:*redefinition-action* nil))
(defun end-redefinitions-ok () (defun end-redefinitions-ok ()
#+sbcl (declaim (sb-ext:unmuffle-conditions sb-ext:compiler-note)) #+sbcl (declare (sb-ext:unmuffle-conditions sb-ext:compiler-note))
#+(or allegro lispworks) #+(or allegro lispworks)
(setq #+allegro excl:*redefinition-warnings* (setq #+allegro excl:*redefinition-warnings*
#+lispworks lw:*redefinition-action* original-redefinition-warnings))) #+lispworks lw:*redefinition-action* original-redefinition-warnings)))
...@@ -244,7 +246,7 @@ ...@@ -244,7 +246,7 @@
(:case-sensitive-lower string))) (:case-sensitive-lower string)))
(defmacro w-o-interrupts (&body body) (defmacro w-o-interrupts (&body body)
(warn "Without-interrupts is deprecated in multiprocessing Lisp - replace usage with something else.") (format t "NOTE: Without-interrupts is deprecated in multiprocessing Lisp - replace usage with something else in glisp:w-o-interrupts.")
#-(or allegro lispworks cmu sbcl) (error "Need implementation for without-interrupts for currently running lisp.~%") #-(or allegro lispworks cmu sbcl) (error "Need implementation for without-interrupts for currently running lisp.~%")
`(#+allegro excl:without-interrupts `(#+allegro excl:without-interrupts
#+lispworks progn #+lispworks progn
...@@ -319,3 +321,7 @@ quicklisp/ directory, with respective copyrights and licenses. ...@@ -319,3 +321,7 @@ quicklisp/ directory, with respective copyrights and licenses.
)))) ))))
(defmacro without-package-variance-warnings (&body body)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(handler-bind (#+sbcl(sb-int:package-at-variance #'muffle-warning))
,@body)))
\ No newline at end of file
...@@ -76,14 +76,22 @@ ...@@ -76,14 +76,22 @@
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,self-arg ,(make-keyword attr-sym)) ,val-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)) `(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))))
`(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)) `(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok)))))) computed-slots))
...@@ -98,21 +106,32 @@ ...@@ -98,21 +106,32 @@
(list (list
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:begin-redefinitions-ok)) `(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:begin-redefinitions-ok))
(unless from-objects? ;; DJC trim effort (unless from-objects? ;; DJC trim effort
`(defmethod ,(glisp:intern (symbol-name slot) :gdl-inputs) ((,parent-arg gdl-basis) ;;
,part-arg ;; FLAG -- duplicated from objects.lisp, inputs.lisp, functions.lisp, and above in this file.
(,self-arg gdl-basis)) ;;
(declare (ignore ,part-arg)) `(unless (and (fboundp ',(glisp:intern (symbol-name slot) :gdl-inputs))
(let ((,val-arg (getf (the-object ,self-arg %parameters%) (find-method (symbol-function ',(glisp:intern (symbol-name slot) :gdl-inputs))
,(make-keyword (symbol-name slot)) 'gdl-rule:%not-handled%))) nil (list (find-class 'gdl-basis) (find-class t) (find-class 'gdl-basis)) nil))
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,parent-arg ,(make-keyword slot)) ,val-arg)))) (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)))))
`(defmethod ,(glisp:intern (symbol-name slot) :gdl-trickle-downs) ((,self-arg gdl-basis) &rest ,args-arg) `(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))
(trickle-down-basis ,self-arg ',slot ,args-arg)) 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)))
`(defmethod ,(glisp:intern (symbol-name slot) :gdl-slots) ((,self-arg gdl-basis) &rest ,args-arg) `(unless nil #+nil(and (fboundp ',(glisp:intern (symbol-name slot) :gdl-slots))
(find-method (symbol-function ',(glisp:intern (symbol-name slot) :gdl-slots))
(chase-up-trickle-down ',(glisp:intern (symbol-name slot) :gdl-slots) ,self-arg ,args-arg)) 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)))))) `(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok))))))
......
...@@ -98,14 +98,20 @@ ...@@ -98,14 +98,20 @@
,parent-arg (the-object ,self-arg :%name%) ,self-arg))))) ,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))
`(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-inputs) ((,parent-arg gdl-basis) ;;
,part-arg ;; FLAG -- duplicated from inputs.lisp, objects.lisp, and computed-slots.lisp
(,self-arg gdl-basis)) ;;
(declare (ignore ,part-arg)) `(unless (and (fboundp ',(glisp:intern (symbol-name attr-sym) :gdl-inputs))
(let ((,val-arg (getf (the-object ,self-arg %parameters%) (find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-inputs))
,(make-keyword (symbol-name attr-sym)) 'gdl-rule:%not-handled%))) nil (list (find-class 'gdl-basis) (find-class t) (find-class 'gdl-basis)) nil))
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,parent-arg ,(make-keyword attr-sym)) ,val-arg))) (defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-inputs) ((,parent-arg gdl-basis)
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok))))))) ,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)))))))
......