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

Last change on this file since 10456 was 10456, checked in by gb, 11 years ago

Use %CLASS-ORDINAL (not INSTANCE.HASH) in MAKE-CPL-BITS, to work with
foreign classes.

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