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