Context Navigation

l1-clos-boot.lisp @ 15237

Visit:

Last change on this file since 15237 was 15093, checked in by gb, 8 years ago

New Linux ARM binaries.

The image and FASL versions changed on the ARM, but (if I did it right)
not on other platforms.

(The image and FASL versions are now architecture-specific. This may
make it somewhat easier and less disruptive to change them, since the
motivation for such a change is often also architecture-specific.)
The FASL and current image version are defined (in the "TARGET" package)
in the architecture-specific *-arch.lisp files; the min, max, and current
image versions are defined in the *constants*.h file for the architecture.

Most of the changes are ARM-specific.

Each TCR now contains a 256-word table at byte offset 256. (We've
been using about 168 bytes in the TCR, so there are still 88 bytes/22
words left for expansion.) The table is initialized at TCR-creation
time to contain the absolute addresses of the subprims (there are
currently around 130 defined); we try otherwise not to reference
subprims by absolute address. Jumping to a subprim is:

(ldr pc (:@ rcontext (:$ offset-of-subprim-in-tcr-table)))

and calling one involves loading its address from that table into a
register and doing (blx reg). We canonically use LR as the register,
since it's going to be clobbered by the blx anyway and there doesn't
seem to be a performance hazard there. The old scheme (which involved
using BA and BLA pseudoinstructions to jump to/call a hidden jump table
at the end of the function) is no longer supported.

ARM Subprims no longer need to be aligned (on anything more than an
instruction boundary.) Some remnants of the consequences of an old
scheme (where subprims had to "fit" in small regions and sometimes
had to jump out of line if they would overflow that region's bounds)
still remain, but we can repair that (and it'll be a bit more straightforward
to add new ARM subprims.) We no longer care (much) about where subprims
are mapped in memory, and don't have to bias suprimitive addresses by
a platform-specific constant (and have to figure out whether or not we've
already done so) on (e.g.) Android.

Rather than setting the first element (fn.entrypoint) of a
newly-created function to the (absolute) address of a subprim that updates
that entrypoint on the first call, we use a little LAP function to correct
the address before the function can be called.

Non-function objects that can be stored in symbols' function cells
(the UNDEFINED-FUNCTION object, the things that encapsulate
special-operator names and global macro-functions) need to be
structured like FUNCTIONS: the need to have a word-aligned entrypoint
in element 0 that tracks the CODE-VECTOR object in element 1. We
don't want these things to be of type FUNCTION, but do want the GC to
adjust the entrypoint if the codevector moves. We've been essentially
out of GVECTOR subtags on 32-bit platforms, largely because of the
constraints that vector/array subtags must be greater than other
subtags and numeric types be less. The first constraint is probably
reasonable, but the second isn't: other typecodes (tag-list, etc) may
be less than the maximum numeric typecode, so tests like NUMBERP can't
reliably involve a simple comparison. (As long as a mask of all
numeric typecodes will fit in a machine word/FIXNUM, a simple LOGBITP
test can be used instead.) Removed all portable and ARM-specific code
that made assumptions about numeric typecode ordering, made a few more
gvector typecodes available, and used one of them to define a new
"pseudofunction" type. Made the GC update the entrypoints of
pseudofunctions and used them for the undefined-function object and
for the function cells of macros/special-operators.

Since we don't need the subprim jump table at the end of each function
anymore, we can more easily revive the idea of embedded pc-relative
constant data ("constant pools") and initialize FPRs from constant
data, avoiding most remaining traffic between FPRs and GPRs.

I've had a fairly-reproducible cache-coherency problem: on the first
GC in the cold load, the thread misbehaves mysteriously when it
resumes. The GC tries to synchronize the I and D caches on the entire
range of addresses that may contain newly-moved code-vectors. I'm not
at all sure why, but walking that range and flushing the cache for
each code-vector individually seems to avoid the problem (and may actually
be faster.)

Fix ticket:894

Fixed a few typos in error messages/comments/etc.

I -think- that the non-ARM-specific changes (how FASL/image versions are
defined) should bootstrap cleanly, but won't know for sure until this is
committed. (I imagine that the buildbot will complain if not.)

Property svn:eol-style set to native
Property svn:keywords set to Author Date Id Revision

File size: 153.9 KB

Line
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

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: trunk/source/level-1/l1-clos-boot.lisp @ 15237

Download in other formats: