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

Last change on this file since 9917 was 9917, checked in by gz, 11 years ago

Move more definitions into lispequ. To bootstrap, (load "ccl:library;lispequ.lisp") before recompiling

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