source: branches/qres/ccl/level-1/l1-clos-boot.lisp @ 15278

Last change on this file since 15278 was 14056, checked in by gz, 9 years ago

r13980 from trunk (defmethod memory leak)

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