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