3 ;;; Class construction protocol implementation
5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Sensible Object Design, an object system for C.
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.
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.
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.
28 ;;;--------------------------------------------------------------------------
31 (defmethod guess-metaclass ((class sod-class))
32 "Default metaclass-guessing function for classes.
34 Return the most specific metaclass of any of the CLASS's direct
37 (select-minimal-class-property (sod-class-direct-superclasses class)
39 #'sod-subclass-p class "metaclass"))
41 (defmethod shared-initialize :after ((class sod-class) slot-names &key pset)
42 "Specific behaviour for SOD class initialization.
44 Properties inspected are as follows:
46 * `:metaclass' names the metaclass to use. If unspecified, this will be
47 left unbound, and (unless you intervene later) `guess-metaclass' will
48 be called by `finalize-sod-class' to find a suitable default.
50 * `:nick' provides a nickname for the class. If unspecified, a default
51 (the class's name, forced to lowercase) will be chosen in
54 * `:link' names the chained superclass. If unspecified, this class will
55 be left at the head of its chain.
57 Usually, the class's metaclass is determined here, either direcly from the
58 `:metaclass' property or by calling `guess-metaclass'. Guessing is
59 inhibited if the `:%bootstrapping' property is non-nil."
61 ;; If no nickname, copy the class name. It won't be pretty, though.
62 (default-slot-from-property (class 'nickname slot-names)
64 (string-downcase (slot-value class 'name)))
66 ;; Set the metaclass if the appropriate property has been provided or we're
67 ;; not bootstreapping; otherwise leave it unbound for now, and trust the
68 ;; caller to sort out the mess.
69 (multiple-value-bind (meta floc) (get-property pset :metaclass :id)
71 (setf (slot-value class 'metaclass)
72 (with-default-error-location (floc)
73 (find-sod-class meta))))
74 ((not (get-property pset :%bootstrapping :boolean))
75 (default-slot (class 'metaclass slot-names)
76 (guess-metaclass class)))))
78 ;; If no chain-link, then start a new chain here.
79 (default-slot-from-property (class 'chain-link slot-names)
80 (pset :link :id link (find-sod-class link))
83 ;;;--------------------------------------------------------------------------
86 (defmethod make-sod-slot
87 ((class sod-class) name type pset &optional location)
88 (with-default-error-location (location)
89 (when (typep type 'c-function-type)
90 (error "Slot declarations cannot have function type"))
91 (let ((slot (make-instance (get-property pset :slot-class :symbol
96 :location (file-location location)
98 (initarg-name (get-property pset :initarg :id)))
99 (with-slots (slots) class
100 (setf slots (append slots (list slot))))
102 (make-sod-slot-initarg-using-slot class initarg-name
106 (defmethod shared-initialize :after ((slot sod-slot) slot-names &key pset)
107 "This method does nothing.
109 It only exists so that it isn't an error to provide a `:pset' initarg
110 to (make-instance 'sod-slot ...)."
112 (declare (ignore slot-names pset)))
114 ;;;--------------------------------------------------------------------------
115 ;;; Slot initializers.
117 (defmethod make-sod-instance-initializer
118 ((class sod-class) nick name value pset &optional location)
119 (with-default-error-location (location)
120 (let* ((slot (find-instance-slot-by-name class nick name))
121 (initarg-name (get-property pset :initarg :id))
122 (initializer (and value
123 (make-sod-initializer-using-slot
124 class slot 'sod-instance-initializer
125 value pset (file-location location)))))
126 (with-slots (instance-initializers) class
127 (unless (or initarg-name initializer)
128 (error "Slot initializer declaration with no effect"))
130 (make-sod-slot-initarg-using-slot class initarg-name slot
133 (setf instance-initializers
134 (append instance-initializers (list initializer)))))
137 (defmethod make-sod-class-initializer
138 ((class sod-class) nick name value pset &optional location)
139 (with-default-error-location (location)
140 (let* ((slot (find-class-slot-by-name class nick name))
141 (initializer (make-sod-initializer-using-slot
142 class slot 'sod-class-initializer
143 value pset (file-location location))))
144 (with-slots (class-initializers) class
145 (setf class-initializers
146 (append class-initializers (list initializer))))
149 (defmethod make-sod-initializer-using-slot
150 ((class sod-class) (slot sod-slot) init-class value pset location)
151 (make-instance (get-property pset :initializer-class :symbol init-class)
155 :location (file-location location)
158 (defmethod shared-initialize :after
159 ((init sod-initializer) slot-names &key pset)
160 "This method does nothing.
162 It only exists so that it isn't an error to provide a `:pset' initarg
163 to (make-instance 'sod-initializer ...)."
164 (declare (ignore slot-names pset))
167 (defmethod make-sod-user-initarg
168 ((class sod-class) name type pset &optional default location)
169 (with-slots (initargs) class
170 (push (make-instance (get-property pset :initarg-class :symbol
172 :location (file-location location)
173 :class class :name name :type type :default default)
176 (defmethod make-sod-slot-initarg
177 ((class sod-class) name nick slot-name pset &optional location)
178 (let ((slot (find-instance-slot-by-name class nick slot-name)))
179 (make-sod-slot-initarg-using-slot class name slot pset location)))
181 (defmethod make-sod-slot-initarg-using-slot
182 ((class sod-class) name (slot sod-slot) pset &optional location)
183 (with-slots (initargs) class
184 (with-slots ((type %type)) slot
185 (push (make-instance (get-property pset :initarg-class :symbol
187 :location (file-location location)
188 :class class :name name :type type :slot slot)
191 (defmethod sod-initarg-default ((initarg sod-initarg)) nil)
193 (defmethod sod-initarg-argument ((initarg sod-initarg))
194 (make-argument (sod-initarg-name initarg)
195 (sod-initarg-type initarg)
196 (sod-initarg-default initarg)))
198 ;;;--------------------------------------------------------------------------
199 ;;; Initialization and teardown fragments.
201 (defmethod make-sod-class-initfrag
202 ((class sod-class) frag pset &optional location)
203 (declare (ignore pset location))
204 (with-slots (initfrags) class
205 (setf initfrags (append initfrags (list frag)))))
207 (defmethod make-sod-class-tearfrag
208 ((class sod-class) frag pset &optional location)
209 (declare (ignore pset location))
210 (with-slots (tearfrags) class
211 (setf tearfrags (append tearfrags (list frag)))))
213 ;;;--------------------------------------------------------------------------
216 (defmethod make-sod-message
217 ((class sod-class) name type pset &optional location)
218 (with-default-error-location (location)
219 (let* ((msg-class (or (get-property pset :message-class :symbol)
220 (and (get-property pset :combination :keyword)
221 'aggregating-message)
223 (message (make-instance msg-class
227 :location (file-location location)
229 (with-slots (messages) class
230 (setf messages (append messages (list message))))
233 (defmethod shared-initialize :after
234 ((message sod-message) slot-names &key pset)
235 (declare (ignore slot-names pset))
236 (with-slots ((type %type)) message
237 (check-message-type message type)))
239 (defmethod check-message-type ((message sod-message) (type c-function-type))
242 (defmethod check-message-type ((message sod-message) (type c-type))
243 (error "Messages must have function type, not ~A" type))
245 ;;;--------------------------------------------------------------------------
248 (defmethod make-sod-method
249 ((class sod-class) nick name type body pset &optional location)
250 (with-default-error-location (location)
251 (let* ((message (find-message-by-name class nick name))
252 (method (make-sod-method-using-message message class
254 (file-location location))))
255 (with-slots (methods) class
256 (setf methods (append methods (list method))))
259 (defmethod make-sod-method-using-message
260 ((message sod-message) (class sod-class) type body pset location)
261 (make-instance (or (get-property pset :method-class :symbol)
262 (sod-message-method-class message class pset))
267 :location (file-location location)
270 (defmethod sod-message-method-class
271 ((message sod-message) (class sod-class) pset)
272 (declare (ignore pset))
275 (defmethod shared-initialize :after
276 ((method sod-method) slot-names &key pset)
277 (declare (ignore slot-names pset))
279 ;; Check that the arguments are named if we have a method body.
280 (with-slots (body (type %type)) method
281 (unless (or (not body)
283 (or (eq arg :ellipsis)
285 (c-type-equal-p (argument-type arg)
287 (c-function-arguments type)))
288 (error "Abstract declarators not permitted in method definitions")))
290 ;; Check the method type.
291 (with-slots (message (type %type)) method
292 (check-method-type method message type)))
294 (defmethod check-method-type
295 ((method sod-method) (message sod-message) (type c-type))
296 (error "Methods must have function type, not ~A" type))
298 (export 'check-method-return-type)
299 (defun check-method-return-type (method-type wanted-type)
300 "Signal an error unless METHOD-TYPE does not return the WANTED-TYPE."
301 (let ((method-returns (c-type-subtype method-type)))
302 (unless (c-type-equal-p method-returns wanted-type)
303 (error "Method return type ~A should be ~A"
304 method-returns wanted-type))))
306 (export 'check-method-return-type-against-message)
307 (defun check-method-return-type-against-message (method-type message-type)
308 "Signal an error unless METHOD-TYPE and MESSAGE-TYPE return the same type."
309 (let ((message-returns (c-type-subtype message-type))
310 (method-returns (c-type-subtype method-type)))
311 (unless (c-type-equal-p message-returns method-returns)
312 (error "Method return type ~A doesn't match message ~A"
313 method-returns message-returns))))
315 (export 'check-method-argument-lists)
316 (defun check-method-argument-lists (method-type message-type)
317 "Signal an error unless METHOD-TYPE and MESSAGE-TYPE have matching argument
320 This checks that (a) the two types have matching lists of mandatory
321 arguments, and (b) that either both or neither types accept keyword
323 (let ((message-keywords-p (typep message-type 'c-keyword-function-type))
324 (method-keywords-p (typep method-type 'c-keyword-function-type)))
325 (cond (message-keywords-p
326 (unless method-keywords-p
327 (error "Method must declare a keyword argument list")))
329 (error "Method must not declare a keyword argument list"))))
330 (unless (argument-lists-compatible-p (c-function-arguments message-type)
331 (c-function-arguments method-type))
332 (error "Method arguments ~A don't match message ~A"
333 method-type message-type)))
335 (defmethod check-method-type
336 ((method sod-method) (message sod-message) (type c-function-type))
337 (with-slots ((msgtype %type)) message
338 (check-method-return-type-against-message type msgtype)
339 (check-method-argument-lists type msgtype)))
341 ;;;----- That's all, folks --------------------------------------------------