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