bd2407ec6da3ae700c7d8f7101c0393ab8715f36
[sod] / src / class-make-impl.lisp
1 ;;; -*-lisp-*-
2 ;;;
3 ;;; Class construction protocol implementation
4 ;;;
5 ;;; (c) 2009 Straylight/Edgeware
6 ;;;
7
8 ;;;----- Licensing notice ---------------------------------------------------
9 ;;;
10 ;;; This file is part of the Sensible Object Design, an object system for C.
11 ;;;
12 ;;; SOD is free software; you can redistribute it and/or modify
13 ;;; it under the terms of the GNU General Public License as published by
14 ;;; the Free Software Foundation; either version 2 of the License, or
15 ;;; (at your option) any later version.
16 ;;;
17 ;;; SOD is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;;; GNU General Public License for more details.
21 ;;;
22 ;;; You should have received a copy of the GNU General Public License
23 ;;; along with SOD; if not, write to the Free Software Foundation,
24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
25
26 (cl:in-package #:sod)
27
28 ;;;--------------------------------------------------------------------------
29 ;;; Classes.
30
31 (defmethod shared-initialize :after ((class sod-class) slot-names &key pset)
32 "Specific behaviour for SOD class initialization.
33
34 Properties inspected are as follows:
35
36 * `:metaclass' names the metaclass to use. If unspecified, nil is
37 stored, and (unless you intervene later) `guess-metaclass' will be
38 called by `finalize-sod-class' to find a suitable default.
39
40 * `:nick' provides a nickname for the class. If unspecified, a default
41 (the class's name, forced to lowercase) will be chosen in
42 `finalize-sod-class'.
43
44 * `:link' names the chained superclass. If unspecified, this class will
45 be left at the head of its chain."
46
47 ;; If no nickname, copy the class name. It won't be pretty, though.
48 (default-slot-from-property (class 'nickname slot-names)
49 (pset :nick :id)
50 (string-downcase (slot-value class 'name)))
51
52 ;; Set the metaclass if the appropriate property has been provided;
53 ;; otherwise leave it unbound for now, and we'll sort out the mess during
54 ;; finalization.
55 (default-slot-from-property (class 'metaclass slot-names)
56 (pset :metaclass :id meta (find-sod-class meta)))
57
58 ;; If no chain-link, then start a new chain here.
59 (default-slot-from-property (class 'chain-link slot-names)
60 (pset :link :id link (find-sod-class link))
61 nil))
62
63 ;;;--------------------------------------------------------------------------
64 ;;; Slots.
65
66 (defmethod make-sod-slot
67 ((class sod-class) name type pset &optional location)
68 (with-default-error-location (location)
69 (let ((slot (make-instance (get-property pset :slot-class :symbol
70 'sod-slot)
71 :class class
72 :name name
73 :type type
74 :location (file-location location)
75 :pset pset)))
76 (with-slots (slots) class
77 (setf slots (append slots (list slot))))
78 slot)))
79
80 (defmethod shared-initialize :after ((slot sod-slot) slot-names &key pset)
81 "This method does nothing.
82
83 It only exists so that it isn't an error to provide a `:pset' initarg
84 to (make-instance 'sod-slot ...)."
85
86 (declare (ignore slot-names pset)))
87
88 ;;;--------------------------------------------------------------------------
89 ;;; Slot initializers.
90
91 (defmethod make-sod-instance-initializer
92 ((class sod-class) nick name value pset &optional location)
93 (with-default-error-location (location)
94 (let* ((slot (find-instance-slot-by-name class nick name))
95 (initializer (and value
96 (make-sod-initializer-using-slot
97 class slot 'sod-instance-initializer
98 value pset (file-location location)))))
99 (with-slots (instance-initializers) class
100
101 (setf instance-initializers
102 (append instance-initializers (list initializer))))
103 initializer)))
104
105 (defmethod make-sod-class-initializer
106 ((class sod-class) nick name value pset &optional location)
107 (with-default-error-location (location)
108 (let* ((slot (find-class-slot-by-name class nick name))
109 (initializer (make-sod-initializer-using-slot
110 class slot 'sod-class-initializer
111 value pset (file-location location))))
112 (with-slots (class-initializers) class
113 (setf class-initializers
114 (append class-initializers (list initializer))))
115 initializer)))
116
117 (defmethod make-sod-initializer-using-slot
118 ((class sod-class) (slot sod-slot) init-class value pset location)
119 (make-instance (get-property pset :initializer-class :symbol init-class)
120 :class class
121 :slot slot
122 :value value
123 :location (file-location location)
124 :pset pset))
125
126 (defmethod shared-initialize :after
127 ((init sod-initializer) slot-names &key pset)
128 "This method does nothing.
129
130 It only exists so that it isn't an error to provide a `:pset' initarg
131 to (make-instance 'sod-initializer ...)."
132 (declare (ignore slot-names pset))
133 nil)
134
135 ;;;--------------------------------------------------------------------------
136 ;;; Initialization and teardown fragments.
137
138 (defmethod make-sod-class-initfrag
139 ((class sod-class) frag pset &optional location)
140 (declare (ignore pset location))
141 (with-slots (initfrags) class
142 (setf initfrags (append initfrags (list frag)))))
143
144 (defmethod make-sod-class-tearfrag
145 ((class sod-class) frag pset &optional location)
146 (declare (ignore pset location))
147 (with-slots (tearfrags) class
148 (setf tearfrags (append tearfrags (list frag)))))
149
150 ;;;--------------------------------------------------------------------------
151 ;;; Messages.
152
153 (defmethod make-sod-message
154 ((class sod-class) name type pset &optional location)
155 (with-default-error-location (location)
156 (let* ((msg-class (or (get-property pset :message-class :symbol)
157 (and (get-property pset :combination :keyword)
158 'aggregating-message)
159 'standard-message))
160 (message (make-instance msg-class
161 :class class
162 :name name
163 :type type
164 :location (file-location location)
165 :pset pset)))
166 (with-slots (messages) class
167 (setf messages (append messages (list message))))
168 message)))
169
170 (defmethod shared-initialize :after
171 ((message sod-message) slot-names &key pset)
172 (declare (ignore slot-names pset))
173 (with-slots ((type %type)) message
174 (check-message-type message type)))
175
176 (defmethod check-message-type ((message sod-message) (type c-function-type))
177 nil)
178
179 (defmethod check-message-type ((message sod-message) (type c-type))
180 (error "Messages must have function type, not ~A" type))
181
182 ;;;--------------------------------------------------------------------------
183 ;;; Methods.
184
185 (defmethod make-sod-method
186 ((class sod-class) nick name type body pset &optional location)
187 (with-default-error-location (location)
188 (let* ((message (find-message-by-name class nick name))
189 (method (make-sod-method-using-message message class
190 type body pset
191 (file-location location))))
192 (with-slots (methods) class
193 (setf methods (append methods (list method))))
194 method)))
195
196 (defmethod make-sod-method-using-message
197 ((message sod-message) (class sod-class) type body pset location)
198 (make-instance (or (get-property pset :method-class :symbol)
199 (sod-message-method-class message class pset))
200 :message message
201 :class class
202 :type type
203 :body body
204 :location (file-location location)
205 :pset pset))
206
207 (defmethod sod-message-method-class
208 ((message sod-message) (class sod-class) pset)
209 (declare (ignore pset))
210 'sod-method)
211
212 (defmethod shared-initialize :after
213 ((method sod-method) slot-names &key pset)
214 (declare (ignore slot-names pset))
215
216 ;; Check that the arguments are named if we have a method body.
217 (with-slots (body (type %type)) method
218 (unless (or (not body)
219 (every (lambda (arg)
220 (or (eq arg :ellipsis)
221 (argument-name arg)
222 (c-type-equal-p (argument-type arg)
223 c-type-void)))
224 (c-function-arguments type)))
225 (error "Abstract declarators not permitted in method definitions")))
226
227 ;; Check the method type.
228 (with-slots (message (type %type)) method
229 (check-method-type method message type)))
230
231 (defmethod check-method-type
232 ((method sod-method) (message sod-message) (type c-type))
233 (error "Methods must have function type, not ~A" type))
234
235 (export 'check-method-return-type)
236 (defun check-method-return-type (method-type wanted-type)
237 "Signal an error unless METHOD-TYPE does not return the WANTED-TYPE."
238 (let ((method-returns (c-type-subtype method-type)))
239 (unless (c-type-equal-p method-returns wanted-type)
240 (error "Method return type ~A should be ~A"
241 method-returns wanted-type))))
242
243 (export 'check-method-return-type-against-message)
244 (defun check-method-return-type-against-message (method-type message-type)
245 "Signal an error unless METHOD-TYPE and MESSAGE-TYPE return the same type."
246 (let ((message-returns (c-type-subtype message-type))
247 (method-returns (c-type-subtype method-type)))
248 (unless (c-type-equal-p message-returns method-returns)
249 (error "Method return type ~A doesn't match message ~A"
250 method-returns message-returns))))
251
252 (export 'check-method-argument-lists)
253 (defun check-method-argument-lists (method-type message-type)
254 "Signal an error unless METHOD-TYPE and MESSAGE-TYPE have matching argument
255 lists.
256
257 This checks that (a) the two types have matching lists of mandatory
258 arguments, and (b) that either both or neither types accept keyword
259 arguments."
260 (let ((message-keywords-p (typep message-type 'c-keyword-function-type))
261 (method-keywords-p (typep method-type 'c-keyword-function-type)))
262 (cond (message-keywords-p
263 (unless method-keywords-p
264 (error "Method must declare a keyword argument list")))
265 (method-keywords-p
266 (error "Method must not declare a keyword argument list"))))
267 (unless (argument-lists-compatible-p (c-function-arguments message-type)
268 (c-function-arguments method-type))
269 (error "Method arguments ~A don't match message ~A"
270 method-type message-type)))
271
272 (defmethod check-method-type
273 ((method sod-method) (message sod-message) (type c-function-type))
274 (with-slots ((msgtype %type)) message
275 (check-method-return-type-against-message type msgtype)
276 (check-method-argument-lists type msgtype)))
277
278 ;;;----- That's all, folks --------------------------------------------------