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 (sb-kernel:instance) ()
 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             (:copier nil)))
 556
 557 (defclass std-object (slot-object) ()
 558   (:metaclass std-class))
 559
 560 (defclass standard-object (std-object sb-kernel:instance) ())
 561
 562 (defclass funcallable-standard-object (std-object
 563                                        sb-kernel:funcallable-instance)
 564      ()
 565   (:metaclass funcallable-standard-class))
 566
 567 (defclass specializer (standard-object)
 568      ((type
 569         :initform nil
 570         :reader specializer-type)))
 571
 572 (defclass definition-source-mixin (std-object)
 573      ((source
 574         :initform *load-truename*
 575         :reader definition-source
 576         :initarg :definition-source))
 577   (:metaclass std-class))
 578
 579 (defclass plist-mixin (std-object)
 580      ((plist
 581         :initform ()
 582         :accessor object-plist))
 583   (:metaclass std-class))
 584
 585 (defclass documentation-mixin (plist-mixin)
 586      ()
 587   (:metaclass std-class))
 588
 589 (defclass dependent-update-mixin (plist-mixin)
 590     ()
 591   (:metaclass std-class))
 592
 593 ;;; The class CLASS is a specified basic class. It is the common superclass
 594 ;;; of any kind of class. That is any class that can be a metaclass must
 595 ;;; have the class CLASS in its class precedence list.
 596 (defclass class (documentation-mixin dependent-update-mixin
 597                  definition-source-mixin specializer)
 598      ((name
 599         :initform nil
 600         :initarg  :name
 601         :accessor class-name)
 602       (class-eq-specializer
 603         :initform nil
 604         :reader class-eq-specializer)
 605       (direct-superclasses
 606         :initform ()
 607         :reader class-direct-superclasses)
 608       (direct-subclasses
 609         :initform ()
 610         :reader class-direct-subclasses)
 611       (direct-methods
 612         :initform (cons nil nil))
 613       (predicate-name
 614         :initform nil
 615         :reader class-predicate-name)))
 616
 617 ;;; The class PCL-CLASS is an implementation-specific common superclass of
 618 ;;; all specified subclasses of the class CLASS.
 619 (defclass pcl-class (class)
 620      ((class-precedence-list
 621         :reader class-precedence-list)
 622       (can-precede-list
 623         :initform ()
 624         :reader class-can-precede-list)
 625       (incompatible-superclass-list
 626         :initform ()
 627         :accessor class-incompatible-superclass-list)
 628       (wrapper
 629         :initform nil
 630         :reader class-wrapper)
 631       (prototype
 632         :initform nil
 633         :reader class-prototype)))
 634
 635 (defclass slot-class (pcl-class)
 636      ((direct-slots
 637         :initform ()
 638         :accessor class-direct-slots)
 639       (slots
 640         :initform ()
 641         :accessor class-slots)
 642       (initialize-info
 643         :initform nil
 644         :accessor class-initialize-info)))
 645
 646 ;;; The class STD-CLASS is an implementation-specific common superclass of
 647 ;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.
 648 (defclass std-class (slot-class)
 649   ())
 650
 651 (defclass standard-class (std-class)
 652   ())
 653
 654 (defclass funcallable-standard-class (std-class)
 655   ())
 656
 657 (defclass forward-referenced-class (pcl-class) ())
 658
 659 (defclass built-in-class (pcl-class) ())
 660
 661 (defclass structure-class (slot-class)
 662   ((defstruct-form
 663      :initform ()
 664      :accessor class-defstruct-form)
 665    (defstruct-constructor
 666      :initform nil
 667      :accessor class-defstruct-constructor)
 668    (from-defclass-p
 669     :initform nil
 670     :initarg :from-defclass-p)))
 671
 672 (defclass specializer-with-object (specializer) ())
 673
 674 (defclass exact-class-specializer (specializer) ())
 675
 676 (defclass class-eq-specializer (exact-class-specializer
 677                                 specializer-with-object)
 678   ((object :initarg :class
 679            :reader specializer-class
 680            :reader specializer-object)))
 681
 682 (defclass class-prototype-specializer (specializer-with-object)
 683   ((object :initarg :class
 684            :reader specializer-class
 685            :reader specializer-object)))
 686
 687 (defclass eql-specializer (exact-class-specializer specializer-with-object)
 688   ((object :initarg :object :reader specializer-object
 689            :reader eql-specializer-object)))
 690
 691 (defvar *eql-specializer-table* (make-hash-table :test 'eql))
 692
 693 (defun intern-eql-specializer (object)
 694   (or (gethash object *eql-specializer-table*)
 695       (setf (gethash object *eql-specializer-table*)
 696             (make-instance 'eql-specializer :object object))))
 697 \f
 698 ;;;; slot definitions
 699
 700 (defclass slot-definition (standard-object)
 701      ((name
 702         :initform nil
 703         :initarg :name
 704         :accessor slot-definition-name)
 705       (initform
 706         :initform nil
 707         :initarg :initform
 708         :accessor slot-definition-initform)
 709       (initfunction
 710         :initform nil
 711         :initarg :initfunction
 712         :accessor slot-definition-initfunction)
 713       (readers
 714         :initform nil
 715         :initarg :readers
 716         :accessor slot-definition-readers)
 717       (writers
 718         :initform nil
 719         :initarg :writers
 720         :accessor slot-definition-writers)
 721       (initargs
 722         :initform nil
 723         :initarg :initargs
 724         :accessor slot-definition-initargs)
 725       (type
 726         :initform t
 727         :initarg :type
 728         :accessor slot-definition-type)
 729       (documentation
 730         :initform ""
 731         :initarg :documentation)
 732       (class
 733         :initform nil
 734         :initarg :class
 735         :accessor slot-definition-class)))
 736
 737 (defclass standard-slot-definition (slot-definition)
 738   ((allocation
 739     :initform :instance
 740     :initarg :allocation
 741     :accessor slot-definition-allocation)))
 742
 743 (defclass structure-slot-definition (slot-definition)
 744   ((defstruct-accessor-symbol
 745      :initform nil
 746      :initarg :defstruct-accessor-symbol
 747      :accessor slot-definition-defstruct-accessor-symbol)
 748    (internal-reader-function
 749      :initform nil
 750      :initarg :internal-reader-function
 751      :accessor slot-definition-internal-reader-function)
 752    (internal-writer-function
 753      :initform nil
 754      :initarg :internal-writer-function
 755      :accessor slot-definition-internal-writer-function)))
 756
 757 (defclass direct-slot-definition (slot-definition)
 758   ())
 759
 760 (defclass effective-slot-definition (slot-definition)
 761   ((reader-function ; #'(lambda (object) ...)
 762     :accessor slot-definition-reader-function)
 763    (writer-function ; #'(lambda (new-value object) ...)
 764     :accessor slot-definition-writer-function)
 765    (boundp-function ; #'(lambda (object) ...)
 766     :accessor slot-definition-boundp-function)
 767    (accessor-flags
 768     :initform 0)))
 769
 770 (defclass standard-direct-slot-definition (standard-slot-definition
 771                                            direct-slot-definition)
 772   ())
 773
 774 (defclass standard-effective-slot-definition (standard-slot-definition
 775                                               effective-slot-definition)
 776   ((location ; nil, a fixnum, a cons: (slot-name . value)
 777     :initform nil
 778     :accessor slot-definition-location)))
 779
 780 (defclass structure-direct-slot-definition (structure-slot-definition
 781                                             direct-slot-definition)
 782   ())
 783
 784 (defclass structure-effective-slot-definition (structure-slot-definition
 785                                                effective-slot-definition)
 786   ())
 787
 788 (defclass method (standard-object) ())
 789
 790 (defclass standard-method (definition-source-mixin plist-mixin method)
 791      ((generic-function
 792         :initform nil
 793         :accessor method-generic-function)
 794 ;     (qualifiers
 795 ;       :initform ()
 796 ;       :initarg  :qualifiers
 797 ;       :reader method-qualifiers)
 798       (specializers
 799         :initform ()
 800         :initarg  :specializers
 801         :reader method-specializers)
 802       (lambda-list
 803         :initform ()
 804         :initarg  :lambda-list
 805         :reader method-lambda-list)
 806       (function
 807         :initform nil
 808         :initarg :function)             ;no writer
 809       (fast-function
 810         :initform nil
 811         :initarg :fast-function         ;no writer
 812         :reader method-fast-function)
 813 ;     (documentation
 814 ;       :initform nil
 815 ;       :initarg  :documentation
 816 ;       :reader method-documentation)
 817       ))
 818
 819 (defclass standard-accessor-method (standard-method)
 820      ((slot-name :initform nil
 821                  :initarg :slot-name
 822                  :reader accessor-method-slot-name)
 823       (slot-definition :initform nil
 824                        :initarg :slot-definition
 825                        :reader accessor-method-slot-definition)))
 826
 827 (defclass standard-reader-method (standard-accessor-method) ())
 828
 829 (defclass standard-writer-method (standard-accessor-method) ())
 830
 831 (defclass standard-boundp-method (standard-accessor-method) ())
 832
 833 (defclass generic-function (dependent-update-mixin
 834                             definition-source-mixin
 835                             documentation-mixin
 836                             funcallable-standard-object)
 837      ()
 838   (:metaclass funcallable-standard-class))
 839
 840 (defclass standard-generic-function (generic-function)
 841       ((name
 842         :initform nil
 843         :initarg :name
 844         :accessor generic-function-name)
 845       (methods
 846         :initform ()
 847         :accessor generic-function-methods
 848         :type list)
 849       (method-class
 850         :initarg :method-class
 851         :accessor generic-function-method-class)
 852       (method-combination
 853         :initarg :method-combination
 854         :accessor generic-function-method-combination)
 855       (arg-info
 856         :initform (make-arg-info)
 857         :reader gf-arg-info)
 858       (dfun-state
 859         :initform ()
 860         :accessor gf-dfun-state)
 861       (pretty-arglist
 862         :initform ()
 863         :accessor gf-pretty-arglist))
 864   (:metaclass funcallable-standard-class)
 865   (:default-initargs :method-class *the-class-standard-method*
 866                      :method-combination *standard-method-combination*))
 867
 868 (defclass method-combination (standard-object) ())
 869
 870 (defclass standard-method-combination
 871           (definition-source-mixin method-combination)
 872      ((type       :reader method-combination-type
 873                      :initarg :type)
 874       (documentation :reader method-combination-documentation
 875                      :initarg :documentation)
 876       (options       :reader method-combination-options
 877                      :initarg :options)))
 878
 879 (defparameter *early-class-predicates*
 880   '((specializer specializerp)
 881     (exact-class-specializer exact-class-specializer-p)
 882     (class-eq-specializer class-eq-specializer-p)
 883     (eql-specializer eql-specializer-p)
 884     (class classp)
 885     (slot-class slot-class-p)
 886     (std-class std-class-p)
 887     (standard-class standard-class-p)
 888     (funcallable-standard-class funcallable-standard-class-p)
 889     (structure-class structure-class-p)
 890     (forward-referenced-class forward-referenced-class-p)
 891     (method method-p)
 892     (standard-method standard-method-p)
 893     (standard-accessor-method standard-accessor-method-p)
 894     (standard-reader-method standard-reader-method-p)
 895     (standard-writer-method standard-writer-method-p)
 896     (standard-boundp-method standard-boundp-method-p)
 897     (generic-function generic-function-p)
 898     (standard-generic-function standard-generic-function-p)
 899     (method-combination method-combination-p)))
 900