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

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

Fix typo in error message (rededefining non-GF as GF.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 122.1 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 function ~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    (inner-lfun-bits gf (%ilogior (%ilsl $lfbits-gfn-bit 1)
755                                  (%ilogand $lfbits-args-mask
756                                            (lfun-bits (%method-function method))))))
757  gf)
758
759
760
761(defun %method-function-method (method-function)
762  (setq method-function
763        (closure-function
764         (if (function-encapsulation method-function)
765           (find-unencapsulated-definition method-function)
766           method-function)))
767  (setq method-function (require-type method-function 'method-function))
768  (lfun-name method-function))
769
770(defglobal %defgeneric-methods% (make-hash-table :test 'eq :weak t))
771
772(defun %defgeneric-methods (gf)
773   (gethash gf %defgeneric-methods%))
774
775(defun %set-defgeneric-methods (gf &rest methods)
776   (if methods
777     (setf (gethash gf %defgeneric-methods%) methods)
778     (remhash gf %defgeneric-methods%)))
779
780(defun %defgeneric-keys (gf)
781  (%gf-dispatch-table-keyvect (%gf-dispatch-table gf)))
782
783(defun %set-defgeneric-keys (gf keyvect)
784  (setf (%gf-dispatch-table-keyvect (%gf-dispatch-table gf)) keyvect))
785
786(defun congruent-lfbits-p (gbits mbits)
787  (and (eq (ldb $lfbits-numreq gbits) (ldb $lfbits-numreq mbits))
788       (eq (ldb $lfbits-numopt gbits) (ldb $lfbits-numopt mbits))
789       (eq (or (logbitp $lfbits-rest-bit gbits)
790               (logbitp $lfbits-restv-bit gbits)
791               (logbitp $lfbits-keys-bit gbits))
792           (or (logbitp $lfbits-rest-bit mbits)
793               (logbitp $lfbits-restv-bit mbits)
794               (logbitp $lfbits-keys-bit mbits)))))
795
796(defun congruent-lambda-lists-p (gf method &optional
797                                    error-p gbits mbits gkeys)
798  (unless gbits (setq gbits (inner-lfun-bits gf)))
799  (unless mbits (setq mbits (lfun-bits (%method-function method))))
800  (and (congruent-lfbits-p gbits mbits)
801       (or (and (or (logbitp $lfbits-rest-bit mbits)
802                    (logbitp $lfbits-restv-bit mbits))
803                (not (logbitp $lfbits-keys-bit mbits)))
804           (logbitp $lfbits-aok-bit mbits)
805           (progn
806             (unless gkeys (setq gkeys (%defgeneric-keys gf)))
807             (or (null gkeys)
808                 (eql 0 (length gkeys))
809                 (let ((mkeys (lfun-keyvect
810                               (%inner-method-function method))))
811                   (dovector (key gkeys t)
812                     (unless (find key mkeys :test 'eq)
813                       (if error-p
814                         (error "~s does not specify keys: ~s" method gkeys))
815                       (return nil)))))))))
816
817(defun %add-method (gf method)
818  (%add-standard-method-to-standard-gf gf method))
819
820(defun %add-standard-method-to-standard-gf (gfn method)
821  (when (%method-gf method)
822    (error "~s is already a method of ~s." method (%method-gf method)))
823  (set-gf-arg-info gfn :new-method method)
824  (let* ((dt (%gf-dispatch-table gfn))
825         (methods (sgf.methods gfn))
826         (specializers (%method-specializers method))
827         (qualifiers (%method-qualifiers method)))
828    (remove-obsoleted-combined-methods method dt specializers)
829    (apply #'invalidate-initargs-vector-for-gf gfn specializers)
830    (dolist (m methods)
831      (when (and (equal specializers (%method-specializers m))
832                 (equal qualifiers (%method-qualifiers m)))
833        (remove-method gfn m)
834        ;; There can be at most one match
835        (return)))
836    (push method (sgf.methods gfn))
837    (setf (%gf-dispatch-table-methods dt) (sgf.methods gfn))
838    (setf (%method-gf method) gfn)
839    (%add-direct-methods method)
840    (compute-dcode gfn dt)
841    (when (sgf.dependents gfn)
842      (map-dependents gfn #'(lambda (d)
843                              (update-dependent gfn d 'add-method method)))))
844  gfn)
845
846(defglobal *standard-kernel-method-class* nil)
847
848(defun redefine-kernel-method (method)
849  (when (and *warn-if-redefine-kernel*
850             (or (let ((class *standard-kernel-method-class*))
851                   (and class (typep method class)))
852                 (and (standard-method-p method)
853                      (kernel-function-p (%method-function method)))))
854    (cerror "Replace the definition of ~S."
855            "The method ~S is predefined in OpenMCL." method)))
856
857; Called by the expansion of generic-labels
858(defun %add-methods (gf &rest methods)
859  (declare (dynamic-extent methods))
860  (dolist (m methods)
861    (add-method gf m)))
862
863(defun methods-congruent-p (m1 m2)
864  (when (and (standard-method-p m1)(standard-method-p m2))
865    (when (equal (%method-qualifiers m1) (%method-qualifiers m2))
866      (let ((specs (%method-specializers m1)))
867        (dolist (msp (%method-specializers m2) t)
868          (let ((spec (%pop specs)))
869            (unless (eq msp spec)
870              (return nil))))))))
871
872(defvar *maintain-class-direct-methods* nil)
873
874
875
876; CAR is an EQL hash table for objects whose identity is not used by EQL
877; (numbers and macptrs)
878; CDR is a weak EQ hash table for other objects.
879(defvar *eql-methods-hashes* (cons (make-hash-table :test 'eql)
880                                   (make-hash-table :test 'eq :weak :key)))
881
882(defun eql-methods-cell (object &optional addp)
883  (let ((hashes *eql-methods-hashes*))
884    (without-interrupts
885     (let* ((hash (cond
886                   ((or (typep object 'number)
887                        (typep object 'macptr))
888                    (car hashes))
889                   (t (cdr hashes))))
890            (cell (gethash object hash)))
891       (when (and (null cell) addp)
892         (setf (gethash object hash) (setq cell (cons nil nil))))
893       cell))))
894
895
896
897
898(defun map-classes (function)
899  (with-hash-table-iterator (m %find-classes%)
900    (loop
901      (multiple-value-bind (found name cell) (m)
902        (declare (list cell))
903        (unless found (return))
904        (when (cdr cell)
905          (funcall function name (cdr cell)))))))
906
907
908
909(defun %class-primary-slot-accessor-info (class accessor-or-slot-name &optional create?)
910  (let ((info-list (%class-get class '%class-primary-slot-accessor-info)))
911    (or (car (member accessor-or-slot-name info-list
912                     :key #'(lambda (x) (%slot-accessor-info.accessor x))))
913        (and create?
914             (let ((info (%cons-slot-accessor-info class accessor-or-slot-name)))
915               (setf (%class-get class '%class-primary-slot-accessor-info)
916                     (cons info info-list))
917               info)))))
918
919;; Clear the %class.primary-slot-accessor-info for an added or removed method's specializers
920(defun clear-accessor-method-offsets (gf method)
921  (when (or (typep method 'standard-accessor-method)
922            (member 'standard-accessor-method
923                    (%gf-methods gf)
924                    :test #'(lambda (sam meth)
925                             (declare (ignore sam))
926                             (typep meth 'standard-accessor-method))))
927    (labels ((clear-class (class)
928               (when (typep class 'standard-class)
929                 (let ((info (%class-primary-slot-accessor-info class gf)))
930                   (when info
931                     (setf (%slot-accessor-info.offset info) nil)))
932                 (mapc #'clear-class (%class.subclasses class)))))
933      (declare (dynamic-extent #'clear-class))
934      (mapc #'clear-class (%method-specializers method)))))
935
936;; Remove methods which specialize on a sub-class of method's specializers from
937;; the generic-function dispatch-table dt.
938(defun remove-obsoleted-combined-methods (method &optional dt
939                                                 (specializers (%method-specializers method)))
940  (without-interrupts
941   (unless dt
942     (let ((gf (%method-gf method)))
943       (when gf (setq dt (%gf-dispatch-table gf)))))
944   (when dt
945     (if specializers
946       (let* ((argnum (%gf-dispatch-table-argnum dt))
947              (class (nth argnum specializers))
948              (size (%gf-dispatch-table-size dt))
949              (index 0))
950         (clear-accessor-method-offsets (%gf-dispatch-table-gf dt) method)
951         (if (typep class 'eql-specializer)                   ; eql specializer
952           (setq class (class-of (eql-specializer-object class))))
953         (while (%i< index size)
954           (let* ((wrapper (%gf-dispatch-table-ref dt index))
955                  hash-index-0?
956                  (cpl (and wrapper
957                            (not (setq hash-index-0?
958                                       (eql 0 (%wrapper-hash-index wrapper))))
959                            (%inited-class-cpl
960                             (require-type (%wrapper-class wrapper) 'class)))))
961             (when (or hash-index-0? (and cpl (cpl-index class cpl)))
962               (setf (%gf-dispatch-table-ref dt index) *obsolete-wrapper*
963                     (%gf-dispatch-table-ref dt (%i+ index 1)) *gf-dispatch-bug*))
964             (setq index (%i+ index 2)))))
965       (setf (%gf-dispatch-table-ref dt 1) nil)))))   ; clear 0-arg gf cm
966
967; SETQ'd below after the GF's exist.
968(defvar *initialization-invalidation-alist* nil)
969
970; Called by %add-method, %remove-method
971(defun invalidate-initargs-vector-for-gf (gf &optional first-specializer &rest other-specializers)
972  (declare (ignore other-specializers))
973  (when (and first-specializer (typep first-specializer 'class))        ; no eql methods or gfs with no specializers need apply
974    (let ((indices (cdr (assq gf *initialization-invalidation-alist*))))
975      (when indices
976        (labels ((invalidate (class indices)
977                             (when (std-class-p class)   ; catch the class named T
978                               (dolist (index indices)
979                                 (setf (standard-instance-instance-location-access class index) nil)))
980                             (dolist (subclass (%class.subclasses class))
981                               (invalidate subclass indices))))
982          (invalidate first-specializer indices))))))
983
984;; Return two values:
985;; 1) the index of the first non-T specializer of method, or NIL if
986;;    all the specializers are T or only the first one is T
987;; 2) the index of the first non-T specializer
988(defun multi-method-index (method &aux (i 0) index)
989  (dolist (s (%method-specializers method) (values nil index))
990    (unless (eq s *t-class*)
991      (unless index (setq index i))
992      (unless (eql i 0) (return (values index index))))
993    (incf i)))
994
995(defun %remove-standard-method-from-containing-gf (method)
996  (setq method (require-type method 'standard-method))
997  (let ((gf (%method-gf method)))
998    (when gf
999      (let* ((dt (%gf-dispatch-table gf))
1000             (methods (sgf.methods gf)))
1001        (setf (%method-gf method) nil)
1002        (setq methods (nremove method methods))
1003        (setf (%gf-dispatch-table-methods dt) methods
1004              (sgf.methods gf) methods)
1005        (%remove-direct-methods method)
1006        (remove-obsoleted-combined-methods method dt)
1007        (apply #'invalidate-initargs-vector-for-gf gf (%method-specializers method))
1008        (compute-dcode gf dt)
1009        (when (sgf.dependents gf)
1010          (map-dependents
1011           gf
1012           #'(lambda (d)
1013               (update-dependent gf d 'remove-method method)))))))
1014  method)
1015
1016
1017(defvar *reader-method-function-proto*
1018  #'(lambda (instance)
1019      (slot-value instance 'x)))
1020
1021
1022           
1023 
1024(defvar *writer-method-function-proto*
1025  #'(lambda (new instance)
1026      (set-slot-value instance 'x new)))
1027
1028
1029
1030(defparameter dcode-proto-alist
1031  (list (cons #'%%one-arg-dcode *gf-proto-one-arg*)
1032        (cons #'%%1st-two-arg-dcode *gf-proto-two-arg*)))
1033   
1034(defun compute-dcode (gf &optional dt)
1035  (setq gf (require-type gf 'standard-generic-function))
1036  (unless dt (setq dt (%gf-dispatch-table gf)))
1037  (let* ((methods (%gf-dispatch-table-methods dt))
1038         (bits (inner-lfun-bits gf))
1039         (nreq (ldb $lfbits-numreq bits))
1040         (0-args? (eql 0 nreq))
1041         (other-args? (or (not (eql 0 (ldb $lfbits-numopt bits)))
1042                          (logbitp $lfbits-rest-bit bits)
1043                          (logbitp $lfbits-restv-bit bits)
1044                          (logbitp $lfbits-keys-bit bits)
1045                          (logbitp $lfbits-aok-bit bits)))
1046         multi-method-index 
1047         min-index)
1048    (when methods
1049      (unless 0-args?
1050        (dolist (m methods)
1051          (multiple-value-bind (mm-index index) (multi-method-index m)
1052            (when mm-index
1053              (if (or (null multi-method-index) (< mm-index multi-method-index))
1054                (setq multi-method-index mm-index)))
1055            (when index
1056              (if (or (null min-index) (< index min-index))
1057                (setq min-index index))))))
1058      (let ((dcode (if 0-args?
1059                     #'%%0-arg-dcode
1060                     (or (if multi-method-index
1061                           #'%%nth-arg-dcode)
1062                         (if (null other-args?)
1063                           (if (eql nreq 1)
1064                             #'%%one-arg-dcode
1065                             (if (eql nreq 2)
1066                               #'%%1st-two-arg-dcode
1067                               #'%%1st-arg-dcode))                           
1068                             #'%%1st-arg-dcode)))))
1069        (setq multi-method-index
1070              (if multi-method-index
1071                (if min-index
1072                  (min multi-method-index min-index)
1073                  multi-method-index)
1074                0))
1075        (let* ((old-dcode (%gf-dcode gf))
1076               (encapsulated-dcode-cons (and (combined-method-p old-dcode)
1077                                             (eq '%%call-gf-encapsulation 
1078                                                 (function-name (%combined-method-dcode old-dcode)))
1079                                             (cdr (%combined-method-methods old-dcode)))))
1080          (when (or (neq dcode (if encapsulated-dcode-cons (cdr encapsulated-dcode-cons) old-dcode))
1081                    (neq multi-method-index (%gf-dispatch-table-argnum dt)))
1082            (let ((proto (or (cdr (assq dcode dcode-proto-alist)) *gf-proto*)))
1083              (clear-gf-dispatch-table dt)
1084              (setf (%gf-dispatch-table-argnum dt) multi-method-index)
1085              (if encapsulated-dcode-cons ; and more?
1086                (let ((old-gf (car encapsulated-dcode-cons)))
1087                  (if (not (typep old-gf 'generic-function))
1088                    (error "Confused"))
1089                  ;(setf (uvref old-gf 0)(uvref proto 0))
1090                  (setf (cdr encapsulated-dcode-cons) dcode))
1091                (progn 
1092                  (setf (%gf-dcode gf) dcode)
1093                  (setf (uvref gf 0)(uvref proto 0)))))))
1094        (values dcode multi-method-index)))))
1095
1096(defun inherits-from-standard-generic-function-p (class)
1097  (memq *standard-generic-function-class*
1098        (%inited-class-cpl (require-type class 'class))))
1099
1100;;;;;;;;;;; The type system needs to get wedged into CLOS fairly early ;;;;;;;
1101
1102
1103; Could check for duplicates, but not really worth it.  They're all allocated here
1104(defun new-type-class (name)
1105  (let* ((class (%istruct 
1106                 'type-class 
1107                 name
1108                 #'missing-type-method
1109                 nil
1110                 nil
1111                 #'(lambda (x y) (hierarchical-union2 x y))
1112                 nil
1113                 #'(lambda (x y) (hierarchical-intersection2 x y))
1114                 nil
1115                 #'missing-type-method
1116                 nil
1117                 #'missing-type-method)))
1118    (push (cons name class) *type-classes*)
1119    class))
1120
1121;; There are ultimately about a dozen entries on this alist.
1122(defvar *type-classes* nil)
1123(declaim (special *wild-type* *empty-type* *universal-type*))
1124(defvar *type-kind-info* (make-hash-table :test #'equal))
1125
1126(defun info-type-kind (name)
1127  (gethash name *type-kind-info*))
1128
1129(defun (setf info-type-kind) (val name)
1130  (setf (gethash name *type-kind-info*) val))
1131
1132(defun missing-type-method (&rest foo)
1133  (error "Missing type method for ~S" foo))
1134         
1135(new-type-class 'values)
1136(new-type-class 'function)
1137(new-type-class 'constant)
1138(new-type-class 'wild)
1139(new-type-class 'bottom)
1140(new-type-class 'named)
1141(new-type-class 'hairy)
1142(new-type-class 'unknown)
1143(new-type-class 'number)
1144(new-type-class 'array)
1145(new-type-class 'member)
1146(new-type-class 'union)
1147(new-type-class 'foreign)
1148(new-type-class 'cons)
1149(new-type-class 'intersection)
1150(new-type-class 'negation)
1151(defparameter *class-type-class* (new-type-class 'class))
1152
1153
1154                       
1155;;;;;;;;;;;;;;;;;;;;;;;;  Instances and classes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1156
1157(defvar %find-classes% (make-hash-table :test 'eq))
1158
1159(defun class-cell-typep (form class-cell)
1160  (unless (listp class-cell)(error "puke"))
1161  (locally (declare (type list class-cell))
1162    (let ((class (cdr class-cell)))
1163      (when (not class)
1164        (setq class (find-class (car class-cell) nil))
1165        (when class (rplacd class-cell class)))
1166      (if class
1167        (not (null (memq class (%inited-class-cpl (class-of form)))))
1168        (if (fboundp 'typep)(typep form (car class-cell)) t)))))
1169
1170
1171;(defvar puke nil)
1172
1173(defun %require-type-class-cell (arg class-cell)
1174  ; sort of weird 
1175  (if (or ;(not *type-system-initialized*)
1176          (not (listp class-cell)))  ; bootstrapping prob no longer
1177    arg ; (progn (pushnew class-cell puke) arg)
1178    (if (class-cell-typep arg class-cell)
1179      arg
1180      (%kernel-restart $xwrongtype arg (car class-cell)))))
1181
1182
1183
1184(defun find-class-cell (name create?)
1185  (let ((cell (gethash name %find-classes%)))
1186    (or cell
1187        (and create?
1188             (setf (gethash name %find-classes%) (cons name nil))))))
1189
1190
1191(defun find-class (name &optional (errorp t) environment)
1192  (let* ((cell (find-class-cell name nil)))
1193    (declare (list cell))
1194    (or (cdr cell)
1195        (let ((defenv (and environment (definition-environment environment))))
1196          (when defenv
1197            (dolist (class (defenv.classes defenv))
1198              (when (eq name (%class.name class))
1199                (return class)))))
1200        (when (or errorp (not (symbolp name)))
1201          (error "Class named ~S not found." name)))))
1202
1203(defun set-find-class (name class)
1204  (clear-type-cache)
1205  (let ((cell (find-class-cell name class)))
1206    (when cell
1207      (setf (info-type-kind name) :instance)
1208      (setf (cdr (the cons cell)) class))
1209    class))
1210
1211
1212; bootstrapping definition. real one is in "sysutils.lisp"
1213
1214(defun built-in-type-p (name)
1215  (or (type-predicate name)
1216      (memq name '(signed-byte unsigned-byte mod 
1217                   values satisfies member and or not))
1218      (typep (find-class name nil) 'built-in-class)))
1219
1220
1221
1222(defun %compile-time-defclass (name environment)
1223  (unless (find-class name nil environment)
1224    (let ((defenv (definition-environment environment)))
1225      (when defenv
1226        (push (make-instance 'compile-time-class :name name)
1227              (defenv.classes defenv)))))
1228  name)
1229
1230(defun check-setf-find-class-protected-class (old-class new-class name)
1231  (when (and (standard-instance-p old-class)
1232             (%class.kernel-p old-class)
1233             *warn-if-redefine-kernel*
1234             ;; EQL might be necessary on foreign classes
1235             (not (eq new-class old-class)))
1236    (cerror "Setf (FIND-CLASS ~s) to the new class."
1237            "The class name ~s currently denotes the class ~s that
1238marked as being a critical part of the system; an attempt is being made
1239to replace that class with ~s" name old-class new-class)
1240    (setf (%class.kernel-p old-class) nil)))
1241
1242
1243(queue-fixup
1244 (without-interrupts 
1245  (defun set-find-class (name class)
1246    (setq name (require-type name 'symbol))
1247    (let ((cell (find-class-cell name class)))
1248      (declare (type list cell))
1249      (when *warn-if-redefine-kernel*
1250        (let ((old-class (cdr cell)))
1251          (when old-class
1252            (check-setf-find-class-protected-class old-class class name))))
1253      (when (null class)
1254        (when cell
1255          (setf (cdr cell) nil))
1256        (return-from set-find-class nil))
1257      (setq class (require-type class 'class))
1258      (when (built-in-type-p name)
1259        (unless (eq (cdr cell) class)
1260          (error "Cannot redefine built-in type name ~S" name)))
1261      (when (%deftype-expander name)
1262        (cerror "set ~S anyway, removing the ~*~S definition"
1263                "Cannot set ~S because type ~S is already defined by ~S"
1264                `(find-class ',name) name 'deftype)
1265        (%deftype name nil nil))
1266      (setf (info-type-kind name) :instance)
1267      (setf (cdr cell) class)))
1268  ) ; end of without-interrupts
1269 ) ; end of queue-fixup
1270
1271
1272
1273#|
1274; This tended to cluster entries in gf dispatch tables too much.
1275(defvar *class-wrapper-hash-index* 0)
1276(defun new-class-wrapper-hash-index ()
1277  (let ((index *class-wrapper-hash-index*))
1278    (setq *class-wrapper-hash-index*
1279        (if (< index (- most-positive-fixnum 2))
1280          ; Increment by two longwords.  This is important!
1281          ; The dispatch code will break if you change this.
1282          (%i+ index 3)                 ; '3 = 24 bytes = 6 longwords in lap.
1283          1))))
1284|#
1285
1286
1287
1288; Initialized after built-in-class is made
1289(defvar *built-in-class-wrapper* nil)
1290
1291(defun make-class-ctype (class)
1292  (%istruct 'class-ctype *class-type-class* nil class nil))
1293
1294
1295(defvar *t-class* (let ((class (%cons-built-in-class 't)))
1296                    (setf (%class.cpl class) (list class))
1297                    (setf (%class.own-wrapper class)
1298                          (%cons-wrapper class (new-class-wrapper-hash-index)))
1299                    (setf (%class.ctype class) (make-class-ctype class))
1300                    (setf (find-class 't) class)
1301                    class))
1302
1303(defun compute-cpl (class)
1304  (flet ((%real-class-cpl (class)
1305           (or (%class-cpl class)
1306               (compute-cpl class))))
1307    (let* ((predecessors (list (list class))) candidates cpl)
1308      (dolist (sup (%class-direct-superclasses class))
1309        (when (symbolp sup) (report-bad-arg sup 'class))
1310        (dolist (sup (%real-class-cpl sup))
1311          (unless (assq sup predecessors) (push (list sup) predecessors))))
1312      (labels ((compute-predecessors (class table)
1313                 (dolist (sup (%class-direct-superclasses class) table)
1314                   (compute-predecessors sup table)
1315                   ;(push class (cdr (assq sup table)))
1316                   (let ((a (assq sup table))) (%rplacd a (cons class (%cdr a))))
1317                   (setq class sup))))
1318        (compute-predecessors class predecessors))
1319      (setq candidates (list (assq class predecessors)))
1320      (while predecessors
1321        (dolist (c candidates (error "Inconsistent superclasses for ~d" class))
1322          (when (null (%cdr c))
1323            (setq predecessors (nremove c predecessors))
1324            (dolist (p predecessors) (%rplacd p (nremove (%car c) (%cdr p))))
1325            (setq candidates (nremove c candidates))
1326            (setq cpl (%rplacd c cpl))
1327            (dolist (sup (%class-direct-superclasses (%car c)))
1328              (when (setq c (assq sup predecessors)) (push c candidates)))
1329            (return))))
1330      (setq cpl (nreverse cpl))
1331      (do* ((tail cpl (%cdr tail))
1332            sup-cpl)
1333           ((null (setq sup-cpl (and (cdr tail) (%real-class-cpl (cadr tail))))))
1334        (when (equal (%cdr tail) sup-cpl)
1335          (setf (%cdr tail) sup-cpl)
1336          (return)))
1337      cpl)))
1338
1339(defun make-built-in-class (name &rest supers)
1340  (if (null supers)
1341    (setq supers (list *t-class*))
1342    (do ((supers supers (%cdr supers)))
1343        ((null supers))
1344      (when (symbolp (%car supers)) (%rplaca supers (find-class (%car supers))))))
1345  (let ((class (find-class name nil)))
1346    (if class
1347      (progn
1348        ;Must be debugging.  Give a try at redefinition...
1349        (dolist (sup (%class.local-supers class))
1350          (setf (%class.subclasses sup) (nremove class (%class.subclasses sup)))))
1351      (setq class (%cons-built-in-class name)))
1352    (dolist (sup supers)
1353      (setf (%class.subclasses sup) (cons class (%class.subclasses sup))))
1354    (setf (%class.local-supers class) supers)
1355    (setf (%class.cpl class) (compute-cpl class))
1356    (setf (%class.own-wrapper class) (%cons-wrapper class (new-class-wrapper-hash-index)))
1357    (setf (%class.ctype class)  (make-class-ctype class))
1358    (setf (find-class name) class)
1359    (dolist (sub (%class.subclasses class))   ; Only non-nil if redefining
1360      ;Recompute the cpl.
1361      (apply #'make-built-in-class (%class.name sub) (%class.local-supers sub)))
1362    class))
1363
1364;; This will be filled in below.  Need it defined now as it goes in the
1365;; instance.class-wrapper of all the classes that standard-class inherits from.
1366(defvar *standard-class-wrapper* 
1367  (%cons-wrapper 'standard-class))
1368
1369(defun make-standard-class (name &rest supers)
1370  (make-class name *standard-class-wrapper* supers))
1371
1372(defun make-class (name metaclass-wrapper supers &optional own-wrapper)
1373  (let ((class (if (find-class name nil)
1374                 (error "Attempt to remake standard class ~s" name)
1375                 (%cons-standard-class name metaclass-wrapper))))
1376    (if (null supers)
1377      (setq supers (list *standard-class-class*))
1378      (do ((supers supers (cdr supers))
1379           sup)
1380          ((null supers))
1381        (setq sup (%car supers))
1382        (if (symbolp sup) (setf (%car supers) (setq sup (find-class (%car supers)))))
1383        #+nil (unless (or (eq sup *t-class*) (std-class-p sup))
1384          (error "~a is not of type ~a" sup 'std-class))))
1385    (setf (%class.local-supers class) supers)
1386    (let ((cpl (compute-cpl class))
1387          (wrapper (if own-wrapper
1388                     (progn
1389                       (setf (%wrapper-class own-wrapper) class)
1390                       own-wrapper)
1391                     (%cons-wrapper class))))
1392      (setf (%class.cpl class) cpl
1393            (%wrapper-instance-slots wrapper) (vector)
1394            (%class.own-wrapper class) wrapper
1395            (%class.ctype class) (make-class-ctype class)
1396            (%class.slots class) nil
1397            (find-class name) class
1398            )
1399      (dolist (sup supers)
1400        (setf (%class.subclasses sup) (cons class (%class.subclasses sup))))
1401      class)))
1402
1403
1404(eval-when (:compile-toplevel :execute)
1405(declaim (inline standard-instance-p))
1406)
1407
1408
1409
1410
1411(defun standard-instance-p (i)
1412  (eq (typecode i) target::subtag-instance))
1413
1414
1415
1416(defun standard-object-p (thing)
1417 ; returns thing's class-wrapper or nil if it isn't a standard-object
1418  (if (standard-instance-p thing)
1419    (instance.class-wrapper thing)
1420    (if (typep thing 'macptr)
1421      (foreign-instance-class-wrapper thing))))
1422
1423
1424(defun std-class-p (class)
1425  ; (typep class 'std-class)
1426  ; but works at bootstrapping time as well
1427  (let ((wrapper (standard-object-p class)))
1428    (and wrapper
1429         (or (eq wrapper *standard-class-wrapper*)
1430             (memq *std-class-class* (%inited-class-cpl (%wrapper-class wrapper) t))))))
1431
1432(set-type-predicate 'std-class 'std-class-p)
1433
1434(defun slots-class-p (class)
1435  (let ((wrapper (standard-object-p class)))
1436    (and wrapper
1437         (or (eq wrapper *slots-class-wrapper*)
1438             (memq *slots-class* (%inited-class-cpl (%wrapper-class wrapper) t)))))) 
1439
1440(set-type-predicate 'slots-class 'slots-class-p)
1441
1442(defun specializer-p (thing)
1443  (memq *specializer-class* (%inited-class-cpl (class-of thing))))
1444
1445(defvar *standard-object-class* (make-standard-class 'standard-object *t-class*))
1446
1447(defvar *metaobject-class* (make-standard-class 'metaobject *standard-object-class*))
1448
1449(defvar *specializer-class* (make-standard-class 'specializer *metaobject-class*))
1450(defvar *eql-specializer-class* (make-standard-class 'eql-specializer *specializer-class*))
1451
1452(defvar *standard-method-combination*
1453  (make-instance-vector
1454   (%class.own-wrapper
1455    (make-standard-class
1456     'standard-method-combination
1457     (make-standard-class 'method-combination *metaobject-class*)))
1458   1))
1459
1460
1461(defun eql-specializer-p (x)
1462  (memq *eql-specializer-class* (%inited-class-cpl (class-of x))))
1463
1464(setf (type-predicate 'eql-specializer) 'eql-specializer-p)
1465
1466; The *xxx-class-class* instances get slots near the end of this file.
1467(defvar *class-class* (make-standard-class 'class *specializer-class*))
1468
1469(defvar *slots-class* (make-standard-class 'slots-class *class-class*))
1470(defvar *slots-class-wrapper* (%class.own-wrapper *slots-class*))
1471
1472; an implementation class that exists so that
1473; standard-class & funcallable-standard-class can have a common ancestor not
1474; shared by anybody but their subclasses.
1475
1476(defvar *std-class-class* (make-standard-class 'std-class *slots-class*))
1477
1478;The class of all objects whose metaclass is standard-class. Yow.
1479(defvar *standard-class-class* (make-standard-class 'standard-class *std-class-class*))
1480; Replace its wrapper and the circle is closed.
1481(setf (%class.own-wrapper *standard-class-class*) *standard-class-wrapper*
1482      (%wrapper-class *standard-class-wrapper*) *standard-class-class*
1483      (%wrapper-instance-slots *standard-class-wrapper*) (vector))
1484
1485(defvar *built-in-class-class* (make-standard-class 'built-in-class *class-class*))
1486(setf *built-in-class-wrapper* (%class.own-wrapper *built-in-class-class*)
1487      (instance.class-wrapper *t-class*) *built-in-class-wrapper*)
1488
1489(defvar *structure-class-class* (make-standard-class 'structure-class *slots-class*))
1490(defvar *structure-class-wrapper* (%class.own-wrapper *structure-class-class*))
1491(defvar *structure-object-class* 
1492  (make-class 'structure-object *structure-class-wrapper* (list *t-class*)))
1493
1494(defvar *forward-referenced-class-class*
1495  (make-standard-class 'forward-referenced-class *class-class*))
1496
1497(defvar *function-class* (make-built-in-class 'function))
1498
1499;Right now, all functions are compiled.
1500
1501
1502(defvar *compiled-function-class* *function-class*)
1503(setf (find-class 'compiled-function) *compiled-function-class*)
1504
1505(defvar *interpreted-function-class*
1506  (make-standard-class 'interpreted-function *function-class*))
1507
1508(defvar *compiled-lexical-closure-class* 
1509  (make-standard-class 'compiled-lexical-closure *function-class*))
1510
1511(defvar *interpreted-lexical-closure-class*
1512  (make-standard-class 'interpreted-lexical-closure *interpreted-function-class*))
1513
1514(defvar *funcallable-standard-object-class*
1515  (make-standard-class 'funcallable-standard-object
1516                       *standard-object-class* *function-class*))
1517
1518(defvar *funcallable-standard-class-class*
1519  (make-standard-class 'funcallable-standard-class *std-class-class*))
1520
1521(defvar *generic-function-class*
1522  (make-class 'generic-function
1523              (%class.own-wrapper *funcallable-standard-class-class*)
1524              (list *metaobject-class* *funcallable-standard-object-class*)))
1525(defvar *standard-generic-function-class*
1526  (make-class 'standard-generic-function
1527              (%class.own-wrapper *funcallable-standard-class-class*)
1528              (list *generic-function-class*)))
1529
1530; *standard-method-class* is upgraded to a real class below
1531(defvar *method-class* (make-standard-class 'method *metaobject-class*))
1532(defvar *standard-method-class* (make-standard-class 'standard-method *method-class*))
1533(defvar *accessor-method-class* (make-standard-class 'standard-accessor-method *standard-method-class*))
1534(defvar *standard-reader-method-class* (make-standard-class 'standard-reader-method *accessor-method-class*))
1535(defvar *standard-writer-method-class* (make-standard-class 'standard-writer-method *accessor-method-class*))
1536(defvar *method-function-class* (make-standard-class 'method-function *function-class*))
1537(defvar *interpreted-method-function-class* 
1538  (make-standard-class 'interpreted-method-function *method-function-class* *interpreted-function-class*))
1539
1540(defvar *combined-method-class* (make-standard-class 'combined-method *function-class*))
1541
1542(defvar *slot-definition-class* (make-standard-class 'slot-definition *metaobject-class*))
1543(defvar direct-slot-definition-class (make-standard-class 'direct-slot-definition
1544                                                           *slot-definition-class*))
1545(defvar effective-slot-definition-class (make-standard-class 'effective-slot-definition
1546                                                              *slot-definition-class*))
1547(defvar *standard-slot-definition-class* (make-standard-class 'standard-slot-definition
1548                                                              *slot-definition-class*))
1549(defvar *standard-direct-slot-definition-class* (make-class
1550                                                 'standard-direct-slot-definition
1551                                                 *standard-class-wrapper*
1552                                                 (list
1553                                                  *standard-slot-definition-class*
1554                                                  direct-slot-definition-class)))
1555
1556(defvar *standard-effective-slot-definition-class* (make-class
1557                                                    'standard-effective-slot-definition
1558                                                    *standard-class-wrapper*
1559                                                    (list
1560                                                     *standard-slot-definition-class*
1561                                                     effective-slot-definition-class)
1562))
1563
1564(defvar *standard-effective-slot-definition-class-wrapper*
1565  (%class.own-wrapper *standard-effective-slot-definition-class*))
1566
1567
1568
1569(let ((*dont-find-class-optimize* t))
1570
1571;; The built-in classes.
1572(defvar *array-class* (make-built-in-class 'array))
1573(defvar *character-class* (make-built-in-class 'character))
1574(make-built-in-class 'number)
1575(make-built-in-class 'sequence)
1576(defvar *symbol-class* (make-built-in-class 'symbol))
1577(defvar *immediate-class* (make-built-in-class 'immediate))   ; Random immediate
1578;Random uvectors - these are NOT class of all things represented by a uvector
1579;type. Just random uvectors which don't fit anywhere else.
1580(make-built-in-class 'ivector)   ; unknown ivector
1581(make-built-in-class 'gvector)   ; unknown gvector
1582(defvar *istruct-class* (make-built-in-class 'internal-structure))   ; unknown istruct
1583
1584(defvar *slot-vector-class* (make-built-in-class 'slot-vector (find-class 'gvector)))
1585
1586(defvar *macptr-class* (make-built-in-class 'macptr))
1587(defvar *foreign-standard-object-class*
1588  (make-standard-class 'foreign-standard-object
1589                       *standard-object-class* *macptr-class*))
1590
1591(defvar *foreign-class-class*
1592  (make-standard-class 'foreign-class *foreign-standard-object-class* *slots-class*))
1593
1594(make-built-in-class 'population)
1595(make-built-in-class 'pool)
1596(make-built-in-class 'package)
1597(defvar *lock-class* (make-built-in-class 'lock))
1598(defvar *recursive-lock-class* (make-built-in-class 'recursive-lock *lock-class*))
1599(defvar *read-write-lock-class* (make-built-in-class 'read-write-lock *lock-class*))
1600
1601(make-built-in-class 'slot-id *istruct-class*)
1602(make-built-in-class 'value-cell)
1603(make-built-in-class 'restart *istruct-class*)
1604(make-built-in-class 'hash-table *istruct-class*)
1605(make-built-in-class 'lexical-environment *istruct-class*)
1606(make-built-in-class 'compiler-policy *istruct-class*)
1607(make-built-in-class 'readtable *istruct-class*)
1608(make-built-in-class 'pathname *istruct-class*)
1609(make-built-in-class 'random-state *istruct-class*)
1610(make-built-in-class 'xp-structure *istruct-class*)
1611(make-built-in-class 'lisp-thread)
1612(make-built-in-class 'resource *istruct-class*)
1613(make-built-in-class 'periodic-task *istruct-class*)
1614(make-built-in-class 'semaphore *istruct-class*)
1615
1616(make-built-in-class 'type-class *istruct-class*)
1617
1618(defvar *ctype-class* (make-built-in-class 'ctype *istruct-class*))
1619(make-built-in-class 'key-info *istruct-class*)
1620(defvar *args-ctype* (make-built-in-class 'args-ctype *ctype-class*))
1621(make-built-in-class 'values-ctype *args-ctype*)
1622(make-built-in-class 'function-ctype *args-ctype*)
1623(make-built-in-class 'constant-ctype *ctype-class*)
1624(make-built-in-class 'named-ctype *ctype-class*)
1625(make-built-in-class 'cons-ctype *ctype-class*)
1626(make-built-in-class 'unknown-ctype (make-built-in-class 'hairy-ctype *ctype-class*))
1627(make-built-in-class 'numeric-ctype *ctype-class*)
1628(make-built-in-class 'array-ctype *ctype-class*)
1629(make-built-in-class 'member-ctype *ctype-class*)
1630(make-built-in-class 'union-ctype *ctype-class*)
1631(make-built-in-class 'foreign-ctype *ctype-class*)
1632(make-built-in-class 'class-ctype *ctype-class*)
1633(make-built-in-class 'negation-ctype *ctype-class*)
1634(make-built-in-class 'intersection-ctype *ctype-class*)
1635
1636
1637(make-built-in-class 'complex (find-class 'number))
1638(make-built-in-class 'real (find-class 'number))
1639(defvar *float-class* (make-built-in-class 'float (find-class 'real)))
1640(defvar *double-float-class* (make-built-in-class 'double-float (find-class 'float)))
1641(defvar *single-float-class*  (make-built-in-class 'single-float (find-class 'float)))
1642(setf (find-class 'short-float) *single-float-class*)
1643(setf (find-class 'long-float) *double-float-class*)
1644
1645(make-built-in-class 'rational (find-class 'real))
1646(make-built-in-class 'ratio (find-class 'rational))
1647(make-built-in-class 'integer (find-class 'rational))
1648(defvar *fixnum-class* (make-built-in-class 'fixnum (find-class 'integer)))
1649(make-built-in-class 'bignum (find-class 'integer))
1650
1651(make-built-in-class 'bit *fixnum-class*)
1652(make-built-in-class 'unsigned-byte (find-class 'integer))
1653(make-built-In-class 'signed-byte (find-class 'integer))
1654
1655
1656(make-built-in-class 'logical-pathname (find-class 'pathname))
1657
1658(defvar *base-char-class* (setf (find-class 'base-char) *character-class*))
1659(defvar *standard-char-class* (make-built-in-class 'standard-char *base-char-class*))
1660
1661#+who-needs-extended-char
1662(make-built-in-class 'extended-char *character-class*)
1663
1664(defvar *keyword-class* (make-built-in-class 'keyword *symbol-class*))
1665
1666(make-built-in-class 'list (find-class 'sequence))
1667(defvar *cons-class* (make-built-in-class 'cons (find-class 'list)))
1668(defvar *null-class* (make-built-in-class 'null *symbol-class* (find-class 'list)))
1669
1670(make-built-in-class 'svar)
1671(defvar *vector-class* (make-built-in-class 'vector *array-class* (find-class 'sequence)))
1672(make-built-in-class 'simple-array *array-class*)
1673(make-built-in-class 'simple-1d-array *vector-class* (find-class 'simple-array))
1674
1675;Maybe should do *float-array-class* etc?
1676;Also, should straighten out the simple-n-dim-array mess...
1677(make-built-in-class 'unsigned-byte-vector *vector-class*)
1678(make-built-in-class 'simple-unsigned-byte-vector (find-class 'unsigned-byte-vector) (find-class 'simple-1d-array))
1679(make-built-in-class 'unsigned-word-vector *vector-class*)
1680(make-built-in-class 'simple-unsigned-word-vector (find-class 'unsigned-word-vector) (find-class 'simple-1d-array))
1681
1682
1683(progn
1684  (make-built-in-class 'double-float-vector *vector-class*)
1685  (make-built-in-class 'short-float-vector *vector-class*)
1686  (setf (find-class 'long-float-vector) (find-class 'double-float-vector))
1687  (setf (find-class 'single-float-vector) (find-class 'short-float-vector))
1688  (make-built-in-class 'simple-double-float-vector (find-class 'double-float-vector) (find-class 'simple-1d-array))
1689  (make-built-in-class 'simple-short-float-vector (find-class 'short-float-vector) (find-class 'simple-1d-array))
1690  (setf (find-class 'simple-long-float-vector) (find-class 'simple-double-float-vector))
1691  (setf (find-class 'simple-single-float-vector) (find-class 'simple-short-float-vector))
1692)
1693 
1694(make-built-in-class 'long-vector *vector-class*)
1695(make-built-in-class 'simple-long-vector (find-class 'long-vector) (find-class 'simple-1d-array))
1696(make-built-in-class 'unsigned-long-vector *vector-class*)
1697(make-built-in-class 'simple-unsigned-long-vector (find-class 'unsigned-long-vector) (find-class 'simple-1d-array))
1698(make-built-in-class 'byte-vector *vector-class*)
1699(make-built-in-class 'simple-byte-vector (find-class 'byte-vector) (find-class 'simple-1d-array))
1700(make-built-in-class 'bit-vector *vector-class*)
1701(make-built-in-class 'simple-bit-vector (find-class 'bit-vector) (find-class 'simple-1d-array))
1702(make-built-in-class 'word-vector *vector-class*)
1703(make-built-in-class 'simple-word-vector (find-class 'word-vector) (find-class 'simple-1d-array))
1704(make-built-in-class 'string *vector-class*)
1705(make-built-in-class 'base-string (find-class 'string))
1706(make-built-in-class 'simple-string (find-class 'string) (find-class 'simple-1d-array))
1707(make-built-in-class 'simple-base-string (find-class 'base-string) (find-class 'simple-string))
1708(make-built-in-class 'general-vector *vector-class*)
1709(make-built-in-class 'simple-vector (find-class 'general-vector) (find-class 'simple-1d-array))
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720(make-built-in-class 'hash-table-vector)
1721(make-built-in-class 'catch-frame)
1722(make-built-in-class 'code-vector)
1723(make-built-in-class 'creole-object)
1724
1725(make-built-in-class 'xfunction)
1726(make-built-in-class 'xcode-vector)
1727
1728(defun class-cell-find-class (class-cell errorp)
1729  (unless (listp class-cell)
1730    (setq class-cell (%kernel-restart $xwrongtype class-cell 'list)))
1731  (locally (declare (type list class-cell))
1732    (let ((class (cdr class-cell)))
1733      (or class
1734          (and 
1735           (setq class (find-class (car class-cell) nil))
1736           (when class 
1737             (rplacd class-cell class)
1738             class))
1739          ;(if errorp (dbg-paws (format nil "Class ~s not found." (car class-cell))))))))
1740          (if errorp (error "Class ~s not found." (car class-cell)) nil)))))
1741 
1742
1743
1744
1745
1746; (%wrapper-class (instance.class-wrapper frob))
1747
1748
1749
1750(defvar *general-vector-class* (find-class 'general-vector))
1751
1752(defvar *ivector-vector-classes*
1753  (vector (find-class 'short-float-vector)
1754          (find-class 'unsigned-long-vector)
1755          (find-class 'long-vector)
1756          (find-class 'unsigned-byte-vector)
1757          (find-class 'byte-vector)
1758          (find-class 'base-string)
1759          (find-class 'base-string)     ;WRONG
1760          (find-class 'unsigned-word-vector)
1761          (find-class 'word-vector)
1762          (find-class 'double-float-vector)
1763          (find-class 'bit-vector)))
1764
1765
1766
1767
1768(defun make-foreign-object-domain (&key index name recognize class-of classp
1769                                        instance-class-wrapper
1770                                        class-own-wrapper
1771                                        slots-vector)
1772  (%istruct 'foreign-object-domain index name recognize class-of classp
1773            instance-class-wrapper class-own-wrapper slots-vector))
1774
1775(let* ((n-foreign-object-domains 0)
1776       (foreign-object-domains (make-array 10))
1777       (foreign-object-domain-lock (make-lock)))
1778  (defun register-foreign-object-domain (name
1779                                         &key
1780                                         recognize
1781                                         class-of
1782                                         classp
1783                                         instance-class-wrapper
1784                                         class-own-wrapper
1785                                         slots-vector)
1786    (with-lock-grabbed (foreign-object-domain-lock)
1787      (dotimes (i n-foreign-object-domains)
1788        (let* ((already (svref foreign-object-domains i)))
1789          (when (eq name (foreign-object-domain-name already))
1790            (setf (foreign-object-domain-recognize already) recognize
1791                  (foreign-object-domain-class-of already) class-of
1792                  (foreign-object-domain-classp already) classp
1793                  (foreign-object-domain-instance-class-wrapper already)
1794                  instance-class-wrapper
1795                  (foreign-object-domain-class-own-wrapper already)
1796                  class-own-wrapper
1797                  (foreign-object-domain-slots-vector already) slots-vector)
1798            (return-from register-foreign-object-domain i))))
1799      (let* ((i n-foreign-object-domains)
1800             (new (make-foreign-object-domain :index i
1801                                              :name name
1802                                              :recognize recognize
1803                                              :class-of class-of
1804                                              :classp classp
1805                                              :instance-class-wrapper
1806                                              instance-class-wrapper
1807                                              :class-own-wrapper
1808                                              class-own-wrapper
1809                                              :slots-vector
1810                                              slots-vector)))
1811        (incf n-foreign-object-domains)
1812        (if (= i (length foreign-object-domains))
1813          (setq foreign-object-domains (%extend-vector i foreign-object-domains (* i 2))))
1814        (setf (svref foreign-object-domains i) new)
1815        i)))
1816  (defun foreign-class-of (p)
1817    (funcall (foreign-object-domain-class-of (svref foreign-object-domains (%macptr-domain p))) p))
1818  (defun foreign-classp (p)
1819    (funcall (foreign-object-domain-classp (svref foreign-object-domains (%macptr-domain p))) p))
1820  (defun foreign-instance-class-wrapper (p)
1821    (funcall (foreign-object-domain-instance-class-wrapper (svref foreign-object-domains (%macptr-domain p))) p))
1822  (defun foreign-class-own-wrapper (p)
1823    (funcall (foreign-object-domain-class-own-wrapper (svref foreign-object-domains (%macptr-domain p))) p))
1824  (defun foreign-slots-vector (p)
1825    (funcall (foreign-object-domain-slots-vector (svref foreign-object-domains (%macptr-domain p))) p))
1826  (defun classify-foreign-pointer (p)
1827    (do* ((i (1- n-foreign-object-domains) (1- i)))
1828         ((zerop i) (error "this can't happen"))
1829      (when (funcall (foreign-object-domain-recognize (svref foreign-object-domains i)) p)
1830        (%set-macptr-domain p i)
1831        (return p)))))
1832
1833(defun constantly (x)
1834  #'(lambda (&rest ignore)
1835      (declare (dynamic-extent ignore)
1836               (ignore ignore))
1837      x))
1838
1839(register-foreign-object-domain :unclassified
1840                                :recognize #'(lambda (p)
1841                                               (declare (ignore p))
1842                                               (error "Shouldn't happen"))
1843                                :class-of #'(lambda (p)
1844                                              (foreign-class-of
1845                                               (classify-foreign-pointer p)))
1846                                :classp #'(lambda (p)
1847                                            (foreign-classp
1848                                             (classify-foreign-pointer p)))
1849                                :instance-class-wrapper
1850                                #'(lambda (p)
1851                                    (foreign-instance-class-wrapper
1852                                     (classify-foreign-pointer p)))
1853                                :class-own-wrapper
1854                                #'(lambda (p)
1855                                    (foreign-class-own-wrapper 
1856                                     (classify-foreign-pointer p)))
1857                                :slots-vector
1858                                #'(lambda (p)
1859                                    (foreign-slots-vector
1860                                     (classify-foreign-pointer p))))
1861
1862;;; "Raw" macptrs, that aren't recognized as "standard foreign objects"
1863;;; in some other domain, should always be recognized as such (and this
1864;;; pretty much has to be domain #1.)
1865
1866(register-foreign-object-domain :raw
1867                                :recognize #'true
1868                                :class-of (constantly *macptr-class*)
1869                                :classp #'false
1870                                :instance-class-wrapper
1871                                (constantly (%class.own-wrapper *macptr-class*))
1872                                :class-own-wrapper #'false
1873                                :slots-vector #'false)
1874
1875
1876(defparameter *class-table*
1877  (let* ((v (make-array 256 :initial-element nil)))
1878    ; Make one loop through the vector, initializing fixnum & list cells
1879    ; Set all things of ppc32::fulltag-imm to *immediate-class*, then special-case
1880    ; characters later.
1881    (do* ((slice 0 (+ 8 slice)))
1882         ((= slice 256))
1883      (declare (type (unsigned-byte 8) slice))
1884      (setf (%svref v (+ slice ppc32::fulltag-even-fixnum)) *fixnum-class*
1885            (%svref v (+ slice ppc32::fulltag-odd-fixnum))  *fixnum-class*
1886            (%svref v (+ slice ppc32::fulltag-cons)) *cons-class*
1887            (%svref v (+ slice ppc32::fulltag-nil)) *null-class*
1888            (%svref v (+ slice ppc32::fulltag-imm)) *immediate-class*))
1889    (macrolet ((map-subtag (subtag class-name)
1890               `(setf (%svref v ,subtag) (find-class ',class-name))))
1891      ; immheader types map to built-in classes.
1892      (map-subtag ppc32::subtag-bignum bignum)
1893      (map-subtag ppc32::subtag-double-float double-float)
1894      (map-subtag ppc32::subtag-single-float short-float)
1895      (map-subtag ppc32::subtag-dead-macptr ivector)
1896      (map-subtag ppc32::subtag-code-vector code-vector)
1897      (map-subtag ppc32::subtag-creole-object creole-object)
1898      (map-subtag ppc32::subtag-xcode-vector xcode-vector)
1899      (map-subtag ppc32::subtag-xfunction xfunction)
1900      (map-subtag ppc32::subtag-svar svar)
1901      (map-subtag ppc32::subtag-single-float-vector simple-short-float-vector)
1902      (map-subtag ppc32::subtag-u32-vector simple-unsigned-long-vector)
1903      (map-subtag ppc32::subtag-s32-vector simple-long-vector)
1904      (map-subtag ppc32::subtag-u8-vector simple-unsigned-byte-vector)
1905      (map-subtag ppc32::subtag-s8-vector simple-byte-vector)
1906      (map-subtag ppc32::subtag-simple-base-string simple-base-string)
1907      (map-subtag ppc32::subtag-u16-vector simple-unsigned-word-vector)
1908      (map-subtag ppc32::subtag-s16-vector simple-word-vector)
1909      (map-subtag ppc32::subtag-double-float-vector simple-double-float-vector)
1910      (map-subtag ppc32::subtag-bit-vector simple-bit-vector)
1911      ; Some nodeheader types map to built-in-classes; others
1912      ; require further dispatching.
1913      (map-subtag ppc32::subtag-ratio ratio)
1914      (map-subtag ppc32::subtag-complex complex)
1915      (map-subtag ppc32::subtag-catch-frame catch-frame)
1916      (map-subtag ppc32::subtag-lisp-thread lisp-thread)
1917      (map-subtag ppc32::subtag-hash-vector hash-table-vector)
1918      (map-subtag ppc32::subtag-value-cell value-cell)
1919      (map-subtag ppc32::subtag-pool pool)
1920      (map-subtag ppc32::subtag-weak population)
1921      (map-subtag ppc32::subtag-package package)
1922      (map-subtag ppc32::subtag-simple-vector simple-vector)
1923      (map-subtag ppc32::subtag-slot-vector slot-vector))
1924    (setf (%svref v ppc32::subtag-arrayH) *array-class*)
1925    ; These need to be special-cased:
1926    (setf (%svref v ppc32::subtag-macptr) #'foreign-class-of)
1927    (setf (%svref v ppc32::subtag-character)
1928          #'(lambda (c) (let* ((code (%char-code c)))
1929                            (if (or (eq c #\NewLine)
1930                                    (and (>= code (char-code #\space))
1931                                         (< code (char-code #\rubout))))
1932                              *standard-char-class*
1933                              *base-char-class*))))
1934    (setf (%svref v ppc32::subtag-struct)
1935          #'(lambda (s) (%structure-class-of s)))       ; need DEFSTRUCT
1936    (setf (%svref v ppc32::subtag-istruct)
1937          #'(lambda (i) (or (find-class (%svref i 0) nil) *istruct-class*)))
1938    (setf (%svref v ppc32::subtag-instance)
1939          #'%class-of-instance) ; #'(lambda (i) (%wrapper-class (instance.class-wrapper i))))
1940    (setf (%svref v ppc32::subtag-symbol)
1941          #'(lambda (s) (if (eq (symbol-package s) *keyword-package*)
1942                          *keyword-class*
1943                          *symbol-class*)))
1944    (setf (%svref v ppc32::subtag-function)
1945          #'(lambda (thing)
1946              (let ((bits (lfun-bits thing)))
1947                (declare (fixnum bits))
1948                (if (logbitp $lfbits-trampoline-bit bits)
1949                  ; closure
1950                  (if (logbitp $lfbits-evaluated-bit bits)
1951                    *interpreted-lexical-closure-class*
1952                    (let ((inner-fn (closure-function thing)))
1953                      (if (neq inner-fn thing)
1954                        (let ((inner-bits (lfun-bits inner-fn)))
1955                          (if (logbitp $lfbits-method-bit inner-bits)
1956                            *compiled-lexical-closure-class*
1957                            (if (logbitp $lfbits-gfn-bit inner-bits)
1958                              (%wrapper-class (gf.instance.class-wrapper thing))
1959                              (if (logbitp $lfbits-cm-bit inner-bits)
1960                                *combined-method-class*
1961                                *compiled-lexical-closure-class*))))
1962                          *compiled-lexical-closure-class*)))
1963                  (if (logbitp $lfbits-evaluated-bit bits)
1964                    (if (logbitp $lfbits-method-bit bits)
1965                      *interpreted-method-function-class*
1966                      *interpreted-function-class*)
1967                    (if (logbitp  $lfbits-method-bit bits)
1968                      *method-function-class* 
1969                      (if (logbitp $lfbits-gfn-bit bits)
1970                        (%wrapper-class (instance.class-wrapper thing))
1971                        (if (logbitp $lfbits-cm-bit bits)
1972                          *combined-method-class*
1973                          *compiled-function-class*))))))))
1974    (setf (%svref v ppc32::subtag-vectorH)
1975          #'(lambda (v)
1976              (let* ((subtype (%array-header-subtype v)))
1977                (declare (fixnum subtype))
1978                (if (eql subtype ppc32::subtag-simple-vector)
1979                  *general-vector-class*
1980                  (%svref *ivector-vector-classes*
1981                          (ash (the fixnum (- subtype ppc32::min-cl-ivector-subtag))
1982                               (- ppc32::ntagbits)))))))
1983    (setf (%svref v ppc32::subtag-lock)
1984          #'(lambda (thing)
1985              (case (%svref thing ppc32::lock.kind-cell)
1986                (recursive-lock *recursive-lock-class*)
1987                (read-write-lock *read-write-lock-class*)
1988                (t *lock-class*))))
1989    v))
1990
1991
1992
1993
1994
1995(defun no-class-error (x)
1996  (error "Bug (probably): can't determine class of ~s" x))
1997 
1998
1999  ; return frob from table
2000
2001
2002
2003
2004) ; end let
2005
2006; Can't use typep at bootstrapping time.
2007(defun classp (x)
2008  (or (and (typep x 'macptr) (foreign-classp x))                ; often faster
2009      (let ((wrapper (standard-object-p x)))
2010        (or
2011         (and wrapper
2012              (let ((super (%wrapper-class wrapper)))
2013                (memq *class-class* (%inited-class-cpl super t))))))))
2014
2015(set-type-predicate 'class 'classp)
2016
2017(defun subclassp (c1 c2)
2018  (and (classp c1)
2019       (classp c2)
2020       (not (null (memq c2 (%inited-class-cpl c1 t))))))
2021
2022(defun %class-get (class indicator &optional default)
2023  (let ((cell (assq indicator (%class-alist class))))
2024    (if cell (cdr cell) default)))
2025
2026(defun %class-put (class indicator value)
2027  (let ((cell (assq indicator (%class-alist class))))
2028    (if cell
2029      (setf (cdr cell) value)
2030      (push (cons indicator value) (%class-alist class))))
2031  value)
2032 
2033(defsetf %class-get %class-put)
2034(defun %class-remprop (class indicator)
2035  (let* ((handle (cons nil (%class-alist class)))
2036         (last handle))
2037    (declare (dynamic-extent handle))
2038    (while (cdr last)
2039      (if (eq indicator (caar (%cdr last)))
2040        (progn
2041          (setf (%cdr last) (%cddr last))
2042          (setf (%class-alist class) (%cdr handle)))
2043        (setf last (%cdr last))))))   
2044
2045
2046(pushnew :primary-classes *features*)
2047
2048(defun %class-primary-p (class)
2049  (if (typep class 'slots-class)
2050    (%class-get class :primary-p)
2051    t))
2052
2053(defun (setf %class-primary-p) (value class)
2054  (if value
2055    (setf (%class-get class :primary-p) value)
2056    (progn
2057      (%class-remprop class :primary-p)
2058      nil)))
2059
2060; Returns the first element of the CPL that is primary
2061(defun %class-or-superclass-primary-p (class)
2062  (unless (class-has-a-forward-referenced-superclass-p class)
2063    (dolist (super (%inited-class-cpl class t))
2064      (when (and (typep super 'standard-class) (%class-primary-p super))
2065        (return super)))))
2066
2067
2068; Bootstrapping version of union
2069(unless (fboundp 'union)
2070(defun union (l1 l2)
2071  (dolist (e l1)
2072    (unless (memq e l2)
2073      (push e l2)))
2074  l2)
2075)
2076
2077;; Stub to prevent errors when the user doesn't define types
2078(defun type-intersect (type1 type2)
2079  (cond ((and (null type1) (null type2))
2080         nil)
2081        ((equal type1 type2)
2082         type1)
2083        ((subtypep type1 type2)
2084         type1)
2085        ((subtypep type2 type1)
2086         type2)
2087        (t `(and ,type1 ,type2))
2088        ;(t (error "type-intersect not implemented yet."))
2089        ))
2090
2091(defun %add-direct-methods (method)
2092  (dolist (spec (%method-specializers method))
2093    (%do-add-direct-method spec method)))
2094
2095(defun %do-add-direct-method (spec method)
2096  (pushnew method (specializer.direct-methods spec)))
2097
2098(defun %remove-direct-methods (method)
2099  (dolist (spec (%method-specializers method))
2100    (%do-remove-direct-method spec method)))
2101
2102(defun %do-remove-direct-method (spec method)
2103  (setf (specializer.direct-methods spec)
2104        (nremove method (specializer.direct-methods spec))))
2105
2106(ensure-generic-function 'initialize-instance
2107                         :lambda-list '(instance &rest initargs &key &allow-other-keys))
2108
2109(defmethod find-method ((generic-function standard-generic-function)
2110                        method-qualifiers specializers &optional (errorp t))
2111  (dolist (m (%gf-methods generic-function)
2112           (if errorp
2113             (error "~s has no method for ~s ~s"
2114                    generic-function method-qualifiers specializers)))
2115    (flet ((err ()
2116             (error "Wrong number of specializers: ~s" specializers)))
2117      (let ((ss (%method-specializers m))
2118            (q (%method-qualifiers m))
2119            s)
2120        (when (equal q method-qualifiers)
2121          (dolist (spec specializers
2122                   (if (null ss)
2123                     (return-from find-method m)
2124                     (err)))
2125            (unless (setq s (pop ss))
2126              (err))
2127            (unless (eq s spec)
2128              (return))))))))
2129
2130(defmethod create-reader-method-function ((class slots-class)
2131                                          (reader-method-class standard-reader-method)
2132                                          (dslotd direct-slot-definition))
2133  (gvector :function
2134           (uvref *reader-method-function-proto* 0)
2135           (ensure-slot-id (%slot-definition-name dslotd))
2136           'slot-id-value
2137           nil                          ;method-function name
2138           (dpb 1 $lfbits-numreq (ash 1 $lfbits-method-bit))))
2139
2140(defmethod create-writer-method-function ((class slots-class)
2141                                          (writer-method-class standard-writer-method)
2142                                          (dslotd direct-slot-definition))
2143  (gvector :function
2144           (uvref *writer-method-function-proto* 0)
2145           (ensure-slot-id (%slot-definition-name dslotd))
2146           'set-slot-id-value
2147           nil
2148           (dpb 2 $lfbits-numreq (ash 1 $lfbits-method-bit))))
2149
2150
2151
2152
2153
2154
2155(defun %make-instance (class-cell &rest initargs)
2156  (declare (dynamic-extent initargs))
2157  (apply #'make-instance
2158         (or (cdr class-cell) (car (the list class-cell)))
2159         initargs))
2160
2161
2162(defmethod make-instance ((class symbol) &rest initargs)
2163  (declare (dynamic-extent initargs))
2164  (apply 'make-instance (find-class class) initargs))
2165
2166
2167(defmethod make-instance ((class standard-class) &rest initargs &key &allow-other-keys)
2168  (declare (dynamic-extent initargs))
2169  (%make-std-instance class initargs))
2170
2171(defmethod make-instance ((class std-class) &rest initargs &key &allow-other-keys)
2172  (declare (dynamic-extent initargs))
2173  (%make-std-instance class initargs))
2174
2175
2176(defun %make-std-instance (class initargs)
2177  (setq initargs (default-initargs class initargs))
2178  (when initargs
2179    (apply #'check-initargs
2180           nil class initargs t
2181           #'initialize-instance #'allocate-instance #'shared-initialize
2182           nil))
2183  (let ((instance (apply #'allocate-instance class initargs)))
2184    (apply #'initialize-instance instance initargs)
2185    instance))
2186
2187(defun default-initargs (class initargs)
2188  (unless (std-class-p class)
2189    (setq class (require-type class 'std-class)))
2190  (when (null (%class.cpl class)) (update-class class t))
2191  (let ((defaults ()))
2192    (dolist (key.form (%class-default-initargs class))
2193      (unless (pl-search initargs (%car key.form))
2194        (setq defaults
2195              (list* (funcall (caddr key.form))
2196                     (%car key.form)
2197                     defaults))))
2198    (when defaults
2199      (setq initargs (append initargs (nreverse defaults))))
2200    initargs))
2201
2202
2203(defun %allocate-std-instance (class)
2204  (unless (class-finalized-p class)
2205    (finalize-inheritance class))
2206  (let* ((wrapper (%class.own-wrapper class))
2207         (len (length (%wrapper-instance-slots wrapper))))
2208    (declare (fixnum len))
2209    (make-instance-vector wrapper len)))
2210
2211
2212
2213
2214(defmethod copy-instance ((instance standard-object))
2215  (let* ((new-slots (copy-uvector (instance.slots instance)))
2216         (copy (gvector :instance 0 (instance.class-wrapper instance) new-slots)))
2217    (setf (instance.hash copy) (strip-tag-to-fixnum copy)
2218          (slot-vector.instance new-slots) copy)))
2219
2220(defmethod initialize-instance ((instance standard-object) &rest initargs)
2221  (declare (dynamic-extent ini targs))
2222  (apply 'shared-initialize instance t initargs))
2223
2224
2225(defmethod reinitialize-instance ((instance standard-object) &rest initargs)
2226  (declare (dynamic-extent initargs))
2227  (when initargs
2228    (check-initargs 
2229     instance nil initargs t #'reinitialize-instance #'shared-initialize))
2230  (apply 'shared-initialize instance nil initargs))
2231
2232(defmethod shared-initialize ((instance standard-object) slot-names &rest initargs)
2233  (declare (dynamic-extent initargs))
2234  (%shared-initialize instance slot-names initargs))
2235
2236(defmethod shared-initialize ((instance standard-generic-function) slot-names
2237                              &rest initargs)
2238  (declare (dynamic-extent initargs))
2239  (%shared-initialize instance slot-names initargs))
2240
2241
2242;;; Slot-value, slot-boundp, slot-makunbound, etc.
2243(declaim (inline find-slotd))
2244(defun find-slotd (name slots)
2245  (find name slots :key #'%slot-definition-name))
2246
2247(declaim (inline %std-slot-vector-value))
2248
2249(defun %std-slot-vector-value (slot-vector slotd)
2250  (let* ((loc (standard-effective-slot-definition.location slotd)))
2251    (symbol-macrolet ((instance (slot-vector.instance slot-vector)))
2252      (typecase loc
2253        (fixnum
2254         (%slot-ref slot-vector loc))
2255        (cons
2256         (let* ((val (%cdr loc)))
2257           (if (eq val (%slot-unbound-marker))
2258             (slot-unbound (class-of instance) instance (standard-effective-slot-definition.name slotd))
2259           val)))
2260      (t
2261       (error "Slot definition ~s has invalid location ~s (allocation ~s)."
2262              slotd loc (slot-definition-allocation slotd)))))))
2263
2264
2265(defmethod slot-value-using-class ((class standard-class)
2266                                   instance
2267                                   (slotd standard-effective-slot-definition))
2268  (%std-slot-vector-value (instance-slots instance) slotd))
2269
2270(defun %maybe-std-slot-value-using-class (class instance slotd)
2271  (if (and (eql (typecode class) target::subtag-instance)
2272           (eql (typecode slotd) target::subtag-instance)
2273           (eq *standard-effective-slot-definition-class-wrapper*
2274               (instance.class-wrapper slotd))
2275           (eq *standard-class-wrapper* (instance.class-wrapper class)))
2276    (%std-slot-vector-value (instance-slots instance) slotd)
2277    (slot-value-using-class class instance slotd)))
2278
2279
2280(declaim (inline  %set-std-slot-vector-value))
2281
2282(defun %set-std-slot-vector-value (slot-vector slotd  new)
2283  (let* ((loc (standard-effective-slot-definition.location slotd))
2284         (type (standard-effective-slot-definition.type slotd))
2285         (type-predicate (standard-effective-slot-definition.type-predicate slotd)))
2286    (unless (or (eq new (%slot-unbound-marker))
2287                (funcall type-predicate new))
2288      (error 'bad-slot-type
2289             :instance (slot-vector.instance slot-vector)
2290             :datum new :expected-type type
2291             :slot-definition slotd))
2292    (typecase loc
2293      (fixnum
2294       (setf (%svref slot-vector loc) new))
2295      (cons
2296       (setf (%cdr loc) new))
2297      (t
2298       (error "Slot definition ~s has invalid location ~s (allocation ~s)."
2299              slotd loc (slot-definition-allocation slotd))))))
2300 
2301 
2302(defmethod (setf slot-value-using-class)
2303    (new
2304     (class standard-class)
2305     instance
2306     (slotd standard-effective-slot-definition))
2307  (%set-std-slot-vector-value (instance-slots instance) slotd new))
2308
2309
2310(defun %maybe-std-setf-slot-value-using-class (class instance slotd new)
2311  (if (and (eql (typecode class) target::subtag-instance)
2312           (eql (typecode slotd) target::subtag-instance)
2313           (eq *standard-effective-slot-definition-class-wrapper*
2314               (instance.class-wrapper slotd))
2315           (eq *standard-class-wrapper* (instance.class-wrapper class)))
2316    (%set-std-slot-vector-value (instance-slots instance) slotd new)
2317    (setf (slot-value-using-class class instance slotd) new)))
2318
2319(defmethod slot-value-using-class ((class funcallable-standard-class)
2320                                   instance
2321                                   (slotd standard-effective-slot-definition))
2322  (%std-slot-vector-value (gf.slots instance) slotd))
2323
2324(defmethod (setf slot-value-using-class)
2325    (new
2326     (class funcallable-standard-class)
2327     instance
2328     (slotd standard-effective-slot-definition))
2329  (%set-std-slot-vector-value (gf.slots instance) slotd new))
2330
2331(defun slot-value (instance slot-name)
2332  (let* ((class (class-of instance))
2333           (slotd (find-slotd slot-name (%class-slots class))))
2334      (if slotd
2335        (slot-value-using-class class instance slotd)
2336        (values (slot-missing class instance slot-name 'slot-value)))))
2337   
2338
2339
2340(defmethod slot-unbound (class instance slot-name)
2341  (declare (ignore class))
2342  (error 'unbound-slot :name slot-name :instance instance))
2343
2344
2345
2346(defmethod slot-makunbound-using-class ((class slots-class)
2347                                        instance
2348                                        (slotd standard-effective-slot-definition))
2349  (setf (slot-value-using-class class instance slotd) (%slot-unbound-marker))
2350  instance)
2351
2352(defmethod slot-missing (class object slot-name operation &optional new-value)
2353  (declare (ignore class operation new-value))
2354  (error "~s has no slot named ~s." object slot-name))
2355
2356
2357(defun set-slot-value (instance name value)
2358  (let* ((class (class-of instance))
2359             (slotd (find-slotd  name (%class-slots class))))
2360        (if slotd
2361          (setf (slot-value-using-class class instance slotd) value)
2362          (progn           
2363            (slot-missing class instance name 'setf value)
2364            value))))
2365
2366(defsetf slot-value set-slot-value)
2367
2368(defun slot-makunbound (instance name)
2369  (let* ((class (class-of instance))
2370         (slotd (find-slotd name (%class-slots class))))
2371    (if slotd
2372      (slot-makunbound-using-class class instance slotd)
2373      (slot-missing class instance name 'slot-makunbound))
2374    instance))
2375
2376(defun %std-slot-vector-boundp (slot-vector slotd)
2377  (let* ((loc (standard-effective-slot-definition.location slotd)))
2378    (typecase loc
2379      (fixnum
2380       (not (eq (%svref slot-vector loc) (%slot-unbound-marker))))
2381      (cons
2382       (not (eq (%cdr loc) (%slot-unbound-marker))))
2383      (t
2384       (error "Slot definition ~s has invalid location ~s (allocation ~s)."
2385                slotd loc (slot-definition-allocation slotd))))))
2386
2387(defmethod slot-boundp-using-class ((class standard-class)
2388                                    instance
2389                                    (slotd standard-effective-slot-definition))
2390  (%std-slot-vector-boundp (instance-slots instance) slotd))
2391
2392(defmethod slot-boundp-using-class ((class funcallable-standard-class)
2393                                    instance
2394                                    (slotd standard-effective-slot-definition))
2395  (%std-slot-vector-boundp (gf.slots instance) slotd))
2396
2397
2398
2399(defun slot-boundp (instance name)
2400  (let* ((class (class-of instance))
2401         (slotd (find-slotd name (%class-slots class))))
2402    (if slotd
2403      (slot-boundp-using-class class instance slotd)
2404      (values (slot-missing class instance name 'slot-boundp)))))
2405
2406(defun slot-value-if-bound (instance name &optional default)
2407  (if (slot-boundp instance name)
2408    (slot-value instance name)
2409    default))
2410
2411(defun slot-exists-p (instance name)
2412  (let* ((class (class-of instance))
2413         (slots  (class-slots class)))
2414    (find-slotd name slots)))
2415
2416
2417(defun slot-id-value (instance slot-id)
2418  (let* ((wrapper (or (standard-object-p instance)
2419                    (%class-own-wrapper (class-of instance)))))
2420    (funcall (%wrapper-slot-id-value wrapper) instance slot-id)))
2421
2422(defun set-slot-id-value (instance slot-id value)
2423  (let* ((wrapper (or (standard-object-p instance)
2424                    (%class-own-wrapper (class-of instance)))))
2425    (funcall (%wrapper-set-slot-id-value wrapper) instance slot-id value)))
2426
2427; returns nil if (apply gf args) wil cause an error because of the
2428; non-existance of a method (or if GF is not a generic function or the name
2429; of a generic function).
2430(defun method-exists-p (gf &rest args)
2431  (declare (dynamic-extent args))
2432  (when (symbolp gf)
2433    (setq gf (fboundp gf)))
2434  (when (typep gf 'standard-generic-function)
2435    (or (null args)
2436        (let* ((methods (sgf.methods gf)))
2437          (dolist (m methods)
2438            (when (null (%method-qualifiers m))
2439              (let ((specializers (%method-specializers m))
2440                    (args args))
2441                (when (dolist (s specializers t)
2442                        (unless (cond ((typep s 'eql-specializer) 
2443                                       (eql (eql-specializer-object s)
2444                                            (car args)))
2445                                      (t (memq s (%inited-class-cpl
2446                                                  (class-of (car args))))))
2447                          (return nil))
2448                        (pop args))
2449                  (return-from method-exists-p m)))))
2450          nil))))
2451
2452(defun funcall-if-method-exists (gf &optional default &rest args)
2453  (declare (dynamic-extent args))
2454  (if (apply #'method-exists-p gf args)
2455    (apply gf args)
2456    (if default (apply default args))))
2457
2458
2459(defun find-specializer (specializer)
2460  (if (and (listp specializer) (eql (car specializer) 'eql))
2461    (intern-eql-specializer (cadr specializer))
2462    (find-class specializer)))
2463
2464(defmethod make-instances-obsolete ((class symbol))
2465  (make-instances-obsolete (find-class class)))
2466
2467(defmethod make-instances-obsolete ((class standard-class))
2468  (let ((wrapper (%class-own-wrapper class)))
2469    (when wrapper
2470      (setf (%class-own-wrapper class) nil)
2471      (make-wrapper-obsolete wrapper)))
2472  class)
2473
2474(defmethod make-instances-obsolete ((class funcallable-standard-class))
2475  (let ((wrapper (%class.own-wrapper class)))
2476    (when wrapper
2477      (setf (%class-own-wrapper class) nil)
2478      (make-wrapper-obsolete wrapper)))
2479  class)
2480
2481(defmethod make-instances-obsolete ((class structure-class))
2482  ;; could maybe warn that instances are obsolete, but there's not
2483  ;; much that we can do about that.
2484  class)
2485
2486
2487
2488; A wrapper is made obsolete by setting the hash-index & instance-slots to 0
2489; The instance slots are saved for update-obsolete-instance
2490; by consing them onto the class slots.
2491; Method dispatch looks at the hash-index.
2492; slot-value & set-slot-value look at the instance-slots.
2493; Each wrapper may have an associated forwarding wrapper, which must also be made
2494; obsolete.  The forwarding-wrapper is stored in the hash table below keyed
2495; on the wrapper-hash-index of the two wrappers.
2496(defvar *forwarding-wrapper-hash-table* (make-hash-table :test 'eq)) 
2497
2498
2499(defun make-wrapper-obsolete (wrapper)
2500  (without-interrupts
2501   (let ((forwarding-info
2502          (unless (eql 0 (%wrapper-instance-slots wrapper))   ; already forwarded or obsolete?
2503            (%cons-forwarding-info (%wrapper-instance-slots wrapper)
2504                                   (%wrapper-class-slots wrapper)))))
2505     (when forwarding-info
2506       (setf (%wrapper-hash-index wrapper) 0
2507             (%wrapper-instance-slots wrapper) 0
2508             (%wrapper-forwarding-info wrapper) forwarding-info
2509             (%wrapper-slot-id->slotd wrapper) #'%slot-id-lookup-obsolete
2510             (%wrapper-slot-id-value wrapper) #'%slot-id-ref-obsolete
2511             (%wrapper-set-slot-id-value wrapper) #'%slot-id-set-obsolete
2512             ))))
2513  wrapper)
2514
2515(defun %clear-class-primary-slot-accessor-offsets (class)
2516  (let ((info-list (%class-get class '%class-primary-slot-accessor-info)))
2517    (dolist (info info-list)
2518      (setf (%slot-accessor-info.offset info) nil))))
2519
2520(defun primary-class-slot-offset (class slot-name)
2521  (dolist (super (%class.cpl class))
2522    (let* ((pos (and (typep super 'standard-class)
2523                     (%class-primary-p super)
2524                     (dolist (slot (%class-slots class))
2525                       (when (eq (%slot-definition-allocation slot)
2526                                 :instance)
2527                         (when (eq slot-name (%slot-definition-name slot))
2528                           (return (%slot-definition-location slot))))))))
2529      (when pos (return pos)))))
2530
2531; Called by the compiler-macro expansion for slot-value
2532; info is the result of a %class-primary-slot-accessor-info call.
2533; value-form is specified if this is set-slot-value.
2534; Otherwise it's slot-value.
2535(defun primary-class-slot-value (instance info &optional (value-form nil value-form-p))
2536  (let ((slot-name (%slot-accessor-info.slot-name info)))
2537    (prog1
2538      (if value-form-p
2539        (setf (slot-value instance slot-name) value-form)
2540        (slot-value instance slot-name))
2541      (setf (%slot-accessor-info.offset info)
2542            (primary-class-slot-offset (class-of instance) slot-name)))))
2543
2544(defun primary-class-accessor (instance info &optional (value-form nil value-form-p))
2545  (let ((accessor (%slot-accessor-info.accessor info)))
2546    (prog1
2547      (if value-form-p
2548        (funcall accessor value-form instance)
2549        (funcall accessor instance))
2550      (let ((methods (compute-applicable-methods
2551                      accessor
2552                      (if value-form-p (list value-form instance) (list instance))))
2553            method)
2554        (when (and (eql (length methods) 1)
2555                   (typep (setq method (car methods)) 'standard-accessor-method))
2556          (let* ((slot-name (method-slot-name method)))
2557            (setf (%slot-accessor-info.offset info)
2558                  (primary-class-slot-offset (class-of instance) slot-name))))))))
2559
2560(defun exchange-slot-vectors-and-wrappers (a b)
2561  (let* ((temp-wrapper (instance.class-wrapper a))
2562         (orig-a-slots (instance.slots a))
2563         (orig-b-slots (instance.slots b)))
2564    (setf (instance.class-wrapper a) (instance.class-wrapper b)
2565          (instance.class-wrapper b) temp-wrapper
2566          (instance.slots a) orig-b-slots
2567          (instance.slots b) orig-a-slots
2568          (slot-vector.instance orig-a-slots) b
2569          (slot-vector.instance orig-b-slots) a)))
2570
2571
2572
2573
2574;;; How slot values transfer (from PCL):
2575;;;
2576;;; local  --> local        transfer
2577;;; local  --> shared       discard
2578;;; local  -->  --          discard
2579;;; shared --> local        transfer
2580;;; shared --> shared       discard
2581;;; shared -->  --          discard
2582;;;  --    --> local        added
2583;;;  --    --> shared        --
2584;;;
2585;;; See make-wrapper-obsolete to see how we got here.
2586;;; A word about forwarding.  When a class is made obsolete, the
2587;;; %wrapper-instance-slots slot of its wrapper is set to 0.
2588;;; %wrapper-class-slots = (instance-slots . class-slots)
2589;;; Note: this should stack-cons the new-instance if we can reuse the
2590;;; old instance or it's forwarded value.
2591(defun update-obsolete-instance (instance)
2592  (let* ((added ())
2593         (discarded ())
2594         (plist ()))
2595    (without-interrupts                 ; Not -close- to being correct
2596     (let* ((old-wrapper (standard-object-p instance)))
2597       (unless old-wrapper
2598         (when (standard-generic-function-p instance)
2599           (setq old-wrapper (gf.instance.class-wrapper instance)))
2600         (unless old-wrapper
2601           (report-bad-arg instance '(or standard-instance standard-generic-function))))
2602       (when (eql 0 (%wrapper-instance-slots old-wrapper))   ; is it really obsolete?
2603         (let* ((class (%wrapper-class old-wrapper))
2604                (new-wrapper (or (%class.own-wrapper class)
2605                                 (progn
2606                                   (update-class class t)
2607                                   (%class.own-wrapper class))))
2608                (forwarding-info (%wrapper-forwarding-info old-wrapper))
2609                (old-class-slots (%forwarding-class-slots forwarding-info))
2610                (old-instance-slots (%forwarding-instance-slots forwarding-info))
2611                (new-instance-slots (%wrapper-instance-slots new-wrapper))
2612                (new-class-slots (%wrapper-class-slots new-wrapper))
2613                (new-instance (allocate-instance class))
2614                (old-slot-vector (instance.slots instance))
2615                (new-slot-vector (instance.slots new-instance)))
2616             ;; Lots to do.  Hold onto your hat.
2617             (let* ((old-size (uvsize old-instance-slots))
2618                    (new-size (uvsize new-instance-slots)))
2619               (declare (fixnum old-size new-size))
2620               (dotimes (i old-size)
2621                 (declare (fixnum i))
2622                 (let* ((slot-name (%svref old-instance-slots i))
2623                        (pos (%vector-member slot-name new-instance-slots))
2624                        (val (%svref old-slot-vector (%i+ i 1))))
2625                   (if pos
2626                     (setf (%svref new-slot-vector (%i+ pos 1)) val)
2627                     (progn
2628                       (push slot-name discarded)
2629                       (unless (eq val (%slot-unbound-marker))
2630                         (setf (getf plist slot-name) val))))))
2631               ;; Go through old class slots
2632               (dolist (pair old-class-slots)
2633                 (let* ((slot-name (%car pair))
2634                        (val (%cdr pair))
2635                        (pos (%vector-member slot-name new-instance-slots)))
2636                   (if pos
2637                     (setf (%svref new-slot-vector (%i+ pos 1)) val)
2638                     (progn
2639                       (push slot-name discarded)
2640                       (unless (eq val (%slot-unbound-marker))
2641                         (setf (getf plist slot-name) val))))))
2642               ; Go through new instance slots
2643               (dotimes (i new-size)
2644                 (declare (fixnum i))
2645                 (let* ((slot-name (%svref new-instance-slots i)))
2646                   (unless (or (%vector-member slot-name old-instance-slots)
2647                               (assoc slot-name old-class-slots))
2648                     (push slot-name added))))
2649               ;; Go through new class slots
2650               (dolist (pair new-class-slots)
2651                 (let ((slot-name (%car pair)))
2652                   (unless (or (%vector-member slot-name old-instance-slots)
2653                               (assoc slot-name old-class-slots))
2654                     (push slot-name added))))
2655               (exchange-slot-vectors-and-wrappers new-instance instance))))))
2656    ;; run user code with interrupts enabled.
2657    (update-instance-for-redefined-class instance added discarded plist))
2658  instance)
2659           
2660         
2661(defmethod update-instance-for-redefined-class ((instance standard-object)
2662                                                added-slots
2663                                                discarded-slots
2664                                                property-list
2665                                                &rest initargs)
2666  (declare (ignore discarded-slots property-list))
2667  (when initargs
2668    (check-initargs
2669     instance nil initargs t
2670     #'update-instance-for-redefined-class #'shared-initialize))
2671  (apply #'shared-initialize instance added-slots initargs))
2672
2673(defmethod update-instance-for-redefined-class ((instance standard-generic-function)
2674                                                added-slots
2675                                                discarded-slots
2676                                                property-list
2677                                                &rest initargs)
2678  (declare (ignore discarded-slots property-list))
2679  (when initargs
2680    (check-initargs
2681     instance nil initargs t
2682     #'update-instance-for-redefined-class #'shared-initialize))
2683  (apply #'shared-initialize instance added-slots initargs))
2684
2685(defun check-initargs (instance class initargs errorp &rest functions)
2686  (declare (dynamic-extent functions))
2687  (declare (list functions))
2688  (setq class (require-type (or class (class-of instance)) 'std-class))
2689  (unless (getf initargs :allow-other-keys)
2690    (let ((initvect (initargs-vector instance class functions)))
2691      (when (eq initvect t) (return-from check-initargs nil))
2692      (do* ((tail initargs (cddr tail))
2693            (initarg (car tail) (car tail))
2694            bad-keys? bad-key)
2695           ((null (cdr tail))
2696            (if bad-keys?
2697              (if errorp
2698                (signal-program-error
2699                 "~s is an invalid initarg to ~s for ~s.~%~
2700                                    Valid initargs: ~s."
2701                 bad-key
2702                 (function-name (car functions))
2703                 class (coerce initvect 'list))
2704                (values bad-keys? bad-key))))
2705        (if (eq initarg :allow-other-keys)
2706          (if (cadr tail)
2707            (return))                   ; (... :allow-other-keys t ...)
2708          (unless (or bad-keys? (%vector-member initarg initvect))
2709            (setq bad-keys? t
2710                  bad-key initarg)))))))
2711
2712(defun initargs-vector (instance class functions)
2713  (let ((index (cadr (assq (car functions) *initialization-invalidation-alist*))))
2714    (unless index
2715      (error "Unknown initialization function: ~s." (car functions)))
2716    (let ((initvect (%svref (instance-slots class) index)))
2717      (unless initvect
2718        (setf (%svref (instance-slots class) index) 
2719              (setq initvect (compute-initargs-vector instance class functions))))
2720      initvect)))
2721
2722
2723(defun compute-initargs-vector (instance class functions)
2724  (let ((initargs (class-slot-initargs class))
2725        (cpl (%inited-class-cpl class)))
2726    (dolist (f functions)         ; for all the functions passed
2727      #+no
2728      (if (logbitp $lfbits-aok-bit (lfun-bits f))
2729        (return-from compute-initargs-vector t))
2730      (dolist (method (%gf-methods f))   ; for each applicable method
2731        (let ((spec (car (%method-specializers method))))
2732          (when (if (typep spec 'eql-specializer)
2733                  (eql instance (eql-specializer-object spec))
2734                  (memq spec cpl))
2735            (let* ((func (%inner-method-function method))
2736                   (keyvect (if (logbitp $lfbits-aok-bit (lfun-bits func))
2737                              (return-from compute-initargs-vector t)
2738                              (lfun-keyvect func))))
2739              (dovector (key keyvect)
2740                (pushnew key initargs)))))))   ; add all of the method's keys
2741    (apply #'vector initargs)))
2742
2743
2744
2745; A useful function
2746(defun class-make-instance-initargs (class)
2747  (setq class (require-type (if (symbolp class) (find-class class) class)
2748                            'std-class))
2749  (flet ((iv (class &rest functions)
2750           (declare (dynamic-extent functions))
2751           (initargs-vector (class-prototype class) class functions)))
2752    (let ((initvect (apply #'iv
2753                           class
2754                           #'initialize-instance #'allocate-instance #'shared-initialize
2755                           nil)))
2756      (if (eq initvect 't)
2757        t
2758        (concatenate 'list initvect)))))
2759
2760                                   
2761
2762; This is part of the MOP
2763;;; Maybe it was, at one point in the distant past ...
2764(defmethod class-slot-initargs ((class slots-class))
2765  (apply #'append (mapcar #'(lambda (s)
2766                              (%slot-definition-initargs s))
2767                          (%class-slots class))))
2768
2769   
2770 
2771(defun maybe-update-obsolete-instance (instance)
2772  (let ((wrapper (standard-object-p instance)))
2773    (unless wrapper
2774      (when (standard-generic-function-p instance)
2775        (setq wrapper (generic-function-wrapper instance)))
2776      (unless wrapper
2777        (report-bad-arg instance '(or standard-object standard-generic-function))))
2778    (when (eql 0 (%wrapper-hash-index wrapper))
2779      (update-obsolete-instance instance)))
2780  instance)
2781
2782
2783; If you ever reference one of these through anyone who might call update-obsolete-instance,
2784; you will lose badly.
2785(defun %maybe-forwarded-instance (instance)
2786  (maybe-update-obsolete-instance instance)
2787  instance)
2788
2789
2790
2791(defmethod change-class (instance
2792                         (new-class symbol)
2793                         &rest initargs &key &allow-other-keys)
2794  (declare (dynamic-extent initargs))
2795  (apply #'change-class instance (find-class new-class) initargs))
2796
2797(defmethod change-class ((instance standard-object)
2798                         (new-class standard-class)
2799                          &rest initargs &key &allow-other-keys)
2800  (declare (dynamic-extent initargs))
2801  (%change-class instance new-class initargs))
2802
2803
2804(defun %change-class (object new-class initargs)
2805  (let* ((old-class (class-of object))
2806         (old-wrapper (%class.own-wrapper old-class))
2807         (new-wrapper (or (%class.own-wrapper new-class)
2808                          (progn
2809                            (update-class new-class t)
2810                            (%class.own-wrapper new-class))))
2811         (old-instance-slots-vector (%wrapper-instance-slots old-wrapper))
2812         (new-instance-slots-vector (%wrapper-instance-slots new-wrapper))
2813         (num-new-instance-slots (length new-instance-slots-vector))
2814         (new-object (allocate-instance new-class)))
2815    (declare (fixnum num-new-instance-slots)
2816             (simple-vector new-instance-slots old-instance-slots))
2817    ;; Retain local slots shared between the new class and the old.
2818    (do* ((new-pos 0 (1+ new-pos))
2819          (new-slot-location 1 (1+ new-slot-location)))
2820         ((= new-pos num-new-instance-slots))
2821      (declare (fixnum new-pos new-slot-vector-pos))
2822      (let* ((old-pos (position (svref new-instance-slots-vector new-pos)
2823                                old-instance-slots-vector :test #'eq)))
2824        (when old-pos
2825          (setf (%standard-instance-instance-location-access
2826                 new-object
2827                 new-slot-location)
2828                (%standard-instance-instance-location-access
2829                 object
2830                 (the fixnum (1+ (the fixnum old-pos))))))))
2831    ;; If the new class defines a local slot whos name matches
2832    ;; that of a shared slot in the old class, the shared slot's
2833    ;; value is used to initialize the new instance's local slot.
2834    (dolist (shared-slot (%wrapper-class-slots old-wrapper))
2835      (destructuring-bind (name . value) shared-slot
2836        (let* ((new-slot-pos (position name new-instance-slots-vector
2837                                       :test #'eq)))
2838          (if new-slot-pos
2839            (setf (%standard-instance-instance-location-access
2840                   new-object
2841                   (the fixnum (1+ (the fixnum new-slot-pos))))
2842                  value)))))
2843    (exchange-slot-vectors-and-wrappers object new-object)
2844    (apply #'update-instance-for-different-class new-object object initargs)
2845    object))
2846
2847(defmethod update-instance-for-different-class ((previous standard-object)
2848                                                (current standard-object)
2849                                                &rest initargs)
2850  (declare (dynamic-extent initargs))
2851  (%update-instance-for-different-class previous current initargs))
2852
2853(defun %update-instance-for-different-class (previous current initargs)
2854  (when initargs
2855    (check-initargs
2856     current nil initargs t
2857     #'update-instance-for-different-class #'shared-initialize))
2858  (let* ((previous-slots (class-slots (class-of previous)))
2859         (current-slots (class-slots (class-of current)))
2860         (added-slot-names ()))
2861    (dolist (s current-slots)
2862      (let* ((name (%slot-definition-name s)))
2863        (unless (find-slotd name previous-slots)
2864          (push name added-slot-names))))
2865    (apply #'shared-initialize
2866           current
2867           added-slot-names
2868           initargs)))
2869
2870
2871
2872
2873; Clear all the valid initargs caches.
2874(defun clear-valid-initargs-caches ()
2875  (map-classes #'(lambda (name class)
2876                   (declare (ignore name))
2877                   (when (std-class-p class)
2878                     (setf (%class.make-instance-initargs class) nil
2879                           (%class.reinit-initargs class) nil
2880                           (%class.redefined-initargs class) nil
2881                           (%class.changed-initargs class) nil)))))
2882
2883(defun clear-clos-caches ()
2884  (clear-all-gf-caches)
2885  (clear-valid-initargs-caches))
2886
2887(defmethod allocate-instance ((class standard-class) &rest initargs)
2888  (declare (ignore initargs))
2889  (%allocate-std-instance class))
2890
2891(defmethod allocate-instance ((class funcallable-standard-class) &rest initargs)
2892  (declare (ignore initargs))
2893  (%allocate-gf-instance class))
2894
2895(unless *initialization-invalidation-alist*
2896  (setq *initialization-invalidation-alist*
2897        (list (list #'initialize-instance %class.make-instance-initargs)
2898              (list #'allocate-instance %class.make-instance-initargs)
2899              (list #'reinitialize-instance %class.reinit-initargs)
2900              (list #'shared-initialize 
2901                    %class.make-instance-initargs %class.reinit-initargs
2902                    %class.redefined-initargs %class.changed-initargs)
2903              (list #'update-instance-for-redefined-class
2904                    %class.redefined-initargs)
2905              (list #'update-instance-for-different-class
2906                    %class.changed-initargs))))
2907
2908
2909(defvar *initialization-function-lists*
2910  (list (list #'initialize-instance #'allocate-instance #'shared-initialize)
2911        (list #'reinitialize-instance #'shared-initialize)
2912        (list #'update-instance-for-redefined-class #'shared-initialize)
2913        (list #'update-instance-for-different-class #'shared-initialize)))
2914
2915
2916
2917(unless *clos-initialization-functions*
2918  (setq *clos-initialization-functions*
2919        (list #'initialize-instance #'allocate-instance #'shared-initialize
2920              #'reinitialize-instance
2921              #'update-instance-for-different-class #'update-instance-for-redefined-class)))
2922
2923(defun compute-initialization-functions-alist ()
2924  (let ((res nil)
2925        (lists *initialization-function-lists*))
2926    (dolist (cell *initialization-invalidation-alist*)
2927      (let (res-list)
2928        (dolist (slot-num (cdr cell))
2929          (push
2930           (ecase slot-num
2931             (#.%class.make-instance-initargs 
2932              (assq #'initialize-instance lists))
2933             (#.%class.reinit-initargs
2934              (assq #'reinitialize-instance lists))
2935             (#.%class.redefined-initargs
2936              (assq #'update-instance-for-redefined-class lists))
2937             (#.%class.changed-initargs
2938              (assq #'update-instance-for-different-class lists)))
2939           res-list))
2940        (push (cons (car cell) (nreverse res-list)) res)))
2941    (setq *initialization-functions-alist* res)))
2942
2943(compute-initialization-functions-alist)
2944
2945                 
2946
2947
2948
2949
2950;; Need to define this for all of the built-in-class'es.
2951(defmethod class-prototype ((class std-class))
2952  (or (%class.prototype class)
2953      (setf (%class.prototype class) (allocate-instance class))))
2954
2955
2956
2957(defun gf-class-prototype (class)
2958  (%allocate-gf-instance class))
2959
2960
2961
2962(defmethod class-prototype ((class structure-class))
2963  (or (%class.prototype class)
2964      (setf (%class.prototype class)
2965            (funcall (sd-constructor (gethash (%class.name class) %defstructs%))))))
2966
2967
2968(defmethod remove-method ((generic-function standard-generic-function)
2969                          (method standard-method))
2970  (when (eq generic-function (%method-gf method))
2971    (%remove-standard-method-from-containing-gf method))
2972  generic-function)
2973
2974
2975
2976(defmethod function-keywords ((method standard-method))
2977  (let ((f (%inner-method-function method)))
2978    (values
2979     (concatenate 'list (lfun-keyvect f))
2980     (%ilogbitp $lfbits-aok-bit (lfun-bits f)))))
2981
2982(defmethod no-next-method ((generic-function standard-generic-function)
2983                           (method standard-method)
2984                           &rest args)
2985  (error "There is no next method for ~s~%args: ~s" method args))
2986
2987(defmethod add-method ((generic-function standard-generic-function) (method standard-method))
2988  (%add-standard-method-to-standard-gf generic-function method))
2989
2990(defmethod no-applicable-method (gf &rest args)
2991  (error "No applicable method for args:~% ~s~% to ~s" args gf))
2992
2993
2994(defmethod no-applicable-primary-method (gf methods)
2995  (%method-combination-error "No applicable primary methods for ~s~@
2996                              Applicable methods: ~s" gf methods))
2997
2998(defmethod compute-applicable-methods ((gf standard-generic-function) args)
2999  (%compute-applicable-methods* gf args))
3000
3001(defun %compute-applicable-methods+ (gf &rest args)
3002  (declare (dynamic-extent args))
3003  (%compute-applicable-methods* gf args))
3004
3005(defun %compute-applicable-methods* (gf args)
3006  (let* ((methods (%gf-methods gf))
3007         (args-length (length args))
3008         (bits (inner-lfun-bits gf))
3009         arg-count res)
3010    (when methods
3011      (setq arg-count (length (%method-specializers (car methods))))
3012      (unless (<= arg-count args-length)
3013        (error "Too few args to ~s" gf))
3014      (unless (or (logbitp $lfbits-rest-bit bits)
3015                  (logbitp $lfbits-restv-bit bits)
3016                  (logbitp $lfbits-keys-bit bits)
3017                  (<= args-length 
3018                      (+ (ldb $lfbits-numreq bits) (ldb $lfbits-numopt bits))))
3019        (error "Too many args to ~s" gf))
3020      (let ((cpls (make-list arg-count)))
3021        (declare (dynamic-extent cpls))
3022        (do* ((args-tail args (cdr args-tail))
3023              (cpls-tail cpls (cdr cpls-tail)))
3024            ((null cpls-tail))
3025          (setf (car cpls-tail)
3026                (%class-precedence-list (class-of (car args-tail)))))
3027        (dolist (m methods)
3028          (if (%method-applicable-p m args cpls)
3029            (push m res)))
3030        (sort-methods res cpls (%gf-precedence-list gf))))))
3031
3032
3033(defun %method-applicable-p (method args cpls)
3034  (do* ((specs (%method-specializers method) (%cdr specs))
3035        (args args (%cdr args))
3036        (cpls cpls (%cdr cpls)))
3037      ((null specs) t)
3038    (let ((spec (%car specs)))
3039      (if (typep spec 'eql-specializer)
3040        (unless (eql (%car args) (eql-specializer-object spec))
3041          (return nil))
3042        (unless (memq spec (%car cpls))
3043          (return nil))))))
3044
3045
3046; Need this so that (compute-applicable-methods #'class-precedence-list ...)
3047; will not recurse.
3048(defun %class-precedence-list (class)
3049  (if (eq (class-of class) *standard-class-class*)
3050    (%inited-class-cpl class)
3051    (class-precedence-list class)))
3052
3053(defmethod class-precedence-list ((class class))
3054  (%inited-class-cpl class))
3055
3056
3057
3058
3059
3060
3061
3062(defun make-all-methods-kernel ()
3063  (dolist (f (population.data %all-gfs%))
3064    (let ((smc *standard-method-class*))
3065      (dolist (method (slot-value-if-bound f 'methods))
3066        (when (eq (class-of method) smc)
3067          (change-class method *standard-kernel-method-class*))))))
3068
3069
3070(defun make-all-methods-non-kernel ()
3071  (dolist (f (population.data %all-gfs%))
3072    (let ((skmc *standard-kernel-method-class*))
3073      (dolist (method (slot-value-if-bound f 'methods))
3074        (when (eq (class-of method) skmc)
3075          (change-class method *standard-method-class*))))))
3076
3077
3078
3079
3080
3081(defun required-lambda-list-args (l)
3082  (multiple-value-bind (ok req) (verify-lambda-list l)
3083    (unless ok (error "Malformed lambda-list: ~s" l))
3084    req))
3085
3086
3087
3088
3089(defun check-generic-function-lambda-list (ll &optional (errorp t))
3090  (multiple-value-bind (ok reqsyms opttail resttail keytail auxtail)
3091                       (verify-lambda-list ll)
3092    (declare (ignore reqsyms resttail))
3093    (when ok 
3094      (block checkit
3095        (when (eq (car opttail) '&optional)
3096          (dolist (elt (cdr opttail))
3097            (when (memq elt lambda-list-keywords) (return))
3098            (unless (or (symbolp elt)
3099                        (and (listp elt)
3100                             (non-nil-symbol-p (car elt))
3101                             (null (cdr elt))))
3102              (return-from checkit (setq ok nil)))))
3103        (dolist (elt (cdr keytail))
3104          (when (memq elt lambda-list-keywords) (return))
3105          (unless (or (symbolp elt)
3106                      (and (listp elt)
3107                           (or (non-nil-symbol-p (car elt))
3108                               (and (listp (car elt))
3109                                    (non-nil-symbol-p (caar elt))
3110                                    (non-nil-symbol-p (cadar elt))
3111                                    (null (cddar elt))))
3112                           (null (cdr elt))))
3113            (return-from checkit (setq ok nil))))
3114        (when auxtail (setq ok nil))))
3115    (when (and errorp (not ok))
3116      (signal-program-error "Bad generic function lambda list: ~s" ll))
3117    ok))
3118
3119
3120
3121
3122(defun canonicalize-argument-precedence-order (apo req)
3123  (cond ((equal apo req) nil)
3124        ((not (eql (length apo) (length req)))
3125         (signal-program-error "Lengths of ~S and ~S differ." apo req))
3126        (t (let ((res nil))
3127             (dolist (arg apo (nreverse res))
3128               (let ((index (position arg req)))
3129                 (if (or (null index) (memq index res))
3130                   (error "Missing or duplicate arguments in ~s" apo))
3131                 (push index res)))))))
3132
3133
3134
3135(defun %defgeneric (function-name lambda-list method-combination generic-function-class
3136                                  options)
3137  (setq generic-function-class (find-class generic-function-class))
3138  (setq method-combination 
3139        (find-method-combination
3140         (class-prototype generic-function-class)
3141         (car method-combination)
3142         (cdr method-combination)))
3143  (let ((gf (fboundp function-name)))
3144    (when gf
3145      (dolist (method (%defgeneric-methods gf))
3146        (remove-method gf method))))
3147  (record-source-file function-name 'function)
3148  (record-arglist function-name lambda-list)
3149  (apply #'ensure-generic-function 
3150         function-name
3151         :lambda-list lambda-list
3152         :method-combination method-combination
3153         :generic-function-class generic-function-class
3154         options))
3155
3156
3157
3158
3159; Redefined in lib;method-combination.lisp
3160(defmethod find-method-combination ((gf standard-generic-function) type options)
3161  (unless (and (eq type 'standard) (null options))
3162    (error "non-standard method-combination not supported yet."))
3163  *standard-method-combination*)
3164
3165
3166
3167(defmethod add-direct-method ((spec specializer) (method method))
3168  (pushnew method (specializer.direct-methods spec)))
3169
3170(setf (fdefinition '%do-add-direct-method) #'add-direct-method)
3171
3172
3173(defmethod remove-direct-method ((spec specializer) (method method))
3174  (setf (specializer.direct-methods spec)
3175        (nremove method (specializer.direct-methods spec))))
3176
3177(setf (fdefinition '%do-remove-direct-method) #'remove-direct-method)
3178
3179(defmethod instance-class-wrapper ((instance standard-object))
3180  (if (%standard-instance-p instance)
3181    (instance.class-wrapper instance)
3182    (if (typep instance 'macptr)
3183      (foreign-instance-class-wrapper instance))))
3184
3185(defmethod instance-class-wrapper ((instance standard-generic-function))
3186  (gf.instance.class-wrapper  instance))
3187
3188
3189                                   
3190
3191(defun generic-function-wrapper (gf)
3192  (unless (inherits-from-standard-generic-function-p (class-of gf))
3193    (%badarg gf 'standard-generic-function))
3194  (gf.instance.class-wrapper gf))
3195
3196(defvar *make-load-form-saving-slots-hash* (make-hash-table :test 'eq))
3197
3198(defun make-load-form-saving-slots (object &key
3199                                           (slot-names nil slot-names-p)
3200                                           environment)
3201  (declare (ignore environment))
3202  (let* ((class (class-of object))
3203         (class-name (class-name class))
3204         (structurep (structurep object))
3205         (sd (and structurep (require-type (gethash class-name %defstructs%) 'vector))))
3206    (unless (or structurep
3207                (standard-instance-p object))
3208      (%badarg object '(or standard-object structure-object)))
3209    (if slot-names-p
3210      (dolist (slot slot-names)
3211        (unless (slot-exists-p object slot)
3212          (error "~s has no slot named ~s" object slot)))
3213      (setq slot-names
3214            (if structurep
3215              (let ((res nil))
3216                (dolist (slot (sd-slots sd))
3217                  (unless (fixnump (car slot))
3218                    (push (%car slot) res)))
3219                (nreverse res))
3220              (mapcar '%slot-definition-name
3221                      (extract-instance-effective-slotds
3222                       (class-of object))))))
3223    (values
3224     (let* ((form (gethash class-name *make-load-form-saving-slots-hash*)))
3225       (or (and (consp form)
3226                (eq (car form) 'allocate-instance)
3227                form)
3228           (setf (gethash class-name *make-load-form-saving-slots-hash*)
3229                 `(allocate-instance (find-class ',class-name)))))
3230     ;; initform is NIL when there are no slots
3231     (when slot-names
3232       `(%set-slot-values
3233         ',object
3234         ',slot-names
3235         ',(let ((temp #'(lambda (slot)
3236                           (if (slot-boundp object slot)
3237                             (slot-value object slot)
3238                             (%slot-unbound-marker)))))
3239             (declare (dynamic-extent temp))
3240             (mapcar temp slot-names)))))))
3241
3242
3243   
3244
3245(defmethod allocate-instance ((class structure-class) &rest initargs)
3246  (declare (ignore initargs))
3247  (let* ((class-name (%class-name class))
3248         (sd (or (gethash class-name %defstructs%)
3249                 (error "Can't find structure named ~s" class-name)))
3250         (res (make-structure-vector (sd-size sd))))
3251    (setf (%svref res 0) (sd-superclasses sd))
3252    res))
3253
3254
3255(defun %set-slot-values (object slots values)
3256  (dolist (slot slots)
3257    (let ((value (pop values)))
3258      (if (eq value (%slot-unbound-marker))
3259        (slot-makunbound object slot)
3260        (setf (slot-value object slot) value)))))
3261
3262#|
3263(defmethod method-specializers ((method standard-method))
3264  (%method-specializers method))
3265
3266(defmethod method-qualifiers ((method standard-method))
3267  (%method-qualifiers method))
3268|#
3269
3270(defun %recache-class-direct-methods ()
3271  (let ((*maintain-class-direct-methods* t))   ; in case we get an error
3272    (dolist (f (population-data %all-gfs%))
3273      (when (standard-generic-function-p f)
3274        (dolist (method (%gf-methods f))
3275          (%add-direct-methods method)))))
3276  (setq *maintain-class-direct-methods* t))   ; no error, all is well
3277
Note: See TracBrowser for help on using the repository browser.