computed-slots.lisp 8.72 KB
Newer Older
1
;;
2
;; Copyright 2002-2012 Genworks International
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
;;
;; 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)

Dave Cooper's avatar
Dave Cooper committed
24
(defparameter *trickle-down-basis-method-hash* (make-hash-table))
25

26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
(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))
Dave Cooper's avatar
Dave Cooper committed
41
		       (gdl-rule::lookup-parameters ,self-arg ,(make-keyword message))))) messages)))
Dave Cooper's avatar
Dave Cooper committed
42
43
44
45
46
47
48
49
50
51


(eval-when (:compile-toplevel :load-toplevel :execute)
  (defpackage :iq (:use) (:export #:qlet)))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defmacro iq:qlet ((&rest args) &rest body)
    (declare (ignore args body))
    (error "Query-attributes are not supported in this Gendl distribution.~%")))

52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77

(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))
Dave Cooper's avatar
Dave Cooper committed
78
79
80
		  (with-dependency-tracking (,attr-sym)
		    ,(if query? `(iq:qlet (()) ,attr-expr) attr-expr))
		  #+nil
81
82
83
84
85
86
87
88
89
90
91
92
                  (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)))))))
           
93
94
	   `(unless (find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-slots))
				 nil (list (find-class 'gdl-basis)) nil)
95
	      (defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-slots) ((,self-arg gdl-basis) &rest ,args-arg)
96
		;;(declare (ignore ,args-arg))
97
		(let ((,parent-arg (the-object ,self-arg %parent%)))
98
		  (if (null ,parent-arg) (not-handled ,self-arg ,(make-keyword attr-sym) ,args-arg)
99
100
101
		      (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))))
102
			(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,self-arg ,(make-keyword attr-sym) ,args-arg) ,val-arg)))))))))) 
103
104
105
106
   computed-slots))



Dave Cooper's avatar
Dave Cooper committed
107
108
109
110
111
;;
;; 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).
;;
112
113
114
(defun trickle-down-slots-section (slots &key from-objects?)
  (mapcan 
   #'(lambda(slot)
Dave Cooper's avatar
Dave Cooper committed
115
116
117
118
       (remove 
	nil
	(list
	 (unless from-objects?
119
	   ;;
Dave Cooper's avatar
Dave Cooper committed
120
	   ;; FLAG -- duplicated from objects.lisp, inputs.lisp, functions.lisp, and above in this file. 
121
	   ;;
Dave Cooper's avatar
Dave Cooper committed
122
	   ;; FLAG -- this must be get-riddable. Test carefully because trickle-downs are relatively rare. 
123
124
	   ;;
	   ;; FLAG -- maybe don't remove, could have a trickle-down which is not otherwise declared as a message.
Dave Cooper's avatar
Dave Cooper committed
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
	   `(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)
140
141
142
143
144
145
146
	    ,@(remove 
	       nil
	       `((unless (fboundp ',(glisp:intern (symbol-name slot) :gdl-trickle-downs))
		   (defgeneric ,(glisp:intern (symbol-name slot) :gdl-trickle-downs) (,self-arg &rest ,args-arg)))
		 ,(unless from-objects?
			  `(unless (fboundp ',(glisp:intern (symbol-name slot) :gdl-slots))
			     (defgeneric ,(glisp:intern (symbol-name slot) :gdl-slots) (,self-arg &rest ,args-arg)))))))
147

Dave Cooper's avatar
Dave Cooper committed
148
149
150
151
152
153
	 `(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)))

	 ;;
154
155
	 ;; FLAG -- we need to redefine the standard gdl-basis method here for trickle-down-slots, 
	 ;;         figure out how to do it without the crude off/on of redefinition warnings.
Dave Cooper's avatar
Dave Cooper committed
156
	 ;;
Dave Cooper's avatar
Dave Cooper committed
157
158
159
160
161
162
163
164
	 ;;`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:begin-redefinitions-ok))
	 
	 `(unless (gethash ',(glisp:intern (symbol-name slot) :gdl-slots) *trickle-down-basis-method-hash*)
	    (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))
	    (setf (gethash ',(glisp:intern (symbol-name slot) :gdl-slots) *trickle-down-basis-method-hash*) t))
	 
	 #+nil
165
166
	 `(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))
Dave Cooper's avatar
Dave Cooper committed
167
168


169
170
171
172
173
	 #+nil
	 `(unless (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)))
Dave Cooper's avatar
Dave Cooper committed
174
	 ;;`(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok))
175
           
Dave Cooper's avatar
Dave Cooper committed
176
	 )))
177
   slots))