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

Last change on this file since 10309 was 10309, checked in by gb, 11 years ago

Don't assume that (uvref istruct 0) is a symbol; try to use accessors
instead, and hope that I caught everything ...

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