1 | ;;;-*-Mode: LISP; Package: CCL -*- |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2009 Clozure Associates |
---|
4 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
---|
5 | ;;; This file is part of Clozure CL. |
---|
6 | ;;; |
---|
7 | ;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public |
---|
8 | ;;; License , known as the LLGPL and distributed with Clozure CL as the |
---|
9 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
10 | ;;; which is distributed with Clozure CL as the file "LGPL". Where these |
---|
11 | ;;; conflict, the preamble takes precedence. |
---|
12 | ;;; |
---|
13 | ;;; Clozure CL is referenced in the preamble as the "LIBRARY." |
---|
14 | ;;; |
---|
15 | ;;; The LLGPL is also available online at |
---|
16 | ;;; http://opensource.franz.com/preamble.html |
---|
17 | |
---|
18 | |
---|
19 | |
---|
20 | |
---|
21 | ;;; l1-clos-boot.lisp |
---|
22 | |
---|
23 | |
---|
24 | (in-package "CCL") |
---|
25 | |
---|
26 | ;;; Early accessors. These functions eventually all get replaced with |
---|
27 | ;;; generic functions with "real", official names. |
---|
28 | |
---|
29 | |
---|
30 | (declaim (inline instance-slots %non-standard-instance-slots)) |
---|
31 | (defun %non-standard-instance-slots (instance typecode) |
---|
32 | (cond ((eql typecode target::subtag-macptr) (foreign-slots-vector instance)) |
---|
33 | ((or (typep instance 'standard-generic-function) |
---|
34 | (typep instance 'funcallable-standard-object)) |
---|
35 | (gf.slots instance)) |
---|
36 | (t (error "Don't know how to find slots of ~s" instance)))) |
---|
37 | |
---|
38 | (defun instance-slots (instance) |
---|
39 | (let* ((typecode (typecode instance))) |
---|
40 | (cond ((eql typecode target::subtag-instance) (instance.slots instance)) |
---|
41 | (t (%non-standard-instance-slots instance typecode))))) |
---|
42 | |
---|
43 | |
---|
44 | ;;; True if X is a class but not a foreign-class. |
---|
45 | (defun native-class-p (x) |
---|
46 | (if (%standard-instance-p x) |
---|
47 | (< (the fixnum (instance.hash x)) max-class-ordinal))) |
---|
48 | |
---|
49 | (defun %class-name (class) |
---|
50 | (if (native-class-p class) |
---|
51 | (%class.name class) |
---|
52 | (class-name class))) |
---|
53 | |
---|
54 | (defun %class-info (class) |
---|
55 | (if (native-class-p class) |
---|
56 | (%class.info class) |
---|
57 | (class-info class))) |
---|
58 | |
---|
59 | |
---|
60 | (defun %class-kernel-p (class) |
---|
61 | (car (%class-info class))) |
---|
62 | |
---|
63 | (defun (setf %class-kernel-p) (new class) |
---|
64 | (setf (car (%class-info class)) new)) |
---|
65 | |
---|
66 | (defun %class-proper-name (class) |
---|
67 | (cdr (%class-info class))) |
---|
68 | |
---|
69 | (defun (setf %class-proper-name) (new class) |
---|
70 | (setf (cdr (%class-info class)) new)) |
---|
71 | |
---|
72 | |
---|
73 | (defun %class-own-wrapper (class) |
---|
74 | (if (native-class-p class) |
---|
75 | (%class.own-wrapper class) |
---|
76 | (class-own-wrapper class))) |
---|
77 | |
---|
78 | (defun (setf %class-own-wrapper) (new class) |
---|
79 | (setf (%class.own-wrapper class) new)) |
---|
80 | |
---|
81 | (defun %class-alist (class) |
---|
82 | (%class.alist class)) |
---|
83 | |
---|
84 | (defun (setf %class-alist) (new class) |
---|
85 | (if (typep class 'slots-class) |
---|
86 | (setf (%class.alist class) new) |
---|
87 | new)) |
---|
88 | |
---|
89 | (defun %class-slots (class) |
---|
90 | (if (native-class-p class) |
---|
91 | (%class.slots class) |
---|
92 | (class-slots class))) |
---|
93 | |
---|
94 | (defun (setf %class-slots) (new class) |
---|
95 | (if (native-class-p class) |
---|
96 | (setf (%class.slots class) new) |
---|
97 | (setf (class-slots class) new))) |
---|
98 | |
---|
99 | (defun %class-direct-slots (class) |
---|
100 | (if (native-class-p class) |
---|
101 | (%class.direct-slots class) |
---|
102 | (class-direct-slots class))) |
---|
103 | |
---|
104 | (defun (setf %class-direct-slots) (new class) |
---|
105 | (if (native-class-p class) |
---|
106 | (setf (%class.direct-slots class) new) |
---|
107 | (setf (class-direct-slots class) new))) |
---|
108 | |
---|
109 | |
---|
110 | |
---|
111 | |
---|
112 | |
---|
113 | |
---|
114 | (defun %class-direct-superclasses (class) |
---|
115 | (%class.local-supers class)) |
---|
116 | |
---|
117 | (defun (setf %class-direct-superclasses) (new class) |
---|
118 | (setf (%class.local-supers class) new)) |
---|
119 | |
---|
120 | (defun %class-direct-subclasses (class) |
---|
121 | (%class.subclasses class)) |
---|
122 | |
---|
123 | (defun (setf %class-direct-subclasses) (new class) |
---|
124 | (setf (%class.subclasses class) new)) |
---|
125 | |
---|
126 | (defun %class-direct-default-initargs (class) |
---|
127 | (if (typep class 'std-class) |
---|
128 | (%class.local-default-initargs class))) |
---|
129 | |
---|
130 | (defun (setf %class-direct-default-initargs) (new class) |
---|
131 | (if (typep class 'std-class) |
---|
132 | (setf (%class.local-default-initargs class) new) |
---|
133 | new)) |
---|
134 | |
---|
135 | |
---|
136 | (defun %class-default-initargs (class) |
---|
137 | (if (typep class 'std-class) |
---|
138 | (%class.default-initargs class))) |
---|
139 | |
---|
140 | |
---|
141 | (defun (setf %class-default-initargs) (new class) |
---|
142 | (setf (%class.default-initargs class) new)) |
---|
143 | |
---|
144 | (defun %slot-definition-name (slotd) |
---|
145 | (standard-slot-definition.name slotd)) |
---|
146 | |
---|
147 | |
---|
148 | (defun %slot-definition-type (slotd) |
---|
149 | (standard-slot-definition.type slotd)) |
---|
150 | |
---|
151 | (defun %slot-definition-initargs (slotd) |
---|
152 | (standard-slot-definition.initargs slotd)) |
---|
153 | |
---|
154 | |
---|
155 | (defun %slot-definition-initform (slotd) |
---|
156 | (standard-slot-definition.initform slotd)) |
---|
157 | |
---|
158 | (defun %slot-definition-initfunction (slotd) |
---|
159 | (standard-slot-definition.initfunction slotd)) |
---|
160 | |
---|
161 | (defun %slot-definition-allocation (slotd) |
---|
162 | (standard-slot-definition.allocation slotd)) |
---|
163 | |
---|
164 | (defun %slot-definition-class (slotd) |
---|
165 | (standard-slot-definition.class slotd)) |
---|
166 | |
---|
167 | ;;; Returns (VALUES BOUNDP VALUE). |
---|
168 | (defun %slot-definition-documentation (slotd) |
---|
169 | (let* ((val (%standard-instance-instance-location-access |
---|
170 | slotd |
---|
171 | standard-slot-definition.documentation))) |
---|
172 | (if (eq val (%slot-unbound-marker)) |
---|
173 | (values nil nil) |
---|
174 | (values t val)))) |
---|
175 | |
---|
176 | |
---|
177 | (defun %slot-definition-location (slotd) |
---|
178 | (standard-effective-slot-definition.location slotd)) |
---|
179 | |
---|
180 | (defun (setf %slot-definition-location) (new slotd) |
---|
181 | (setf (standard-effective-slot-definition.location slotd) new)) |
---|
182 | |
---|
183 | (defun %slot-definition-readers (slotd) |
---|
184 | (standard-direct-slot-definition.readers slotd)) |
---|
185 | |
---|
186 | (defun (setf %slot-definition-readers) (new slotd) |
---|
187 | (setf (standard-direct-slot-definition.readers slotd) new)) |
---|
188 | |
---|
189 | (defun %slot-definition-writers (slotd) |
---|
190 | (standard-direct-slot-definition.writers slotd)) |
---|
191 | |
---|
192 | (defun (setf %slot-definition-writers) (new slotd) |
---|
193 | (setf (standard-direct-slot-definition.writers slotd) new)) |
---|
194 | |
---|
195 | (defun %generic-function-name (gf) |
---|
196 | (sgf.name gf)) |
---|
197 | |
---|
198 | (defun %generic-function-method-combination (gf) |
---|
199 | (sgf.method-combination gf)) |
---|
200 | |
---|
201 | (defun %generic-function-method-class (gf) |
---|
202 | (sgf.method-class gf)) |
---|
203 | |
---|
204 | |
---|
205 | (defun %method-qualifiers (m) |
---|
206 | (%method.qualifiers m)) |
---|
207 | |
---|
208 | (defun %method-specializers (m) |
---|
209 | (%method.specializers m)) |
---|
210 | |
---|
211 | (defun %method-function (m) |
---|
212 | (%method.function m)) |
---|
213 | |
---|
214 | (defun (setf %method-function) (new m) |
---|
215 | (setf (%method.function m) new)) |
---|
216 | |
---|
217 | (defun %method-gf (m) |
---|
218 | (%method.gf m)) |
---|
219 | |
---|
220 | (defun (setf %method-gf) (new m) |
---|
221 | (setf (%method.gf m) new)) |
---|
222 | |
---|
223 | (defun %method-name (m) |
---|
224 | (%method.name m)) |
---|
225 | |
---|
226 | (defun %method-lambda-list (m) |
---|
227 | (%method.lambda-list m)) |
---|
228 | |
---|
229 | |
---|
230 | ;;; Map slot-names (symbols) to SLOT-ID objects (which contain unique indices). |
---|
231 | (let* ((slot-id-lock (make-lock)) |
---|
232 | (next-slot-index 1) ; 0 is never a valid slot-index |
---|
233 | (slot-id-hash (make-hash-table :test #'eq :weak t))) |
---|
234 | (defun ensure-slot-id (slot-name) |
---|
235 | (setq slot-name (require-type slot-name 'symbol)) |
---|
236 | (with-lock-grabbed (slot-id-lock) |
---|
237 | (or (gethash slot-name slot-id-hash) |
---|
238 | (setf (gethash slot-name slot-id-hash) |
---|
239 | (%istruct 'slot-id slot-name (prog1 |
---|
240 | next-slot-index |
---|
241 | (incf next-slot-index))))))) |
---|
242 | (defun current-slot-index () (with-lock-grabbed (slot-id-lock) |
---|
243 | next-slot-index)) |
---|
244 | ) |
---|
245 | |
---|
246 | |
---|
247 | |
---|
248 | |
---|
249 | (defun %slot-id-lookup-obsolete (instance slot-id) |
---|
250 | (update-obsolete-instance instance) |
---|
251 | (funcall (%wrapper-slot-id->slotd (instance.class-wrapper instance)) |
---|
252 | instance slot-id)) |
---|
253 | (defun slot-id-lookup-no-slots (instance slot-id) |
---|
254 | (declare (ignore instance slot-id))) |
---|
255 | |
---|
256 | (defun %slot-id-ref-obsolete (instance slot-id) |
---|
257 | (update-obsolete-instance instance) |
---|
258 | (funcall (%wrapper-slot-id-value (instance.class-wrapper instance)) |
---|
259 | instance slot-id)) |
---|
260 | (defun %slot-id-ref-missing (instance slot-id) |
---|
261 | (values (slot-missing (class-of instance) instance (slot-id.name slot-id) 'slot-value))) |
---|
262 | |
---|
263 | (defun %slot-id-set-obsolete (instance slot-id new-value) |
---|
264 | (update-obsolete-instance instance) |
---|
265 | (funcall (%wrapper-set-slot-id-value (instance.class-wrapper instance)) |
---|
266 | instance slot-id new-value)) |
---|
267 | |
---|
268 | (defun %slot-id-set-missing (instance slot-id new-value) |
---|
269 | (slot-missing (class-of instance) instance (slot-id.name slot-id) 'setf new-value) |
---|
270 | new-value |
---|
271 | ) |
---|
272 | |
---|
273 | |
---|
274 | |
---|
275 | ;;; This becomes (apply #'make-instance <method-class> &rest args). |
---|
276 | (fset '%make-method-instance |
---|
277 | (nlambda bootstrapping-%make-method-instance (class &key |
---|
278 | qualifiers |
---|
279 | specializers |
---|
280 | function |
---|
281 | name |
---|
282 | lambda-list |
---|
283 | &allow-other-keys) |
---|
284 | (let* ((method |
---|
285 | (%instance-vector (%class-own-wrapper class) |
---|
286 | qualifiers |
---|
287 | specializers |
---|
288 | function |
---|
289 | nil |
---|
290 | name |
---|
291 | lambda-list))) |
---|
292 | (when function |
---|
293 | (let* ((inner (closure-function function))) |
---|
294 | (unless (eq inner function) |
---|
295 | (copy-method-function-bits inner function))) |
---|
296 | (lfun-name function method)) |
---|
297 | method))) |
---|
298 | |
---|
299 | |
---|
300 | |
---|
301 | (defun encode-lambda-list (l &optional return-keys?) |
---|
302 | (multiple-value-bind (ok req opttail resttail keytail auxtail) |
---|
303 | (verify-lambda-list l) |
---|
304 | (when ok |
---|
305 | (let* ((bits 0) |
---|
306 | (temp nil) |
---|
307 | (nreq (length req)) |
---|
308 | (num-opt 0) |
---|
309 | (rest nil) |
---|
310 | (lexpr nil) |
---|
311 | (keyp nil) |
---|
312 | (key-list nil) |
---|
313 | (aokp nil) |
---|
314 | (hardopt nil)) |
---|
315 | (when (> nreq #.(ldb $lfbits-numreq $lfbits-numreq)) |
---|
316 | (return-from encode-lambda-list nil)) |
---|
317 | (when (eq (pop opttail) '&optional) |
---|
318 | (until (eq opttail resttail) |
---|
319 | (when (and (consp (setq temp (pop opttail))) |
---|
320 | (%cadr temp)) |
---|
321 | (setq hardopt t)) |
---|
322 | (setq num-opt (%i+ num-opt 1)))) |
---|
323 | (when (eq (%car resttail) '&rest) |
---|
324 | (setq rest t)) |
---|
325 | (when (eq (%car resttail) '&lexpr) |
---|
326 | (setq lexpr t)) |
---|
327 | (when (eq (pop keytail) '&key) |
---|
328 | (setq keyp t) |
---|
329 | (labels ((ensure-symbol (x) |
---|
330 | (if (symbolp x) x (return-from encode-lambda-list nil))) |
---|
331 | (ensure-keyword (x) |
---|
332 | (make-keyword (ensure-symbol x)))) |
---|
333 | (declare (dynamic-extent #'ensure-symbol #'ensure-keyword)) |
---|
334 | (until (eq keytail auxtail) |
---|
335 | (setq temp (pop keytail)) |
---|
336 | (if (eq temp '&allow-other-keys) |
---|
337 | (progn |
---|
338 | (setq aokp t) |
---|
339 | (unless (eq keytail auxtail) |
---|
340 | (return-from encode-lambda-list nil))) |
---|
341 | (when return-keys? |
---|
342 | (push (if (consp temp) |
---|
343 | (if (consp (setq temp (%car temp))) |
---|
344 | (ensure-symbol (%car temp)) |
---|
345 | (ensure-keyword temp)) |
---|
346 | (ensure-keyword temp)) |
---|
347 | key-list)))))) |
---|
348 | (when (%i> nreq (ldb $lfbits-numreq -1)) |
---|
349 | (setq nreq (ldb $lfbits-numreq -1))) |
---|
350 | (setq bits (dpb nreq $lfbits-numreq bits)) |
---|
351 | (when (%i> num-opt (ldb $lfbits-numopt -1)) |
---|
352 | (setq num-opt (ldb $lfbits-numopt -1))) |
---|
353 | (setq bits (dpb num-opt $lfbits-numopt bits)) |
---|
354 | (when hardopt (setq bits (%ilogior (%ilsl $lfbits-optinit-bit 1) bits))) |
---|
355 | (when rest (setq bits (%ilogior (%ilsl $lfbits-rest-bit 1) bits))) |
---|
356 | (when lexpr (setq bits (%ilogior (%ilsl $lfbits-restv-bit 1) bits))) |
---|
357 | (when keyp (setq bits (%ilogior (%ilsl $lfbits-keys-bit 1) bits))) |
---|
358 | (when aokp (setq bits (%ilogior (%ilsl $lfbits-aok-bit 1) bits))) |
---|
359 | (if return-keys? |
---|
360 | (values bits (and keyp (apply #'vector (nreverse key-list)))) |
---|
361 | bits))))) |
---|
362 | |
---|
363 | (defun pair-arg-p (thing &optional lambda-list-ok supplied-p-ok keyword-nesting-ok) |
---|
364 | (or (symbol-arg-p thing lambda-list-ok) ; nil ok in destructuring case |
---|
365 | (and (consp thing) |
---|
366 | (or (null (%cdr thing)) |
---|
367 | (and (consp (%cdr thing)) |
---|
368 | (or (null (%cddr thing)) |
---|
369 | (and supplied-p-ok |
---|
370 | (consp (%cddr thing)) |
---|
371 | (null (%cdddr thing)))))) |
---|
372 | (if (not keyword-nesting-ok) |
---|
373 | (req-arg-p (%car thing) lambda-list-ok) |
---|
374 | (or (symbol-arg-p (%car thing) lambda-list-ok) |
---|
375 | (and (consp (setq thing (%car thing))) |
---|
376 | (consp (%cdr thing)) |
---|
377 | (null (%cddr thing)) |
---|
378 | (%car thing) |
---|
379 | (symbolp (%car thing)) |
---|
380 | (req-arg-p (%cadr thing) lambda-list-ok))))))) |
---|
381 | |
---|
382 | (defun req-arg-p (thing &optional lambda-list-ok) |
---|
383 | (or |
---|
384 | (symbol-arg-p thing lambda-list-ok) |
---|
385 | (lambda-list-arg-p thing lambda-list-ok))) |
---|
386 | |
---|
387 | (defun symbol-arg-p (thing nil-ok) |
---|
388 | (and |
---|
389 | (symbolp thing) |
---|
390 | (or thing nil-ok) |
---|
391 | (not (memq thing lambda-list-keywords)))) |
---|
392 | |
---|
393 | (defun lambda-list-arg-p (thing lambda-list-ok) |
---|
394 | (and |
---|
395 | lambda-list-ok |
---|
396 | (listp thing) |
---|
397 | (if (verify-lambda-list thing t t) |
---|
398 | (setq *structured-lambda-list* t)))) |
---|
399 | |
---|
400 | (defun opt-arg-p (thing &optional lambda-ok) |
---|
401 | (pair-arg-p thing lambda-ok t nil)) |
---|
402 | |
---|
403 | (defun key-arg-p (thing &optional lambda-ok) |
---|
404 | (pair-arg-p thing lambda-ok t t)) |
---|
405 | |
---|
406 | (defun proclaimed-ignore-p (sym) |
---|
407 | (cdr (assq sym *nx-proclaimed-ignore*))) |
---|
408 | |
---|
409 | (defun verify-lambda-list (l &optional destructure-p whole-p env-p) |
---|
410 | (let* ((the-keys lambda-list-keywords) |
---|
411 | opttail |
---|
412 | resttail |
---|
413 | keytail |
---|
414 | allowothertail |
---|
415 | auxtail |
---|
416 | safecopy |
---|
417 | whole |
---|
418 | m |
---|
419 | n |
---|
420 | req |
---|
421 | sym |
---|
422 | (*structured-lambda-list* nil)) |
---|
423 | (prog () |
---|
424 | (multiple-value-setq (safecopy whole) |
---|
425 | (normalize-lambda-list l whole-p env-p)) |
---|
426 | (unless (or destructure-p (eq l safecopy) (go LOSE))) |
---|
427 | (setq l safecopy) |
---|
428 | (unless (dolist (key the-keys t) |
---|
429 | (when (setq m (cdr (memq key l))) |
---|
430 | (if (memq key m) (return)))) |
---|
431 | (go LOSE)) |
---|
432 | (if (null l) (go WIN)) |
---|
433 | (setq opttail (memq '&optional l)) |
---|
434 | (setq m (or (memq '&rest l) |
---|
435 | (unless destructure-p (memq '&lexpr l)))) |
---|
436 | (setq n (if destructure-p (memq '&body l))) |
---|
437 | (if (and m n) (go LOSE) (setq resttail (or m n))) |
---|
438 | (setq keytail (memq '&key l)) |
---|
439 | (if (and (setq allowothertail (memq '&allow-other-keys l)) |
---|
440 | (not keytail)) |
---|
441 | (go LOSE)) |
---|
442 | (if (and (eq (car resttail) '&lexpr) |
---|
443 | (or keytail opttail)) |
---|
444 | (go lose)) |
---|
445 | (setq auxtail (memq '&aux l)) |
---|
446 | (loop |
---|
447 | (when (null l) (go WIN)) |
---|
448 | (when (or (eq l opttail) |
---|
449 | (eq l resttail) |
---|
450 | (eq l keytail) |
---|
451 | (eq l allowothertail) |
---|
452 | (eq l auxtail)) |
---|
453 | (return)) |
---|
454 | (setq sym (pop l)) |
---|
455 | (unless (and (req-arg-p sym destructure-p) |
---|
456 | (or (proclaimed-ignore-p sym) |
---|
457 | (and destructure-p (null sym)) |
---|
458 | (not (memq sym req)))) ; duplicate required args |
---|
459 | (go LOSE)) |
---|
460 | (push sym req)) |
---|
461 | (when (eq l opttail) |
---|
462 | (setq l (%cdr l)) |
---|
463 | (loop |
---|
464 | (when (null l) (go WIN)) |
---|
465 | (when (or (eq l resttail) |
---|
466 | (eq l keytail) |
---|
467 | (eq l allowothertail) |
---|
468 | (eq l auxtail)) |
---|
469 | (return)) |
---|
470 | (unless (opt-arg-p (pop l) destructure-p) |
---|
471 | (go LOSE)))) |
---|
472 | (when (eq l resttail) |
---|
473 | (setq l (%cdr l)) |
---|
474 | (when (or (null l) |
---|
475 | (eq l opttail) |
---|
476 | (eq l keytail) |
---|
477 | (eq l allowothertail) |
---|
478 | (eq l auxtail)) |
---|
479 | (go LOSE)) |
---|
480 | (unless (req-arg-p (pop l) destructure-p) (go LOSE))) |
---|
481 | (unless (or (eq l keytail) ; allowothertail is a sublist of keytail if present |
---|
482 | (eq l auxtail)) |
---|
483 | (go LOSE)) |
---|
484 | (when (eq l keytail) |
---|
485 | (pop l) |
---|
486 | (loop |
---|
487 | (when (null l) (go WIN)) |
---|
488 | (when (or (eq l opttail) |
---|
489 | (eq l resttail)) |
---|
490 | (go LOSE)) |
---|
491 | (when (or (eq l auxtail) (setq n (eq l allowothertail))) |
---|
492 | (if n (setq l (%cdr l))) |
---|
493 | (return)) |
---|
494 | (unless (key-arg-p (pop l) destructure-p) (go LOSE)))) |
---|
495 | (when (eq l auxtail) |
---|
496 | (setq l (%cdr l)) |
---|
497 | (loop |
---|
498 | (when (null l) (go WIN)) |
---|
499 | (when (or (eq l opttail) |
---|
500 | (eq l resttail) |
---|
501 | (eq l keytail)) |
---|
502 | (go LOSE)) |
---|
503 | (unless (pair-arg-p (pop l)) (go LOSE)))) |
---|
504 | (when l (go LOSE)) |
---|
505 | WIN |
---|
506 | (return (values |
---|
507 | t |
---|
508 | (nreverse req) |
---|
509 | (or opttail resttail keytail auxtail) |
---|
510 | (or resttail keytail auxtail) |
---|
511 | (or keytail auxtail) |
---|
512 | auxtail |
---|
513 | safecopy |
---|
514 | whole |
---|
515 | *structured-lambda-list*)) |
---|
516 | LOSE |
---|
517 | (return (values nil nil nil nil nil nil nil nil nil nil))))) |
---|
518 | |
---|
519 | (defun normalize-lambda-list (x &optional whole-p env-p) |
---|
520 | (let* ((y x) whole env envtail head) |
---|
521 | (setq |
---|
522 | x |
---|
523 | (loop |
---|
524 | (when (atom y) |
---|
525 | (if (or (null y) (eq x y)) (return x)) |
---|
526 | (setq x (copy-list x) y x) |
---|
527 | (return |
---|
528 | (loop |
---|
529 | (when (atom (%cdr y)) |
---|
530 | (%rplacd y (list '&rest (%cdr y))) |
---|
531 | (return x)) |
---|
532 | (setq y (%cdr y))))) |
---|
533 | (setq y (%cdr y)))) |
---|
534 | (when env-p |
---|
535 | ;; Trapped in a world it never made ... |
---|
536 | (when (setq y (memq '&environment x)) |
---|
537 | (setq envtail (%cddr y) |
---|
538 | env (%cadr y)) |
---|
539 | (cond ((eq y x) |
---|
540 | (setq x envtail)) |
---|
541 | (t |
---|
542 | (dolist (v x) |
---|
543 | (if (eq v '&environment) |
---|
544 | (return) |
---|
545 | (push v head))) |
---|
546 | (setq x (nconc (nreverse head) envtail) y (%car envtail)))))) |
---|
547 | (when (and whole-p |
---|
548 | (eq (%car x) '&whole) |
---|
549 | (%cadr x)) |
---|
550 | (setq whole (%cadr x) x (%cddr x))) |
---|
551 | (values x whole env))) |
---|
552 | |
---|
553 | |
---|
554 | |
---|
555 | |
---|
556 | (eval-when (eval compile) |
---|
557 | (require 'defstruct-macros)) |
---|
558 | |
---|
559 | (eval-when (:compile-toplevel :execute) |
---|
560 | (defmacro make-instance-vector (wrapper len) |
---|
561 | (let* ((instance (gensym)) |
---|
562 | (slots (gensym))) |
---|
563 | `(let* ((,slots (allocate-typed-vector :slot-vector (1+ ,len) (%slot-unbound-marker))) |
---|
564 | (,instance (gvector :instance 0 ,wrapper ,slots))) |
---|
565 | (setf (instance.hash ,instance) (strip-tag-to-fixnum ,instance) |
---|
566 | (slot-vector.instance ,slots) ,instance)))) |
---|
567 | ) |
---|
568 | |
---|
569 | (eval-when (:compile-toplevel :execute) |
---|
570 | (defmacro make-structure-vector (size) |
---|
571 | `(%alloc-misc ,size target::subtag-struct nil)) |
---|
572 | |
---|
573 | ) |
---|
574 | ;;;;;;;;;;;;;;;;;;;;;;;;;;; defmethod support ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
---|
575 | |
---|
576 | (%fhave '%move-method-encapsulations-maybe ; Redefined in encapsulate |
---|
577 | (qlfun boot-%move-method-encapsulations-maybe (m1 m2) |
---|
578 | (declare (ignore m1 m2)) |
---|
579 | nil)) |
---|
580 | |
---|
581 | (%fhave 'find-unencapsulated-definition ;Redefined in encapsulate |
---|
582 | (qlfun bootstrapping-find-unencapsulated-definition (fn) |
---|
583 | fn)) |
---|
584 | |
---|
585 | (%fhave 'function-encapsulated-p ;Redefined in encapsulate |
---|
586 | (qlfun bootstrapping-function-encapsulated-p (fn) |
---|
587 | (declare (ignore fn)) |
---|
588 | nil)) |
---|
589 | |
---|
590 | (defparameter *uniquify-dcode* #+unique-dcode t #-unique-dcode nil |
---|
591 | "If true, each gf will get its own unique copy of its dcode. Not recommended for |
---|
592 | real use (for one thing, it's known to break gf tracing), but may be helpful for |
---|
593 | profiling") |
---|
594 | |
---|
595 | (let* ((class-wrapper-random-state (make-random-state)) |
---|
596 | (class-wrapper-random-state-lock (make-lock))) |
---|
597 | |
---|
598 | (defun new-class-wrapper-hash-index () |
---|
599 | ;; mustn't be 0 |
---|
600 | (with-lock-grabbed (class-wrapper-random-state-lock) |
---|
601 | (the fixnum (1+ (the fixnum (random target::target-most-positive-fixnum class-wrapper-random-state))))))) |
---|
602 | |
---|
603 | |
---|
604 | (defun %inner-method-function (method) |
---|
605 | (closure-function |
---|
606 | (find-unencapsulated-definition |
---|
607 | (%method-function method)))) |
---|
608 | |
---|
609 | (defun copy-method-function-bits (from to) |
---|
610 | (let ((new-bits (logior (logand (logior (lsh 1 $lfbits-method-bit) |
---|
611 | (ash 1 $lfbits-nextmeth-bit) |
---|
612 | (ash 1 $lfbits-nextmeth-with-args-bit) |
---|
613 | $lfbits-args-mask) |
---|
614 | (lfun-bits from)) |
---|
615 | (logand (lognot (logior (lsh 1 $lfbits-method-bit) |
---|
616 | (ash 1 $lfbits-nextmeth-bit) |
---|
617 | (ash 1 $lfbits-nextmeth-with-args-bit) |
---|
618 | $lfbits-args-mask)) |
---|
619 | (lfun-bits to))))) |
---|
620 | (lfun-bits to new-bits) |
---|
621 | new-bits)) |
---|
622 | |
---|
623 | (defun %ensure-generic-function-using-class (gf function-name &rest keys |
---|
624 | &key |
---|
625 | &allow-other-keys) |
---|
626 | (if gf |
---|
627 | (apply #'%ensure-existing-generic-function-using-class gf function-name keys) |
---|
628 | (apply #'%ensure-new-generic-function-using-class function-name keys))) |
---|
629 | |
---|
630 | (defun ensure-generic-function (function-name &rest keys &key &allow-other-keys) |
---|
631 | (let* ((def (fboundp function-name))) |
---|
632 | (when (and def (not (typep def 'generic-function))) |
---|
633 | (cerror "Try to remove any global non-generic function or macro definition." |
---|
634 | (make-condition 'simple-program-error :format-control "The function ~s is defined as something other than a generic function." :format-arguments (list function-name))) |
---|
635 | (fmakunbound function-name) |
---|
636 | (setq def nil)) |
---|
637 | (apply #'%ensure-generic-function-using-class def function-name keys))) |
---|
638 | |
---|
639 | |
---|
640 | (defun %ensure-new-generic-function-using-class |
---|
641 | (function-name &rest keys &key |
---|
642 | (generic-function-class *standard-generic-function-class* gfc-p) |
---|
643 | &allow-other-keys) |
---|
644 | (declare (dynamic-extent keys)) |
---|
645 | (when gfc-p |
---|
646 | (if (symbolp generic-function-class) |
---|
647 | (setq generic-function-class (find-class generic-function-class))) |
---|
648 | (unless (subtypep generic-function-class *standard-generic-function-class*) |
---|
649 | (error "~s is not a subtype of ~s" generic-function-class *generic-function-class*)) |
---|
650 | (remf keys :generic-function-class)) |
---|
651 | (let* ((gf (apply #'%make-gf-instance generic-function-class keys))) |
---|
652 | (unless (eq (%gf-method-combination gf) *standard-method-combination*) |
---|
653 | (register-gf-method-combination gf (%gf-method-combination gf))) |
---|
654 | (setf (sgf.name gf) (getf keys :name function-name)) |
---|
655 | (setf (fdefinition function-name) gf))) |
---|
656 | |
---|
657 | (defun %ensure-existing-generic-function-using-class |
---|
658 | (gf function-name &key |
---|
659 | (generic-function-class *standard-generic-function-class* gfc-p) |
---|
660 | (method-combination *standard-method-combination* mcomb-p) |
---|
661 | (method-class *standard-method-class* mclass-p) |
---|
662 | (argument-precedence-order nil apo-p) |
---|
663 | declarations |
---|
664 | (lambda-list nil ll-p) |
---|
665 | name) |
---|
666 | (when gfc-p |
---|
667 | (if (symbolp generic-function-class) |
---|
668 | (setq generic-function-class (find-class generic-function-class))) |
---|
669 | (unless (subtypep generic-function-class *standard-generic-function-class*) |
---|
670 | (error "~s is not a subtype of ~s" generic-function-class *standard-generic-function-class*))) |
---|
671 | (when mcomb-p |
---|
672 | (unless (typep method-combination 'method-combination) |
---|
673 | (report-bad-arg method-combination 'method-combination))) |
---|
674 | (when mclass-p |
---|
675 | (if (symbolp method-class) |
---|
676 | (setq method-class (find-class method-class))) |
---|
677 | (unless (subtypep method-class *method-class*) |
---|
678 | (error "~s is not a subtype of ~s." method-class *method-class*))) |
---|
679 | (when declarations |
---|
680 | (unless (list-length declarations) |
---|
681 | (error "~s is not a proper list" declarations))) |
---|
682 | ;; Fix APO, lambda-list |
---|
683 | (if apo-p |
---|
684 | (if (not ll-p) |
---|
685 | (error "Cannot specify ~s without specifying ~s" :argument-precedence-order |
---|
686 | :lambda-list))) |
---|
687 | (let* ((old-mc (sgf.method-combination gf))) |
---|
688 | (unless (eq old-mc method-combination) |
---|
689 | (unless (eq old-mc *standard-method-combination*) |
---|
690 | (unregister-gf-method-combination gf method-combination)))) |
---|
691 | (setf (sgf.name gf) (or name function-name) |
---|
692 | (sgf.decls gf) declarations |
---|
693 | (sgf.method-class gf) method-class |
---|
694 | (sgf.method-combination gf) method-combination) |
---|
695 | (unless (eq method-combination *standard-method-combination*) |
---|
696 | (register-gf-method-combination gf method-combination)) |
---|
697 | (when ll-p |
---|
698 | (if apo-p |
---|
699 | (set-gf-arg-info gf :lambda-list lambda-list |
---|
700 | :argument-precedence-order argument-precedence-order) |
---|
701 | (set-gf-arg-info gf :lambda-list lambda-list))) |
---|
702 | (setf (fdefinition function-name) gf)) |
---|
703 | |
---|
704 | (defun canonicalize-specializers (specializers &optional (copy t)) |
---|
705 | (flet ((canonicalize-specializer (spec) |
---|
706 | (if (specializer-p spec) |
---|
707 | spec |
---|
708 | (if (symbolp spec) |
---|
709 | (find-class spec) |
---|
710 | (if (and (consp spec) |
---|
711 | (eq (car spec) 'eql) |
---|
712 | (consp (cdr spec)) |
---|
713 | (null (cddr spec))) |
---|
714 | (intern-eql-specializer (cadr spec)) |
---|
715 | (error "Unknown specializer form ~s" spec)))))) |
---|
716 | (if (and (not copy) |
---|
717 | (dolist (s specializers t) |
---|
718 | (unless (specializer-p s) (return nil)))) |
---|
719 | specializers |
---|
720 | (mapcar #'canonicalize-specializer specializers)))) |
---|
721 | |
---|
722 | (defparameter *sealed-clos-world* nil "When true, class and method definition -at least - are disallowed.") |
---|
723 | |
---|
724 | (defun ensure-method (name specializers &rest keys &key (documentation nil doc-p) qualifiers |
---|
725 | &allow-other-keys) |
---|
726 | (declare (dynamic-extent keys)) |
---|
727 | (if *sealed-clos-world* |
---|
728 | (error "Method (re)definition is not allowed in this environment.") |
---|
729 | (progn |
---|
730 | (setq specializers (canonicalize-specializers specializers)) |
---|
731 | (let* ((gf (ensure-generic-function name)) |
---|
732 | (method (apply #'%make-method-instance |
---|
733 | (%gf-method-class gf) |
---|
734 | :name name |
---|
735 | :specializers specializers |
---|
736 | keys)) |
---|
737 | (old-method (when (%gf-methods gf) |
---|
738 | (ignore-errors |
---|
739 | (find-method gf qualifiers specializers nil))))) |
---|
740 | |
---|
741 | (%add-method gf method) |
---|
742 | (when (and doc-p *save-doc-strings*) |
---|
743 | (set-documentation method t documentation)) |
---|
744 | (when old-method (%move-method-encapsulations-maybe old-method method)) |
---|
745 | method)))) |
---|
746 | |
---|
747 | |
---|
748 | (defun %anonymous-method (function specializers qualifiers lambda-list &optional documentation |
---|
749 | &aux name method-class) |
---|
750 | (let ((inner-function (closure-function function))) |
---|
751 | (unless (%method-function-p inner-function) |
---|
752 | (report-bad-arg inner-function 'method-function)) ; Well, I suppose we'll have to shoot you. |
---|
753 | (unless (eq inner-function function) ; must be closed over |
---|
754 | (copy-method-function-bits inner-function function)) |
---|
755 | (setq name (function-name inner-function)) |
---|
756 | (if (typep name 'standard-method) ; method-function already installed. |
---|
757 | (setq name (%method-name name))) |
---|
758 | (setq method-class *standard-method-class*) |
---|
759 | (unless (memq *standard-method-class* (or (%class.cpl method-class) |
---|
760 | (%class.cpl (update-class method-class t)))) |
---|
761 | (%badarg method-class 'standard-method)) |
---|
762 | #| |
---|
763 | (unless (member qualifiers '(() (:before) (:after) (:around)) :test #'equal) |
---|
764 | (report-bad-arg qualifiers)) |
---|
765 | ||# |
---|
766 | (setq specializers (mapcar #'(lambda (s) |
---|
767 | (or (and (consp s) |
---|
768 | (eq (%car s) 'eql) |
---|
769 | (consp (%cdr s)) |
---|
770 | (null (%cddr s)) |
---|
771 | (intern-eql-specializer (%cadr s))) |
---|
772 | (and (specializer-p s) s) |
---|
773 | (find-class s))) |
---|
774 | specializers)) |
---|
775 | (let ((method (%make-method-instance method-class |
---|
776 | :name name |
---|
777 | :lambda-list lambda-list |
---|
778 | :qualifiers qualifiers |
---|
779 | :specializers specializers |
---|
780 | :function function))) |
---|
781 | (lfun-name inner-function method) |
---|
782 | (when documentation |
---|
783 | (set-documentation method t documentation)) |
---|
784 | method))) |
---|
785 | |
---|
786 | |
---|
787 | (defun check-defmethod-congruency (gf method) |
---|
788 | (unless (congruent-lambda-lists-p gf method) |
---|
789 | (cerror (format nil |
---|
790 | "Remove ~d method~:p from the generic-function and change its lambda list." |
---|
791 | (length (%gf-methods gf))) |
---|
792 | "Lambda list of method ~S ~%~ |
---|
793 | is incompatible with that of the generic function ~S.~%~ |
---|
794 | Method's lambda-list : ~s~%~ |
---|
795 | Generic-function's : ~s~%" method (or (generic-function-name gf) gf) (flatten-method-lambda-list (%method-lambda-list method)) (generic-function-lambda-list gf)) |
---|
796 | (loop |
---|
797 | (let ((methods (%gf-methods gf))) |
---|
798 | (if methods |
---|
799 | (remove-method gf (car methods)) |
---|
800 | (return)))) |
---|
801 | (%set-defgeneric-keys gf nil) |
---|
802 | (inner-lfun-bits gf (%ilogior (%ilsl $lfbits-gfn-bit 1) |
---|
803 | (%ilogand $lfbits-args-mask |
---|
804 | (lfun-bits (%method-function method)))))) |
---|
805 | gf) |
---|
806 | |
---|
807 | |
---|
808 | |
---|
809 | (defun %method-function-method (method-function) |
---|
810 | (setq method-function |
---|
811 | (closure-function |
---|
812 | (find-unencapsulated-definition method-function))) |
---|
813 | (setq method-function (require-type method-function 'method-function)) |
---|
814 | (lfun-name method-function)) |
---|
815 | |
---|
816 | (defstatic %defgeneric-methods% (make-hash-table :test 'eq :weak t)) |
---|
817 | |
---|
818 | (defun %defgeneric-methods (gf) |
---|
819 | (gethash gf %defgeneric-methods%)) |
---|
820 | |
---|
821 | (defun %set-defgeneric-methods (gf &rest methods) |
---|
822 | (if methods |
---|
823 | (setf (gethash gf %defgeneric-methods%) methods) |
---|
824 | (remhash gf %defgeneric-methods%))) |
---|
825 | |
---|
826 | (defun %defgeneric-keys (gf) |
---|
827 | (%gf-dispatch-table-keyvect (%gf-dispatch-table gf))) |
---|
828 | |
---|
829 | (defun %set-defgeneric-keys (gf keyvect) |
---|
830 | (setf (%gf-dispatch-table-keyvect (%gf-dispatch-table gf)) keyvect)) |
---|
831 | |
---|
832 | (defun congruent-lfbits-p (gbits mbits) |
---|
833 | (and (eq (ldb $lfbits-numreq gbits) (ldb $lfbits-numreq mbits)) |
---|
834 | (eq (ldb $lfbits-numopt gbits) (ldb $lfbits-numopt mbits)) |
---|
835 | (eq (or (logbitp $lfbits-rest-bit gbits) |
---|
836 | (logbitp $lfbits-restv-bit gbits) |
---|
837 | (logbitp $lfbits-keys-bit gbits)) |
---|
838 | (or (logbitp $lfbits-rest-bit mbits) |
---|
839 | (logbitp $lfbits-restv-bit mbits) |
---|
840 | (logbitp $lfbits-keys-bit mbits))))) |
---|
841 | |
---|
842 | (defun congruent-lambda-lists-p (gf method &optional |
---|
843 | error-p gbits mbits gkeys) |
---|
844 | (unless gbits (setq gbits (inner-lfun-bits gf))) |
---|
845 | (unless mbits (setq mbits (encode-lambda-list (%method-lambda-list method)))) |
---|
846 | (and (congruent-lfbits-p gbits mbits) |
---|
847 | (or (and (or (logbitp $lfbits-rest-bit mbits) |
---|
848 | (logbitp $lfbits-restv-bit mbits)) |
---|
849 | (not (logbitp $lfbits-keys-bit mbits))) |
---|
850 | (logbitp $lfbits-aok-bit mbits) |
---|
851 | (progn |
---|
852 | (unless gkeys (setq gkeys (%defgeneric-keys gf))) |
---|
853 | (or (null gkeys) |
---|
854 | (eql 0 (length gkeys)) |
---|
855 | (let ((mkeys (lfun-keyvect |
---|
856 | (%inner-method-function method)))) |
---|
857 | (dovector (key gkeys t) |
---|
858 | (unless (find key mkeys :test 'eq) |
---|
859 | (if error-p |
---|
860 | (error "~s does not specify keys: ~s" method gkeys)) |
---|
861 | (return nil))))))))) |
---|
862 | |
---|
863 | (defun %add-method (gf method) |
---|
864 | (%add-standard-method-to-standard-gf gf method)) |
---|
865 | |
---|
866 | ;; Redefined in l1-clos.lisp |
---|
867 | (fset 'maybe-remove-make-instance-optimization |
---|
868 | (nlambda bootstrapping-maybe-remove-make-instance-optimization (gfn method) |
---|
869 | (declare (ignore gfn method)) |
---|
870 | nil)) |
---|
871 | |
---|
872 | (defun %add-standard-method-to-standard-gf (gfn method) |
---|
873 | (when (%method-gf method) |
---|
874 | (error "~s is already a method of ~s." method (%method-gf method))) |
---|
875 | (set-gf-arg-info gfn :new-method method) |
---|
876 | (let* ((dt (%gf-dispatch-table gfn)) |
---|
877 | (methods (sgf.methods gfn)) |
---|
878 | (specializers (%method-specializers method)) |
---|
879 | (qualifiers (%method-qualifiers method))) |
---|
880 | (remove-obsoleted-combined-methods method dt specializers) |
---|
881 | (maybe-remove-make-instance-optimization gfn method) |
---|
882 | (apply #'invalidate-initargs-vector-for-gf gfn specializers) |
---|
883 | (dolist (m methods) |
---|
884 | (when (and (equal specializers (%method-specializers m)) |
---|
885 | (equal qualifiers (%method-qualifiers m))) |
---|
886 | (remove-method gfn m) |
---|
887 | ;; There can be at most one match |
---|
888 | (return))) |
---|
889 | (push method (sgf.methods gfn)) |
---|
890 | (setf (%gf-dispatch-table-methods dt) (sgf.methods gfn)) |
---|
891 | (setf (%method-gf method) gfn) |
---|
892 | (%add-direct-methods method) |
---|
893 | (compute-dcode gfn dt) |
---|
894 | (when (sgf.dependents gfn) |
---|
895 | (map-dependents gfn #'(lambda (d) |
---|
896 | (update-dependent gfn d 'add-method method))))) |
---|
897 | gfn) |
---|
898 | |
---|
899 | (defstatic *standard-kernel-method-class* nil) |
---|
900 | |
---|
901 | (defun methods-congruent-p (m1 m2) |
---|
902 | (when (and (standard-method-p m1)(standard-method-p m2)) |
---|
903 | (when (equal (%method-qualifiers m1) (%method-qualifiers m2)) |
---|
904 | (let ((specs (%method-specializers m1))) |
---|
905 | (dolist (msp (%method-specializers m2) t) |
---|
906 | (let ((spec (%pop specs))) |
---|
907 | (unless (eq msp spec) |
---|
908 | (return nil)))))))) |
---|
909 | |
---|
910 | (defvar *maintain-class-direct-methods* nil) |
---|
911 | |
---|
912 | |
---|
913 | |
---|
914 | ;;; CAR is an EQL hash table for objects whose identity is not used by EQL |
---|
915 | ;;; (numbers and macptrs) |
---|
916 | ;;; CDR is a weak EQ hash table for other objects. |
---|
917 | (defvar *eql-methods-hashes* (cons (make-hash-table :test 'eql) |
---|
918 | (make-hash-table :test 'eq :weak :key))) |
---|
919 | |
---|
920 | (defun eql-methods-cell (object &optional addp) |
---|
921 | (let ((hashes *eql-methods-hashes*)) |
---|
922 | (without-interrupts |
---|
923 | (let* ((hash (cond |
---|
924 | ((or (typep object 'number) |
---|
925 | (typep object 'macptr)) |
---|
926 | (car hashes)) |
---|
927 | (t (cdr hashes)))) |
---|
928 | (cell (gethash object hash))) |
---|
929 | (when (and (null cell) addp) |
---|
930 | (setf (gethash object hash) (setq cell (cons nil nil)))) |
---|
931 | cell)))) |
---|
932 | |
---|
933 | |
---|
934 | |
---|
935 | |
---|
936 | (defun map-classes (function) |
---|
937 | (with-hash-table-iterator (m %find-classes%) |
---|
938 | (loop |
---|
939 | (multiple-value-bind (found name cell) (m) |
---|
940 | (declare (optimize speed) (type class-cell cell)) |
---|
941 | (unless found (return)) |
---|
942 | (when cell |
---|
943 | (funcall function name (class-cell-class cell))))))) |
---|
944 | |
---|
945 | |
---|
946 | |
---|
947 | (defun %class-primary-slot-accessor-info (class accessor-or-slot-name &optional create?) |
---|
948 | (let ((info-list (%class-get class '%class-primary-slot-accessor-info))) |
---|
949 | (or (car (member accessor-or-slot-name info-list |
---|
950 | :key #'(lambda (x) (%slot-accessor-info.accessor x)))) |
---|
951 | (and create? |
---|
952 | (let ((info (%cons-slot-accessor-info class accessor-or-slot-name))) |
---|
953 | (setf (%class-get class '%class-primary-slot-accessor-info) |
---|
954 | (cons info info-list)) |
---|
955 | info))))) |
---|
956 | |
---|
957 | ;;; Clear the %class.primary-slot-accessor-info for an added or |
---|
958 | ;;; removed method's specializers |
---|
959 | (defun clear-accessor-method-offsets (gf method) |
---|
960 | (when (or (typep method 'standard-accessor-method) |
---|
961 | (member 'standard-accessor-method |
---|
962 | (%gf-methods gf) |
---|
963 | :test #'(lambda (sam meth) |
---|
964 | (declare (ignore sam)) |
---|
965 | (typep meth 'standard-accessor-method)))) |
---|
966 | (labels ((clear-class (class) |
---|
967 | (when (typep class 'standard-class) |
---|
968 | (let ((info (%class-primary-slot-accessor-info class gf))) |
---|
969 | (when info |
---|
970 | (setf (%slot-accessor-info.offset info) nil))) |
---|
971 | (mapc #'clear-class (%class.subclasses class))))) |
---|
972 | (declare (dynamic-extent #'clear-class)) |
---|
973 | (mapc #'clear-class (%method-specializers method))))) |
---|
974 | |
---|
975 | ;;; Remove methods which specialize on a sub-class of method's |
---|
976 | ;;; specializers from the generic-function dispatch-table dt. |
---|
977 | (defun remove-obsoleted-combined-methods (method &optional dt |
---|
978 | (specializers (%method-specializers method))) |
---|
979 | (without-interrupts |
---|
980 | (unless dt |
---|
981 | (let ((gf (%method-gf method))) |
---|
982 | (when gf (setq dt (%gf-dispatch-table gf))))) |
---|
983 | (when dt |
---|
984 | (if specializers |
---|
985 | (let* ((argnum (%gf-dispatch-table-argnum dt))) |
---|
986 | (when (>= argnum 0) |
---|
987 | (let ((class (nth argnum specializers)) |
---|
988 | (size (%gf-dispatch-table-size dt)) |
---|
989 | (index 0)) |
---|
990 | (clear-accessor-method-offsets (%gf-dispatch-table-gf dt) method) |
---|
991 | (if (typep class 'eql-specializer) |
---|
992 | (setq class (class-of (eql-specializer-object class)))) |
---|
993 | (while (%i< index size) |
---|
994 | (let* ((wrapper (%gf-dispatch-table-ref dt index)) |
---|
995 | hash-index-0? |
---|
996 | (cpl (and wrapper |
---|
997 | (not (setq hash-index-0? |
---|
998 | (eql 0 (%wrapper-hash-index wrapper)))) |
---|
999 | (%inited-class-cpl |
---|
1000 | (require-type (%wrapper-class wrapper) 'class))))) |
---|
1001 | (when (or hash-index-0? (and cpl (cpl-index class cpl))) |
---|
1002 | (setf (%gf-dispatch-table-ref dt index) *obsolete-wrapper* |
---|
1003 | (%gf-dispatch-table-ref dt (%i+ index 1)) *gf-dispatch-bug*)) |
---|
1004 | (setq index (%i+ index 2))))))) |
---|
1005 | (setf (%gf-dispatch-table-ref dt 1) nil))))) ; clear 0-arg gf cm |
---|
1006 | |
---|
1007 | ;;; SETQ'd below after the GF's exist. |
---|
1008 | (defvar *initialization-invalidation-alist* nil) |
---|
1009 | |
---|
1010 | ;;; Called by %add-method, %remove-method |
---|
1011 | (defun invalidate-initargs-vector-for-gf (gf &optional first-specializer &rest other-specializers) |
---|
1012 | (declare (ignore other-specializers)) |
---|
1013 | (when (and first-specializer (typep first-specializer 'class)) ; no eql methods or gfs with no specializers need apply |
---|
1014 | (let ((indices (cdr (assq gf *initialization-invalidation-alist*)))) |
---|
1015 | (when indices |
---|
1016 | (labels ((invalidate (class indices) |
---|
1017 | (when (std-class-p class) ; catch the class named T |
---|
1018 | (dolist (index indices) |
---|
1019 | (setf (standard-instance-instance-location-access class index) nil))) |
---|
1020 | (dolist (subclass (%class.subclasses class)) |
---|
1021 | (invalidate subclass indices)))) |
---|
1022 | (invalidate first-specializer indices)))))) |
---|
1023 | |
---|
1024 | ;;; Return two values: |
---|
1025 | ;;; 1) the index of the first non-T specializer of method, or NIL if |
---|
1026 | ;;; all the specializers are T or only the first one is T |
---|
1027 | ;;; 2) the index of the first non-T specializer |
---|
1028 | (defun multi-method-index (method &aux (i 0) index) |
---|
1029 | (dolist (s (%method.specializers method) (values nil index)) |
---|
1030 | (unless (eq s *t-class*) |
---|
1031 | (unless index (setq index i)) |
---|
1032 | (unless (eql i 0) (return (values index index)))) |
---|
1033 | (incf i))) |
---|
1034 | |
---|
1035 | (defun %remove-standard-method-from-containing-gf (method) |
---|
1036 | (setq method (require-type method 'standard-method)) |
---|
1037 | (let ((gf (%method-gf method))) |
---|
1038 | (when gf |
---|
1039 | (let* ((dt (%gf-dispatch-table gf)) |
---|
1040 | (methods (sgf.methods gf))) |
---|
1041 | (setf (%method-gf method) nil) |
---|
1042 | (setq methods (nremove method methods)) |
---|
1043 | (setf (%gf-dispatch-table-methods dt) methods |
---|
1044 | (sgf.methods gf) methods) |
---|
1045 | (%remove-direct-methods method) |
---|
1046 | (remove-obsoleted-combined-methods method dt) |
---|
1047 | (apply #'invalidate-initargs-vector-for-gf gf (%method-specializers method)) |
---|
1048 | (compute-dcode gf dt) |
---|
1049 | (when (sgf.dependents gf) |
---|
1050 | (map-dependents |
---|
1051 | gf |
---|
1052 | #'(lambda (d) |
---|
1053 | (update-dependent gf d 'remove-method method))))))) |
---|
1054 | method) |
---|
1055 | |
---|
1056 | |
---|
1057 | (defvar *reader-method-function-proto* |
---|
1058 | #'(lambda (instance) |
---|
1059 | (slot-value instance 'x))) |
---|
1060 | |
---|
1061 | |
---|
1062 | (defvar *writer-method-function-proto* |
---|
1063 | #'(lambda (new instance) |
---|
1064 | (set-slot-value instance 'x new))) |
---|
1065 | |
---|
1066 | (defun dcode-for-gf (gf dcode) |
---|
1067 | (if *uniquify-dcode* |
---|
1068 | (let ((new-dcode (%copy-function dcode))) |
---|
1069 | (lfun-name new-dcode (list (lfun-name dcode) (lfun-name gf))) |
---|
1070 | new-dcode) |
---|
1071 | dcode)) |
---|
1072 | |
---|
1073 | (defstatic *non-dt-dcode-functions* () "List of functions which return a dcode function for the GF which is their argument. The dcode functions will be caled with all of the incoming arguments.") |
---|
1074 | |
---|
1075 | (defun non-dt-dcode-function (gf) |
---|
1076 | (dolist (f *non-dt-dcode-functions*) |
---|
1077 | (let* ((dcode (funcall f gf))) |
---|
1078 | (when dcode (return dcode))))) |
---|
1079 | |
---|
1080 | (defun compute-dcode (gf &optional dt) |
---|
1081 | (setq gf (require-type gf 'standard-generic-function)) |
---|
1082 | (unless dt (setq dt (%gf-dispatch-table gf))) |
---|
1083 | (let* ((methods (%gf-dispatch-table-methods dt)) |
---|
1084 | (bits (inner-lfun-bits gf)) |
---|
1085 | (nreq (ldb $lfbits-numreq bits)) |
---|
1086 | (0-args? (eql 0 nreq)) |
---|
1087 | (other-args? (or (not (eql 0 (ldb $lfbits-numopt bits))) |
---|
1088 | (logbitp $lfbits-rest-bit bits) |
---|
1089 | (logbitp $lfbits-restv-bit bits) |
---|
1090 | (logbitp $lfbits-keys-bit bits) |
---|
1091 | (logbitp $lfbits-aok-bit bits))) |
---|
1092 | multi-method-index |
---|
1093 | min-index) |
---|
1094 | (when methods |
---|
1095 | (unless 0-args? |
---|
1096 | (dolist (m methods) |
---|
1097 | (multiple-value-bind (mm-index index) (multi-method-index m) |
---|
1098 | (when mm-index |
---|
1099 | (if (or (null multi-method-index) (< mm-index multi-method-index)) |
---|
1100 | (setq multi-method-index mm-index))) |
---|
1101 | (when index |
---|
1102 | (if (or (null min-index) (< index min-index)) |
---|
1103 | (setq min-index index)))))) |
---|
1104 | (let* ((non-dt (non-dt-dcode-function gf)) |
---|
1105 | (dcode (or non-dt |
---|
1106 | (if 0-args? |
---|
1107 | #'%%0-arg-dcode |
---|
1108 | (or (if multi-method-index |
---|
1109 | #'%%nth-arg-dcode) |
---|
1110 | (if (null other-args?) |
---|
1111 | (if (eql nreq 1) |
---|
1112 | #'%%one-arg-dcode |
---|
1113 | (if (eql nreq 2) |
---|
1114 | #'%%1st-two-arg-dcode |
---|
1115 | #'%%1st-arg-dcode)) |
---|
1116 | #'%%1st-arg-dcode)))))) |
---|
1117 | (setq multi-method-index |
---|
1118 | (if multi-method-index |
---|
1119 | (if min-index |
---|
1120 | (min multi-method-index min-index) |
---|
1121 | multi-method-index) |
---|
1122 | 0)) |
---|
1123 | (let* ((old-dcode (%gf-dcode (find-unencapsulated-definition gf)))) |
---|
1124 | (when (or non-dt |
---|
1125 | (neq dcode old-dcode) |
---|
1126 | (neq multi-method-index (%gf-dispatch-table-argnum dt))) |
---|
1127 | (clear-gf-dispatch-table dt) |
---|
1128 | (setf (%gf-dispatch-table-argnum dt) multi-method-index) |
---|
1129 | (if (function-encapsulated-p gf) |
---|
1130 | (%set-encapsulated-gf-dcode gf dcode) |
---|
1131 | (setf (%gf-dcode gf) dcode)))) |
---|
1132 | (values dcode multi-method-index))))) |
---|
1133 | |
---|
1134 | (defun inherits-from-standard-generic-function-p (class) |
---|
1135 | (memq *standard-generic-function-class* |
---|
1136 | (%inited-class-cpl (require-type class 'class)))) |
---|
1137 | |
---|
1138 | ;;;;;;;;;;; The type system needs to get wedged into CLOS fairly early ;;;;;;; |
---|
1139 | |
---|
1140 | |
---|
1141 | ;;; Could check for duplicates, but not really worth it. They're all |
---|
1142 | ;;; allocated here |
---|
1143 | (defun new-type-class (name) |
---|
1144 | (let* ((class (%istruct |
---|
1145 | 'type-class |
---|
1146 | name |
---|
1147 | #'missing-type-method |
---|
1148 | nil |
---|
1149 | nil |
---|
1150 | #'(lambda (x y) (hierarchical-union2 x y)) |
---|
1151 | nil |
---|
1152 | #'(lambda (x y) (hierarchical-intersection2 x y)) |
---|
1153 | nil |
---|
1154 | #'missing-type-method |
---|
1155 | nil |
---|
1156 | #'missing-type-method))) |
---|
1157 | (push (cons name class) *type-classes*) |
---|
1158 | class)) |
---|
1159 | |
---|
1160 | ;; There are ultimately about a dozen entries on this alist. |
---|
1161 | (defvar *type-classes* nil) |
---|
1162 | (declaim (special *wild-type* *empty-type* *universal-type*)) |
---|
1163 | (defvar *type-kind-info* (make-hash-table :test #'equal)) |
---|
1164 | |
---|
1165 | (defun info-type-kind (name) |
---|
1166 | (gethash name *type-kind-info*)) |
---|
1167 | |
---|
1168 | (defun (setf info-type-kind) (val name) |
---|
1169 | (if val |
---|
1170 | (setf (gethash name *type-kind-info*) val) |
---|
1171 | (remhash name *type-kind-info*))) |
---|
1172 | |
---|
1173 | (defun missing-type-method (&rest foo) |
---|
1174 | (error "Missing type method for ~S" foo)) |
---|
1175 | |
---|
1176 | (new-type-class 'values) |
---|
1177 | (new-type-class 'function) |
---|
1178 | (new-type-class 'constant) |
---|
1179 | (new-type-class 'wild) |
---|
1180 | (new-type-class 'bottom) |
---|
1181 | (new-type-class 'named) |
---|
1182 | (new-type-class 'hairy) |
---|
1183 | (new-type-class 'unknown) |
---|
1184 | (new-type-class 'number) |
---|
1185 | (new-type-class 'array) |
---|
1186 | (new-type-class 'member) |
---|
1187 | (new-type-class 'union) |
---|
1188 | (new-type-class 'foreign) |
---|
1189 | (new-type-class 'cons) |
---|
1190 | (new-type-class 'intersection) |
---|
1191 | (new-type-class 'negation) |
---|
1192 | (defparameter *class-type-class* (new-type-class 'class)) |
---|
1193 | |
---|
1194 | |
---|
1195 | |
---|
1196 | |
---|
1197 | |
---|
1198 | ;;;;;;;;;;;;;;;;;;;;;;;; Instances and classes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
---|
1199 | |
---|
1200 | (declaim (inline non-standard-instance-class-wrapper)) |
---|
1201 | |
---|
1202 | (defun non-standard-instance-class-wrapper (instance) |
---|
1203 | (let* ((typecode (typecode instance))) |
---|
1204 | (declare (type (unsigned-byte 8) typecode)) |
---|
1205 | (cond ((eql typecode target::subtag-struct) |
---|
1206 | (%class.own-wrapper |
---|
1207 | (class-cell-class (car (%svref instance 0))))) |
---|
1208 | ((eql typecode target::subtag-istruct) |
---|
1209 | (istruct-cell-info (%svref instance 0))) |
---|
1210 | ((eql typecode target::subtag-basic-stream) |
---|
1211 | (basic-stream.wrapper instance)) |
---|
1212 | ((typep instance 'funcallable-standard-object) |
---|
1213 | (gf.instance.class-wrapper instance)) |
---|
1214 | ((eql typecode target::subtag-macptr) (foreign-instance-class-wrapper instance)) |
---|
1215 | (t (%class.own-wrapper (class-of instance)))))) |
---|
1216 | |
---|
1217 | (defun instance-class-wrapper (instance) |
---|
1218 | (if (= (typecode instance) target::subtag-instance) |
---|
1219 | (instance.class-wrapper instance) |
---|
1220 | (non-standard-instance-class-wrapper instance))) |
---|
1221 | |
---|
1222 | |
---|
1223 | (defun std-instance-class-cell-typep (form class-cell) |
---|
1224 | (let* ((typecode (typecode form)) |
---|
1225 | (wrapper (cond ((= typecode target::subtag-instance) |
---|
1226 | (instance.class-wrapper form)) |
---|
1227 | ((= typecode target::subtag-basic-stream) |
---|
1228 | (basic-stream.wrapper form)) |
---|
1229 | (t nil)))) |
---|
1230 | (declare (type (unsigned-byte 8) typecode)) |
---|
1231 | (when wrapper |
---|
1232 | (loop |
---|
1233 | (let ((class (class-cell-class class-cell))) |
---|
1234 | (if class |
---|
1235 | (let* ((ordinal (%class-ordinal class)) |
---|
1236 | (bits (or (%wrapper-cpl-bits wrapper) |
---|
1237 | (make-cpl-bits (%inited-class-cpl (%wrapper-class wrapper)))))) |
---|
1238 | (declare (fixnum ordinal)) |
---|
1239 | (return |
---|
1240 | (if bits |
---|
1241 | (locally (declare (simple-bit-vector bits) |
---|
1242 | (optimize (speed 3) (safety 0))) |
---|
1243 | (if (< ordinal (length bits)) |
---|
1244 | (not (eql 0 (sbit bits ordinal)))))))) |
---|
1245 | (let* ((name (class-cell-name class-cell)) |
---|
1246 | (new-cell (find-class-cell name nil))) |
---|
1247 | (unless |
---|
1248 | (if (and new-cell (not (eq class-cell new-cell))) |
---|
1249 | (setq class-cell new-cell class (class-cell-class class-cell)) |
---|
1250 | (return (typep form name))))))))))) |
---|
1251 | |
---|
1252 | (defun class-cell-typep (form class-cell) |
---|
1253 | (locally (declare (type class-cell class-cell)) |
---|
1254 | (loop |
---|
1255 | (let ((class (class-cell-class class-cell))) |
---|
1256 | (if class |
---|
1257 | (let* ((ordinal (%class-ordinal class)) |
---|
1258 | (wrapper (instance-class-wrapper form)) |
---|
1259 | (bits (or (%wrapper-cpl-bits wrapper) |
---|
1260 | (make-cpl-bits (%inited-class-cpl (%wrapper-class wrapper)))))) |
---|
1261 | (declare (fixnum ordinal)) |
---|
1262 | (return |
---|
1263 | (if bits |
---|
1264 | (locally (declare (simple-bit-vector bits) |
---|
1265 | (optimize (speed 3) (safety 0))) |
---|
1266 | (if (< ordinal (length bits)) |
---|
1267 | (not (eql 0 (sbit bits ordinal)))))))) |
---|
1268 | (let* ((name (class-cell-name class-cell)) |
---|
1269 | (new-cell (find-class-cell name nil))) |
---|
1270 | (unless |
---|
1271 | (if (and new-cell (not (eq class-cell new-cell))) |
---|
1272 | (setq class-cell new-cell class (class-cell-class class-cell)) |
---|
1273 | (return (typep form name)))))))))) |
---|
1274 | |
---|
1275 | |
---|
1276 | |
---|
1277 | (defun %require-type-class-cell (arg class-cell) |
---|
1278 | (if (class-cell-typep arg class-cell) |
---|
1279 | arg |
---|
1280 | (%kernel-restart $xwrongtype arg (car class-cell)))) |
---|
1281 | |
---|
1282 | |
---|
1283 | |
---|
1284 | |
---|
1285 | (defun find-class (name &optional (errorp t) environment) |
---|
1286 | (declare (optimize speed)) |
---|
1287 | (let* ((cell (find-class-cell name nil))) |
---|
1288 | (declare (type class-cell cell)) |
---|
1289 | (or (and cell (class-cell-class cell)) |
---|
1290 | (let ((defenv (and environment (definition-environment environment)))) |
---|
1291 | (when defenv |
---|
1292 | (dolist (class (defenv.classes defenv)) |
---|
1293 | (when (eq name (%class.name class)) |
---|
1294 | (return class))))) |
---|
1295 | (when (or errorp (not (symbolp name))) |
---|
1296 | (cerror "Try finding the class again" |
---|
1297 | "Class named ~S not found." name) |
---|
1298 | (find-class name errorp environment))))) |
---|
1299 | |
---|
1300 | (fset 'pessimize-make-instance-for-class-name ;; redefined later |
---|
1301 | (qlfun bootstrapping-pessimize-make-instance-for-class-name (name) name)) |
---|
1302 | |
---|
1303 | (defun update-class-proper-names (name old-class new-class) |
---|
1304 | (when name |
---|
1305 | (pessimize-make-instance-for-class-name name)) |
---|
1306 | (when (and old-class |
---|
1307 | (not (eq old-class new-class)) |
---|
1308 | (eq (%class-proper-name old-class) name)) |
---|
1309 | (setf (%class-proper-name old-class) nil)) |
---|
1310 | (when (and new-class (eq (%class-name new-class) name)) |
---|
1311 | (setf (%class-proper-name new-class) name))) |
---|
1312 | |
---|
1313 | |
---|
1314 | (fset 'set-find-class (nfunction bootstrapping-set-find-class ; redefined below |
---|
1315 | (lambda (name class) |
---|
1316 | (clear-type-cache) |
---|
1317 | (let* ((cell (find-class-cell name t)) |
---|
1318 | (old-class (class-cell-class cell))) |
---|
1319 | (when class |
---|
1320 | (if (eq name (%class.name class)) |
---|
1321 | (setf (info-type-kind name) :instance))) |
---|
1322 | (setf (class-cell-class cell) class) |
---|
1323 | (update-class-proper-names name old-class class) |
---|
1324 | class)))) |
---|
1325 | |
---|
1326 | |
---|
1327 | ;;; bootstrapping definition. real one is in "sysutils.lisp" |
---|
1328 | (fset 'built-in-type-p (nfunction boostrapping-built-in-typep-p |
---|
1329 | (lambda (name) |
---|
1330 | (or (type-predicate name) |
---|
1331 | (memq name '(signed-byte unsigned-byte mod |
---|
1332 | values satisfies member and or not)) |
---|
1333 | (typep (find-class name nil) 'built-in-class))))) |
---|
1334 | |
---|
1335 | |
---|
1336 | |
---|
1337 | (defun %compile-time-defclass (name environment) |
---|
1338 | (note-type-info name 'class environment) |
---|
1339 | (unless (find-class name nil environment) |
---|
1340 | (let ((defenv (definition-environment environment))) |
---|
1341 | (when defenv |
---|
1342 | (push (make-instance 'compile-time-class :name name) |
---|
1343 | (defenv.classes defenv))))) |
---|
1344 | name) |
---|
1345 | |
---|
1346 | (eval-when (:compile-toplevel :execute) |
---|
1347 | (declaim (inline standard-instance-p)) |
---|
1348 | ) |
---|
1349 | |
---|
1350 | |
---|
1351 | |
---|
1352 | |
---|
1353 | (defun standard-instance-p (i) |
---|
1354 | (eq (typecode i) target::subtag-instance)) |
---|
1355 | |
---|
1356 | (defun check-setf-find-class-protected-class (old-class new-class name) |
---|
1357 | (when (and (standard-instance-p old-class) |
---|
1358 | (%class-kernel-p old-class) |
---|
1359 | *warn-if-redefine-kernel* |
---|
1360 | ;; EQL might be necessary on foreign classes |
---|
1361 | (not (eq new-class old-class))) |
---|
1362 | (cerror "Setf (FIND-CLASS ~s) to the new class." |
---|
1363 | "The class name ~s currently denotes the class ~s that |
---|
1364 | marked as being a critical part of the system; an attempt is being made |
---|
1365 | to replace that class with ~s" name old-class new-class) |
---|
1366 | (setf (%class-kernel-p old-class) nil))) |
---|
1367 | |
---|
1368 | |
---|
1369 | (queue-fixup |
---|
1370 | (defun set-find-class (name class) |
---|
1371 | (setq name (require-type name 'symbol)) |
---|
1372 | (let* ((cell (find-class-cell name t)) |
---|
1373 | (old-class (class-cell-class cell))) |
---|
1374 | (declare (type class-cell cell)) |
---|
1375 | (when old-class |
---|
1376 | (when (eq (%class.name old-class) name) |
---|
1377 | (setf (info-type-kind name) nil) |
---|
1378 | (clear-type-cache)) |
---|
1379 | (when *warn-if-redefine-kernel* |
---|
1380 | (check-setf-find-class-protected-class old-class class name))) |
---|
1381 | (when (null class) |
---|
1382 | (when cell |
---|
1383 | (setf (class-cell-class cell) nil)) |
---|
1384 | (update-class-proper-names name old-class class) |
---|
1385 | (return-from set-find-class nil)) |
---|
1386 | (setq class (require-type class 'class)) |
---|
1387 | (when (built-in-type-p name) |
---|
1388 | (unless (eq (class-cell-class cell) class) |
---|
1389 | (error "Cannot redefine built-in type name ~S" name))) |
---|
1390 | (when (eq (%class.name class) name) |
---|
1391 | (when (%deftype-expander name) |
---|
1392 | (cerror "set ~S anyway, removing the ~*~S definition" |
---|
1393 | "Cannot set ~S because type ~S is already defined by ~S" |
---|
1394 | `(find-class ',name) name 'deftype) |
---|
1395 | (%deftype name nil nil)) |
---|
1396 | (setf (info-type-kind name) :instance)) |
---|
1397 | (update-class-proper-names name old-class class) |
---|
1398 | (setf (class-cell-class cell) class))) |
---|
1399 | ) ; end of queue-fixup |
---|
1400 | |
---|
1401 | |
---|
1402 | |
---|
1403 | #|| |
---|
1404 | ; This tended to cluster entries in gf dispatch tables too much. |
---|
1405 | (defvar *class-wrapper-hash-index* 0) |
---|
1406 | (defun new-class-wrapper-hash-index () |
---|
1407 | (let ((index *class-wrapper-hash-index*)) |
---|
1408 | (setq *class-wrapper-hash-index* |
---|
1409 | (if (< index (- most-positive-fixnum 2)) |
---|
1410 | ; Increment by two longwords. This is important! |
---|
1411 | ; The dispatch code will break if you change this. |
---|
1412 | (%i+ index 3) ; '3 = 24 bytes = 6 longwords in lap. |
---|
1413 | 1)))) |
---|
1414 | ||# |
---|
1415 | |
---|
1416 | (defglobal *next-class-ordinal* 0) |
---|
1417 | |
---|
1418 | (defun %next-class-ordinal () |
---|
1419 | (%atomic-incf-node 1 '*next-class-ordinal* target::symbol.vcell)) |
---|
1420 | |
---|
1421 | ;;; Initialized after built-in-class is made |
---|
1422 | (defvar *built-in-class-wrapper* nil) |
---|
1423 | |
---|
1424 | (defun make-class-ctype (class) |
---|
1425 | (%istruct 'class-ctype *class-type-class* nil class nil)) |
---|
1426 | |
---|
1427 | (defun %class-ordinal (class &optional no-error) |
---|
1428 | (if (standard-instance-p class) |
---|
1429 | (instance.hash class) |
---|
1430 | (if (typep class 'macptr) |
---|
1431 | (foreign-class-ordinal class) |
---|
1432 | (unless no-error |
---|
1433 | (error "Can't determine ordinal of ~s" class))))) |
---|
1434 | |
---|
1435 | (defun (setf %class-ordinal) (new class &optional no-error) |
---|
1436 | (if (standard-instance-p class) |
---|
1437 | (setf (instance.hash class) new) |
---|
1438 | (if (typep class 'macptr) |
---|
1439 | (setf (foreign-class-ordinal class) new) |
---|
1440 | (unless no-error |
---|
1441 | (error "Can't set ordinal of class ~s to ~s" class new))))) |
---|
1442 | |
---|
1443 | |
---|
1444 | (defvar *t-class* (let* ((class (%cons-built-in-class 't))) |
---|
1445 | (setf (instance.hash class) 0) |
---|
1446 | (let* ((cpl (list class)) |
---|
1447 | (wrapper (%cons-wrapper class (new-class-wrapper-hash-index)))) |
---|
1448 | (setf (%class.cpl class) cpl) |
---|
1449 | (setf (%wrapper-cpl wrapper) cpl |
---|
1450 | (%class.own-wrapper class) wrapper |
---|
1451 | (%wrapper-cpl-bits wrapper) |
---|
1452 | (let* ((bv (make-array 1 :element-type 'bit))) |
---|
1453 | (setf (aref bv 0) 1) |
---|
1454 | bv)) |
---|
1455 | (setf (%class.ctype class) (make-class-ctype class)) |
---|
1456 | (setf (find-class 't) class) |
---|
1457 | class))) |
---|
1458 | |
---|
1459 | (defun compute-cpl (class) |
---|
1460 | (flet ((%real-class-cpl (class) |
---|
1461 | (or (%class-cpl class) |
---|
1462 | (compute-cpl class)))) |
---|
1463 | (let* ((predecessors (list (list class))) candidates cpl) |
---|
1464 | (dolist (sup (%class-direct-superclasses class)) |
---|
1465 | (when (symbolp sup) (report-bad-arg sup 'class)) |
---|
1466 | (dolist (sup (%real-class-cpl sup)) |
---|
1467 | (unless (assq sup predecessors) (push (list sup) predecessors)))) |
---|
1468 | (labels ((compute-predecessors (class table) |
---|
1469 | (dolist (sup (%class-direct-superclasses class) table) |
---|
1470 | (compute-predecessors sup table) |
---|
1471 | ;(push class (cdr (assq sup table))) |
---|
1472 | (let ((a (assq sup table))) (%rplacd a (cons class (%cdr a)))) |
---|
1473 | (setq class sup)))) |
---|
1474 | (compute-predecessors class predecessors)) |
---|
1475 | (setq candidates (list (assq class predecessors))) |
---|
1476 | (while predecessors |
---|
1477 | (dolist (c candidates (error "Inconsistent superclasses for ~d" class)) |
---|
1478 | (when (null (%cdr c)) |
---|
1479 | (setq predecessors (nremove c predecessors)) |
---|
1480 | (dolist (p predecessors) (%rplacd p (nremove (%car c) (%cdr p)))) |
---|
1481 | (setq candidates (nremove c candidates)) |
---|
1482 | (setq cpl (%rplacd c cpl)) |
---|
1483 | (dolist (sup (%class-direct-superclasses (%car c))) |
---|
1484 | (when (setq c (assq sup predecessors)) (push c candidates))) |
---|
1485 | (return)))) |
---|
1486 | (setq cpl (nreverse cpl)) |
---|
1487 | (do* ((tail cpl (%cdr tail)) |
---|
1488 | sup-cpl) |
---|
1489 | ((null (setq sup-cpl (and (cdr tail) (%real-class-cpl (cadr tail)))))) |
---|
1490 | (when (equal (%cdr tail) sup-cpl) |
---|
1491 | (setf (%cdr tail) sup-cpl) |
---|
1492 | (return))) |
---|
1493 | cpl))) |
---|
1494 | |
---|
1495 | (defun make-cpl-bits (cpl) |
---|
1496 | (declare (optimize speed)) |
---|
1497 | (when cpl |
---|
1498 | (let* ((max 0)) |
---|
1499 | (declare (fixnum max)) |
---|
1500 | (dolist (class cpl) |
---|
1501 | (let* ((ordinal (%class-ordinal class))) |
---|
1502 | (declare (fixnum ordinal)) |
---|
1503 | (when (> ordinal max) |
---|
1504 | (setq max ordinal)))) |
---|
1505 | (let* ((bits (make-array (the fixnum (1+ max)) :element-type 'bit))) |
---|
1506 | (dolist (class cpl bits) |
---|
1507 | (let* ((ordinal (%class-ordinal class))) |
---|
1508 | (setf (sbit bits ordinal) 1))))))) |
---|
1509 | |
---|
1510 | |
---|
1511 | (defun make-built-in-class (name &rest supers) |
---|
1512 | (if (null supers) |
---|
1513 | (setq supers (list *t-class*)) |
---|
1514 | (do ((supers supers (%cdr supers))) |
---|
1515 | ((null supers)) |
---|
1516 | (when (symbolp (%car supers)) (%rplaca supers (find-class (%car supers)))))) |
---|
1517 | (let ((class (find-class name nil))) |
---|
1518 | (if class |
---|
1519 | (progn |
---|
1520 | ;Must be debugging. Give a try at redefinition... |
---|
1521 | (dolist (sup (%class.local-supers class)) |
---|
1522 | (setf (%class.subclasses sup) (nremove class (%class.subclasses sup))))) |
---|
1523 | (progn |
---|
1524 | (setq class (%cons-built-in-class name)) |
---|
1525 | (setf (instance.hash class) (%next-class-ordinal)))) |
---|
1526 | (dolist (sup supers) |
---|
1527 | (setf (%class.subclasses sup) (cons class (%class.subclasses sup)))) |
---|
1528 | (setf (%class.local-supers class) supers) |
---|
1529 | (let* ((wrapper (%cons-wrapper class (new-class-wrapper-hash-index))) |
---|
1530 | (cpl (compute-cpl class))) |
---|
1531 | (setf (%class.cpl class) cpl) |
---|
1532 | (setf (%class.own-wrapper class) wrapper) |
---|
1533 | (setf (%wrapper-cpl wrapper) cpl |
---|
1534 | (%wrapper-cpl-bits wrapper) (make-cpl-bits cpl) |
---|
1535 | (%wrapper-class-ordinal wrapper) (%class-ordinal class))) |
---|
1536 | (setf (%class.ctype class) (make-class-ctype class)) |
---|
1537 | (setf (find-class name) class) |
---|
1538 | (dolist (sub (%class.subclasses class)) ; Only non-nil if redefining |
---|
1539 | ;Recompute the cpl. |
---|
1540 | (apply #'make-built-in-class (%class.name sub) (%class.local-supers sub))) |
---|
1541 | class)) |
---|
1542 | |
---|
1543 | (defun make-istruct-class (name &rest supers) |
---|
1544 | (let* ((class (apply #'make-built-in-class name supers)) |
---|
1545 | (cell (register-istruct-cell name))) |
---|
1546 | (setf (istruct-cell-info cell) (%class.own-wrapper class)) |
---|
1547 | class)) |
---|
1548 | |
---|
1549 | ;;; This will be filled in below. Need it defined now as it goes in |
---|
1550 | ;;; the instance.class-wrapper of all the classes that STANDARD-CLASS |
---|
1551 | ;;; inherits from. |
---|
1552 | (defstatic *standard-class-wrapper* |
---|
1553 | (%cons-wrapper 'standard-class)) |
---|
1554 | |
---|
1555 | (defun make-standard-class (name &rest supers) |
---|
1556 | (make-class name *standard-class-wrapper* supers)) |
---|
1557 | |
---|
1558 | (defun make-class (name metaclass-wrapper supers &optional own-wrapper) |
---|
1559 | (let ((class (if (find-class name nil) |
---|
1560 | (error "Attempt to remake standard class ~s" name) |
---|
1561 | (%cons-standard-class name metaclass-wrapper)))) |
---|
1562 | (setf (instance.hash class) (%next-class-ordinal)) |
---|
1563 | (if (null supers) |
---|
1564 | (setq supers (list *standard-class-class*)) |
---|
1565 | (do ((supers supers (cdr supers)) |
---|
1566 | sup) |
---|
1567 | ((null supers)) |
---|
1568 | (setq sup (%car supers)) |
---|
1569 | (if (symbolp sup) (setf (%car supers) (setq sup (find-class (%car supers))))) |
---|
1570 | #+nil (unless (or (eq sup *t-class*) (std-class-p sup)) |
---|
1571 | (error "~a is not of type ~a" sup 'std-class)))) |
---|
1572 | (setf (%class.local-supers class) supers) |
---|
1573 | (let ((cpl (compute-cpl class)) |
---|
1574 | (wrapper (if own-wrapper |
---|
1575 | (progn |
---|
1576 | (setf (%wrapper-class own-wrapper) class) |
---|
1577 | own-wrapper) |
---|
1578 | (%cons-wrapper class)))) |
---|
1579 | (setf (%class.cpl class) cpl |
---|
1580 | (%wrapper-instance-slots wrapper) (vector) |
---|
1581 | (%class.own-wrapper class) wrapper |
---|
1582 | (%class.ctype class) (make-class-ctype class) |
---|
1583 | (%class.slots class) nil |
---|
1584 | (%wrapper-class-ordinal wrapper) (%class-ordinal class) |
---|
1585 | (%wrapper-cpl wrapper) cpl |
---|
1586 | (%wrapper-cpl-bits wrapper) (make-cpl-bits cpl) |
---|
1587 | (find-class name) class |
---|
1588 | ) |
---|
1589 | (dolist (sup supers) |
---|
1590 | (setf (%class.subclasses sup) (cons class (%class.subclasses sup)))) |
---|
1591 | class))) |
---|
1592 | |
---|
1593 | |
---|
1594 | |
---|
1595 | |
---|
1596 | |
---|
1597 | (defun standard-object-p (thing) |
---|
1598 | ;; returns thing's class-wrapper or nil if it isn't a standard-object |
---|
1599 | (if (standard-instance-p thing) |
---|
1600 | (instance.class-wrapper thing) |
---|
1601 | (if (typep thing 'macptr) |
---|
1602 | (foreign-instance-class-wrapper thing)))) |
---|
1603 | |
---|
1604 | |
---|
1605 | (defun std-class-p (class) |
---|
1606 | ;; (typep class 'std-class) |
---|
1607 | ;; but works at bootstrapping time as well |
---|
1608 | (let ((wrapper (standard-object-p class))) |
---|
1609 | (and wrapper |
---|
1610 | (or (eq wrapper *standard-class-wrapper*) |
---|
1611 | (memq *std-class-class* (%inited-class-cpl (%wrapper-class wrapper) t)))))) |
---|
1612 | |
---|
1613 | (set-type-predicate 'std-class 'std-class-p) |
---|
1614 | |
---|
1615 | (defun slots-class-p (class) |
---|
1616 | (let ((wrapper (standard-object-p class))) |
---|
1617 | (and wrapper |
---|
1618 | (or (eq wrapper *slots-class-wrapper*) |
---|
1619 | (memq *slots-class* (%inited-class-cpl (%wrapper-class wrapper) t)))))) |
---|
1620 | |
---|
1621 | (set-type-predicate 'slots-class 'slots-class-p) |
---|
1622 | |
---|
1623 | (defun specializer-p (thing) |
---|
1624 | (memq *specializer-class* (%inited-class-cpl (class-of thing)))) |
---|
1625 | |
---|
1626 | (defstatic *standard-object-class* (make-standard-class 'standard-object *t-class*)) |
---|
1627 | |
---|
1628 | (defstatic *metaobject-class* (make-standard-class 'metaobject *standard-object-class*)) |
---|
1629 | |
---|
1630 | (defstatic *specializer-class* (make-standard-class 'specializer *metaobject-class*)) |
---|
1631 | (defstatic *eql-specializer-class* (make-standard-class 'eql-specializer *specializer-class*)) |
---|
1632 | |
---|
1633 | (defstatic *standard-method-combination* |
---|
1634 | (make-instance-vector |
---|
1635 | (%class.own-wrapper |
---|
1636 | (make-standard-class |
---|
1637 | 'standard-method-combination |
---|
1638 | (make-standard-class 'method-combination *metaobject-class*))) |
---|
1639 | 1)) |
---|
1640 | |
---|
1641 | |
---|
1642 | (defun eql-specializer-p (x) |
---|
1643 | (memq *eql-specializer-class* (%inited-class-cpl (class-of x)))) |
---|
1644 | |
---|
1645 | (setf (type-predicate 'eql-specializer) 'eql-specializer-p) |
---|
1646 | |
---|
1647 | ;;; The *xxx-class-class* instances get slots near the end of this file. |
---|
1648 | (defstatic *class-class* (make-standard-class 'class *specializer-class*)) |
---|
1649 | |
---|
1650 | (defstatic *slots-class* (make-standard-class 'slots-class *class-class*)) |
---|
1651 | (defstatic *slots-class-wrapper* (%class.own-wrapper *slots-class*)) |
---|
1652 | |
---|
1653 | |
---|
1654 | ;;; an implementation class that exists so that |
---|
1655 | ;;; standard-class & funcallable-standard-class can have a common ancestor not |
---|
1656 | ;;; shared by anybody but their subclasses. |
---|
1657 | |
---|
1658 | (defstatic *std-class-class* (make-standard-class 'std-class *slots-class*)) |
---|
1659 | |
---|
1660 | ;;; The class of all objects whose metaclass is standard-class. Yow. |
---|
1661 | (defstatic *standard-class-class* (make-standard-class 'standard-class *std-class-class*)) |
---|
1662 | ;;; Replace its wrapper and the circle is closed. |
---|
1663 | (setf (%class.own-wrapper *standard-class-class*) *standard-class-wrapper* |
---|
1664 | (%wrapper-class *standard-class-wrapper*) *standard-class-class* |
---|
1665 | (%wrapper-class-ordinal *standard-class-wrapper*) (%class-ordinal *standard-class-class*) |
---|
1666 | (%wrapper-instance-slots *standard-class-wrapper*) (vector)) |
---|
1667 | |
---|
1668 | (defstatic *built-in-class-class* (make-standard-class 'built-in-class *class-class*)) |
---|
1669 | (setf *built-in-class-wrapper* (%class.own-wrapper *built-in-class-class*) |
---|
1670 | (instance.class-wrapper *t-class*) *built-in-class-wrapper*) |
---|
1671 | |
---|
1672 | (defstatic *structure-class-class* (make-standard-class 'structure-class *slots-class*)) |
---|
1673 | (defstatic *structure-class-wrapper* (%class.own-wrapper *structure-class-class*)) |
---|
1674 | (defstatic *structure-object-class* |
---|
1675 | (make-class 'structure-object *structure-class-wrapper* (list *t-class*))) |
---|
1676 | |
---|
1677 | (defstatic *forward-referenced-class-class* |
---|
1678 | (make-standard-class 'forward-referenced-class *class-class*)) |
---|
1679 | |
---|
1680 | (defstatic *function-class* (make-built-in-class 'function)) |
---|
1681 | |
---|
1682 | #+arm-target |
---|
1683 | (make-built-in-class 'pseudofunction) |
---|
1684 | |
---|
1685 | (defun alias-class (name class) |
---|
1686 | (setf (find-class name) class |
---|
1687 | (info-type-kind name) :instance) |
---|
1688 | class) |
---|
1689 | |
---|
1690 | ;;;Right now, all functions are compiled. |
---|
1691 | |
---|
1692 | |
---|
1693 | (defstatic *compiled-function-class* *function-class*) |
---|
1694 | (alias-class 'compiled-function *compiled-function-class*) |
---|
1695 | |
---|
1696 | (defstatic *compiled-lexical-closure-class* |
---|
1697 | (make-standard-class 'compiled-lexical-closure *function-class*)) |
---|
1698 | |
---|
1699 | |
---|
1700 | |
---|
1701 | |
---|
1702 | |
---|
1703 | (defstatic *funcallable-standard-class-class* |
---|
1704 | (make-standard-class 'funcallable-standard-class *std-class-class*)) |
---|
1705 | |
---|
1706 | (defstatic *funcallable-standard-object-class* |
---|
1707 | (make-class 'funcallable-standard-object |
---|
1708 | (%class.own-wrapper *funcallable-standard-class-class*) |
---|
1709 | (list *standard-object-class* *function-class*))) |
---|
1710 | |
---|
1711 | (defstatic *generic-function-class* |
---|
1712 | (make-class 'generic-function |
---|
1713 | (%class.own-wrapper *funcallable-standard-class-class*) |
---|
1714 | (list *metaobject-class* *funcallable-standard-object-class*))) |
---|
1715 | (setq *generic-function-class-wrapper* (%class.own-wrapper *generic-function-class*)) |
---|
1716 | |
---|
1717 | (defstatic *standard-generic-function-class* |
---|
1718 | (make-class 'standard-generic-function |
---|
1719 | (%class.own-wrapper *funcallable-standard-class-class*) |
---|
1720 | (list *generic-function-class*))) |
---|
1721 | (setq *standard-generic-function-class-wrapper* |
---|
1722 | (%class.own-wrapper *standard-generic-function-class*)) |
---|
1723 | |
---|
1724 | ;;; *standard-method-class* is upgraded to a real class below |
---|
1725 | (defstatic *method-class* (make-standard-class 'method *metaobject-class*)) |
---|
1726 | (defstatic *standard-method-class* (make-standard-class 'standard-method *method-class*)) |
---|
1727 | (defstatic *accessor-method-class* (make-standard-class 'standard-accessor-method *standard-method-class*)) |
---|
1728 | (defstatic *standard-reader-method-class* (make-standard-class 'standard-reader-method *accessor-method-class*)) |
---|
1729 | (defstatic *standard-writer-method-class* (make-standard-class 'standard-writer-method *accessor-method-class*)) |
---|
1730 | (defstatic *method-function-class* (make-standard-class 'method-function *function-class*)) |
---|
1731 | |
---|
1732 | |
---|
1733 | (defstatic *combined-method-class* (make-standard-class 'combined-method *function-class*)) |
---|
1734 | |
---|
1735 | (defstatic *slot-definition-class* (make-standard-class 'slot-definition *metaobject-class*)) |
---|
1736 | (defstatic direct-slot-definition-class (make-standard-class 'direct-slot-definition |
---|
1737 | *slot-definition-class*)) |
---|
1738 | (defstatic effective-slot-definition-class (make-standard-class 'effective-slot-definition |
---|
1739 | *slot-definition-class*)) |
---|
1740 | (defstatic *standard-slot-definition-class* (make-standard-class 'standard-slot-definition |
---|
1741 | *slot-definition-class*)) |
---|
1742 | (defstatic *standard-direct-slot-definition-class* (make-class |
---|
1743 | 'standard-direct-slot-definition |
---|
1744 | *standard-class-wrapper* |
---|
1745 | (list |
---|
1746 | *standard-slot-definition-class* |
---|
1747 | direct-slot-definition-class))) |
---|
1748 | |
---|
1749 | (defstatic *standard-effective-slot-definition-class* (make-class |
---|
1750 | 'standard-effective-slot-definition |
---|
1751 | *standard-class-wrapper* |
---|
1752 | (list |
---|
1753 | *standard-slot-definition-class* |
---|
1754 | effective-slot-definition-class) |
---|
1755 | )) |
---|
1756 | |
---|
1757 | (defstatic *standard-effective-slot-definition-class-wrapper* |
---|
1758 | (%class.own-wrapper *standard-effective-slot-definition-class*)) |
---|
1759 | |
---|
1760 | |
---|
1761 | |
---|
1762 | |
---|
1763 | |
---|
1764 | |
---|
1765 | |
---|
1766 | (let ((*dont-find-class-optimize* t) |
---|
1767 | (ordinal-type-class-alist ()) |
---|
1768 | (ordinal-type-class-alist-lock (make-lock))) |
---|
1769 | |
---|
1770 | (declare (optimize speed)) ;; make sure everything gets inlined that needs to be. |
---|
1771 | |
---|
1772 | ;; The built-in classes. |
---|
1773 | (defstatic *array-class* (make-built-in-class 'array)) |
---|
1774 | (defstatic *character-class* (make-built-in-class 'character)) |
---|
1775 | (make-built-in-class 'number) |
---|
1776 | (make-built-in-class 'sequence) |
---|
1777 | (defstatic *symbol-class* (make-built-in-class 'symbol)) |
---|
1778 | (defstatic *immediate-class* (make-built-in-class 'immediate)) ; Random immediate |
---|
1779 | ;; Random uvectors - these are NOT class of all things represented by a uvector |
---|
1780 | ;;type. Just random uvectors which don't fit anywhere else. |
---|
1781 | (make-built-in-class 'ivector) ; unknown ivector |
---|
1782 | (make-built-in-class 'gvector) ; unknown gvector |
---|
1783 | (defstatic *istruct-class* (make-built-in-class 'internal-structure)) ; unknown istruct |
---|
1784 | |
---|
1785 | (defstatic *slot-vector-class* (make-built-in-class 'slot-vector (find-class 'gvector))) |
---|
1786 | |
---|
1787 | (defstatic *macptr-class* (make-built-in-class 'macptr)) |
---|
1788 | (defstatic *foreign-standard-object-class* |
---|
1789 | (make-standard-class 'foreign-standard-object |
---|
1790 | *standard-object-class* *macptr-class*)) |
---|
1791 | |
---|
1792 | (defstatic *foreign-class-class* |
---|
1793 | (make-standard-class 'foreign-class *foreign-standard-object-class* *slots-class*)) |
---|
1794 | |
---|
1795 | (make-built-in-class 'population) |
---|
1796 | (make-built-in-class 'pool) |
---|
1797 | (make-built-in-class 'package) |
---|
1798 | (defstatic *lock-class* (make-built-in-class 'lock)) |
---|
1799 | (defstatic *recursive-lock-class* (make-built-in-class 'recursive-lock *lock-class*)) |
---|
1800 | (defstatic *read-write-lock-class* (make-built-in-class 'read-write-lock *lock-class*)) |
---|
1801 | |
---|
1802 | (make-istruct-class 'lock-acquisition *istruct-class*) |
---|
1803 | (make-istruct-class 'semaphore-notification *istruct-class*) |
---|
1804 | (make-istruct-class 'class-wrapper *istruct-class*) |
---|
1805 | ;; Compiler stuff, mostly |
---|
1806 | (make-istruct-class 'faslapi *istruct-class*) |
---|
1807 | (make-istruct-class 'faslstate *istruct-class*) |
---|
1808 | (make-istruct-class 'var *istruct-class*) |
---|
1809 | (make-istruct-class 'afunc *istruct-class*) |
---|
1810 | (make-istruct-class 'lexical-environment *istruct-class*) |
---|
1811 | (make-istruct-class 'definition-environment *istruct-class*) |
---|
1812 | (make-istruct-class 'compiler-policy *istruct-class*) |
---|
1813 | (make-istruct-class 'deferred-warnings *istruct-class*) |
---|
1814 | (make-istruct-class 'ptaskstate *istruct-class*) |
---|
1815 | (make-istruct-class 'entry *istruct-class*) |
---|
1816 | (make-istruct-class 'foreign-object-domain *istruct-class*) |
---|
1817 | |
---|
1818 | |
---|
1819 | (make-istruct-class 'slot-id *istruct-class*) |
---|
1820 | (make-built-in-class 'value-cell) |
---|
1821 | (make-istruct-class 'restart *istruct-class*) |
---|
1822 | (make-istruct-class 'hash-table *istruct-class*) |
---|
1823 | (make-istruct-class 'readtable *istruct-class*) |
---|
1824 | (make-istruct-class 'pathname *istruct-class*) |
---|
1825 | (make-istruct-class 'random-state *istruct-class*) |
---|
1826 | (make-istruct-class 'xp-structure *istruct-class*) |
---|
1827 | (make-istruct-class 'lisp-thread *istruct-class*) |
---|
1828 | (make-istruct-class 'resource *istruct-class*) |
---|
1829 | (make-istruct-class 'periodic-task *istruct-class*) |
---|
1830 | (make-istruct-class 'semaphore *istruct-class*) |
---|
1831 | |
---|
1832 | (make-istruct-class 'type-class *istruct-class*) |
---|
1833 | |
---|
1834 | (defstatic *ctype-class* (make-istruct-class 'ctype *istruct-class*)) |
---|
1835 | (make-istruct-class 'key-info *istruct-class*) |
---|
1836 | (defstatic *args-ctype* (make-istruct-class 'args-ctype *ctype-class*)) |
---|
1837 | (make-istruct-class 'values-ctype *args-ctype*) |
---|
1838 | (make-istruct-class 'function-ctype *args-ctype*) |
---|
1839 | (make-istruct-class 'constant-ctype *ctype-class*) |
---|
1840 | (make-istruct-class 'named-ctype *ctype-class*) |
---|
1841 | (make-istruct-class 'cons-ctype *ctype-class*) |
---|
1842 | (make-istruct-class 'unknown-ctype (make-istruct-class 'hairy-ctype *ctype-class*)) |
---|
1843 | (make-istruct-class 'numeric-ctype *ctype-class*) |
---|
1844 | (make-istruct-class 'array-ctype *ctype-class*) |
---|
1845 | (make-istruct-class 'member-ctype *ctype-class*) |
---|
1846 | (make-istruct-class 'union-ctype *ctype-class*) |
---|
1847 | (make-istruct-class 'foreign-ctype *ctype-class*) |
---|
1848 | (make-istruct-class 'class-ctype *ctype-class*) |
---|
1849 | (make-istruct-class 'negation-ctype *ctype-class*) |
---|
1850 | (make-istruct-class 'intersection-ctype *ctype-class*) |
---|
1851 | |
---|
1852 | (make-istruct-class 'class-cell *istruct-class*) |
---|
1853 | (make-istruct-class 'type-cell *istruct-class*) |
---|
1854 | (make-istruct-class 'package-ref *istruct-class*) |
---|
1855 | |
---|
1856 | (make-istruct-class 'foreign-variable *istruct-class*) |
---|
1857 | (make-istruct-class 'external-entry-point *istruct-class*) |
---|
1858 | (make-istruct-class 'shlib *istruct-class*) |
---|
1859 | |
---|
1860 | (make-built-in-class 'complex (find-class 'number)) |
---|
1861 | (make-built-in-class 'real (find-class 'number)) |
---|
1862 | (defstatic *float-class* (make-built-in-class 'float (find-class 'real))) |
---|
1863 | (defstatic *double-float-class* (make-built-in-class 'double-float (find-class 'float))) |
---|
1864 | (defstatic *single-float-class* (make-built-in-class 'single-float (find-class 'float))) |
---|
1865 | (alias-class 'short-float *single-float-class*) |
---|
1866 | (alias-class 'long-float *double-float-class*) |
---|
1867 | |
---|
1868 | (make-built-in-class 'rational (find-class 'real)) |
---|
1869 | (make-built-in-class 'ratio (find-class 'rational)) |
---|
1870 | (make-built-in-class 'integer (find-class 'rational)) |
---|
1871 | (defstatic *fixnum-class* (make-built-in-class 'fixnum (find-class 'integer))) |
---|
1872 | |
---|
1873 | #+x86-target |
---|
1874 | (defstatic *tagged-return-address-class* (make-built-in-class 'tagged-return-address)) |
---|
1875 | (make-built-in-class 'bignum (find-class 'integer)) |
---|
1876 | |
---|
1877 | (make-built-in-class 'bit *fixnum-class*) |
---|
1878 | (make-built-in-class 'unsigned-byte (find-class 'integer)) |
---|
1879 | (make-built-In-class 'signed-byte (find-class 'integer)) |
---|
1880 | |
---|
1881 | |
---|
1882 | (make-istruct-class 'logical-pathname (find-class 'pathname)) |
---|
1883 | |
---|
1884 | (make-istruct-class 'destructure-state *istruct-class*) |
---|
1885 | |
---|
1886 | (defstatic *base-char-class* (alias-class 'base-char *character-class*)) |
---|
1887 | (defstatic *standard-char-class* (make-built-in-class 'standard-char *base-char-class*)) |
---|
1888 | |
---|
1889 | (defstatic *keyword-class* (make-built-in-class 'keyword *symbol-class*)) |
---|
1890 | |
---|
1891 | (make-built-in-class 'list (find-class 'sequence)) |
---|
1892 | (defstatic *cons-class* (make-built-in-class 'cons (find-class 'list))) |
---|
1893 | (defstatic *null-class* (make-built-in-class 'null *symbol-class* (find-class 'list))) |
---|
1894 | |
---|
1895 | (defstatic *vector-class* (make-built-in-class 'vector *array-class* (find-class 'sequence))) |
---|
1896 | (defstatic *simple-array-class* (make-built-in-class 'simple-array *array-class*)) |
---|
1897 | (make-built-in-class 'simple-1d-array *vector-class* *simple-array-class*) |
---|
1898 | |
---|
1899 | ;;Maybe should do *float-array-class* etc? |
---|
1900 | ;;Also, should straighten out the simple-n-dim-array mess... |
---|
1901 | (make-built-in-class 'unsigned-byte-vector *vector-class*) |
---|
1902 | (make-built-in-class 'simple-unsigned-byte-vector (find-class 'unsigned-byte-vector) (find-class 'simple-1d-array)) |
---|
1903 | (make-built-in-class 'unsigned-word-vector *vector-class*) |
---|
1904 | (make-built-in-class 'simple-unsigned-word-vector (find-class 'unsigned-word-vector) (find-class 'simple-1d-array)) |
---|
1905 | (make-built-in-class 'fixnum-vector *vector-class*) |
---|
1906 | (make-built-in-class 'simple-fixnum-vector (find-class 'fixnum-vector) (find-class 'simple-1d-array)) |
---|
1907 | |
---|
1908 | |
---|
1909 | (progn |
---|
1910 | (make-built-in-class 'double-float-vector *vector-class*) |
---|
1911 | (make-built-in-class 'short-float-vector *vector-class*) |
---|
1912 | (alias-class 'long-float-vector (find-class 'double-float-vector)) |
---|
1913 | (alias-class 'single-float-vector (find-class 'short-float-vector)) |
---|
1914 | (make-built-in-class 'simple-double-float-vector (find-class 'double-float-vector) (find-class 'simple-1d-array)) |
---|
1915 | (make-built-in-class 'simple-short-float-vector (find-class 'short-float-vector) (find-class 'simple-1d-array)) |
---|
1916 | (alias-class 'simple-long-float-vector (find-class 'simple-double-float-vector)) |
---|
1917 | (alias-class 'simple-single-float-vector (find-class 'simple-short-float-vector)) |
---|
1918 | ) |
---|
1919 | |
---|
1920 | #+x8664-target |
---|
1921 | (progn |
---|
1922 | (make-built-in-class 'symbol-vector (find-class 'gvector)) |
---|
1923 | (make-built-in-class 'function-vector (find-class 'gvector))) |
---|
1924 | |
---|
1925 | #+64-bit-target |
---|
1926 | (progn |
---|
1927 | (make-built-in-class 'doubleword-vector *vector-class*) |
---|
1928 | (make-built-in-class 'simple-doubleword-vector (find-class 'doubleword-vector) (find-class 'simple-1d-array)) |
---|
1929 | (make-built-in-class 'unsigned-doubleword-vector *vector-class*) |
---|
1930 | (make-built-in-class 'simple-unsigned-doubleword-vector (find-class 'unsigned-doubleword-vector) (find-class 'simple-1d-array)) |
---|
1931 | ) ; #+64-bit-target |
---|
1932 | |
---|
1933 | (make-built-in-class 'long-vector *vector-class*) |
---|
1934 | (make-built-in-class 'simple-long-vector (find-class 'long-vector) (find-class 'simple-1d-array)) |
---|
1935 | (make-built-in-class 'unsigned-long-vector *vector-class*) |
---|
1936 | (make-built-in-class 'simple-unsigned-long-vector (find-class 'unsigned-long-vector) (find-class 'simple-1d-array)) |
---|
1937 | (make-built-in-class 'byte-vector *vector-class*) |
---|
1938 | (make-built-in-class 'simple-byte-vector (find-class 'byte-vector) (find-class 'simple-1d-array)) |
---|
1939 | (make-built-in-class 'bit-vector *vector-class*) |
---|
1940 | (make-built-in-class 'simple-bit-vector (find-class 'bit-vector) (find-class 'simple-1d-array)) |
---|
1941 | (make-built-in-class 'word-vector *vector-class*) |
---|
1942 | (make-built-in-class 'simple-word-vector (find-class 'word-vector) (find-class 'simple-1d-array)) |
---|
1943 | (make-built-in-class 'string *vector-class*) |
---|
1944 | (make-built-in-class 'base-string (find-class 'string)) |
---|
1945 | (make-built-in-class 'simple-string (find-class 'string) (find-class 'simple-1d-array)) |
---|
1946 | (make-built-in-class 'simple-base-string (find-class 'base-string) (find-class 'simple-string)) |
---|
1947 | (make-built-in-class 'general-vector *vector-class*) |
---|
1948 | (make-built-in-class 'simple-vector (find-class 'general-vector) (find-class 'simple-1d-array)) |
---|
1949 | |
---|
1950 | (make-built-in-class 'hash-table-vector) |
---|
1951 | (make-built-in-class 'catch-frame) |
---|
1952 | (make-built-in-class 'code-vector) |
---|
1953 | #+ppc32-target |
---|
1954 | (make-built-in-class 'creole-object) |
---|
1955 | |
---|
1956 | (make-built-in-class 'xfunction) |
---|
1957 | (make-built-in-class 'xcode-vector) |
---|
1958 | |
---|
1959 | (defun class-cell-find-class (class-cell errorp) |
---|
1960 | (unless (istruct-typep class-cell 'class-cell) |
---|
1961 | (setq class-cell (%kernel-restart $xwrongtype class-cell 'class-cell))) |
---|
1962 | (locally (declare (type class-cell class-cell)) |
---|
1963 | (let ((class (class-cell-class class-cell))) |
---|
1964 | (or class |
---|
1965 | (and |
---|
1966 | (setq class (find-class (class-cell-name class-cell) nil)) |
---|
1967 | (when class |
---|
1968 | (setf (class-cell-class class-cell) class) |
---|
1969 | class)) |
---|
1970 | (if errorp (error "Class ~s not found." (class-cell-name class-cell)) nil))))) |
---|
1971 | |
---|
1972 | ;;; (%wrapper-class (instance.class-wrapper frob)) |
---|
1973 | |
---|
1974 | |
---|
1975 | |
---|
1976 | (defstatic *general-vector-class* (find-class 'general-vector)) |
---|
1977 | |
---|
1978 | #+ppc32-target |
---|
1979 | (defparameter *ivector-vector-classes* |
---|
1980 | (vector (find-class 'short-float-vector) |
---|
1981 | (find-class 'unsigned-long-vector) |
---|
1982 | (find-class 'long-vector) |
---|
1983 | (find-class 'fixnum-vector) |
---|
1984 | (find-class 'base-string) |
---|
1985 | (find-class 'unsigned-byte-vector) |
---|
1986 | (find-class 'byte-vector) |
---|
1987 | *t-class* ; old base-string |
---|
1988 | (find-class 'unsigned-word-vector) |
---|
1989 | (find-class 'word-vector) |
---|
1990 | (find-class 'double-float-vector) |
---|
1991 | (find-class 'bit-vector))) |
---|
1992 | |
---|
1993 | #+ppc64-target |
---|
1994 | (defparameter *ivector-vector-classes* |
---|
1995 | (vector *t-class* |
---|
1996 | *t-class* |
---|
1997 | *t-class* |
---|
1998 | *t-class* |
---|
1999 | (find-class 'byte-vector) |
---|
2000 | (find-class 'word-vector) |
---|
2001 | (find-class 'long-vector) |
---|
2002 | (find-class 'doubleword-vector) |
---|
2003 | (find-class 'unsigned-byte-vector) |
---|
2004 | (find-class 'unsigned-word-vector) |
---|
2005 | (find-class 'unsigned-long-vector) |
---|
2006 | (find-class 'unsigned-doubleword-vector) |
---|
2007 | *t-class* |
---|
2008 | *t-class* |
---|
2009 | (find-class 'short-float-vector) |
---|
2010 | (find-class 'fixnum-vector) |
---|
2011 | *t-class* |
---|
2012 | *t-class* |
---|
2013 | *t-class* |
---|
2014 | (find-class 'double-float-vector) |
---|
2015 | (find-class 'base-string) |
---|
2016 | *t-class* |
---|
2017 | (find-class 'base-string) |
---|
2018 | *t-class* |
---|
2019 | *t-class* |
---|
2020 | *t-class* |
---|
2021 | *t-class* |
---|
2022 | *t-class* |
---|
2023 | *t-class* |
---|
2024 | (find-class 'bit-vector) |
---|
2025 | *t-class* |
---|
2026 | *t-class*)) |
---|
2027 | |
---|
2028 | #+x8632-target |
---|
2029 | (defparameter *ivector-vector-classes* |
---|
2030 | (vector (find-class 'short-float-vector) |
---|
2031 | (find-class 'unsigned-long-vector) |
---|
2032 | (find-class 'long-vector) |
---|
2033 | (find-class 'fixnum-vector) |
---|
2034 | (find-class 'base-string) |
---|
2035 | (find-class 'unsigned-byte-vector) |
---|
2036 | (find-class 'byte-vector) |
---|
2037 | *t-class* |
---|
2038 | (find-class 'unsigned-word-vector) |
---|
2039 | (find-class 'word-vector) |
---|
2040 | (find-class 'double-float-vector) |
---|
2041 | (find-class 'bit-vector))) |
---|
2042 | |
---|
2043 | #+x8664-target |
---|
2044 | (progn |
---|
2045 | (defparameter *immheader-0-classes* |
---|
2046 | (vector *t-class* |
---|
2047 | *t-class* |
---|
2048 | *t-class* |
---|
2049 | *t-class* |
---|
2050 | *t-class* |
---|
2051 | *t-class* |
---|
2052 | *t-class* |
---|
2053 | *t-class* |
---|
2054 | *t-class* |
---|
2055 | *t-class* |
---|
2056 | (find-class 'word-vector) |
---|
2057 | (find-class 'unsigned-word-vector) |
---|
2058 | (find-class 'base-string) ;old |
---|
2059 | (find-class 'byte-vector) |
---|
2060 | (find-class 'unsigned-byte-vector) |
---|
2061 | (find-class 'bit-vector))) |
---|
2062 | |
---|
2063 | (defparameter *immheader-1-classes* |
---|
2064 | (vector *t-class* |
---|
2065 | *t-class* |
---|
2066 | *t-class* |
---|
2067 | *t-class* |
---|
2068 | *t-class* |
---|
2069 | *t-class* |
---|
2070 | *t-class* |
---|
2071 | *t-class* |
---|
2072 | *t-class* |
---|
2073 | *t-class* |
---|
2074 | *t-class* |
---|
2075 | *t-class* |
---|
2076 | (find-class 'base-string) |
---|
2077 | (find-class 'long-vector) |
---|
2078 | (find-class 'unsigned-long-vector) |
---|
2079 | (find-class 'short-float-vector))) |
---|
2080 | |
---|
2081 | (defparameter *immheader-2-classes* |
---|
2082 | (vector *t-class* |
---|
2083 | *t-class* |
---|
2084 | *t-class* |
---|
2085 | *t-class* |
---|
2086 | *t-class* |
---|
2087 | *t-class* |
---|
2088 | *t-class* |
---|
2089 | *t-class* |
---|
2090 | *t-class* |
---|
2091 | *t-class* |
---|
2092 | *t-class* |
---|
2093 | *t-class* |
---|
2094 | (find-class 'fixnum-vector) |
---|
2095 | (find-class 'doubleword-vector) |
---|
2096 | (find-class 'unsigned-doubleword-vector) |
---|
2097 | (find-class 'double-float-vector)))) |
---|
2098 | |
---|
2099 | #+arm-target |
---|
2100 | (defparameter *ivector-vector-classes* |
---|
2101 | (vector (find-class 'short-float-vector) |
---|
2102 | (find-class 'unsigned-long-vector) |
---|
2103 | (find-class 'long-vector) |
---|
2104 | (find-class 'fixnum-vector) |
---|
2105 | (find-class 'base-string) |
---|
2106 | (find-class 'unsigned-byte-vector) |
---|
2107 | (find-class 'byte-vector) |
---|
2108 | *t-class* ; old base-string |
---|
2109 | (find-class 'unsigned-word-vector) |
---|
2110 | (find-class 'word-vector) |
---|
2111 | (find-class 'double-float-vector) |
---|
2112 | (find-class 'bit-vector))) |
---|
2113 | |
---|
2114 | |
---|
2115 | |
---|
2116 | |
---|
2117 | (defun make-foreign-object-domain (&key index name recognize class-of classp |
---|
2118 | instance-class-wrapper |
---|
2119 | class-own-wrapper |
---|
2120 | slots-vector class-ordinal |
---|
2121 | set-class-ordinal) |
---|
2122 | (%istruct 'foreign-object-domain index name recognize class-of classp |
---|
2123 | instance-class-wrapper class-own-wrapper slots-vector |
---|
2124 | class-ordinal set-class-ordinal)) |
---|
2125 | |
---|
2126 | (let* ((n-foreign-object-domains 0) |
---|
2127 | (foreign-object-domains (make-array 10)) |
---|
2128 | (foreign-object-domain-lock (make-lock))) |
---|
2129 | (defun register-foreign-object-domain (name |
---|
2130 | &key |
---|
2131 | recognize |
---|
2132 | class-of |
---|
2133 | classp |
---|
2134 | instance-class-wrapper |
---|
2135 | class-own-wrapper |
---|
2136 | slots-vector |
---|
2137 | class-ordinal |
---|
2138 | set-class-ordinal) |
---|
2139 | (with-lock-grabbed (foreign-object-domain-lock) |
---|
2140 | (dotimes (i n-foreign-object-domains) |
---|
2141 | (let* ((already (svref foreign-object-domains i))) |
---|
2142 | (when (eq name (foreign-object-domain-name already)) |
---|
2143 | (setf (foreign-object-domain-recognize already) recognize |
---|
2144 | (foreign-object-domain-class-of already) class-of |
---|
2145 | (foreign-object-domain-classp already) classp |
---|
2146 | (foreign-object-domain-instance-class-wrapper already) |
---|
2147 | instance-class-wrapper |
---|
2148 | (foreign-object-domain-class-own-wrapper already) |
---|
2149 | class-own-wrapper |
---|
2150 | (foreign-object-domain-slots-vector already) slots-vector |
---|
2151 | (foreign-object-domain-class-ordinal already) class-ordinal |
---|
2152 | (foreign-object-domain-set-class-ordinal already) |
---|
2153 | set-class-ordinal) |
---|
2154 | (return-from register-foreign-object-domain i)))) |
---|
2155 | (let* ((i n-foreign-object-domains) |
---|
2156 | (new (make-foreign-object-domain :index i |
---|
2157 | :name name |
---|
2158 | :recognize recognize |
---|
2159 | :class-of class-of |
---|
2160 | :classp classp |
---|
2161 | :instance-class-wrapper |
---|
2162 | instance-class-wrapper |
---|
2163 | :class-own-wrapper |
---|
2164 | class-own-wrapper |
---|
2165 | :slots-vector |
---|
2166 | slots-vector |
---|
2167 | :class-ordinal class-ordinal |
---|
2168 | :set-class-ordinal set-class-ordinal))) |
---|
2169 | (incf n-foreign-object-domains) |
---|
2170 | (if (= i (length foreign-object-domains)) |
---|
2171 | (setq foreign-object-domains (%extend-vector i foreign-object-domains (* i 2)))) |
---|
2172 | (setf (svref foreign-object-domains i) new) |
---|
2173 | i))) |
---|
2174 | (defun foreign-class-of (p) |
---|
2175 | (funcall (foreign-object-domain-class-of (svref foreign-object-domains (%macptr-domain p))) p)) |
---|
2176 | (defun foreign-classp (p) |
---|
2177 | (funcall (foreign-object-domain-classp (svref foreign-object-domains (%macptr-domain p))) p)) |
---|
2178 | (defun foreign-instance-class-wrapper (p) |
---|
2179 | (funcall (foreign-object-domain-instance-class-wrapper (svref foreign-object-domains (%macptr-domain p))) p)) |
---|
2180 | (defun foreign-class-own-wrapper (p) |
---|
2181 | (funcall (foreign-object-domain-class-own-wrapper (svref foreign-object-domains (%macptr-domain p))) p)) |
---|
2182 | (defun foreign-slots-vector (p) |
---|
2183 | (funcall (foreign-object-domain-slots-vector (svref foreign-object-domains (%macptr-domain p))) p)) |
---|
2184 | (defun foreign-class-ordinal (p) |
---|
2185 | (funcall (foreign-object-domain-class-ordinal (svref foreign-object-domains (%macptr-domain p))) p)) |
---|
2186 | (defun (setf foreign-class-ordinal) (new p) |
---|
2187 | (funcall (foreign-object-domain-set-class-ordinal (svref foreign-object-domains (%macptr-domain p))) p new)) |
---|
2188 | (defun classify-foreign-pointer (p) |
---|
2189 | (do* ((i (1- n-foreign-object-domains) (1- i))) |
---|
2190 | ((zerop i) (error "this can't happen")) |
---|
2191 | (when (funcall (foreign-object-domain-recognize (svref foreign-object-domains i)) p) |
---|
2192 | (%set-macptr-domain p i) |
---|
2193 | (return p))))) |
---|
2194 | |
---|
2195 | (defun constantly (x) |
---|
2196 | "Return a function that always returns VALUE." |
---|
2197 | #'(lambda (&rest ignore) |
---|
2198 | (declare (dynamic-extent ignore) |
---|
2199 | (ignore ignore)) |
---|
2200 | x)) |
---|
2201 | |
---|
2202 | (defun %register-type-ordinal-class (foreign-type class-name) |
---|
2203 | ;; ordinal-type-class shouldn't already exist |
---|
2204 | (with-lock-grabbed (ordinal-type-class-alist-lock) |
---|
2205 | (or (let* ((class (cdr (assq foreign-type ordinal-type-class-alist)))) |
---|
2206 | (if (and class (eq class-name (class-name class))) |
---|
2207 | class)) |
---|
2208 | (let* ((class (make-built-in-class class-name 'macptr))) |
---|
2209 | (push (cons foreign-type class) ordinal-type-class-alist) |
---|
2210 | class)))) |
---|
2211 | |
---|
2212 | (defun %ordinal-type-class-for-macptr (p) |
---|
2213 | (with-lock-grabbed (ordinal-type-class-alist-lock) |
---|
2214 | (or (unless (%null-ptr-p p) |
---|
2215 | (cdr (assoc (%macptr-type p) ordinal-type-class-alist :key #'foreign-type-ordinal))) |
---|
2216 | *macptr-class*))) |
---|
2217 | |
---|
2218 | |
---|
2219 | (register-foreign-object-domain :unclassified |
---|
2220 | :recognize #'(lambda (p) |
---|
2221 | (declare (ignore p)) |
---|
2222 | (error "Shouldn't happen")) |
---|
2223 | :class-of #'(lambda (p) |
---|
2224 | (foreign-class-of |
---|
2225 | (classify-foreign-pointer p))) |
---|
2226 | :classp #'(lambda (p) |
---|
2227 | (foreign-classp |
---|
2228 | (classify-foreign-pointer p))) |
---|
2229 | :instance-class-wrapper |
---|
2230 | #'(lambda (p) |
---|
2231 | (foreign-instance-class-wrapper |
---|
2232 | (classify-foreign-pointer p))) |
---|
2233 | :class-own-wrapper |
---|
2234 | #'(lambda (p) |
---|
2235 | (foreign-class-own-wrapper |
---|
2236 | (classify-foreign-pointer p))) |
---|
2237 | :slots-vector |
---|
2238 | #'(lambda (p) |
---|
2239 | (foreign-slots-vector |
---|
2240 | (classify-foreign-pointer p)))) |
---|
2241 | |
---|
2242 | ;;; "Raw" macptrs, that aren't recognized as "standard foreign objects" |
---|
2243 | ;;; in some other domain, should always be recognized as such (and this |
---|
2244 | ;;; pretty much has to be domain #1.) |
---|
2245 | |
---|
2246 | (register-foreign-object-domain :raw |
---|
2247 | :recognize #'true |
---|
2248 | :class-of #'%ordinal-type-class-for-macptr |
---|
2249 | :classp #'false |
---|
2250 | :instance-class-wrapper |
---|
2251 | (lambda (p) |
---|
2252 | (%class.own-wrapper (%ordinal-type-class-for-macptr p))) |
---|
2253 | :class-own-wrapper #'false |
---|
2254 | :slots-vector #'false) |
---|
2255 | |
---|
2256 | (defstatic *class-table* |
---|
2257 | (let* ((v (make-array 256 :initial-element nil)) |
---|
2258 | (class-of-function-function |
---|
2259 | #'(lambda (thing) |
---|
2260 | (let ((bits (lfun-bits-known-function thing))) |
---|
2261 | (declare (fixnum bits)) |
---|
2262 | (if (logbitp $lfbits-trampoline-bit bits) |
---|
2263 | ;; closure |
---|
2264 | (let ((inner-fn (closure-function thing))) |
---|
2265 | (if (neq inner-fn thing) |
---|
2266 | (let ((inner-bits (lfun-bits inner-fn))) |
---|
2267 | (if (logbitp $lfbits-method-bit inner-bits) |
---|
2268 | *compiled-lexical-closure-class* |
---|
2269 | (if (logbitp $lfbits-gfn-bit inner-bits) |
---|
2270 | (%wrapper-class (gf.instance.class-wrapper thing)) |
---|
2271 | (if (logbitp $lfbits-cm-bit inner-bits) |
---|
2272 | *combined-method-class* |
---|
2273 | *compiled-lexical-closure-class*)))) |
---|
2274 | *compiled-lexical-closure-class*)) |
---|
2275 | (if (logbitp $lfbits-method-bit bits) |
---|
2276 | *method-function-class* |
---|
2277 | (if (logbitp $lfbits-gfn-bit bits) |
---|
2278 | (%wrapper-class (gf.instance.class-wrapper thing)) |
---|
2279 | (if (logbitp $lfbits-cm-bit bits) |
---|
2280 | *combined-method-class* |
---|
2281 | *compiled-function-class*)))))))) |
---|
2282 | ;; Make one loop through the vector, initializing fixnum & list |
---|
2283 | ;; cells. Set all immediates to *immediate-class*, then |
---|
2284 | ;; special-case characters later. |
---|
2285 | #+ppc32-target |
---|
2286 | (do* ((slice 0 (+ 8 slice))) |
---|
2287 | ((= slice 256)) |
---|
2288 | (declare (type (unsigned-byte 8) slice)) |
---|
2289 | (setf (%svref v (+ slice ppc32::fulltag-even-fixnum)) *fixnum-class* |
---|
2290 | (%svref v (+ slice ppc32::fulltag-odd-fixnum)) *fixnum-class* |
---|
2291 | (%svref v (+ slice ppc32::fulltag-cons)) *cons-class* |
---|
2292 | (%svref v (+ slice ppc32::fulltag-nil)) *null-class* |
---|
2293 | (%svref v (+ slice ppc32::fulltag-imm)) *immediate-class*)) |
---|
2294 | #+ppc64-target |
---|
2295 | (do* ((slice 0 (+ 16 slice))) |
---|
2296 | ((= slice 256)) |
---|
2297 | (declare (type (unsigned-byte 8) slice)) |
---|
2298 | (setf (%svref v (+ slice ppc64::fulltag-even-fixnum)) *fixnum-class* |
---|
2299 | (%svref v (+ slice ppc64::fulltag-odd-fixnum)) *fixnum-class* |
---|
2300 | (%svref v (+ slice ppc64::fulltag-cons)) *cons-class* |
---|
2301 | (%svref v (+ slice ppc64::fulltag-imm-0)) *immediate-class* |
---|
2302 | (%svref v (+ slice ppc64::fulltag-imm-1)) *immediate-class* |
---|
2303 | (%svref v (+ slice ppc64::fulltag-imm-2)) *immediate-class* |
---|
2304 | (%svref v (+ slice ppc64::fulltag-imm-3)) *immediate-class*)) |
---|
2305 | #+x8632-target |
---|
2306 | (do* ((slice 0 (+ 8 slice)) |
---|
2307 | (cons-fn #'(lambda (x) (if (null x) *null-class* *cons-class*)))) |
---|
2308 | ((= slice 256)) |
---|
2309 | (declare (type (unsigned-byte 8) slice)) |
---|
2310 | (setf (%svref v (+ slice x8632::fulltag-even-fixnum)) *fixnum-class* |
---|
2311 | (%svref v (+ slice x8632::fulltag-odd-fixnum)) *fixnum-class* |
---|
2312 | (%svref v (+ slice x8632::fulltag-cons)) cons-fn |
---|
2313 | (%svref v (+ slice x8632::fulltag-tra)) *tagged-return-address-class* |
---|
2314 | (%svref v (+ slice x8632::fulltag-imm)) *immediate-class*)) |
---|
2315 | #+x8664-target |
---|
2316 | (do* ((slice 0 (+ 16 slice))) |
---|
2317 | ((= slice 256)) |
---|
2318 | (declare (type (unsigned-byte 8) slice)) |
---|
2319 | (setf (%svref v (+ slice x8664::fulltag-even-fixnum)) *fixnum-class* |
---|
2320 | (%svref v (+ slice x8664::fulltag-odd-fixnum)) *fixnum-class* |
---|
2321 | (%svref v (+ slice x8664::fulltag-cons)) *cons-class* |
---|
2322 | (%svref v (+ slice x8664::fulltag-imm-0)) *immediate-class* |
---|
2323 | (%svref v (+ slice x8664::fulltag-imm-1)) *immediate-class* |
---|
2324 | (%svref v (+ slice x8664::fulltag-tra-0)) *tagged-return-address-class* |
---|
2325 | (%svref v (+ slice x8664::fulltag-tra-1)) *tagged-return-address-class* |
---|
2326 | (%svref v (+ slice x8664::fulltag-nil)) *null-class*)) |
---|
2327 | #+arm-target |
---|
2328 | (do* ((slice 0 (+ 8 slice))) |
---|
2329 | ((= slice 256)) |
---|
2330 | (declare (type (unsigned-byte 8) slice)) |
---|
2331 | (setf (%svref v (+ slice arm::fulltag-even-fixnum)) *fixnum-class* |
---|
2332 | (%svref v (+ slice arm::fulltag-odd-fixnum)) *fixnum-class* |
---|
2333 | (%svref v (+ slice arm::fulltag-cons)) *cons-class* |
---|
2334 | (%svref v (+ slice arm::fulltag-nil)) *null-class* |
---|
2335 | (%svref v (+ slice arm::fulltag-imm)) *immediate-class*)) |
---|
2336 | |
---|
2337 | (macrolet ((map-subtag (subtag class-name) |
---|
2338 | `(setf (%svref v ,subtag) (find-class ',class-name)))) |
---|
2339 | ;; immheader types map to built-in classes. |
---|
2340 | (map-subtag target::subtag-bignum bignum) |
---|
2341 | (map-subtag target::subtag-double-float double-float) |
---|
2342 | (map-subtag target::subtag-single-float short-float) |
---|
2343 | (map-subtag target::subtag-dead-macptr ivector) |
---|
2344 | #+ppc32-target |
---|
2345 | (map-subtag ppc32::subtag-code-vector code-vector) |
---|
2346 | #+ppc64-target |
---|
2347 | (map-subtag ppc64::subtag-code-vector code-vector) |
---|
2348 | #+arm-target |
---|
2349 | (map-subtag arm::subtag-code-vector code-vector) |
---|
2350 | #+ppc32-target |
---|
2351 | (map-subtag ppc32::subtag-creole-object creole-object) |
---|
2352 | (map-subtag target::subtag-xcode-vector xcode-vector) |
---|
2353 | (map-subtag target::subtag-xfunction xfunction) |
---|
2354 | #+arm-target |
---|
2355 | (map-subtag arm::subtag-pseudofunction pseudofunction) |
---|
2356 | (map-subtag target::subtag-single-float-vector simple-short-float-vector) |
---|
2357 | #+64-bit-target |
---|
2358 | (map-subtag target::subtag-u64-vector simple-unsigned-doubleword-vector) |
---|
2359 | #+64-bit-target |
---|
2360 | (map-subtag target::subtag-s64-vector simple-doubleword-vector) |
---|
2361 | (map-subtag target::subtag-fixnum-vector simple-fixnum-vector) |
---|
2362 | (map-subtag target::subtag-u32-vector simple-unsigned-long-vector) |
---|
2363 | (map-subtag target::subtag-s32-vector simple-long-vector) |
---|
2364 | (map-subtag target::subtag-u8-vector simple-unsigned-byte-vector) |
---|
2365 | (map-subtag target::subtag-s8-vector simple-byte-vector) |
---|
2366 | (map-subtag target::subtag-simple-base-string simple-base-string) |
---|
2367 | (map-subtag target::subtag-u16-vector simple-unsigned-word-vector) |
---|
2368 | (map-subtag target::subtag-s16-vector simple-word-vector) |
---|
2369 | (map-subtag target::subtag-double-float-vector simple-double-float-vector) |
---|
2370 | (map-subtag target::subtag-bit-vector simple-bit-vector) |
---|
2371 | ;; Some nodeheader types map to built-in-classes; others require |
---|
2372 | ;; further dispatching. |
---|
2373 | (map-subtag target::subtag-ratio ratio) |
---|
2374 | (map-subtag target::subtag-complex complex) |
---|
2375 | (map-subtag target::subtag-catch-frame catch-frame) |
---|
2376 | (map-subtag target::subtag-hash-vector hash-table-vector) |
---|
2377 | (map-subtag target::subtag-value-cell value-cell) |
---|
2378 | (map-subtag target::subtag-pool pool) |
---|
2379 | (map-subtag target::subtag-weak population) |
---|
2380 | (map-subtag target::subtag-package package) |
---|
2381 | (map-subtag target::subtag-simple-vector simple-vector) |
---|
2382 | (map-subtag target::subtag-slot-vector slot-vector) |
---|
2383 | #+x8664-target (map-subtag x8664::subtag-symbol symbol-vector) |
---|
2384 | #+x8664-target (map-subtag x8664::subtag-function function-vector)) |
---|
2385 | (setf (%svref v target::subtag-arrayH) |
---|
2386 | #'(lambda (x) |
---|
2387 | (if (logbitp $arh_simple_bit |
---|
2388 | (the fixnum (%svref x target::arrayH.flags-cell))) |
---|
2389 | *simple-array-class* |
---|
2390 | *array-class*))) |
---|
2391 | ;; These need to be special-cased: |
---|
2392 | (setf (%svref v target::subtag-macptr) #'foreign-class-of) |
---|
2393 | (setf (%svref v target::subtag-character) |
---|
2394 | #'(lambda (c) (let* ((code (%char-code c))) |
---|
2395 | (if (or (eq c #\NewLine) |
---|
2396 | (and (>= code (char-code #\space)) |
---|
2397 | (< code (char-code #\rubout)))) |
---|
2398 | *standard-char-class* |
---|
2399 | *base-char-class*)))) |
---|
2400 | (setf (%svref v target::subtag-struct) |
---|
2401 | #'(lambda (s) (%structure-class-of s))) ; need DEFSTRUCT |
---|
2402 | (setf (%svref v target::subtag-istruct) |
---|
2403 | #'(lambda (i) |
---|
2404 | (let* ((cell (%svref i 0)) |
---|
2405 | (wrapper (istruct-cell-info cell))) |
---|
2406 | (if wrapper |
---|
2407 | (%wrapper-class wrapper) |
---|
2408 | (or (find-class (istruct-cell-name cell) nil) |
---|
2409 | *istruct-class*))))) |
---|
2410 | (setf (%svref v target::subtag-basic-stream) |
---|
2411 | #'(lambda (b) (%wrapper-class (basic-stream.wrapper b)))) |
---|
2412 | (setf (%svref v target::subtag-instance) |
---|
2413 | #'%class-of-instance) |
---|
2414 | (setf (%svref v #+ppc-target target::subtag-symbol |
---|
2415 | #+arm-target target::subtag-symbol |
---|
2416 | #+x8632-target target::subtag-symbol |
---|
2417 | #+x8664-target target::tag-symbol) |
---|
2418 | #-ppc64-target |
---|
2419 | #'(lambda (s) (if (eq (symbol-package s) *keyword-package*) |
---|
2420 | *keyword-class* |
---|
2421 | *symbol-class*)) |
---|
2422 | #+ppc64-target |
---|
2423 | #'(lambda (s) |
---|
2424 | (if s |
---|
2425 | (if (eq (symbol-package s) *keyword-package*) |
---|
2426 | *keyword-class* |
---|
2427 | *symbol-class*) |
---|
2428 | *null-class*))) |
---|
2429 | |
---|
2430 | (setf (%svref v |
---|
2431 | #+ppc-target target::subtag-function |
---|
2432 | #+arm-target target::subtag-function |
---|
2433 | #+x8632-target target::subtag-function |
---|
2434 | #+x8664-target target::tag-function) |
---|
2435 | class-of-function-function) |
---|
2436 | (setf (%svref v target::subtag-vectorH) |
---|
2437 | #'(lambda (v) |
---|
2438 | (let* ((subtype (%array-header-subtype v))) |
---|
2439 | (declare (fixnum subtype)) |
---|
2440 | (if (eql subtype target::subtag-simple-vector) |
---|
2441 | *general-vector-class* |
---|
2442 | #-x8664-target |
---|
2443 | (%svref *ivector-vector-classes* |
---|
2444 | #+ppc32-target |
---|
2445 | (ash (the fixnum (- subtype ppc32::min-cl-ivector-subtag)) |
---|
2446 | (- ppc32::ntagbits)) |
---|
2447 | #+arm-target |
---|
2448 | (ash (the fixnum (- subtype arm::min-cl-ivector-subtag)) |
---|
2449 | (- arm::ntagbits)) |
---|
2450 | #+ppc64-target |
---|
2451 | (ash (the fixnum (logand subtype #x7f)) (- ppc64::nlowtagbits)) |
---|
2452 | #+x8632-target |
---|
2453 | (ash (the fixnum (- subtype x8632::min-cl-ivector-subtag)) |
---|
2454 | (- x8632::ntagbits))) |
---|
2455 | #+x8664-target |
---|
2456 | (let* ((class (logand x8664::fulltagmask subtype)) |
---|
2457 | (idx (ash subtype (- x8664::ntagbits)))) |
---|
2458 | (cond ((= class x8664::fulltag-immheader-0) |
---|
2459 | (%svref *immheader-0-classes* idx)) |
---|
2460 | ((= class x8664::fulltag-immheader-1) |
---|
2461 | (%svref *immheader-1-classes* idx)) |
---|
2462 | ((= class x8664::fulltag-immheader-2) |
---|
2463 | (%svref *immheader-2-classes* idx)) |
---|
2464 | (t *t-class*))) |
---|
2465 | |
---|
2466 | )))) |
---|
2467 | (setf (%svref v target::subtag-lock) |
---|
2468 | #'(lambda (thing) |
---|
2469 | (case (%svref thing target::lock.kind-cell) |
---|
2470 | (recursive-lock *recursive-lock-class*) |
---|
2471 | (read-write-lock *read-write-lock-class*) |
---|
2472 | (t *lock-class*)))) |
---|
2473 | v)) |
---|
2474 | |
---|
2475 | |
---|
2476 | |
---|
2477 | |
---|
2478 | |
---|
2479 | (defun no-class-error (x) |
---|
2480 | (error "Bug (probably): can't determine class of ~s" x)) |
---|
2481 | |
---|
2482 | |
---|
2483 | ; return frob from table |
---|
2484 | |
---|
2485 | |
---|
2486 | |
---|
2487 | |
---|
2488 | ) ; end let |
---|
2489 | |
---|
2490 | |
---|
2491 | |
---|
2492 | (defun classp (x) |
---|
2493 | (if (%standard-instance-p x) |
---|
2494 | (< (the fixnum (instance.hash x)) max-class-ordinal) |
---|
2495 | (and (typep x 'macptr) (foreign-classp x)))) |
---|
2496 | |
---|
2497 | (set-type-predicate 'class 'classp) |
---|
2498 | |
---|
2499 | (defun subclassp (c1 c2) |
---|
2500 | (and (classp c1) |
---|
2501 | (classp c2) |
---|
2502 | (not (null (memq c2 (%inited-class-cpl c1 t)))))) |
---|
2503 | |
---|
2504 | (defun %class-get (class indicator &optional default) |
---|
2505 | (let ((cell (assq indicator (%class-alist class)))) |
---|
2506 | (if cell (cdr cell) default))) |
---|
2507 | |
---|
2508 | (defun %class-put (class indicator value) |
---|
2509 | (let ((cell (assq indicator (%class-alist class)))) |
---|
2510 | (if cell |
---|
2511 | (setf (cdr cell) value) |
---|
2512 | (push (cons indicator value) (%class-alist class)))) |
---|
2513 | value) |
---|
2514 | |
---|
2515 | (defsetf %class-get %class-put) |
---|
2516 | |
---|
2517 | (defun %class-remprop (class indicator) |
---|
2518 | (let* ((handle (cons nil (%class-alist class))) |
---|
2519 | (last handle)) |
---|
2520 | (declare (dynamic-extent handle)) |
---|
2521 | (while (cdr last) |
---|
2522 | (if (eq indicator (caar (%cdr last))) |
---|
2523 | (progn |
---|
2524 | (setf (%cdr last) (%cddr last)) |
---|
2525 | (setf (%class-alist class) (%cdr handle))) |
---|
2526 | (setf last (%cdr last)))))) |
---|
2527 | |
---|
2528 | |
---|
2529 | (pushnew :primary-classes *features*) |
---|
2530 | |
---|
2531 | (defun %class-primary-p (class) |
---|
2532 | (if (typep class 'slots-class) |
---|
2533 | (%class-get class :primary-p) |
---|
2534 | t)) |
---|
2535 | |
---|
2536 | (defun (setf %class-primary-p) (value class) |
---|
2537 | (if value |
---|
2538 | (setf (%class-get class :primary-p) value) |
---|
2539 | (progn |
---|
2540 | (%class-remprop class :primary-p) |
---|
2541 | nil))) |
---|
2542 | |
---|
2543 | ;;; Returns the first element of the CPL that is primary |
---|
2544 | (defun %class-or-superclass-primary-p (class) |
---|
2545 | (unless (class-has-a-forward-referenced-superclass-p class) |
---|
2546 | (dolist (super (%inited-class-cpl class t)) |
---|
2547 | (when (and (typep super 'standard-class) (%class-primary-p super)) |
---|
2548 | (return super))))) |
---|
2549 | |
---|
2550 | |
---|
2551 | ;;; Bootstrapping version of union |
---|
2552 | (unless (fboundp 'union) |
---|
2553 | (fset 'union (nlambda bootstrapping-union (l1 l2) |
---|
2554 | (dolist (e l1) |
---|
2555 | (unless (memq e l2) |
---|
2556 | (push e l2))) |
---|
2557 | l2)) |
---|
2558 | ) |
---|
2559 | |
---|
2560 | (defun %add-direct-methods (method) |
---|
2561 | (dolist (spec (%method-specializers method)) |
---|
2562 | (%do-add-direct-method spec method))) |
---|
2563 | |
---|
2564 | (defun %do-add-direct-method (spec method) |
---|
2565 | (pushnew method (specializer.direct-methods spec))) |
---|
2566 | |
---|
2567 | (defun %remove-direct-methods (method) |
---|
2568 | (dolist (spec (%method-specializers method)) |
---|
2569 | (%do-remove-direct-method spec method))) |
---|
2570 | |
---|
2571 | (defun %do-remove-direct-method (spec method) |
---|
2572 | (setf (specializer.direct-methods spec) |
---|
2573 | (nremove method (specializer.direct-methods spec)))) |
---|
2574 | |
---|
2575 | (ensure-generic-function 'initialize-instance |
---|
2576 | :lambda-list '(instance &rest initargs &key &allow-other-keys)) |
---|
2577 | |
---|
2578 | (defmethod find-method ((generic-function standard-generic-function) |
---|
2579 | method-qualifiers specializers &optional (errorp t)) |
---|
2580 | (dolist (m (%gf-methods generic-function) |
---|
2581 | (when errorp |
---|
2582 | (cerror "Try finding the method again" |
---|
2583 | "~s has no method for ~s ~s" |
---|
2584 | generic-function method-qualifiers specializers) |
---|
2585 | (find-method generic-function method-qualifiers specializers |
---|
2586 | errorp))) |
---|
2587 | (flet ((err () |
---|
2588 | (error "Wrong number of specializers: ~s" specializers))) |
---|
2589 | (let ((ss (%method-specializers m)) |
---|
2590 | (q (%method-qualifiers m)) |
---|
2591 | s) |
---|
2592 | (when (equal q method-qualifiers) |
---|
2593 | (dolist (spec (canonicalize-specializers specializers nil) |
---|
2594 | (if (null ss) |
---|
2595 | (return-from find-method m) |
---|
2596 | (err))) |
---|
2597 | (unless (setq s (pop ss)) |
---|
2598 | (err)) |
---|
2599 | (unless (eq s spec) |
---|
2600 | (return)))))))) |
---|
2601 | |
---|
2602 | (defmethod create-reader-method-function ((class slots-class) |
---|
2603 | (reader-method-class standard-reader-method) |
---|
2604 | (dslotd direct-slot-definition)) |
---|
2605 | #+ppc-target |
---|
2606 | (gvector :function |
---|
2607 | (uvref *reader-method-function-proto* 0) |
---|
2608 | (ensure-slot-id (%slot-definition-name dslotd)) |
---|
2609 | 'slot-id-value |
---|
2610 | nil ;method-function name |
---|
2611 | (dpb 1 $lfbits-numreq (ash 1 $lfbits-method-bit))) |
---|
2612 | #+x86-target |
---|
2613 | (%clone-x86-function |
---|
2614 | *reader-method-function-proto* |
---|
2615 | (ensure-slot-id (%slot-definition-name dslotd)) |
---|
2616 | 'slot-id-value |
---|
2617 | nil ;method-function name |
---|
2618 | (dpb 1 $lfbits-numreq (ash 1 $lfbits-method-bit))) |
---|
2619 | #+arm-target |
---|
2620 | (%fix-fn-entrypoint |
---|
2621 | (gvector :function |
---|
2622 | 0 |
---|
2623 | (uvref *reader-method-function-proto* 1) |
---|
2624 | (ensure-slot-id (%slot-definition-name dslotd)) |
---|
2625 | 'slot-id-value |
---|
2626 | nil ;method-function name |
---|
2627 | (dpb 1 $lfbits-numreq (ash 1 $lfbits-method-bit)))) |
---|
2628 | ) |
---|
2629 | |
---|
2630 | (defmethod create-writer-method-function ((class slots-class) |
---|
2631 | (writer-method-class standard-writer-method) |
---|
2632 | (dslotd direct-slot-definition)) |
---|
2633 | #+ppc-target |
---|
2634 | (gvector :function |
---|
2635 | (uvref *writer-method-function-proto* 0) |
---|
2636 | (ensure-slot-id (%slot-definition-name dslotd)) |
---|
2637 | 'set-slot-id-value |
---|
2638 | nil |
---|
2639 | (dpb 2 $lfbits-numreq (ash 1 $lfbits-method-bit))) |
---|
2640 | #+x86-target |
---|
2641 | (%clone-x86-function |
---|
2642 | *writer-method-function-proto* |
---|
2643 | (ensure-slot-id (%slot-definition-name dslotd)) |
---|
2644 | 'set-slot-id-value |
---|
2645 | nil |
---|
2646 | (dpb 2 $lfbits-numreq (ash 1 $lfbits-method-bit))) |
---|
2647 | #+arm-target |
---|
2648 | (%fix-fn-entrypoint |
---|
2649 | (gvector :function |
---|
2650 | 0 |
---|
2651 | (uvref *writer-method-function-proto* 1) |
---|
2652 | (ensure-slot-id (%slot-definition-name dslotd)) |
---|
2653 | 'set-slot-id-value |
---|
2654 | nil |
---|
2655 | (dpb 2 $lfbits-numreq (ash 1 $lfbits-method-bit)))) |
---|
2656 | ) |
---|
2657 | |
---|
2658 | |
---|
2659 | |
---|
2660 | |
---|
2661 | |
---|
2662 | |
---|
2663 | (defun %make-instance (class-cell &rest initargs) |
---|
2664 | (declare (dynamic-extent initargs)) |
---|
2665 | (declare (optimize speed)) ;; make sure everything gets inlined that needs to be. |
---|
2666 | (apply #'make-instance |
---|
2667 | (or (class-cell-class class-cell) (class-cell-name (the class-cell class-cell))) |
---|
2668 | initargs)) |
---|
2669 | |
---|
2670 | |
---|
2671 | (defmethod make-instance ((class symbol) &rest initargs) |
---|
2672 | (declare (dynamic-extent initargs)) |
---|
2673 | (apply 'make-instance (find-class class) initargs)) |
---|
2674 | |
---|
2675 | |
---|
2676 | (defmethod make-instance ((class standard-class) &rest initargs &key &allow-other-keys) |
---|
2677 | (declare (dynamic-extent initargs)) |
---|
2678 | (%make-std-instance class initargs)) |
---|
2679 | |
---|
2680 | (defmethod make-instance ((class std-class) &rest initargs &key &allow-other-keys) |
---|
2681 | (declare (dynamic-extent initargs)) |
---|
2682 | (%make-std-instance class initargs)) |
---|
2683 | |
---|
2684 | |
---|
2685 | (defun %make-std-instance (class initargs) |
---|
2686 | (setq initargs (default-initargs class initargs)) |
---|
2687 | (when initargs |
---|
2688 | (apply #'check-initargs |
---|
2689 | nil class initargs t |
---|
2690 | #'initialize-instance #'allocate-instance #'shared-initialize |
---|
2691 | nil)) |
---|
2692 | (let ((instance (apply #'allocate-instance class initargs))) |
---|
2693 | (apply #'initialize-instance instance initargs) |
---|
2694 | instance)) |
---|
2695 | |
---|
2696 | (defun default-initargs (class initargs) |
---|
2697 | (unless (std-class-p class) |
---|
2698 | (setq class (require-type class 'std-class))) |
---|
2699 | (when (null (%class.cpl class)) (update-class class t)) |
---|
2700 | (let ((defaults ())) |
---|
2701 | (dolist (key.form (%class-default-initargs class)) |
---|
2702 | (unless (pl-search initargs (%car key.form)) |
---|
2703 | (setq defaults |
---|
2704 | (list* (funcall (caddr key.form)) |
---|
2705 | (%car key.form) |
---|
2706 | defaults)))) |
---|
2707 | (when defaults |
---|
2708 | (setq initargs (append initargs (nreverse defaults)))) |
---|
2709 | initargs)) |
---|
2710 | |
---|
2711 | |
---|
2712 | (defun %allocate-std-instance (class) |
---|
2713 | (unless (class-finalized-p class) |
---|
2714 | (finalize-inheritance class)) |
---|
2715 | (let* ((wrapper (%class.own-wrapper class)) |
---|
2716 | (len (length (%wrapper-instance-slots wrapper)))) |
---|
2717 | (declare (fixnum len)) |
---|
2718 | (make-instance-vector wrapper len))) |
---|
2719 | |
---|
2720 | |
---|
2721 | |
---|
2722 | |
---|
2723 | (defmethod copy-instance ((instance standard-object)) |
---|
2724 | (let* ((new-slots (copy-uvector (instance.slots instance))) |
---|
2725 | (copy (gvector :instance 0 (instance-class-wrapper instance) new-slots))) |
---|
2726 | (setf (instance.hash copy) (strip-tag-to-fixnum copy) |
---|
2727 | (slot-vector.instance new-slots) copy))) |
---|
2728 | |
---|
2729 | (defmethod initialize-instance ((instance standard-object) &rest initargs) |
---|
2730 | (declare (dynamic-extent initargs)) |
---|
2731 | (apply 'shared-initialize instance t initargs)) |
---|
2732 | |
---|
2733 | |
---|
2734 | (defmethod reinitialize-instance ((instance standard-object) &rest initargs) |
---|
2735 | (declare (dynamic-extent initargs)) |
---|
2736 | (when initargs |
---|
2737 | (check-initargs |
---|
2738 | instance nil initargs t #'reinitialize-instance #'shared-initialize)) |
---|
2739 | (apply 'shared-initialize instance nil initargs)) |
---|
2740 | |
---|
2741 | (defmethod shared-initialize ((instance standard-object) slot-names &rest initargs) |
---|
2742 | (declare (dynamic-extent initargs)) |
---|
2743 | (%shared-initialize instance slot-names initargs)) |
---|
2744 | |
---|
2745 | (defmethod shared-initialize ((instance standard-generic-function) slot-names |
---|
2746 | &rest initargs) |
---|
2747 | (declare (dynamic-extent initargs)) |
---|
2748 | (%shared-initialize instance slot-names initargs)) |
---|
2749 | |
---|
2750 | |
---|
2751 | ;;; Slot-value, slot-boundp, slot-makunbound, etc. |
---|
2752 | (declaim (inline find-slotd)) |
---|
2753 | (defun find-slotd (name slots) |
---|
2754 | (dolist (slotd slots) |
---|
2755 | (when (eq name (standard-slot-definition.name slotd)) |
---|
2756 | (return slotd)))) |
---|
2757 | |
---|
2758 | (declaim (inline %std-slot-vector-value)) |
---|
2759 | |
---|
2760 | (defun %std-slot-vector-value (slot-vector slotd) |
---|
2761 | (let* ((loc (standard-effective-slot-definition.location slotd))) |
---|
2762 | (symbol-macrolet ((instance (slot-vector.instance slot-vector))) |
---|
2763 | (typecase loc |
---|
2764 | (fixnum |
---|
2765 | (%slot-ref slot-vector loc)) |
---|
2766 | (cons |
---|
2767 | (let* ((val (%cdr loc))) |
---|
2768 | (if (eq val (%slot-unbound-marker)) |
---|
2769 | (slot-unbound (class-of instance) instance (standard-effective-slot-definition.name slotd)) |
---|
2770 | val))) |
---|
2771 | (t |
---|
2772 | (error "Slot definition ~s has invalid location ~s (allocation ~s)." |
---|
2773 | slotd loc (slot-definition-allocation slotd))))))) |
---|
2774 | |
---|
2775 | |
---|
2776 | (defmethod slot-value-using-class ((class standard-class) |
---|
2777 | instance |
---|
2778 | (slotd standard-effective-slot-definition)) |
---|
2779 | (ecase (standard-slot-definition.allocation slotd) |
---|
2780 | ((:instance :class) |
---|
2781 | (%std-slot-vector-value (instance-slots instance) slotd)))) |
---|
2782 | |
---|
2783 | (defun %maybe-std-slot-value-using-class (class instance slotd) |
---|
2784 | (if (and (eql (typecode class) target::subtag-instance) |
---|
2785 | (eql (typecode slotd) target::subtag-instance) |
---|
2786 | (eq *standard-effective-slot-definition-class-wrapper* |
---|
2787 | (instance.class-wrapper slotd)) |
---|
2788 | (eq *standard-class-wrapper* (instance.class-wrapper class)) |
---|
2789 | (let* ((allocation (standard-effective-slot-definition.allocation slotd))) |
---|
2790 | (or (eq allocation :instance) (eq allocation :class)))) |
---|
2791 | (%std-slot-vector-value (instance-slots instance) slotd) |
---|
2792 | (if (= (the fixnum (typecode instance)) target::subtag-struct) |
---|
2793 | (struct-ref instance (standard-effective-slot-definition.location slotd)) |
---|
2794 | (slot-value-using-class class instance slotd)))) |
---|
2795 | |
---|
2796 | |
---|
2797 | (declaim (inline %set-std-slot-vector-value)) |
---|
2798 | |
---|
2799 | (defun %set-std-slot-vector-value (slot-vector slotd new) |
---|
2800 | (let* ((loc (standard-effective-slot-definition.location slotd)) |
---|
2801 | (type (standard-effective-slot-definition.type slotd)) |
---|
2802 | (type-predicate (standard-effective-slot-definition.type-predicate slotd))) |
---|
2803 | (unless (or (eq new (%slot-unbound-marker)) |
---|
2804 | (null type-predicate) |
---|
2805 | (funcall type-predicate new)) |
---|
2806 | (error 'bad-slot-type |
---|
2807 | :instance (slot-vector.instance slot-vector) |
---|
2808 | :datum new :expected-type type |
---|
2809 | :slot-definition slotd)) |
---|
2810 | (typecase loc |
---|
2811 | (fixnum |
---|
2812 | (setf (%svref slot-vector loc) new)) |
---|
2813 | (cons |
---|
2814 | (setf (%cdr loc) new)) |
---|
2815 | (t |
---|
2816 | (error "Slot definition ~s has invalid location ~s (allocation ~s)." |
---|
2817 | slotd loc (slot-definition-allocation slotd)))))) |
---|
2818 | |
---|
2819 | |
---|
2820 | (defmethod (setf slot-value-using-class) |
---|
2821 | (new |
---|
2822 | (class standard-class) |
---|
2823 | instance |
---|
2824 | (slotd standard-effective-slot-definition)) |
---|
2825 | (ecase (standard-slot-definition.allocation slotd) |
---|
2826 | ((:instance :class) |
---|
2827 | (%set-std-slot-vector-value (instance-slots instance) slotd new)))) |
---|
2828 | |
---|
2829 | |
---|
2830 | (defun %maybe-std-setf-slot-value-using-class (class instance slotd new) |
---|
2831 | (if (and (eql (typecode class) target::subtag-instance) |
---|
2832 | (eql (typecode slotd) target::subtag-instance) |
---|
2833 | (eq *standard-effective-slot-definition-class-wrapper* |
---|
2834 | (instance.class-wrapper slotd)) |
---|
2835 | (eq *standard-class-wrapper* (instance.class-wrapper class)) |
---|
2836 | (let* ((allocation (standard-effective-slot-definition.allocation slotd))) |
---|
2837 | (or (eq allocation :instance) (eq allocation :class)))) |
---|
2838 | ;; Not safe to use instance.slots here, since the instance is not |
---|
2839 | ;; definitely of type SUBTAG-INSTANCE. (Anyway, INSTANCE-SLOTS |
---|
2840 | ;; should be inlined here.) |
---|
2841 | (%set-std-slot-vector-value (instance-slots instance) slotd new) |
---|
2842 | (if (structurep instance) |
---|
2843 | (setf (struct-ref instance (standard-effective-slot-definition.location slotd)) |
---|
2844 | new) |
---|
2845 | (setf (slot-value-using-class class instance slotd) new)))) |
---|
2846 | |
---|
2847 | (defmethod slot-value-using-class ((class funcallable-standard-class) |
---|
2848 | instance |
---|
2849 | (slotd standard-effective-slot-definition)) |
---|
2850 | (%std-slot-vector-value (gf.slots instance) slotd)) |
---|
2851 | |
---|
2852 | (defmethod (setf slot-value-using-class) |
---|
2853 | (new |
---|
2854 | (class funcallable-standard-class) |
---|
2855 | instance |
---|
2856 | (slotd standard-effective-slot-definition)) |
---|
2857 | (%set-std-slot-vector-value (gf.slots instance) slotd new)) |
---|
2858 | |
---|
2859 | (defun slot-value (instance slot-name) |
---|
2860 | (let* ((wrapper |
---|
2861 | (let* ((w (instance-class-wrapper instance))) |
---|
2862 | (if (eql 0 (%wrapper-hash-index w)) |
---|
2863 | (instance.class-wrapper (update-obsolete-instance instance)) |
---|
2864 | w))) |
---|
2865 | (class (%wrapper-class wrapper)) |
---|
2866 | (slotd (find-slotd slot-name (if (%standard-instance-p class) |
---|
2867 | (%class.slots class) |
---|
2868 | (class-slots class))))) |
---|
2869 | (if slotd |
---|
2870 | (%maybe-std-slot-value-using-class class instance slotd) |
---|
2871 | (if (typep slot-name 'symbol) |
---|
2872 | (restart-case |
---|
2873 | (values (slot-missing class instance slot-name 'slot-value)) |
---|
2874 | (continue () |
---|
2875 | :report "Try accessing the slot again" |
---|
2876 | (slot-value instance slot-name)) |
---|
2877 | (use-value (value) |
---|
2878 | :report "Return a value" |
---|
2879 | :interactive (lambda () |
---|
2880 | (format *query-io* "~&Value to use: ") |
---|
2881 | (list (read *query-io*))) |
---|
2882 | value)) |
---|
2883 | (report-bad-arg slot-name 'symbol))))) |
---|
2884 | |
---|
2885 | |
---|
2886 | (defmethod slot-unbound (class instance slot-name) |
---|
2887 | (declare (ignore class)) |
---|
2888 | (restart-case (error 'unbound-slot :name slot-name :instance instance) |
---|
2889 | (use-value (value) |
---|
2890 | :report "Return a value" |
---|
2891 | :interactive (lambda () |
---|
2892 | (format *query-io* "~&Value to use: ") |
---|
2893 | (list (read *query-io*))) |
---|
2894 | value))) |
---|
2895 | |
---|
2896 | |
---|
2897 | |
---|
2898 | (defmethod slot-makunbound-using-class ((class slots-class) |
---|
2899 | instance |
---|
2900 | (slotd standard-effective-slot-definition)) |
---|
2901 | (setf (slot-value-using-class class instance slotd) (%slot-unbound-marker)) |
---|
2902 | instance) |
---|
2903 | |
---|
2904 | (defmethod slot-missing (class object slot-name operation &optional new-value) |
---|
2905 | (declare (ignore class operation new-value)) |
---|
2906 | (error "~s has no slot named ~s." object slot-name)) |
---|
2907 | |
---|
2908 | |
---|
2909 | (defun set-slot-value (instance name value) |
---|
2910 | (let* ((wrapper |
---|
2911 | (let* ((w (instance-class-wrapper instance))) |
---|
2912 | (if (eql 0 (%wrapper-hash-index w)) |
---|
2913 | (instance.class-wrapper (update-obsolete-instance instance)) |
---|
2914 | w))) |
---|
2915 | (class (%wrapper-class wrapper)) |
---|
2916 | (slotd (find-slotd name (if (%standard-instance-p class) |
---|
2917 | (%class.slots class) |
---|
2918 | (class-slots class))))) |
---|
2919 | (if slotd |
---|
2920 | (%maybe-std-setf-slot-value-using-class class instance slotd value) |
---|
2921 | (if (typep name 'symbol) |
---|
2922 | (progn |
---|
2923 | (slot-missing class instance name 'setf value) |
---|
2924 | value) |
---|
2925 | (report-bad-arg name 'symbol))))) |
---|
2926 | |
---|
2927 | (defsetf slot-value set-slot-value) |
---|
2928 | |
---|
2929 | (defun slot-makunbound (instance name) |
---|
2930 | (let* ((class (class-of instance)) |
---|
2931 | (slotd (find-slotd name (%class-slots class)))) |
---|
2932 | (if slotd |
---|
2933 | (slot-makunbound-using-class class instance slotd) |
---|
2934 | (slot-missing class instance name 'slot-makunbound)) |
---|
2935 | instance)) |
---|
2936 | |
---|
2937 | (defun %std-slot-vector-boundp (slot-vector slotd) |
---|
2938 | (let* ((loc (standard-effective-slot-definition.location slotd))) |
---|
2939 | (typecase loc |
---|
2940 | (fixnum |
---|
2941 | (not (eq (%svref slot-vector loc) (%slot-unbound-marker)))) |
---|
2942 | (cons |
---|
2943 | (not (eq (%cdr loc) (%slot-unbound-marker)))) |
---|
2944 | (t |
---|
2945 | (error "Slot definition ~s has invalid location ~s (allocation ~s)." |
---|
2946 | slotd loc (slot-definition-allocation slotd)))))) |
---|
2947 | |
---|
2948 | (defun %maybe-std-slot-boundp-using-class (class instance slotd) |
---|
2949 | (if (and (eql (typecode class) target::subtag-instance) |
---|
2950 | (eql (typecode slotd) target::subtag-instance) |
---|
2951 | (eq *standard-effective-slot-definition-class-wrapper* |
---|
2952 | (instance.class-wrapper slotd)) |
---|
2953 | (eq *standard-class-wrapper* (instance.class-wrapper class)) |
---|
2954 | (let* ((allocation (standard-slot-definition.allocation slotd))) |
---|
2955 | (or (eq allocation :class) |
---|
2956 | (eq allocation :instance)))) |
---|
2957 | (%std-slot-vector-boundp (instance-slots instance) slotd) |
---|
2958 | (slot-boundp-using-class class instance slotd))) |
---|
2959 | |
---|
2960 | |
---|
2961 | (defmethod slot-boundp-using-class ((class standard-class) |
---|
2962 | instance |
---|
2963 | (slotd standard-effective-slot-definition)) |
---|
2964 | (ecase (standard-slot-definition.allocation slotd) |
---|
2965 | ((:instance :class) |
---|
2966 | (%std-slot-vector-boundp (instance-slots instance) slotd)))) |
---|
2967 | |
---|
2968 | (defmethod slot-boundp-using-class ((class funcallable-standard-class) |
---|
2969 | instance |
---|
2970 | (slotd standard-effective-slot-definition)) |
---|
2971 | (%std-slot-vector-boundp (gf.slots instance) slotd)) |
---|
2972 | |
---|
2973 | |
---|
2974 | |
---|
2975 | (defun slot-boundp (instance name) |
---|
2976 | (let* ((wrapper |
---|
2977 | (let* ((w (instance-class-wrapper instance))) |
---|
2978 | (if (eql 0 (%wrapper-hash-index w)) |
---|
2979 | (instance.class-wrapper (update-obsolete-instance instance)) |
---|
2980 | w))) |
---|
2981 | (class (%wrapper-class wrapper)) |
---|
2982 | (slotd (find-slotd name (if (%standard-instance-p class) |
---|
2983 | (%class.slots class) |
---|
2984 | (class-slots class))))) |
---|
2985 | (if slotd |
---|
2986 | (%maybe-std-slot-boundp-using-class class instance slotd) |
---|
2987 | (if (typep name 'symbol) |
---|
2988 | (values (slot-missing class instance name 'slot-boundp)) |
---|
2989 | (report-bad-arg name 'symbol))))) |
---|
2990 | |
---|
2991 | (defun slot-value-if-bound (instance name &optional default) |
---|
2992 | (if (slot-boundp instance name) |
---|
2993 | (slot-value instance name) |
---|
2994 | default)) |
---|
2995 | |
---|
2996 | (defun slot-exists-p (instance name) |
---|
2997 | (let* ((class (class-of instance)) |
---|
2998 | (slots (class-slots class))) |
---|
2999 | (find-slotd name slots))) |
---|
3000 | |
---|
3001 | |
---|
3002 | (defun slot-id-value (instance slot-id) |
---|
3003 | (let* ((wrapper (instance-class-wrapper instance))) |
---|
3004 | (funcall (%wrapper-slot-id-value wrapper) instance slot-id))) |
---|
3005 | |
---|
3006 | (defun set-slot-id-value (instance slot-id value) |
---|
3007 | (let* ((wrapper (instance-class-wrapper instance))) |
---|
3008 | (funcall (%wrapper-set-slot-id-value wrapper) instance slot-id value))) |
---|
3009 | |
---|
3010 | (defun slot-id-boundp (instance slot-id) |
---|
3011 | (let* ((wrapper (instance-class-wrapper instance)) |
---|
3012 | (class (%wrapper-class wrapper)) |
---|
3013 | (slotd (funcall (%wrapper-slot-id->slotd wrapper) instance slot-id))) |
---|
3014 | (if slotd |
---|
3015 | (%maybe-std-slot-boundp-using-class class instance slotd) |
---|
3016 | (values (slot-missing class instance (slot-id.name slot-id) 'slot-boundp))))) |
---|
3017 | |
---|
3018 | ;;; returns nil if (apply gf args) wil cause an error because of the |
---|
3019 | ;;; non-existance of a method (or if GF is not a generic function or the name |
---|
3020 | ;;; of a generic function). |
---|
3021 | (defun method-exists-p (gf &rest args) |
---|
3022 | (declare (dynamic-extent args)) |
---|
3023 | (when (symbolp gf) |
---|
3024 | (setq gf (fboundp gf))) |
---|
3025 | (when (typep gf 'standard-generic-function) |
---|
3026 | (or (null args) |
---|
3027 | (let* ((methods (sgf.methods gf))) |
---|
3028 | (dolist (m methods) |
---|
3029 | (when (null (%method-qualifiers m)) |
---|
3030 | (let ((specializers (%method-specializers m)) |
---|
3031 | (args args)) |
---|
3032 | (when (dolist (s specializers t) |
---|
3033 | (unless (cond ((typep s 'eql-specializer) |
---|
3034 | (eql (eql-specializer-object s) |
---|
3035 | (car args))) |
---|
3036 | (t (memq s (%inited-class-cpl |
---|
3037 | (class-of (car args)))))) |
---|
3038 | (return nil)) |
---|
3039 | (pop args)) |
---|
3040 | (return-from method-exists-p m))))) |
---|
3041 | nil)))) |
---|
3042 | |
---|
3043 | (defun funcall-if-method-exists (gf &optional default &rest args) |
---|
3044 | (declare (dynamic-extent args)) |
---|
3045 | (if (apply #'method-exists-p gf args) |
---|
3046 | (apply gf args) |
---|
3047 | (if default (apply default args)))) |
---|
3048 | |
---|
3049 | |
---|
3050 | (defun find-specializer (specializer) |
---|
3051 | (if (and (listp specializer) (eql (car specializer) 'eql)) |
---|
3052 | (intern-eql-specializer (cadr specializer)) |
---|
3053 | (find-class specializer))) |
---|
3054 | |
---|
3055 | (defmethod make-instances-obsolete ((class symbol)) |
---|
3056 | (make-instances-obsolete (find-class class))) |
---|
3057 | |
---|
3058 | (defmethod make-instances-obsolete ((class standard-class)) |
---|
3059 | (let ((wrapper (%class-own-wrapper class))) |
---|
3060 | (when wrapper |
---|
3061 | (setf (%class-own-wrapper class) nil) |
---|
3062 | (make-wrapper-obsolete wrapper))) |
---|
3063 | class) |
---|
3064 | |
---|
3065 | (defmethod make-instances-obsolete ((class funcallable-standard-class)) |
---|
3066 | (let ((wrapper (%class.own-wrapper class))) |
---|
3067 | (when wrapper |
---|
3068 | (setf (%class-own-wrapper class) nil) |
---|
3069 | (make-wrapper-obsolete wrapper))) |
---|
3070 | class) |
---|
3071 | |
---|
3072 | (defmethod make-instances-obsolete ((class structure-class)) |
---|
3073 | ;; could maybe warn that instances are obsolete, but there's not |
---|
3074 | ;; much that we can do about that. |
---|
3075 | class) |
---|
3076 | |
---|
3077 | |
---|
3078 | |
---|
3079 | ;;; A wrapper is made obsolete by setting the hash-index & instance-slots to 0 |
---|
3080 | ;;; The instance slots are saved for update-obsolete-instance |
---|
3081 | ;;; by consing them onto the class slots. |
---|
3082 | ;;; Method dispatch looks at the hash-index. |
---|
3083 | ;;; slot-value & set-slot-value look at the instance-slots. |
---|
3084 | ;;; Each wrapper may have an associated forwarding wrapper, which must |
---|
3085 | ;;; also be made obsolete. The forwarding-wrapper is stored in the |
---|
3086 | ;;; hash table below keyed on the wrapper-hash-index of the two |
---|
3087 | ;;; wrappers. |
---|
3088 | (defvar *forwarding-wrapper-hash-table* (make-hash-table :test 'eq)) |
---|
3089 | |
---|
3090 | |
---|
3091 | (defun make-wrapper-obsolete (wrapper) |
---|
3092 | (without-interrupts |
---|
3093 | (let ((forwarding-info |
---|
3094 | (unless (eql 0 (%wrapper-instance-slots wrapper)) ; already forwarded or obsolete? |
---|
3095 | (%cons-forwarding-info (%wrapper-instance-slots wrapper) |
---|
3096 | (%wrapper-class-slots wrapper))))) |
---|
3097 | (when forwarding-info |
---|
3098 | (setf (%wrapper-hash-index wrapper) 0 |
---|
3099 | (%wrapper-cpl wrapper) nil |
---|
3100 | (%wrapper-cpl-bits wrapper) nil |
---|
3101 | (%wrapper-instance-slots wrapper) 0 |
---|
3102 | (%wrapper-forwarding-info wrapper) forwarding-info |
---|
3103 | (%wrapper-slot-id->slotd wrapper) #'%slot-id-lookup-obsolete |
---|
3104 | (%wrapper-slot-id-value wrapper) #'%slot-id-ref-obsolete |
---|
3105 | (%wrapper-set-slot-id-value wrapper) #'%slot-id-set-obsolete |
---|
3106 | )))) |
---|
3107 | wrapper) |
---|
3108 | |
---|
3109 | (defun %clear-class-primary-slot-accessor-offsets (class) |
---|
3110 | (let ((info-list (%class-get class '%class-primary-slot-accessor-info))) |
---|
3111 | (dolist (info info-list) |
---|
3112 | (setf (%slot-accessor-info.offset info) nil)))) |
---|
3113 | |
---|
3114 | (defun primary-class-slot-offset (class slot-name) |
---|
3115 | (dolist (super (%class.cpl class)) |
---|
3116 | (let* ((pos (and (typep super 'standard-class) |
---|
3117 | (%class-primary-p super) |
---|
3118 | (dolist (slot (%class-slots class)) |
---|
3119 | (when (eq (%slot-definition-allocation slot) |
---|
3120 | :instance) |
---|
3121 | (when (eq slot-name (%slot-definition-name slot)) |
---|
3122 | (return (%slot-definition-location slot)))))))) |
---|
3123 | (when pos (return pos))))) |
---|
3124 | |
---|
3125 | ;;; Called by the compiler-macro expansion for slot-value |
---|
3126 | ;;; info is the result of a %class-primary-slot-accessor-info call. |
---|
3127 | ;;; value-form is specified if this is set-slot-value. |
---|
3128 | ;;; Otherwise it's slot-value. |
---|
3129 | (defun primary-class-slot-value (instance info &optional (value-form nil value-form-p)) |
---|
3130 | (let ((slot-name (%slot-accessor-info.slot-name info))) |
---|
3131 | (prog1 |
---|
3132 | (if value-form-p |
---|
3133 | (setf (slot-value instance slot-name) value-form) |
---|
3134 | (slot-value instance slot-name)) |
---|
3135 | (setf (%slot-accessor-info.offset info) |
---|
3136 | (primary-class-slot-offset (class-of instance) slot-name))))) |
---|
3137 | |
---|
3138 | (defun primary-class-accessor (instance info &optional (value-form nil value-form-p)) |
---|
3139 | (let ((accessor (%slot-accessor-info.accessor info))) |
---|
3140 | (prog1 |
---|
3141 | (if value-form-p |
---|
3142 | (funcall accessor value-form instance) |
---|
3143 | (funcall accessor instance)) |
---|
3144 | (let ((methods (compute-applicable-methods |
---|
3145 | accessor |
---|
3146 | (if value-form-p (list value-form instance) (list instance)))) |
---|
3147 | method) |
---|
3148 | (when (and (eql (length methods) 1) |
---|
3149 | (typep (setq method (car methods)) 'standard-accessor-method)) |
---|
3150 | (let* ((slot-name (method-slot-name method))) |
---|
3151 | (setf (%slot-accessor-info.offset info) |
---|
3152 | (primary-class-slot-offset (class-of instance) slot-name)))))))) |
---|
3153 | |
---|
3154 | (defun exchange-slot-vectors-and-wrappers (a b) |
---|
3155 | (if (typep a 'funcallable-standard-object) |
---|
3156 | (let* ((temp-wrapper (gf.instance.class-wrapper a)) |
---|
3157 | (orig-a-slots (gf.slots a)) |
---|
3158 | (orig-b-slots (gf.slots b))) |
---|
3159 | (setf (gf.instance.class-wrapper a) (gf.instance.class-wrapper b) |
---|
3160 | (gf.instance.class-wrapper b) temp-wrapper |
---|
3161 | (gf.slots a) orig-b-slots |
---|
3162 | (gf.slots b) orig-a-slots |
---|
3163 | (slot-vector.instance orig-a-slots) b |
---|
3164 | (slot-vector.instance orig-b-slots) a)) |
---|
3165 | (let* ((temp-wrapper (instance.class-wrapper a)) |
---|
3166 | (orig-a-slots (instance.slots a)) |
---|
3167 | (orig-b-slots (instance.slots b))) |
---|
3168 | (setf (instance.class-wrapper a) (instance.class-wrapper b) |
---|
3169 | (instance.class-wrapper b) temp-wrapper |
---|
3170 | (instance.slots a) orig-b-slots |
---|
3171 | (instance.slots b) orig-a-slots |
---|
3172 | (slot-vector.instance orig-a-slots) b |
---|
3173 | (slot-vector.instance orig-b-slots) a)))) |
---|
3174 | |
---|
3175 | |
---|
3176 | |
---|
3177 | |
---|
3178 | ;;; How slot values transfer (from PCL): |
---|
3179 | ;;; |
---|
3180 | ;;; local --> local transfer |
---|
3181 | ;;; local --> shared discard |
---|
3182 | ;;; local --> -- discard |
---|
3183 | ;;; shared --> local transfer |
---|
3184 | ;;; shared --> shared discard |
---|
3185 | ;;; shared --> -- discard |
---|
3186 | ;;; -- --> local added |
---|
3187 | ;;; -- --> shared -- |
---|
3188 | ;;; |
---|
3189 | ;;; See make-wrapper-obsolete to see how we got here. |
---|
3190 | ;;; A word about forwarding. When a class is made obsolete, the |
---|
3191 | ;;; %wrapper-instance-slots slot of its wrapper is set to 0. |
---|
3192 | ;;; %wrapper-class-slots = (instance-slots . class-slots) |
---|
3193 | ;;; Note: this should stack-cons the new-instance if we can reuse the |
---|
3194 | ;;; old instance or it's forwarded value. |
---|
3195 | (defun update-obsolete-instance (instance) |
---|
3196 | (let* ((added ()) |
---|
3197 | (discarded ()) |
---|
3198 | (plist ())) |
---|
3199 | (without-interrupts ; Not -close- to being correct |
---|
3200 | (let* ((old-wrapper (standard-object-p instance))) |
---|
3201 | (unless old-wrapper |
---|
3202 | (when (typep instance 'funcallable-standard-object) |
---|
3203 | (setq old-wrapper (gf.instance.class-wrapper instance))) |
---|
3204 | (unless old-wrapper |
---|
3205 | (report-bad-arg instance '(or standard-object funcallable-standard-object)))) |
---|
3206 | (when (eql 0 (%wrapper-instance-slots old-wrapper)) ; is it really obsolete? |
---|
3207 | (let* ((class (%wrapper-class old-wrapper)) |
---|
3208 | (new-wrapper (or (%class.own-wrapper class) |
---|
3209 | (progn |
---|
3210 | (update-class class t) |
---|
3211 | (%class.own-wrapper class)))) |
---|
3212 | (forwarding-info (%wrapper-forwarding-info old-wrapper)) |
---|
3213 | (old-class-slots (%forwarding-class-slots forwarding-info)) |
---|
3214 | (old-instance-slots (%forwarding-instance-slots forwarding-info)) |
---|
3215 | (new-instance-slots (%wrapper-instance-slots new-wrapper)) |
---|
3216 | (new-class-slots (%wrapper-class-slots new-wrapper)) |
---|
3217 | (new-instance (allocate-instance class)) |
---|
3218 | (old-slot-vector (instance-slots instance)) |
---|
3219 | (new-slot-vector (instance-slots new-instance))) |
---|
3220 | ;; Lots to do. Hold onto your hat. |
---|
3221 | (let* ((old-size (uvsize old-instance-slots)) |
---|
3222 | (new-size (uvsize new-instance-slots))) |
---|
3223 | (declare (fixnum old-size new-size)) |
---|
3224 | (dotimes (i old-size) |
---|
3225 | (declare (fixnum i)) |
---|
3226 | (let* ((slot-name (%svref old-instance-slots i)) |
---|
3227 | (pos (%vector-member slot-name new-instance-slots)) |
---|
3228 | (val (%svref old-slot-vector (%i+ i 1)))) |
---|
3229 | (if pos |
---|
3230 | (setf (%svref new-slot-vector (%i+ pos 1)) val) |
---|
3231 | (progn |
---|
3232 | (push slot-name discarded) |
---|
3233 | (unless (eq val (%slot-unbound-marker)) |
---|
3234 | (setf (getf plist slot-name) val)))))) |
---|
3235 | ;; Go through old class slots |
---|
3236 | (dolist (pair old-class-slots) |
---|
3237 | (let* ((slot-name (%car pair)) |
---|
3238 | (val (%cdr pair)) |
---|
3239 | (pos (%vector-member slot-name new-instance-slots))) |
---|
3240 | (if pos |
---|
3241 | (setf (%svref new-slot-vector (%i+ pos 1)) val) |
---|
3242 | (progn |
---|
3243 | (push slot-name discarded) |
---|
3244 | (unless (eq val (%slot-unbound-marker)) |
---|
3245 | (setf (getf plist slot-name) val)))))) |
---|
3246 | ; Go through new instance slots |
---|
3247 | (dotimes (i new-size) |
---|
3248 | (declare (fixnum i)) |
---|
3249 | (let* ((slot-name (%svref new-instance-slots i))) |
---|
3250 | (unless (or (%vector-member slot-name old-instance-slots) |
---|
3251 | (assoc slot-name old-class-slots)) |
---|
3252 | (push slot-name added)))) |
---|
3253 | ;; Go through new class slots |
---|
3254 | (dolist (pair new-class-slots) |
---|
3255 | (let ((slot-name (%car pair))) |
---|
3256 | (unless (or (%vector-member slot-name old-instance-slots) |
---|
3257 | (assoc slot-name old-class-slots)) |
---|
3258 | (push slot-name added)))) |
---|
3259 | (exchange-slot-vectors-and-wrappers new-instance instance)))))) |
---|
3260 | ;; run user code with interrupts enabled. |
---|
3261 | (update-instance-for-redefined-class instance added discarded plist)) |
---|
3262 | instance) |
---|
3263 | |
---|
3264 | |
---|
3265 | (defmethod update-instance-for-redefined-class ((instance standard-object) |
---|
3266 | added-slots |
---|
3267 | discarded-slots |
---|
3268 | property-list |
---|
3269 | &rest initargs) |
---|
3270 | (declare (ignore discarded-slots property-list)) |
---|
3271 | (when initargs |
---|
3272 | (check-initargs |
---|
3273 | instance nil initargs t |
---|
3274 | #'update-instance-for-redefined-class #'shared-initialize)) |
---|
3275 | (apply #'shared-initialize instance added-slots initargs)) |
---|
3276 | |
---|
3277 | (defmethod update-instance-for-redefined-class ((instance standard-generic-function) |
---|
3278 | added-slots |
---|
3279 | discarded-slots |
---|
3280 | property-list |
---|
3281 | &rest initargs) |
---|
3282 | (declare (ignore discarded-slots property-list)) |
---|
3283 | (when initargs |
---|
3284 | (check-initargs |
---|
3285 | instance nil initargs t |
---|
3286 | #'update-instance-for-redefined-class #'shared-initialize)) |
---|
3287 | (apply #'shared-initialize instance added-slots initargs)) |
---|
3288 | |
---|
3289 | (defun check-initargs (instance class initargs errorp &rest functions) |
---|
3290 | (declare (dynamic-extent functions)) |
---|
3291 | (declare (list functions)) |
---|
3292 | (setq class (require-type (or class (class-of instance)) 'class)) |
---|
3293 | (unless (getf initargs :allow-other-keys) |
---|
3294 | (let ((initvect (initargs-vector instance class functions))) |
---|
3295 | (when (eq initvect t) (return-from check-initargs nil)) |
---|
3296 | (do* ((tail initargs (cddr tail)) |
---|
3297 | (initarg (car tail) (car tail)) |
---|
3298 | bad-keys? bad-key) |
---|
3299 | ((null (cdr tail)) |
---|
3300 | (if bad-keys? |
---|
3301 | (if errorp |
---|
3302 | (signal-program-error |
---|
3303 | "~s is an invalid initarg to ~s for ~s.~%~ |
---|
3304 | Valid initargs: ~s." |
---|
3305 | bad-key |
---|
3306 | (function-name (car functions)) |
---|
3307 | class (coerce initvect 'list)) |
---|
3308 | (values bad-keys? bad-key)))) |
---|
3309 | (if (eq initarg :allow-other-keys) |
---|
3310 | (if (cadr tail) |
---|
3311 | (return)) ; (... :allow-other-keys t ...) |
---|
3312 | (unless (or bad-keys? (%vector-member initarg initvect)) |
---|
3313 | (setq bad-keys? t |
---|
3314 | bad-key initarg))))))) |
---|
3315 | |
---|
3316 | (defun initargs-vector (instance class functions) |
---|
3317 | (let ((index (cadr (assq (car functions) *initialization-invalidation-alist*)))) |
---|
3318 | (unless index |
---|
3319 | (error "Unknown initialization function: ~s." (car functions))) |
---|
3320 | (let ((initvect (%svref (instance-slots class) index))) |
---|
3321 | (unless initvect |
---|
3322 | (setf (%svref (instance-slots class) index) |
---|
3323 | (setq initvect (compute-initargs-vector instance class functions)))) |
---|
3324 | initvect))) |
---|
3325 | |
---|
3326 | |
---|
3327 | ;; This is used for compile-time defclass option checking. |
---|
3328 | (defun class-keyvect (class-arg initargs) |
---|
3329 | (let* ((class (if (typep class-arg 'class) class-arg (find-class class-arg nil))) |
---|
3330 | (meta-arg (getf initargs :metaclass (if (and class (not (typep class 'forward-referenced-class))) |
---|
3331 | (class-of class) |
---|
3332 | *standard-class-class*))) |
---|
3333 | (meta-spec (if (quoted-form-p meta-arg) (%cadr meta-arg) meta-arg)) |
---|
3334 | (meta (if (typep meta-spec 'class) meta-spec (find-class meta-spec nil)))) |
---|
3335 | (if (and meta (not (typep meta 'forward-referenced-class))) |
---|
3336 | (compute-initargs-vector class meta (list #'initialize-instance #'allocate-instance #'shared-initialize) t) |
---|
3337 | t))) |
---|
3338 | |
---|
3339 | (defun compute-initargs-vector (instance class functions &optional require-rest) |
---|
3340 | (let ((initargs (class-slot-initargs class)) |
---|
3341 | (cpl (%inited-class-cpl class))) |
---|
3342 | (dolist (f functions) ; for all the functions passed |
---|
3343 | #+no |
---|
3344 | (if (logbitp $lfbits-aok-bit (lfun-bits f)) |
---|
3345 | (return-from compute-initargs-vector t)) |
---|
3346 | (dolist (method (%gf-methods f)) ; for each applicable method |
---|
3347 | (let ((spec (car (%method-specializers method)))) |
---|
3348 | (when (if (typep spec 'eql-specializer) |
---|
3349 | (eql instance (eql-specializer-object spec)) |
---|
3350 | (memq spec cpl)) |
---|
3351 | (let* ((func (%inner-method-function method)) |
---|
3352 | (keyvect (if (and (logbitp $lfbits-aok-bit (lfun-bits func)) |
---|
3353 | (or (not require-rest) |
---|
3354 | (logbitp $lfbits-rest-bit (lfun-bits func)))) |
---|
3355 | (return-from compute-initargs-vector t) |
---|
3356 | (lfun-keyvect func)))) |
---|
3357 | (dovector (key keyvect) |
---|
3358 | (pushnew key initargs))))))) ; add all of the method's keys |
---|
3359 | (apply #'vector initargs))) |
---|
3360 | |
---|
3361 | |
---|
3362 | |
---|
3363 | ;;; A useful function |
---|
3364 | (defun class-make-instance-initargs (class) |
---|
3365 | (setq class (require-type (if (symbolp class) (find-class class) class) |
---|
3366 | 'std-class)) |
---|
3367 | (flet ((iv (class &rest functions) |
---|
3368 | (declare (dynamic-extent functions)) |
---|
3369 | (initargs-vector (class-prototype class) class functions))) |
---|
3370 | (let ((initvect (apply #'iv |
---|
3371 | class |
---|
3372 | #'initialize-instance #'allocate-instance #'shared-initialize |
---|
3373 | nil))) |
---|
3374 | (if (eq initvect 't) |
---|
3375 | t |
---|
3376 | (concatenate 'list initvect))))) |
---|
3377 | |
---|
3378 | |
---|
3379 | |
---|
3380 | ;;; This is part of the MOP |
---|
3381 | ;;; Maybe it was, at one point in the distant past ... |
---|
3382 | (defmethod class-slot-initargs ((class slots-class)) |
---|
3383 | (collect ((initargs)) |
---|
3384 | (dolist (slot (%class-slots class) (initargs)) |
---|
3385 | (dolist (i (%slot-definition-initargs slot)) |
---|
3386 | (initargs i))))) |
---|
3387 | |
---|
3388 | |
---|
3389 | (defun maybe-update-obsolete-instance (instance) |
---|
3390 | (let ((wrapper (standard-object-p instance))) |
---|
3391 | (unless wrapper |
---|
3392 | (when (typep instance 'funcallable-standard-object) |
---|
3393 | (setq wrapper (gf.instance.class-wrapper instance))) |
---|
3394 | |
---|
3395 | (unless wrapper |
---|
3396 | (report-bad-arg instance '(or standard-object funcallable-standard-object)))) |
---|
3397 | (when (eql 0 (%wrapper-hash-index wrapper)) |
---|
3398 | (update-obsolete-instance instance))) |
---|
3399 | instance) |
---|
3400 | |
---|
3401 | |
---|
3402 | ;;; If you ever reference one of these through anyone who might call |
---|
3403 | ;;; update-obsolete-instance, you will lose badly. |
---|
3404 | (defun %maybe-forwarded-instance (instance) |
---|
3405 | (maybe-update-obsolete-instance instance) |
---|
3406 | instance) |
---|
3407 | |
---|
3408 | |
---|
3409 | |
---|
3410 | (defmethod change-class (instance |
---|
3411 | (new-class symbol) |
---|
3412 | &rest initargs &key &allow-other-keys) |
---|
3413 | (declare (dynamic-extent initargs)) |
---|
3414 | (apply #'change-class instance (find-class new-class) initargs)) |
---|
3415 | |
---|
3416 | (defmethod change-class ((instance standard-object) |
---|
3417 | (new-class standard-class) |
---|
3418 | &rest initargs &key &allow-other-keys) |
---|
3419 | (declare (dynamic-extent initargs)) |
---|
3420 | (%change-class instance new-class initargs)) |
---|
3421 | |
---|
3422 | |
---|
3423 | (defun %change-class (object new-class initargs) |
---|
3424 | (let* ((old-class (class-of object)) |
---|
3425 | (old-wrapper (%class.own-wrapper old-class)) |
---|
3426 | (new-wrapper (or (%class.own-wrapper new-class) |
---|
3427 | (progn |
---|
3428 | (update-class new-class t) |
---|
3429 | (%class.own-wrapper new-class)))) |
---|
3430 | (old-instance-slots-vector (%wrapper-instance-slots old-wrapper)) |
---|
3431 | (new-instance-slots-vector (%wrapper-instance-slots new-wrapper)) |
---|
3432 | (num-new-instance-slots (length new-instance-slots-vector)) |
---|
3433 | (new-object (allocate-instance new-class))) |
---|
3434 | (declare (fixnum num-new-instance-slots) |
---|
3435 | (simple-vector new-instance-slots-vector old-instance-slots-vector)) |
---|
3436 | ;; Retain local slots shared between the new class and the old. |
---|
3437 | (do* ((new-pos 0 (1+ new-pos)) |
---|
3438 | (new-slot-location 1 (1+ new-slot-location))) |
---|
3439 | ((= new-pos num-new-instance-slots)) |
---|
3440 | (declare (fixnum new-pos new-slot-location)) |
---|
3441 | (let* ((old-pos (position (svref new-instance-slots-vector new-pos) |
---|
3442 | old-instance-slots-vector :test #'eq))) |
---|
3443 | (when old-pos |
---|
3444 | (setf (%standard-instance-instance-location-access |
---|
3445 | new-object |
---|
3446 | new-slot-location) |
---|
3447 | (%standard-instance-instance-location-access |
---|
3448 | object |
---|
3449 | (the fixnum (1+ (the fixnum old-pos)))))))) |
---|
3450 | ;; If the new class defines a local slot whos name matches |
---|
3451 | ;; that of a shared slot in the old class, the shared slot's |
---|
3452 | ;; value is used to initialize the new instance's local slot. |
---|
3453 | (dolist (shared-slot (%wrapper-class-slots old-wrapper)) |
---|
3454 | (destructuring-bind (name . value) shared-slot |
---|
3455 | (let* ((new-slot-pos (position name new-instance-slots-vector |
---|
3456 | :test #'eq))) |
---|
3457 | (if new-slot-pos |
---|
3458 | (setf (%standard-instance-instance-location-access |
---|
3459 | new-object |
---|
3460 | (the fixnum (1+ (the fixnum new-slot-pos)))) |
---|
3461 | value))))) |
---|
3462 | (exchange-slot-vectors-and-wrappers object new-object) |
---|
3463 | (apply #'update-instance-for-different-class new-object object initargs) |
---|
3464 | object)) |
---|
3465 | |
---|
3466 | (defmethod update-instance-for-different-class ((previous standard-object) |
---|
3467 | (current standard-object) |
---|
3468 | &rest initargs) |
---|
3469 | (declare (dynamic-extent initargs)) |
---|
3470 | (%update-instance-for-different-class previous current initargs)) |
---|
3471 | |
---|
3472 | (defun %update-instance-for-different-class (previous current initargs) |
---|
3473 | (when initargs |
---|
3474 | (check-initargs |
---|
3475 | current nil initargs t |
---|
3476 | #'update-instance-for-different-class #'shared-initialize)) |
---|
3477 | (let* ((previous-slots (class-slots (class-of previous))) |
---|
3478 | (current-slots (class-slots (class-of current))) |
---|
3479 | (added-slot-names ())) |
---|
3480 | (dolist (s current-slots) |
---|
3481 | (let* ((name (%slot-definition-name s))) |
---|
3482 | (unless (find-slotd name previous-slots) |
---|
3483 | (push name added-slot-names)))) |
---|
3484 | (apply #'shared-initialize |
---|
3485 | current |
---|
3486 | added-slot-names |
---|
3487 | initargs))) |
---|
3488 | |
---|
3489 | |
---|
3490 | |
---|
3491 | |
---|
3492 | ;;; Clear all the valid initargs caches. |
---|
3493 | (defun clear-valid-initargs-caches () |
---|
3494 | (map-classes #'(lambda (name class) |
---|
3495 | (declare (ignore name)) |
---|
3496 | (when (std-class-p class) |
---|
3497 | (setf (%class.make-instance-initargs class) nil |
---|
3498 | (%class.reinit-initargs class) nil |
---|
3499 | (%class.redefined-initargs class) nil |
---|
3500 | (%class.changed-initargs class) nil))))) |
---|
3501 | |
---|
3502 | (defun clear-clos-caches () |
---|
3503 | (clear-all-gf-caches) |
---|
3504 | (clear-valid-initargs-caches)) |
---|
3505 | |
---|
3506 | (defmethod allocate-instance ((class standard-class) &rest initargs) |
---|
3507 | (declare (ignore initargs)) |
---|
3508 | (%allocate-std-instance class)) |
---|
3509 | |
---|
3510 | (defmethod allocate-instance ((class funcallable-standard-class) &rest initargs) |
---|
3511 | (declare (ignore initargs)) |
---|
3512 | (%allocate-gf-instance class)) |
---|
3513 | |
---|
3514 | (unless *initialization-invalidation-alist* |
---|
3515 | (setq *initialization-invalidation-alist* |
---|
3516 | (list (list #'initialize-instance %class.make-instance-initargs) |
---|
3517 | (list #'allocate-instance %class.make-instance-initargs) |
---|
3518 | (list #'reinitialize-instance %class.reinit-initargs) |
---|
3519 | (list #'shared-initialize |
---|
3520 | %class.make-instance-initargs %class.reinit-initargs |
---|
3521 | %class.redefined-initargs %class.changed-initargs) |
---|
3522 | (list #'update-instance-for-redefined-class |
---|
3523 | %class.redefined-initargs) |
---|
3524 | (list #'update-instance-for-different-class |
---|
3525 | %class.changed-initargs)))) |
---|
3526 | |
---|
3527 | |
---|
3528 | (defstatic *initialization-function-lists* |
---|
3529 | (list (list #'initialize-instance #'allocate-instance #'shared-initialize) |
---|
3530 | (list #'reinitialize-instance #'shared-initialize) |
---|
3531 | (list #'update-instance-for-redefined-class #'shared-initialize) |
---|
3532 | (list #'update-instance-for-different-class #'shared-initialize))) |
---|
3533 | |
---|
3534 | |
---|
3535 | |
---|
3536 | (unless *clos-initialization-functions* |
---|
3537 | (setq *clos-initialization-functions* |
---|
3538 | (list #'initialize-instance #'allocate-instance #'shared-initialize |
---|
3539 | #'reinitialize-instance |
---|
3540 | #'update-instance-for-different-class #'update-instance-for-redefined-class))) |
---|
3541 | |
---|
3542 | (defun compute-initialization-functions-alist () |
---|
3543 | (let ((res nil) |
---|
3544 | (lists *initialization-function-lists*)) |
---|
3545 | (dolist (cell *initialization-invalidation-alist*) |
---|
3546 | (let (res-list) |
---|
3547 | (dolist (slot-num (cdr cell)) |
---|
3548 | (push |
---|
3549 | (ecase slot-num |
---|
3550 | (#.%class.make-instance-initargs |
---|
3551 | (assq #'initialize-instance lists)) |
---|
3552 | (#.%class.reinit-initargs |
---|
3553 | (assq #'reinitialize-instance lists)) |
---|
3554 | (#.%class.redefined-initargs |
---|
3555 | (assq #'update-instance-for-redefined-class lists)) |
---|
3556 | (#.%class.changed-initargs |
---|
3557 | (assq #'update-instance-for-different-class lists))) |
---|
3558 | res-list)) |
---|
3559 | (push (cons (car cell) (nreverse res-list)) res))) |
---|
3560 | (setq *initialization-functions-alist* res))) |
---|
3561 | |
---|
3562 | (compute-initialization-functions-alist) |
---|
3563 | |
---|
3564 | |
---|
3565 | |
---|
3566 | |
---|
3567 | |
---|
3568 | |
---|
3569 | ;;; Need to define this for all of the BUILT-IN-CLASSes. |
---|
3570 | (defmethod class-prototype ((class class)) |
---|
3571 | (%class.prototype class)) |
---|
3572 | |
---|
3573 | (defmethod class-prototype ((class std-class)) |
---|
3574 | (or (%class.prototype class) |
---|
3575 | (setf (%class.prototype class) (allocate-instance class)))) |
---|
3576 | |
---|
3577 | |
---|
3578 | (defun gf-class-prototype (class) |
---|
3579 | (%allocate-gf-instance class)) |
---|
3580 | |
---|
3581 | |
---|
3582 | |
---|
3583 | (defmethod class-prototype ((class structure-class)) |
---|
3584 | (or (%class.prototype class) |
---|
3585 | (setf (%class.prototype class) |
---|
3586 | (let* ((sd (gethash (class-name class) %defstructs%)) |
---|
3587 | (slots (class-slots class)) |
---|
3588 | (proto (allocate-typed-vector :struct (1+ (length slots))))) |
---|
3589 | (setf (uvref proto 0) (sd-superclasses sd)) |
---|
3590 | (dolist (slot slots proto) |
---|
3591 | (setf (slot-value-using-class class proto slot) |
---|
3592 | (funcall (slot-definition-initfunction slot)))))))) |
---|
3593 | |
---|
3594 | |
---|
3595 | (defmethod remove-method ((generic-function standard-generic-function) |
---|
3596 | (method standard-method)) |
---|
3597 | (when (eq generic-function (%method-gf method)) |
---|
3598 | (%remove-standard-method-from-containing-gf method)) |
---|
3599 | generic-function) |
---|
3600 | |
---|
3601 | |
---|
3602 | |
---|
3603 | (defmethod function-keywords ((method standard-method)) |
---|
3604 | (let ((f (%inner-method-function method))) |
---|
3605 | (values |
---|
3606 | (concatenate 'list (lfun-keyvect f)) |
---|
3607 | (%ilogbitp $lfbits-aok-bit (lfun-bits f))))) |
---|
3608 | |
---|
3609 | (defmethod no-next-method ((generic-function standard-generic-function) |
---|
3610 | (method standard-method) |
---|
3611 | &rest args) |
---|
3612 | (error "There is no next method for ~s~%args: ~s" method args)) |
---|
3613 | |
---|
3614 | (defmethod add-method ((generic-function standard-generic-function) (method standard-method)) |
---|
3615 | (%add-standard-method-to-standard-gf generic-function method)) |
---|
3616 | |
---|
3617 | (defmethod no-applicable-method (gf &rest args) |
---|
3618 | (cerror "Try calling it again" |
---|
3619 | "There is no applicable method for the generic function:~% ~s~%when called with arguments:~% ~s" gf args) |
---|
3620 | (apply gf args)) |
---|
3621 | |
---|
3622 | |
---|
3623 | (defmethod no-applicable-primary-method (gf methods) |
---|
3624 | (%method-combination-error "No applicable primary methods for ~s~@ |
---|
3625 | Applicable methods: ~s" gf methods)) |
---|
3626 | |
---|
3627 | (defmethod compute-applicable-methods ((gf standard-generic-function) args) |
---|
3628 | (%compute-applicable-methods* gf args)) |
---|
3629 | |
---|
3630 | (defmethod compute-applicable-methods-using-classes ((gf standard-generic-function) args) |
---|
3631 | (let ((res (%compute-applicable-methods* gf args t))) |
---|
3632 | (if (eq res :undecidable) |
---|
3633 | (values nil nil) |
---|
3634 | (values res t)))) |
---|
3635 | |
---|
3636 | (defun %compute-applicable-methods+ (gf &rest args) |
---|
3637 | (declare (dynamic-extent args)) |
---|
3638 | (%compute-applicable-methods* gf args)) |
---|
3639 | |
---|
3640 | (defun %compute-applicable-methods* (gf args &optional using-classes-p) |
---|
3641 | (let* ((methods (%gf-methods gf)) |
---|
3642 | (args-length (length args)) |
---|
3643 | (bits (inner-lfun-bits gf)) |
---|
3644 | arg-count res) |
---|
3645 | (when methods |
---|
3646 | (setq arg-count (length (%method-specializers (car methods)))) |
---|
3647 | (unless (<= arg-count args-length) |
---|
3648 | (error "Too few args to ~s" gf)) |
---|
3649 | (unless (or (logbitp $lfbits-rest-bit bits) |
---|
3650 | (logbitp $lfbits-restv-bit bits) |
---|
3651 | (logbitp $lfbits-keys-bit bits) |
---|
3652 | (<= args-length |
---|
3653 | (+ (ldb $lfbits-numreq bits) (ldb $lfbits-numopt bits)))) |
---|
3654 | (error "Too many args to ~s" gf)) |
---|
3655 | (let ((cpls (make-list arg-count))) |
---|
3656 | (declare (dynamic-extent cpls)) |
---|
3657 | (do* ((args-tail args (cdr args-tail)) |
---|
3658 | (cpls-tail cpls (cdr cpls-tail))) |
---|
3659 | ((null cpls-tail)) |
---|
3660 | (setf (car cpls-tail) |
---|
3661 | (%class-precedence-list (if using-classes-p |
---|
3662 | ;; extension for use in source location support |
---|
3663 | (if (typep (car args-tail) 'eql-specializer) |
---|
3664 | (class-of (eql-specializer-object (car args-tail))) |
---|
3665 | (car args-tail)) |
---|
3666 | (class-of (car args-tail)))))) |
---|
3667 | (dolist (m methods) |
---|
3668 | (let ((appp (%method-applicable-p m args cpls using-classes-p))) |
---|
3669 | (when appp |
---|
3670 | (when (eq appp :undecidable) ;; can only happen if using-classes-p |
---|
3671 | (return-from %compute-applicable-methods* appp)) |
---|
3672 | (push m res)))) |
---|
3673 | (sort-methods res cpls (%gf-precedence-list gf)))))) |
---|
3674 | |
---|
3675 | |
---|
3676 | (defun %method-applicable-p (method args cpls &optional using-classes-p) |
---|
3677 | (do* ((specs (%method-specializers method) (%cdr specs)) |
---|
3678 | (args args (%cdr args)) |
---|
3679 | (cpls cpls (%cdr cpls))) |
---|
3680 | ((null specs) t) |
---|
3681 | (let ((spec (%car specs)) |
---|
3682 | (arg (%car args))) |
---|
3683 | (if (typep spec 'eql-specializer) |
---|
3684 | (if using-classes-p |
---|
3685 | (if (typep arg 'eql-specializer) ;; extension for use in source location support |
---|
3686 | (unless (eql (eql-specializer-object arg) (eql-specializer-object spec)) |
---|
3687 | (return nil)) |
---|
3688 | (if (typep (eql-specializer-object spec) arg) |
---|
3689 | ;; Can't tell if going to be applicable or not based on class alone |
---|
3690 | ;; Except for the special case of NULL which is a singleton |
---|
3691 | (unless (eq arg *null-class*) |
---|
3692 | (return :undecidable)) |
---|
3693 | (return nil))) |
---|
3694 | (unless (eql arg (eql-specializer-object spec)) |
---|
3695 | (return nil))) |
---|
3696 | (unless (memq spec (%car cpls)) |
---|
3697 | (return nil)))))) |
---|
3698 | |
---|
3699 | |
---|
3700 | ;;; Need this so that (compute-applicable-methods |
---|
3701 | ;;; #'class-precedence-list ...) will not recurse. |
---|
3702 | (defun %class-precedence-list (class) |
---|
3703 | (if (eq (class-of class) *standard-class-class*) |
---|
3704 | (%inited-class-cpl class) |
---|
3705 | (class-precedence-list class))) |
---|
3706 | |
---|
3707 | (defmethod class-precedence-list ((class class)) |
---|
3708 | (%inited-class-cpl class)) |
---|
3709 | |
---|
3710 | |
---|
3711 | (defun make-all-methods-kernel () |
---|
3712 | (dolist (f (population.data %all-gfs%)) |
---|
3713 | (let ((smc *standard-method-class*)) |
---|
3714 | (dolist (method (slot-value-if-bound f 'methods)) |
---|
3715 | (when (eq (class-of method) smc) |
---|
3716 | (change-class method *standard-kernel-method-class*)))))) |
---|
3717 | |
---|
3718 | |
---|
3719 | (defun make-all-methods-non-kernel () |
---|
3720 | (dolist (f (population.data %all-gfs%)) |
---|
3721 | (let ((skmc *standard-kernel-method-class*)) |
---|
3722 | (dolist (method (slot-value-if-bound f 'methods)) |
---|
3723 | (when (eq (class-of method) skmc) |
---|
3724 | (change-class method *standard-method-class*)))))) |
---|
3725 | |
---|
3726 | |
---|
3727 | (defun required-lambda-list-args (l) |
---|
3728 | (multiple-value-bind (ok req) (verify-lambda-list l) |
---|
3729 | (unless ok (error "Malformed lambda-list: ~s" l)) |
---|
3730 | req)) |
---|
3731 | |
---|
3732 | |
---|
3733 | (defun check-generic-function-lambda-list (ll &optional (errorp t)) |
---|
3734 | (multiple-value-bind (ok reqsyms opttail resttail keytail auxtail) |
---|
3735 | (verify-lambda-list ll) |
---|
3736 | (declare (ignore reqsyms resttail)) |
---|
3737 | (when ok |
---|
3738 | (block checkit |
---|
3739 | (when (eq (car opttail) '&optional) |
---|
3740 | (dolist (elt (cdr opttail)) |
---|
3741 | (when (memq elt lambda-list-keywords) (return)) |
---|
3742 | (unless (or (symbolp elt) |
---|
3743 | (and (listp elt) |
---|
3744 | (non-nil-symbol-p (car elt)) |
---|
3745 | (null (cdr elt)))) |
---|
3746 | (return-from checkit (setq ok nil))))) |
---|
3747 | (dolist (elt (cdr keytail)) |
---|
3748 | (when (memq elt lambda-list-keywords) (return)) |
---|
3749 | (unless (or (symbolp elt) |
---|
3750 | (and (listp elt) |
---|
3751 | (or (non-nil-symbol-p (car elt)) |
---|
3752 | (and (listp (car elt)) |
---|
3753 | (non-nil-symbol-p (caar elt)) |
---|
3754 | (non-nil-symbol-p (cadar elt)) |
---|
3755 | (null (cddar elt)))) |
---|
3756 | (null (cdr elt)))) |
---|
3757 | (return-from checkit (setq ok nil)))) |
---|
3758 | (when auxtail (setq ok nil)))) |
---|
3759 | (when (and errorp (not ok)) |
---|
3760 | (signal-program-error "Bad generic function lambda list: ~s" ll)) |
---|
3761 | ok)) |
---|
3762 | |
---|
3763 | |
---|
3764 | (defun canonicalize-argument-precedence-order (apo req) |
---|
3765 | (cond ((equal apo req) nil) |
---|
3766 | ((not (eql (length apo) (length req))) |
---|
3767 | (signal-program-error "Lengths of ~S and ~S differ." apo req)) |
---|
3768 | (t (let ((res nil)) |
---|
3769 | (dolist (arg apo (nreverse res)) |
---|
3770 | (let ((index (position arg req))) |
---|
3771 | (if (or (null index) (memq index res)) |
---|
3772 | (error "Missing or duplicate arguments in ~s" apo)) |
---|
3773 | (push index res))))))) |
---|
3774 | |
---|
3775 | |
---|
3776 | (defun %defgeneric (function-name lambda-list method-combination generic-function-class |
---|
3777 | options) |
---|
3778 | (setq generic-function-class (find-class generic-function-class)) |
---|
3779 | (setq method-combination |
---|
3780 | (find-method-combination |
---|
3781 | (class-prototype generic-function-class) |
---|
3782 | (car method-combination) |
---|
3783 | (cdr method-combination))) |
---|
3784 | (let ((gf (fboundp function-name))) |
---|
3785 | (when gf |
---|
3786 | (dolist (method (%defgeneric-methods gf)) |
---|
3787 | (remove-method gf method)))) |
---|
3788 | (record-source-file function-name 'function) |
---|
3789 | (record-arglist function-name lambda-list) |
---|
3790 | (apply #'ensure-generic-function |
---|
3791 | function-name |
---|
3792 | :lambda-list lambda-list |
---|
3793 | :method-combination method-combination |
---|
3794 | :generic-function-class generic-function-class |
---|
3795 | options)) |
---|
3796 | |
---|
3797 | |
---|
3798 | |
---|
3799 | |
---|
3800 | ;;; Redefined in lib;method-combination.lisp |
---|
3801 | (defmethod find-method-combination ((gf standard-generic-function) type options) |
---|
3802 | (unless (and (eq type 'standard) (null options)) |
---|
3803 | (error "non-standard method-combination not supported yet.")) |
---|
3804 | *standard-method-combination*) |
---|
3805 | |
---|
3806 | |
---|
3807 | |
---|
3808 | (defmethod add-direct-method ((spec specializer) (method method)) |
---|
3809 | (pushnew method (specializer.direct-methods spec))) |
---|
3810 | |
---|
3811 | (setf (fdefinition '%do-add-direct-method) #'add-direct-method) |
---|
3812 | |
---|
3813 | (defmethod remove-direct-method ((spec specializer) (method method)) |
---|
3814 | (setf (specializer.direct-methods spec) |
---|
3815 | (nremove method (specializer.direct-methods spec)))) |
---|
3816 | |
---|
3817 | (setf (fdefinition '%do-remove-direct-method) #'remove-direct-method) |
---|
3818 | |
---|
3819 | |
---|
3820 | |
---|
3821 | |
---|
3822 | |
---|
3823 | |
---|
3824 | |
---|
3825 | |
---|
3826 | |
---|
3827 | (defvar *make-load-form-saving-slots-hash* (make-hash-table :test 'eq)) |
---|
3828 | |
---|
3829 | (defun make-load-form-saving-slots (object &key |
---|
3830 | (slot-names nil slot-names-p) |
---|
3831 | environment) |
---|
3832 | (declare (ignore environment)) |
---|
3833 | (let* ((class (class-of object)) |
---|
3834 | (class-name (class-name class)) |
---|
3835 | (structurep (structurep object)) |
---|
3836 | (sd (and structurep (require-type (gethash class-name %defstructs%) 'vector)))) |
---|
3837 | (unless (or structurep |
---|
3838 | (standard-instance-p object)) |
---|
3839 | (%badarg object '(or standard-object structure-object))) |
---|
3840 | (if slot-names-p |
---|
3841 | (dolist (slot slot-names) |
---|
3842 | (unless (slot-exists-p object slot) |
---|
3843 | (error "~s has no slot named ~s" object slot))) |
---|
3844 | (setq slot-names |
---|
3845 | (if structurep |
---|
3846 | (let ((res nil)) |
---|
3847 | (dolist (slot (sd-slots sd)) |
---|
3848 | (unless (fixnump (car slot)) |
---|
3849 | (push (%car slot) res))) |
---|
3850 | (nreverse res)) |
---|
3851 | (mapcar '%slot-definition-name |
---|
3852 | (extract-instance-effective-slotds |
---|
3853 | (class-of object)))))) |
---|
3854 | (values |
---|
3855 | (let* ((form (gethash class-name *make-load-form-saving-slots-hash*))) |
---|
3856 | (or (and (consp form) |
---|
3857 | (eq (car form) 'allocate-instance) |
---|
3858 | form) |
---|
3859 | (setf (gethash class-name *make-load-form-saving-slots-hash*) |
---|
3860 | `(allocate-instance (find-class ',class-name))))) |
---|
3861 | ;; initform is NIL when there are no slots |
---|
3862 | (when slot-names |
---|
3863 | `(%set-slot-values |
---|
3864 | ',object |
---|
3865 | ',slot-names |
---|
3866 | ',(let ((temp #'(lambda (slot) |
---|
3867 | (if (slot-boundp object slot) |
---|
3868 | (slot-value object slot) |
---|
3869 | (%slot-unbound-marker))))) |
---|
3870 | (declare (dynamic-extent temp)) |
---|
3871 | (mapcar temp slot-names))))))) |
---|
3872 | |
---|
3873 | |
---|
3874 | |
---|
3875 | |
---|
3876 | (defmethod allocate-instance ((class structure-class) &rest initargs) |
---|
3877 | (declare (ignore initargs)) |
---|
3878 | (let* ((class-name (%class-name class)) |
---|
3879 | (sd (or (gethash class-name %defstructs%) |
---|
3880 | (error "Can't find structure named ~s" class-name))) |
---|
3881 | (res (make-structure-vector (sd-size sd)))) |
---|
3882 | (setf (%svref res 0) (mapcar (lambda (x) |
---|
3883 | (find-class-cell x t)) (sd-superclasses sd))) |
---|
3884 | res)) |
---|
3885 | |
---|
3886 | |
---|
3887 | (defun %set-slot-values (object slots values) |
---|
3888 | (dolist (slot slots) |
---|
3889 | (let ((value (pop values))) |
---|
3890 | (if (eq value (%slot-unbound-marker)) |
---|
3891 | (slot-makunbound object slot) |
---|
3892 | (setf (slot-value object slot) value))))) |
---|
3893 | |
---|
3894 | |
---|
3895 | (defun %recache-class-direct-methods () |
---|
3896 | (let ((*maintain-class-direct-methods* t)) ; in case we get an error |
---|
3897 | (dolist (f (population-data %all-gfs%)) |
---|
3898 | (when (standard-generic-function-p f) |
---|
3899 | (dolist (method (%gf-methods f)) |
---|
3900 | (%add-direct-methods method))))) |
---|
3901 | (setq *maintain-class-direct-methods* t)) ; no error, all is well |
---|
3902 | |
---|