source: branches/arm/level-1/l1-clos-boot.lisp @ 13779

Last change on this file since 13779 was 13779, checked in by gb, 9 years ago

Mostly minor ARM conditionalization.

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