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

Last change on this file since 12761 was 12761, checked in by gb, 10 years ago

When trying to determine whether a call to SLOT-VALUE-USING-CLASS,
SETF thereof, or SLOT-MAKUNBOUND-USING-CLASS can be avoided, check the
slot's allocation and call the gf if the allocation is non-standard.

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