Commit | Line | Data |
---|---|---|
dea4d055 MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; A collection of utility functions for SOD classes | |
4 | ;;; | |
5 | ;;; (c) 2009 Straylight/Edgeware | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
e0808c47 | 10 | ;;; This file is part of the Sensible Object Design, an object system for C. |
dea4d055 MW |
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 | ;;; Finding things by name | |
30 | ||
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." | |
34 | ||
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)) | |
38 | class | |
39 | (or (some (lambda (super) | |
40 | (find nick (sod-class-precedence-list super) | |
41 | :key #'sod-class-nickname | |
42 | :test #'string=)) | |
43 | (sod-class-direct-superclasses class)) | |
44 | (error "No superclass of `~A' with nickname `~A'" class nick)))) | |
45 | ||
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)))) | |
51 | ||
52 | (defun find-instance-slot-by-name (class super-nick slot-name) | |
53 | (let ((super (find-superclass-by-nick class super-nick))) | |
bf090e02 | 54 | (find-thing-by-name "instance slot" super (sod-class-slots super) |
dea4d055 MW |
55 | slot-name #'sod-slot-name))) |
56 | ||
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))) | |
bf090e02 | 60 | (find-thing-by-name "class slot" super (sod-class-slots super) |
dea4d055 MW |
61 | slot-name #'sod-slot-name))) |
62 | ||
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)))) | |
67 | ||
17c7c784 MW |
68 | ;;;-------------------------------------------------------------------------- |
69 | ;;; Describing class inheritance paths in diagnostics. | |
70 | ||
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)))) | |
76 | ||
77 | (export 'make-inheritance-path-reporter-state) | |
78 | (defun make-inheritance-path-reporter-state (class) | |
79 | (make-instance 'inheritance-path-reporter-state :class class)) | |
80 | ||
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 | |
87 | class | |
88 | (lambda (c) | |
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) | |
94 | (cadr subpath)))) | |
95 | (if (or (not sub) (gethash super seen)) | |
96 | nil | |
97 | (progn | |
98 | (setf (gethash super seen) t) | |
99 | (list (cons super sub)))))) | |
100 | (cdr (find super paths :key #'cadr)))) | |
101 | (let ((super (car hop)) | |
102 | (sub (cdr hop))) | |
103 | (info-with-location sub | |
104 | "Class `~A' is a direct superclass ~ | |
105 | of `~A', defined here" | |
106 | super sub))))) | |
107 | ||
6e92afa7 MW |
108 | ;;;-------------------------------------------------------------------------- |
109 | ;;; Metaclass inference. | |
110 | ||
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))) | |
115 | allow-empty) | |
116 | "Return the minimal partially-ordered key from the SUPERS. | |
117 | ||
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. | |
126 | ||
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. | |
130 | ||
131 | The function returns two values: the chosen value, and a flag which is | |
132 | non-nil if it was chosen without errors." | |
133 | ||
134 | (let ((candidates (partial-order-minima (mapcar key supers) order))) | |
135 | (cond ((and (null candidates) allow-empty) | |
136 | (values default t)) | |
137 | ((and candidates (null (cdr candidates))) | |
138 | (values (car candidates) t)) | |
139 | (t | |
140 | (cerror* "No obvious choice for implicit ~A: ~ | |
141 | ~{~#[root classes must specify explicitly~:;~ | |
142 | candidates are ~ | |
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 ~ | |
149 | has ~A ~A" | |
150 | super what (funcall present candidate)))) | |
151 | (values (if candidates (car candidates) default) nil))))) | |
152 | ||
dea4d055 MW |
153 | ;;;-------------------------------------------------------------------------- |
154 | ;;; Miscellaneous useful functions. | |
155 | ||
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. | |
159 | ||
160 | Careful! Assumes that the class precedence list of CLASS-A has been | |
161 | computed!" | |
162 | (member class-b (sod-class-precedence-list class-a))) | |
163 | ||
164 | (export 'valid-name-p) | |
165 | (defun valid-name-p (name) | |
166 | "Checks whether NAME is a valid name. | |
167 | ||
168 | The rules are: | |
169 | ||
170 | * the name must be a string | |
171 | * which is nonempty | |
172 | * whose first character is alphabetic | |
173 | * all of whose characters are alphanumeric or underscores | |
174 | * and which doesn't contain two consecutive underscores." | |
175 | ||
a547121f MW |
176 | (or (typep name 'temporary-variable) |
177 | (and (stringp name) | |
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))))) | |
dea4d055 MW |
182 | |
183 | (export 'find-root-superclass) | |
184 | (defun find-root-superclass (class) | |
185 | "Returns the `root' superclass of CLASS. | |
186 | ||
187 | The root superclass is the superclass which itself has no direct | |
188 | superclasses. In universes not based on the provided builtin module, the | |
3109662a | 189 | root class may not be our beloved `SodObject'; however, there must be one |
dea4d055 MW |
190 | (otherwise the class graph is cyclic, which should be forbidden), and we |
191 | insist that it be unique." | |
192 | ||
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. | |
196 | ;; | |
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 | |
bf090e02 | 199 | ;; superclasses' chains rather than the class's own. This misses a chain |
dea4d055 MW |
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 | |
203 | ;; is harmless. | |
204 | ||
205 | (let* ((supers (sod-class-direct-superclasses class)) | |
206 | (roots (if supers | |
207 | (remove-duplicates | |
208 | (remove-if #'sod-class-direct-superclasses | |
209 | (mappend (lambda (super) | |
210 | (mapcar (lambda (chain) | |
211 | (sod-class-chain-head | |
212 | (car chain))) | |
213 | (sod-class-chains super))) | |
214 | supers))) | |
215 | (list class)))) | |
df4fa4b9 MW |
216 | (cond ((null roots) |
217 | (error "Class ~A has no root class!" class)) | |
218 | ((cdr roots) | |
219 | (cerror* "Class ~A has multiple root classes ~ | |
220 | ~{~#[~;~A~;~A and ~A~:; ~@{~A, ~#[~;and ~A~]~}~]~}" | |
221 | class roots) | |
222 | (let ((state (make-inheritance-path-reporter-state class))) | |
223 | (dolist (root roots) | |
224 | (report-inheritance-path state root)))) | |
dea4d055 MW |
225 | (t (car roots))))) |
226 | ||
227 | (export 'find-root-metaclass) | |
228 | (defun find-root-metaclass (class) | |
229 | "Returns the `root' metaclass of CLASS. | |
230 | ||
231 | The root metaclass is the metaclass of the root superclass -- see | |
232 | `find-root-superclass'." | |
233 | (sod-class-metaclass (find-root-superclass class))) | |
234 | ||
235 | ;;;-------------------------------------------------------------------------- | |
236 | ;;; Type hacking. | |
237 | ||
238 | (export 'argument-lists-compatible-p) | |
239 | (defun argument-lists-compatible-p (message-args method-args) | |
240 | "Compare argument lists for compatibility. | |
241 | ||
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.)" | |
250 | ||
251 | (and (= (length message-args) (length method-args)) | |
252 | (every (lambda (message-arg method-arg) | |
253 | (if (eq message-arg :ellipsis) | |
8dba302b | 254 | (c-type-equal-p (argument-type method-arg) |
e85df3ff | 255 | c-type-va-list) |
dea4d055 MW |
256 | (c-type-equal-p (argument-type message-arg) |
257 | (argument-type method-arg)))) | |
258 | message-args method-args))) | |
259 | ||
260 | ;;;-------------------------------------------------------------------------- | |
261 | ;;; Names of things. | |
262 | ||
263 | (export 'islots-struct-tag) | |
264 | (defun islots-struct-tag (class) | |
265 | (format nil "~A__islots" class)) | |
266 | ||
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))) | |
270 | ||
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))) | |
274 | ||
275 | (export 'ilayout-struct-tag) | |
276 | (defun ilayout-struct-tag (class) | |
277 | (format nil "~A__ilayout" class)) | |
278 | ||
279 | (export 'vtmsgs-struct-tag) | |
280 | (defun vtmsgs-struct-tag (class super) | |
281 | (format nil "~A__vtmsgs_~A" class (sod-class-nickname super))) | |
282 | ||
c2438e62 MW |
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))) | |
286 | ||
dea4d055 MW |
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))) | |
290 | ||
291 | (export 'vtable-name) | |
292 | (defun vtable-name (class chain-head) | |
293 | (format nil "~A__vtable_~A" class (sod-class-nickname chain-head))) | |
294 | ||
6bc944c3 | 295 | (export 'message-macro-name) |
b426ab51 MW |
296 | (defun message-macro-name (class entry) |
297 | (format nil "~A_~A" class (method-entry-slot-name entry))) | |
6bc944c3 | 298 | |
dea4d055 | 299 | ;;;----- That's all, folks -------------------------------------------------- |