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

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

Start setting class ordinals. Note that it's assumed that MAX-CLASS-ORDINAL
(1MB) is smaller than the value returned by (STRIP-TAG-TO-FIXNUM instance)
for any (heap-allocated) standard-instance.

Provide support for foreign-class-ordinals, though we don't yet implement
a foreign object domain that uses them.

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