3 ;;; Class construction protocol
5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Sensble 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 (export 'make-sod-class)
32 (defun make-sod-class (name superclasses pset &optional location)
33 "Construct and return a new SOD class with the given NAME and SUPERCLASSES.
35 This is the main constructor function for classes. The protocol works as
36 follows. The `:lisp-class' property in PSET is checked: if it exists, it
37 must be a symbol naming a (CLOS) class, which is used in place of
38 `sod-class'. All of the arguments are then passed to `make-instance';
39 further behaviour is left to the standard CLOS instance construction
40 protocol; for example, `sod-class' defines an `:after'-method on
43 Minimal sanity checking is done during class construction; most of it is
44 left for `finalize-sod-class' to do (via `check-sod-class').
46 Unused properties in PSET are diagnosed as errors."
48 (with-default-error-location (location)
49 (let* ((pset (property-set pset))
50 (class (make-instance (get-property pset :lisp-class :symbol
53 :superclasses superclasses
54 :location (file-location location)
56 (check-unused-properties pset)
59 (export 'guess-metaclass)
60 (defgeneric guess-metaclass (class)
62 "Determine a suitable metaclass for the CLASS.
64 The default behaviour is to choose the most specific metaclass of any of
65 the direct superclasses of CLASS, or to signal an error if that failed."))
67 ;;;--------------------------------------------------------------------------
68 ;;; Slots and slot initializers.
70 (export 'make-sod-slot)
71 (defgeneric make-sod-slot (class name type pset &optional location)
73 "Construct, add, and attach a new slot with given NAME and TYPE, to CLASS.
75 This is the main constructor function for slots. This is a generic
76 function primarily so that the CLASS can intervene in the construction
77 process. The default method uses the `:lisp-class' property (defaulting
78 to `sod-slot') to choose a (CLOS) class to instantiate. The slot is then
79 constructed by `make-instance' passing the arguments as initargs; further
80 behaviour is left to the standard CLOS instance construction protocol; for
81 example, `sod-slot' defines an `:after'-method on `shared-initialize'.
83 Unused properties on PSET are diagnosed as errors."))
85 (export 'make-sod-instance-initializer)
86 (defgeneric make-sod-instance-initializer
87 (class nick name value-kind value-form pset &optional location)
89 "Construct and attach an instance slot initializer, to CLASS.
91 This is the main constructor function for instance initializers. This is
92 a generic function primarily so that the CLASS can intervene in the
93 construction process. The default method looks up the slot using
94 `find-instance-slot-by-name', calls `make-sod-initializer-using-slot' to
95 actually make the initializer object, and adds it to the appropriate list
98 Unused properties on PSET are diagnosed as errors."))
100 (export 'make-sod-class-initializer)
101 (defgeneric make-sod-class-initializer
102 (class nick name value-kind value-form pset &optional location)
104 "Construct and attach a class slot initializer, to CLASS.
106 This is the main constructor function for class initializers. This is a
107 generic function primarily so that the CLASS can intervene in the
108 construction process. The default method looks up the slot using
109 `find-class-slot-by-name', calls `make-sod-initializer-using-slot' to
110 actually make the initializer object, and adds it to the appropriate list
113 Unused properties on PSET are diagnosed as errors."))
115 (export 'make-sod-initializer-using-slot)
116 (defgeneric make-sod-initializer-using-slot
117 (class slot init-class value-kind value-form pset location)
119 "Common construction protocol for slot initializers.
121 This generic function does the common work for constructing instance and
122 class initializers. It can usefully be specialized according to both the
123 class and slot types. The default method uses the `:lisp-class' property
124 (defaulting to INIT-CLASS) to choose a (CLOS) class to instantiate. The
125 slot is then constructed by `make-instance' passing the arguments as
126 initargs; further behaviour is left to the standard CLOS instance
127 construction protocol; for example, `sod-initializer' defines an
128 `:after'-method on `shared-initialize'.
130 Diagnosing unused properties is left for the caller (usually
131 `make-sod-instance-initializer' or `make-sod-class-initializer') to do.
132 The caller is also expected to have set `with-default-error-location' if
135 You are not expected to call this generic function directly; it's more
136 useful as a place to hang methods for custom initializer classes."))
138 ;;;--------------------------------------------------------------------------
139 ;;; Messages and methods.
141 (export 'make-sod-message)
142 (defgeneric make-sod-message (class name type pset &optional location)
144 "Construct and attach a new message with given NAME and TYPE, to CLASS.
146 This is the main constructor function for messages. This is a generic
147 function primarily so that the CLASS can intervene in the construction
148 process. The default method uses the `:lisp-class' property (defaulting
149 to `sod-message') to choose a (CLOS) class to instantiate. The message is
150 then constructed by `make-instance' passing the arguments as initargs;
151 further behaviour is left to the standard CLOS instance construction
152 protocol; for example, `sod-message' defines an `:after'-method on
155 Unused properties on PSET are diagnosed as errors."))
157 (export 'make-sod-method)
158 (defgeneric make-sod-method
159 (class nick name type body pset &optional location)
161 "Construct and attach a new method to CLASS.
163 This is the main constructor function for methods. This is a generic
164 function primarily so that the CLASS can intervene in the message lookup
165 process, though this is actually a fairly unlikely occurrence.
167 The default method looks up the message using `find-message-by-name',
168 invokes `make-sod-method-using-message' to make the method object, and
169 then adds the method to the class's list of methods. This split allows
170 the message class to intervene in the class selection process, for
173 Unused properties on PSET are diagnosed as errors."))
175 (export 'make-sod-method-using-message)
176 (defgeneric make-sod-method-using-message
177 (message class type body pset location)
179 "Main construction subroutine for method construction.
181 This is a generic function so that it can be specialized according to both
182 a class and -- more particularly -- a message. The default method uses
183 the `:lisp-class' property (defaulting to the result of calling
184 `sod-message-method-class') to choose a (CLOS) class to instantiate. The
185 method is then constructed by `make-instance' passing the arguments as
186 initargs; further behaviour is left to the standard CLOS instance
187 construction protocol; for example, `sod-method' defines an
188 `:after'-method on `shared-initialize'.
190 Diagnosing unused properties is left for the caller (usually
191 `make-sod-method') to do. The caller is also expected to have set
192 `with-default-error-location' if appropriate.
194 You are not expected to call this generic function directly; it's more
195 useful as a place to hang methods for custom method classes."))
197 (export 'sod-message-method-class)
198 (defgeneric sod-message-method-class (message class pset)
200 "Return the preferred class for methods on MESSAGE.
202 The message can inspect the PSET to decide on a particular message. A
203 `:lisp-class' property will usually override this decision: it's then the
204 programmer's responsibility to ensure that the selected method class is
207 (export 'check-message-type)
208 (defgeneric check-message-type (message type)
210 "Check that TYPE is a suitable type for MESSAGE. Signal errors if not.
212 This is separated out of `shared-initialize', where it's called, so that
213 it can be overridden conveniently by subclasses."))
215 (export 'check-method-type)
216 (defgeneric check-method-type (method message type)
218 "Check that TYPE is a suitable type for METHOD. Signal errors if not.
220 This is separated out of `shared-initialize', where it's called, so that
221 it can be overridden conveniently by subclasses."))
223 ;;;--------------------------------------------------------------------------
226 (export 'define-sod-class)
227 (defmacro define-sod-class (name (&rest superclasses) &body body)
228 "Construct a new SOD class called NAME in the current module.
230 The new class has the named direct SUPERCLASSES, which should be a list of
233 The BODY begins with a sequence of alternating keyword/value pairs
234 defining properties for the new class. The keywords are (obviously) not
235 evaluated, but the value forms are.
237 The remainder of the BODY are a sequence of forms to be evaluated as an
238 implicit `progn'. Additional macros are available to the BODY, to make
239 defining the class easier.
241 In the following, NAME is a string giving a C identifier; NICK is a string
242 giving the nickname of a superclass; TYPE is a C type using S-expression
245 * message NAME TYPE &rest PLIST
247 * method NICK NAME TYPE BODY &rest PLIST
249 * slot NAME TYPE &rest PLIST
251 * instance-initializer NICK NAME VALUE-KIND VALUE-FORM &rest PLIST
253 * class-initializer NICK NAME VALUE-KIND VALUE-FORM &rest PLIST"
256 (classvar (gensym "CLASS-")))
258 (when (or (null body)
259 (not (keywordp (car body))))
261 (push (pop body) plist)
262 (push (pop body) plist))
263 `(let ((,classvar (make-sod-class ,name
264 (mapcar #'find-sod-class
265 (list ,@superclasses))
267 ,@(nreverse plist)))))
268 (macrolet ((message (name type &rest plist)
269 `(make-sod-message ,',classvar ,name (c-type ,type)
270 (make-property-set ,@plist)))
271 (method (nick name type body &rest plist)
272 `(make-sod-method ,',classvar ,nick ,name (c-type ,type)
273 ,body (make-property-set ,@plist)))
274 (slot (name type &rest plist)
275 `(make-sod-slot ,',classvar ,name (c-type ,type)
276 (make-property-set ,@plist)))
277 (instance-initializer
278 (nick name value-kind value-form &rest plist)
279 `(make-sod-instance-initializer ,',classvar ,nick ,name
280 ,value-kind ,value-form
284 (nick name value-kind value-form &rest plist)
285 `(make-sod-class-initializer ,',classvar ,nick ,name
286 ,value-kind ,value-form
290 (finalize-sod-class ,classvar)
291 (add-to-module *module* ,classvar)))))
293 ;;;----- That's all, folks --------------------------------------------------