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

Last change on this file since 601 was 601, checked in by gb, 16 years ago

DEFAULT-INITARGS: function follows form ...

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