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