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   ;; Avoid style-warning about compiler-macro being unavailable.
  66   (declare (notinline make-instance))
  67   (when (symbolp type)
  68     (return-from specializer-from-type (find-class type)))
  69   (when (consp type)
  70     (setq args (cdr type) type (car type)))
  71   (cond ((symbolp type)
  72          (or (ecase type
  73                (class    (coerce-to-class (car args)))
  74                (prototype (make-instance 'class-prototype-specializer
  75                                          :object (coerce-to-class (car args))))
  76                (class-eq (class-eq-specializer (coerce-to-class (car args))))
  77                (eql      (intern-eql-specializer (car args))))))
  78         ;; FIXME: do we still need this?
  79         ((and (null args) (typep type 'classoid))
  80          (or (classoid-pcl-class type)
  81              (ensure-non-standard-class (classoid-name type) type)))
  82         ((specializerp type) type)))
  83
  84 ;;; interface
  85 (defun type-from-specializer (specl)
  86   (cond ((eq specl t)
  87          t)
  88         ((consp specl)
  89          (unless (member (car specl) '(class prototype class-eq eql))
  90            (error "~S is not a legal specializer type." specl))
  91          specl)
  92         ((progn
  93            (when (symbolp specl)
  94              ;;maybe (or (find-class specl nil) (ensure-class specl)) instead?
  95              (setq specl (find-class specl)))
  96            (or (not (eq **boot-state** 'complete))
  97                (specializerp specl)))
  98          (specializer-type specl))
  99         (t
 100          (error "~S is neither a type nor a specializer." specl))))
 101
 102 (defun type-class (type)
 103   (declare (special *the-class-t*))
 104   (setq type (type-from-specializer type))
 105   (if (atom type)
 106       (if (eq type t)
 107           *the-class-t*
 108           (error "bad argument to TYPE-CLASS"))
 109       (case (car type)
 110         (eql (class-of (cadr type)))
 111         (prototype (class-of (cadr type))) ;?
 112         (class-eq (cadr type))
 113         (class (cadr type)))))
 114
 115 (defun class-eq-type (class)
 116   (specializer-type (class-eq-specializer class)))
 117
 118 ;;; internal to this file..
 119 ;;;
 120 ;;; These functions are a pale imitation of their namesake. They accept
 121 ;;; class objects or types where they should.
 122 (defun *normalize-type (type)
 123   (cond ((consp type)
 124          (if (member (car type) '(not and or))
 125              `(,(car type) ,@(mapcar #'*normalize-type (cdr type)))
 126              (if (null (cdr type))
 127                  (*normalize-type (car type))
 128                  type)))
 129         ((symbolp type)
 130          (let ((class (find-class type nil)))
 131            (if class
 132                (let ((type (specializer-type class)))
 133                  (ensure-list type))
 134                `(,type))))
 135         ((or (not (eq **boot-state** 'complete))
 136              (specializerp type))
 137          (specializer-type type))
 138         (t
 139          (error "~S is not a type." type))))
 140
 141 ;;; internal to this file...
 142 (defun convert-to-system-type (type)
 143   (case (car type)
 144     ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
 145                                           (cdr type))))
 146     ((class class-eq) ; class-eq is impossible to do right
 147      (layout-classoid (class-wrapper (cadr type))))
 148     (eql type)
 149     (t (if (null (cdr type))
 150            (car type)
 151            type))))
 152
 153 ;;; Writing the missing NOT and AND clauses will improve the quality
 154 ;;; of code generated by GENERATE-DISCRIMINATION-NET, but calling
 155 ;;; SUBTYPEP in place of just returning (VALUES NIL NIL) can be very
 156 ;;; slow. *SUBTYPEP is used by PCL itself, and must be fast.
 157 ;;;
 158 ;;; FIXME: SB-KERNEL has fast-and-not-quite-precise type code for use
 159 ;;; in the compiler. Could we share some of it here?
 160 (defvar *in-*subtypep* nil)
 161
 162 (defun *subtypep (type1 type2)
 163   (if (equal type1 type2)
 164       (values t t)
 165       (if (eq **boot-state** 'early)
 166           (values (eq type1 type2) t)
 167           (let ((*in-*subtypep* t))
 168             (setq type1 (*normalize-type type1))
 169             (setq type2 (*normalize-type type2))
 170             (case (car type2)
 171               (not
 172                (values nil nil)) ; XXX We should improve this.
 173               (and
 174                (values nil nil)) ; XXX We should improve this.
 175               ((eql wrapper-eq class-eq class)
 176                (multiple-value-bind (app-p maybe-app-p)
 177                    (specializer-applicable-using-type-p type2 type1)
 178                  (values app-p (or app-p (not maybe-app-p)))))
 179               (t
 180                (subtypep (convert-to-system-type type1)
 181                          (convert-to-system-type type2))))))))
 182 \f
 183 (defvar *built-in-class-symbols* ())
 184 (defvar *built-in-wrapper-symbols* ())
 185
 186 (defun get-built-in-class-symbol (class-name)
 187   (or (cadr (assq class-name *built-in-class-symbols*))
 188       (let ((symbol (make-class-symbol class-name)))
 189         (push (list class-name symbol) *built-in-class-symbols*)
 190         symbol)))
 191 \f
 192 (defvar *standard-method-combination*)
 193 \f
 194 (defun plist-value (object name)
 195   (getf (object-plist object) name))
 196
 197 (defun (setf plist-value) (new-value object name)
 198   (if new-value
 199       (setf (getf (object-plist object) name) new-value)
 200       (progn
 201         (remf (object-plist object) name)
 202         nil)))
 203 \f
 204 ;;;; built-in classes
 205
 206 ;;; Grovel over SB-KERNEL::*!BUILT-IN-CLASSES* in order to set
 207 ;;; SB-PCL:*BUILT-IN-CLASSES*.
 208 (/show "about to set up SB-PCL::*BUILT-IN-CLASSES*")
 209 (defvar *built-in-classes*
 210   (labels ((direct-supers (class)
 211              (/noshow "entering DIRECT-SUPERS" (classoid-name class))
 212              (if (typep class 'built-in-classoid)
 213                  (built-in-classoid-direct-superclasses class)
 214                  (let ((inherits (layout-inherits
 215                                   (classoid-layout class))))
 216                    (/noshow inherits)
 217                    (list (svref inherits (1- (length inherits)))))))
 218            (direct-subs (class)
 219              (/noshow "entering DIRECT-SUBS" (classoid-name class))
 220              (collect ((res))
 221                (let ((subs (classoid-subclasses class)))
 222                  (/noshow subs)
 223                  (when subs
 224                    (dohash ((sub v) subs)
 225                      (declare (ignore v))
 226                      (/noshow sub)
 227                      (when (member class (direct-supers sub) :test #'eq)
 228                        (res sub)))))
 229                (res))))
 230     (mapcar (lambda (kernel-bic-entry)
 231               (/noshow "setting up" kernel-bic-entry)
 232               (let* ((name (car kernel-bic-entry))
 233                      (class (find-classoid name))
 234                      (prototype-form
 235                       (getf (cdr kernel-bic-entry) :prototype-form)))
 236                 (/noshow name class)
 237                 `(,name
 238                   ,(mapcar #'classoid-name (direct-supers class))
 239                   ,(mapcar #'classoid-name (direct-subs class))
 240                   ,(map 'list
 241                         (lambda (x)
 242                           (classoid-name
 243                            (layout-classoid x)))
 244                         (reverse
 245                          (layout-inherits
 246                           (classoid-layout class))))
 247                   ,(if prototype-form
 248                        (eval prototype-form)
 249                        ;; This is the default prototype value which
 250                        ;; was used, without explanation, by the CMU CL
 251                        ;; code we're derived from. Evidently it's safe
 252                        ;; in all relevant cases.
 253                        42))))
 254             (remove-if (lambda (kernel-bic-entry)
 255                          (member (first kernel-bic-entry)
 256                                  ;; remove special classes (T and our
 257                                  ;; SYSTEM-CLASSes) from the
 258                                  ;; BUILT-IN-CLASS list
 259                                  '(t function stream sequence
 260                                      file-stream string-stream)))
 261                        sb-kernel::*!built-in-classes*))))
 262 (/noshow "done setting up SB-PCL::*BUILT-IN-CLASSES*")
 263 \f
 264 ;;;; the classes that define the kernel of the metabraid
 265
 266 (defclass t () ()
 267   ;; AMOP specifies that the class named T should be an instance of
 268   ;; BUILT-IN-CLASS, but this conflicts with other specifications in
 269   ;; AMOP and CLHS.
 270   (:metaclass system-class))
 271
 272 (defclass function (t) ()
 273   (:metaclass system-class))
 274
 275 (defclass stream (t) ()
 276   (:metaclass system-class))
 277
 278 (defclass file-stream (stream) ()
 279   (:metaclass system-class))
 280
 281 (defclass string-stream (stream) ()
 282   (:metaclass system-class))
 283
 284 (defclass sequence (t) ()
 285   (:metaclass system-class))
 286
 287 (defclass slot-object (t) ()
 288   (:metaclass slot-class))
 289
 290 (defclass condition (slot-object) ()
 291   (:metaclass condition-class))
 292
 293 (defclass structure-object (slot-object) ()
 294   (:metaclass structure-class))
 295
 296 (defstruct (dead-beef-structure-object
 297             (:constructor |STRUCTURE-OBJECT class constructor|)
 298             (:copier nil)))
 299
 300 (defclass standard-object (slot-object) ())
 301
 302 (defclass funcallable-standard-object (function standard-object)
 303   ()
 304   (:metaclass funcallable-standard-class))
 305
 306 (defclass metaobject (standard-object) ())
 307
 308 (defclass generic-function (dependent-update-mixin
 309                             definition-source-mixin
 310                             metaobject
 311                             funcallable-standard-object)
 312   ((%documentation :initform nil :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 :initform () :accessor generic-function-initial-methods)
 325    (encapsulations :initform () :accessor generic-function-encapsulations))
 326   (:metaclass funcallable-standard-class))
 327
 328 (defclass standard-generic-function (generic-function)
 329   ((name
 330     :initform nil
 331     :initarg :name
 332     :reader generic-function-name)
 333    (methods
 334     :initform ()
 335     :accessor generic-function-methods
 336     :type list)
 337    (method-class
 338     :initarg :method-class
 339     :accessor generic-function-method-class)
 340    (%method-combination
 341     :initarg :method-combination
 342     :accessor generic-function-method-combination)
 343    (declarations
 344     ;; KLUDGE: AMOP specifies :DECLARATIONS, while ANSI specifies
 345     ;; :DECLARE.  Allow either (but FIXME: maybe a note or a warning
 346     ;; might be appropriate).
 347     :initarg :declarations
 348     :initarg :declare
 349     :initform ()
 350     :accessor generic-function-declarations)
 351    (arg-info
 352     :initform (make-arg-info)
 353     :reader gf-arg-info)
 354    (dfun-state
 355     :initform ()
 356     :accessor gf-dfun-state)
 357    ;; Used to make DFUN-STATE & FIN-FUNCTION updates atomic.
 358    (%lock
 359     :initform (sb-thread:make-mutex :name "GF lock")
 360     :reader gf-lock))
 361   (:metaclass funcallable-standard-class)
 362   (:default-initargs :method-class *the-class-standard-method*
 363                      :method-combination *standard-method-combination*))
 364
 365 (defclass method (metaobject) ())
 366
 367 (defclass standard-method (plist-mixin definition-source-mixin method)
 368   ((%generic-function :initform nil :accessor method-generic-function)
 369    (qualifiers :initform () :initarg :qualifiers :reader method-qualifiers)
 370    (specializers :initform () :initarg :specializers
 371                  :reader method-specializers)
 372    (lambda-list :initform () :initarg :lambda-list :reader method-lambda-list)
 373    (%function :initform nil :initarg :function :reader method-function)
 374    (%documentation :initform nil :initarg :documentation)
 375    ;; True IFF method is known to have no CALL-NEXT-METHOD in it, or
 376    ;; just a plain (CALL-NEXT-METHOD).
 377    (simple-next-method-call
 378     :initform nil
 379     :initarg simple-next-method-call
 380     :reader simple-next-method-call-p)))
 381
 382 (defclass accessor-method (standard-method)
 383   ((slot-name :initform nil :initarg :slot-name
 384               :reader accessor-method-slot-name)))
 385
 386 (defclass standard-accessor-method (accessor-method)
 387   ((%slot-definition :initform nil :initarg :slot-definition
 388                      :reader accessor-method-slot-definition)))
 389
 390 (defclass standard-reader-method (standard-accessor-method) ())
 391 (defclass standard-writer-method (standard-accessor-method) ())
 392 ;;; an extension, apparently.
 393 (defclass standard-boundp-method (standard-accessor-method) ())
 394
 395 ;;; for (SLOT-VALUE X 'FOO) / ACCESSOR-SLOT-VALUE optimization, which
 396 ;;; can't be STANDARD-READER-METHOD because there is no associated
 397 ;;; slot definition.
 398 (defclass global-reader-method (accessor-method) ())
 399 (defclass global-writer-method (accessor-method) ())
 400 (defclass global-boundp-method (accessor-method) ())
 401
 402 (defclass method-combination (metaobject)
 403   ((%documentation :initform nil :initarg :documentation)))
 404
 405 (defclass standard-method-combination (definition-source-mixin
 406                                        method-combination)
 407   ((type-name
 408     :reader method-combination-type-name
 409     :initarg :type-name)
 410    (options
 411     :reader method-combination-options
 412     :initarg :options)))
 413
 414 (defclass long-method-combination (standard-method-combination)
 415   ((function
 416     :initarg :function
 417     :reader long-method-combination-function)
 418    (args-lambda-list
 419     :initarg :args-lambda-list
 420     :reader long-method-combination-args-lambda-list)))
 421
 422 (defclass short-method-combination (standard-method-combination)
 423   ((operator
 424     :reader short-combination-operator
 425     :initarg :operator)
 426    (identity-with-one-argument
 427     :reader short-combination-identity-with-one-argument
 428     :initarg :identity-with-one-argument)))
 429
 430 (defclass slot-definition (metaobject)
 431   ((name
 432     :initform nil
 433     :initarg :name
 434     :accessor slot-definition-name)
 435    (initform
 436     :initform nil
 437     :initarg :initform
 438     :accessor slot-definition-initform)
 439    (initfunction
 440     :initform nil
 441     :initarg :initfunction
 442     :accessor slot-definition-initfunction)
 443    (initargs
 444     :initform nil
 445     :initarg :initargs
 446     :accessor slot-definition-initargs)
 447    (%type :initform t :initarg :type :accessor slot-definition-type)
 448    (%documentation
 449     :initform nil :initarg :documentation
 450     ;; KLUDGE: we need a reader for bootstrapping purposes, in
 451     ;; COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS.
 452     :reader %slot-definition-documentation)
 453    (%class :initform nil :initarg :class :accessor slot-definition-class)
 454    (source :initform nil :initarg source :accessor definition-source)))
 455
 456 (defclass standard-slot-definition (slot-definition)
 457   ((allocation
 458     :initform :instance
 459     :initarg :allocation
 460     :accessor slot-definition-allocation)
 461    (allocation-class
 462     :initform nil
 463     :initarg :allocation-class
 464     :accessor slot-definition-allocation-class)))
 465
 466 (defclass condition-slot-definition (slot-definition)
 467   ((allocation
 468     :initform :instance
 469     :initarg :allocation
 470     :accessor slot-definition-allocation)
 471    (allocation-class
 472     :initform nil
 473     :initarg :allocation-class
 474     :accessor slot-definition-allocation-class)))
 475
 476 (defclass structure-slot-definition (slot-definition)
 477   ((defstruct-accessor-symbol
 478      :initform nil
 479      :initarg :defstruct-accessor-symbol
 480      :accessor slot-definition-defstruct-accessor-symbol)
 481    (internal-reader-function
 482      :initform nil
 483      :initarg :internal-reader-function
 484      :accessor slot-definition-internal-reader-function)
 485    (internal-writer-function
 486      :initform nil
 487      :initarg :internal-writer-function
 488      :accessor slot-definition-internal-writer-function)))
 489
 490 (defclass direct-slot-definition (slot-definition)
 491   ((readers
 492     :initform nil
 493     :initarg :readers
 494     :accessor slot-definition-readers)
 495    (writers
 496     :initform nil
 497     :initarg :writers
 498     :accessor slot-definition-writers)))
 499
 500 (defclass effective-slot-definition (slot-definition)
 501   ((accessor-flags
 502     :initform 0)
 503    (info
 504     :accessor slot-definition-info)))
 505
 506 ;;; We use a structure here, because fast slot-accesses to this information
 507 ;;; are critical to making SLOT-VALUE-USING-CLASS &co fast: places that need
 508 ;;; these functions can access the SLOT-INFO directly, avoiding the overhead
 509 ;;; of accessing a standard-instance.
 510 (defstruct (slot-info
 511             (:constructor make-slot-info
 512                 (&key slotd typecheck
 513                  (reader (uninitialized-accessor-function :reader slotd))
 514                  (writer (uninitialized-accessor-function :writer slotd))
 515                  (boundp (uninitialized-accessor-function :boundp slotd)))))
 516   (typecheck nil :type (or null function))
 517   (reader (missing-arg) :type function)
 518   (writer (missing-arg) :type function)
 519   (boundp (missing-arg) :type function))
 520
 521 (defclass standard-direct-slot-definition (standard-slot-definition
 522                                            direct-slot-definition)
 523   ())
 524
 525 (defclass standard-effective-slot-definition (standard-slot-definition
 526                                               effective-slot-definition)
 527   ((location ; nil, a fixnum, a cons: (slot-name . value)
 528     :initform nil
 529     :accessor slot-definition-location)))
 530
 531 (defclass condition-direct-slot-definition (condition-slot-definition
 532                                             direct-slot-definition)
 533   ())
 534
 535 (defclass condition-effective-slot-definition (condition-slot-definition
 536                                                effective-slot-definition)
 537   ())
 538
 539 (defclass structure-direct-slot-definition (structure-slot-definition
 540                                             direct-slot-definition)
 541   ())
 542
 543 (defclass structure-effective-slot-definition (structure-slot-definition
 544                                                effective-slot-definition)
 545   ())
 546
 547 (defclass specializer (metaobject)
 548   ;; KLUDGE: in sbcl-0.9.10.2 this was renamed from TYPE, which was an
 549   ;; external symbol of the CL package and hence potentially collides
 550   ;; with user code.  Renaming this to %TYPE, however, is the coward's
 551   ;; way out, because the objects that PCL puts in this slot aren't
 552   ;; (quite) types: they are closer to kinds of specializer.  However,
 553   ;; the wholesale renaming and disentangling of specializers didn't
 554   ;; appeal.  (See also message <sqd5hrclb2.fsf@cam.ac.uk> and
 555   ;; responses in comp.lang.lisp).  -- CSR, 2006-02-27
 556   ((%type :initform nil :reader specializer-type)))
 557
 558 ;;; STANDARD in this name doesn't mean "blessed by a standard" but
 559 ;;; "comes as standard with PCL"; that is, it includes CLASS-EQ
 560 ;;; and vestiges of PROTOTYPE specializers
 561 (defclass standard-specializer (specializer) ())
 562
 563 (defclass specializer-with-object (specializer) ())
 564
 565 (defclass exact-class-specializer (specializer) ())
 566
 567 (defclass class-eq-specializer (standard-specializer
 568                                 exact-class-specializer
 569                                 specializer-with-object)
 570   ((object :initarg :class
 571            :reader specializer-class
 572            :reader specializer-object)))
 573
 574 (defclass class-prototype-specializer (standard-specializer specializer-with-object)
 575   ((object :initarg :class
 576            :reader specializer-class
 577            :reader specializer-object)))
 578
 579 (defclass eql-specializer (standard-specializer exact-class-specializer specializer-with-object)
 580   ((object :initarg :object :reader specializer-object
 581            :reader eql-specializer-object)
 582    ;; Because EQL specializers are interned, any two putative instances
 583    ;; of EQL-specializer referring to the same object are in fact EQ to
 584    ;; each other. Therefore a list of direct methods in the specializer can
 585    ;; reliably track all methods that are specialized on the identical object.
 586    (direct-methods :initform (cons nil nil))))
 587
 588 ;; Why is this weak-value, not weak-key: suppose the value is unreachable (dead)
 589 ;; but the key is reachable - this should allow dropping the entry, because
 590 ;; you're indifferent to getting a fresh EQL specializer if you re-intern the
 591 ;; same key. There's no way to know that you got a new VALUE, since the
 592 ;; pre-condition of this case was that the old value was unreachable.
 593 ;; KEY weakness is actually equivalent to KEY-OR-VALUE weakness, which would
 594 ;; be less likely to drop the entry. The equivalence stems from the fact that
 595 ;; holding the value (the specializer) also holds the key.
 596 ;; Whereas, with :VALUE weakness, you can drop the specializer as soon as
 597 ;; nothing needs it, even if OBJECT persists. You might think that calling
 598 ;; gethash on a live key should get the identical specializer, but since
 599 ;; nothing referenced the old specializer, consing a new one is fine.
 600 (defglobal *eql-specializer-table*
 601   (make-hash-table :test 'eql :weakness :value))
 602
 603 (defun intern-eql-specializer (object)
 604   ;; Avoid style-warning about compiler-macro being unavailable.
 605   (declare (notinline make-instance))
 606   ;; Need to lock, so that two threads don't get non-EQ specializers
 607   ;; for an EQL object.
 608   (with-locked-system-table (*eql-specializer-table*)
 609     (or (gethash object *eql-specializer-table*)
 610         (setf (gethash object *eql-specializer-table*)
 611               (make-instance 'eql-specializer :object object)))))
 612
 613 (defclass class (dependent-update-mixin
 614                  definition-source-mixin
 615                  standard-specializer)
 616   ((name
 617     :initform nil
 618     :initarg :name
 619     :reader class-name)
 620    (class-eq-specializer
 621     :initform nil
 622     :reader class-eq-specializer)
 623    (direct-superclasses
 624     :initform ()
 625     :reader class-direct-superclasses)
 626    ;; Note: The (CLASS-)DIRECT-SUBCLASSES for STRUCTURE-CLASSes and
 627    ;; CONDITION-CLASSes are lazily computed whenever the subclass info
 628    ;; becomes available, i.e. when the PCL class is created.
 629    (direct-subclasses
 630     :initform ()
 631     :reader class-direct-subclasses)
 632    (direct-methods
 633     :initform (cons nil nil))
 634    (%documentation
 635     :initform nil
 636     :initarg :documentation)
 637    ;; True if the class definition was compiled with a (SAFETY 3)
 638    ;; optimization policy.
 639    (safe-p
 640     :initform nil
 641     :initarg safe-p
 642     :accessor safe-p)
 643    (finalized-p
 644     :initform nil
 645     :reader class-finalized-p)))
 646
 647 (def!method make-load-form ((class class) &optional env)
 648   ;; FIXME: should we not instead pass ENV to FIND-CLASS?  Probably
 649   ;; doesn't matter while all our environments are the same...
 650   (declare (ignore env))
 651   (let ((name (class-name class)))
 652     (unless (and name (eq (find-class name nil) class))
 653       (error "~@<Can't use anonymous or undefined class as constant: ~S~:@>"
 654              class))
 655     ;; Essentially we want `(FIND-CLASS ',NAME) but without using backquote.
 656     ;; Because this is a delayed DEF!METHOD, its entire body is quoted structure
 657     ;; and can't contain a comma object until a MAKE-LOAD-FORM exists for that.
 658     (list 'find-class (list 'quote name))))
 659
 660 ;;; The class PCL-CLASS is an implementation-specific common
 661 ;;; superclass of all specified subclasses of the class CLASS.
 662 (defclass pcl-class (class)
 663   ((%class-precedence-list
 664     :reader class-precedence-list)
 665    ;; KLUDGE: see note in CPL-OR-NIL
 666    (cpl-available-p
 667     :reader cpl-available-p
 668     :initform nil)
 669    (can-precede-list
 670     :initform ()
 671     :reader class-can-precede-list)
 672    (incompatible-superclass-list
 673     :initform ()
 674     :accessor class-incompatible-superclass-list)
 675    (wrapper
 676     :initform nil
 677     :reader class-wrapper)
 678    (prototype
 679     :initform nil
 680     :reader class-prototype)))
 681
 682 (defclass slot-class (pcl-class)
 683   ((direct-slots
 684     :initform ()
 685     :reader class-direct-slots)
 686    (slots
 687     :initform ()
 688     :reader class-slots)))
 689
 690 ;;; The class STD-CLASS is an implementation-specific common
 691 ;;; superclass of the classes STANDARD-CLASS and
 692 ;;; FUNCALLABLE-STANDARD-CLASS.
 693 (defclass std-class (slot-class)
 694   ())
 695
 696 (defclass standard-class (std-class)
 697   ()
 698   (:default-initargs
 699    :direct-superclasses (list *the-class-standard-object*)))
 700
 701 (defclass funcallable-standard-class (std-class)
 702   ()
 703   (:default-initargs
 704    :direct-superclasses (list *the-class-funcallable-standard-object*)))
 705
 706 (defclass forward-referenced-class (pcl-class) ())
 707
 708 (defclass system-class (pcl-class) ())
 709
 710 (defclass built-in-class (system-class) ())
 711
 712 (defclass condition-class (slot-class) ())
 713
 714 (defclass structure-class (slot-class)
 715   ((defstruct-form :initform () :accessor class-defstruct-form)
 716    (defstruct-constructor :initform nil :accessor class-defstruct-constructor)
 717    (from-defclass-p :initform nil :initarg :from-defclass-p)))
 718
 719 (defclass definition-source-mixin (standard-object)
 720   ((source
 721     :initform nil
 722     :reader definition-source
 723     :initarg :definition-source)))
 724
 725 (defclass plist-mixin (standard-object)
 726   ((plist :initform () :accessor object-plist :initarg plist)))
 727
 728 (defclass dependent-update-mixin (plist-mixin) ())