source: branches/working-0711/ccl/level-1/l1-clos-boot.lisp @ 11834

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

Assorted tweaks for declaration checking

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