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

Last change on this file since 9365 was 9365, checked in by gz, 12 years ago

New :UNIQUE-DCODE optional feature:

if ccl is built with

(rebuild-ccl :optional-features '(:unique-dcode))

then each generic function will have its own unique copy
of its dcode, whose name is a list (dcode-name gf-name).

This feature is not recommend for real use (for one thing,
it's known to break gf tracing), but may be helpful for
profiling.

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