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

Last change on this file since 9049 was 9049, checked in by gz, 12 years ago

make defclass check for illegal class options (ticket #271)

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