Commit e269264d authored by Dave Cooper's avatar Dave Cooper

got patched cleaned up

parent 7075b337
......@@ -75,12 +75,12 @@
`(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? `(iq:qlet (()) ,attr-expr) attr-expr))
#+nil
(with-dependency-tracking (,attr-sym)
,(if query? `(iq:qlet (()) ,attr-expr) attr-expr))
#+nil
(with-dependency-tracking (,attr-sym)
,(if query? (error "Query-slots are not supported in this distribution of Genworks GDL.")
attr-expr)))))
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,18 +89,16 @@
(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)))))))
`(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%)))
(if (or (null ,parent-arg) ,args-arg) (not-handled ,self-arg ,(make-keyword attr-sym) ,args-arg)
(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) ,args-arg) ,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)
;;(declare (ignore ,args-arg))
(let ((,parent-arg (the-object ,self-arg %parent%)))
(if (or (null ,parent-arg) ,args-arg) (not-handled ,self-arg ,(make-keyword attr-sym) ,args-arg)
(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) ,args-arg) ,val-arg))))))))))
computed-slots))
......
......@@ -66,14 +66,14 @@
,(if has-declare? (first body) `(declare))
,(when *compile-circular-reference-detection?*
`(when (and *run-with-circular-reference-detection?*
(member (list self ',attr-sym) *till-now* :test #'equalp))
(error "Circular reference detected")))
`(when (and *run-with-circular-reference-detection?*
(member (list self ',attr-sym) *till-now* :test #'equalp))
(error "Circular reference detected")))
(let ,(remove nil
(list (when *compile-circular-reference-detection?*
`(*till-now* (when *run-with-circular-reference-detection?*
(cons (list self ',attr-sym) *till-now*))))))
(list (when *compile-circular-reference-detection?*
`(*till-now* (when *run-with-circular-reference-detection?*
(cons (list self ',attr-sym) *till-now*))))))
(block ,(make-keyword attr-sym)
(let ((*error-on-not-handled?* t))
,@(if has-declare? (rest body) body))))) ,args-arg))
......@@ -86,9 +86,9 @@
(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??
;;
;;
;; 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)))
......@@ -96,8 +96,8 @@
;;(declare (ignore ,args-arg))
(let ((,parent-arg (the-object ,self-arg %parent%)))
(if (or (null ,parent-arg) ,args-arg) (not-handled ,self-arg ,(make-keyword attr-sym) ,args-arg)
(,(glisp:intern (symbol-name attr-sym) :gdl-inputs)
,parent-arg (the-object ,self-arg :%name%) ,self-arg))))))))))
(,(glisp:intern (symbol-name attr-sym) :gdl-inputs)
,parent-arg (the-object ,self-arg :%name%) ,self-arg))))))))))
......
......@@ -24,7 +24,7 @@
(defun not-handled (object message &optional args)
(if *error-on-not-handled?*
(not-handled-error object message args)
'gdl-rule:%not-handled%))
'gdl-rule:%not-handled%))
(defun input-slots-generics (input-slots)
......@@ -76,8 +76,8 @@
(mapcan
#'(lambda(input)
(let* ((attr-sym (glisp:intern (symbol-name (if (symbolp input)
input
(message-symbol input))) :gdl-acc))
input
(message-symbol input))) :gdl-acc))
(attr-remarks (when (consp input) (message-strings input))))
(remove
nil
......@@ -91,26 +91,28 @@
(when (and *compile-for-dgdl?* (not (eql attr-sym 'gdl-acc::type)))
`(unless (find-method (symbol-function ',(glisp:intern attr-sym :gdl-inputs))
nil (list (find-class 'gdl-remote) t (find-class 'gdl-basis)) nil)
(defmethod ,(glisp:intern attr-sym :gdl-inputs) ((,parent-arg gdl-remote)
,part-arg
(,self-arg gdl-basis))
(the-object ,parent-arg (fetch-input ,(make-keyword attr-sym) ,part-arg ,self-arg)))))
nil (list (find-class 'gdl-remote) t (find-class 'gdl-basis)) nil)
(defmethod ,(glisp:intern attr-sym :gdl-inputs) ((,parent-arg gdl-remote)
,part-arg
(,self-arg gdl-basis))
(the-object ,parent-arg (fetch-input ,(make-keyword attr-sym) ,part-arg ,self-arg)))))
;;
;; FLAG -- added recently, because why wouldn't we need default message handlers for input-slots?
;;
;; FLAG -- did this cause problems for DAP? Keep an eye out for this.
;;
;; FLAG -- added recently, because why wouldn't we need default message handlers for input-slots?
;;
`(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%)))
(if (or (null ,parent-arg) ,args-arg) (not-handled ,self-arg ,(make-keyword attr-sym) ,args-arg)
(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) ,args-arg) ,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)
(let ((,parent-arg (the-object ,self-arg %parent%)))
(if (or (null ,parent-arg) ,args-arg) (not-handled ,self-arg ,(make-keyword attr-sym) ,args-arg)
(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) ,args-arg) ,val-arg))))))
......@@ -123,14 +125,14 @@
(if ,parent-arg
(let (*error-on-not-handled?*)
(,(glisp:intern (symbol-name attr-sym) :gdl-inputs)
,parent-arg (the-object self %name%) self))
'gdl-rule:%not-handled%)))
,parent-arg (the-object self %name%) self))
'gdl-rule:%not-handled%)))
(cond ((not (eql ,val-arg 'gdl-rule:%not-handled%)) ,val-arg)
((and ,parent-arg (fboundp ',(glisp:intern (symbol-name attr-sym) :gdl-trickle-downs)))
(if ;;(member ,(make-key attr-sym) (the-object ,parent-arg :%trickle-down-slots%))
(gethash ,(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)))
(gethash ,(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) ,args-arg)))))))))))) input-slots))
(defun optional-input-slots-section (name input-slots &optional (defaulted? nil))
......@@ -161,12 +163,13 @@
`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:begin-redefinitions-ok))
(when (and *compile-for-dgdl?* (not (string-equal (symbol-name name) "remote-object") ))
(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 gdl-remote) &rest ,args-arg)
(the (send (:apply (cons ,(make-keyword (symbol-name attr-sym)) ,args-arg)))))))
(when *compile-for-dgdl?*
`(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-inputs) ((,parent-arg gdl-remote)
......@@ -191,13 +194,13 @@
`(if (eql ,val-arg 'gdl-rule:%not-handled%)
(let ((,val-arg (if ,parent-arg
(let (*error-on-not-handled?*)
(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%))
(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))))))))))) input-slots))
,val-arg)
`(if (eql ,val-arg 'gdl-rule:%not-handled%) ,attr-expr ,val-arg))))))))))) input-slots))
......
......@@ -25,28 +25,28 @@
(defun object-inputs-generics-section (cooked-data &key special-keys)
(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))
(getf data :with-attribute-keys)))))
(set-difference plist-keys special-keys))) cooked-data))))))
(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
(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)))
,@(append
(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 (or (null ,parent-arg) ,args-arg) (not-handled ,self-arg ,(make-keyword key) ,args-arg)
(,(glisp:intern key :gdl-inputs)
,parent-arg (the-object ,self-arg :%name%) ,self-arg)))))) object-input-keys))))
`(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 (or (null ,parent-arg) ,args-arg) (not-handled ,self-arg ,(make-keyword key) ,args-arg)
(,(glisp:intern key :gdl-inputs)
,parent-arg (the-object ,self-arg :%name%) ,self-arg)))))) object-input-keys))))
......
This diff is collapsed.
......@@ -72,36 +72,36 @@ set of arms contained in the body which is contained in the robot which is conta
(setq apply? t)(second (first (rest first))))
((listp first) (rest first))))
;;(new-object (gensym))
(new-object '+new-object+)
)
(new-object '+new-object+)
)
`(the-object ,(if *undeclared-parameters-enabled?*
(if evaluate?
`(if (fboundp (glisp:intern (symbol-name ,message) :gdl-slots))
(funcall (symbol-function (glisp:intern (symbol-name ,message) :gdl-slots)) ,object ,@args)
(let ((,new-object (getf (gdl-slots::%parameters% ,object)
(make-keyword ,message) 'gdl-rule:%not-handled%)))
(if (eql ,new-object 'gdl-rule:%not-handled%)
(not-handled-error ,object ',message ',args) ,new-object)))
`(if (fboundp ',message) (,message ,object ,@args)
(let ((,new-object (getf (gdl-slots::%parameters% ,object)
,(make-keyword message) 'gdl-rule:%not-handled%)))
(if (eql ,new-object 'gdl-rule:%not-handled%)
(not-handled-error ,object ',message ',args) ,new-object))))
(cond ((and evaluate? apply?)
`(apply (symbol-function (glisp:intern (symbol-name ,message) :gdl-slots)) ,object
(let ((,new-object (getf (gdl-slots::%parameters% ,object)
(make-keyword ,message) 'gdl-rule:%not-handled%)))
(if (eql ,new-object 'gdl-rule:%not-handled%)
(not-handled-error ,object ',message ',args) ,new-object)))
`(if (fboundp ',message) (,message ,object ,@args)
(let ((,new-object (getf (gdl-slots::%parameters% ,object)
,(make-keyword message) 'gdl-rule:%not-handled%)))
(if (eql ,new-object 'gdl-rule:%not-handled%)
(not-handled-error ,object ',message ',args) ,new-object))))
(cond ((and evaluate? apply?)
`(apply (symbol-function (glisp:intern (symbol-name ,message) :gdl-slots)) ,object
,args))
(evaluate?
`(funcall (symbol-function (glisp:intern (symbol-name ,message) :gdl-slots)) ,object
,@args))
(apply?
`(apply ',message ,object ,args))
(evaluate?
`(funcall (symbol-function (glisp:intern (symbol-name ,message) :gdl-slots)) ,object
,@args))
(apply?
`(apply ',message ,object ,args))
(t `(,message ,object ,@args))))
(t `(,message ,object ,@args))))
,@(rest reference-chain))))
object))
object))
......@@ -114,16 +114,16 @@ This is often used for sending the <tt>index</tt> message to an element of a qua
(defun not-handled-error (object message &optional args)
(if (the-object object root?)
(error "~s, which is the root object, could not handle the ~s message~a."
object (make-keyword message)
(if args (format nil "~%with args: ~s " args) ""))
(error "Neither ~s nor any of its ancestor instances could handle the ~s message~a
(if (the-object object root?)
(error "~s, which is the root object, could not handle the ~s message~a."
object (make-keyword message)
(if args (format nil "~%with args: ~s " args) ""))
(error "Neither ~s nor any of its ancestor instances could handle the ~s message~a
The path to the containing object is: ~s"
object (make-keyword message)
(if args (format nil "~%with args: ~s " args) "")
(append '(the :root) (symbols-as-keywords
(reverse (the-object object :root-path)))))))
object (make-keyword message)
(if args (format nil "~%with args: ~s " args) "")
(append '(the :root) (symbols-as-keywords
(reverse (the-object object :root-path)))))))
(defmacro with-format ((format stream-or-file &rest args) &body body)
"Void [Macro]. Used to establish an output format and a stream to which data is to be sent. This is the experimental
......
......@@ -37,26 +37,29 @@
(defun chase-up-trickle-down (slot-symbol self args)
(let ((keyword (make-keyword slot-symbol)))
(let ((parent (the-object self parent)))
;;
;; FLAG -- make sure 'args' below is correct - it was removed in 1590 p002.lisp (which is now gone).
;;
(if (null parent) (not-handled self keyword args)
(let ((result
(let (*error-on-not-handled?*)
(funcall (symbol-function (glisp:intern slot-symbol :gdl-inputs)) parent (the %name%) self))))
(if (eql result 'gdl-rule:%not-handled%)
(let ((result
(let (*error-on-not-handled?*)
(cond (;;(member keyword (the-object parent %trickle-down-slots%))
(gethash keyword (the-object parent %trickle-down-slots%))
(apply (symbol-function slot-symbol) parent args))
(t (apply (symbol-function (glisp:intern slot-symbol :gdl-trickle-downs)) parent args))))))
(if (eql result 'gdl-rule:%not-handled%) (not-handled self keyword args) result))
result))))))
(let ((result
(let (*error-on-not-handled?*)
(funcall (symbol-function (glisp:intern slot-symbol :gdl-inputs)) parent (the %name%) self))))
(if (eql result 'gdl-rule:%not-handled%)
(let ((result
(let (*error-on-not-handled?*)
(cond (;;(member keyword (the-object parent %trickle-down-slots%))
(gethash keyword (the-object parent %trickle-down-slots%))
(apply (symbol-function slot-symbol) parent args))
(t (apply (symbol-function (glisp:intern slot-symbol :gdl-trickle-downs)) parent args))))))
(if (eql result 'gdl-rule:%not-handled%) (not-handled self keyword args) result))
result))))))
(defun trickle-down-basis (self slot args)
(let ((keyword (make-keyword slot)))
(let (*error-on-not-handled?* (parent (the parent)))
(cond ((null parent) (not-handled self keyword args))
(;;(member keyword (the-object parent %trickle-down-slots%))
(gethash keyword (the-object parent %trickle-down-slots%))
(apply (symbol-function (glisp:intern slot :gdl-slots)) parent args))
(t (apply (symbol-function (glisp:intern slot :gdl-trickle-downs)) parent args))))))
(;;(member keyword (the-object parent %trickle-down-slots%))
(gethash keyword (the-object parent %trickle-down-slots%))
(apply (symbol-function (glisp:intern slot :gdl-slots)) parent args))
(t (apply (symbol-function (glisp:intern slot :gdl-trickle-downs)) parent args))))))
......@@ -79,23 +79,16 @@ filleted-polyline."
(%renderer-info% (list :vrml? t :view-default :top))
(path-info (append
(let ((first? t))
(mapcan #'(lambda(straight curve-set)
(append (if first? (progn (setq first? nil)
(list :move (first straight) :line (second straight)))
(list :line (second straight)))
(apply #'append
(mapcar #'(lambda(curve) (cons :curve (rest (reverse curve))))
(reverse (the-object curve-set %curves-to-draw%))))))
(the straights) (list-elements (the fillets))))
(when (> (length (the straights)) (the fillets number-of-elements))
(list :line (second (lastcar (the straights)))))))
(path-info (let ((first? t))
(mapcan #'(lambda(straight curve-set)
(append (if first? (progn (setq first? nil)
(list :move (first straight) :line (second straight)))
(list :line (second straight)))
(apply #'append
(mapcar #'(lambda(curve) (cons :curve (rest (reverse curve))))
(reverse (the-object curve-set %curves-to-draw%))))))
(the straights) (list-elements (the fillets)))))
(fillet-types (mapcar #'(lambda(test)
(if (the-object test valid?) 'fillet 'null-part))
......
;;
;; Copyright 2002-2012 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; This source file contains free software: you can redistribute it
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
(in-package :gdl)
(#+allegro
excl:without-package-locks #-allegro progn
(#+allegro
excl:without-redefinition-warnings #-allegro progn
(defun load-hotpatches (&key force? (directory (merge-pathnames "hotpatches/" (glisp:executable-homedir-pathname))))
(if (not (and (probe-file directory)
(glisp:file-directory-p directory)))
(warn "~s does not exist and/or is not a directory~%" directory)
(let* ((files (glisp:directory-list directory))
(source-files (sort (remove-if-not #'(lambda(file)
(let ((type (pathname-type file)))
(or (string-equal type "lisp")
(string-equal type "gdl")
(string-equal type "gendl")))) files)
#'string-lessp :key #'namestring)))
(when (or (not (glisp:featurep :allegro))
(glisp:featurep :compiler))
(dolist (file source-files)
(with-error-handling ()
(format t "~&Compiling patch file ~a...~%" file)
(#+allegro excl:compile-file-if-needed #-allegro compile-file file))))
(setq files (remove-if #'(lambda(file)(string-equal (pathname-name file) "load")) (glisp:directory-list directory)))
(let ((compiled-files (sort (remove-if-not #'(lambda(file)
(string-equal (pathname-type file) glisp:*fasl-extension*)) files)
#'string-lessp :key #'namestring)))
(dolist (file compiled-files)
(unless (and (not force?) (find file *loaded-hotpatches* :test #'equalp))
(with-error-handling ()
(format t "~&Loading patch file ~a...~%" file)
(load file)
(pushnew file *loaded-hotpatches* :test #'equalp))))))))))
(load-hotpatches :directory (make-pathname :directory (pathname-directory *load-truename*) :defaults nil) :force? t)
;;
;; Copyright 2002-2011 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; This source file contains free software: you can redistribute it
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
These changes have been merged into codebase.
#|
(in-package :gdl)
(excl:without-package-locks
(excl:without-redefinition-warnings
(defmacro the-object (object &rest reference-chain)
"Lisp object. Sends the <tt>reference-chain</tt> to <tt>object</tt>, which must be specified
as a Lisp expression (e.g. a variable) which evaluates to a GDL object.
:arguments (reference-chain \"(&rest). A spliced-in list of symbols naming messages, which can
be slots or objects starting from <tt>object</tt>. For referring to elements of a quantified set,
or for passing arguments to GDL functions which take arguments, use parentheses around the
message name and enclose the quantified element index or function arguments after the message
name.\")
:example
This example sends the <tt>length</tt> message to the ``zeroth'' element of the quantified
set of arms contained in the body which is contained in the robot which is contained in <tt>object</tt>:
<pre>
(the-object object robot body (arms 0) length)
</pre>"
(if reference-chain
(let ((first (first reference-chain)) evaluate? apply?)
(let ((message (cond ((atom first) (glisp:intern (symbol-name first) :gdl-slots))
((and (symbolp (first first))
(not (eql (first first) 'evaluate))) (glisp:intern (symbol-name (first first)) :gdl-slots))
((eql (first first) 'evaluate) (setq evaluate? t) (second first))
((and (consp (first first))
(eql (first (first first)) 'evaluate))
(setq evaluate? t)
(second (first first)))))
(args (cond ((and (listp first) (eql (first first) 'evaluate)) nil)
((and (listp first) (listp (first (rest first)))
(eql (first (first (rest first))) :apply))
(setq apply? t)(second (first (rest first))))
((listp first) (rest first))))
(new-object (gensym)))
`(the-object ,(if *undeclared-parameters-enabled?*
(if evaluate?
`(if (fboundp (glisp:intern (symbol-name ,message) :gdl-slots))
(funcall (symbol-function (glisp:intern (symbol-name ,message) :gdl-slots)) ,object ,@args)
(let ((,new-object (getf (gdl-slots::%parameters% ,object)
(make-keyword ,message) 'gdl-rule:%not-handled%)))
(if (eql ,new-object 'gdl-rule:%not-handled%)
(not-handled-error ,object ',message ',args) ,new-object)))
`(if (fboundp ',message) (,message ,object ,@args)
(let ((,new-object (getf (gdl-slots::%parameters% ,object)
,(make-keyword message) 'gdl-rule:%not-handled%)))
(if (eql ,new-object 'gdl-rule:%not-handled%)
(not-handled-error ,object ',message ',args) ,new-object))))
(cond ((and evaluate? apply?)
`(apply (symbol-function (glisp:intern (symbol-name ,message) :gdl-slots)) ,object
,args))
(evaluate?
`(funcall (symbol-function (glisp:intern (symbol-name ,message) :gdl-slots)) ,object
,@args))
(apply?
`(apply ',message ,object ,args))
(t `(,message ,object ,@args))))
,@(rest reference-chain))))
object))
(defun not-handled-error (object message &optional args)
(if (the-object object root?)
(error "~s, which is the root object, could not handle the ~s message~a."
object (make-keyword message)
(if args (format nil "~%with args: ~s " args) ""))
(error "Neither ~s nor any of its ancestor instances could handle the ~s message~a
The path to the containing object is: ~s"
object (make-keyword message)
(if args (format nil "~%with args: ~s " args) "")
(append '(the :root) (symbols-as-keywords
(reverse (the-object object :root-path)))))))
(defun not-handled (object message &optional args)
(if *error-on-not-handled?*
(not-handled-error object message args)
'gdl-rule:%not-handled%))
(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)))