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