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