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

Last change on this file since 9117 was 9117, checked in by gz, 13 years ago

Add CCL:TEST-CCL - runs the gcl test suite (checking it out into ccl:tests;
if necessary). This will print out a bunch of warnings early on (for now),
then sit there for a while (about 3 mins on a MacBook? Pro) and finally
report "No tests failed".

Propagate assorted small fixes from trunk:

r8996 - fix case of spurious defvar warning
r9027 - check arg count before deciding to use builtin-call
r9046 - small fix for ~@:C
r9047 - report a TYPE-ERROR when make-broadcast-stream is given a non-output-stream
r9048 - Make make-file-stream rejected wildcarded pathnames. Various tweaks to make

meta-. work when using pathnames relative to the file system's "current directory".

r9049 - make defclass check for illegal class options
r9052 - Don't constant-fold if arg count is obviously wrong.
r9059 - Try harder to do function calls as function calls when (OPTIMIZE (SAFETY 3))

is in effect.

r9060, r9061 - CTYPE-SUBTYPE: try harder in some cases.
r9068, r9069, r9103, r9104 - PPC2-REF-SYMBOL-VALUE: force boundp checks unless

*ppc2-reckless* (same policy as x86; the per-thread binding lookup is generally
more expensive than boundp trap these days.). Unless skipping boundp check, don't
ignore unused result (so we can error when safety is 3, mostly.)

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