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 (consp type)
  66     (setq args (cdr type) type (car type)))
  67   (cond ((symbolp type)
  68          (or (and (null args) (find-class type))
  69              (ecase type
  70                (class    (coerce-to-class (car args)))
  71                (prototype (make-instance 'class-prototype-specializer
  72                                          :object (coerce-to-class (car args))))
  73                (class-eq (class-eq-specializer (coerce-to-class (car args))))
  74                (eql      (intern-eql-specializer (car args))))))
  75         ;; FIXME: do we still need this?
  76         ((and (null args) (typep type 'classoid))
  77          (or (classoid-pcl-class type)
  78              (ensure-non-standard-class (classoid-name type))))
  79         ((specializerp type) type)))
  80
  81 ;;; interface
  82 (defun type-from-specializer (specl)
  83   (cond ((eq specl t)
  84          t)
  85         ((consp specl)
  86          (unless (member (car specl) '(class prototype class-eq eql))
  87            (error "~S is not a legal specializer type." specl))
  88          specl)
  89         ((progn
  90            (when (symbolp specl)
  91              ;;maybe (or (find-class specl nil) (ensure-class specl)) instead?
  92              (setq specl (find-class specl)))
  93            (or (not (eq *boot-state* 'complete))
  94                (specializerp specl)))
  95          (specializer-type specl))
  96         (t
  97          (error "~S is neither a type nor a specializer." specl))))
  98
  99 (defun type-class (type)
 100   (declare (special *the-class-t*))
 101   (setq type (type-from-specializer type))
 102   (if (atom type)
 103       (if (eq type t)
 104           *the-class-t*
 105           (error "bad argument to TYPE-CLASS"))
 106       (case (car type)
 107         (eql (class-of (cadr type)))
 108         (prototype (class-of (cadr type))) ;?
 109         (class-eq (cadr type))
 110         (class (cadr type)))))
 111
 112 (defun class-eq-type (class)
 113   (specializer-type (class-eq-specializer class)))
 114
 115 ;;; internal to this file..
 116 ;;;
 117 ;;; These functions are a pale imitation of their namesake. They accept
 118 ;;; class objects or types where they should.
 119 (defun *normalize-type (type)
 120   (cond ((consp type)
 121          (if (member (car type) '(not and or))
 122              `(,(car type) ,@(mapcar #'*normalize-type (cdr type)))
 123              (if (null (cdr type))
 124                  (*normalize-type (car type))
 125                  type)))
 126         ((symbolp type)
 127          (let ((class (find-class type nil)))
 128            (if class
 129                (let ((type (specializer-type class)))
 130                  (if (listp type) type `(,type)))
 131                `(,type))))
 132         ((or (not (eq *boot-state* 'complete))
 133              (specializerp type))
 134          (specializer-type type))
 135         (t
 136          (error "~S is not a type." type))))
 137
 138 ;;; internal to this file...
 139 (defun convert-to-system-type (type)
 140   (case (car type)
 141     ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
 142                                           (cdr type))))
 143     ((class class-eq) ; class-eq is impossible to do right
 144      (layout-classoid (class-wrapper (cadr type))))
 145     (eql type)
 146     (t (if (null (cdr type))
 147            (car type)
 148            type))))
 149
 150 ;;; Writing the missing NOT and AND clauses will improve the quality
 151 ;;; of code generated by GENERATE-DISCRIMINATION-NET, but calling
 152 ;;; SUBTYPEP in place of just returning (VALUES NIL NIL) can be very
 153 ;;; slow. *SUBTYPEP is used by PCL itself, and must be fast.
 154 ;;;
 155 ;;; FIXME: SB-KERNEL has fast-and-not-quite-precise type code for use
 156 ;;; in the compiler. Could we share some of it here?
 157 (defun *subtypep (type1 type2)
 158   (if (equal type1 type2)
 159       (values t t)
 160       (if (eq *boot-state* 'early)
 161           (values (eq type1 type2) t)
 162           (let ((*in-precompute-effective-methods-p* t))
 163             (declare (special *in-precompute-effective-methods-p*))
 164             ;; FIXME: *IN-PRECOMPUTE-EFFECTIVE-METHODS-P* is not a
 165             ;; good name. It changes the way
 166             ;; CLASS-APPLICABLE-USING-CLASS-P works.
 167             (setq type1 (*normalize-type type1))
 168             (setq type2 (*normalize-type type2))
 169             (case (car type2)
 170               (not
 171                (values nil nil)) ; XXX We should improve this.
 172               (and
 173                (values nil nil)) ; XXX We should improve this.
 174               ((eql wrapper-eq class-eq class)
 175                (multiple-value-bind (app-p maybe-app-p)
 176                    (specializer-applicable-using-type-p type2 type1)
 177                  (values app-p (or app-p (not maybe-app-p)))))
 178               (t
 179                (subtypep (convert-to-system-type type1)
 180                          (convert-to-system-type type2))))))))
 181 \f
 182 (defvar *built-in-class-symbols* ())
 183 (defvar *built-in-wrapper-symbols* ())
 184
 185 (defun get-built-in-class-symbol (class-name)
 186   (or (cadr (assq class-name *built-in-class-symbols*))
 187       (let ((symbol (make-class-symbol class-name)))
 188         (push (list class-name symbol) *built-in-class-symbols*)
 189         symbol)))
 190
 191 (defun get-built-in-wrapper-symbol (class-name)
 192   (or (cadr (assq class-name *built-in-wrapper-symbols*))
 193       (let ((symbol (make-wrapper-symbol class-name)))
 194         (push (list class-name symbol) *built-in-wrapper-symbols*)
 195         symbol)))
 196 \f
 197 (pushnew '%class *var-declarations*)
 198 (pushnew '%variable-rebinding *var-declarations*)
 199
 200 (defun variable-class (var env)
 201   (caddr (var-declaration 'class var env)))
 202
 203 (defvar *name->class->slotd-table* (make-hash-table))
 204
 205 (defvar *standard-method-combination*)
 206 \f
 207 (defun make-class-predicate-name (name)
 208   (list 'class-predicate name))
 209
 210 (defun plist-value (object name)
 211   (getf (object-plist object) name))
 212
 213 (defun (setf plist-value) (new-value object name)
 214   (if new-value
 215       (setf (getf (object-plist object) name) new-value)
 216       (progn
 217         (remf (object-plist object) name)
 218         nil)))
 219 \f
 220 ;;;; built-in classes
 221
 222 ;;; Grovel over SB-KERNEL::*BUILT-IN-CLASSES* in order to set
 223 ;;; SB-PCL:*BUILT-IN-CLASSES*.
 224 (/show "about to set up SB-PCL::*BUILT-IN-CLASSES*")
 225 (defvar *built-in-classes*
 226   (labels ((direct-supers (class)
 227              (/noshow "entering DIRECT-SUPERS" (classoid-name class))
 228              (if (typep class 'built-in-classoid)
 229                  (built-in-classoid-direct-superclasses class)
 230                  (let ((inherits (layout-inherits
 231                                   (classoid-layout class))))
 232                    (/noshow inherits)
 233                    (list (svref inherits (1- (length inherits)))))))
 234            (direct-subs (class)
 235              (/noshow "entering DIRECT-SUBS" (classoid-name class))
 236              (collect ((res))
 237                (let ((subs (classoid-subclasses class)))
 238                  (/noshow subs)
 239                  (when subs
 240                    (dohash (sub v subs)
 241                      (declare (ignore v))
 242                      (/noshow sub)
 243                      (when (member class (direct-supers sub))
 244                        (res sub)))))
 245                (res))))
 246     (mapcar (lambda (kernel-bic-entry)
 247               (/noshow "setting up" kernel-bic-entry)
 248               (let* ((name (car kernel-bic-entry))
 249                      (class (find-classoid name))
 250                      (prototype-form
 251                       (getf (cdr kernel-bic-entry) :prototype-form)))
 252                 (/noshow name class)
 253                 `(,name
 254                   ,(mapcar #'classoid-name (direct-supers class))
 255                   ,(mapcar #'classoid-name (direct-subs class))
 256                   ,(map 'list
 257                         (lambda (x)
 258                           (classoid-name
 259                            (layout-classoid x)))
 260                         (reverse
 261                          (layout-inherits
 262                           (classoid-layout class))))
 263                   ,(if prototype-form
 264                        (eval prototype-form)
 265                        ;; This is the default prototype value which
 266                        ;; was used, without explanation, by the CMU CL
 267                        ;; code we're derived from. Evidently it's safe
 268                        ;; in all relevant cases.
 269                        42))))
 270             (remove-if (lambda (kernel-bic-entry)
 271                          (member (first kernel-bic-entry)
 272                                  ;; I'm not sure why these are removed from
 273                                  ;; the list, but that's what the original
 274                                  ;; CMU CL code did. -- WHN 20000715
 275                                  '(t function stream
 276                                      file-stream string-stream)))
 277                        sb-kernel::*built-in-classes*))))
 278 (/noshow "done setting up SB-PCL::*BUILT-IN-CLASSES*")
 279 \f
 280 ;;;; the classes that define the kernel of the metabraid
 281
 282 (defclass t () ()
 283   (:metaclass built-in-class))
 284
 285 (defclass function (t) ()
 286   (:metaclass built-in-class))
 287
 288 (defclass stream (t) ()
 289   (:metaclass built-in-class))
 290
 291 (defclass file-stream (stream) ()
 292   (:metaclass built-in-class))
 293
 294 (defclass string-stream (stream) ()
 295   (:metaclass built-in-class))
 296
 297 (defclass slot-object (t) ()
 298   (:metaclass slot-class))
 299
 300 (defclass condition (slot-object) ()
 301   (:metaclass condition-class))
 302
 303 (defclass structure-object (slot-object) ()
 304   (:metaclass structure-class))
 305
 306 (defstruct (dead-beef-structure-object
 307             (:constructor |STRUCTURE-OBJECT class constructor|)
 308             (:copier nil)))
 309
 310 (defclass standard-object (slot-object) ())
 311
 312 (defclass funcallable-standard-object (standard-object function)
 313   ()
 314   (:metaclass funcallable-standard-class))
 315
 316 (defclass metaobject (standard-object) ())
 317
 318 (defclass generic-function (dependent-update-mixin
 319                             definition-source-mixin
 320                             metaobject
 321                             funcallable-standard-object)
 322   ((documentation
 323     :initform nil
 324     :initarg :documentation)
 325    ;; We need to make a distinction between the methods initially set
 326    ;; up by :METHOD options to DEFGENERIC and the ones set up later by
 327    ;; DEFMETHOD, because ANSI specifies that executing DEFGENERIC on
 328    ;; an already-DEFGENERICed function clears the methods set by the
 329    ;; previous DEFGENERIC, but not methods set by DEFMETHOD. (Making
 330    ;; this distinction seems a little kludgy, but it has the positive
 331    ;; effect of making it so that loading a file a.lisp containing
 332    ;; DEFGENERIC, then loading a second file b.lisp containing
 333    ;; DEFMETHOD, then modifying and reloading a.lisp and/or b.lisp
 334    ;; tends to leave the generic function in a state consistent with
 335    ;; the most-recently-loaded state of a.lisp and b.lisp.)
 336    (initial-methods
 337     :initform ()
 338     :accessor generic-function-initial-methods))
 339   (:metaclass funcallable-standard-class))
 340
 341 (defclass standard-generic-function (generic-function)
 342   ((name
 343     :initform nil
 344     :initarg :name
 345     :reader generic-function-name)
 346    (methods
 347     :initform ()
 348     :accessor generic-function-methods
 349     :type list)
 350    (method-class
 351     :initarg :method-class
 352     :accessor generic-function-method-class)
 353    (method-combination
 354     :initarg :method-combination
 355     :accessor generic-function-method-combination)
 356    (declarations
 357     ;; KLUDGE: AMOP specifies :DECLARATIONS, while ANSI specifies
 358     ;; :DECLARE.  Allow either (but FIXME: maybe a note or a warning
 359     ;; might be appropriate).
 360     :initarg :declarations
 361     :initarg :declare
 362     :initform ()
 363     :accessor generic-function-declarations)
 364    (arg-info
 365     :initform (make-arg-info)
 366     :reader gf-arg-info)
 367    (dfun-state
 368     :initform ()
 369     :accessor gf-dfun-state))
 370   (:metaclass funcallable-standard-class)
 371   (:default-initargs :method-class *the-class-standard-method*
 372                      :method-combination *standard-method-combination*))
 373
 374 (defclass method (metaobject) ())
 375
 376 (defclass standard-method (definition-source-mixin plist-mixin method)
 377   ((generic-function
 378     :initform nil
 379     :accessor method-generic-function)
 380 ;;;     (qualifiers
 381 ;;;     :initform ()
 382 ;;;     :initarg  :qualifiers
 383 ;;;     :reader method-qualifiers)
 384    (specializers
 385     :initform ()
 386     :initarg  :specializers
 387     :reader method-specializers)
 388    (lambda-list
 389     :initform ()
 390     :initarg  :lambda-list
 391     :reader method-lambda-list)
 392    (function
 393     :initform nil
 394     :initarg :function)                 ;no writer
 395    (fast-function
 396     :initform nil
 397     :initarg :fast-function             ;no writer
 398     :reader method-fast-function)
 399    (documentation
 400     :initform nil
 401     :initarg :documentation)))
 402
 403 (defclass standard-accessor-method (standard-method)
 404   ((slot-name :initform nil
 405               :initarg :slot-name
 406               :reader accessor-method-slot-name)
 407    (slot-definition :initform nil
 408                     :initarg :slot-definition
 409                     :reader accessor-method-slot-definition)))
 410
 411 (defclass standard-reader-method (standard-accessor-method) ())
 412 (defclass standard-writer-method (standard-accessor-method) ())
 413 ;;; an extension, apparently.
 414 (defclass standard-boundp-method (standard-accessor-method) ())
 415
 416 (defclass method-combination (metaobject)
 417   ((documentation
 418     :reader method-combination-documentation
 419     :initform nil
 420     :initarg :documentation)))
 421
 422 (defclass standard-method-combination (definition-source-mixin
 423                                        method-combination)
 424   ((type
 425     :reader method-combination-type
 426     :initarg :type)
 427    (options
 428     :reader method-combination-options
 429     :initarg :options)))
 430
 431 (defclass long-method-combination (standard-method-combination)
 432   ((function
 433     :initarg :function
 434     :reader long-method-combination-function)
 435    (args-lambda-list
 436     :initarg :args-lambda-list
 437     :reader long-method-combination-args-lambda-list)))
 438
 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    (readers
 453     :initform nil
 454     :initarg :readers
 455     :accessor slot-definition-readers)
 456    (writers
 457     :initform nil
 458     :initarg :writers
 459     :accessor slot-definition-writers)
 460    (initargs
 461     :initform nil
 462     :initarg :initargs
 463     :accessor slot-definition-initargs)
 464    (type
 465     :initform t
 466     :initarg :type
 467     :accessor slot-definition-type)
 468    (documentation
 469     :initform nil
 470     :initarg :documentation)
 471    (class
 472     :initform nil
 473     :initarg :class
 474     :accessor slot-definition-class)))
 475
 476 (defclass standard-slot-definition (slot-definition)
 477   ((allocation
 478     :initform :instance
 479     :initarg :allocation
 480     :accessor slot-definition-allocation)
 481    (allocation-class
 482     :initform nil
 483     :initarg :allocation-class
 484     :accessor slot-definition-allocation-class)))
 485
 486 (defclass condition-slot-definition (slot-definition)
 487   ((allocation
 488     :initform :instance
 489     :initarg :allocation
 490     :accessor slot-definition-allocation)
 491    (allocation-class
 492     :initform nil
 493     :initarg :allocation-class
 494     :accessor slot-definition-allocation-class)))
 495
 496 (defclass structure-slot-definition (slot-definition)
 497   ((defstruct-accessor-symbol
 498      :initform nil
 499      :initarg :defstruct-accessor-symbol
 500      :accessor slot-definition-defstruct-accessor-symbol)
 501    (internal-reader-function
 502      :initform nil
 503      :initarg :internal-reader-function
 504      :accessor slot-definition-internal-reader-function)
 505    (internal-writer-function
 506      :initform nil
 507      :initarg :internal-writer-function
 508      :accessor slot-definition-internal-writer-function)))
 509
 510 (defclass direct-slot-definition (slot-definition)
 511   ())
 512
 513 (defclass effective-slot-definition (slot-definition)
 514   ((reader-function ; (lambda (object) ...)
 515     :accessor slot-definition-reader-function)
 516    (writer-function ; (lambda (new-value object) ...)
 517     :accessor slot-definition-writer-function)
 518    (boundp-function ; (lambda (object) ...)
 519     :accessor slot-definition-boundp-function)
 520    (accessor-flags
 521     :initform 0)))
 522
 523 (defclass standard-direct-slot-definition (standard-slot-definition
 524                                            direct-slot-definition)
 525   ())
 526
 527 (defclass standard-effective-slot-definition (standard-slot-definition
 528                                               effective-slot-definition)
 529   ((location ; nil, a fixnum, a cons: (slot-name . value)
 530     :initform nil
 531     :accessor slot-definition-location)))
 532
 533 (defclass condition-direct-slot-definition (condition-slot-definition
 534                                             direct-slot-definition)
 535   ())
 536
 537 (defclass condition-effective-slot-definition (condition-slot-definition
 538                                                effective-slot-definition)
 539   ())
 540
 541 (defclass structure-direct-slot-definition (structure-slot-definition
 542                                             direct-slot-definition)
 543   ())
 544
 545 (defclass structure-effective-slot-definition (structure-slot-definition
 546                                                effective-slot-definition)
 547   ())
 548
 549 (defclass specializer (metaobject)
 550   ((type :initform nil :reader specializer-type)))
 551
 552 (defclass specializer-with-object (specializer) ())
 553
 554 (defclass exact-class-specializer (specializer) ())
 555
 556 (defclass class-eq-specializer (exact-class-specializer
 557                                 specializer-with-object)
 558   ((object :initarg :class
 559            :reader specializer-class
 560            :reader specializer-object)))
 561
 562 (defclass class-prototype-specializer (specializer-with-object)
 563   ((object :initarg :class
 564            :reader specializer-class
 565            :reader specializer-object)))
 566
 567 (defclass eql-specializer (exact-class-specializer specializer-with-object)
 568   ((object :initarg :object :reader specializer-object
 569            :reader eql-specializer-object)))
 570
 571 (defvar *eql-specializer-table* (make-hash-table :test 'eql))
 572
 573 (defun intern-eql-specializer (object)
 574   (or (gethash object *eql-specializer-table*)
 575       (setf (gethash object *eql-specializer-table*)
 576             (make-instance 'eql-specializer :object object))))
 577
 578 (defclass class (dependent-update-mixin
 579                  definition-source-mixin
 580                  specializer)
 581   ((name
 582     :initform nil
 583     :initarg :name
 584     :reader class-name)
 585    (class-eq-specializer
 586     :initform nil
 587     :reader class-eq-specializer)
 588    (direct-superclasses
 589     :initform ()
 590     :reader class-direct-superclasses)
 591    ;; Note: The (CLASS-)DIRECT-SUBCLASSES for STRUCTURE-CLASSes and
 592    ;; CONDITION-CLASSes are lazily computed whenever the subclass info
 593    ;; becomes available, i.e. when the PCL class is created.
 594    (direct-subclasses
 595     :initform ()
 596     :reader class-direct-subclasses)
 597    (direct-methods
 598     :initform (cons nil nil))
 599    (predicate-name
 600     :initform nil
 601     :reader class-predicate-name)
 602    (documentation
 603     :initform nil
 604     :initarg :documentation)
 605    (finalized-p
 606     :initform nil
 607     :reader class-finalized-p)))
 608
 609 (def!method make-load-form ((class class) &optional env)
 610   ;; FIXME: should we not instead pass ENV to FIND-CLASS?  Probably
 611   ;; doesn't matter while all our environments are the same...
 612   (declare (ignore env))
 613   (let ((name (class-name class)))
 614     (unless (and name (eq (find-class name nil) class))
 615       (error "~@<Can't use anonymous or undefined class as constant: ~S~:@>"
 616              class))
 617     `(find-class ',name)))
 618
 619 ;;; The class PCL-CLASS is an implementation-specific common
 620 ;;; superclass of all specified subclasses of the class CLASS.
 621 (defclass pcl-class (class)
 622   ((class-precedence-list
 623     :reader class-precedence-list)
 624    ;; KLUDGE: see note in CPL-OR-NIL
 625    (cpl-available-p
 626     :reader cpl-available-p
 627     :initform nil)
 628    (can-precede-list
 629     :initform ()
 630     :reader class-can-precede-list)
 631    (incompatible-superclass-list
 632     :initform ()
 633     :accessor class-incompatible-superclass-list)
 634    (wrapper
 635     :initform nil
 636     :reader class-wrapper)
 637    (prototype
 638     :initform nil
 639     :reader class-prototype)))
 640
 641 (defclass slot-class (pcl-class)
 642   ((direct-slots
 643     :initform ()
 644     :accessor class-direct-slots)
 645    (slots
 646     :initform ()
 647     :accessor class-slots)))
 648
 649 ;;; The class STD-CLASS is an implementation-specific common
 650 ;;; superclass of the classes STANDARD-CLASS and
 651 ;;; FUNCALLABLE-STANDARD-CLASS.
 652 (defclass std-class (slot-class)
 653   ())
 654
 655 (defclass standard-class (std-class)
 656   ())
 657
 658 (defclass funcallable-standard-class (std-class)
 659   ())
 660
 661 (defclass forward-referenced-class (pcl-class) ())
 662
 663 (defclass built-in-class (pcl-class) ())
 664
 665 (defclass condition-class (slot-class) ())
 666
 667 (defclass structure-class (slot-class)
 668   ((defstruct-form
 669      :initform ()
 670      :accessor class-defstruct-form)
 671    (defstruct-constructor
 672      :initform nil
 673      :accessor class-defstruct-constructor)
 674    (from-defclass-p
 675     :initform nil
 676     :initarg :from-defclass-p)))
 677
 678 (defclass definition-source-mixin (standard-object)
 679   ((source :initform *load-pathname* :reader definition-source
 680            :initarg :definition-source)))
 681
 682 (defclass plist-mixin (standard-object)
 683   ((plist :initform () :accessor object-plist)))
 684
 685 (defclass dependent-update-mixin (plist-mixin) ())
 686
 687 (defparameter *early-class-predicates*
 688   '((specializer specializerp)
 689     (exact-class-specializer exact-class-specializer-p)
 690     (class-eq-specializer class-eq-specializer-p)
 691     (eql-specializer eql-specializer-p)
 692     (class classp)
 693     (slot-class slot-class-p)
 694     (std-class std-class-p)
 695     (standard-class standard-class-p)
 696     (funcallable-standard-class funcallable-standard-class-p)
 697     (condition-class condition-class-p)
 698     (structure-class structure-class-p)
 699     (forward-referenced-class forward-referenced-class-p)
 700     (method method-p)
 701     (standard-method standard-method-p)
 702     (standard-accessor-method standard-accessor-method-p)
 703     (standard-reader-method standard-reader-method-p)
 704     (standard-writer-method standard-writer-method-p)
 705     (standard-boundp-method standard-boundp-method-p)
 706     (generic-function generic-function-p)
 707     (standard-generic-function standard-generic-function-p)
 708     (method-combination method-combination-p)
 709     (long-method-combination long-method-combination-p)))
 710