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

Last change on this file since 9830 was 9830, checked in by mb, 12 years ago

Typo in the no-applicable-method default method.

The cerror should reapply the generic function to its args, like it says
its going to do, and not reapply #'no-applicable-method to the gf and th
eargs, like it does.

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