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