Fix print-object on sb!fasl::descriptor
[sbcl.git] / src / pcl / defs.lisp
blob6ca3fd2578e8656666d9cb76b9cc87ad7e1edfe1
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
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.
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.
24 (in-package "SB-PCL")
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."))
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))
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))
54 ;;;; type specifier hackery
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))
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)))
82 ;;; interface
83 (defun type-from-specializer (specl)
84 (cond ((eq specl 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))
98 (error "~S is neither a type nor a specializer." specl))))
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)))))
113 (defun class-eq-type (class)
114 (specializer-type (class-eq-specializer class)))
116 ;;; internal to this file..
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))
137 (error "~S is not a type." type))))
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))))
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.
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)
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)))))
178 (subtypep (convert-to-system-type type1)
179 (convert-to-system-type type2))))))))
181 (defvar *built-in-class-symbols* ())
182 (defvar *built-in-wrapper-symbols* ())
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)))
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)))
196 (defvar *standard-method-combination*)
198 (defun plist-value (object name)
199 (getf (object-plist object) name))
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)))
208 ;;;; built-in classes
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 ;; remove special classes (T and our
261 ;; SYSTEM-CLASSes) from the
262 ;; BUILT-IN-CLASS list
263 '(t function stream sequence
264 file-stream string-stream)))
265 sb-kernel::*!built-in-classes*))))
266 (/noshow "done setting up SB-PCL::*BUILT-IN-CLASSES*")
268 ;;;; the classes that define the kernel of the metabraid
270 (defclass t () ()
271 ;; AMOP specifies that the class named T should be an instance of
272 ;; BUILT-IN-CLASS, but this conflicts with other specifications in
273 ;; AMOP and CLHS.
274 (:metaclass system-class))
276 (defclass function (t) ()
277 (:metaclass system-class))
279 (defclass stream (t) ()
280 (:metaclass system-class))
282 (defclass file-stream (stream) ()
283 (:metaclass system-class))
285 (defclass string-stream (stream) ()
286 (:metaclass system-class))
288 (defclass sequence (t) ()
289 (:metaclass system-class))
291 (defclass slot-object (t) ()
292 (:metaclass slot-class))
294 (defclass condition (slot-object) ()
295 (:metaclass condition-class))
297 (defclass structure-object (slot-object) ()
298 (:metaclass structure-class))
300 (defstruct (dead-beef-structure-object
301 (:constructor |STRUCTURE-OBJECT class constructor|)
302 (:copier nil)))
304 (defclass standard-object (slot-object) ())
306 (defclass funcallable-standard-object (function standard-object)
308 (:metaclass funcallable-standard-class))
310 (defclass metaobject (standard-object) ())
312 (defclass generic-function (dependent-update-mixin
313 definition-source-mixin
314 metaobject
315 funcallable-standard-object)
316 ((%documentation :initform nil :initarg :documentation)
317 ;; We need to make a distinction between the methods initially set
318 ;; up by :METHOD options to DEFGENERIC and the ones set up later by
319 ;; DEFMETHOD, because ANSI specifies that executing DEFGENERIC on
320 ;; an already-DEFGENERICed function clears the methods set by the
321 ;; previous DEFGENERIC, but not methods set by DEFMETHOD. (Making
322 ;; this distinction seems a little kludgy, but it has the positive
323 ;; effect of making it so that loading a file a.lisp containing
324 ;; DEFGENERIC, then loading a second file b.lisp containing
325 ;; DEFMETHOD, then modifying and reloading a.lisp and/or b.lisp
326 ;; tends to leave the generic function in a state consistent with
327 ;; the most-recently-loaded state of a.lisp and b.lisp.)
328 (initial-methods :initform () :accessor generic-function-initial-methods)
329 (encapsulations :initform () :accessor generic-function-encapsulations))
330 (:metaclass funcallable-standard-class))
332 (defclass standard-generic-function (generic-function)
333 ((name
334 :initform nil
335 :initarg :name
336 :reader generic-function-name)
337 (methods
338 :initform ()
339 :accessor generic-function-methods
340 :type list)
341 (method-class
342 :initarg :method-class
343 :accessor generic-function-method-class)
344 (%method-combination
345 :initarg :method-combination
346 :accessor generic-function-method-combination)
347 (declarations
348 ;; KLUDGE: AMOP specifies :DECLARATIONS, while ANSI specifies
349 ;; :DECLARE. Allow either (but FIXME: maybe a note or a warning
350 ;; might be appropriate).
351 :initarg :declarations
352 :initarg :declare
353 :initform ()
354 :accessor generic-function-declarations)
355 (arg-info
356 :initform (make-arg-info)
357 :reader gf-arg-info)
358 (dfun-state
359 :initform ()
360 :accessor gf-dfun-state)
361 ;; Used to make DFUN-STATE & FIN-FUNCTION updates atomic.
362 (%lock
363 :initform (sb-thread:make-mutex :name "GF lock")
364 :reader gf-lock)
365 ;; Set to true by ADD-METHOD, REMOVE-METHOD; to false by
366 ;; MAYBE-UPDATE-INFO-FOR-GF.
367 (info-needs-update
368 :initform nil
369 :accessor gf-info-needs-update))
370 (:metaclass funcallable-standard-class)
371 (:default-initargs :method-class *the-class-standard-method*
372 :method-combination *standard-method-combination*))
374 (defclass method (metaobject) ())
376 (defclass standard-method (plist-mixin definition-source-mixin method)
377 ((%generic-function :initform nil :accessor method-generic-function)
378 (qualifiers :initform () :initarg :qualifiers :reader method-qualifiers)
379 (specializers :initform () :initarg :specializers
380 :reader method-specializers)
381 (lambda-list :initform () :initarg :lambda-list :reader method-lambda-list)
382 (%function :initform nil :initarg :function :reader method-function)
383 (%documentation :initform nil :initarg :documentation)
384 ;; True IFF method is known to have no CALL-NEXT-METHOD in it, or
385 ;; just a plain (CALL-NEXT-METHOD).
386 (simple-next-method-call
387 :initform nil
388 :initarg simple-next-method-call
389 :reader simple-next-method-call-p)))
391 (defclass accessor-method (standard-method)
392 ((slot-name :initform nil :initarg :slot-name
393 :reader accessor-method-slot-name)))
395 (defclass standard-accessor-method (accessor-method)
396 ((%slot-definition :initform nil :initarg :slot-definition
397 :reader accessor-method-slot-definition)))
399 (defclass standard-reader-method (standard-accessor-method) ())
400 (defclass standard-writer-method (standard-accessor-method) ())
401 ;;; an extension, apparently.
402 (defclass standard-boundp-method (standard-accessor-method) ())
404 ;;; for (SLOT-VALUE X 'FOO) / ACCESSOR-SLOT-VALUE optimization, which
405 ;;; can't be STANDARD-READER-METHOD because there is no associated
406 ;;; slot definition.
407 (defclass global-reader-method (accessor-method) ())
408 (defclass global-writer-method (accessor-method) ())
409 (defclass global-boundp-method (accessor-method) ())
411 (defclass method-combination (metaobject)
412 ((%documentation :initform nil :initarg :documentation)))
414 (defclass standard-method-combination (definition-source-mixin
415 method-combination)
416 ((type-name
417 :reader method-combination-type-name
418 :initarg :type-name)
419 (options
420 :reader method-combination-options
421 :initarg :options)))
423 (defclass long-method-combination (standard-method-combination)
424 ((function
425 :initarg :function
426 :reader long-method-combination-function)
427 (args-lambda-list
428 :initarg :args-lambda-list
429 :reader long-method-combination-args-lambda-list)))
431 (defclass short-method-combination (standard-method-combination)
432 ((operator
433 :reader short-combination-operator
434 :initarg :operator)
435 (identity-with-one-argument
436 :reader short-combination-identity-with-one-argument
437 :initarg :identity-with-one-argument)))
439 (defclass slot-definition (metaobject)
440 ((name
441 :initform nil
442 :initarg :name
443 :accessor slot-definition-name)
444 (initform
445 :initform nil
446 :initarg :initform
447 :accessor slot-definition-initform)
448 (initfunction
449 :initform nil
450 :initarg :initfunction
451 :accessor slot-definition-initfunction)
452 (initargs
453 :initform nil
454 :initarg :initargs
455 :accessor slot-definition-initargs)
456 (%type :initform t :initarg :type :accessor slot-definition-type)
457 (%documentation
458 :initform nil :initarg :documentation
459 ;; KLUDGE: we need a reader for bootstrapping purposes, in
460 ;; COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS.
461 :reader %slot-definition-documentation)
462 (%class :initform nil :initarg :class :accessor slot-definition-class)))
464 (defclass standard-slot-definition (slot-definition)
465 ((allocation
466 :initform :instance
467 :initarg :allocation
468 :accessor slot-definition-allocation)
469 (allocation-class
470 :initform nil
471 :initarg :allocation-class
472 :accessor slot-definition-allocation-class)))
474 (defclass condition-slot-definition (slot-definition)
475 ((allocation
476 :initform :instance
477 :initarg :allocation
478 :accessor slot-definition-allocation)
479 (allocation-class
480 :initform nil
481 :initarg :allocation-class
482 :accessor slot-definition-allocation-class)))
484 (defclass structure-slot-definition (slot-definition)
485 ((defstruct-accessor-symbol
486 :initform nil
487 :initarg :defstruct-accessor-symbol
488 :accessor slot-definition-defstruct-accessor-symbol)
489 (internal-reader-function
490 :initform nil
491 :initarg :internal-reader-function
492 :accessor slot-definition-internal-reader-function)
493 (internal-writer-function
494 :initform nil
495 :initarg :internal-writer-function
496 :accessor slot-definition-internal-writer-function)))
498 (defclass direct-slot-definition (slot-definition)
499 ((readers
500 :initform nil
501 :initarg :readers
502 :accessor slot-definition-readers)
503 (writers
504 :initform nil
505 :initarg :writers
506 :accessor slot-definition-writers)))
508 (defclass effective-slot-definition (slot-definition)
509 ((accessor-flags
510 :initform 0)
511 (info
512 :accessor slot-definition-info)))
514 ;;; We use a structure here, because fast slot-accesses to this information
515 ;;; are critical to making SLOT-VALUE-USING-CLASS &co fast: places that need
516 ;;; these functions can access the SLOT-INFO directly, avoiding the overhead
517 ;;; of accessing a standard-instance.
518 (defstruct (slot-info
519 (:constructor make-slot-info
520 (&key slotd typecheck
521 (reader (uninitialized-accessor-function :reader slotd))
522 (writer (uninitialized-accessor-function :writer slotd))
523 (boundp (uninitialized-accessor-function :boundp slotd)))))
524 (typecheck nil :type (or null function))
525 (reader (missing-arg) :type function)
526 (writer (missing-arg) :type function)
527 (boundp (missing-arg) :type function))
529 (defclass standard-direct-slot-definition (standard-slot-definition
530 direct-slot-definition)
533 (defclass standard-effective-slot-definition (standard-slot-definition
534 effective-slot-definition)
535 ((location ; nil, a fixnum, a cons: (slot-name . value)
536 :initform nil
537 :accessor slot-definition-location)))
539 (defclass condition-direct-slot-definition (condition-slot-definition
540 direct-slot-definition)
543 (defclass condition-effective-slot-definition (condition-slot-definition
544 effective-slot-definition)
547 (defclass structure-direct-slot-definition (structure-slot-definition
548 direct-slot-definition)
551 (defclass structure-effective-slot-definition (structure-slot-definition
552 effective-slot-definition)
555 (defclass specializer (metaobject)
556 ;; KLUDGE: in sbcl-0.9.10.2 this was renamed from TYPE, which was an
557 ;; external symbol of the CL package and hence potentially collides
558 ;; with user code. Renaming this to %TYPE, however, is the coward's
559 ;; way out, because the objects that PCL puts in this slot aren't
560 ;; (quite) types: they are closer to kinds of specializer. However,
561 ;; the wholesale renaming and disentangling of specializers didn't
562 ;; appeal. (See also message <sqd5hrclb2.fsf@cam.ac.uk> and
563 ;; responses in comp.lang.lisp). -- CSR, 2006-02-27
564 ((%type :initform nil :reader specializer-type)))
566 ;;; STANDARD in this name doesn't mean "blessed by a standard" but
567 ;;; "comes as standard with PCL"; that is, it includes CLASS-EQ
568 ;;; and vestiges of PROTOTYPE specializers
569 (defclass standard-specializer (specializer) ())
571 (defclass specializer-with-object (specializer) ())
573 (defclass exact-class-specializer (specializer) ())
575 (defclass class-eq-specializer (standard-specializer
576 exact-class-specializer
577 specializer-with-object)
578 ((object :initarg :class
579 :reader specializer-class
580 :reader specializer-object)))
582 (defclass class-prototype-specializer (standard-specializer specializer-with-object)
583 ((object :initarg :class
584 :reader specializer-class
585 :reader specializer-object)))
587 (defclass eql-specializer (standard-specializer exact-class-specializer specializer-with-object)
588 ((object :initarg :object :reader specializer-object
589 :reader eql-specializer-object)))
591 (defvar *eql-specializer-table* (make-hash-table :test 'eql))
593 (defun intern-eql-specializer (object)
594 ;; Need to lock, so that two threads don't get non-EQ specializers
595 ;; for an EQL object.
596 (with-locked-system-table (*eql-specializer-table*)
597 (or (gethash object *eql-specializer-table*)
598 (setf (gethash object *eql-specializer-table*)
599 (make-instance 'eql-specializer :object object)))))
601 (defclass class (dependent-update-mixin
602 definition-source-mixin
603 standard-specializer)
604 ((name
605 :initform nil
606 :initarg :name
607 :reader class-name)
608 (class-eq-specializer
609 :initform nil
610 :reader class-eq-specializer)
611 (direct-superclasses
612 :initform ()
613 :reader class-direct-superclasses)
614 ;; Note: The (CLASS-)DIRECT-SUBCLASSES for STRUCTURE-CLASSes and
615 ;; CONDITION-CLASSes are lazily computed whenever the subclass info
616 ;; becomes available, i.e. when the PCL class is created.
617 (direct-subclasses
618 :initform ()
619 :reader class-direct-subclasses)
620 (direct-methods
621 :initform (cons nil nil))
622 (%documentation
623 :initform nil
624 :initarg :documentation)
625 ;; True if the class definition was compiled with a (SAFETY 3)
626 ;; optimization policy.
627 (safe-p
628 :initform nil
629 :initarg safe-p
630 :accessor safe-p)
631 (finalized-p
632 :initform nil
633 :reader class-finalized-p)))
635 (def!method make-load-form ((class class) &optional env)
636 ;; FIXME: should we not instead pass ENV to FIND-CLASS? Probably
637 ;; doesn't matter while all our environments are the same...
638 (declare (ignore env))
639 (let ((name (class-name class)))
640 (unless (and name (eq (find-class name nil) class))
641 (error "~@<Can't use anonymous or undefined class as constant: ~S~:@>"
642 class))
643 ;; Essentially we want `(FIND-CLASS ',NAME) but without using backquote.
644 ;; Because this is a delayed DEF!METHOD, its entire body is quoted structure
645 ;; and can't contain a comma object until a MAKE-LOAD-FORM exists for that.
646 (list 'find-class (list 'quote name))))
648 ;;; The class PCL-CLASS is an implementation-specific common
649 ;;; superclass of all specified subclasses of the class CLASS.
650 (defclass pcl-class (class)
651 ((%class-precedence-list
652 :reader class-precedence-list)
653 ;; KLUDGE: see note in CPL-OR-NIL
654 (cpl-available-p
655 :reader cpl-available-p
656 :initform nil)
657 (can-precede-list
658 :initform ()
659 :reader class-can-precede-list)
660 (incompatible-superclass-list
661 :initform ()
662 :accessor class-incompatible-superclass-list)
663 (wrapper
664 :initform nil
665 :reader class-wrapper)
666 (prototype
667 :initform nil
668 :reader class-prototype)))
670 (defclass slot-class (pcl-class)
671 ((direct-slots
672 :initform ()
673 :reader class-direct-slots)
674 (slots
675 :initform ()
676 :reader class-slots)))
678 ;;; The class STD-CLASS is an implementation-specific common
679 ;;; superclass of the classes STANDARD-CLASS and
680 ;;; FUNCALLABLE-STANDARD-CLASS.
681 (defclass std-class (slot-class)
684 (defclass standard-class (std-class)
686 (:default-initargs
687 :direct-superclasses (list *the-class-standard-object*)))
689 (defclass funcallable-standard-class (std-class)
691 (:default-initargs
692 :direct-superclasses (list *the-class-funcallable-standard-object*)))
694 (defclass forward-referenced-class (pcl-class) ())
696 (defclass system-class (pcl-class) ())
698 (defclass built-in-class (system-class) ())
700 (defclass condition-class (slot-class) ())
702 (defclass structure-class (slot-class)
703 ((defstruct-form :initform () :accessor class-defstruct-form)
704 (defstruct-constructor :initform nil :accessor class-defstruct-constructor)
705 (from-defclass-p :initform nil :initarg :from-defclass-p)))
707 (defclass definition-source-mixin (standard-object)
708 ((source
709 :initform nil
710 :reader definition-source
711 :initarg :definition-source)))
713 (defclass plist-mixin (standard-object)
714 ((plist :initform () :accessor object-plist :initarg plist)))
716 (defclass dependent-update-mixin (plist-mixin) ())
718 (defparameter *!early-class-predicates*
719 '((specializer specializerp)
720 (standard-specializer standard-specializer-p)
721 (exact-class-specializer exact-class-specializer-p)
722 (class-eq-specializer class-eq-specializer-p)
723 (eql-specializer eql-specializer-p)
724 (class classp)
725 (slot-class slot-class-p)
726 (std-class std-class-p)
727 (standard-class standard-class-p)
728 (funcallable-standard-class funcallable-standard-class-p)
729 (condition-class condition-class-p)
730 (structure-class structure-class-p)
731 (forward-referenced-class forward-referenced-class-p)
732 (method method-p)
733 (standard-method standard-method-p)
734 (accessor-method accessor-method-p)
735 (standard-accessor-method standard-accessor-method-p)
736 (standard-reader-method standard-reader-method-p)
737 (standard-writer-method standard-writer-method-p)
738 (standard-boundp-method standard-boundp-method-p)
739 (global-reader-method global-reader-method-p)
740 (global-writer-method global-writer-method-p)
741 (global-boundp-method global-boundp-method-p)
742 (generic-function generic-function-p)
743 (standard-generic-function standard-generic-function-p)
744 (method-combination method-combination-p)
745 (long-method-combination long-method-combination-p)
746 (short-method-combination short-method-combination-p)))