UPGRADED-ARRAY-ELEMENT-TYPE: more thoroughly signal errors on unknown types.
[sbcl.git] / src / pcl / defs.lisp
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3
4 ;;;; This software is derived from software originally released by Xerox
5 ;;;; Corporation. Copyright and release statements follow. Later modifications
6 ;;;; to the software are in the public domain and are provided with
7 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
8 ;;;; information.
9
10 ;;;; copyright information from original PCL sources:
11 ;;;;
12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
13 ;;;; All rights reserved.
14 ;;;;
15 ;;;; Use and copying of this software and preparation of derivative works based
16 ;;;; upon this software are permitted. Any distribution of this software or
17 ;;;; derivative works must comply with all applicable United States export
18 ;;;; control laws.
19 ;;;;
20 ;;;; This software is made available AS IS, and Xerox Corporation makes no
21 ;;;; warranty about the software, its performance or its conformity to any
22 ;;;; specification.
23
24 (in-package "SB-PCL")
25 \f
26 ;;; (These are left over from the days when PCL was an add-on package
27 ;;; for a pre-CLOS Common Lisp. They shouldn't happen in a normal
28 ;;; build, of course, but they might happen if someone is experimenting
29 ;;; and debugging, and it's probably worth complaining if they do,
30 ;;; so we've left 'em in.)
31 (when (eq **boot-state** 'complete)
32   (error "Trying to load (or compile) PCL in an environment in which it~%~
33           has already been loaded. This doesn't work, you will have to~%~
34           get a fresh lisp (reboot) and then load PCL."))
35 (when **boot-state**
36   (cerror "Try loading (or compiling) PCL anyways."
37           "Trying to load (or compile) PCL in an environment in which it~%~
38            has already been partially loaded. This may not work, you may~%~
39            need to get a fresh lisp (reboot) and then load PCL."))
40 \f
41 #-sb-fluid (declaim (inline gdefinition))
42 (defun gdefinition (spec)
43   ;; This is null layer right now, but once FDEFINITION stops bypasssing
44   ;; fwrappers/encapsulations we can do that here.
45   (fdefinition spec))
46
47 (defun (setf gdefinition) (new-value spec)
48   ;; This is almost a null layer right now, but once (SETF
49   ;; FDEFINITION) stops bypasssing fwrappers/encapsulations we can do
50   ;; that here.
51   (sb-c::note-name-defined spec :function) ; FIXME: do we need this? Why?
52   (setf (fdefinition spec) new-value))
53 \f
54 ;;;; type specifier hackery
55
56 ;;; internal to this file
57 (defun coerce-to-class (class &optional make-forward-referenced-class-p)
58   (if (symbolp class)
59       (or (find-class class (not make-forward-referenced-class-p))
60           (ensure-class class))
61       class))
62
63 ;;; interface
64 (defun specializer-from-type (type &aux args)
65   (when (symbolp type)
66     (return-from specializer-from-type (find-class type)))
67   (when (consp type)
68     (setq args (cdr type) type (car type)))
69   (cond ((symbolp type)
70          (or (ecase type
71                (class    (coerce-to-class (car args)))
72                (prototype (make-instance 'class-prototype-specializer
73                                          :object (coerce-to-class (car args))))
74                (class-eq (class-eq-specializer (coerce-to-class (car args))))
75                (eql      (intern-eql-specializer (car args))))))
76         ;; FIXME: do we still need this?
77         ((and (null args) (typep type 'classoid))
78          (or (classoid-pcl-class type)
79              (ensure-non-standard-class (classoid-name type) type)))
80         ((specializerp type) type)))
81
82 ;;; interface
83 (defun type-from-specializer (specl)
84   (cond ((eq specl t)
85          t)
86         ((consp specl)
87          (unless (member (car specl) '(class prototype class-eq eql))
88            (error "~S is not a legal specializer type." specl))
89          specl)
90         ((progn
91            (when (symbolp specl)
92              ;;maybe (or (find-class specl nil) (ensure-class specl)) instead?
93              (setq specl (find-class specl)))
94            (or (not (eq **boot-state** 'complete))
95                (specializerp specl)))
96          (specializer-type specl))
97         (t
98          (error "~S is neither a type nor a specializer." specl))))
99
100 (defun type-class (type)
101   (declare (special *the-class-t*))
102   (setq type (type-from-specializer type))
103   (if (atom type)
104       (if (eq type t)
105           *the-class-t*
106           (error "bad argument to TYPE-CLASS"))
107       (case (car type)
108         (eql (class-of (cadr type)))
109         (prototype (class-of (cadr type))) ;?
110         (class-eq (cadr type))
111         (class (cadr type)))))
112
113 (defun class-eq-type (class)
114   (specializer-type (class-eq-specializer class)))
115
116 ;;; internal to this file..
117 ;;;
118 ;;; These functions are a pale imitation of their namesake. They accept
119 ;;; class objects or types where they should.
120 (defun *normalize-type (type)
121   (cond ((consp type)
122          (if (member (car type) '(not and or))
123              `(,(car type) ,@(mapcar #'*normalize-type (cdr type)))
124              (if (null (cdr type))
125                  (*normalize-type (car type))
126                  type)))
127         ((symbolp type)
128          (let ((class (find-class type nil)))
129            (if class
130                (let ((type (specializer-type class)))
131                  (if (listp type) type `(,type)))
132                `(,type))))
133         ((or (not (eq **boot-state** 'complete))
134              (specializerp type))
135          (specializer-type type))
136         (t
137          (error "~S is not a type." type))))
138
139 ;;; internal to this file...
140 (defun convert-to-system-type (type)
141   (case (car type)
142     ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
143                                           (cdr type))))
144     ((class class-eq) ; class-eq is impossible to do right
145      (layout-classoid (class-wrapper (cadr type))))
146     (eql type)
147     (t (if (null (cdr type))
148            (car type)
149            type))))
150
151 ;;; Writing the missing NOT and AND clauses will improve the quality
152 ;;; of code generated by GENERATE-DISCRIMINATION-NET, but calling
153 ;;; SUBTYPEP in place of just returning (VALUES NIL NIL) can be very
154 ;;; slow. *SUBTYPEP is used by PCL itself, and must be fast.
155 ;;;
156 ;;; FIXME: SB-KERNEL has fast-and-not-quite-precise type code for use
157 ;;; in the compiler. Could we share some of it here?
158 (defvar *in-*subtypep* nil)
159
160 (defun *subtypep (type1 type2)
161   (if (equal type1 type2)
162       (values t t)
163       (if (eq **boot-state** 'early)
164           (values (eq type1 type2) t)
165           (let ((*in-*subtypep* t))
166             (setq type1 (*normalize-type type1))
167             (setq type2 (*normalize-type type2))
168             (case (car type2)
169               (not
170                (values nil nil)) ; XXX We should improve this.
171               (and
172                (values nil nil)) ; XXX We should improve this.
173               ((eql wrapper-eq class-eq class)
174                (multiple-value-bind (app-p maybe-app-p)
175                    (specializer-applicable-using-type-p type2 type1)
176                  (values app-p (or app-p (not maybe-app-p)))))
177               (t
178                (subtypep (convert-to-system-type type1)
179                          (convert-to-system-type type2))))))))
180 \f
181 (defvar *built-in-class-symbols* ())
182 (defvar *built-in-wrapper-symbols* ())
183
184 (defun get-built-in-class-symbol (class-name)
185   (or (cadr (assq class-name *built-in-class-symbols*))
186       (let ((symbol (make-class-symbol class-name)))
187         (push (list class-name symbol) *built-in-class-symbols*)
188         symbol)))
189
190 (defun get-built-in-wrapper-symbol (class-name)
191   (or (cadr (assq class-name *built-in-wrapper-symbols*))
192       (let ((symbol (make-wrapper-symbol class-name)))
193         (push (list class-name symbol) *built-in-wrapper-symbols*)
194         symbol)))
195 \f
196 (defvar *standard-method-combination*)
197 \f
198 (defun plist-value (object name)
199   (getf (object-plist object) name))
200
201 (defun (setf plist-value) (new-value object name)
202   (if new-value
203       (setf (getf (object-plist object) name) new-value)
204       (progn
205         (remf (object-plist object) name)
206         nil)))
207 \f
208 ;;;; built-in classes
209
210 ;;; Grovel over SB-KERNEL::*BUILT-IN-CLASSES* in order to set
211 ;;; SB-PCL:*BUILT-IN-CLASSES*.
212 (/show "about to set up SB-PCL::*BUILT-IN-CLASSES*")
213 (defvar *built-in-classes*
214   (labels ((direct-supers (class)
215              (/noshow "entering DIRECT-SUPERS" (classoid-name class))
216              (if (typep class 'built-in-classoid)
217                  (built-in-classoid-direct-superclasses class)
218                  (let ((inherits (layout-inherits
219                                   (classoid-layout class))))
220                    (/noshow inherits)
221                    (list (svref inherits (1- (length inherits)))))))
222            (direct-subs (class)
223              (/noshow "entering DIRECT-SUBS" (classoid-name class))
224              (collect ((res))
225                (let ((subs (classoid-subclasses class)))
226                  (/noshow subs)
227                  (when subs
228                    (dohash ((sub v) subs)
229                      (declare (ignore v))
230                      (/noshow sub)
231                      (when (member class (direct-supers sub) :test #'eq)
232                        (res sub)))))
233                (res))))
234     (mapcar (lambda (kernel-bic-entry)
235               (/noshow "setting up" kernel-bic-entry)
236               (let* ((name (car kernel-bic-entry))
237                      (class (find-classoid name))
238                      (prototype-form
239                       (getf (cdr kernel-bic-entry) :prototype-form)))
240                 (/noshow name class)
241                 `(,name
242                   ,(mapcar #'classoid-name (direct-supers class))
243                   ,(mapcar #'classoid-name (direct-subs class))
244                   ,(map 'list
245                         (lambda (x)
246                           (classoid-name
247                            (layout-classoid x)))
248                         (reverse
249                          (layout-inherits
250                           (classoid-layout class))))
251                   ,(if prototype-form
252                        (eval prototype-form)
253                        ;; This is the default prototype value which
254                        ;; was used, without explanation, by the CMU CL
255                        ;; code we're derived from. Evidently it's safe
256                        ;; in all relevant cases.
257                        42))))
258             (remove-if (lambda (kernel-bic-entry)
259                          (member (first kernel-bic-entry)
260                                  ;; I'm not sure why these are removed from
261                                  ;; the list, but that's what the original
262                                  ;; CMU CL code did. -- WHN 20000715
263                                  '(t function stream
264                                      file-stream string-stream)))
265                        sb-kernel::*built-in-classes*))))
266 (/noshow "done setting up SB-PCL::*BUILT-IN-CLASSES*")
267 \f
268 ;;;; the classes that define the kernel of the metabraid
269
270 (defclass t () ()
271   (:metaclass built-in-class))
272
273 (defclass function (t) ()
274   (:metaclass built-in-class))
275
276 (defclass stream (t) ()
277   (:metaclass built-in-class))
278
279 (defclass file-stream (stream) ()
280   (:metaclass built-in-class))
281
282 (defclass string-stream (stream) ()
283   (:metaclass built-in-class))
284
285 (defclass slot-object (t) ()
286   (:metaclass slot-class))
287
288 (defclass condition (slot-object) ()
289   (:metaclass condition-class))
290
291 (defclass structure-object (slot-object) ()
292   (:metaclass structure-class))
293
294 (defstruct (dead-beef-structure-object
295             (:constructor |STRUCTURE-OBJECT class constructor|)
296             (:copier nil)))
297
298 (defclass standard-object (slot-object) ())
299
300 (defclass funcallable-standard-object (function standard-object)
301   ()
302   (:metaclass funcallable-standard-class))
303
304 (defclass metaobject (standard-object) ())
305
306 (defclass generic-function (dependent-update-mixin
307                             definition-source-mixin
308                             metaobject
309                             funcallable-standard-object)
310   ((%documentation
311     :initform nil
312     :initarg :documentation)
313    ;; We need to make a distinction between the methods initially set
314    ;; up by :METHOD options to DEFGENERIC and the ones set up later by
315    ;; DEFMETHOD, because ANSI specifies that executing DEFGENERIC on
316    ;; an already-DEFGENERICed function clears the methods set by the
317    ;; previous DEFGENERIC, but not methods set by DEFMETHOD. (Making
318    ;; this distinction seems a little kludgy, but it has the positive
319    ;; effect of making it so that loading a file a.lisp containing
320    ;; DEFGENERIC, then loading a second file b.lisp containing
321    ;; DEFMETHOD, then modifying and reloading a.lisp and/or b.lisp
322    ;; tends to leave the generic function in a state consistent with
323    ;; the most-recently-loaded state of a.lisp and b.lisp.)
324    (initial-methods
325     :initform ()
326     :accessor generic-function-initial-methods))
327   (:metaclass funcallable-standard-class))
328
329 (defclass standard-generic-function (generic-function)
330   ((name
331     :initform nil
332     :initarg :name
333     :reader generic-function-name)
334    (methods
335     :initform ()
336     :accessor generic-function-methods
337     :type list)
338    (method-class
339     :initarg :method-class
340     :accessor generic-function-method-class)
341    (%method-combination
342     :initarg :method-combination
343     :accessor generic-function-method-combination)
344    (declarations
345     ;; KLUDGE: AMOP specifies :DECLARATIONS, while ANSI specifies
346     ;; :DECLARE.  Allow either (but FIXME: maybe a note or a warning
347     ;; might be appropriate).
348     :initarg :declarations
349     :initarg :declare
350     :initform ()
351     :accessor generic-function-declarations)
352    (arg-info
353     :initform (make-arg-info)
354     :reader gf-arg-info)
355    (dfun-state
356     :initform ()
357     :accessor gf-dfun-state)
358    ;; Used to make DFUN-STATE & FIN-FUNCTION updates atomic.
359    (%lock
360     :initform (sb-thread:make-mutex :name "GF lock")
361     :reader gf-lock)
362    ;; Set to true by ADD-METHOD, REMOVE-METHOD; to false by
363    ;; MAYBE-UPDATE-INFO-FOR-GF.
364    (info-needs-update
365     :initform nil
366     :accessor gf-info-needs-update))
367   (:metaclass funcallable-standard-class)
368   (:default-initargs :method-class *the-class-standard-method*
369                      :method-combination *standard-method-combination*))
370
371 (defclass method (metaobject) ())
372
373 (defclass standard-method (plist-mixin definition-source-mixin method)
374   ((%generic-function :initform nil :accessor method-generic-function)
375    (qualifiers :initform () :initarg :qualifiers :reader method-qualifiers)
376    (specializers :initform () :initarg :specializers
377                  :reader method-specializers)
378    (lambda-list :initform () :initarg :lambda-list :reader method-lambda-list)
379    (%function :initform nil :initarg :function :reader method-function)
380    (%documentation :initform nil :initarg :documentation)
381    ;; True IFF method is known to have no CALL-NEXT-METHOD in it, or
382    ;; just a plain (CALL-NEXT-METHOD).
383    (simple-next-method-call
384     :initform nil
385     :initarg simple-next-method-call
386     :reader simple-next-method-call-p)))
387
388 (defclass accessor-method (standard-method)
389   ((slot-name :initform nil :initarg :slot-name
390               :reader accessor-method-slot-name)))
391
392 (defclass standard-accessor-method (accessor-method)
393   ((%slot-definition :initform nil :initarg :slot-definition
394                      :reader accessor-method-slot-definition)))
395
396 (defclass standard-reader-method (standard-accessor-method) ())
397 (defclass standard-writer-method (standard-accessor-method) ())
398 ;;; an extension, apparently.
399 (defclass standard-boundp-method (standard-accessor-method) ())
400
401 ;;; for (SLOT-VALUE X 'FOO) / ACCESSOR-SLOT-VALUE optimization, which
402 ;;; can't be STANDARD-READER-METHOD because there is no associated
403 ;;; slot definition.
404 (defclass global-reader-method (accessor-method) ())
405 (defclass global-writer-method (accessor-method) ())
406 (defclass global-boundp-method (accessor-method) ())
407
408 (defclass method-combination (metaobject)
409   ((%documentation :initform nil :initarg :documentation)))
410
411 (defclass standard-method-combination (definition-source-mixin
412                                        method-combination)
413   ((type-name
414     :reader method-combination-type-name
415     :initarg :type-name)
416    (options
417     :reader method-combination-options
418     :initarg :options)))
419
420 (defclass long-method-combination (standard-method-combination)
421   ((function
422     :initarg :function
423     :reader long-method-combination-function)
424    (args-lambda-list
425     :initarg :args-lambda-list
426     :reader long-method-combination-args-lambda-list)))
427
428 (defclass short-method-combination (standard-method-combination)
429   ((operator
430     :reader short-combination-operator
431     :initarg :operator)
432    (identity-with-one-argument
433     :reader short-combination-identity-with-one-argument
434     :initarg :identity-with-one-argument)))
435
436 (defclass slot-definition (metaobject)
437   ((name
438     :initform nil
439     :initarg :name
440     :accessor slot-definition-name)
441    (initform
442     :initform nil
443     :initarg :initform
444     :accessor slot-definition-initform)
445    (initfunction
446     :initform nil
447     :initarg :initfunction
448     :accessor slot-definition-initfunction)
449    (initargs
450     :initform nil
451     :initarg :initargs
452     :accessor slot-definition-initargs)
453    (%type :initform t :initarg :type :accessor slot-definition-type)
454    (%documentation
455     :initform nil :initarg :documentation
456     ;; KLUDGE: we need a reader for bootstrapping purposes, in
457     ;; COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS.
458     :reader %slot-definition-documentation)
459    (%class :initform nil :initarg :class :accessor slot-definition-class)))
460
461 (defclass standard-slot-definition (slot-definition)
462   ((allocation
463     :initform :instance
464     :initarg :allocation
465     :accessor slot-definition-allocation)
466    (allocation-class
467     :initform nil
468     :initarg :allocation-class
469     :accessor slot-definition-allocation-class)))
470
471 (defclass condition-slot-definition (slot-definition)
472   ((allocation
473     :initform :instance
474     :initarg :allocation
475     :accessor slot-definition-allocation)
476    (allocation-class
477     :initform nil
478     :initarg :allocation-class
479     :accessor slot-definition-allocation-class)))
480
481 (defclass structure-slot-definition (slot-definition)
482   ((defstruct-accessor-symbol
483      :initform nil
484      :initarg :defstruct-accessor-symbol
485      :accessor slot-definition-defstruct-accessor-symbol)
486    (internal-reader-function
487      :initform nil
488      :initarg :internal-reader-function
489      :accessor slot-definition-internal-reader-function)
490    (internal-writer-function
491      :initform nil
492      :initarg :internal-writer-function
493      :accessor slot-definition-internal-writer-function)))
494
495 (defclass direct-slot-definition (slot-definition)
496   ((readers
497     :initform nil
498     :initarg :readers
499     :accessor slot-definition-readers)
500    (writers
501     :initform nil
502     :initarg :writers
503     :accessor slot-definition-writers)))
504
505 (defclass effective-slot-definition (slot-definition)
506   ((accessor-flags
507     :initform 0)
508    (info
509     :accessor slot-definition-info)))
510
511 ;;; We use a structure here, because fast slot-accesses to this information
512 ;;; are critical to making SLOT-VALUE-USING-CLASS &co fast: places that need
513 ;;; these functions can access the SLOT-INFO directly, avoiding the overhead
514 ;;; of accessing a standard-instance.
515 (defstruct (slot-info (:constructor make-slot-info
516                                     (&key slotd
517                                           typecheck
518                                           (type t)
519                                           (reader
520                                            (uninitialized-accessor-function :reader slotd))
521                                           (writer
522                                            (uninitialized-accessor-function :writer slotd))
523                                           (boundp
524                                            (uninitialized-accessor-function :boundp slotd)))))
525   (typecheck nil :type (or null function))
526   (reader (missing-arg) :type function)
527   (writer (missing-arg) :type function)
528   (boundp (missing-arg) :type function))
529
530 (defclass standard-direct-slot-definition (standard-slot-definition
531                                            direct-slot-definition)
532   ())
533
534 (defclass standard-effective-slot-definition (standard-slot-definition
535                                               effective-slot-definition)
536   ((location ; nil, a fixnum, a cons: (slot-name . value)
537     :initform nil
538     :accessor slot-definition-location)))
539
540 (defclass condition-direct-slot-definition (condition-slot-definition
541                                             direct-slot-definition)
542   ())
543
544 (defclass condition-effective-slot-definition (condition-slot-definition
545                                                effective-slot-definition)
546   ())
547
548 (defclass structure-direct-slot-definition (structure-slot-definition
549                                             direct-slot-definition)
550   ())
551
552 (defclass structure-effective-slot-definition (structure-slot-definition
553                                                effective-slot-definition)
554   ())
555
556 (defclass specializer (metaobject)
557   ;; KLUDGE: in sbcl-0.9.10.2 this was renamed from TYPE, which was an
558   ;; external symbol of the CL package and hence potentially collides
559   ;; with user code.  Renaming this to %TYPE, however, is the coward's
560   ;; way out, because the objects that PCL puts in this slot aren't
561   ;; (quite) types: they are closer to kinds of specializer.  However,
562   ;; the wholesale renaming and disentangling of specializers didn't
563   ;; appeal.  (See also message <sqd5hrclb2.fsf@cam.ac.uk> and
564   ;; responses in comp.lang.lisp).  -- CSR, 2006-02-27
565   ((%type :initform nil :reader specializer-type)))
566
567 ;;; STANDARD in this name doesn't mean "blessed by a standard" but
568 ;;; "comes as standard with PCL"; that is, it includes CLASS-EQ
569 ;;; and vestiges of PROTOTYPE specializers
570 (defclass standard-specializer (specializer) ())
571
572 (defclass specializer-with-object (specializer) ())
573
574 (defclass exact-class-specializer (specializer) ())
575
576 (defclass class-eq-specializer (standard-specializer
577                                 exact-class-specializer
578                                 specializer-with-object)
579   ((object :initarg :class
580            :reader specializer-class
581            :reader specializer-object)))
582
583 (defclass class-prototype-specializer (standard-specializer specializer-with-object)
584   ((object :initarg :class
585            :reader specializer-class
586            :reader specializer-object)))
587
588 (defclass eql-specializer (standard-specializer exact-class-specializer specializer-with-object)
589   ((object :initarg :object :reader specializer-object
590            :reader eql-specializer-object)))
591
592 (defvar *eql-specializer-table* (make-hash-table :test 'eql))
593
594 (defun intern-eql-specializer (object)
595   ;; Need to lock, so that two threads don't get non-EQ specializers
596   ;; for an EQL object.
597   (with-locked-system-table (*eql-specializer-table*)
598     (or (gethash object *eql-specializer-table*)
599         (setf (gethash object *eql-specializer-table*)
600               (make-instance 'eql-specializer :object object)))))
601
602 (defclass class (dependent-update-mixin
603                  definition-source-mixin
604                  standard-specializer)
605   ((name
606     :initform nil
607     :initarg :name
608     :reader class-name)
609    (class-eq-specializer
610     :initform nil
611     :reader class-eq-specializer)
612    (direct-superclasses
613     :initform ()
614     :reader class-direct-superclasses)
615    ;; Note: The (CLASS-)DIRECT-SUBCLASSES for STRUCTURE-CLASSes and
616    ;; CONDITION-CLASSes are lazily computed whenever the subclass info
617    ;; becomes available, i.e. when the PCL class is created.
618    (direct-subclasses
619     :initform ()
620     :reader class-direct-subclasses)
621    (direct-methods
622     :initform (cons nil nil))
623    (%documentation
624     :initform nil
625     :initarg :documentation)
626    ;; True if the class definition was compiled with a (SAFETY 3)
627    ;; optimization policy.
628    (safe-p
629     :initform nil
630     :initarg safe-p
631     :accessor safe-p)
632    (finalized-p
633     :initform nil
634     :reader class-finalized-p)))
635
636 (def!method make-load-form ((class class) &optional env)
637   ;; FIXME: should we not instead pass ENV to FIND-CLASS?  Probably
638   ;; doesn't matter while all our environments are the same...
639   (declare (ignore env))
640   (let ((name (class-name class)))
641     (unless (and name (eq (find-class name nil) class))
642       (error "~@<Can't use anonymous or undefined class as constant: ~S~:@>"
643              class))
644     `(find-class ',name)))
645
646 ;;; The class PCL-CLASS is an implementation-specific common
647 ;;; superclass of all specified subclasses of the class CLASS.
648 (defclass pcl-class (class)
649   ((%class-precedence-list
650     :reader class-precedence-list)
651    ;; KLUDGE: see note in CPL-OR-NIL
652    (cpl-available-p
653     :reader cpl-available-p
654     :initform nil)
655    (can-precede-list
656     :initform ()
657     :reader class-can-precede-list)
658    (incompatible-superclass-list
659     :initform ()
660     :accessor class-incompatible-superclass-list)
661    (wrapper
662     :initform nil
663     :reader class-wrapper)
664    (prototype
665     :initform nil
666     :reader class-prototype)))
667
668 (defclass slot-class (pcl-class)
669   ((direct-slots
670     :initform ()
671     :reader class-direct-slots)
672    (slots
673     :initform ()
674     :reader class-slots)))
675
676 ;;; The class STD-CLASS is an implementation-specific common
677 ;;; superclass of the classes STANDARD-CLASS and
678 ;;; FUNCALLABLE-STANDARD-CLASS.
679 (defclass std-class (slot-class)
680   ())
681
682 (defclass standard-class (std-class)
683   ()
684   (:default-initargs
685    :direct-superclasses (list *the-class-standard-object*)))
686
687 (defclass funcallable-standard-class (std-class)
688   ()
689   (:default-initargs
690    :direct-superclasses (list *the-class-funcallable-standard-object*)))
691
692 (defclass forward-referenced-class (pcl-class) ())
693
694 (defclass built-in-class (pcl-class) ())
695
696 (defclass condition-class (slot-class) ())
697
698 (defclass structure-class (slot-class)
699   ((defstruct-form :initform () :accessor class-defstruct-form)
700    (defstruct-constructor :initform nil :accessor class-defstruct-constructor)
701    (from-defclass-p :initform nil :initarg :from-defclass-p)))
702
703 (defclass definition-source-mixin (standard-object)
704   ((source
705     :initform nil
706     :reader definition-source
707     :initarg :definition-source)))
708
709 (defclass plist-mixin (standard-object)
710   ((plist :initform () :accessor object-plist :initarg plist)))
711
712 (defclass dependent-update-mixin (plist-mixin) ())
713
714 (defparameter *early-class-predicates*
715   '((specializer specializerp)
716     (standard-specializer standard-specializer-p)
717     (exact-class-specializer exact-class-specializer-p)
718     (class-eq-specializer class-eq-specializer-p)
719     (eql-specializer eql-specializer-p)
720     (class classp)
721     (slot-class slot-class-p)
722     (std-class std-class-p)
723     (standard-class standard-class-p)
724     (funcallable-standard-class funcallable-standard-class-p)
725     (condition-class condition-class-p)
726     (structure-class structure-class-p)
727     (forward-referenced-class forward-referenced-class-p)
728     (method method-p)
729     (standard-method standard-method-p)
730     (accessor-method accessor-method-p)
731     (standard-accessor-method standard-accessor-method-p)
732     (standard-reader-method standard-reader-method-p)
733     (standard-writer-method standard-writer-method-p)
734     (standard-boundp-method standard-boundp-method-p)
735     (global-reader-method global-reader-method-p)
736     (global-writer-method global-writer-method-p)
737     (global-boundp-method global-boundp-method-p)
738     (generic-function generic-function-p)
739     (standard-generic-function standard-generic-function-p)
740     (method-combination method-combination-p)
741     (long-method-combination long-method-combination-p)
742     (short-method-combination short-method-combination-p)))