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