computed-slots.lisp 7.26 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
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
;;
;; Copyright 2002-2011 Genworks International and Genworks BV 
;;
;; 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)

(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))))))
           
78
           `(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:begin-redefinitions-ok))
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
	   

	   ;;
	   ;; 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))))
94

95
           `(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok)))))) computed-slots))
96
97
98
99
100
101
102
103
104
105
106


(defun trickle-down-slots-section (slots &key from-objects?)
  (mapcan 
   #'(lambda(slot)
       (let (;; DJC trim effort
             ;; (result (gensym))
             )
         (remove 
          nil
          (list
107
           `(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:begin-redefinitions-ok))
108
           (unless from-objects? ;; DJC trim effort
109
110
111
	     ;;
 	     ;; FLAG -- duplicated from objects.lisp, inputs.lisp, functions.lisp, and above in this file. 
	     ;;
Dave Cooper's avatar
Dave Cooper committed
112
113
114
             `(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))
115
116
117
118
119
120
121
		(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)))))
122

123
124
125
126
127
128
	   `(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))
	      (defmethod ,(glisp:intern (symbol-name slot) :gdl-trickle-downs) ((,self-arg gdl-basis) &rest ,args-arg)
		
		(trickle-down-basis ,self-arg ',slot ,args-arg)))
129
           
Dave Cooper's avatar
Dave Cooper committed
130
131
132
           `(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))
133
134
	      (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)))
135
136

           
137
           `(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok))))))
138
   slots))