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