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

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

Made loading a file not forget encapsulations. (The old behavior can be
restored by setting ccl::*loading-removes-encapsulation* to true).

Added new keyword arg to ADVISE - :dynamic-extent-arglist, if true, declares the
advised arglist to be dynamic-extent, this can be used to minimize runtime
consing when the advice form doesn't save the arglist outside the dynamic extent
of the invocation.

Changed how encapsulation (i.e. tracing and advising) of generic functions
works. Before, the encapsulating function would be installed as the dcode and
then try to guess what the gf code used to do in order to invoke the original
dcode. Now, we just save a copy of the original gf code and jump to it. This
way encapsulation is isolated from having to know details of how the dcode and
the gf interact.

Made (setf %gf-dcode) also update the GF function code to match the dcode. This
is now the only place that has knowledge of how to do that.

register-dcode-proto for %%1st-arg-dcode and %%nth-arg-dcode, since *gf-proto*
is no longer the default.

Also while in there, I consolidated and rearranged some of the encapsulation
recording, hopefully without introducing too many bugs (or at least none that
will be hard to fix).

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