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

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

Move %FIND-CLASSES% and accessor to level-0.

Start to bootstrap structure-type changes by making STRUCTURE-TYPEP
handle legacy/new cases.

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