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