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

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

Use SET-ISTRUCT-CELL-INFO (not (SETF ISTRUCT-CELL-INFO)) in
MAKE-ISTRUCT-CLASS, for bootstrapping.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 140.2 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) (or (find-class (%svref i 0) nil) *istruct-class*)))
2205        (setf (%svref v target::subtag-basic-stream)
2206              #'(lambda (b) (basic-stream.class b)))
2207        (setf (%svref v target::subtag-instance)
2208              #'%class-of-instance)
2209        (setf (%svref v #+ppc-target target::subtag-symbol
2210                      #+x8632-target target::subtag-symbol
2211                      #+x8664-target target::tag-symbol)
2212              #-ppc64-target
2213              #'(lambda (s) (if (eq (symbol-package s) *keyword-package*)
2214                              *keyword-class*
2215                              *symbol-class*))
2216              #+ppc64-target
2217              #'(lambda (s)
2218                  (if s
2219                    (if (eq (symbol-package s) *keyword-package*)
2220                      *keyword-class*
2221                      *symbol-class*)
2222                    *null-class*)))
2223       
2224        (setf (%svref v
2225                      #+ppc-target target::subtag-function
2226                      #+x8632-target target::subtag-function
2227                      #+x8664-target target::tag-function) 
2228              class-of-function-function)
2229        (setf (%svref v target::subtag-vectorH)
2230              #'(lambda (v)
2231                  (let* ((subtype (%array-header-subtype v)))
2232                    (declare (fixnum subtype))
2233                    (if (eql subtype target::subtag-simple-vector)
2234                      *general-vector-class*
2235                      #-x8664-target
2236                      (%svref *ivector-vector-classes*
2237                              #+ppc32-target
2238                              (ash (the fixnum (- subtype ppc32::min-cl-ivector-subtag))
2239                                   (- ppc32::ntagbits))
2240                              #+ppc64-target
2241                              (ash (the fixnum (logand subtype #x7f)) (- ppc64::nlowtagbits))
2242                              #+x8632-target
2243                              (ash (the fixnum (- subtype x8632::min-cl-ivector-subtag))
2244                                   (- x8632::ntagbits)))
2245                      #+x8664-target
2246                      (let* ((class (logand x8664::fulltagmask subtype))
2247                             (idx (ash subtype (- x8664::ntagbits))))
2248                        (cond ((= class x8664::fulltag-immheader-0)
2249                               (%svref *immheader-0-classes* idx))
2250                              ((= class x8664::fulltag-immheader-1)
2251                               (%svref *immheader-1-classes* idx))
2252                              ((= class x8664::fulltag-immheader-2)
2253                               (%svref *immheader-2-classes* idx))
2254                              (t *t-class*)))
2255                               
2256                      ))))
2257        (setf (%svref v target::subtag-lock)
2258              #'(lambda (thing)
2259                  (case (%svref thing target::lock.kind-cell)
2260                    (recursive-lock *recursive-lock-class*)
2261                    (read-write-lock *read-write-lock-class*)
2262                    (t *lock-class*))))
2263        v))
2264
2265
2266
2267
2268
2269  (defun no-class-error (x)
2270    (error "Bug (probably): can't determine class of ~s" x))
2271 
2272
2273                                        ; return frob from table
2274
2275
2276
2277
2278  )                                     ; end let
2279
2280
2281;;; Can't use typep at bootstrapping time.
2282(defun classp (x)
2283  (or (and (typep x 'macptr) (foreign-classp x))                ; often faster
2284      (let ((wrapper (standard-object-p x)))
2285        (or
2286         (and wrapper
2287              (let ((super (%wrapper-class wrapper)))
2288                (memq *class-class* (%inited-class-cpl super t))))))))
2289
2290(set-type-predicate 'class 'classp)
2291
2292(defun subclassp (c1 c2)
2293  (and (classp c1)
2294       (classp c2)
2295       (not (null (memq c2 (%inited-class-cpl c1 t))))))
2296
2297(defun %class-get (class indicator &optional default)
2298  (let ((cell (assq indicator (%class-alist class))))
2299    (if cell (cdr cell) default)))
2300
2301(defun %class-put (class indicator value)
2302  (let ((cell (assq indicator (%class-alist class))))
2303    (if cell
2304      (setf (cdr cell) value)
2305      (push (cons indicator value) (%class-alist class))))
2306  value)
2307 
2308(defsetf %class-get %class-put)
2309
2310(defun %class-remprop (class indicator)
2311  (let* ((handle (cons nil (%class-alist class)))
2312         (last handle))
2313    (declare (dynamic-extent handle))
2314    (while (cdr last)
2315      (if (eq indicator (caar (%cdr last)))
2316        (progn
2317          (setf (%cdr last) (%cddr last))
2318          (setf (%class-alist class) (%cdr handle)))
2319        (setf last (%cdr last))))))   
2320
2321
2322(pushnew :primary-classes *features*)
2323
2324(defun %class-primary-p (class)
2325  (if (typep class 'slots-class)
2326    (%class-get class :primary-p)
2327    t))
2328
2329(defun (setf %class-primary-p) (value class)
2330  (if value
2331    (setf (%class-get class :primary-p) value)
2332    (progn
2333      (%class-remprop class :primary-p)
2334      nil)))
2335
2336;;; Returns the first element of the CPL that is primary
2337(defun %class-or-superclass-primary-p (class)
2338  (unless (class-has-a-forward-referenced-superclass-p class)
2339    (dolist (super (%inited-class-cpl class t))
2340      (when (and (typep super 'standard-class) (%class-primary-p super))
2341        (return super)))))
2342
2343
2344;;; Bootstrapping version of union
2345(unless (fboundp 'union)
2346(defun union (l1 l2)
2347  (dolist (e l1)
2348    (unless (memq e l2)
2349      (push e l2)))
2350  l2)
2351)
2352
2353;; Stub to prevent errors when the user doesn't define types
2354(defun type-intersect (type1 type2)
2355  (cond ((and (null type1) (null type2))
2356         nil)
2357        ((equal type1 type2)
2358         type1)
2359        ((subtypep type1 type2)
2360         type1)
2361        ((subtypep type2 type1)
2362         type2)
2363        (t `(and ,type1 ,type2))
2364        ;(t (error "type-intersect not implemented yet."))
2365        ))
2366
2367(defun %add-direct-methods (method)
2368  (dolist (spec (%method-specializers method))
2369    (%do-add-direct-method spec method)))
2370
2371(defun %do-add-direct-method (spec method)
2372  (pushnew method (specializer.direct-methods spec)))
2373
2374(defun %remove-direct-methods (method)
2375  (dolist (spec (%method-specializers method))
2376    (%do-remove-direct-method spec method)))
2377
2378(defun %do-remove-direct-method (spec method)
2379  (setf (specializer.direct-methods spec)
2380        (nremove method (specializer.direct-methods spec))))
2381
2382(ensure-generic-function 'initialize-instance
2383                         :lambda-list '(instance &rest initargs &key &allow-other-keys))
2384
2385(defmethod find-method ((generic-function standard-generic-function)
2386                        method-qualifiers specializers &optional (errorp t))
2387  (dolist (m (%gf-methods generic-function)
2388           (when errorp
2389             (cerror "Try finding the method again"
2390                     "~s has no method for ~s ~s"
2391                     generic-function method-qualifiers specializers)
2392             (find-method generic-function method-qualifiers specializers
2393                          errorp)))
2394    (flet ((err ()
2395             (error "Wrong number of specializers: ~s" specializers)))
2396      (let ((ss (%method-specializers m))
2397            (q (%method-qualifiers m))
2398            s)
2399        (when (equal q method-qualifiers)
2400          (dolist (spec (canonicalize-specializers specializers nil)
2401                   (if (null ss)
2402                     (return-from find-method m)
2403                     (err)))
2404            (unless (setq s (pop ss))
2405              (err))
2406            (unless (eq s spec)
2407              (return))))))))
2408
2409(defmethod create-reader-method-function ((class slots-class)
2410                                          (reader-method-class standard-reader-method)
2411                                          (dslotd direct-slot-definition))
2412  #+ppc-target
2413  (gvector :function
2414           (uvref *reader-method-function-proto* 0)
2415           (ensure-slot-id (%slot-definition-name dslotd))
2416           'slot-id-value
2417           nil                          ;method-function name
2418           (dpb 1 $lfbits-numreq (ash 1 $lfbits-method-bit)))
2419  #+x86-target
2420  (%clone-x86-function
2421   *reader-method-function-proto*
2422   (ensure-slot-id (%slot-definition-name dslotd))
2423   'slot-id-value
2424   nil                          ;method-function name
2425   (dpb 1 $lfbits-numreq (ash 1 $lfbits-method-bit))))
2426
2427(defmethod create-writer-method-function ((class slots-class)
2428                                          (writer-method-class standard-writer-method)
2429                                          (dslotd direct-slot-definition))
2430  #+ppc-target
2431  (gvector :function
2432           (uvref *writer-method-function-proto* 0)
2433           (ensure-slot-id (%slot-definition-name dslotd))
2434           'set-slot-id-value
2435           nil
2436           (dpb 2 $lfbits-numreq (ash 1 $lfbits-method-bit)))
2437  #+x86-target
2438    (%clone-x86-function
2439     *writer-method-function-proto*
2440     (ensure-slot-id (%slot-definition-name dslotd))
2441     'set-slot-id-value
2442     nil
2443     (dpb 2 $lfbits-numreq (ash 1 $lfbits-method-bit)))
2444  )
2445
2446
2447
2448
2449
2450
2451(defun %make-instance (class-cell &rest initargs)
2452  (declare (dynamic-extent initargs))
2453  (apply #'make-instance
2454         (or (class-cell-class class-cell) (class-cell-name  (the class-cell class-cell)))
2455         initargs))
2456
2457
2458(defmethod make-instance ((class symbol) &rest initargs)
2459  (declare (dynamic-extent initargs))
2460  (apply 'make-instance (find-class class) initargs))
2461
2462
2463(defmethod make-instance ((class standard-class) &rest initargs &key &allow-other-keys)
2464  (declare (dynamic-extent initargs))
2465  (%make-std-instance class initargs))
2466
2467(defmethod make-instance ((class std-class) &rest initargs &key &allow-other-keys)
2468  (declare (dynamic-extent initargs))
2469  (%make-std-instance class initargs))
2470
2471
2472(defun %make-std-instance (class initargs)
2473  (setq initargs (default-initargs class initargs))
2474  (when initargs
2475    (apply #'check-initargs
2476           nil class initargs t
2477           #'initialize-instance #'allocate-instance #'shared-initialize
2478           nil))
2479  (let ((instance (apply #'allocate-instance class initargs)))
2480    (apply #'initialize-instance instance initargs)
2481    instance))
2482
2483(defun default-initargs (class initargs)
2484  (unless (std-class-p class)
2485    (setq class (require-type class 'std-class)))
2486  (when (null (%class.cpl class)) (update-class class t))
2487  (let ((defaults ()))
2488    (dolist (key.form (%class-default-initargs class))
2489      (unless (pl-search initargs (%car key.form))
2490        (setq defaults
2491              (list* (funcall (caddr key.form))
2492                     (%car key.form)
2493                     defaults))))
2494    (when defaults
2495      (setq initargs (append initargs (nreverse defaults))))
2496    initargs))
2497
2498
2499(defun %allocate-std-instance (class)
2500  (unless (class-finalized-p class)
2501    (finalize-inheritance class))
2502  (let* ((wrapper (%class.own-wrapper class))
2503         (len (length (%wrapper-instance-slots wrapper))))
2504    (declare (fixnum len))
2505    (make-instance-vector wrapper len)))
2506
2507
2508
2509
2510(defmethod copy-instance ((instance standard-object))
2511  (let* ((new-slots (copy-uvector (instance.slots instance)))
2512         (copy (gvector :instance 0 (instance-class-wrapper instance) new-slots)))
2513    (setf (instance.hash copy) (strip-tag-to-fixnum copy)
2514          (slot-vector.instance new-slots) copy)))
2515
2516(defmethod initialize-instance ((instance standard-object) &rest initargs)
2517  (declare (dynamic-extent initargs))
2518  (apply 'shared-initialize instance t initargs))
2519
2520
2521(defmethod reinitialize-instance ((instance standard-object) &rest initargs)
2522  (declare (dynamic-extent initargs))
2523  (when initargs
2524    (check-initargs 
2525     instance nil initargs t #'reinitialize-instance #'shared-initialize))
2526  (apply 'shared-initialize instance nil initargs))
2527
2528(defmethod shared-initialize ((instance standard-object) slot-names &rest initargs)
2529  (declare (dynamic-extent initargs))
2530  (%shared-initialize instance slot-names initargs))
2531
2532(defmethod shared-initialize ((instance standard-generic-function) slot-names
2533                              &rest initargs)
2534  (declare (dynamic-extent initargs))
2535  (%shared-initialize instance slot-names initargs))
2536
2537
2538;;; Slot-value, slot-boundp, slot-makunbound, etc.
2539(declaim (inline find-slotd))
2540(defun find-slotd (name slots)
2541  (find name slots :key #'%slot-definition-name))
2542
2543(declaim (inline %std-slot-vector-value))
2544
2545(defun %std-slot-vector-value (slot-vector slotd)
2546  (let* ((loc (standard-effective-slot-definition.location slotd)))
2547    (symbol-macrolet ((instance (slot-vector.instance slot-vector)))
2548      (typecase loc
2549        (fixnum
2550         (%slot-ref slot-vector loc))
2551        (cons
2552         (let* ((val (%cdr loc)))
2553           (if (eq val (%slot-unbound-marker))
2554             (slot-unbound (class-of instance) instance (standard-effective-slot-definition.name slotd))
2555           val)))
2556      (t
2557       (error "Slot definition ~s has invalid location ~s (allocation ~s)."
2558              slotd loc (slot-definition-allocation slotd)))))))
2559
2560
2561(defmethod slot-value-using-class ((class standard-class)
2562                                   instance
2563                                   (slotd standard-effective-slot-definition))
2564  (ecase (standard-slot-definition.allocation slotd)
2565    ((:instance :class)
2566     (%std-slot-vector-value (instance-slots instance) slotd))))
2567
2568(defun %maybe-std-slot-value-using-class (class instance slotd)
2569  (if (and (eql (typecode class) target::subtag-instance)
2570           (eql (typecode slotd) target::subtag-instance)
2571           (eq *standard-effective-slot-definition-class-wrapper*
2572               (instance.class-wrapper slotd))
2573           (eq *standard-class-wrapper* (instance.class-wrapper class)))
2574    (%std-slot-vector-value (instance-slots instance) slotd)
2575    (slot-value-using-class class instance slotd)))
2576
2577
2578(declaim (inline  %set-std-slot-vector-value))
2579
2580(defun %set-std-slot-vector-value (slot-vector slotd  new)
2581  (let* ((loc (standard-effective-slot-definition.location slotd))
2582         (type (standard-effective-slot-definition.type slotd))
2583         (type-predicate (standard-effective-slot-definition.type-predicate slotd)))
2584    (unless (or (eq new (%slot-unbound-marker))
2585                (null type-predicate)
2586                (funcall type-predicate new))
2587      (error 'bad-slot-type
2588             :instance (slot-vector.instance slot-vector)
2589             :datum new :expected-type type
2590             :slot-definition slotd))
2591    (typecase loc
2592      (fixnum
2593       (setf (%svref slot-vector loc) new))
2594      (cons
2595       (setf (%cdr loc) new))
2596      (t
2597       (error "Slot definition ~s has invalid location ~s (allocation ~s)."
2598              slotd loc (slot-definition-allocation slotd))))))
2599 
2600 
2601(defmethod (setf slot-value-using-class)
2602    (new
2603     (class standard-class)
2604     instance
2605     (slotd standard-effective-slot-definition))
2606  (ecase (standard-slot-definition.allocation slotd)
2607    ((:instance :class)
2608     (%set-std-slot-vector-value (instance-slots instance) slotd new))))
2609
2610
2611(defun %maybe-std-setf-slot-value-using-class (class instance slotd new)
2612  (if (and (eql (typecode class) target::subtag-instance)
2613           (eql (typecode slotd) target::subtag-instance)
2614           (eq *standard-effective-slot-definition-class-wrapper*
2615               (instance.class-wrapper slotd))
2616           (eq *standard-class-wrapper* (instance.class-wrapper class)))
2617    ;; Not safe to use instance.slots here, since the instance is not
2618    ;; definitely of type SUBTAG-INSTANCE.  (Anyway, INSTANCE-SLOTS
2619    ;; should be inlined here.
2620    (%set-std-slot-vector-value (instance-slots instance) slotd new)
2621    (setf (slot-value-using-class class instance slotd) new)))
2622
2623(defmethod slot-value-using-class ((class funcallable-standard-class)
2624                                   instance
2625                                   (slotd standard-effective-slot-definition))
2626  (%std-slot-vector-value (gf.slots instance) slotd))
2627
2628(defmethod (setf slot-value-using-class)
2629    (new
2630     (class funcallable-standard-class)
2631     instance
2632     (slotd standard-effective-slot-definition))
2633  (%set-std-slot-vector-value (gf.slots instance) slotd new))
2634
2635(defun slot-value (instance slot-name)
2636  (let* ((class (class-of instance))
2637           (slotd (find-slotd slot-name (%class-slots class))))
2638      (if slotd
2639       (slot-value-using-class class instance slotd)
2640       (restart-case
2641           (values (slot-missing class instance slot-name 'slot-value))
2642         (continue ()
2643           :report "Try accessing the slot again"
2644           (slot-value instance slot-name))
2645         (use-value (value)
2646           :report "Return a value"
2647           :interactive (lambda ()
2648                          (format *query-io* "~&Value to use: ")
2649                          (list (read *query-io*)))
2650           value)))))
2651   
2652
2653
2654(defmethod slot-unbound (class instance slot-name)
2655  (declare (ignore class))
2656  (restart-case (error 'unbound-slot :name slot-name :instance instance)
2657    (use-value (value)
2658      :report "Return a value"
2659      :interactive (lambda ()
2660                     (format *query-io* "~&Value to use: ")
2661                     (list (read *query-io*)))
2662      value)))
2663
2664
2665
2666(defmethod slot-makunbound-using-class ((class slots-class)
2667                                        instance
2668                                        (slotd standard-effective-slot-definition))
2669  (setf (slot-value-using-class class instance slotd) (%slot-unbound-marker))
2670  instance)
2671
2672(defmethod slot-missing (class object slot-name operation &optional new-value)
2673  (declare (ignore class operation new-value))
2674  (error "~s has no slot named ~s." object slot-name))
2675
2676
2677(defun set-slot-value (instance name value)
2678  (let* ((class (class-of instance))
2679             (slotd (find-slotd  name (%class-slots class))))
2680        (if slotd
2681          (setf (slot-value-using-class class instance slotd) value)
2682          (progn           
2683            (slot-missing class instance name 'setf value)
2684            value))))
2685
2686(defsetf slot-value set-slot-value)
2687
2688(defun slot-makunbound (instance name)
2689  (let* ((class (class-of instance))
2690         (slotd (find-slotd name (%class-slots class))))
2691    (if slotd
2692      (slot-makunbound-using-class class instance slotd)
2693      (slot-missing class instance name 'slot-makunbound))
2694    instance))
2695
2696(defun %std-slot-vector-boundp (slot-vector slotd)
2697  (let* ((loc (standard-effective-slot-definition.location slotd)))
2698    (typecase loc
2699      (fixnum
2700       (not (eq (%svref slot-vector loc) (%slot-unbound-marker))))
2701      (cons
2702       (not (eq (%cdr loc) (%slot-unbound-marker))))
2703      (t
2704       (error "Slot definition ~s has invalid location ~s (allocation ~s)."
2705                slotd loc (slot-definition-allocation slotd))))))
2706
2707(defmethod slot-boundp-using-class ((class standard-class)
2708                                    instance
2709                                    (slotd standard-effective-slot-definition))
2710  (ecase (standard-slot-definition.allocation slotd)
2711    ((:instance :class)
2712     (%std-slot-vector-boundp (instance-slots instance) slotd))))
2713
2714(defmethod slot-boundp-using-class ((class funcallable-standard-class)
2715                                    instance
2716                                    (slotd standard-effective-slot-definition))
2717  (%std-slot-vector-boundp (gf.slots instance) slotd))
2718
2719
2720
2721(defun slot-boundp (instance name)
2722  (let* ((class (class-of instance))
2723         (slotd (find-slotd name (%class-slots class))))
2724    (if slotd
2725      (slot-boundp-using-class class instance slotd)
2726      (values (slot-missing class instance name 'slot-boundp)))))
2727
2728(defun slot-value-if-bound (instance name &optional default)
2729  (if (slot-boundp instance name)
2730    (slot-value instance name)
2731    default))
2732
2733(defun slot-exists-p (instance name)
2734  (let* ((class (class-of instance))
2735         (slots  (class-slots class)))
2736    (find-slotd name slots)))
2737
2738
2739(defun slot-id-value (instance slot-id)
2740  (let* ((wrapper (or (standard-object-p instance)
2741                    (%class-own-wrapper (class-of instance)))))
2742    (funcall (%wrapper-slot-id-value wrapper) instance slot-id)))
2743
2744(defun set-slot-id-value (instance slot-id value)
2745  (let* ((wrapper (or (standard-object-p instance)
2746                    (%class-own-wrapper (class-of instance)))))
2747    (funcall (%wrapper-set-slot-id-value wrapper) instance slot-id value)))
2748
2749;;; returns nil if (apply gf args) wil cause an error because of the
2750;;; non-existance of a method (or if GF is not a generic function or the name
2751;;; of a generic function).
2752(defun method-exists-p (gf &rest args)
2753  (declare (dynamic-extent args))
2754  (when (symbolp gf)
2755    (setq gf (fboundp gf)))
2756  (when (typep gf 'standard-generic-function)
2757    (or (null args)
2758        (let* ((methods (sgf.methods gf)))
2759          (dolist (m methods)
2760            (when (null (%method-qualifiers m))
2761              (let ((specializers (%method-specializers m))
2762                    (args args))
2763                (when (dolist (s specializers t)
2764                        (unless (cond ((typep s 'eql-specializer) 
2765                                       (eql (eql-specializer-object s)
2766                                            (car args)))
2767                                      (t (memq s (%inited-class-cpl
2768                                                  (class-of (car args))))))
2769                          (return nil))
2770                        (pop args))
2771                  (return-from method-exists-p m)))))
2772          nil))))
2773
2774(defun funcall-if-method-exists (gf &optional default &rest args)
2775  (declare (dynamic-extent args))
2776  (if (apply #'method-exists-p gf args)
2777    (apply gf args)
2778    (if default (apply default args))))
2779
2780
2781(defun find-specializer (specializer)
2782  (if (and (listp specializer) (eql (car specializer) 'eql))
2783    (intern-eql-specializer (cadr specializer))
2784    (find-class specializer)))
2785
2786(defmethod make-instances-obsolete ((class symbol))
2787  (make-instances-obsolete (find-class class)))
2788
2789(defmethod make-instances-obsolete ((class standard-class))
2790  (let ((wrapper (%class-own-wrapper class)))
2791    (when wrapper
2792      (setf (%class-own-wrapper class) nil)
2793      (make-wrapper-obsolete wrapper)))
2794  class)
2795
2796(defmethod make-instances-obsolete ((class funcallable-standard-class))
2797  (let ((wrapper (%class.own-wrapper class)))
2798    (when wrapper
2799      (setf (%class-own-wrapper class) nil)
2800      (make-wrapper-obsolete wrapper)))
2801  class)
2802
2803(defmethod make-instances-obsolete ((class structure-class))
2804  ;; could maybe warn that instances are obsolete, but there's not
2805  ;; much that we can do about that.
2806  class)
2807
2808
2809
2810;;; A wrapper is made obsolete by setting the hash-index & instance-slots to 0
2811;;; The instance slots are saved for update-obsolete-instance
2812;;; by consing them onto the class slots.
2813;;; Method dispatch looks at the hash-index.
2814;;; slot-value & set-slot-value look at the instance-slots.
2815;;; Each wrapper may have an associated forwarding wrapper, which must
2816;;; also be made obsolete.  The forwarding-wrapper is stored in the
2817;;; hash table below keyed on the wrapper-hash-index of the two
2818;;; wrappers.
2819(defvar *forwarding-wrapper-hash-table* (make-hash-table :test 'eq)) 
2820
2821
2822(defun make-wrapper-obsolete (wrapper)
2823  (without-interrupts
2824   (let ((forwarding-info
2825          (unless (eql 0 (%wrapper-instance-slots wrapper))   ; already forwarded or obsolete?
2826            (%cons-forwarding-info (%wrapper-instance-slots wrapper)
2827                                   (%wrapper-class-slots wrapper)))))
2828     (when forwarding-info
2829       (setf (%wrapper-hash-index wrapper) 0
2830             (%wrapper-cpl wrapper) nil
2831             (%wrapper-instance-slots wrapper) 0
2832             (%wrapper-forwarding-info wrapper) forwarding-info
2833             (%wrapper-slot-id->slotd wrapper) #'%slot-id-lookup-obsolete
2834             (%wrapper-slot-id-value wrapper) #'%slot-id-ref-obsolete
2835             (%wrapper-set-slot-id-value wrapper) #'%slot-id-set-obsolete
2836             ))))
2837  wrapper)
2838
2839(defun %clear-class-primary-slot-accessor-offsets (class)
2840  (let ((info-list (%class-get class '%class-primary-slot-accessor-info)))
2841    (dolist (info info-list)
2842      (setf (%slot-accessor-info.offset info) nil))))
2843
2844(defun primary-class-slot-offset (class slot-name)
2845  (dolist (super (%class.cpl class))
2846    (let* ((pos (and (typep super 'standard-class)
2847                     (%class-primary-p super)
2848                     (dolist (slot (%class-slots class))
2849                       (when (eq (%slot-definition-allocation slot)
2850                                 :instance)
2851                         (when (eq slot-name (%slot-definition-name slot))
2852                           (return (%slot-definition-location slot))))))))
2853      (when pos (return pos)))))
2854
2855;;; Called by the compiler-macro expansion for slot-value
2856;;; info is the result of a %class-primary-slot-accessor-info call.
2857;;; value-form is specified if this is set-slot-value.
2858;;; Otherwise it's slot-value.
2859(defun primary-class-slot-value (instance info &optional (value-form nil value-form-p))
2860  (let ((slot-name (%slot-accessor-info.slot-name info)))
2861    (prog1
2862      (if value-form-p
2863        (setf (slot-value instance slot-name) value-form)
2864        (slot-value instance slot-name))
2865      (setf (%slot-accessor-info.offset info)
2866            (primary-class-slot-offset (class-of instance) slot-name)))))
2867
2868(defun primary-class-accessor (instance info &optional (value-form nil value-form-p))
2869  (let ((accessor (%slot-accessor-info.accessor info)))
2870    (prog1
2871      (if value-form-p
2872        (funcall accessor value-form instance)
2873        (funcall accessor instance))
2874      (let ((methods (compute-applicable-methods
2875                      accessor
2876                      (if value-form-p (list value-form instance) (list instance))))
2877            method)
2878        (when (and (eql (length methods) 1)
2879                   (typep (setq method (car methods)) 'standard-accessor-method))
2880          (let* ((slot-name (method-slot-name method)))
2881            (setf (%slot-accessor-info.offset info)
2882                  (primary-class-slot-offset (class-of instance) slot-name))))))))
2883
2884(defun exchange-slot-vectors-and-wrappers (a b)
2885  (if (typep a 'generic-function)
2886    (let* ((temp-wrapper (gf.instance.class-wrapper a))
2887           (orig-a-slots (gf.slots a))
2888           (orig-b-slots (gf.slots b)))
2889      (setf (gf.instance.class-wrapper a) (gf.instance.class-wrapper b)
2890            (gf.instance.class-wrapper b) temp-wrapper
2891            (gf.slots a) orig-b-slots
2892            (gf.slots b) orig-a-slots
2893            (slot-vector.instance orig-a-slots) b
2894            (slot-vector.instance orig-b-slots) a))   
2895    (let* ((temp-wrapper (instance.class-wrapper a))
2896           (orig-a-slots (instance.slots a))
2897           (orig-b-slots (instance.slots b)))
2898      (setf (instance.class-wrapper a) (instance.class-wrapper b)
2899            (instance.class-wrapper b) temp-wrapper
2900            (instance.slots a) orig-b-slots
2901            (instance.slots b) orig-a-slots
2902            (slot-vector.instance orig-a-slots) b
2903            (slot-vector.instance orig-b-slots) a))))
2904
2905
2906
2907
2908;;; How slot values transfer (from PCL):
2909;;;
2910;;; local  --> local        transfer
2911;;; local  --> shared       discard
2912;;; local  -->  --          discard
2913;;; shared --> local        transfer
2914;;; shared --> shared       discard
2915;;; shared -->  --          discard
2916;;;  --    --> local        added
2917;;;  --    --> shared        --
2918;;;
2919;;; See make-wrapper-obsolete to see how we got here.
2920;;; A word about forwarding.  When a class is made obsolete, the
2921;;; %wrapper-instance-slots slot of its wrapper is set to 0.
2922;;; %wrapper-class-slots = (instance-slots . class-slots)
2923;;; Note: this should stack-cons the new-instance if we can reuse the
2924;;; old instance or it's forwarded value.
2925(defun update-obsolete-instance (instance)
2926  (let* ((added ())
2927         (discarded ())
2928         (plist ()))
2929    (without-interrupts                 ; Not -close- to being correct
2930     (let* ((old-wrapper (standard-object-p instance)))
2931       (unless old-wrapper
2932         (when (standard-generic-function-p instance)
2933           (setq old-wrapper (gf.instance.class-wrapper instance)))
2934         (unless old-wrapper
2935           (report-bad-arg instance '(or standard-instance standard-generic-function))))
2936       (when (eql 0 (%wrapper-instance-slots old-wrapper))   ; is it really obsolete?
2937         (let* ((class (%wrapper-class old-wrapper))
2938                (new-wrapper (or (%class.own-wrapper class)
2939                                 (progn
2940                                   (update-class class t)
2941                                   (%class.own-wrapper class))))
2942                (forwarding-info (%wrapper-forwarding-info old-wrapper))
2943                (old-class-slots (%forwarding-class-slots forwarding-info))
2944                (old-instance-slots (%forwarding-instance-slots forwarding-info))
2945                (new-instance-slots (%wrapper-instance-slots new-wrapper))
2946                (new-class-slots (%wrapper-class-slots new-wrapper))
2947                (new-instance (allocate-instance class))
2948                (old-slot-vector (instance.slots instance))
2949                (new-slot-vector (instance.slots new-instance)))
2950             ;; Lots to do.  Hold onto your hat.
2951             (let* ((old-size (uvsize old-instance-slots))
2952                    (new-size (uvsize new-instance-slots)))
2953               (declare (fixnum old-size new-size))
2954               (dotimes (i old-size)
2955                 (declare (fixnum i))
2956                 (let* ((slot-name (%svref old-instance-slots i))
2957                        (pos (%vector-member slot-name new-instance-slots))
2958                        (val (%svref old-slot-vector (%i+ i 1))))
2959                   (if pos
2960                     (setf (%svref new-slot-vector (%i+ pos 1)) val)
2961                     (progn
2962                       (push slot-name discarded)
2963                       (unless (eq val (%slot-unbound-marker))
2964                         (setf (getf plist slot-name) val))))))
2965               ;; Go through old class slots
2966               (dolist (pair old-class-slots)
2967                 (let* ((slot-name (%car pair))
2968                        (val (%cdr pair))
2969                        (pos (%vector-member slot-name new-instance-slots)))
2970                   (if pos
2971                     (setf (%svref new-slot-vector (%i+ pos 1)) val)
2972                     (progn
2973                       (push slot-name discarded)
2974                       (unless (eq val (%slot-unbound-marker))
2975                         (setf (getf plist slot-name) val))))))
2976               ; Go through new instance slots
2977               (dotimes (i new-size)
2978                 (declare (fixnum i))
2979                 (let* ((slot-name (%svref new-instance-slots i)))
2980                   (unless (or (%vector-member slot-name old-instance-slots)
2981                               (assoc slot-name old-class-slots))
2982                     (push slot-name added))))
2983               ;; Go through new class slots
2984               (dolist (pair new-class-slots)
2985                 (let ((slot-name (%car pair)))
2986                   (unless (or (%vector-member slot-name old-instance-slots)
2987                               (assoc slot-name old-class-slots))
2988                     (push slot-name added))))
2989               (exchange-slot-vectors-and-wrappers new-instance instance))))))
2990    ;; run user code with interrupts enabled.
2991    (update-instance-for-redefined-class instance added discarded plist))
2992  instance)
2993           
2994         
2995(defmethod update-instance-for-redefined-class ((instance standard-object)
2996                                                added-slots
2997                                                discarded-slots
2998                                                property-list
2999                                                &rest initargs)
3000  (declare (ignore discarded-slots property-list))
3001  (when initargs
3002    (check-initargs
3003     instance nil initargs t
3004     #'update-instance-for-redefined-class #'shared-initialize))
3005  (apply #'shared-initialize instance added-slots initargs))
3006
3007(defmethod update-instance-for-redefined-class ((instance standard-generic-function)
3008                                                added-slots
3009                                                discarded-slots
3010                                                property-list
3011                                                &rest initargs)
3012  (declare (ignore discarded-slots property-list))
3013  (when initargs
3014    (check-initargs
3015     instance nil initargs t
3016     #'update-instance-for-redefined-class #'shared-initialize))
3017  (apply #'shared-initialize instance added-slots initargs))
3018
3019(defun check-initargs (instance class initargs errorp &rest functions)
3020  (declare (dynamic-extent functions))
3021  (declare (list functions))
3022  (setq class (require-type (or class (class-of instance)) 'std-class))
3023  (unless (getf initargs :allow-other-keys)
3024    (let ((initvect (initargs-vector instance class functions)))
3025      (when (eq initvect t) (return-from check-initargs nil))
3026      (do* ((tail initargs (cddr tail))
3027            (initarg (car tail) (car tail))
3028            bad-keys? bad-key)
3029           ((null (cdr tail))
3030            (if bad-keys?
3031              (if errorp
3032                (signal-program-error
3033                 "~s is an invalid initarg to ~s for ~s.~%~
3034                                    Valid initargs: ~s."
3035                 bad-key
3036                 (function-name (car functions))
3037                 class (coerce initvect 'list))
3038                (values bad-keys? bad-key))))
3039        (if (eq initarg :allow-other-keys)
3040          (if (cadr tail)
3041            (return))                   ; (... :allow-other-keys t ...)
3042          (unless (or bad-keys? (%vector-member initarg initvect))
3043            (setq bad-keys? t
3044                  bad-key initarg)))))))
3045
3046(defun initargs-vector (instance class functions)
3047  (let ((index (cadr (assq (car functions) *initialization-invalidation-alist*))))
3048    (unless index
3049      (error "Unknown initialization function: ~s." (car functions)))
3050    (let ((initvect (%svref (instance-slots class) index)))
3051      (unless initvect
3052        (setf (%svref (instance-slots class) index) 
3053              (setq initvect (compute-initargs-vector instance class functions))))
3054      initvect)))
3055
3056
3057;; This is used for compile-time defclass option checking.
3058(defun class-keyvect (class-arg initargs)
3059  (let* ((class (if (typep class-arg 'class) class-arg (find-class class-arg nil)))
3060         (meta-arg (getf initargs :metaclass (if (and class (not (typep class 'forward-referenced-class)))
3061                                               (class-of class)
3062                                               *standard-class-class*)))
3063         (meta-spec (if (quoted-form-p meta-arg) (%cadr meta-arg) meta-arg))
3064         (meta (if (typep meta-spec 'class) meta-spec (find-class meta-spec nil))))
3065    (if (and meta (not (typep meta 'forward-referenced-class)))
3066      (compute-initargs-vector class meta (list #'initialize-instance #'allocate-instance #'shared-initialize) t)
3067      t)))
3068
3069(defun compute-initargs-vector (instance class functions &optional require-rest)
3070  (let ((initargs (class-slot-initargs class))
3071        (cpl (%inited-class-cpl class)))
3072    (dolist (f functions)         ; for all the functions passed
3073      #+no
3074      (if (logbitp $lfbits-aok-bit (lfun-bits f))
3075        (return-from compute-initargs-vector t))
3076      (dolist (method (%gf-methods f))   ; for each applicable method
3077        (let ((spec (car (%method-specializers method))))
3078          (when (if (typep spec 'eql-specializer)
3079                  (eql instance (eql-specializer-object spec))
3080                  (memq spec cpl))
3081            (let* ((func (%inner-method-function method))
3082                   (keyvect (if (and (logbitp $lfbits-aok-bit (lfun-bits func))
3083                                     (or (not require-rest)
3084                                         (logbitp $lfbits-rest-bit (lfun-bits func))))
3085                              (return-from compute-initargs-vector t)
3086                              (lfun-keyvect func))))
3087              (dovector (key keyvect)
3088                (pushnew key initargs)))))))   ; add all of the method's keys
3089    (apply #'vector initargs)))
3090
3091
3092
3093;;; A useful function
3094(defun class-make-instance-initargs (class)
3095  (setq class (require-type (if (symbolp class) (find-class class) class)
3096                            'std-class))
3097  (flet ((iv (class &rest functions)
3098           (declare (dynamic-extent functions))
3099           (initargs-vector (class-prototype class) class functions)))
3100    (let ((initvect (apply #'iv
3101                           class
3102                           #'initialize-instance #'allocate-instance #'shared-initialize
3103                           nil)))
3104      (if (eq initvect 't)
3105        t
3106        (concatenate 'list initvect)))))
3107
3108                                   
3109
3110;;; This is part of the MOP
3111;;; Maybe it was, at one point in the distant past ...
3112(defmethod class-slot-initargs ((class slots-class))
3113  (collect ((initargs))
3114    (dolist (slot (%class-slots class) (initargs))
3115      (dolist (i (%slot-definition-initargs slot))
3116        (initargs i)))))
3117
3118 
3119(defun maybe-update-obsolete-instance (instance)
3120  (let ((wrapper (standard-object-p instance)))
3121    (unless wrapper
3122      (if (standard-generic-function-p instance)
3123        (setq wrapper (generic-function-wrapper instance))
3124        (when (typep instance 'funcallable-standard-object)
3125          (setq wrapper (gf.instance.class-wrapper instance))))
3126     
3127      (unless wrapper
3128        (report-bad-arg instance '(or standard-object standard-generic-function))))
3129    (when (eql 0 (%wrapper-hash-index wrapper))
3130      (update-obsolete-instance instance)))
3131  instance)
3132
3133
3134;;; If you ever reference one of these through anyone who might call
3135;;; update-obsolete-instance, you will lose badly.
3136(defun %maybe-forwarded-instance (instance)
3137  (maybe-update-obsolete-instance instance)
3138  instance)
3139
3140
3141
3142(defmethod change-class (instance
3143                         (new-class symbol)
3144                         &rest initargs &key &allow-other-keys)
3145  (declare (dynamic-extent initargs))
3146  (apply #'change-class instance (find-class new-class) initargs))
3147
3148(defmethod change-class ((instance standard-object)
3149                         (new-class standard-class)
3150                          &rest initargs &key &allow-other-keys)
3151  (declare (dynamic-extent initargs))
3152  (%change-class instance new-class initargs))
3153
3154(defmethod change-class ((instance funcallable-standard-object)
3155                         (new-class funcallable-standard-class)
3156                         &rest initargs &key &allow-other-keys)
3157  (declare (dynamic-extent initargs))
3158  (%change-class instance new-class initargs))
3159 
3160
3161(defun %change-class (object new-class initargs)
3162  (let* ((old-class (class-of object))
3163         (old-wrapper (%class.own-wrapper old-class))
3164         (new-wrapper (or (%class.own-wrapper new-class)
3165                          (progn
3166                            (update-class new-class t)
3167                            (%class.own-wrapper new-class))))
3168         (old-instance-slots-vector (%wrapper-instance-slots old-wrapper))
3169         (new-instance-slots-vector (%wrapper-instance-slots new-wrapper))
3170         (num-new-instance-slots (length new-instance-slots-vector))
3171         (new-object (allocate-instance new-class)))
3172    (declare (fixnum num-new-instance-slots)
3173             (simple-vector new-instance-slots-vector old-instance-slots-vector))
3174    ;; Retain local slots shared between the new class and the old.
3175    (do* ((new-pos 0 (1+ new-pos))
3176          (new-slot-location 1 (1+ new-slot-location)))
3177         ((= new-pos num-new-instance-slots))
3178      (declare (fixnum new-pos new-slot-location))
3179      (let* ((old-pos (position (svref new-instance-slots-vector new-pos)
3180                                old-instance-slots-vector :test #'eq)))
3181        (when old-pos
3182          (setf (%standard-instance-instance-location-access
3183                 new-object
3184                 new-slot-location)
3185                (%standard-instance-instance-location-access
3186                 object
3187                 (the fixnum (1+ (the fixnum old-pos))))))))
3188    ;; If the new class defines a local slot whos name matches
3189    ;; that of a shared slot in the old class, the shared slot's
3190    ;; value is used to initialize the new instance's local slot.
3191    (dolist (shared-slot (%wrapper-class-slots old-wrapper))
3192      (destructuring-bind (name . value) shared-slot
3193        (let* ((new-slot-pos (position name new-instance-slots-vector
3194                                       :test #'eq)))
3195          (if new-slot-pos
3196            (setf (%standard-instance-instance-location-access
3197                   new-object
3198                   (the fixnum (1+ (the fixnum new-slot-pos))))
3199                  value)))))
3200    (exchange-slot-vectors-and-wrappers object new-object)
3201    (apply #'update-instance-for-different-class new-object object initargs)
3202    object))
3203
3204(defmethod update-instance-for-different-class ((previous standard-object)
3205                                                (current standard-object)
3206                                                &rest initargs)
3207  (declare (dynamic-extent initargs))
3208  (%update-instance-for-different-class previous current initargs))
3209
3210(defun %update-instance-for-different-class (previous current initargs)
3211  (when initargs
3212    (check-initargs
3213     current nil initargs t
3214     #'update-instance-for-different-class #'shared-initialize))
3215  (let* ((previous-slots (class-slots (class-of previous)))
3216         (current-slots (class-slots (class-of current)))
3217         (added-slot-names ()))
3218    (dolist (s current-slots)
3219      (let* ((name (%slot-definition-name s)))
3220        (unless (find-slotd name previous-slots)
3221          (push name added-slot-names))))
3222    (apply #'shared-initialize
3223           current
3224           added-slot-names
3225           initargs)))
3226
3227
3228
3229
3230;;; Clear all the valid initargs caches.
3231(defun clear-valid-initargs-caches ()
3232  (map-classes #'(lambda (name class)
3233                   (declare (ignore name))
3234                   (when (std-class-p class)
3235                     (setf (%class.make-instance-initargs class) nil
3236                           (%class.reinit-initargs class) nil
3237                           (%class.redefined-initargs class) nil
3238                           (%class.changed-initargs class) nil)))))
3239
3240(defun clear-clos-caches ()
3241  (clear-all-gf-caches)
3242  (clear-valid-initargs-caches))
3243
3244(defmethod allocate-instance ((class standard-class) &rest initargs)
3245  (declare (ignore initargs))
3246  (%allocate-std-instance class))
3247
3248(defmethod allocate-instance ((class funcallable-standard-class) &rest initargs)
3249  (declare (ignore initargs))
3250  (%allocate-gf-instance class))
3251
3252(unless *initialization-invalidation-alist*
3253  (setq *initialization-invalidation-alist*
3254        (list (list #'initialize-instance %class.make-instance-initargs)
3255              (list #'allocate-instance %class.make-instance-initargs)
3256              (list #'reinitialize-instance %class.reinit-initargs)
3257              (list #'shared-initialize 
3258                    %class.make-instance-initargs %class.reinit-initargs
3259                    %class.redefined-initargs %class.changed-initargs)
3260              (list #'update-instance-for-redefined-class
3261                    %class.redefined-initargs)
3262              (list #'update-instance-for-different-class
3263                    %class.changed-initargs))))
3264
3265
3266(defstatic *initialization-function-lists*
3267  (list (list #'initialize-instance #'allocate-instance #'shared-initialize)
3268        (list #'reinitialize-instance #'shared-initialize)
3269        (list #'update-instance-for-redefined-class #'shared-initialize)
3270        (list #'update-instance-for-different-class #'shared-initialize)))
3271
3272
3273
3274(unless *clos-initialization-functions*
3275  (setq *clos-initialization-functions*
3276        (list #'initialize-instance #'allocate-instance #'shared-initialize
3277              #'reinitialize-instance
3278              #'update-instance-for-different-class #'update-instance-for-redefined-class)))
3279
3280(defun compute-initialization-functions-alist ()
3281  (let ((res nil)
3282        (lists *initialization-function-lists*))
3283    (dolist (cell *initialization-invalidation-alist*)
3284      (let (res-list)
3285        (dolist (slot-num (cdr cell))
3286          (push
3287           (ecase slot-num
3288             (#.%class.make-instance-initargs 
3289              (assq #'initialize-instance lists))
3290             (#.%class.reinit-initargs
3291              (assq #'reinitialize-instance lists))
3292             (#.%class.redefined-initargs
3293              (assq #'update-instance-for-redefined-class lists))
3294             (#.%class.changed-initargs
3295              (assq #'update-instance-for-different-class lists)))
3296           res-list))
3297        (push (cons (car cell) (nreverse res-list)) res)))
3298    (setq *initialization-functions-alist* res)))
3299
3300(compute-initialization-functions-alist)
3301
3302                 
3303
3304
3305
3306
3307;;; Need to define this for all of the BUILT-IN-CLASSes.
3308(defmethod class-prototype ((class class))
3309  (%class.prototype class))
3310
3311(defmethod class-prototype ((class std-class))
3312  (or (%class.prototype class)
3313      (setf (%class.prototype class) (allocate-instance class))))
3314
3315
3316(defun gf-class-prototype (class)
3317  (%allocate-gf-instance class))
3318
3319
3320
3321(defmethod class-prototype ((class structure-class))
3322  (or (%class.prototype class)
3323      (setf (%class.prototype class)
3324            (let* ((sd (gethash (class-name class) %defstructs%))
3325                   (slots (class-slots class))
3326                   (proto (allocate-typed-vector :struct (1+ (length slots)))))
3327              (setf (uvref proto 0) (sd-superclasses sd))
3328              (dolist (slot slots proto)
3329                (setf (slot-value-using-class class proto slot)
3330                      (funcall (slot-definition-initfunction slot))))))))
3331
3332
3333(defmethod remove-method ((generic-function standard-generic-function)
3334                          (method standard-method))
3335  (when (eq generic-function (%method-gf method))
3336    (%remove-standard-method-from-containing-gf method))
3337  generic-function)
3338
3339
3340
3341(defmethod function-keywords ((method standard-method))
3342  (let ((f (%inner-method-function method)))
3343    (values
3344     (concatenate 'list (lfun-keyvect f))
3345     (%ilogbitp $lfbits-aok-bit (lfun-bits f)))))
3346
3347(defmethod no-next-method ((generic-function standard-generic-function)
3348                           (method standard-method)
3349                           &rest args)
3350  (error "There is no next method for ~s~%args: ~s" method args))
3351
3352(defmethod add-method ((generic-function standard-generic-function) (method standard-method))
3353  (%add-standard-method-to-standard-gf generic-function method))
3354
3355(defmethod no-applicable-method (gf &rest args)
3356  (cerror "Try calling it again"
3357          "No applicable method for args:~% ~s~% to ~s" args gf)
3358  (apply gf args))
3359
3360
3361(defmethod no-applicable-primary-method (gf methods)
3362  (%method-combination-error "No applicable primary methods for ~s~@
3363                              Applicable methods: ~s" gf methods))
3364
3365(defmethod compute-applicable-methods ((gf standard-generic-function) args)
3366  (%compute-applicable-methods* gf args))
3367
3368(defun %compute-applicable-methods+ (gf &rest args)
3369  (declare (dynamic-extent args))
3370  (%compute-applicable-methods* gf args))
3371
3372(defun %compute-applicable-methods* (gf args)
3373  (let* ((methods (%gf-methods gf))
3374         (args-length (length args))
3375         (bits (inner-lfun-bits gf))
3376         arg-count res)
3377    (when methods
3378      (setq arg-count (length (%method-specializers (car methods))))
3379      (unless (<= arg-count args-length)
3380        (error "Too few args to ~s" gf))
3381      (unless (or (logbitp $lfbits-rest-bit bits)
3382                  (logbitp $lfbits-restv-bit bits)
3383                  (logbitp $lfbits-keys-bit bits)
3384                  (<= args-length 
3385                      (+ (ldb $lfbits-numreq bits) (ldb $lfbits-numopt bits))))
3386        (error "Too many args to ~s" gf))
3387      (let ((cpls (make-list arg-count)))
3388        (declare (dynamic-extent cpls))
3389        (do* ((args-tail args (cdr args-tail))
3390              (cpls-tail cpls (cdr cpls-tail)))
3391            ((null cpls-tail))
3392          (setf (car cpls-tail)
3393                (%class-precedence-list (class-of (car args-tail)))))
3394        (dolist (m methods)
3395          (if (%method-applicable-p m args cpls)
3396            (push m res)))
3397        (sort-methods res cpls (%gf-precedence-list gf))))))
3398
3399
3400(defun %method-applicable-p (method args cpls)
3401  (do* ((specs (%method-specializers method) (%cdr specs))
3402        (args args (%cdr args))
3403        (cpls cpls (%cdr cpls)))
3404      ((null specs) t)
3405    (let ((spec (%car specs)))
3406      (if (typep spec 'eql-specializer)
3407        (unless (eql (%car args) (eql-specializer-object spec))
3408          (return nil))
3409        (unless (memq spec (%car cpls))
3410          (return nil))))))
3411
3412
3413;;; Need this so that (compute-applicable-methods
3414;;; #'class-precedence-list ...)  will not recurse.
3415(defun %class-precedence-list (class)
3416  (if (eq (class-of class) *standard-class-class*)
3417    (%inited-class-cpl class)
3418    (class-precedence-list class)))
3419
3420(defmethod class-precedence-list ((class class))
3421  (%inited-class-cpl class))
3422
3423
3424(defun make-all-methods-kernel ()
3425  (dolist (f (population.data %all-gfs%))
3426    (let ((smc *standard-method-class*))
3427      (dolist (method (slot-value-if-bound f 'methods))
3428        (when (eq (class-of method) smc)
3429          (change-class method *standard-kernel-method-class*))))))
3430
3431
3432(defun make-all-methods-non-kernel ()
3433  (dolist (f (population.data %all-gfs%))
3434    (let ((skmc *standard-kernel-method-class*))
3435      (dolist (method (slot-value-if-bound f 'methods))
3436        (when (eq (class-of method) skmc)
3437          (change-class method *standard-method-class*))))))
3438
3439
3440(defun required-lambda-list-args (l)
3441  (multiple-value-bind (ok req) (verify-lambda-list l)
3442    (unless ok (error "Malformed lambda-list: ~s" l))
3443    req))
3444
3445
3446(defun check-generic-function-lambda-list (ll &optional (errorp t))
3447  (multiple-value-bind (ok reqsyms opttail resttail keytail auxtail)
3448                       (verify-lambda-list ll)
3449    (declare (ignore reqsyms resttail))
3450    (when ok 
3451      (block checkit
3452        (when (eq (car opttail) '&optional)
3453          (dolist (elt (cdr opttail))
3454            (when (memq elt lambda-list-keywords) (return))
3455            (unless (or (symbolp elt)
3456                        (and (listp elt)
3457                             (non-nil-symbol-p (car elt))
3458                             (null (cdr elt))))
3459              (return-from checkit (setq ok nil)))))
3460        (dolist (elt (cdr keytail))
3461          (when (memq elt lambda-list-keywords) (return))
3462          (unless (or (symbolp elt)
3463                      (and (listp elt)
3464                           (or (non-nil-symbol-p (car elt))
3465                               (and (listp (car elt))
3466                                    (non-nil-symbol-p (caar elt))
3467                                    (non-nil-symbol-p (cadar elt))
3468                                    (null (cddar elt))))
3469                           (null (cdr elt))))
3470            (return-from checkit (setq ok nil))))
3471        (when auxtail (setq ok nil))))
3472    (when (and errorp (not ok))
3473      (signal-program-error "Bad generic function lambda list: ~s" ll))
3474    ok))
3475
3476
3477(defun canonicalize-argument-precedence-order (apo req)
3478  (cond ((equal apo req) nil)
3479        ((not (eql (length apo) (length req)))
3480         (signal-program-error "Lengths of ~S and ~S differ." apo req))
3481        (t (let ((res nil))
3482             (dolist (arg apo (nreverse res))
3483               (let ((index (position arg req)))
3484                 (if (or (null index) (memq index res))
3485                   (error "Missing or duplicate arguments in ~s" apo))
3486                 (push index res)))))))
3487
3488
3489(defun %defgeneric (function-name lambda-list method-combination generic-function-class
3490                                  options)
3491  (setq generic-function-class (find-class generic-function-class))
3492  (setq method-combination 
3493        (find-method-combination
3494         (class-prototype generic-function-class)
3495         (car method-combination)
3496         (cdr method-combination)))
3497  (let ((gf (fboundp function-name)))
3498    (when gf
3499      (dolist (method (%defgeneric-methods gf))
3500        (remove-method gf method))))
3501  (record-source-file function-name 'function)
3502  (record-arglist function-name lambda-list)
3503  (apply #'ensure-generic-function 
3504         function-name
3505         :lambda-list lambda-list
3506         :method-combination method-combination
3507         :generic-function-class generic-function-class
3508         options))
3509
3510
3511
3512
3513;;; Redefined in lib;method-combination.lisp
3514(defmethod find-method-combination ((gf standard-generic-function) type options)
3515  (unless (and (eq type 'standard) (null options))
3516    (error "non-standard method-combination not supported yet."))
3517  *standard-method-combination*)
3518
3519
3520
3521(defmethod add-direct-method ((spec specializer) (method method))
3522  (pushnew method (specializer.direct-methods spec)))
3523
3524(setf (fdefinition '%do-add-direct-method) #'add-direct-method)
3525
3526(defmethod remove-direct-method ((spec specializer) (method method))
3527  (setf (specializer.direct-methods spec)
3528        (nremove method (specializer.direct-methods spec))))
3529
3530(setf (fdefinition '%do-remove-direct-method) #'remove-direct-method)
3531
3532(defmethod instance-class-wrapper (x)
3533  (%class.own-wrapper (class-of x)))
3534
3535(defmethod instance-class-wrapper ((instance standard-object))
3536  (if (%standard-instance-p instance)
3537    (instance.class-wrapper instance)
3538    (if (typep instance 'macptr)
3539      (foreign-instance-class-wrapper instance)
3540      (%class.own-wrapper (class-of instance)))))
3541
3542(defmethod instance-class-wrapper ((instance standard-generic-function))
3543  (gf.instance.class-wrapper  instance))
3544
3545
3546                                   
3547
3548(defun generic-function-wrapper (gf)
3549  (unless (inherits-from-standard-generic-function-p (class-of gf))
3550    (%badarg gf 'standard-generic-function))
3551  (gf.instance.class-wrapper gf))
3552
3553(defvar *make-load-form-saving-slots-hash* (make-hash-table :test 'eq))
3554
3555(defun make-load-form-saving-slots (object &key
3556                                           (slot-names nil slot-names-p)
3557                                           environment)
3558  (declare (ignore environment))
3559  (let* ((class (class-of object))
3560         (class-name (class-name class))
3561         (structurep (structurep object))
3562         (sd (and structurep (require-type (gethash class-name %defstructs%) 'vector))))
3563    (unless (or structurep
3564                (standard-instance-p object))
3565      (%badarg object '(or standard-object structure-object)))
3566    (if slot-names-p
3567      (dolist (slot slot-names)
3568        (unless (slot-exists-p object slot)
3569          (error "~s has no slot named ~s" object slot)))
3570      (setq slot-names
3571            (if structurep
3572              (let ((res nil))
3573                (dolist (slot (sd-slots sd))
3574                  (unless (fixnump (car slot))
3575                    (push (%car slot) res)))
3576                (nreverse res))
3577              (mapcar '%slot-definition-name
3578                      (extract-instance-effective-slotds
3579                       (class-of object))))))
3580    (values
3581     (let* ((form (gethash class-name *make-load-form-saving-slots-hash*)))
3582       (or (and (consp form)
3583                (eq (car form) 'allocate-instance)
3584                form)
3585           (setf (gethash class-name *make-load-form-saving-slots-hash*)
3586                 `(allocate-instance (find-class ',class-name)))))
3587     ;; initform is NIL when there are no slots
3588     (when slot-names
3589       `(%set-slot-values
3590         ',object
3591         ',slot-names
3592         ',(let ((temp #'(lambda (slot)
3593                           (if (slot-boundp object slot)
3594                             (slot-value object slot)
3595                             (%slot-unbound-marker)))))
3596             (declare (dynamic-extent temp))
3597             (mapcar temp slot-names)))))))
3598
3599
3600   
3601
3602(defmethod allocate-instance ((class structure-class) &rest initargs)
3603  (declare (ignore initargs))
3604  (let* ((class-name (%class-name class))
3605         (sd (or (gethash class-name %defstructs%)
3606                 (error "Can't find structure named ~s" class-name)))
3607         (res (make-structure-vector (sd-size sd))))
3608    (setf (%svref res 0) (sd-superclasses sd))
3609    res))
3610
3611
3612(defun %set-slot-values (object slots values)
3613  (dolist (slot slots)
3614    (let ((value (pop values)))
3615      (if (eq value (%slot-unbound-marker))
3616        (slot-makunbound object slot)
3617        (setf (slot-value object slot) value)))))
3618
3619
3620(defun %recache-class-direct-methods ()
3621  (let ((*maintain-class-direct-methods* t))   ; in case we get an error
3622    (dolist (f (population-data %all-gfs%))
3623      (when (standard-generic-function-p f)
3624        (dolist (method (%gf-methods f))
3625          (%add-direct-methods method)))))
3626  (setq *maintain-class-direct-methods* t))   ; no error, all is well
3627
Note: See TracBrowser for help on using the repository browser.