source: branches/ia32/level-1/l1-clos-boot.lisp @ 9159

Last change on this file since 9159 was 9159, checked in by rme, 12 years ago

When initializing *CLASS-TABLE* on x8632, instead of putting *cons-class* into
all the list cells, put in a function that returns *cons-class* or *null-class*
depending on whether the cons in question is NIL or not.

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