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