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