3 ;;; A collection of utility functions for SOD classes
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 ;;;--------------------------------------------------------------------------
29 ;;; Finding things by name
31 (export 'find-superclass-by-nick)
32 (defun find-superclass-by-nick (class nick)
33 "Returns the superclass of CLASS with nickname NICK, or signals an error."
35 ;; Slightly tricky. The class almost certainly hasn't been finalized, so
36 ;; trundle through its superclasses and hope for the best.
37 (if (string= nick (sod-class-nickname class))
39 (or (some (lambda (super)
40 (find nick (sod-class-precedence-list super)
41 :key #'sod-class-nickname
43 (sod-class-direct-superclasses class))
44 (error "No superclass of `~A' with nickname `~A'" class nick))))
46 (export '(find-instance-slot-by-name find-class-slot-by-name
47 find-message-by-name))
48 (flet ((find-thing-by-name (what class list name key)
49 (or (find name list :key key :test #'string=)
50 (error "No ~A in class `~A' with name `~A'" what class name))))
52 (defun find-instance-slot-by-name (class super-nick slot-name)
53 (let ((super (find-superclass-by-nick class super-nick)))
54 (find-thing-by-name "instance slot" super (sod-class-slots super)
55 slot-name #'sod-slot-name)))
57 (defun find-class-slot-by-name (class super-nick slot-name)
58 (let* ((meta (sod-class-metaclass class))
59 (super (find-superclass-by-nick meta super-nick)))
60 (find-thing-by-name "class slot" super (sod-class-slots super)
61 slot-name #'sod-slot-name)))
63 (defun find-message-by-name (class super-nick message-name)
64 (let ((super (find-superclass-by-nick class super-nick)))
65 (find-thing-by-name "message" super (sod-class-messages super)
66 message-name #'sod-message-name))))
68 ;;;--------------------------------------------------------------------------
69 ;;; Describing class inheritance paths in diagnostics.
71 (export 'inheritance-path-reporter-state)
72 (defclass inheritance-path-reporter-state ()
73 ((%class :type sod-class :initarg :class)
74 (paths :type list :initarg :paths)
75 (seen :type hash-table :initform (make-hash-table))))
77 (export 'make-inheritance-path-reporter-state)
78 (defun make-inheritance-path-reporter-state (class)
79 (make-instance 'inheritance-path-reporter-state :class class))
81 (export 'report-inheritance-path)
82 (defun report-inheritance-path (state super)
83 "Issue informational messages showing how CLASS inherits from SUPER."
84 (with-slots (paths (class %class) include-boundary seen) state
85 (unless (slot-boundp state 'paths)
86 (setf paths (distinguished-point-shortest-paths
89 (mapcar (lambda (super) (cons super 1))
90 (sod-class-direct-superclasses c))))))
91 (dolist (hop (mapcon (lambda (subpath)
92 (let ((super (car subpath))
93 (sub (and (cdr subpath)
95 (if (or (not sub) (gethash super seen))
98 (setf (gethash super seen) t)
99 (list (cons super sub))))))
100 (cdr (find super paths :key #'cadr))))
101 (let ((super (car hop))
103 (info-with-location sub
104 "Class `~A' is a direct superclass ~
105 of `~A', defined here"
108 ;;;--------------------------------------------------------------------------
109 ;;; Metaclass inference.
111 (export 'select-minimal-class-property)
112 (defun select-minimal-class-property (supers key order default what
113 &key (present (lambda (x)
114 (format nil "`~A'" x)))
116 "Return the minimal partially-ordered key from the SUPERS.
118 KEY is a function of one argument which returns some interesting property
119 of a class. The keys are assumed to be partially ordered by ORDER, a
120 function of two arguments which returns non-nil if its first argument
121 precedes its second. If there is a unique minimal key then return it;
122 otherwise report a useful error and pick some candidate in an arbitrary
123 way; the DEFAULT may be chosen if no better choices are available. If
124 ALLOW-EMPTY is non-nil, then no error is reported if there are no SUPERS,
125 and the DEFAULT choice is returned immediately.
127 In an error message, the keys are described as WHAT, which should be a
128 noun phrase; keys are filtered through PRESENT, a function of one
129 argument, before presentation.
131 The function returns two values: the chosen value, and a flag which is
132 non-nil if it was chosen without errors."
134 (let ((candidates (partial-order-minima (mapcar key supers) order)))
135 (cond ((and (null candidates) allow-empty)
137 ((and candidates (null (cdr candidates)))
138 (values (car candidates) t))
140 (cerror* "No obvious choice for implicit ~A: ~
141 ~{~#[root classes must specify explicitly~:;~
143 ~#[~;~A~;~A and ~A~:;~@{~A, ~#[~;and ~A~]~}~]~]~:}"
144 what (mapcar present candidates))
145 (dolist (candidate candidates)
146 (let ((super (find candidate supers :key key)))
147 (info-with-location super
148 "Direct superclass `~A' defined here ~
150 super what (funcall present candidate))))
151 (values (if candidates (car candidates) default) nil)))))
153 ;;;--------------------------------------------------------------------------
154 ;;; Miscellaneous useful functions.
156 (export 'sod-subclass-p)
157 (defun sod-subclass-p (class-a class-b)
158 "Return whether CLASS-A is a descendent of CLASS-B.
160 Careful! Assumes that the class precedence list of CLASS-A has been
162 (member class-b (sod-class-precedence-list class-a)))
164 (export 'valid-name-p)
165 (defun valid-name-p (name)
166 "Checks whether NAME is a valid name.
170 * the name must be a string
172 * whose first character is alphabetic
173 * all of whose characters are alphanumeric or underscores
174 * and which doesn't contain two consecutive underscores."
176 (or (typep name 'temporary-variable)
178 (plusp (length name))
179 (alpha-char-p (char name 0))
180 (every (lambda (ch) (or (alphanumericp ch) (char= ch #\_))) name)
181 (not (search "__" name)))))
183 (export 'find-root-superclass)
184 (defun find-root-superclass (class)
185 "Returns the `root' superclass of CLASS.
187 The root superclass is the superclass which itself has no direct
188 superclasses. In universes not based on the provided builtin module, the
189 root class may not be our beloved `SodObject'; however, there must be one
190 (otherwise the class graph is cyclic, which should be forbidden), and we
191 insist that it be unique."
193 ;; The root superclass must be a chain head since the chains partition the
194 ;; superclasses; the root has no superclasses so it can't have a link and
195 ;; must therefore be a head. This narrows the field down quite a lot.
197 ;; Note! This function gets called from `check-sod-class' before the
198 ;; class's chains have been computed. Therefore we iterate over the direct
199 ;; superclasses' chains rather than the class's own. This misses a chain
200 ;; only in the case where the class is its own chain head. There are two
201 ;; subcases: if there are no direct superclasses at all, then the class is
202 ;; its own root; otherwise, it clearly can't be the root and the omission
205 (let* ((supers (sod-class-direct-superclasses class))
208 (remove-if #'sod-class-direct-superclasses
209 (mappend (lambda (super)
210 (mapcar (lambda (chain)
211 (sod-class-chain-head
213 (sod-class-chains super)))
217 (error "Class ~A has no root class!" class))
219 (cerror* "Class ~A has multiple root classes ~
220 ~{~#[~;~A~;~A and ~A~:; ~@{~A, ~#[~;and ~A~]~}~]~}"
222 (let ((state (make-inheritance-path-reporter-state class)))
224 (report-inheritance-path state root))))
227 (export 'find-root-metaclass)
228 (defun find-root-metaclass (class)
229 "Returns the `root' metaclass of CLASS.
231 The root metaclass is the metaclass of the root superclass -- see
232 `find-root-superclass'."
233 (sod-class-metaclass (find-root-superclass class)))
235 ;;;--------------------------------------------------------------------------
238 (export 'argument-lists-compatible-p)
239 (defun argument-lists-compatible-p (message-args method-args)
240 "Compare argument lists for compatibility.
242 Return true if METHOD-ARGS is a suitable method argument list
243 corresponding to the message argument list MESSAGE-ARGS. This is the case
244 if the lists are the same length, each message argument has a
245 corresponding method argument with the same type, and if the message
246 arguments end in an ellpisis, the method arguments must end with a
247 `va_list' argument. (We can't pass actual variable argument lists around,
248 except as `va_list' objects, which are devilish inconvenient things and
249 require much hacking. See the method combination machinery for details.)"
251 (and (= (length message-args) (length method-args))
252 (every (lambda (message-arg method-arg)
253 (if (eq message-arg :ellipsis)
254 (c-type-equal-p (argument-type method-arg)
256 (c-type-equal-p (argument-type message-arg)
257 (argument-type method-arg))))
258 message-args method-args)))
260 ;;;--------------------------------------------------------------------------
263 (export 'islots-struct-tag)
264 (defun islots-struct-tag (class)
265 (format nil "~A__islots" class))
267 (export 'ichain-struct-tag)
268 (defun ichain-struct-tag (class chain-head)
269 (format nil "~A__ichain_~A" class (sod-class-nickname chain-head)))
271 (export 'ichain-union-tag)
272 (defun ichain-union-tag (class chain-head)
273 (format nil "~A__ichainu_~A" class (sod-class-nickname chain-head)))
275 (export 'ilayout-struct-tag)
276 (defun ilayout-struct-tag (class)
277 (format nil "~A__ilayout" class))
279 (export 'vtmsgs-struct-tag)
280 (defun vtmsgs-struct-tag (class super)
281 (format nil "~A__vtmsgs_~A" class (sod-class-nickname super)))
283 (export 'vtable-union-tag)
284 (defun vtable-union-tag (class chain-head)
285 (format nil "~A__vtu_~A" class (sod-class-nickname chain-head)))
287 (export 'vtable-struct-tag)
288 (defun vtable-struct-tag (class chain-head)
289 (format nil "~A__vt_~A" class (sod-class-nickname chain-head)))
291 (export 'vtable-name)
292 (defun vtable-name (class chain-head)
293 (format nil "~A__vtable_~A" class (sod-class-nickname chain-head)))
295 (export 'message-macro-name)
296 (defun message-macro-name (class entry)
297 (format nil "~A_~A" class (method-entry-slot-name entry)))
299 ;;;----- That's all, folks --------------------------------------------------