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 ;;; FIXME: This was the portable PCL way of setting up
 306 ;;; *BUILT-IN-CLASSES*, but in SBCL (as in CMU CL) it's almost
 307 ;;; entirely wasted motion, since it's immediately overwritten by a
 308 ;;; result mostly derived from SB-KERNEL::*BUILT-IN-CLASSES*. However,
 309 ;;; we can't just delete it, since the fifth element from each entry
 310 ;;; (a prototype of the class) is still in the final result. It would
 311 ;;; be nice to clean this up so that the other, never-used stuff is
 312 ;;; gone, perhaps finding a tidier way to represent examples of each
 313 ;;; class, too.
 314 ;;;
 315 ;;; FIXME: This can probably be blown away after bootstrapping.
 316 ;;; And SB-KERNEL::*BUILT-IN-CLASSES*, too..
 317 #|
 318 (defvar *built-in-classes*
 319   ;; name       supers     subs              cdr of cpl
 320   ;; prototype
 321   '(;(t  ()      (number sequence array character symbol) ())
 322     (number     (t)     (complex float rational) (t))
 323     (complex    (number)   ()                  (number t)
 324      #c(1 1))
 325     (float      (number)   ()                  (number t)
 326      1.0)
 327     (rational   (number)   (integer ratio)        (number t))
 328     (integer    (rational) ()                  (rational number t)
 329      1)
 330     (ratio      (rational) ()                  (rational number t)
 331      1/2)
 332
 333     (sequence   (t)     (list vector)       (t))
 334     (list       (sequence) (cons null)        (sequence t))
 335     (cons       (list)     ()                  (list sequence t)
 336      (nil))
 337
 338     (array      (t)     (vector)                 (t)
 339      #2A((nil)))
 340     (vector     (array
 341                  sequence) (string bit-vector)      (array sequence t)
 342      #())
 343     (string     (vector)   ()                  (vector array sequence t)
 344      "")
 345     (bit-vector (vector)   ()                  (vector array sequence t)
 346      #*1)
 347     (character  (t)     ()                     (t)
 348      #\c)
 349
 350     (symbol     (t)     (null)             (t)
 351      symbol)
 352     (null       (symbol
 353                  list)     ()                  (symbol list sequence t)
 354      nil)))
 355 |#
 356
 357 ;;; Grovel over SB-KERNEL::*BUILT-IN-CLASSES* in order to set
 358 ;;; SB-PCL:*BUILT-IN-CLASSES*.
 359 (/show "about to set up SB-PCL::*BUILT-IN-CLASSES*")
 360 (defvar *built-in-classes*
 361   (labels ((direct-supers (class)
 362              (/noshow "entering DIRECT-SUPERS" (classoid-name class))
 363              (if (typep class 'built-in-classoid)
 364                  (built-in-classoid-direct-superclasses class)
 365                  (let ((inherits (layout-inherits
 366                                   (classoid-layout class))))
 367                    (/noshow inherits)
 368                    (list (svref inherits (1- (length inherits)))))))
 369            (direct-subs (class)
 370              (/noshow "entering DIRECT-SUBS" (classoid-name class))
 371              (collect ((res))
 372                (let ((subs (classoid-subclasses class)))
 373                  (/noshow subs)
 374                  (when subs
 375                    (dohash (sub v subs)
 376                      (declare (ignore v))
 377                      (/noshow sub)
 378                      (when (member class (direct-supers sub))
 379                        (res sub)))))
 380                (res)))
 381            (prototype (class-name)
 382              (let ((assoc (assoc class-name
 383                                  '((complex    . #c(1 1))
 384                                    (float      . 1.0)
 385                                    (integer    . 1)
 386                                    (ratio      . 1/2)
 387                                    (sequence   . nil)
 388                                    (list       . nil)
 389                                    (cons       . (nil))
 390                                    (array      . #2a((nil)))
 391                                    (vector     . #())
 392                                    (string     . "")
 393                                    (bit-vector . #*1)
 394                                    (character  . #\c)
 395                                    (symbol     . symbol)
 396                                    (null       . nil)))))
 397                (if assoc
 398                    (cdr assoc)
 399                    ;; This is the default prototype value which was
 400                    ;; used, without explanation, by the CMU CL code
 401                    ;; we're derived from. Evidently it's safe in all
 402                    ;; relevant cases.
 403                    42))))
 404     (mapcar (lambda (kernel-bic-entry)
 405               (/noshow "setting up" kernel-bic-entry)
 406               (let* ((name (car kernel-bic-entry))
 407                      (class (find-classoid name)))
 408                 (/noshow name class)
 409                 `(,name
 410                   ,(mapcar #'classoid-name (direct-supers class))
 411                   ,(mapcar #'classoid-name (direct-subs class))
 412                   ,(map 'list
 413                         (lambda (x)
 414                           (classoid-name
 415                            (layout-classoid x)))
 416                         (reverse
 417                          (layout-inherits
 418                           (classoid-layout class))))
 419                   ,(prototype name))))
 420             (remove-if (lambda (kernel-bic-entry)
 421                          (member (first kernel-bic-entry)
 422                                  ;; I'm not sure why these are removed from
 423                                  ;; the list, but that's what the original
 424                                  ;; CMU CL code did. -- WHN 20000715
 425                                  '(t instance
 426                                      funcallable-instance
 427                                      function stream)))
 428                        sb-kernel::*built-in-classes*))))
 429 (/noshow "done setting up SB-PCL::*BUILT-IN-CLASSES*")
 430 \f
 431 ;;;; the classes that define the kernel of the metabraid
 432
 433 (defclass t () ()
 434   (:metaclass built-in-class))
 435
 436 (defclass instance (t) ()
 437   (:metaclass built-in-class))
 438
 439 (defclass function (t) ()
 440   (:metaclass built-in-class))
 441
 442 (defclass funcallable-instance (function) ()
 443   (:metaclass built-in-class))
 444
 445 (defclass stream (instance) ()
 446   (:metaclass built-in-class))
 447
 448 (defclass slot-object (t) ()
 449   (:metaclass slot-class))
 450
 451 (defclass condition (slot-object instance) ()
 452   (:metaclass condition-class))
 453
 454 (defclass structure-object (slot-object instance) ()
 455   (:metaclass structure-class))
 456
 457 (defstruct (dead-beef-structure-object
 458             (:constructor |STRUCTURE-OBJECT class constructor|)
 459             (:copier nil)))
 460
 461 (defclass std-object (slot-object) ()
 462   (:metaclass std-class))
 463
 464 (defclass standard-object (std-object instance) ())
 465
 466 (defclass funcallable-standard-object (std-object funcallable-instance)
 467   ()
 468   (:metaclass funcallable-standard-class))
 469
 470 (defclass specializer (standard-object)
 471   ((type
 472     :initform nil
 473     :reader specializer-type)))
 474
 475 (defclass definition-source-mixin (std-object)
 476   ((source
 477     :initform *load-pathname*
 478     :reader definition-source
 479     :initarg :definition-source))
 480   (:metaclass std-class))
 481
 482 (defclass plist-mixin (std-object)
 483   ((plist
 484     :initform ()
 485     :accessor object-plist))
 486   (:metaclass std-class))
 487
 488 (defclass documentation-mixin (plist-mixin)
 489   ()
 490   (:metaclass std-class))
 491
 492 (defclass dependent-update-mixin (plist-mixin)
 493   ()
 494   (:metaclass std-class))
 495
 496 ;;; The class CLASS is a specified basic class. It is the common
 497 ;;; superclass of any kind of class. That is, any class that can be a
 498 ;;; metaclass must have the class CLASS in its class precedence list.
 499 (defclass class (documentation-mixin
 500                  dependent-update-mixin
 501                  definition-source-mixin
 502                  specializer)
 503   ((name
 504     :initform nil
 505     :initarg  :name
 506     :accessor class-name)
 507    (class-eq-specializer
 508     :initform nil
 509     :reader class-eq-specializer)
 510    (direct-superclasses
 511     :initform ()
 512     :reader class-direct-superclasses)
 513    ;; Note: The (CLASS-)DIRECT-SUBCLASSES for STRUCTURE-CLASSes and
 514    ;; CONDITION-CLASSes are lazily computed whenever the subclass info
 515    ;; becomes available, i.e. when the PCL class is created.
 516    (direct-subclasses
 517     :initform ()
 518     :reader class-direct-subclasses)
 519    (direct-methods
 520     :initform (cons nil nil))
 521    (predicate-name
 522     :initform nil
 523     :reader class-predicate-name)
 524    (finalized-p
 525     :initform nil
 526     :reader class-finalized-p)))
 527
 528 (def!method make-load-form ((class class) &optional env)
 529   ;; FIXME: should we not instead pass ENV to FIND-CLASS?  Probably
 530   ;; doesn't matter while all our environments are the same...
 531   (declare (ignore env))
 532   (let ((name (class-name class)))
 533     (unless (and name (eq (find-class name nil) class))
 534       (error "~@<Can't use anonymous or undefined class as constant: ~S~:@>"
 535              class))
 536     `(find-class ',name)))
 537
 538 ;;; The class PCL-CLASS is an implementation-specific common
 539 ;;; superclass of all specified subclasses of the class CLASS.
 540 (defclass pcl-class (class)
 541   ((class-precedence-list
 542     :reader class-precedence-list)
 543    (can-precede-list
 544     :initform ()
 545     :reader class-can-precede-list)
 546    (incompatible-superclass-list
 547     :initform ()
 548     :accessor class-incompatible-superclass-list)
 549    (wrapper
 550     :initform nil
 551     :reader class-wrapper)
 552    (prototype
 553     :initform nil
 554     :reader class-prototype)))
 555
 556 (defclass slot-class (pcl-class)
 557   ((direct-slots
 558     :initform ()
 559     :accessor class-direct-slots)
 560    (slots
 561     :initform ()
 562     :accessor class-slots)
 563    (initialize-info
 564     :initform nil
 565     :accessor class-initialize-info)))
 566
 567 ;;; The class STD-CLASS is an implementation-specific common
 568 ;;; superclass of the classes STANDARD-CLASS and
 569 ;;; FUNCALLABLE-STANDARD-CLASS.
 570 (defclass std-class (slot-class)
 571   ())
 572
 573 (defclass standard-class (std-class)
 574   ())
 575
 576 (defclass funcallable-standard-class (std-class)
 577   ())
 578
 579 (defclass forward-referenced-class (pcl-class) ())
 580
 581 (defclass built-in-class (pcl-class) ())
 582
 583 (defclass condition-class (slot-class) ())
 584
 585 (defclass structure-class (slot-class)
 586   ((defstruct-form
 587      :initform ()
 588      :accessor class-defstruct-form)
 589    (defstruct-constructor
 590      :initform nil
 591      :accessor class-defstruct-constructor)
 592    (from-defclass-p
 593     :initform nil
 594     :initarg :from-defclass-p)))
 595
 596 (defclass specializer-with-object (specializer) ())
 597
 598 (defclass exact-class-specializer (specializer) ())
 599
 600 (defclass class-eq-specializer (exact-class-specializer
 601                                 specializer-with-object)
 602   ((object :initarg :class
 603            :reader specializer-class
 604            :reader specializer-object)))
 605
 606 (defclass class-prototype-specializer (specializer-with-object)
 607   ((object :initarg :class
 608            :reader specializer-class
 609            :reader specializer-object)))
 610
 611 (defclass eql-specializer (exact-class-specializer specializer-with-object)
 612   ((object :initarg :object :reader specializer-object
 613            :reader eql-specializer-object)))
 614
 615 (defvar *eql-specializer-table* (make-hash-table :test 'eql))
 616
 617 (defun intern-eql-specializer (object)
 618   (or (gethash object *eql-specializer-table*)
 619       (setf (gethash object *eql-specializer-table*)
 620             (make-instance 'eql-specializer :object object))))
 621 \f
 622 ;;;; slot definitions
 623
 624 (defclass slot-definition (standard-object)
 625   ((name
 626     :initform nil
 627     :initarg :name
 628     :accessor slot-definition-name)
 629    (initform
 630     :initform nil
 631     :initarg :initform
 632     :accessor slot-definition-initform)
 633    (initfunction
 634     :initform nil
 635     :initarg :initfunction
 636     :accessor slot-definition-initfunction)
 637    (readers
 638     :initform nil
 639     :initarg :readers
 640     :accessor slot-definition-readers)
 641    (writers
 642     :initform nil
 643     :initarg :writers
 644     :accessor slot-definition-writers)
 645    (initargs
 646     :initform nil
 647     :initarg :initargs
 648     :accessor slot-definition-initargs)
 649    (type
 650     :initform t
 651     :initarg :type
 652     :accessor slot-definition-type)
 653    (documentation
 654     :initform ""
 655     :initarg :documentation)
 656    (class
 657     :initform nil
 658     :initarg :class
 659     :accessor slot-definition-class)))
 660
 661 (defclass standard-slot-definition (slot-definition)
 662   ((allocation
 663     :initform :instance
 664     :initarg :allocation
 665     :accessor slot-definition-allocation)
 666    (allocation-class
 667     :initform nil
 668     :initarg :allocation-class
 669     :accessor slot-definition-allocation-class)))
 670
 671 (defclass condition-slot-definition (slot-definition)
 672   ((allocation
 673     :initform :instance
 674     :initarg :allocation
 675     :accessor slot-definition-allocation)
 676    (allocation-class
 677     :initform nil
 678     :initarg :allocation-class
 679     :accessor slot-definition-allocation-class)))
 680
 681 (defclass structure-slot-definition (slot-definition)
 682   ((defstruct-accessor-symbol
 683      :initform nil
 684      :initarg :defstruct-accessor-symbol
 685      :accessor slot-definition-defstruct-accessor-symbol)
 686    (internal-reader-function
 687      :initform nil
 688      :initarg :internal-reader-function
 689      :accessor slot-definition-internal-reader-function)
 690    (internal-writer-function
 691      :initform nil
 692      :initarg :internal-writer-function
 693      :accessor slot-definition-internal-writer-function)))
 694
 695 (defclass direct-slot-definition (slot-definition)
 696   ())
 697
 698 (defclass effective-slot-definition (slot-definition)
 699   ((reader-function ; (lambda (object) ...)
 700     :accessor slot-definition-reader-function)
 701    (writer-function ; (lambda (new-value object) ...)
 702     :accessor slot-definition-writer-function)
 703    (boundp-function ; (lambda (object) ...)
 704     :accessor slot-definition-boundp-function)
 705    (accessor-flags
 706     :initform 0)))
 707
 708 (defclass standard-direct-slot-definition (standard-slot-definition
 709                                            direct-slot-definition)
 710   ())
 711
 712 (defclass standard-effective-slot-definition (standard-slot-definition
 713                                               effective-slot-definition)
 714   ((location ; nil, a fixnum, a cons: (slot-name . value)
 715     :initform nil
 716     :accessor slot-definition-location)))
 717
 718 (defclass condition-direct-slot-definition (condition-slot-definition
 719                                             direct-slot-definition)
 720   ())
 721
 722 (defclass condition-effective-slot-definition (condition-slot-definition
 723                                                effective-slot-definition)
 724   ())
 725
 726 (defclass structure-direct-slot-definition (structure-slot-definition
 727                                             direct-slot-definition)
 728   ())
 729
 730 (defclass structure-effective-slot-definition (structure-slot-definition
 731                                                effective-slot-definition)
 732   ())
 733
 734 (defclass method (standard-object) ())
 735
 736 (defclass standard-method (definition-source-mixin plist-mixin method)
 737   ((generic-function
 738     :initform nil
 739     :accessor method-generic-function)
 740 ;;;     (qualifiers
 741 ;;;     :initform ()
 742 ;;;     :initarg  :qualifiers
 743 ;;;     :reader method-qualifiers)
 744    (specializers
 745     :initform ()
 746     :initarg  :specializers
 747     :reader method-specializers)
 748    (lambda-list
 749     :initform ()
 750     :initarg  :lambda-list
 751     :reader method-lambda-list)
 752    (function
 753     :initform nil
 754     :initarg :function)                 ;no writer
 755    (fast-function
 756     :initform nil
 757     :initarg :fast-function             ;no writer
 758     :reader method-fast-function)
 759 ;;;     (documentation
 760 ;;;     :initform nil
 761 ;;;     :initarg  :documentation
 762 ;;;     :reader method-documentation)
 763   ))
 764
 765 (defclass standard-accessor-method (standard-method)
 766   ((slot-name :initform nil
 767               :initarg :slot-name
 768               :reader accessor-method-slot-name)
 769    (slot-definition :initform nil
 770                     :initarg :slot-definition
 771                     :reader accessor-method-slot-definition)))
 772
 773 (defclass standard-reader-method (standard-accessor-method) ())
 774
 775 (defclass standard-writer-method (standard-accessor-method) ())
 776
 777 (defclass standard-boundp-method (standard-accessor-method) ())
 778
 779 (defclass generic-function (dependent-update-mixin
 780                             definition-source-mixin
 781                             documentation-mixin
 782                             funcallable-standard-object)
 783   (;; We need to make a distinction between the methods initially set
 784    ;; up by :METHOD options to DEFGENERIC and the ones set up later by
 785    ;; DEFMETHOD, because ANSI's specifies that executing DEFGENERIC on
 786    ;; an already-DEFGENERICed function clears the methods set by the
 787    ;; previous DEFGENERIC, but not methods set by DEFMETHOD. (Making
 788    ;; this distinction seems a little kludgy, but it has the positive
 789    ;; effect of making it so that loading a file a.lisp containing
 790    ;; DEFGENERIC, then loading a second file b.lisp containing
 791    ;; DEFMETHOD, then modifying and reloading a.lisp and/or b.lisp
 792    ;; tends to leave the generic function in a state consistent with
 793    ;; the most-recently-loaded state of a.lisp and b.lisp.)
 794    (initial-methods
 795     :initform ()
 796     :accessor generic-function-initial-methods))
 797   (:metaclass funcallable-standard-class))
 798
 799 (defclass standard-generic-function (generic-function)
 800   ((name
 801     :initform nil
 802     :initarg :name
 803     :accessor generic-function-name)
 804    (methods
 805     :initform ()
 806     :accessor generic-function-methods
 807     :type list)
 808    (method-class
 809     :initarg :method-class
 810     :accessor generic-function-method-class)
 811    (method-combination
 812     :initarg :method-combination
 813     :accessor generic-function-method-combination)
 814    (declarations
 815     :initarg :declarations
 816     :initform ()
 817     :accessor generic-function-declarations)
 818    (arg-info
 819     :initform (make-arg-info)
 820     :reader gf-arg-info)
 821    (dfun-state
 822     :initform ()
 823     :accessor gf-dfun-state))
 824   (:metaclass funcallable-standard-class)
 825   (:default-initargs :method-class *the-class-standard-method*
 826                      :method-combination *standard-method-combination*))
 827
 828 (defclass method-combination (standard-object) ())
 829
 830 (defclass standard-method-combination (definition-source-mixin
 831                                         method-combination)
 832   ((type
 833     :reader method-combination-type
 834     :initarg :type)
 835    (documentation
 836     :reader method-combination-documentation
 837     :initarg :documentation)
 838    (options
 839     :reader method-combination-options
 840     :initarg :options)))
 841
 842 (defclass long-method-combination (standard-method-combination)
 843   ((function
 844     :initarg :function
 845     :reader long-method-combination-function)
 846    (args-lambda-list
 847     :initarg :args-lambda-list
 848     :reader long-method-combination-args-lambda-list)))
 849
 850 (defparameter *early-class-predicates*
 851   '((specializer specializerp)
 852     (exact-class-specializer exact-class-specializer-p)
 853     (class-eq-specializer class-eq-specializer-p)
 854     (eql-specializer eql-specializer-p)
 855     (class classp)
 856     (slot-class slot-class-p)
 857     (std-class std-class-p)
 858     (standard-class standard-class-p)
 859     (funcallable-standard-class funcallable-standard-class-p)
 860     (condition-class condition-class-p)
 861     (structure-class structure-class-p)
 862     (forward-referenced-class forward-referenced-class-p)
 863     (method method-p)
 864     (standard-method standard-method-p)
 865     (standard-accessor-method standard-accessor-method-p)
 866     (standard-reader-method standard-reader-method-p)
 867     (standard-writer-method standard-writer-method-p)
 868     (standard-boundp-method standard-boundp-method-p)
 869     (generic-function generic-function-p)
 870     (standard-generic-function standard-generic-function-p)
 871     (method-combination method-combination-p)
 872     (long-method-combination long-method-combination-p)))
 873