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

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

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