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

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

Split INSTANCE-SLOTS into (inlineable) standard case, non-standard case.

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