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