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 ;;;; type specifier hackery
  87
  88 ;;; internal to this file
  89 (defun coerce-to-class (class &optional make-forward-referenced-class-p)
  90   (if (symbolp class)
  91       (or (find-class class (not make-forward-referenced-class-p))
  92           (ensure-class class))
  93       class))
  94
  95 ;;; interface
  96 (defun specializer-from-type (type &aux args)
  97   (when (consp type)
  98     (setq args (cdr type) type (car type)))
  99   (cond ((symbolp type)
 100          (or (and (null args) (find-class type))
 101              (ecase type
 102                (class    (coerce-to-class (car args)))
 103                (prototype (make-instance 'class-prototype-specializer
 104                                          :object (coerce-to-class (car args))))
 105                (class-eq (class-eq-specializer (coerce-to-class (car args))))
 106                (eql      (intern-eql-specializer (car args))))))
 107         ;; FIXME: do we still need this?
 108         ((and (null args) (typep type 'classoid))
 109          (or (classoid-pcl-class type)
 110              (ensure-non-standard-class (classoid-name type))))
 111         ((specializerp type) type)))
 112
 113 ;;; interface
 114 (defun type-from-specializer (specl)
 115   (cond ((eq specl t)
 116          t)
 117         ((consp specl)
 118          (unless (member (car specl) '(class prototype class-eq eql))
 119            (error "~S is not a legal specializer type." specl))
 120          specl)
 121         ((progn
 122            (when (symbolp specl)
 123              ;;maybe (or (find-class specl nil) (ensure-class specl)) instead?
 124              (setq specl (find-class specl)))
 125            (or (not (eq *boot-state* 'complete))
 126                (specializerp specl)))
 127          (specializer-type specl))
 128         (t
 129          (error "~S is neither a type nor a specializer." specl))))
 130
 131 (defun type-class (type)
 132   (declare (special *the-class-t*))
 133   (setq type (type-from-specializer type))
 134   (if (atom type)
 135       (if (eq type t)
 136           *the-class-t*
 137           (error "bad argument to TYPE-CLASS"))
 138       (case (car type)
 139         (eql (class-of (cadr type)))
 140         (prototype (class-of (cadr type))) ;?
 141         (class-eq (cadr type))
 142         (class (cadr type)))))
 143
 144 (defun class-eq-type (class)
 145   (specializer-type (class-eq-specializer class)))
 146
 147 ;;; internal to this file..
 148 ;;;
 149 ;;; These functions are a pale imitation of their namesake. They accept
 150 ;;; class objects or types where they should.
 151 (defun *normalize-type (type)
 152   (cond ((consp type)
 153          (if (member (car type) '(not and or))
 154              `(,(car type) ,@(mapcar #'*normalize-type (cdr type)))
 155              (if (null (cdr type))
 156                  (*normalize-type (car type))
 157                  type)))
 158         ((symbolp type)
 159          (let ((class (find-class type nil)))
 160            (if class
 161                (let ((type (specializer-type class)))
 162                  (if (listp type) type `(,type)))
 163                `(,type))))
 164         ((or (not (eq *boot-state* 'complete))
 165              (specializerp type))
 166          (specializer-type type))
 167         (t
 168          (error "~S is not a type." type))))
 169
 170 ;;; internal to this file...
 171 (defun convert-to-system-type (type)
 172   (case (car type)
 173     ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
 174                                           (cdr type))))
 175     ((class class-eq) ; class-eq is impossible to do right
 176      (layout-classoid (class-wrapper (cadr type))))
 177     (eql type)
 178     (t (if (null (cdr type))
 179            (car type)
 180            type))))
 181
 182 ;;; Writing the missing NOT and AND clauses will improve the quality
 183 ;;; of code generated by GENERATE-DISCRIMINATION-NET, but calling
 184 ;;; SUBTYPEP in place of just returning (VALUES NIL NIL) can be very
 185 ;;; slow. *SUBTYPEP is used by PCL itself, and must be fast.
 186 ;;;
 187 ;;; FIXME: SB-KERNEL has fast-and-not-quite-precise type code for use
 188 ;;; in the compiler. Could we share some of it here?
 189 (defun *subtypep (type1 type2)
 190   (if (equal type1 type2)
 191       (values t t)
 192       (if (eq *boot-state* 'early)
 193           (values (eq type1 type2) t)
 194           (let ((*in-precompute-effective-methods-p* t))
 195             (declare (special *in-precompute-effective-methods-p*))
 196             ;; FIXME: *IN-PRECOMPUTE-EFFECTIVE-METHODS-P* is not a
 197             ;; good name. It changes the way
 198             ;; CLASS-APPLICABLE-USING-CLASS-P works.
 199             (setq type1 (*normalize-type type1))
 200             (setq type2 (*normalize-type type2))
 201             (case (car type2)
 202               (not
 203                (values nil nil)) ; XXX We should improve this.
 204               (and
 205                (values nil nil)) ; XXX We should improve this.
 206               ((eql wrapper-eq class-eq class)
 207                (multiple-value-bind (app-p maybe-app-p)
 208                    (specializer-applicable-using-type-p type2 type1)
 209                  (values app-p (or app-p (not maybe-app-p)))))
 210               (t
 211                (subtypep (convert-to-system-type type1)
 212                          (convert-to-system-type type2))))))))
 213 \f
 214 (defvar *built-in-class-symbols* ())
 215 (defvar *built-in-wrapper-symbols* ())
 216
 217 (defun get-built-in-class-symbol (class-name)
 218   (or (cadr (assq class-name *built-in-class-symbols*))
 219       (let ((symbol (make-class-symbol class-name)))
 220         (push (list class-name symbol) *built-in-class-symbols*)
 221         symbol)))
 222
 223 (defun get-built-in-wrapper-symbol (class-name)
 224   (or (cadr (assq class-name *built-in-wrapper-symbols*))
 225       (let ((symbol (make-wrapper-symbol class-name)))
 226         (push (list class-name symbol) *built-in-wrapper-symbols*)
 227         symbol)))
 228 \f
 229 (pushnew '%class *var-declarations*)
 230 (pushnew '%variable-rebinding *var-declarations*)
 231
 232 (defun variable-class (var env)
 233   (caddr (var-declaration 'class var env)))
 234
 235 (defvar *name->class->slotd-table* (make-hash-table))
 236
 237 (defvar *standard-method-combination*)
 238 \f
 239 (defun make-class-predicate-name (name)
 240   (list 'class-predicate name))
 241
 242 (defun plist-value (object name)
 243   (getf (object-plist object) name))
 244
 245 (defun (setf plist-value) (new-value object name)
 246   (if new-value
 247       (setf (getf (object-plist object) name) new-value)
 248       (progn
 249         (remf (object-plist object) name)
 250         nil)))
 251 \f
 252 ;;;; built-in classes
 253
 254 ;;; Grovel over SB-KERNEL::*BUILT-IN-CLASSES* in order to set
 255 ;;; SB-PCL:*BUILT-IN-CLASSES*.
 256 (/show "about to set up SB-PCL::*BUILT-IN-CLASSES*")
 257 (defvar *built-in-classes*
 258   (labels ((direct-supers (class)
 259              (/noshow "entering DIRECT-SUPERS" (classoid-name class))
 260              (if (typep class 'built-in-classoid)
 261                  (built-in-classoid-direct-superclasses class)
 262                  (let ((inherits (layout-inherits
 263                                   (classoid-layout class))))
 264                    (/noshow inherits)
 265                    (list (svref inherits (1- (length inherits)))))))
 266            (direct-subs (class)
 267              (/noshow "entering DIRECT-SUBS" (classoid-name class))
 268              (collect ((res))
 269                (let ((subs (classoid-subclasses class)))
 270                  (/noshow subs)
 271                  (when subs
 272                    (dohash (sub v subs)
 273                      (declare (ignore v))
 274                      (/noshow sub)
 275                      (when (member class (direct-supers sub))
 276                        (res sub)))))
 277                (res))))
 278     (mapcar (lambda (kernel-bic-entry)
 279               (/noshow "setting up" kernel-bic-entry)
 280               (let* ((name (car kernel-bic-entry))
 281                      (class (find-classoid name))
 282                      (prototype-form
 283                       (getf (cdr kernel-bic-entry) :prototype-form)))
 284                 (/noshow name class)
 285                 `(,name
 286                   ,(mapcar #'classoid-name (direct-supers class))
 287                   ,(mapcar #'classoid-name (direct-subs class))
 288                   ,(map 'list
 289                         (lambda (x)
 290                           (classoid-name
 291                            (layout-classoid x)))
 292                         (reverse
 293                          (layout-inherits
 294                           (classoid-layout class))))
 295                   ,(if prototype-form
 296                        (eval prototype-form)
 297                        ;; This is the default prototype value which
 298                        ;; was used, without explanation, by the CMU CL
 299                        ;; code we're derived from. Evidently it's safe
 300                        ;; in all relevant cases.
 301                        42))))
 302             (remove-if (lambda (kernel-bic-entry)
 303                          (member (first kernel-bic-entry)
 304                                  ;; I'm not sure why these are removed from
 305                                  ;; the list, but that's what the original
 306                                  ;; CMU CL code did. -- WHN 20000715
 307                                  '(t instance
 308                                      funcallable-instance
 309                                      function stream
 310                                      file-stream string-stream)))
 311                        sb-kernel::*built-in-classes*))))
 312 (/noshow "done setting up SB-PCL::*BUILT-IN-CLASSES*")
 313 \f
 314 ;;;; the classes that define the kernel of the metabraid
 315
 316 (defclass t () ()
 317   (:metaclass built-in-class))
 318
 319 (defclass instance (t) ()
 320   (:metaclass built-in-class))
 321
 322 (defclass function (t) ()
 323   (:metaclass built-in-class))
 324
 325 (defclass funcallable-instance (function) ()
 326   (:metaclass built-in-class))
 327
 328 (defclass stream (instance) ()
 329   (:metaclass built-in-class))
 330
 331 (defclass file-stream (stream) ()
 332   (:metaclass built-in-class))
 333
 334 (defclass string-stream (stream) ()
 335   (:metaclass built-in-class))
 336
 337 (defclass slot-object (t) ()
 338   (:metaclass slot-class))
 339
 340 (defclass condition (slot-object instance) ()
 341   (:metaclass condition-class))
 342
 343 (defclass structure-object (slot-object instance) ()
 344   (:metaclass structure-class))
 345
 346 (defstruct (dead-beef-structure-object
 347             (:constructor |STRUCTURE-OBJECT class constructor|)
 348             (:copier nil)))
 349
 350 (defclass std-object (slot-object) ()
 351   (:metaclass std-class))
 352
 353 (defclass standard-object (std-object instance) ())
 354
 355 (defclass funcallable-standard-object (std-object funcallable-instance)
 356   ()
 357   (:metaclass funcallable-standard-class))
 358
 359 (defclass specializer (standard-object)
 360   ((type
 361     :initform nil
 362     :reader specializer-type)))
 363
 364 (defclass definition-source-mixin (std-object)
 365   ((source
 366     :initform *load-pathname*
 367     :reader definition-source
 368     :initarg :definition-source))
 369   (:metaclass std-class))
 370
 371 (defclass plist-mixin (std-object)
 372   ((plist
 373     :initform ()
 374     :accessor object-plist))
 375   (:metaclass std-class))
 376
 377 (defclass dependent-update-mixin (plist-mixin)
 378   ()
 379   (:metaclass std-class))
 380
 381 ;;; The class CLASS is a specified basic class. It is the common
 382 ;;; superclass of any kind of class. That is, any class that can be a
 383 ;;; metaclass must have the class CLASS in its class precedence list.
 384 (defclass class (dependent-update-mixin
 385                  definition-source-mixin
 386                  specializer)
 387   ((name
 388     :initform nil
 389     :initarg  :name
 390     :accessor class-name)
 391    (class-eq-specializer
 392     :initform nil
 393     :reader class-eq-specializer)
 394    (direct-superclasses
 395     :initform ()
 396     :reader class-direct-superclasses)
 397    ;; Note: The (CLASS-)DIRECT-SUBCLASSES for STRUCTURE-CLASSes and
 398    ;; CONDITION-CLASSes are lazily computed whenever the subclass info
 399    ;; becomes available, i.e. when the PCL class is created.
 400    (direct-subclasses
 401     :initform ()
 402     :reader class-direct-subclasses)
 403    (direct-methods
 404     :initform (cons nil nil))
 405    (predicate-name
 406     :initform nil
 407     :reader class-predicate-name)
 408    (documentation
 409     :initform nil
 410     :initarg :documentation)
 411    (finalized-p
 412     :initform nil
 413     :reader class-finalized-p)))
 414
 415 (def!method make-load-form ((class class) &optional env)
 416   ;; FIXME: should we not instead pass ENV to FIND-CLASS?  Probably
 417   ;; doesn't matter while all our environments are the same...
 418   (declare (ignore env))
 419   (let ((name (class-name class)))
 420     (unless (and name (eq (find-class name nil) class))
 421       (error "~@<Can't use anonymous or undefined class as constant: ~S~:@>"
 422              class))
 423     `(find-class ',name)))
 424
 425 ;;; The class PCL-CLASS is an implementation-specific common
 426 ;;; superclass of all specified subclasses of the class CLASS.
 427 (defclass pcl-class (class)
 428   ((class-precedence-list
 429     :reader class-precedence-list)
 430    ;; KLUDGE: see note in CPL-OR-NIL
 431    (cpl-available-p
 432     :reader cpl-available-p
 433     :initform nil)
 434    (can-precede-list
 435     :initform ()
 436     :reader class-can-precede-list)
 437    (incompatible-superclass-list
 438     :initform ()
 439     :accessor class-incompatible-superclass-list)
 440    (wrapper
 441     :initform nil
 442     :reader class-wrapper)
 443    (prototype
 444     :initform nil
 445     :reader class-prototype)))
 446
 447 (defclass slot-class (pcl-class)
 448   ((direct-slots
 449     :initform ()
 450     :accessor class-direct-slots)
 451    (slots
 452     :initform ()
 453     :accessor class-slots)))
 454
 455 ;;; The class STD-CLASS is an implementation-specific common
 456 ;;; superclass of the classes STANDARD-CLASS and
 457 ;;; FUNCALLABLE-STANDARD-CLASS.
 458 (defclass std-class (slot-class)
 459   ())
 460
 461 (defclass standard-class (std-class)
 462   ())
 463
 464 (defclass funcallable-standard-class (std-class)
 465   ())
 466
 467 (defclass forward-referenced-class (pcl-class) ())
 468
 469 (defclass built-in-class (pcl-class) ())
 470
 471 (defclass condition-class (slot-class) ())
 472
 473 (defclass structure-class (slot-class)
 474   ((defstruct-form
 475      :initform ()
 476      :accessor class-defstruct-form)
 477    (defstruct-constructor
 478      :initform nil
 479      :accessor class-defstruct-constructor)
 480    (from-defclass-p
 481     :initform nil
 482     :initarg :from-defclass-p)))
 483
 484 (defclass specializer-with-object (specializer) ())
 485
 486 (defclass exact-class-specializer (specializer) ())
 487
 488 (defclass class-eq-specializer (exact-class-specializer
 489                                 specializer-with-object)
 490   ((object :initarg :class
 491            :reader specializer-class
 492            :reader specializer-object)))
 493
 494 (defclass class-prototype-specializer (specializer-with-object)
 495   ((object :initarg :class
 496            :reader specializer-class
 497            :reader specializer-object)))
 498
 499 (defclass eql-specializer (exact-class-specializer specializer-with-object)
 500   ((object :initarg :object :reader specializer-object
 501            :reader eql-specializer-object)))
 502
 503 (defvar *eql-specializer-table* (make-hash-table :test 'eql))
 504
 505 (defun intern-eql-specializer (object)
 506   (or (gethash object *eql-specializer-table*)
 507       (setf (gethash object *eql-specializer-table*)
 508             (make-instance 'eql-specializer :object object))))
 509 \f
 510 ;;;; slot definitions
 511
 512 (defclass slot-definition (standard-object)
 513   ((name
 514     :initform nil
 515     :initarg :name
 516     :accessor slot-definition-name)
 517    (initform
 518     :initform nil
 519     :initarg :initform
 520     :accessor slot-definition-initform)
 521    (initfunction
 522     :initform nil
 523     :initarg :initfunction
 524     :accessor slot-definition-initfunction)
 525    (readers
 526     :initform nil
 527     :initarg :readers
 528     :accessor slot-definition-readers)
 529    (writers
 530     :initform nil
 531     :initarg :writers
 532     :accessor slot-definition-writers)
 533    (initargs
 534     :initform nil
 535     :initarg :initargs
 536     :accessor slot-definition-initargs)
 537    (type
 538     :initform t
 539     :initarg :type
 540     :accessor slot-definition-type)
 541    (documentation
 542     :initform nil
 543     :initarg :documentation)
 544    (class
 545     :initform nil
 546     :initarg :class
 547     :accessor slot-definition-class)))
 548
 549 (defclass standard-slot-definition (slot-definition)
 550   ((allocation
 551     :initform :instance
 552     :initarg :allocation
 553     :accessor slot-definition-allocation)
 554    (allocation-class
 555     :initform nil
 556     :initarg :allocation-class
 557     :accessor slot-definition-allocation-class)))
 558
 559 (defclass condition-slot-definition (slot-definition)
 560   ((allocation
 561     :initform :instance
 562     :initarg :allocation
 563     :accessor slot-definition-allocation)
 564    (allocation-class
 565     :initform nil
 566     :initarg :allocation-class
 567     :accessor slot-definition-allocation-class)))
 568
 569 (defclass structure-slot-definition (slot-definition)
 570   ((defstruct-accessor-symbol
 571      :initform nil
 572      :initarg :defstruct-accessor-symbol
 573      :accessor slot-definition-defstruct-accessor-symbol)
 574    (internal-reader-function
 575      :initform nil
 576      :initarg :internal-reader-function
 577      :accessor slot-definition-internal-reader-function)
 578    (internal-writer-function
 579      :initform nil
 580      :initarg :internal-writer-function
 581      :accessor slot-definition-internal-writer-function)))
 582
 583 (defclass direct-slot-definition (slot-definition)
 584   ())
 585
 586 (defclass effective-slot-definition (slot-definition)
 587   ((reader-function ; (lambda (object) ...)
 588     :accessor slot-definition-reader-function)
 589    (writer-function ; (lambda (new-value object) ...)
 590     :accessor slot-definition-writer-function)
 591    (boundp-function ; (lambda (object) ...)
 592     :accessor slot-definition-boundp-function)
 593    (accessor-flags
 594     :initform 0)))
 595
 596 (defclass standard-direct-slot-definition (standard-slot-definition
 597                                            direct-slot-definition)
 598   ())
 599
 600 (defclass standard-effective-slot-definition (standard-slot-definition
 601                                               effective-slot-definition)
 602   ((location ; nil, a fixnum, a cons: (slot-name . value)
 603     :initform nil
 604     :accessor slot-definition-location)))
 605
 606 (defclass condition-direct-slot-definition (condition-slot-definition
 607                                             direct-slot-definition)
 608   ())
 609
 610 (defclass condition-effective-slot-definition (condition-slot-definition
 611                                                effective-slot-definition)
 612   ())
 613
 614 (defclass structure-direct-slot-definition (structure-slot-definition
 615                                             direct-slot-definition)
 616   ())
 617
 618 (defclass structure-effective-slot-definition (structure-slot-definition
 619                                                effective-slot-definition)
 620   ())
 621
 622 (defclass method (standard-object) ())
 623
 624 (defclass standard-method (definition-source-mixin plist-mixin method)
 625   ((generic-function
 626     :initform nil
 627     :accessor method-generic-function)
 628 ;;;     (qualifiers
 629 ;;;     :initform ()
 630 ;;;     :initarg  :qualifiers
 631 ;;;     :reader method-qualifiers)
 632    (specializers
 633     :initform ()
 634     :initarg  :specializers
 635     :reader method-specializers)
 636    (lambda-list
 637     :initform ()
 638     :initarg  :lambda-list
 639     :reader method-lambda-list)
 640    (function
 641     :initform nil
 642     :initarg :function)                 ;no writer
 643    (fast-function
 644     :initform nil
 645     :initarg :fast-function             ;no writer
 646     :reader method-fast-function)
 647    (documentation
 648     :initform nil
 649     :initarg :documentation)))
 650
 651 (defclass standard-accessor-method (standard-method)
 652   ((slot-name :initform nil
 653               :initarg :slot-name
 654               :reader accessor-method-slot-name)
 655    (slot-definition :initform nil
 656                     :initarg :slot-definition
 657                     :reader accessor-method-slot-definition)))
 658
 659 (defclass standard-reader-method (standard-accessor-method) ())
 660
 661 (defclass standard-writer-method (standard-accessor-method) ())
 662
 663 (defclass standard-boundp-method (standard-accessor-method) ())
 664
 665 (defclass generic-function (dependent-update-mixin
 666                             definition-source-mixin
 667                             funcallable-standard-object)
 668   ((documentation
 669     :initform nil
 670     :initarg :documentation)
 671    ;; We need to make a distinction between the methods initially set
 672    ;; up by :METHOD options to DEFGENERIC and the ones set up later by
 673    ;; DEFMETHOD, because ANSI specifies that executing DEFGENERIC on
 674    ;; an already-DEFGENERICed function clears the methods set by the
 675    ;; previous DEFGENERIC, but not methods set by DEFMETHOD. (Making
 676    ;; this distinction seems a little kludgy, but it has the positive
 677    ;; effect of making it so that loading a file a.lisp containing
 678    ;; DEFGENERIC, then loading a second file b.lisp containing
 679    ;; DEFMETHOD, then modifying and reloading a.lisp and/or b.lisp
 680    ;; tends to leave the generic function in a state consistent with
 681    ;; the most-recently-loaded state of a.lisp and b.lisp.)
 682    (initial-methods
 683     :initform ()
 684     :accessor generic-function-initial-methods))
 685   (:metaclass funcallable-standard-class))
 686
 687 (defclass standard-generic-function (generic-function)
 688   ((name
 689     :initform nil
 690     :initarg :name
 691     :accessor generic-function-name)
 692    (methods
 693     :initform ()
 694     :accessor generic-function-methods
 695     :type list)
 696    (method-class
 697     :initarg :method-class
 698     :accessor generic-function-method-class)
 699    (method-combination
 700     :initarg :method-combination
 701     :accessor generic-function-method-combination)
 702    (declarations
 703     ;; KLUDGE: AMOP specifies :DECLARATIONS, while ANSI specifies
 704     ;; :DECLARE.  Allow either (but FIXME: maybe a note or a warning
 705     ;; might be appropriate).
 706     :initarg :declarations
 707     :initarg :declare
 708     :initform ()
 709     :accessor generic-function-declarations)
 710    (arg-info
 711     :initform (make-arg-info)
 712     :reader gf-arg-info)
 713    (dfun-state
 714     :initform ()
 715     :accessor gf-dfun-state))
 716   (:metaclass funcallable-standard-class)
 717   (:default-initargs :method-class *the-class-standard-method*
 718                      :method-combination *standard-method-combination*))
 719
 720 (defclass method-combination (standard-object)
 721   ((documentation
 722     :reader method-combination-documentation
 723     :initform nil
 724     :initarg :documentation)))
 725
 726 (defclass standard-method-combination (definition-source-mixin
 727                                        method-combination)
 728   ((type
 729     :reader method-combination-type
 730     :initarg :type)
 731    (options
 732     :reader method-combination-options
 733     :initarg :options)))
 734
 735 (defclass long-method-combination (standard-method-combination)
 736   ((function
 737     :initarg :function
 738     :reader long-method-combination-function)
 739    (args-lambda-list
 740     :initarg :args-lambda-list
 741     :reader long-method-combination-args-lambda-list)))
 742
 743 (defparameter *early-class-predicates*
 744   '((specializer specializerp)
 745     (exact-class-specializer exact-class-specializer-p)
 746     (class-eq-specializer class-eq-specializer-p)
 747     (eql-specializer eql-specializer-p)
 748     (class classp)
 749     (slot-class slot-class-p)
 750     (std-class std-class-p)
 751     (standard-class standard-class-p)
 752     (funcallable-standard-class funcallable-standard-class-p)
 753     (condition-class condition-class-p)
 754     (structure-class structure-class-p)
 755     (forward-referenced-class forward-referenced-class-p)
 756     (method method-p)
 757     (standard-method standard-method-p)
 758     (standard-accessor-method standard-accessor-method-p)
 759     (standard-reader-method standard-reader-method-p)
 760     (standard-writer-method standard-writer-method-p)
 761     (standard-boundp-method standard-boundp-method-p)
 762     (generic-function generic-function-p)
 763     (standard-generic-function standard-generic-function-p)
 764     (method-combination method-combination-p)
 765     (long-method-combination long-method-combination-p)))
 766