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