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-spinlock :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    (readers
 450     :initform nil
 451     :initarg :readers
 452     :accessor slot-definition-readers)
 453    (writers
 454     :initform nil
 455     :initarg :writers
 456     :accessor slot-definition-writers)
 457    (initargs
 458     :initform nil
 459     :initarg :initargs
 460     :accessor slot-definition-initargs)
 461    (%type :initform t :initarg :type :accessor slot-definition-type)
 462    (%documentation
 463     :initform nil :initarg :documentation
 464     ;; KLUDGE: we need a reader for bootstrapping purposes, in
 465     ;; COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS.
 466     :reader %slot-definition-documentation)
 467    (%class :initform nil :initarg :class :accessor slot-definition-class)))
 468
 469 (defclass standard-slot-definition (slot-definition)
 470   ((allocation
 471     :initform :instance
 472     :initarg :allocation
 473     :accessor slot-definition-allocation)
 474    (allocation-class
 475     :initform nil
 476     :initarg :allocation-class
 477     :accessor slot-definition-allocation-class)))
 478
 479 (defclass condition-slot-definition (slot-definition)
 480   ((allocation
 481     :initform :instance
 482     :initarg :allocation
 483     :accessor slot-definition-allocation)
 484    (allocation-class
 485     :initform nil
 486     :initarg :allocation-class
 487     :accessor slot-definition-allocation-class)))
 488
 489 (defclass structure-slot-definition (slot-definition)
 490   ((defstruct-accessor-symbol
 491      :initform nil
 492      :initarg :defstruct-accessor-symbol
 493      :accessor slot-definition-defstruct-accessor-symbol)
 494    (internal-reader-function
 495      :initform nil
 496      :initarg :internal-reader-function
 497      :accessor slot-definition-internal-reader-function)
 498    (internal-writer-function
 499      :initform nil
 500      :initarg :internal-writer-function
 501      :accessor slot-definition-internal-writer-function)))
 502
 503 (defclass direct-slot-definition (slot-definition)
 504   ())
 505
 506 (defclass effective-slot-definition (slot-definition)
 507   ((accessor-flags
 508     :initform 0)
 509    (info
 510     :accessor slot-definition-info)))
 511
 512 ;;; We use a structure here, because fast slot-accesses to this information
 513 ;;; are critical to making SLOT-VALUE-USING-CLASS &co fast: places that need
 514 ;;; these functions can access the SLOT-INFO directly, avoiding the overhead
 515 ;;; of accessing a standard-instance.
 516 (defstruct (slot-info (:constructor make-slot-info
 517                                     (&key slotd
 518                                           typecheck
 519                                           (type t)
 520                                           (reader
 521                                            (uninitialized-accessor-function :reader slotd))
 522                                           (writer
 523                                            (uninitialized-accessor-function :writer slotd))
 524                                           (boundp
 525                                            (uninitialized-accessor-function :boundp slotd)))))
 526   (typecheck nil :type (or null function))
 527   (reader (missing-arg) :type function)
 528   (writer (missing-arg) :type function)
 529   (boundp (missing-arg) :type function))
 530
 531 (defclass standard-direct-slot-definition (standard-slot-definition
 532                                            direct-slot-definition)
 533   ())
 534
 535 (defclass standard-effective-slot-definition (standard-slot-definition
 536                                               effective-slot-definition)
 537   ((location ; nil, a fixnum, a cons: (slot-name . value)
 538     :initform nil
 539     :accessor slot-definition-location)))
 540
 541 (defclass condition-direct-slot-definition (condition-slot-definition
 542                                             direct-slot-definition)
 543   ())
 544
 545 (defclass condition-effective-slot-definition (condition-slot-definition
 546                                                effective-slot-definition)
 547   ())
 548
 549 (defclass structure-direct-slot-definition (structure-slot-definition
 550                                             direct-slot-definition)
 551   ())
 552
 553 (defclass structure-effective-slot-definition (structure-slot-definition
 554                                                effective-slot-definition)
 555   ())
 556
 557 (defclass specializer (metaobject)
 558   ;; KLUDGE: in sbcl-0.9.10.2 this was renamed from TYPE, which was an
 559   ;; external symbol of the CL package and hence potentially collides
 560   ;; with user code.  Renaming this to %TYPE, however, is the coward's
 561   ;; way out, because the objects that PCL puts in this slot aren't
 562   ;; (quite) types: they are closer to kinds of specializer.  However,
 563   ;; the wholesale renaming and disentangling of specializers didn't
 564   ;; appeal.  (See also message <sqd5hrclb2.fsf@cam.ac.uk> and
 565   ;; responses in comp.lang.lisp).  -- CSR, 2006-02-27
 566   ((%type :initform nil :reader specializer-type)))
 567
 568 ;;; STANDARD in this name doesn't mean "blessed by a standard" but
 569 ;;; "comes as standard with PCL"; that is, it includes CLASS-EQ
 570 ;;; and vestiges of PROTOTYPE specializers
 571 (defclass standard-specializer (specializer) ())
 572
 573 (defclass specializer-with-object (specializer) ())
 574
 575 (defclass exact-class-specializer (specializer) ())
 576
 577 (defclass class-eq-specializer (standard-specializer
 578                                 exact-class-specializer
 579                                 specializer-with-object)
 580   ((object :initarg :class
 581            :reader specializer-class
 582            :reader specializer-object)))
 583
 584 (defclass class-prototype-specializer (standard-specializer specializer-with-object)
 585   ((object :initarg :class
 586            :reader specializer-class
 587            :reader specializer-object)))
 588
 589 (defclass eql-specializer (standard-specializer exact-class-specializer specializer-with-object)
 590   ((object :initarg :object :reader specializer-object
 591            :reader eql-specializer-object)))
 592
 593 (defvar *eql-specializer-table* (make-hash-table :test 'eql))
 594
 595 (defvar *eql-specializer-table-lock*
 596   (sb-thread::make-spinlock :name "EQL-specializer table lock"))
 597
 598 (defun intern-eql-specializer (object)
 599   ;; Need to lock, so that two threads don't get non-EQ specializers
 600   ;; for an EQL object.
 601   (sb-thread::with-spinlock (*eql-specializer-table-lock*)
 602     (or (gethash object *eql-specializer-table*)
 603         (setf (gethash object *eql-specializer-table*)
 604               (make-instance 'eql-specializer :object object)))))
 605
 606 (defclass class (dependent-update-mixin
 607                  definition-source-mixin
 608                  standard-specializer)
 609   ((name
 610     :initform nil
 611     :initarg :name
 612     :reader class-name)
 613    (class-eq-specializer
 614     :initform nil
 615     :reader class-eq-specializer)
 616    (direct-superclasses
 617     :initform ()
 618     :reader class-direct-superclasses)
 619    ;; Note: The (CLASS-)DIRECT-SUBCLASSES for STRUCTURE-CLASSes and
 620    ;; CONDITION-CLASSes are lazily computed whenever the subclass info
 621    ;; becomes available, i.e. when the PCL class is created.
 622    (direct-subclasses
 623     :initform ()
 624     :reader class-direct-subclasses)
 625    (direct-methods
 626     :initform (cons nil nil))
 627    (%documentation
 628     :initform nil
 629     :initarg :documentation)
 630    ;; True if the class definition was compiled with a (SAFETY 3)
 631    ;; optimization policy.
 632    (safe-p
 633     :initform nil
 634     :initarg safe-p
 635     :accessor safe-p)
 636    (finalized-p
 637     :initform nil
 638     :reader class-finalized-p)))
 639
 640 (def!method make-load-form ((class class) &optional env)
 641   ;; FIXME: should we not instead pass ENV to FIND-CLASS?  Probably
 642   ;; doesn't matter while all our environments are the same...
 643   (declare (ignore env))
 644   (let ((name (class-name class)))
 645     (unless (and name (eq (find-class name nil) class))
 646       (error "~@<Can't use anonymous or undefined class as constant: ~S~:@>"
 647              class))
 648     `(find-class ',name)))
 649
 650 ;;; The class PCL-CLASS is an implementation-specific common
 651 ;;; superclass of all specified subclasses of the class CLASS.
 652 (defclass pcl-class (class)
 653   ((%class-precedence-list
 654     :reader class-precedence-list)
 655    ;; KLUDGE: see note in CPL-OR-NIL
 656    (cpl-available-p
 657     :reader cpl-available-p
 658     :initform nil)
 659    (can-precede-list
 660     :initform ()
 661     :reader class-can-precede-list)
 662    (incompatible-superclass-list
 663     :initform ()
 664     :accessor class-incompatible-superclass-list)
 665    (wrapper
 666     :initform nil
 667     :reader class-wrapper)
 668    (prototype
 669     :initform nil
 670     :reader class-prototype)))
 671
 672 (defclass slot-class (pcl-class)
 673   ((direct-slots
 674     :initform ()
 675     :reader class-direct-slots)
 676    (slots
 677     :initform ()
 678     :reader class-slots)))
 679
 680 ;;; The class STD-CLASS is an implementation-specific common
 681 ;;; superclass of the classes STANDARD-CLASS and
 682 ;;; FUNCALLABLE-STANDARD-CLASS.
 683 (defclass std-class (slot-class)
 684   ())
 685
 686 (defclass standard-class (std-class)
 687   ()
 688   (:default-initargs
 689    :direct-superclasses (list *the-class-standard-object*)))
 690
 691 (defclass funcallable-standard-class (std-class)
 692   ()
 693   (:default-initargs
 694    :direct-superclasses (list *the-class-funcallable-standard-object*)))
 695
 696 (defclass forward-referenced-class (pcl-class) ())
 697
 698 (defclass built-in-class (pcl-class) ())
 699
 700 (defclass condition-class (slot-class) ())
 701
 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)))
 706
 707 (defclass definition-source-mixin (standard-object)
 708   ((source
 709     :initform nil
 710     :reader definition-source
 711     :initarg :definition-source)))
 712
 713 (defclass plist-mixin (standard-object)
 714   ((plist :initform () :accessor object-plist :initarg plist)))
 715
 716 (defclass dependent-update-mixin (plist-mixin) ())
 717
 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)))