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

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

Init %wrapper-cpl-bits of *T-CLASS* (missed in merge.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 148.9 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                            (%class.own-wrapper class) wrapper
1462                            (%wrapper-cpl-bits wrapper) #*1)
1463                      (setf (%class.ctype class) (make-class-ctype class))
1464                      (setf (find-class 't) class)
1465                      class)))
1466
1467(defun compute-cpl (class)
1468  (flet ((%real-class-cpl (class)
1469           (or (%class-cpl class)
1470               (compute-cpl class))))
1471    (let* ((predecessors (list (list class))) candidates cpl)
1472      (dolist (sup (%class-direct-superclasses class))
1473        (when (symbolp sup) (report-bad-arg sup 'class))
1474        (dolist (sup (%real-class-cpl sup))
1475          (unless (assq sup predecessors) (push (list sup) predecessors))))
1476      (labels ((compute-predecessors (class table)
1477                 (dolist (sup (%class-direct-superclasses class) table)
1478                   (compute-predecessors sup table)
1479                   ;(push class (cdr (assq sup table)))
1480                   (let ((a (assq sup table))) (%rplacd a (cons class (%cdr a))))
1481                   (setq class sup))))
1482        (compute-predecessors class predecessors))
1483      (setq candidates (list (assq class predecessors)))
1484      (while predecessors
1485        (dolist (c candidates (error "Inconsistent superclasses for ~d" class))
1486          (when (null (%cdr c))
1487            (setq predecessors (nremove c predecessors))
1488            (dolist (p predecessors) (%rplacd p (nremove (%car c) (%cdr p))))
1489            (setq candidates (nremove c candidates))
1490            (setq cpl (%rplacd c cpl))
1491            (dolist (sup (%class-direct-superclasses (%car c)))
1492              (when (setq c (assq sup predecessors)) (push c candidates)))
1493            (return))))
1494      (setq cpl (nreverse cpl))
1495      (do* ((tail cpl (%cdr tail))
1496            sup-cpl)
1497           ((null (setq sup-cpl (and (cdr tail) (%real-class-cpl (cadr tail))))))
1498        (when (equal (%cdr tail) sup-cpl)
1499          (setf (%cdr tail) sup-cpl)
1500          (return)))
1501      cpl)))
1502
1503(defun make-cpl-bits (cpl)
1504  (when cpl
1505    (let* ((max 0))
1506      (declare (fixnum max))
1507      (dolist (class cpl)
1508        (let* ((ordinal (%class-ordinal class)))
1509          (declare (fixnum ordinal))
1510          (when (> ordinal max)
1511            (setq max ordinal))))
1512      (let* ((bits (make-array (the fixnum (1+ max)) :element-type 'bit)))
1513        (dolist (class cpl bits)
1514          (let* ((ordinal (%class-ordinal class)))
1515            (setf (sbit bits ordinal) 1)))))))
1516
1517         
1518(defun make-built-in-class (name &rest supers)
1519  (if (null supers)
1520    (setq supers (list *t-class*))
1521    (do ((supers supers (%cdr supers)))
1522        ((null supers))
1523      (when (symbolp (%car supers)) (%rplaca supers (find-class (%car supers))))))
1524  (let ((class (find-class name nil)))
1525    (if class
1526      (progn
1527        ;Must be debugging.  Give a try at redefinition...
1528        (dolist (sup (%class.local-supers class))
1529          (setf (%class.subclasses sup) (nremove class (%class.subclasses sup)))))
1530      (progn
1531        (setq class (%cons-built-in-class name))
1532        (setf (instance.hash class) (%next-class-ordinal))))
1533    (dolist (sup supers)
1534      (setf (%class.subclasses sup) (cons class (%class.subclasses sup))))
1535    (setf (%class.local-supers class) supers)
1536    (let* ((wrapper (%cons-wrapper class (new-class-wrapper-hash-index)))
1537           (cpl (compute-cpl class)))
1538      (setf (%class.cpl class) cpl)
1539      (setf (%class.own-wrapper class) wrapper)
1540      (setf (%wrapper-cpl wrapper) cpl
1541            (%wrapper-cpl-bits wrapper) (make-cpl-bits cpl)
1542            (%wrapper-class-ordinal wrapper) (%class-ordinal class)))
1543    (setf (%class.ctype class)  (make-class-ctype class))
1544    (setf (find-class name) class)
1545    (dolist (sub (%class.subclasses class))   ; Only non-nil if redefining
1546      ;Recompute the cpl.
1547      (apply #'make-built-in-class (%class.name sub) (%class.local-supers sub)))
1548    class))
1549
1550(defun make-istruct-class (name &rest supers)
1551  (let* ((class (apply #'make-built-in-class name supers))
1552         (cell (register-istruct-cell name)))
1553    (setf (istruct-cell-info cell) (%class.own-wrapper class))
1554    class))
1555
1556;;; This will be filled in below.  Need it defined now as it goes in
1557;;; the instance.class-wrapper of all the classes that STANDARD-CLASS
1558;;; inherits from.
1559(defstatic *standard-class-wrapper* 
1560  (%cons-wrapper 'standard-class))
1561
1562(defun make-standard-class (name &rest supers)
1563  (make-class name *standard-class-wrapper* supers))
1564
1565(defun make-class (name metaclass-wrapper supers &optional own-wrapper)
1566  (let ((class (if (find-class name nil)
1567                 (error "Attempt to remake standard class ~s" name)
1568                 (%cons-standard-class name metaclass-wrapper))))
1569    (setf (instance.hash class) (%next-class-ordinal))
1570    (if (null supers)
1571      (setq supers (list *standard-class-class*))
1572      (do ((supers supers (cdr supers))
1573           sup)
1574          ((null supers))
1575        (setq sup (%car supers))
1576        (if (symbolp sup) (setf (%car supers) (setq sup (find-class (%car supers)))))
1577        #+nil (unless (or (eq sup *t-class*) (std-class-p sup))
1578          (error "~a is not of type ~a" sup 'std-class))))
1579    (setf (%class.local-supers class) supers)
1580    (let ((cpl (compute-cpl class))
1581          (wrapper (if own-wrapper
1582                     (progn
1583                       (setf (%wrapper-class own-wrapper) class)
1584                       own-wrapper)
1585                     (%cons-wrapper class))))
1586      (setf (%class.cpl class) cpl
1587            (%wrapper-instance-slots wrapper) (vector)
1588            (%class.own-wrapper class) wrapper
1589            (%class.ctype class) (make-class-ctype class)
1590            (%class.slots class) nil
1591            (%wrapper-class-ordinal wrapper) (%class-ordinal class)
1592            (%wrapper-cpl wrapper) cpl
1593            (%wrapper-cpl-bits wrapper) (make-cpl-bits cpl)
1594            (find-class name) class
1595            )
1596      (dolist (sup supers)
1597        (setf (%class.subclasses sup) (cons class (%class.subclasses sup))))
1598      class)))
1599
1600
1601
1602
1603
1604(defun standard-object-p (thing)
1605  ;; returns thing's class-wrapper or nil if it isn't a standard-object
1606  (if (standard-instance-p thing)
1607    (instance.class-wrapper thing)
1608    (if (typep thing 'macptr)
1609      (foreign-instance-class-wrapper thing))))
1610
1611
1612(defun std-class-p (class)
1613  ;; (typep class 'std-class)
1614  ;; but works at bootstrapping time as well
1615  (let ((wrapper (standard-object-p class)))
1616    (and wrapper
1617         (or (eq wrapper *standard-class-wrapper*)
1618             (memq *std-class-class* (%inited-class-cpl (%wrapper-class wrapper) t))))))
1619
1620(set-type-predicate 'std-class 'std-class-p)
1621
1622(defun slots-class-p (class)
1623  (let ((wrapper (standard-object-p class)))
1624    (and wrapper
1625         (or (eq wrapper *slots-class-wrapper*)
1626             (memq *slots-class* (%inited-class-cpl (%wrapper-class wrapper) t)))))) 
1627
1628(set-type-predicate 'slots-class 'slots-class-p)
1629
1630(defun specializer-p (thing)
1631  (memq *specializer-class* (%inited-class-cpl (class-of thing))))
1632
1633(defstatic *standard-object-class* (make-standard-class 'standard-object *t-class*))
1634
1635(defstatic *metaobject-class* (make-standard-class 'metaobject *standard-object-class*))
1636
1637(defstatic *specializer-class* (make-standard-class 'specializer *metaobject-class*))
1638(defstatic *eql-specializer-class* (make-standard-class 'eql-specializer *specializer-class*))
1639
1640(defstatic *standard-method-combination*
1641  (make-instance-vector
1642   (%class.own-wrapper
1643    (make-standard-class
1644     'standard-method-combination
1645     (make-standard-class 'method-combination *metaobject-class*)))
1646   1))
1647
1648
1649(defun eql-specializer-p (x)
1650  (memq *eql-specializer-class* (%inited-class-cpl (class-of x))))
1651
1652(setf (type-predicate 'eql-specializer) 'eql-specializer-p)
1653
1654;;; The *xxx-class-class* instances get slots near the end of this file.
1655(defstatic *class-class* (make-standard-class 'class *specializer-class*))
1656
1657(defstatic *slots-class* (make-standard-class 'slots-class *class-class*))
1658(defstatic *slots-class-wrapper* (%class.own-wrapper *slots-class*))
1659
1660
1661;;; an implementation class that exists so that
1662;;; standard-class & funcallable-standard-class can have a common ancestor not
1663;;; shared by anybody but their subclasses.
1664
1665(defstatic *std-class-class* (make-standard-class 'std-class *slots-class*))
1666
1667;;; The class of all objects whose metaclass is standard-class. Yow.
1668(defstatic *standard-class-class* (make-standard-class 'standard-class *std-class-class*))
1669;;; Replace its wrapper and the circle is closed.
1670(setf (%class.own-wrapper *standard-class-class*) *standard-class-wrapper*
1671      (%wrapper-class *standard-class-wrapper*) *standard-class-class*
1672      (%wrapper-class-ordinal *standard-class-wrapper*) (%class-ordinal *standard-class-class*)
1673      (%wrapper-instance-slots *standard-class-wrapper*) (vector))
1674
1675(defstatic *built-in-class-class* (make-standard-class 'built-in-class *class-class*))
1676(setf *built-in-class-wrapper* (%class.own-wrapper *built-in-class-class*)
1677      (instance.class-wrapper *t-class*) *built-in-class-wrapper*)
1678
1679(defstatic *structure-class-class* (make-standard-class 'structure-class *slots-class*))
1680(defstatic *structure-class-wrapper* (%class.own-wrapper *structure-class-class*))
1681(defstatic *structure-object-class* 
1682  (make-class 'structure-object *structure-class-wrapper* (list *t-class*)))
1683
1684(defstatic *forward-referenced-class-class*
1685  (make-standard-class 'forward-referenced-class *class-class*))
1686
1687(defstatic *function-class* (make-built-in-class 'function))
1688
1689(defun alias-class (name class)
1690  (setf (find-class name) class
1691        (info-type-kind name) :instance)
1692  class)
1693
1694;;;Right now, all functions are compiled.
1695
1696
1697(defstatic *compiled-function-class* *function-class*)
1698(alias-class 'compiled-function *compiled-function-class*)
1699
1700(defstatic *compiled-lexical-closure-class* 
1701  (make-standard-class 'compiled-lexical-closure *function-class*))
1702
1703
1704
1705
1706
1707(defstatic *funcallable-standard-class-class*
1708  (make-standard-class 'funcallable-standard-class *std-class-class*))
1709
1710(defstatic *funcallable-standard-object-class*
1711  (make-class 'funcallable-standard-object
1712              (%class.own-wrapper *funcallable-standard-class-class*)
1713              (list *standard-object-class* *function-class*)))
1714
1715(defstatic *generic-function-class*
1716  (make-class 'generic-function
1717              (%class.own-wrapper *funcallable-standard-class-class*)
1718              (list *metaobject-class* *funcallable-standard-object-class*)))
1719(setq *generic-function-class-wrapper* (%class.own-wrapper *generic-function-class*))
1720
1721(defstatic *standard-generic-function-class*
1722  (make-class 'standard-generic-function
1723              (%class.own-wrapper *funcallable-standard-class-class*)
1724              (list *generic-function-class*)))
1725(setq *standard-generic-function-class-wrapper*
1726      (%class.own-wrapper *standard-generic-function-class*))
1727
1728;;; *standard-method-class* is upgraded to a real class below
1729(defstatic *method-class* (make-standard-class 'method *metaobject-class*))
1730(defstatic *standard-method-class* (make-standard-class 'standard-method *method-class*))
1731(defstatic *accessor-method-class* (make-standard-class 'standard-accessor-method *standard-method-class*))
1732(defstatic *standard-reader-method-class* (make-standard-class 'standard-reader-method *accessor-method-class*))
1733(defstatic *standard-writer-method-class* (make-standard-class 'standard-writer-method *accessor-method-class*))
1734(defstatic *method-function-class* (make-standard-class 'method-function *function-class*))
1735
1736
1737(defstatic *combined-method-class* (make-standard-class 'combined-method *function-class*))
1738
1739(defstatic *slot-definition-class* (make-standard-class 'slot-definition *metaobject-class*))
1740(defstatic direct-slot-definition-class (make-standard-class 'direct-slot-definition
1741                                                           *slot-definition-class*))
1742(defstatic effective-slot-definition-class (make-standard-class 'effective-slot-definition
1743                                                              *slot-definition-class*))
1744(defstatic *standard-slot-definition-class* (make-standard-class 'standard-slot-definition
1745                                                                 *slot-definition-class*))
1746(defstatic *standard-direct-slot-definition-class* (make-class
1747                                                    'standard-direct-slot-definition
1748                                                    *standard-class-wrapper*
1749                                                    (list
1750                                                     *standard-slot-definition-class*
1751                                                     direct-slot-definition-class)))
1752
1753(defstatic *standard-effective-slot-definition-class* (make-class
1754                                                    'standard-effective-slot-definition
1755                                                    *standard-class-wrapper*
1756                                                    (list
1757                                                     *standard-slot-definition-class*
1758                                                     effective-slot-definition-class)
1759))
1760
1761(defstatic *standard-effective-slot-definition-class-wrapper*
1762  (%class.own-wrapper *standard-effective-slot-definition-class*))
1763
1764
1765
1766
1767
1768 
1769
1770(let ((*dont-find-class-optimize* t)
1771      (ordinal-type-class-alist ())
1772      (ordinal-type-class-alist-lock (make-lock)))
1773
1774;; The built-in classes.
1775  (defstatic *array-class* (make-built-in-class 'array))
1776  (defstatic *character-class* (make-built-in-class 'character))
1777  (make-built-in-class 'number)
1778  (make-built-in-class 'sequence)
1779  (defstatic *symbol-class* (make-built-in-class 'symbol))
1780  (defstatic *immediate-class* (make-built-in-class 'immediate)) ; Random immediate
1781  ;; Random uvectors - these are NOT class of all things represented by a uvector
1782  ;;type. Just random uvectors which don't fit anywhere else.
1783  (make-built-in-class 'ivector)        ; unknown ivector
1784  (make-built-in-class 'gvector)        ; unknown gvector
1785  (defstatic *istruct-class* (make-built-in-class 'internal-structure)) ; unknown istruct
1786 
1787  (defstatic *slot-vector-class* (make-built-in-class 'slot-vector (find-class 'gvector)))
1788 
1789  (defstatic *macptr-class* (make-built-in-class 'macptr))
1790  (defstatic *foreign-standard-object-class*
1791    (make-standard-class 'foreign-standard-object
1792                         *standard-object-class* *macptr-class*))
1793
1794  (defstatic *foreign-class-class*
1795    (make-standard-class 'foreign-class *foreign-standard-object-class* *slots-class*))
1796 
1797  (make-built-in-class 'population)
1798  (make-built-in-class 'pool)
1799  (make-built-in-class 'package)
1800  (defstatic *lock-class* (make-built-in-class 'lock))
1801  (defstatic *recursive-lock-class* (make-built-in-class 'recursive-lock *lock-class*))
1802  (defstatic *read-write-lock-class* (make-built-in-class 'read-write-lock *lock-class*))
1803 
1804  (make-istruct-class 'lock-acquisition *istruct-class*)
1805  (make-istruct-class 'semaphore-notification *istruct-class*)
1806  (make-istruct-class 'class-wrapper *istruct-class*)
1807  ;; Compiler stuff, mostly
1808  (make-istruct-class 'faslapi *istruct-class*)
1809  (make-istruct-class 'faslstate *istruct-class*)
1810  (make-istruct-class 'var *istruct-class*)
1811  (make-istruct-class 'afunc *istruct-class*)
1812  (make-istruct-class 'lexical-environment *istruct-class*)
1813  (make-istruct-class 'definition-environment *istruct-class*)
1814  (make-istruct-class 'compiler-policy *istruct-class*)
1815  (make-istruct-class 'deferred-warnings *istruct-class*)
1816  (make-istruct-class 'ptaskstate *istruct-class*)
1817  (make-istruct-class 'entry *istruct-class*)
1818  (make-istruct-class 'foreign-object-domain *istruct-class*)
1819
1820 
1821  (make-istruct-class 'slot-id *istruct-class*)
1822  (make-built-in-class 'value-cell)
1823  (make-istruct-class 'restart *istruct-class*)
1824  (make-istruct-class 'hash-table *istruct-class*)
1825  (make-istruct-class 'readtable *istruct-class*)
1826  (make-istruct-class 'pathname *istruct-class*)
1827  (make-istruct-class 'random-state *istruct-class*)
1828  (make-istruct-class 'xp-structure *istruct-class*)
1829  (make-istruct-class 'lisp-thread *istruct-class*)
1830  (make-istruct-class 'resource *istruct-class*)
1831  (make-istruct-class 'periodic-task *istruct-class*)
1832  (make-istruct-class 'semaphore *istruct-class*)
1833 
1834  (make-istruct-class 'type-class *istruct-class*)
1835 
1836  (defstatic *ctype-class* (make-istruct-class 'ctype *istruct-class*))
1837  (make-istruct-class 'key-info *istruct-class*)
1838  (defstatic *args-ctype* (make-istruct-class 'args-ctype *ctype-class*))
1839  (make-istruct-class 'values-ctype *args-ctype*)
1840  (make-istruct-class 'function-ctype *args-ctype*)
1841  (make-istruct-class 'constant-ctype *ctype-class*)
1842  (make-istruct-class 'named-ctype *ctype-class*)
1843  (make-istruct-class 'cons-ctype *ctype-class*)
1844  (make-istruct-class 'unknown-ctype (make-istruct-class 'hairy-ctype *ctype-class*))
1845  (make-istruct-class 'numeric-ctype *ctype-class*)
1846  (make-istruct-class 'array-ctype *ctype-class*)
1847  (make-istruct-class 'member-ctype *ctype-class*)
1848  (make-istruct-class 'union-ctype *ctype-class*)
1849  (make-istruct-class 'foreign-ctype *ctype-class*)
1850  (make-istruct-class 'class-ctype *ctype-class*)
1851  (make-istruct-class 'negation-ctype *ctype-class*)
1852  (make-istruct-class 'intersection-ctype *ctype-class*)
1853 
1854  (make-istruct-class 'class-cell *istruct-class*)
1855  (make-istruct-class 'type-cell *istruct-class*)
1856  (make-istruct-class 'package-ref *istruct-class*)
1857
1858  (make-istruct-class 'foreign-variable *istruct-class*)
1859  (make-istruct-class 'external-entry-point *istruct-class*)
1860  (make-istruct-class 'shlib *istruct-class*)
1861
1862  (make-built-in-class 'complex (find-class 'number))
1863  (make-built-in-class 'real (find-class 'number))
1864  (defstatic *float-class* (make-built-in-class 'float (find-class 'real)))
1865  (defstatic *double-float-class* (make-built-in-class 'double-float (find-class 'float)))
1866  (defstatic *single-float-class*  (make-built-in-class 'single-float (find-class 'float)))
1867  (alias-class 'short-float *single-float-class*)
1868  (alias-class 'long-float *double-float-class*)
1869
1870  (make-built-in-class 'rational (find-class 'real))
1871  (make-built-in-class 'ratio (find-class 'rational))
1872  (make-built-in-class 'integer (find-class 'rational))
1873  (defstatic *fixnum-class* (make-built-in-class 'fixnum (find-class 'integer)))
1874
1875  #+x86-target
1876  (defstatic *tagged-return-address-class* (make-built-in-class 'tagged-return-address))
1877  (make-built-in-class 'bignum (find-class 'integer))
1878 
1879  (make-built-in-class 'bit *fixnum-class*)
1880  (make-built-in-class 'unsigned-byte (find-class 'integer))
1881  (make-built-In-class 'signed-byte (find-class 'integer))
1882
1883
1884  (make-istruct-class 'logical-pathname (find-class 'pathname))
1885
1886  (make-istruct-class 'destructure-state *istruct-class*)
1887 
1888  (defstatic *base-char-class* (alias-class 'base-char *character-class*))
1889  (defstatic *standard-char-class* (make-built-in-class 'standard-char *base-char-class*))
1890 
1891  (defstatic *keyword-class* (make-built-in-class 'keyword *symbol-class*))
1892 
1893  (make-built-in-class 'list (find-class 'sequence))
1894  (defstatic *cons-class* (make-built-in-class 'cons (find-class 'list)))
1895  (defstatic *null-class* (make-built-in-class 'null *symbol-class* (find-class 'list)))
1896 
1897  (defstatic *vector-class* (make-built-in-class 'vector *array-class* (find-class 'sequence)))
1898  (defstatic *simple-array-class* (make-built-in-class 'simple-array *array-class*))
1899  (make-built-in-class 'simple-1d-array *vector-class* *simple-array-class*)
1900 
1901  ;;Maybe should do *float-array-class* etc?
1902  ;;Also, should straighten out the simple-n-dim-array mess...
1903  (make-built-in-class 'unsigned-byte-vector *vector-class*)
1904  (make-built-in-class 'simple-unsigned-byte-vector (find-class 'unsigned-byte-vector) (find-class 'simple-1d-array))
1905  (make-built-in-class 'unsigned-word-vector *vector-class*)
1906  (make-built-in-class 'simple-unsigned-word-vector (find-class 'unsigned-word-vector) (find-class 'simple-1d-array))
1907  (make-built-in-class 'fixnum-vector *vector-class*)
1908  (make-built-in-class 'simple-fixnum-vector (find-class 'fixnum-vector) (find-class 'simple-1d-array))
1909
1910
1911  (progn
1912    (make-built-in-class 'double-float-vector *vector-class*)
1913    (make-built-in-class 'short-float-vector *vector-class*)
1914    (alias-class 'long-float-vector (find-class 'double-float-vector))
1915    (alias-class 'single-float-vector (find-class 'short-float-vector))
1916    (make-built-in-class 'simple-double-float-vector (find-class 'double-float-vector) (find-class 'simple-1d-array))
1917    (make-built-in-class 'simple-short-float-vector (find-class 'short-float-vector) (find-class 'simple-1d-array))
1918    (alias-class 'simple-long-float-vector (find-class 'simple-double-float-vector))
1919    (alias-class 'simple-single-float-vector (find-class 'simple-short-float-vector))
1920    )
1921
1922  #+x8664-target
1923  (progn
1924    (make-built-in-class 'symbol-vector (find-class 'gvector))
1925    (make-built-in-class 'function-vector (find-class 'gvector)))
1926
1927  #+64-bit-target
1928  (progn
1929    (make-built-in-class 'doubleword-vector *vector-class*)
1930    (make-built-in-class 'simple-doubleword-vector (find-class 'doubleword-vector) (find-class 'simple-1d-array))
1931    (make-built-in-class 'unsigned-doubleword-vector *vector-class*)
1932    (make-built-in-class 'simple-unsigned-doubleword-vector (find-class 'unsigned-doubleword-vector) (find-class 'simple-1d-array))
1933    )                                   ; #+64-bit-target
1934
1935  (make-built-in-class 'long-vector *vector-class*)
1936  (make-built-in-class 'simple-long-vector (find-class 'long-vector) (find-class 'simple-1d-array))
1937  (make-built-in-class 'unsigned-long-vector *vector-class*)
1938  (make-built-in-class 'simple-unsigned-long-vector (find-class 'unsigned-long-vector) (find-class 'simple-1d-array))
1939  (make-built-in-class 'byte-vector *vector-class*)
1940  (make-built-in-class 'simple-byte-vector (find-class 'byte-vector) (find-class 'simple-1d-array))
1941  (make-built-in-class 'bit-vector *vector-class*)
1942  (make-built-in-class 'simple-bit-vector (find-class 'bit-vector) (find-class 'simple-1d-array))
1943  (make-built-in-class 'word-vector *vector-class*)
1944  (make-built-in-class 'simple-word-vector (find-class 'word-vector) (find-class 'simple-1d-array))
1945  (make-built-in-class 'string *vector-class*)
1946  (make-built-in-class 'base-string (find-class 'string))
1947  (make-built-in-class 'simple-string (find-class 'string) (find-class 'simple-1d-array))
1948  (make-built-in-class 'simple-base-string (find-class 'base-string) (find-class 'simple-string))
1949  (make-built-in-class 'general-vector *vector-class*)
1950  (make-built-in-class 'simple-vector (find-class 'general-vector) (find-class 'simple-1d-array))
1951
1952  (make-built-in-class 'hash-table-vector)
1953  (make-built-in-class 'catch-frame)
1954  (make-built-in-class 'code-vector)
1955  #+ppc32-target
1956  (make-built-in-class 'creole-object)
1957
1958  (make-built-in-class 'xfunction)
1959  (make-built-in-class 'xcode-vector)
1960
1961  (defun class-cell-find-class (class-cell errorp)
1962    (unless (istruct-typep class-cell 'class-cell)
1963      (setq class-cell (%kernel-restart $xwrongtype class-cell 'class-cell)))
1964    (locally (declare (type class-cell class-cell))
1965      (let ((class (class-cell-class class-cell)))
1966        (or class
1967            (and 
1968             (setq class (find-class (class-cell-name class-cell) nil))
1969             (when class 
1970               (setf (class-cell-class class-cell) class)
1971               class))
1972            (if errorp (error "Class ~s not found." (class-cell-name class-cell)) nil)))))
1973
1974;;; (%wrapper-class (instance.class-wrapper frob))
1975
1976
1977
1978  (defstatic *general-vector-class* (find-class 'general-vector))
1979
1980  #+ppc32-target
1981  (defparameter *ivector-vector-classes*
1982    (vector (find-class 'short-float-vector)
1983            (find-class 'unsigned-long-vector)
1984            (find-class 'long-vector)
1985            (find-class 'fixnum-vector)
1986            (find-class 'base-string)
1987            (find-class 'unsigned-byte-vector)
1988            (find-class 'byte-vector)
1989            *t-class*                   ; old base-string
1990            (find-class 'unsigned-word-vector)
1991            (find-class 'word-vector)
1992            (find-class 'double-float-vector)
1993            (find-class 'bit-vector)))
1994
1995  #+ppc64-target
1996  (defparameter *ivector-vector-classes*
1997    (vector *t-class*
1998            *t-class*
1999            *t-class*
2000            *t-class*
2001            (find-class 'byte-vector)
2002            (find-class 'word-vector)
2003            (find-class 'long-vector)
2004            (find-class 'doubleword-vector)
2005            (find-class 'unsigned-byte-vector)
2006            (find-class 'unsigned-word-vector)
2007            (find-class 'unsigned-long-vector)
2008            (find-class 'unsigned-doubleword-vector)
2009            *t-class*
2010            *t-class*
2011            (find-class 'short-float-vector)
2012            (find-class 'fixnum-vector)
2013            *t-class*
2014            *t-class*
2015            *t-class*
2016            (find-class 'double-float-vector)
2017            (find-class 'base-string)
2018            *t-class*
2019            (find-class 'base-string)
2020            *t-class*
2021            *t-class*
2022            *t-class*
2023            *t-class*
2024            *t-class*
2025            *t-class*
2026            (find-class 'bit-vector)
2027            *t-class*
2028            *t-class*))
2029
2030  #+x8632-target
2031  (defparameter *ivector-vector-classes*
2032    (vector (find-class 'short-float-vector)
2033            (find-class 'unsigned-long-vector)
2034            (find-class 'long-vector)
2035            (find-class 'fixnum-vector)
2036            (find-class 'base-string)
2037            (find-class 'unsigned-byte-vector)
2038            (find-class 'byte-vector)
2039            *t-class*
2040            (find-class 'unsigned-word-vector)
2041            (find-class 'word-vector)
2042            (find-class 'double-float-vector)
2043            (find-class 'bit-vector)))
2044
2045  #+x8664-target
2046  (progn
2047    (defparameter *immheader-0-classes*
2048      (vector *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              *t-class*
2058              (find-class 'word-vector)
2059              (find-class 'unsigned-word-vector)
2060              (find-class 'base-string) ;old
2061              (find-class 'byte-vector)
2062              (find-class 'unsigned-byte-vector)
2063              (find-class 'bit-vector)))
2064
2065    (defparameter *immheader-1-classes*
2066      (vector *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              *t-class*
2078              (find-class 'base-string)
2079              (find-class 'long-vector)
2080              (find-class 'unsigned-long-vector)
2081              (find-class 'short-float-vector)))
2082
2083    (defparameter *immheader-2-classes*
2084      (vector *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              *t-class*
2096              (find-class 'fixnum-vector)
2097              (find-class 'doubleword-vector)
2098              (find-class 'unsigned-doubleword-vector)
2099              (find-class 'double-float-vector))))
2100
2101
2102
2103  (defun make-foreign-object-domain (&key index name recognize class-of classp
2104                                          instance-class-wrapper
2105                                          class-own-wrapper
2106                                          slots-vector class-ordinal
2107                                          set-class-ordinal)
2108    (%istruct 'foreign-object-domain index name recognize class-of classp
2109              instance-class-wrapper class-own-wrapper slots-vector
2110              class-ordinal set-class-ordinal))
2111 
2112  (let* ((n-foreign-object-domains 0)
2113         (foreign-object-domains (make-array 10))
2114         (foreign-object-domain-lock (make-lock)))
2115    (defun register-foreign-object-domain (name
2116                                           &key
2117                                           recognize
2118                                           class-of
2119                                           classp
2120                                           instance-class-wrapper
2121                                           class-own-wrapper
2122                                           slots-vector
2123                                           class-ordinal
2124                                           set-class-ordinal)
2125      (with-lock-grabbed (foreign-object-domain-lock)
2126        (dotimes (i n-foreign-object-domains)
2127          (let* ((already (svref foreign-object-domains i)))
2128            (when (eq name (foreign-object-domain-name already))
2129              (setf (foreign-object-domain-recognize already) recognize
2130                    (foreign-object-domain-class-of already) class-of
2131                    (foreign-object-domain-classp already) classp
2132                    (foreign-object-domain-instance-class-wrapper already)
2133                    instance-class-wrapper
2134                    (foreign-object-domain-class-own-wrapper already)
2135                    class-own-wrapper
2136                    (foreign-object-domain-slots-vector already) slots-vector
2137                    (foreign-object-domain-class-ordinal already) class-ordinal
2138                    (foreign-object-domain-set-class-ordinal already)
2139                    set-class-ordinal)
2140              (return-from register-foreign-object-domain i))))
2141        (let* ((i n-foreign-object-domains)
2142               (new (make-foreign-object-domain :index i
2143                                                :name name
2144                                                :recognize recognize
2145                                                :class-of class-of
2146                                                :classp classp
2147                                                :instance-class-wrapper
2148                                                instance-class-wrapper
2149                                                :class-own-wrapper
2150                                                class-own-wrapper
2151                                                :slots-vector
2152                                                slots-vector
2153                                                :class-ordinal class-ordinal
2154                                                :set-class-ordinal set-class-ordinal)))
2155          (incf n-foreign-object-domains)
2156          (if (= i (length foreign-object-domains))
2157            (setq foreign-object-domains (%extend-vector i foreign-object-domains (* i 2))))
2158          (setf (svref foreign-object-domains i) new)
2159          i)))
2160    (defun foreign-class-of (p)
2161      (funcall (foreign-object-domain-class-of (svref foreign-object-domains (%macptr-domain p))) p))
2162    (defun foreign-classp (p)
2163      (funcall (foreign-object-domain-classp (svref foreign-object-domains (%macptr-domain p))) p))
2164    (defun foreign-instance-class-wrapper (p)
2165      (funcall (foreign-object-domain-instance-class-wrapper (svref foreign-object-domains (%macptr-domain p))) p))
2166    (defun foreign-class-own-wrapper (p)
2167      (funcall (foreign-object-domain-class-own-wrapper (svref foreign-object-domains (%macptr-domain p))) p))
2168    (defun foreign-slots-vector (p)
2169      (funcall (foreign-object-domain-slots-vector (svref foreign-object-domains (%macptr-domain p))) p))
2170    (defun foreign-class-ordinal (p)
2171      (funcall (foreign-object-domain-class-ordinal (svref foreign-object-domains (%macptr-domain p))) p))
2172    (defun (setf foreign-class-ordinal) (new p)
2173      (funcall (foreign-object-domain-set-class-ordinal (svref foreign-object-domains (%macptr-domain p))) p new))
2174    (defun classify-foreign-pointer (p)
2175      (do* ((i (1- n-foreign-object-domains) (1- i)))
2176           ((zerop i) (error "this can't happen"))
2177        (when (funcall (foreign-object-domain-recognize (svref foreign-object-domains i)) p)
2178          (%set-macptr-domain p i)
2179          (return p)))))
2180
2181  (defun constantly (x)
2182    "Return a function that always returns VALUE."
2183    #'(lambda (&rest ignore)
2184        (declare (dynamic-extent ignore)
2185                 (ignore ignore))
2186        x))
2187
2188  (defun %register-type-ordinal-class (foreign-type class-name)
2189    ;; ordinal-type-class shouldn't already exist
2190    (with-lock-grabbed (ordinal-type-class-alist-lock)
2191      (or (let* ((class (cdr (assq foreign-type ordinal-type-class-alist))))
2192            (if (and class (eq class-name (class-name class)))
2193              class))
2194          (let* ((class (make-built-in-class class-name 'macptr)))
2195            (push (cons foreign-type class) ordinal-type-class-alist)
2196            class))))
2197
2198  (defun %ordinal-type-class-for-macptr (p)
2199    (with-lock-grabbed (ordinal-type-class-alist-lock)
2200      (or (unless (%null-ptr-p p)
2201            (cdr (assoc (%macptr-type p) ordinal-type-class-alist :key #'foreign-type-ordinal)))
2202          *macptr-class*)))
2203                 
2204
2205  (register-foreign-object-domain :unclassified
2206                                  :recognize #'(lambda (p)
2207                                                 (declare (ignore p))
2208                                                 (error "Shouldn't happen"))
2209                                  :class-of #'(lambda (p)
2210                                                (foreign-class-of
2211                                                 (classify-foreign-pointer p)))
2212                                  :classp #'(lambda (p)
2213                                              (foreign-classp
2214                                               (classify-foreign-pointer p)))
2215                                  :instance-class-wrapper
2216                                  #'(lambda (p)
2217                                      (foreign-instance-class-wrapper
2218                                       (classify-foreign-pointer p)))
2219                                  :class-own-wrapper
2220                                  #'(lambda (p)
2221                                      (foreign-class-own-wrapper 
2222                                       (classify-foreign-pointer p)))
2223                                  :slots-vector
2224                                  #'(lambda (p)
2225                                      (foreign-slots-vector
2226                                       (classify-foreign-pointer p))))
2227
2228;;; "Raw" macptrs, that aren't recognized as "standard foreign objects"
2229;;; in some other domain, should always be recognized as such (and this
2230;;; pretty much has to be domain #1.)
2231
2232  (register-foreign-object-domain :raw
2233                                  :recognize #'true
2234                                  :class-of #'%ordinal-type-class-for-macptr
2235                                  :classp #'false
2236                                  :instance-class-wrapper
2237                                  (lambda (p)
2238                                    (%class.own-wrapper (%ordinal-type-class-for-macptr p)))
2239                                  :class-own-wrapper #'false
2240                                  :slots-vector #'false)
2241
2242  (defstatic *class-table*
2243      (let* ((v (make-array 256 :initial-element nil))
2244             (class-of-function-function
2245              #'(lambda (thing)
2246                  (let ((bits (lfun-bits-known-function thing)))
2247                    (declare (fixnum bits))
2248                    (if (logbitp $lfbits-trampoline-bit bits)
2249                      ;; closure
2250                      (let ((inner-fn (closure-function thing)))
2251                        (if (neq inner-fn thing)
2252                          (let ((inner-bits (lfun-bits inner-fn)))
2253                            (if (logbitp $lfbits-method-bit inner-bits)
2254                              *compiled-lexical-closure-class*
2255                              (if (logbitp $lfbits-gfn-bit inner-bits)
2256                                (%wrapper-class (gf.instance.class-wrapper thing))
2257                                (if (logbitp $lfbits-cm-bit inner-bits)
2258                                  *combined-method-class*
2259                                  *compiled-lexical-closure-class*))))
2260                          *compiled-lexical-closure-class*))
2261                      (if (logbitp  $lfbits-method-bit bits)
2262                        *method-function-class* 
2263                        (if (logbitp $lfbits-gfn-bit bits)
2264                          (%wrapper-class (gf.instance.class-wrapper thing))
2265                          (if (logbitp $lfbits-cm-bit bits)
2266                            *combined-method-class*
2267                            *compiled-function-class*))))))))
2268        ;; Make one loop through the vector, initializing fixnum & list
2269        ;; cells.  Set all immediates to *immediate-class*, then
2270        ;; special-case characters later.
2271        #+ppc32-target
2272        (do* ((slice 0 (+ 8 slice)))
2273             ((= slice 256))
2274          (declare (type (unsigned-byte 8) slice))
2275          (setf (%svref v (+ slice ppc32::fulltag-even-fixnum)) *fixnum-class*
2276                (%svref v (+ slice ppc32::fulltag-odd-fixnum))  *fixnum-class*
2277                (%svref v (+ slice ppc32::fulltag-cons)) *cons-class*
2278                (%svref v (+ slice ppc32::fulltag-nil)) *null-class*
2279                (%svref v (+ slice ppc32::fulltag-imm)) *immediate-class*))
2280        #+ppc64-target
2281        (do* ((slice 0 (+ 16 slice)))
2282             ((= slice 256))
2283          (declare (type (unsigned-byte 8) slice))
2284          (setf (%svref v (+ slice ppc64::fulltag-even-fixnum)) *fixnum-class*
2285                (%svref v (+ slice ppc64::fulltag-odd-fixnum))  *fixnum-class*
2286                (%svref v (+ slice ppc64::fulltag-cons)) *cons-class*
2287                (%svref v (+ slice ppc64::fulltag-imm-0)) *immediate-class*
2288                (%svref v (+ slice ppc64::fulltag-imm-1)) *immediate-class*
2289                (%svref v (+ slice ppc64::fulltag-imm-2)) *immediate-class*
2290                (%svref v (+ slice ppc64::fulltag-imm-3)) *immediate-class*))
2291        #+x8632-target
2292        (do* ((slice 0 (+ 8 slice))
2293              (cons-fn #'(lambda (x) (if (null x) *null-class* *cons-class*))))
2294             ((= slice 256))
2295          (declare (type (unsigned-byte 8) slice))
2296          (setf (%svref v (+ slice x8632::fulltag-even-fixnum)) *fixnum-class*
2297                (%svref v (+ slice x8632::fulltag-odd-fixnum))  *fixnum-class*
2298                (%svref v (+ slice x8632::fulltag-cons)) cons-fn
2299                (%svref v (+ slice x8632::fulltag-tra)) *tagged-return-address-class*
2300                (%svref v (+ slice x8632::fulltag-imm)) *immediate-class*))
2301        #+x8664-target
2302        (do* ((slice 0 (+ 16 slice)))
2303             ((= slice 256))
2304          (declare (type (unsigned-byte 8) slice))
2305          (setf (%svref v (+ slice x8664::fulltag-even-fixnum)) *fixnum-class*
2306                (%svref v (+ slice x8664::fulltag-odd-fixnum))  *fixnum-class*
2307                (%svref v (+ slice x8664::fulltag-cons)) *cons-class*
2308                (%svref v (+ slice x8664::fulltag-imm-0)) *immediate-class*
2309                (%svref v (+ slice x8664::fulltag-imm-1)) *immediate-class*
2310                (%svref v (+ slice x8664::fulltag-tra-0)) *tagged-return-address-class*
2311                (%svref v (+ slice x8664::fulltag-tra-1)) *tagged-return-address-class*
2312                (%svref v (+ slice x8664::fulltag-nil)) *null-class*))
2313        (macrolet ((map-subtag (subtag class-name)
2314                     `(setf (%svref v ,subtag) (find-class ',class-name))))
2315          ;; immheader types map to built-in classes.
2316          (map-subtag target::subtag-bignum bignum)
2317          (map-subtag target::subtag-double-float double-float)
2318          (map-subtag target::subtag-single-float short-float)
2319          (map-subtag target::subtag-dead-macptr ivector)
2320          #-x86-target
2321          (map-subtag target::subtag-code-vector code-vector)
2322          #+ppc32-target
2323          (map-subtag ppc32::subtag-creole-object creole-object)
2324          (map-subtag target::subtag-xcode-vector xcode-vector)
2325          (map-subtag target::subtag-xfunction xfunction)
2326          (map-subtag target::subtag-single-float-vector simple-short-float-vector)
2327          #+64-bit-target
2328          (map-subtag target::subtag-u64-vector simple-unsigned-doubleword-vector)
2329          #+64-bit-target
2330          (map-subtag target::subtag-s64-vector simple-doubleword-vector)
2331          (map-subtag target::subtag-fixnum-vector simple-fixnum-vector)
2332          (map-subtag target::subtag-u32-vector simple-unsigned-long-vector)
2333          (map-subtag target::subtag-s32-vector simple-long-vector)
2334          (map-subtag target::subtag-u8-vector simple-unsigned-byte-vector)
2335          (map-subtag target::subtag-s8-vector simple-byte-vector)
2336          (map-subtag target::subtag-simple-base-string simple-base-string)
2337          (map-subtag target::subtag-u16-vector simple-unsigned-word-vector)
2338          (map-subtag target::subtag-s16-vector simple-word-vector)
2339          (map-subtag target::subtag-double-float-vector simple-double-float-vector)
2340          (map-subtag target::subtag-bit-vector simple-bit-vector)
2341          ;; Some nodeheader types map to built-in-classes; others require
2342          ;; further dispatching.
2343          (map-subtag target::subtag-ratio ratio)
2344          (map-subtag target::subtag-complex complex)
2345          (map-subtag target::subtag-catch-frame catch-frame)
2346          (map-subtag target::subtag-hash-vector hash-table-vector)
2347          (map-subtag target::subtag-value-cell value-cell)
2348          (map-subtag target::subtag-pool pool)
2349          (map-subtag target::subtag-weak population)
2350          (map-subtag target::subtag-package package)
2351          (map-subtag target::subtag-simple-vector simple-vector)
2352          (map-subtag target::subtag-slot-vector slot-vector)
2353          #+x8664-target (map-subtag x8664::subtag-symbol symbol-vector)
2354          #+x8664-target (map-subtag x8664::subtag-function function-vector))
2355        (setf (%svref v target::subtag-arrayH)
2356              #'(lambda (x)
2357                  (if (logbitp $arh_simple_bit
2358                               (the fixnum (%svref x target::arrayH.flags-cell)))
2359                    *simple-array-class*
2360                    *array-class*)))
2361        ;; These need to be special-cased:
2362        (setf (%svref v target::subtag-macptr) #'foreign-class-of)
2363        (setf (%svref v target::subtag-character)
2364              #'(lambda (c) (let* ((code (%char-code c)))
2365                              (if (or (eq c #\NewLine)
2366                                      (and (>= code (char-code #\space))
2367                                           (< code (char-code #\rubout))))
2368                                *standard-char-class*
2369                                *base-char-class*))))
2370        (setf (%svref v target::subtag-struct)
2371              #'(lambda (s) (%structure-class-of s))) ; need DEFSTRUCT
2372        (setf (%svref v target::subtag-istruct)
2373              #'(lambda (i)
2374                  (let* ((cell (%svref i 0))
2375                         (wrapper (istruct-cell-info  cell)))
2376                    (if wrapper
2377                      (%wrapper-class wrapper)
2378                      (or (find-class (istruct-cell-name cell) nil)
2379                          *istruct-class*)))))
2380        (setf (%svref v target::subtag-basic-stream)
2381              #'(lambda (b) (%wrapper-class (basic-stream.wrapper b))))
2382        (setf (%svref v target::subtag-instance)
2383              #'%class-of-instance)
2384        (setf (%svref v #+ppc-target target::subtag-symbol
2385                      #+x8632-target target::subtag-symbol
2386                      #+x8664-target target::tag-symbol)
2387              #-ppc64-target
2388              #'(lambda (s) (if (eq (symbol-package s) *keyword-package*)
2389                              *keyword-class*
2390                              *symbol-class*))
2391              #+ppc64-target
2392              #'(lambda (s)
2393                  (if s
2394                    (if (eq (symbol-package s) *keyword-package*)
2395                      *keyword-class*
2396                      *symbol-class*)
2397                    *null-class*)))
2398       
2399        (setf (%svref v
2400                      #+ppc-target target::subtag-function
2401                      #+x8632-target target::subtag-function
2402                      #+x8664-target target::tag-function) 
2403              class-of-function-function)
2404        (setf (%svref v target::subtag-vectorH)
2405              #'(lambda (v)
2406                  (let* ((subtype (%array-header-subtype v)))
2407                    (declare (fixnum subtype))
2408                    (if (eql subtype target::subtag-simple-vector)
2409                      *general-vector-class*
2410                      #-x8664-target
2411                      (%svref *ivector-vector-classes*
2412                              #+ppc32-target
2413                              (ash (the fixnum (- subtype ppc32::min-cl-ivector-subtag))
2414                                   (- ppc32::ntagbits))
2415                              #+ppc64-target
2416                              (ash (the fixnum (logand subtype #x7f)) (- ppc64::nlowtagbits))
2417                              #+x8632-target
2418                              (ash (the fixnum (- subtype x8632::min-cl-ivector-subtag))
2419                                   (- x8632::ntagbits)))
2420                      #+x8664-target
2421                      (let* ((class (logand x8664::fulltagmask subtype))
2422                             (idx (ash subtype (- x8664::ntagbits))))
2423                        (cond ((= class x8664::fulltag-immheader-0)
2424                               (%svref *immheader-0-classes* idx))
2425                              ((= class x8664::fulltag-immheader-1)
2426                               (%svref *immheader-1-classes* idx))
2427                              ((= class x8664::fulltag-immheader-2)
2428                               (%svref *immheader-2-classes* idx))
2429                              (t *t-class*)))
2430                               
2431                      ))))
2432        (setf (%svref v target::subtag-lock)
2433              #'(lambda (thing)
2434                  (case (%svref thing target::lock.kind-cell)
2435                    (recursive-lock *recursive-lock-class*)
2436                    (read-write-lock *read-write-lock-class*)
2437                    (t *lock-class*))))
2438        v))
2439
2440
2441
2442
2443
2444  (defun no-class-error (x)
2445    (error "Bug (probably): can't determine class of ~s" x))
2446 
2447
2448                                        ; return frob from table
2449
2450
2451
2452
2453  )                                     ; end let
2454
2455
2456
2457(defun classp (x)
2458  (if (%standard-instance-p x)
2459    (< (the fixnum (instance.hash x)) max-class-ordinal)
2460    (and (typep x 'macptr) (foreign-classp x))))
2461
2462(set-type-predicate 'class 'classp)
2463
2464(defun subclassp (c1 c2)
2465  (and (classp c1)
2466       (classp c2)
2467       (not (null (memq c2 (%inited-class-cpl c1 t))))))
2468
2469(defun %class-get (class indicator &optional default)
2470  (let ((cell (assq indicator (%class-alist class))))
2471    (if cell (cdr cell) default)))
2472
2473(defun %class-put (class indicator value)
2474  (let ((cell (assq indicator (%class-alist class))))
2475    (if cell
2476      (setf (cdr cell) value)
2477      (push (cons indicator value) (%class-alist class))))
2478  value)
2479 
2480(defsetf %class-get %class-put)
2481
2482(defun %class-remprop (class indicator)
2483  (let* ((handle (cons nil (%class-alist class)))
2484         (last handle))
2485    (declare (dynamic-extent handle))
2486    (while (cdr last)
2487      (if (eq indicator (caar (%cdr last)))
2488        (progn
2489          (setf (%cdr last) (%cddr last))
2490          (setf (%class-alist class) (%cdr handle)))
2491        (setf last (%cdr last))))))   
2492
2493
2494(pushnew :primary-classes *features*)
2495
2496(defun %class-primary-p (class)
2497  (if (typep class 'slots-class)
2498    (%class-get class :primary-p)
2499    t))
2500
2501(defun (setf %class-primary-p) (value class)
2502  (if value
2503    (setf (%class-get class :primary-p) value)
2504    (progn
2505      (%class-remprop class :primary-p)
2506      nil)))
2507
2508;;; Returns the first element of the CPL that is primary
2509(defun %class-or-superclass-primary-p (class)
2510  (unless (class-has-a-forward-referenced-superclass-p class)
2511    (dolist (super (%inited-class-cpl class t))
2512      (when (and (typep super 'standard-class) (%class-primary-p super))
2513        (return super)))))
2514
2515
2516;;; Bootstrapping version of union
2517(unless (fboundp 'union)
2518(defun union (l1 l2)
2519  (dolist (e l1)
2520    (unless (memq e l2)
2521      (push e l2)))
2522  l2)
2523)
2524
2525;; Stub to prevent errors when the user doesn't define types
2526(defun type-intersect (type1 type2)
2527  (cond ((and (null type1) (null type2))
2528         nil)
2529        ((equal type1 type2)
2530         type1)
2531        ((subtypep type1 type2)
2532         type1)
2533        ((subtypep type2 type1)
2534         type2)
2535        (t `(and ,type1 ,type2))
2536        ;(t (error "type-intersect not implemented yet."))
2537        ))
2538
2539(defun %add-direct-methods (method)
2540  (dolist (spec (%method-specializers method))
2541    (%do-add-direct-method spec method)))
2542
2543(defun %do-add-direct-method (spec method)
2544  (pushnew method (specializer.direct-methods spec)))
2545
2546(defun %remove-direct-methods (method)
2547  (dolist (spec (%method-specializers method))
2548    (%do-remove-direct-method spec method)))
2549
2550(defun %do-remove-direct-method (spec method)
2551  (setf (specializer.direct-methods spec)
2552        (nremove method (specializer.direct-methods spec))))
2553
2554(ensure-generic-function 'initialize-instance
2555                         :lambda-list '(instance &rest initargs &key &allow-other-keys))
2556
2557(defmethod find-method ((generic-function standard-generic-function)
2558                        method-qualifiers specializers &optional (errorp t))
2559  (dolist (m (%gf-methods generic-function)
2560           (when errorp
2561             (cerror "Try finding the method again"
2562                     "~s has no method for ~s ~s"
2563                     generic-function method-qualifiers specializers)
2564             (find-method generic-function method-qualifiers specializers
2565                          errorp)))
2566    (flet ((err ()
2567             (error "Wrong number of specializers: ~s" specializers)))
2568      (let ((ss (%method-specializers m))
2569            (q (%method-qualifiers m))
2570            s)
2571        (when (equal q method-qualifiers)
2572          (dolist (spec (canonicalize-specializers specializers nil)
2573                   (if (null ss)
2574                     (return-from find-method m)
2575                     (err)))
2576            (unless (setq s (pop ss))
2577              (err))
2578            (unless (eq s spec)
2579              (return))))))))
2580
2581(defmethod create-reader-method-function ((class slots-class)
2582                                          (reader-method-class standard-reader-method)
2583                                          (dslotd direct-slot-definition))
2584  #+ppc-target
2585  (gvector :function
2586           (uvref *reader-method-function-proto* 0)
2587           (ensure-slot-id (%slot-definition-name dslotd))
2588           'slot-id-value
2589           nil                          ;method-function name
2590           (dpb 1 $lfbits-numreq (ash 1 $lfbits-method-bit)))
2591  #+x86-target
2592  (%clone-x86-function
2593   *reader-method-function-proto*
2594   (ensure-slot-id (%slot-definition-name dslotd))
2595   'slot-id-value
2596   nil                          ;method-function name
2597   (dpb 1 $lfbits-numreq (ash 1 $lfbits-method-bit))))
2598
2599(defmethod create-writer-method-function ((class slots-class)
2600                                          (writer-method-class standard-writer-method)
2601                                          (dslotd direct-slot-definition))
2602  #+ppc-target
2603  (gvector :function
2604           (uvref *writer-method-function-proto* 0)
2605           (ensure-slot-id (%slot-definition-name dslotd))
2606           'set-slot-id-value
2607           nil
2608           (dpb 2 $lfbits-numreq (ash 1 $lfbits-method-bit)))
2609  #+x86-target
2610    (%clone-x86-function
2611     *writer-method-function-proto*
2612     (ensure-slot-id (%slot-definition-name dslotd))
2613     'set-slot-id-value
2614     nil
2615     (dpb 2 $lfbits-numreq (ash 1 $lfbits-method-bit)))
2616  )
2617
2618
2619
2620
2621
2622
2623(defun %make-instance (class-cell &rest initargs)
2624  (declare (dynamic-extent initargs))
2625  (apply #'make-instance
2626         (or (class-cell-class class-cell) (class-cell-name  (the class-cell class-cell)))
2627         initargs))
2628
2629
2630(defmethod make-instance ((class symbol) &rest initargs)
2631  (declare (dynamic-extent initargs))
2632  (apply 'make-instance (find-class class) initargs))
2633
2634
2635(defmethod make-instance ((class standard-class) &rest initargs &key &allow-other-keys)
2636  (declare (dynamic-extent initargs))
2637  (%make-std-instance class initargs))
2638
2639(defmethod make-instance ((class std-class) &rest initargs &key &allow-other-keys)
2640  (declare (dynamic-extent initargs))
2641  (%make-std-instance class initargs))
2642
2643
2644(defun %make-std-instance (class initargs)
2645  (setq initargs (default-initargs class initargs))
2646  (when initargs
2647    (apply #'check-initargs
2648           nil class initargs t
2649           #'initialize-instance #'allocate-instance #'shared-initialize
2650           nil))
2651  (let ((instance (apply #'allocate-instance class initargs)))
2652    (apply #'initialize-instance instance initargs)
2653    instance))
2654
2655(defun default-initargs (class initargs)
2656  (unless (std-class-p class)
2657    (setq class (require-type class 'std-class)))
2658  (when (null (%class.cpl class)) (update-class class t))
2659  (let ((defaults ()))
2660    (dolist (key.form (%class-default-initargs class))
2661      (unless (pl-search initargs (%car key.form))
2662        (setq defaults
2663              (list* (funcall (caddr key.form))
2664                     (%car key.form)
2665                     defaults))))
2666    (when defaults
2667      (setq initargs (append initargs (nreverse defaults))))
2668    initargs))
2669
2670
2671(defun %allocate-std-instance (class)
2672  (unless (class-finalized-p class)
2673    (finalize-inheritance class))
2674  (let* ((wrapper (%class.own-wrapper class))
2675         (len (length (%wrapper-instance-slots wrapper))))
2676    (declare (fixnum len))
2677    (make-instance-vector wrapper len)))
2678
2679
2680
2681
2682(defmethod copy-instance ((instance standard-object))
2683  (let* ((new-slots (copy-uvector (instance.slots instance)))
2684         (copy (gvector :instance 0 (instance-class-wrapper instance) new-slots)))
2685    (setf (instance.hash copy) (strip-tag-to-fixnum copy)
2686          (slot-vector.instance new-slots) copy)))
2687
2688(defmethod initialize-instance ((instance standard-object) &rest initargs)
2689  (declare (dynamic-extent initargs))
2690  (apply 'shared-initialize instance t initargs))
2691
2692
2693(defmethod reinitialize-instance ((instance standard-object) &rest initargs)
2694  (declare (dynamic-extent initargs))
2695  (when initargs
2696    (check-initargs 
2697     instance nil initargs t #'reinitialize-instance #'shared-initialize))
2698  (apply 'shared-initialize instance nil initargs))
2699
2700(defmethod shared-initialize ((instance standard-object) slot-names &rest initargs)
2701  (declare (dynamic-extent initargs))
2702  (%shared-initialize instance slot-names initargs))
2703
2704(defmethod shared-initialize ((instance standard-generic-function) slot-names
2705                              &rest initargs)
2706  (declare (dynamic-extent initargs))
2707  (%shared-initialize instance slot-names initargs))
2708
2709
2710;;; Slot-value, slot-boundp, slot-makunbound, etc.
2711(declaim (inline find-slotd))
2712(defun find-slotd (name slots)
2713  (dolist (slotd slots)
2714    (when (eq name (standard-slot-definition.name slotd))
2715      (return slotd))))
2716
2717(declaim (inline %std-slot-vector-value))
2718
2719(defun %std-slot-vector-value (slot-vector slotd)
2720  (let* ((loc (standard-effective-slot-definition.location slotd)))
2721    (symbol-macrolet ((instance (slot-vector.instance slot-vector)))
2722      (typecase loc
2723        (fixnum
2724         (%slot-ref slot-vector loc))
2725        (cons
2726         (let* ((val (%cdr loc)))
2727           (if (eq val (%slot-unbound-marker))
2728             (slot-unbound (class-of instance) instance (standard-effective-slot-definition.name slotd))
2729           val)))
2730      (t
2731       (error "Slot definition ~s has invalid location ~s (allocation ~s)."
2732              slotd loc (slot-definition-allocation slotd)))))))
2733
2734
2735(defmethod slot-value-using-class ((class standard-class)
2736                                   instance
2737                                   (slotd standard-effective-slot-definition))
2738  (ecase (standard-slot-definition.allocation slotd)
2739    ((:instance :class)
2740     (%std-slot-vector-value (instance-slots instance) slotd))))
2741
2742(defun %maybe-std-slot-value-using-class (class instance slotd)
2743  (if (and (eql (typecode class) target::subtag-instance)
2744           (eql (typecode slotd) target::subtag-instance)
2745           (eq *standard-effective-slot-definition-class-wrapper*
2746               (instance.class-wrapper slotd))
2747           (eq *standard-class-wrapper* (instance.class-wrapper class)))
2748    (%std-slot-vector-value (instance-slots instance) slotd)
2749    (if (= (the fixnum (typecode instance)) target::subtag-struct)
2750      (struct-ref instance (standard-effective-slot-definition.location slotd))
2751      (slot-value-using-class class instance slotd))))
2752
2753
2754(declaim (inline  %set-std-slot-vector-value))
2755
2756(defun %set-std-slot-vector-value (slot-vector slotd  new)
2757  (let* ((loc (standard-effective-slot-definition.location slotd))
2758         (type (standard-effective-slot-definition.type slotd))
2759         (type-predicate (standard-effective-slot-definition.type-predicate slotd)))
2760    (unless (or (eq new (%slot-unbound-marker))
2761                (null type-predicate)
2762                (funcall type-predicate new))
2763      (error 'bad-slot-type
2764             :instance (slot-vector.instance slot-vector)
2765             :datum new :expected-type type
2766             :slot-definition slotd))
2767    (typecase loc
2768      (fixnum
2769       (setf (%svref slot-vector loc) new))
2770      (cons
2771       (setf (%cdr loc) new))
2772      (t
2773       (error "Slot definition ~s has invalid location ~s (allocation ~s)."
2774              slotd loc (slot-definition-allocation slotd))))))
2775 
2776 
2777(defmethod (setf slot-value-using-class)
2778    (new
2779     (class standard-class)
2780     instance
2781     (slotd standard-effective-slot-definition))
2782  (ecase (standard-slot-definition.allocation slotd)
2783    ((:instance :class)
2784     (%set-std-slot-vector-value (instance-slots instance) slotd new))))
2785
2786
2787(defun %maybe-std-setf-slot-value-using-class (class instance slotd new)
2788  (if (and (eql (typecode class) target::subtag-instance)
2789           (eql (typecode slotd) target::subtag-instance)
2790           (eq *standard-effective-slot-definition-class-wrapper*
2791               (instance.class-wrapper slotd))
2792           (eq *standard-class-wrapper* (instance.class-wrapper class)))
2793    ;; Not safe to use instance.slots here, since the instance is not
2794    ;; definitely of type SUBTAG-INSTANCE.  (Anyway, INSTANCE-SLOTS
2795    ;; should be inlined here.)
2796    (%set-std-slot-vector-value (instance-slots instance) slotd new)
2797    (if (structurep instance)
2798      (setf (struct-ref instance (standard-effective-slot-definition.location slotd))
2799            new)
2800      (setf (slot-value-using-class class instance slotd) new))))
2801
2802(defmethod slot-value-using-class ((class funcallable-standard-class)
2803                                   instance
2804                                   (slotd standard-effective-slot-definition))
2805  (%std-slot-vector-value (gf.slots instance) slotd))
2806
2807(defmethod (setf slot-value-using-class)
2808    (new
2809     (class funcallable-standard-class)
2810     instance
2811     (slotd standard-effective-slot-definition))
2812  (%set-std-slot-vector-value (gf.slots instance) slotd new))
2813
2814(defun slot-value (instance slot-name)
2815  (let* ((wrapper
2816          (let* ((w (instance-class-wrapper instance)))
2817            (if (eql 0 (%wrapper-hash-index w))
2818              (instance.class-wrapper (update-obsolete-instance instance))
2819              w)))
2820         (class (%wrapper-class wrapper))
2821         (slotd (find-slotd slot-name (if (%standard-instance-p class)
2822                                        (%class.slots class)
2823                                        (class-slots class)))))
2824    (if slotd
2825      (%maybe-std-slot-value-using-class class instance slotd)
2826      (if (typep slot-name 'symbol)
2827        (restart-case
2828         (values (slot-missing class instance slot-name 'slot-value))
2829         (continue ()
2830                   :report "Try accessing the slot again"
2831                   (slot-value instance slot-name))
2832         (use-value (value)
2833                    :report "Return a value"
2834                    :interactive (lambda ()
2835                                   (format *query-io* "~&Value to use: ")
2836                                   (list (read *query-io*)))
2837                    value))
2838        (report-bad-arg slot-name 'symbol)))))
2839
2840
2841(defmethod slot-unbound (class instance slot-name)
2842  (declare (ignore class))
2843  (restart-case (error 'unbound-slot :name slot-name :instance instance)
2844    (use-value (value)
2845      :report "Return a value"
2846      :interactive (lambda ()
2847                     (format *query-io* "~&Value to use: ")
2848                     (list (read *query-io*)))
2849      value)))
2850
2851
2852
2853(defmethod slot-makunbound-using-class ((class slots-class)
2854                                        instance
2855                                        (slotd standard-effective-slot-definition))
2856  (setf (slot-value-using-class class instance slotd) (%slot-unbound-marker))
2857  instance)
2858
2859(defmethod slot-missing (class object slot-name operation &optional new-value)
2860  (declare (ignore class operation new-value))
2861  (error "~s has no slot named ~s." object slot-name))
2862
2863
2864(defun set-slot-value (instance name value)
2865  (let* ((wrapper
2866          (let* ((w (instance-class-wrapper instance)))
2867            (if (eql 0 (%wrapper-hash-index w))
2868              (instance.class-wrapper (update-obsolete-instance instance))
2869              w)))
2870         (class (%wrapper-class wrapper))
2871         (slotd (find-slotd name (if (%standard-instance-p class)
2872                                   (%class.slots class)
2873                                   (class-slots class)))))
2874    (if slotd
2875      (%maybe-std-setf-slot-value-using-class class instance slotd value)
2876      (if (typep name 'symbol)
2877        (progn     
2878          (slot-missing class instance name 'setf value)
2879          value)
2880        (report-bad-arg name 'symbol)))))
2881
2882(defsetf slot-value set-slot-value)
2883
2884(defun slot-makunbound (instance name)
2885  (let* ((class (class-of instance))
2886         (slotd (find-slotd name (%class-slots class))))
2887    (if slotd
2888      (slot-makunbound-using-class class instance slotd)
2889      (slot-missing class instance name 'slot-makunbound))
2890    instance))
2891
2892(defun %std-slot-vector-boundp (slot-vector slotd)
2893  (let* ((loc (standard-effective-slot-definition.location slotd)))
2894    (typecase loc
2895      (fixnum
2896       (not (eq (%svref slot-vector loc) (%slot-unbound-marker))))
2897      (cons
2898       (not (eq (%cdr loc) (%slot-unbound-marker))))
2899      (t
2900       (error "Slot definition ~s has invalid location ~s (allocation ~s)."
2901                slotd loc (slot-definition-allocation slotd))))))
2902
2903(defun %maybe-std-slot-boundp-using-class (class instance slotd)
2904  (if (and (eql (typecode class) target::subtag-instance)
2905           (eql (typecode slotd) target::subtag-instance)
2906           (eq *standard-effective-slot-definition-class-wrapper*
2907               (instance.class-wrapper slotd))
2908           (eq *standard-class-wrapper* (instance.class-wrapper class)))
2909    (%std-slot-vector-boundp (instance-slots instance) slotd)
2910    (slot-boundp-using-class class instance slotd)))
2911
2912
2913(defmethod slot-boundp-using-class ((class standard-class)
2914                                    instance
2915                                    (slotd standard-effective-slot-definition))
2916  (ecase (standard-slot-definition.allocation slotd)
2917    ((:instance :class)
2918     (%std-slot-vector-boundp (instance-slots instance) slotd))))
2919
2920(defmethod slot-boundp-using-class ((class funcallable-standard-class)
2921                                    instance
2922                                    (slotd standard-effective-slot-definition))
2923  (%std-slot-vector-boundp (gf.slots instance) slotd))
2924
2925
2926
2927(defun slot-boundp (instance name)
2928  (let* ((wrapper
2929          (let* ((w (instance-class-wrapper instance)))
2930            (if (eql 0 (%wrapper-hash-index w))
2931              (instance.class-wrapper (update-obsolete-instance instance))
2932              w)))
2933         (class (%wrapper-class wrapper))
2934         (slotd (find-slotd name (if (%standard-instance-p class)
2935                                   (%class.slots class)
2936                                   (class-slots class)))))
2937    (if slotd
2938      (%maybe-std-slot-boundp-using-class class instance slotd)
2939      (if (typep name 'symbol)
2940        (values (slot-missing class instance name 'slot-boundp))
2941        (report-bad-arg name 'symbol)))))
2942
2943(defun slot-value-if-bound (instance name &optional default)
2944  (if (slot-boundp instance name)
2945    (slot-value instance name)
2946    default))
2947
2948(defun slot-exists-p (instance name)
2949  (let* ((class (class-of instance))
2950         (slots  (class-slots class)))
2951    (find-slotd name slots)))
2952
2953
2954(defun slot-id-value (instance slot-id)
2955  (let* ((wrapper (instance-class-wrapper instance)))
2956    (funcall (%wrapper-slot-id-value wrapper) instance slot-id)))
2957
2958(defun set-slot-id-value (instance slot-id value)
2959  (let* ((wrapper (instance-class-wrapper instance)))
2960    (funcall (%wrapper-set-slot-id-value wrapper) instance slot-id value)))
2961
2962(defun slot-id-boundp (instance slot-id)
2963  (let* ((wrapper (instance-class-wrapper instance))
2964         (class (%wrapper-class wrapper))
2965         (slotd (funcall (%wrapper-slot-id->slotd wrapper) instance slot-id)))
2966    (if slotd
2967      (%maybe-std-slot-boundp-using-class class instance slotd)
2968      (values (slot-missing class instance (slot-id.name slot-id) 'slot-boundp)))))
2969 
2970;;; returns nil if (apply gf args) wil cause an error because of the
2971;;; non-existance of a method (or if GF is not a generic function or the name
2972;;; of a generic function).
2973(defun method-exists-p (gf &rest args)
2974  (declare (dynamic-extent args))
2975  (when (symbolp gf)
2976    (setq gf (fboundp gf)))
2977  (when (typep gf 'standard-generic-function)
2978    (or (null args)
2979        (let* ((methods (sgf.methods gf)))
2980          (dolist (m methods)
2981            (when (null (%method-qualifiers m))
2982              (let ((specializers (%method-specializers m))
2983                    (args args))
2984                (when (dolist (s specializers t)
2985                        (unless (cond ((typep s 'eql-specializer) 
2986                                       (eql (eql-specializer-object s)
2987                                            (car args)))
2988                                      (t (memq s (%inited-class-cpl
2989                                                  (class-of (car args))))))
2990                          (return nil))
2991                        (pop args))
2992                  (return-from method-exists-p m)))))
2993          nil))))
2994
2995(defun funcall-if-method-exists (gf &optional default &rest args)
2996  (declare (dynamic-extent args))
2997  (if (apply #'method-exists-p gf args)
2998    (apply gf args)
2999    (if default (apply default args))))
3000
3001
3002(defun find-specializer (specializer)
3003  (if (and (listp specializer) (eql (car specializer) 'eql))
3004    (intern-eql-specializer (cadr specializer))
3005    (find-class specializer)))
3006
3007(defmethod make-instances-obsolete ((class symbol))
3008  (make-instances-obsolete (find-class class)))
3009
3010(defmethod make-instances-obsolete ((class standard-class))
3011  (let ((wrapper (%class-own-wrapper class)))
3012    (when wrapper
3013      (setf (%class-own-wrapper class) nil)
3014      (make-wrapper-obsolete wrapper)))
3015  class)
3016
3017(defmethod make-instances-obsolete ((class funcallable-standard-class))
3018  (let ((wrapper (%class.own-wrapper class)))
3019    (when wrapper
3020      (setf (%class-own-wrapper class) nil)
3021      (make-wrapper-obsolete wrapper)))
3022  class)
3023
3024(defmethod make-instances-obsolete ((class structure-class))
3025  ;; could maybe warn that instances are obsolete, but there's not
3026  ;; much that we can do about that.
3027  class)
3028
3029
3030
3031;;; A wrapper is made obsolete by setting the hash-index & instance-slots to 0
3032;;; The instance slots are saved for update-obsolete-instance
3033;;; by consing them onto the class slots.
3034;;; Method dispatch looks at the hash-index.
3035;;; slot-value & set-slot-value look at the instance-slots.
3036;;; Each wrapper may have an associated forwarding wrapper, which must
3037;;; also be made obsolete.  The forwarding-wrapper is stored in the
3038;;; hash table below keyed on the wrapper-hash-index of the two
3039;;; wrappers.
3040(defvar *forwarding-wrapper-hash-table* (make-hash-table :test 'eq)) 
3041
3042
3043(defun make-wrapper-obsolete (wrapper)
3044  (without-interrupts
3045   (let ((forwarding-info
3046          (unless (eql 0 (%wrapper-instance-slots wrapper))   ; already forwarded or obsolete?
3047            (%cons-forwarding-info (%wrapper-instance-slots wrapper)
3048                                   (%wrapper-class-slots wrapper)))))
3049     (when forwarding-info
3050       (setf (%wrapper-hash-index wrapper) 0
3051             (%wrapper-cpl wrapper) nil
3052             (%wrapper-cpl-bits wrapper) nil
3053             (%wrapper-instance-slots wrapper) 0
3054             (%wrapper-forwarding-info wrapper) forwarding-info
3055             (%wrapper-slot-id->slotd wrapper) #'%slot-id-lookup-obsolete
3056             (%wrapper-slot-id-value wrapper) #'%slot-id-ref-obsolete
3057             (%wrapper-set-slot-id-value wrapper) #'%slot-id-set-obsolete
3058             ))))
3059  wrapper)
3060
3061(defun %clear-class-primary-slot-accessor-offsets (class)
3062  (let ((info-list (%class-get class '%class-primary-slot-accessor-info)))
3063    (dolist (info info-list)
3064      (setf (%slot-accessor-info.offset info) nil))))
3065
3066(defun primary-class-slot-offset (class slot-name)
3067  (dolist (super (%class.cpl class))
3068    (let* ((pos (and (typep super 'standard-class)
3069                     (%class-primary-p super)
3070                     (dolist (slot (%class-slots class))
3071                       (when (eq (%slot-definition-allocation slot)
3072                                 :instance)
3073                         (when (eq slot-name (%slot-definition-name slot))
3074                           (return (%slot-definition-location slot))))))))
3075      (when pos (return pos)))))
3076
3077;;; Called by the compiler-macro expansion for slot-value
3078;;; info is the result of a %class-primary-slot-accessor-info call.
3079;;; value-form is specified if this is set-slot-value.
3080;;; Otherwise it's slot-value.
3081(defun primary-class-slot-value (instance info &optional (value-form nil value-form-p))
3082  (let ((slot-name (%slot-accessor-info.slot-name info)))
3083    (prog1
3084      (if value-form-p
3085        (setf (slot-value instance slot-name) value-form)
3086        (slot-value instance slot-name))
3087      (setf (%slot-accessor-info.offset info)
3088            (primary-class-slot-offset (class-of instance) slot-name)))))
3089
3090(defun primary-class-accessor (instance info &optional (value-form nil value-form-p))
3091  (let ((accessor (%slot-accessor-info.accessor info)))
3092    (prog1
3093      (if value-form-p
3094        (funcall accessor value-form instance)
3095        (funcall accessor instance))
3096      (let ((methods (compute-applicable-methods
3097                      accessor
3098                      (if value-form-p (list value-form instance) (list instance))))
3099            method)
3100        (when (and (eql (length methods) 1)
3101                   (typep (setq method (car methods)) 'standard-accessor-method))
3102          (let* ((slot-name (method-slot-name method)))
3103            (setf (%slot-accessor-info.offset info)
3104                  (primary-class-slot-offset (class-of instance) slot-name))))))))
3105
3106(defun exchange-slot-vectors-and-wrappers (a b)
3107  (if (typep a 'generic-function)
3108    (let* ((temp-wrapper (gf.instance.class-wrapper a))
3109           (orig-a-slots (gf.slots a))
3110           (orig-b-slots (gf.slots b)))
3111      (setf (gf.instance.class-wrapper a) (gf.instance.class-wrapper b)
3112            (gf.instance.class-wrapper b) temp-wrapper
3113            (gf.slots a) orig-b-slots
3114            (gf.slots b) orig-a-slots
3115            (slot-vector.instance orig-a-slots) b
3116            (slot-vector.instance orig-b-slots) a))   
3117    (let* ((temp-wrapper (instance.class-wrapper a))
3118           (orig-a-slots (instance.slots a))
3119           (orig-b-slots (instance.slots b)))
3120      (setf (instance.class-wrapper a) (instance.class-wrapper b)
3121            (instance.class-wrapper b) temp-wrapper
3122            (instance.slots a) orig-b-slots
3123            (instance.slots b) orig-a-slots
3124            (slot-vector.instance orig-a-slots) b
3125            (slot-vector.instance orig-b-slots) a))))
3126
3127
3128
3129
3130;;; How slot values transfer (from PCL):
3131;;;
3132;;; local  --> local        transfer
3133;;; local  --> shared       discard
3134;;; local  -->  --          discard
3135;;; shared --> local        transfer
3136;;; shared --> shared       discard
3137;;; shared -->  --          discard
3138;;;  --    --> local        added
3139;;;  --    --> shared        --
3140;;;
3141;;; See make-wrapper-obsolete to see how we got here.
3142;;; A word about forwarding.  When a class is made obsolete, the
3143;;; %wrapper-instance-slots slot of its wrapper is set to 0.
3144;;; %wrapper-class-slots = (instance-slots . class-slots)
3145;;; Note: this should stack-cons the new-instance if we can reuse the
3146;;; old instance or it's forwarded value.
3147(defun update-obsolete-instance (instance)
3148  (let* ((added ())
3149         (discarded ())
3150         (plist ()))
3151    (without-interrupts                 ; Not -close- to being correct
3152     (let* ((old-wrapper (standard-object-p instance)))
3153       (unless old-wrapper
3154         (when (standard-generic-function-p instance)
3155           (setq old-wrapper (gf.instance.class-wrapper instance)))
3156         (unless old-wrapper
3157           (report-bad-arg instance '(or standard-instance standard-generic-function))))
3158       (when (eql 0 (%wrapper-instance-slots old-wrapper))   ; is it really obsolete?
3159         (let* ((class (%wrapper-class old-wrapper))
3160                (new-wrapper (or (%class.own-wrapper class)
3161                                 (progn
3162                                   (update-class class t)
3163                                   (%class.own-wrapper class))))
3164                (forwarding-info (%wrapper-forwarding-info old-wrapper))
3165                (old-class-slots (%forwarding-class-slots forwarding-info))
3166                (old-instance-slots (%forwarding-instance-slots forwarding-info))
3167                (new-instance-slots (%wrapper-instance-slots new-wrapper))
3168                (new-class-slots (%wrapper-class-slots new-wrapper))
3169                (new-instance (allocate-instance class))
3170                (old-slot-vector (instance.slots instance))
3171                (new-slot-vector (instance.slots new-instance)))
3172             ;; Lots to do.  Hold onto your hat.
3173             (let* ((old-size (uvsize old-instance-slots))
3174                    (new-size (uvsize new-instance-slots)))
3175               (declare (fixnum old-size new-size))
3176               (dotimes (i old-size)
3177                 (declare (fixnum i))
3178                 (let* ((slot-name (%svref old-instance-slots i))
3179                        (pos (%vector-member slot-name new-instance-slots))
3180                        (val (%svref old-slot-vector (%i+ i 1))))
3181                   (if pos
3182                     (setf (%svref new-slot-vector (%i+ pos 1)) val)
3183                     (progn
3184                       (push slot-name discarded)
3185                       (unless (eq val (%slot-unbound-marker))
3186                         (setf (getf plist slot-name) val))))))
3187               ;; Go through old class slots
3188               (dolist (pair old-class-slots)
3189                 (let* ((slot-name (%car pair))
3190                        (val (%cdr pair))
3191                        (pos (%vector-member slot-name new-instance-slots)))
3192                   (if pos
3193                     (setf (%svref new-slot-vector (%i+ pos 1)) val)
3194                     (progn
3195                       (push slot-name discarded)
3196                       (unless (eq val (%slot-unbound-marker))
3197                         (setf (getf plist slot-name) val))))))
3198               ; Go through new instance slots
3199               (dotimes (i new-size)
3200                 (declare (fixnum i))
3201                 (let* ((slot-name (%svref new-instance-slots i)))
3202                   (unless (or (%vector-member slot-name old-instance-slots)
3203                               (assoc slot-name old-class-slots))
3204                     (push slot-name added))))
3205               ;; Go through new class slots
3206               (dolist (pair new-class-slots)
3207                 (let ((slot-name (%car pair)))
3208                   (unless (or (%vector-member slot-name old-instance-slots)
3209                               (assoc slot-name old-class-slots))
3210                     (push slot-name added))))
3211               (exchange-slot-vectors-and-wrappers new-instance instance))))))
3212    ;; run user code with interrupts enabled.
3213    (update-instance-for-redefined-class instance added discarded plist))
3214  instance)
3215           
3216         
3217(defmethod update-instance-for-redefined-class ((instance standard-object)
3218                                                added-slots
3219                                                discarded-slots
3220                                                property-list
3221                                                &rest initargs)
3222  (declare (ignore discarded-slots property-list))
3223  (when initargs
3224    (check-initargs
3225     instance nil initargs t
3226     #'update-instance-for-redefined-class #'shared-initialize))
3227  (apply #'shared-initialize instance added-slots initargs))
3228
3229(defmethod update-instance-for-redefined-class ((instance standard-generic-function)
3230                                                added-slots
3231                                                discarded-slots
3232                                                property-list
3233                                                &rest initargs)
3234  (declare (ignore discarded-slots property-list))
3235  (when initargs
3236    (check-initargs
3237     instance nil initargs t
3238     #'update-instance-for-redefined-class #'shared-initialize))
3239  (apply #'shared-initialize instance added-slots initargs))
3240
3241(defun check-initargs (instance class initargs errorp &rest functions)
3242  (declare (dynamic-extent functions))
3243  (declare (list functions))
3244  (setq class (require-type (or class (class-of instance)) 'std-class))
3245  (unless (getf initargs :allow-other-keys)
3246    (let ((initvect (initargs-vector instance class functions)))
3247      (when (eq initvect t) (return-from check-initargs nil))
3248      (do* ((tail initargs (cddr tail))
3249            (initarg (car tail) (car tail))
3250            bad-keys? bad-key)
3251           ((null (cdr tail))
3252            (if bad-keys?
3253              (if errorp
3254                (signal-program-error
3255                 "~s is an invalid initarg to ~s for ~s.~%~
3256                                    Valid initargs: ~s."
3257                 bad-key
3258                 (function-name (car functions))
3259                 class (coerce initvect 'list))
3260                (values bad-keys? bad-key))))
3261        (if (eq initarg :allow-other-keys)
3262          (if (cadr tail)
3263            (return))                   ; (... :allow-other-keys t ...)
3264          (unless (or bad-keys? (%vector-member initarg initvect))
3265            (setq bad-keys? t
3266                  bad-key initarg)))))))
3267
3268(defun initargs-vector (instance class functions)
3269  (let ((index (cadr (assq (car functions) *initialization-invalidation-alist*))))
3270    (unless index
3271      (error "Unknown initialization function: ~s." (car functions)))
3272    (let ((initvect (%svref (instance-slots class) index)))
3273      (unless initvect
3274        (setf (%svref (instance-slots class) index) 
3275              (setq initvect (compute-initargs-vector instance class functions))))
3276      initvect)))
3277
3278
3279;; This is used for compile-time defclass option checking.
3280(defun class-keyvect (class-arg initargs)
3281  (let* ((class (if (typep class-arg 'class) class-arg (find-class class-arg nil)))
3282         (meta-arg (getf initargs :metaclass (if (and class (not (typep class 'forward-referenced-class)))
3283                                               (class-of class)
3284                                               *standard-class-class*)))
3285         (meta-spec (if (quoted-form-p meta-arg) (%cadr meta-arg) meta-arg))
3286         (meta (if (typep meta-spec 'class) meta-spec (find-class meta-spec nil))))
3287    (if (and meta (not (typep meta 'forward-referenced-class)))
3288      (compute-initargs-vector class meta (list #'initialize-instance #'allocate-instance #'shared-initialize) t)
3289      t)))
3290
3291(defun compute-initargs-vector (instance class functions &optional require-rest)
3292  (let ((initargs (class-slot-initargs class))
3293        (cpl (%inited-class-cpl class)))
3294    (dolist (f functions)         ; for all the functions passed
3295      #+no
3296      (if (logbitp $lfbits-aok-bit (lfun-bits f))
3297        (return-from compute-initargs-vector t))
3298      (dolist (method (%gf-methods f))   ; for each applicable method
3299        (let ((spec (car (%method-specializers method))))
3300          (when (if (typep spec 'eql-specializer)
3301                  (eql instance (eql-specializer-object spec))
3302                  (memq spec cpl))
3303            (let* ((func (%inner-method-function method))
3304                   (keyvect (if (and (logbitp $lfbits-aok-bit (lfun-bits func))
3305                                     (or (not require-rest)
3306                                         (logbitp $lfbits-rest-bit (lfun-bits func))))
3307                              (return-from compute-initargs-vector t)
3308                              (lfun-keyvect func))))
3309              (dovector (key keyvect)
3310                (pushnew key initargs)))))))   ; add all of the method's keys
3311    (apply #'vector initargs)))
3312
3313
3314
3315;;; A useful function
3316(defun class-make-instance-initargs (class)
3317  (setq class (require-type (if (symbolp class) (find-class class) class)
3318                            'std-class))
3319  (flet ((iv (class &rest functions)
3320           (declare (dynamic-extent functions))
3321           (initargs-vector (class-prototype class) class functions)))
3322    (let ((initvect (apply #'iv
3323                           class
3324                           #'initialize-instance #'allocate-instance #'shared-initialize
3325                           nil)))
3326      (if (eq initvect 't)
3327        t
3328        (concatenate 'list initvect)))))
3329
3330                                   
3331
3332;;; This is part of the MOP
3333;;; Maybe it was, at one point in the distant past ...
3334(defmethod class-slot-initargs ((class slots-class))
3335  (collect ((initargs))
3336    (dolist (slot (%class-slots class) (initargs))
3337      (dolist (i (%slot-definition-initargs slot))
3338        (initargs i)))))
3339
3340 
3341(defun maybe-update-obsolete-instance (instance)
3342  (let ((wrapper (standard-object-p instance)))
3343    (unless wrapper
3344              (when (typep instance 'funcallable-standard-object)
3345          (setq wrapper (gf.instance.class-wrapper instance)))
3346     
3347      (unless wrapper
3348        (report-bad-arg instance '(or standard-object funcallable-standard-object))))
3349    (when (eql 0 (%wrapper-hash-index wrapper))
3350      (update-obsolete-instance instance)))
3351  instance)
3352
3353
3354;;; If you ever reference one of these through anyone who might call
3355;;; update-obsolete-instance, you will lose badly.
3356(defun %maybe-forwarded-instance (instance)
3357  (maybe-update-obsolete-instance instance)
3358  instance)
3359
3360
3361
3362(defmethod change-class (instance
3363                         (new-class symbol)
3364                         &rest initargs &key &allow-other-keys)
3365  (declare (dynamic-extent initargs))
3366  (apply #'change-class instance (find-class new-class) initargs))
3367
3368(defmethod change-class ((instance standard-object)
3369                         (new-class standard-class)
3370                          &rest initargs &key &allow-other-keys)
3371  (declare (dynamic-extent initargs))
3372  (%change-class instance new-class initargs))
3373
3374
3375(defun %change-class (object new-class initargs)
3376  (let* ((old-class (class-of object))
3377         (old-wrapper (%class.own-wrapper old-class))
3378         (new-wrapper (or (%class.own-wrapper new-class)
3379                          (progn
3380                            (update-class new-class t)
3381                            (%class.own-wrapper new-class))))
3382         (old-instance-slots-vector (%wrapper-instance-slots old-wrapper))
3383         (new-instance-slots-vector (%wrapper-instance-slots new-wrapper))
3384         (num-new-instance-slots (length new-instance-slots-vector))
3385         (new-object (allocate-instance new-class)))
3386    (declare (fixnum num-new-instance-slots)
3387             (simple-vector new-instance-slots-vector old-instance-slots-vector))
3388    ;; Retain local slots shared between the new class and the old.
3389    (do* ((new-pos 0 (1+ new-pos))
3390          (new-slot-location 1 (1+ new-slot-location)))
3391         ((= new-pos num-new-instance-slots))
3392      (declare (fixnum new-pos new-slot-location))
3393      (let* ((old-pos (position (svref new-instance-slots-vector new-pos)
3394                                old-instance-slots-vector :test #'eq)))
3395        (when old-pos
3396          (setf (%standard-instance-instance-location-access
3397                 new-object
3398                 new-slot-location)
3399                (%standard-instance-instance-location-access
3400                 object
3401                 (the fixnum (1+ (the fixnum old-pos))))))))
3402    ;; If the new class defines a local slot whos name matches
3403    ;; that of a shared slot in the old class, the shared slot's
3404    ;; value is used to initialize the new instance's local slot.
3405    (dolist (shared-slot (%wrapper-class-slots old-wrapper))
3406      (destructuring-bind (name . value) shared-slot
3407        (let* ((new-slot-pos (position name new-instance-slots-vector
3408                                       :test #'eq)))
3409          (if new-slot-pos
3410            (setf (%standard-instance-instance-location-access
3411                   new-object
3412                   (the fixnum (1+ (the fixnum new-slot-pos))))
3413                  value)))))
3414    (exchange-slot-vectors-and-wrappers object new-object)
3415    (apply #'update-instance-for-different-class new-object object initargs)
3416    object))
3417
3418(defmethod update-instance-for-different-class ((previous standard-object)
3419                                                (current standard-object)
3420                                                &rest initargs)
3421  (declare (dynamic-extent initargs))
3422  (%update-instance-for-different-class previous current initargs))
3423
3424(defun %update-instance-for-different-class (previous current initargs)
3425  (when initargs
3426    (check-initargs
3427     current nil initargs t
3428     #'update-instance-for-different-class #'shared-initialize))
3429  (let* ((previous-slots (class-slots (class-of previous)))
3430         (current-slots (class-slots (class-of current)))
3431         (added-slot-names ()))
3432    (dolist (s current-slots)
3433      (let* ((name (%slot-definition-name s)))
3434        (unless (find-slotd name previous-slots)
3435          (push name added-slot-names))))
3436    (apply #'shared-initialize
3437           current
3438           added-slot-names
3439           initargs)))
3440
3441
3442
3443
3444;;; Clear all the valid initargs caches.
3445(defun clear-valid-initargs-caches ()
3446  (map-classes #'(lambda (name class)
3447                   (declare (ignore name))
3448                   (when (std-class-p class)
3449                     (setf (%class.make-instance-initargs class) nil
3450                           (%class.reinit-initargs class) nil
3451                           (%class.redefined-initargs class) nil
3452                           (%class.changed-initargs class) nil)))))
3453
3454(defun clear-clos-caches ()
3455  (clear-all-gf-caches)
3456  (clear-valid-initargs-caches))
3457
3458(defmethod allocate-instance ((class standard-class) &rest initargs)
3459  (declare (ignore initargs))
3460  (%allocate-std-instance class))
3461
3462(defmethod allocate-instance ((class funcallable-standard-class) &rest initargs)
3463  (declare (ignore initargs))
3464  (%allocate-gf-instance class))
3465
3466(unless *initialization-invalidation-alist*
3467  (setq *initialization-invalidation-alist*
3468        (list (list #'initialize-instance %class.make-instance-initargs)
3469              (list #'allocate-instance %class.make-instance-initargs)
3470              (list #'reinitialize-instance %class.reinit-initargs)
3471              (list #'shared-initialize 
3472                    %class.make-instance-initargs %class.reinit-initargs
3473                    %class.redefined-initargs %class.changed-initargs)
3474              (list #'update-instance-for-redefined-class
3475                    %class.redefined-initargs)
3476              (list #'update-instance-for-different-class
3477                    %class.changed-initargs))))
3478
3479
3480(defstatic *initialization-function-lists*
3481  (list (list #'initialize-instance #'allocate-instance #'shared-initialize)
3482        (list #'reinitialize-instance #'shared-initialize)
3483        (list #'update-instance-for-redefined-class #'shared-initialize)
3484        (list #'update-instance-for-different-class #'shared-initialize)))
3485
3486
3487
3488(unless *clos-initialization-functions*
3489  (setq *clos-initialization-functions*
3490        (list #'initialize-instance #'allocate-instance #'shared-initialize
3491              #'reinitialize-instance
3492              #'update-instance-for-different-class #'update-instance-for-redefined-class)))
3493
3494(defun compute-initialization-functions-alist ()
3495  (let ((res nil)
3496        (lists *initialization-function-lists*))
3497    (dolist (cell *initialization-invalidation-alist*)
3498      (let (res-list)
3499        (dolist (slot-num (cdr cell))
3500          (push
3501           (ecase slot-num
3502             (#.%class.make-instance-initargs 
3503              (assq #'initialize-instance lists))
3504             (#.%class.reinit-initargs
3505              (assq #'reinitialize-instance lists))
3506             (#.%class.redefined-initargs
3507              (assq #'update-instance-for-redefined-class lists))
3508             (#.%class.changed-initargs
3509              (assq #'update-instance-for-different-class lists)))
3510           res-list))
3511        (push (cons (car cell) (nreverse res-list)) res)))
3512    (setq *initialization-functions-alist* res)))
3513
3514(compute-initialization-functions-alist)
3515
3516                 
3517
3518
3519
3520
3521;;; Need to define this for all of the BUILT-IN-CLASSes.
3522(defmethod class-prototype ((class class))
3523  (%class.prototype class))
3524
3525(defmethod class-prototype ((class std-class))
3526  (or (%class.prototype class)
3527      (setf (%class.prototype class) (allocate-instance class))))
3528
3529
3530(defun gf-class-prototype (class)
3531  (%allocate-gf-instance class))
3532
3533
3534
3535(defmethod class-prototype ((class structure-class))
3536  (or (%class.prototype class)
3537      (setf (%class.prototype class)
3538            (let* ((sd (gethash (class-name class) %defstructs%))
3539                   (slots (class-slots class))
3540                   (proto (allocate-typed-vector :struct (1+ (length slots)))))
3541              (setf (uvref proto 0) (sd-superclasses sd))
3542              (dolist (slot slots proto)
3543                (setf (slot-value-using-class class proto slot)
3544                      (funcall (slot-definition-initfunction slot))))))))
3545
3546
3547(defmethod remove-method ((generic-function standard-generic-function)
3548                          (method standard-method))
3549  (when (eq generic-function (%method-gf method))
3550    (%remove-standard-method-from-containing-gf method))
3551  generic-function)
3552
3553
3554
3555(defmethod function-keywords ((method standard-method))
3556  (let ((f (%inner-method-function method)))
3557    (values
3558     (concatenate 'list (lfun-keyvect f))
3559     (%ilogbitp $lfbits-aok-bit (lfun-bits f)))))
3560
3561(defmethod no-next-method ((generic-function standard-generic-function)
3562                           (method standard-method)
3563                           &rest args)
3564  (error "There is no next method for ~s~%args: ~s" method args))
3565
3566(defmethod add-method ((generic-function standard-generic-function) (method standard-method))
3567  (%add-standard-method-to-standard-gf generic-function method))
3568
3569(defmethod no-applicable-method (gf &rest args)
3570  (cerror "Try calling it again"
3571          "There is no applicable method for the generic function:~%  ~s~%when called with arguments:~%  ~s" gf args)
3572  (apply gf args))
3573
3574
3575(defmethod no-applicable-primary-method (gf methods)
3576  (%method-combination-error "No applicable primary methods for ~s~@
3577                              Applicable methods: ~s" gf methods))
3578
3579(defmethod compute-applicable-methods ((gf standard-generic-function) args)
3580  (%compute-applicable-methods* gf args))
3581
3582(defun %compute-applicable-methods+ (gf &rest args)
3583  (declare (dynamic-extent args))
3584  (%compute-applicable-methods* gf args))
3585
3586(defun %compute-applicable-methods* (gf args)
3587  (let* ((methods (%gf-methods gf))
3588         (args-length (length args))
3589         (bits (inner-lfun-bits gf))
3590         arg-count res)
3591    (when methods
3592      (setq arg-count (length (%method-specializers (car methods))))
3593      (unless (<= arg-count args-length)
3594        (error "Too few args to ~s" gf))
3595      (unless (or (logbitp $lfbits-rest-bit bits)
3596                  (logbitp $lfbits-restv-bit bits)
3597                  (logbitp $lfbits-keys-bit bits)
3598                  (<= args-length 
3599                      (+ (ldb $lfbits-numreq bits) (ldb $lfbits-numopt bits))))
3600        (error "Too many args to ~s" gf))
3601      (let ((cpls (make-list arg-count)))
3602        (declare (dynamic-extent cpls))
3603        (do* ((args-tail args (cdr args-tail))
3604              (cpls-tail cpls (cdr cpls-tail)))
3605            ((null cpls-tail))
3606          (setf (car cpls-tail)
3607                (%class-precedence-list (class-of (car args-tail)))))
3608        (dolist (m methods)
3609          (if (%method-applicable-p m args cpls)
3610            (push m res)))
3611        (sort-methods res cpls (%gf-precedence-list gf))))))
3612
3613
3614(defun %method-applicable-p (method args cpls)
3615  (do* ((specs (%method-specializers method) (%cdr specs))
3616        (args args (%cdr args))
3617        (cpls cpls (%cdr cpls)))
3618      ((null specs) t)
3619    (let ((spec (%car specs)))
3620      (if (typep spec 'eql-specializer)
3621        (unless (eql (%car args) (eql-specializer-object spec))
3622          (return nil))
3623        (unless (memq spec (%car cpls))
3624          (return nil))))))
3625
3626
3627;;; Need this so that (compute-applicable-methods
3628;;; #'class-precedence-list ...)  will not recurse.
3629(defun %class-precedence-list (class)
3630  (if (eq (class-of class) *standard-class-class*)
3631    (%inited-class-cpl class)
3632    (class-precedence-list class)))
3633
3634(defmethod class-precedence-list ((class class))
3635  (%inited-class-cpl class))
3636
3637
3638(defun make-all-methods-kernel ()
3639  (dolist (f (population.data %all-gfs%))
3640    (let ((smc *standard-method-class*))
3641      (dolist (method (slot-value-if-bound f 'methods))
3642        (when (eq (class-of method) smc)
3643          (change-class method *standard-kernel-method-class*))))))
3644
3645
3646(defun make-all-methods-non-kernel ()
3647  (dolist (f (population.data %all-gfs%))
3648    (let ((skmc *standard-kernel-method-class*))
3649      (dolist (method (slot-value-if-bound f 'methods))
3650        (when (eq (class-of method) skmc)
3651          (change-class method *standard-method-class*))))))
3652
3653
3654(defun required-lambda-list-args (l)
3655  (multiple-value-bind (ok req) (verify-lambda-list l)
3656    (unless ok (error "Malformed lambda-list: ~s" l))
3657    req))
3658
3659
3660(defun check-generic-function-lambda-list (ll &optional (errorp t))
3661  (multiple-value-bind (ok reqsyms opttail resttail keytail auxtail)
3662                       (verify-lambda-list ll)
3663    (declare (ignore reqsyms resttail))
3664    (when ok 
3665      (block checkit
3666        (when (eq (car opttail) '&optional)
3667          (dolist (elt (cdr opttail))
3668            (when (memq elt lambda-list-keywords) (return))
3669            (unless (or (symbolp elt)
3670                        (and (listp elt)
3671                             (non-nil-symbol-p (car elt))
3672                             (null (cdr elt))))
3673              (return-from checkit (setq ok nil)))))
3674        (dolist (elt (cdr keytail))
3675          (when (memq elt lambda-list-keywords) (return))
3676          (unless (or (symbolp elt)
3677                      (and (listp elt)
3678                           (or (non-nil-symbol-p (car elt))
3679                               (and (listp (car elt))
3680                                    (non-nil-symbol-p (caar elt))
3681                                    (non-nil-symbol-p (cadar elt))
3682                                    (null (cddar elt))))
3683                           (null (cdr elt))))
3684            (return-from checkit (setq ok nil))))
3685        (when auxtail (setq ok nil))))
3686    (when (and errorp (not ok))
3687      (signal-program-error "Bad generic function lambda list: ~s" ll))
3688    ok))
3689
3690
3691(defun canonicalize-argument-precedence-order (apo req)
3692  (cond ((equal apo req) nil)
3693        ((not (eql (length apo) (length req)))
3694         (signal-program-error "Lengths of ~S and ~S differ." apo req))
3695        (t (let ((res nil))
3696             (dolist (arg apo (nreverse res))
3697               (let ((index (position arg req)))
3698                 (if (or (null index) (memq index res))
3699                   (error "Missing or duplicate arguments in ~s" apo))
3700                 (push index res)))))))
3701
3702
3703(defun %defgeneric (function-name lambda-list method-combination generic-function-class
3704                                  options)
3705  (setq generic-function-class (find-class generic-function-class))
3706  (setq method-combination 
3707        (find-method-combination
3708         (class-prototype generic-function-class)
3709         (car method-combination)
3710         (cdr method-combination)))
3711  (let ((gf (fboundp function-name)))
3712    (when gf
3713      (dolist (method (%defgeneric-methods gf))
3714        (remove-method gf method))))
3715  (record-source-file function-name 'function)
3716  (record-arglist function-name lambda-list)
3717  (apply #'ensure-generic-function 
3718         function-name
3719         :lambda-list lambda-list
3720         :method-combination method-combination
3721         :generic-function-class generic-function-class
3722         options))
3723
3724
3725
3726
3727;;; Redefined in lib;method-combination.lisp
3728(defmethod find-method-combination ((gf standard-generic-function) type options)
3729  (unless (and (eq type 'standard) (null options))
3730    (error "non-standard method-combination not supported yet."))
3731  *standard-method-combination*)
3732
3733
3734
3735(defmethod add-direct-method ((spec specializer) (method method))
3736  (pushnew method (specializer.direct-methods spec)))
3737
3738(setf (fdefinition '%do-add-direct-method) #'add-direct-method)
3739
3740(defmethod remove-direct-method ((spec specializer) (method method))
3741  (setf (specializer.direct-methods spec)
3742        (nremove method (specializer.direct-methods spec))))
3743
3744(setf (fdefinition '%do-remove-direct-method) #'remove-direct-method)
3745
3746
3747
3748
3749
3750                                   
3751
3752
3753
3754(defvar *make-load-form-saving-slots-hash* (make-hash-table :test 'eq))
3755
3756(defun make-load-form-saving-slots (object &key
3757                                           (slot-names nil slot-names-p)
3758                                           environment)
3759  (declare (ignore environment))
3760  (let* ((class (class-of object))
3761         (class-name (class-name class))
3762         (structurep (structurep object))
3763         (sd (and structurep (require-type (gethash class-name %defstructs%) 'vector))))
3764    (unless (or structurep
3765                (standard-instance-p object))
3766      (%badarg object '(or standard-object structure-object)))
3767    (if slot-names-p
3768      (dolist (slot slot-names)
3769        (unless (slot-exists-p object slot)
3770          (error "~s has no slot named ~s" object slot)))
3771      (setq slot-names
3772            (if structurep
3773              (let ((res nil))
3774                (dolist (slot (sd-slots sd))
3775                  (unless (fixnump (car slot))
3776                    (push (%car slot) res)))
3777                (nreverse res))
3778              (mapcar '%slot-definition-name
3779                      (extract-instance-effective-slotds
3780                       (class-of object))))))
3781    (values
3782     (let* ((form (gethash class-name *make-load-form-saving-slots-hash*)))
3783       (or (and (consp form)
3784                (eq (car form) 'allocate-instance)
3785                form)
3786           (setf (gethash class-name *make-load-form-saving-slots-hash*)
3787                 `(allocate-instance (find-class ',class-name)))))
3788     ;; initform is NIL when there are no slots
3789     (when slot-names
3790       `(%set-slot-values
3791         ',object
3792         ',slot-names
3793         ',(let ((temp #'(lambda (slot)
3794                           (if (slot-boundp object slot)
3795                             (slot-value object slot)
3796                             (%slot-unbound-marker)))))
3797             (declare (dynamic-extent temp))
3798             (mapcar temp slot-names)))))))
3799
3800
3801   
3802
3803(defmethod allocate-instance ((class structure-class) &rest initargs)
3804  (declare (ignore initargs))
3805  (let* ((class-name (%class-name class))
3806         (sd (or (gethash class-name %defstructs%)
3807                 (error "Can't find structure named ~s" class-name)))
3808         (res (make-structure-vector (sd-size sd))))
3809    (setf (%svref res 0) (mapcar (lambda (x)
3810                                   (find-class-cell x t)) (sd-superclasses sd)))
3811    res))
3812
3813
3814(defun %set-slot-values (object slots values)
3815  (dolist (slot slots)
3816    (let ((value (pop values)))
3817      (if (eq value (%slot-unbound-marker))
3818        (slot-makunbound object slot)
3819        (setf (slot-value object slot) value)))))
3820
3821
3822(defun %recache-class-direct-methods ()
3823  (let ((*maintain-class-direct-methods* t))   ; in case we get an error
3824    (dolist (f (population-data %all-gfs%))
3825      (when (standard-generic-function-p f)
3826        (dolist (method (%gf-methods f))
3827          (%add-direct-methods method)))))
3828  (setq *maintain-class-direct-methods* t))   ; no error, all is well
3829
Note: See TracBrowser for help on using the repository browser.