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

Last change on this file since 13773 was 13647, checked in by rme, 10 years ago

Delete KERNEL-FUNCTION-P (it returns NIL always) and update its callers.
Delete unused functions REDEFINE-KERNEL-METHOD and %ADD-METHODS.

I will probably end up paying for this bit of cleanup.

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