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

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

INSTANCE-CLASS-WRAPPER: non-generic, split into standard, non-standard
instance cases.

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