src/pcl/defclass.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 ;;;; DEFCLASS macro and close personal friends
  27
  28 ;;; state for the current DEFCLASS expansion
  29 (defvar *initfunctions-for-this-defclass*)
  30 (defvar *readers-for-this-defclass*)
  31 (defvar *writers-for-this-defclass*)
  32 (defvar *slot-names-for-this-defclass*)
  33
  34 ;;; Like the DEFMETHOD macro, the expansion of the DEFCLASS macro is
  35 ;;; fixed. DEFCLASS always expands into a call to LOAD-DEFCLASS. Until
  36 ;;; the meta-braid is set up, LOAD-DEFCLASS has a special definition
  37 ;;; which simply collects all class definitions up, when the metabraid
  38 ;;; is initialized it is done from those class definitions.
  39 ;;;
  40 ;;; After the metabraid has been setup, and the protocol for defining
  41 ;;; classes has been defined, the real definition of LOAD-DEFCLASS is
  42 ;;; installed by the file std-class.lisp
  43 (defmacro defclass (&environment env name direct-superclasses direct-slots &rest options)
  44   (let (*initfunctions-for-this-defclass*
  45         *readers-for-this-defclass* ;Truly a crock, but we got
  46         *writers-for-this-defclass* ;to have it to live nicely.
  47         *slot-names-for-this-defclass*)
  48     ;; FIXME: It would be nice to collect all errors from the
  49     ;; expansion of a defclass and signal them in a single go.
  50     (multiple-value-bind (metaclass canonical-options)
  51         (canonize-defclass-options name options)
  52     (let ((canonical-slots (canonize-defclass-slots name direct-slots env))
  53           ;; DEFSTRUCT-P should be true if the class is defined
  54           ;; with a metaclass STRUCTURE-CLASS, so that a DEFSTRUCT
  55           ;; is compiled for the class.
  56           (defstruct-p (and (eq **boot-state** 'complete)
  57                             (let ((mclass (find-class metaclass nil)))
  58                               (and mclass
  59                                    (*subtypep
  60                                     mclass
  61                                     *the-class-structure-class*))))))
  62       (let* ((defclass-form
  63               `(let ,(mapcar #'cdr *initfunctions-for-this-defclass*)
  64                  (load-defclass ',name
  65                                 ',metaclass
  66                                 ',direct-superclasses
  67                                 (list ,@canonical-slots)
  68                                 (list ,@(apply #'append
  69                                                (when defstruct-p
  70                                                  '(:from-defclass-p t))
  71                                                 canonical-options))
  72                                 ',*readers-for-this-defclass*
  73                                 ',*writers-for-this-defclass*
  74                                 ',*slot-names-for-this-defclass*
  75                                 (sb-c:source-location)
  76                                 ',(safe-code-p env)))))
  77         (if defstruct-p
  78             (progn
  79               ;; FIXME: (YUK!) Why do we do this? Because in order
  80               ;; to make the defstruct form, we need to know what
  81               ;; the accessors for the slots are, so we need already
  82               ;; to have hooked into the CLOS machinery.
  83               ;;
  84               ;; There may be a better way to do this: it would
  85               ;; involve knowing enough about PCL to ask "what will
  86               ;; my slot names and accessors be"; failing this, we
  87               ;; currently just evaluate the whole kaboodle, and
  88               ;; then use CLASS-DIRECT-SLOTS. -- CSR, 2002-06-07
  89               (eval defclass-form)
  90               (let* ((include (or (and direct-superclasses
  91                                        (find-class (car direct-superclasses) nil))
  92                                   (and (not (eq name 'structure-object))
  93                                        *the-class-structure-object*)))
  94                      (defstruct-form (make-structure-class-defstruct-form
  95                                       name (class-direct-slots (find-class name))
  96                                       include)))
  97                 `(progn
  98                    (eval-when (:compile-toplevel :load-toplevel :execute)
  99                      ,defstruct-form) ; really compile the defstruct-form
 100                    (eval-when (:compile-toplevel :load-toplevel :execute)
 101                      ,defclass-form))))
 102             `(progn
 103                ;; By telling the type system at compile time about
 104                ;; the existence of a class named NAME, we can avoid
 105                ;; various bogus warnings about "type isn't defined yet"
 106                ;; for code elsewhere in the same file which uses
 107                ;; the name of the type.
 108                ;;
 109                ;; We only need to do this at compile time, because
 110                ;; at load and execute time we write the actual
 111                ;; full-blown class, so the "a class of this name is
 112                ;; coming" note we write here would be irrelevant.
 113                (eval-when (:compile-toplevel)
 114                  (%compiler-defclass ',name
 115                                      ',*readers-for-this-defclass*
 116                                      ',*writers-for-this-defclass*
 117                                      ',*slot-names-for-this-defclass*))
 118                ,defclass-form)))))))
 119
 120 (defun canonize-defclass-options (class-name options)
 121   (maplist (lambda (sublist)
 122              (let ((option-name (first (pop sublist))))
 123                (when (member option-name sublist :key #'first :test #'eq)
 124                  (error 'simple-program-error
 125                         :format-control "Multiple ~S options in DEFCLASS ~S."
 126                         :format-arguments (list option-name class-name)))))
 127            options)
 128   (let (metaclass
 129         default-initargs
 130         documentation
 131         canonized-options)
 132       (dolist (option options)
 133         (unless (listp option)
 134           (error "~S is not a legal defclass option." option))
 135         (case (first option)
 136           (:metaclass
 137            (let ((maybe-metaclass (second option)))
 138              (unless (and maybe-metaclass (legal-class-name-p maybe-metaclass))
 139                (error 'simple-program-error
 140                       :format-control "~@<The value of the :metaclass option (~S) ~
 141                          is not a legal class name.~:@>"
 142                       :format-arguments (list maybe-metaclass)))
 143              (setf metaclass maybe-metaclass)))
 144           (:default-initargs
 145            (let (initargs arg-names)
 146              (doplist (key val) (cdr option)
 147                (when (member key arg-names :test #'eq)
 148                  (error 'simple-program-error
 149                         :format-control "~@<Duplicate initialization argument ~
 150                                            name ~S in :DEFAULT-INITARGS of ~
 151                                            DEFCLASS ~S.~:>"
 152                         :format-arguments (list key class-name)))
 153                (push key arg-names)
 154                (push ``(,',key ,',val ,,(make-initfunction val)) initargs))
 155              (setf default-initargs t)
 156              (push `(:direct-default-initargs (list ,@(nreverse initargs)))
 157                    canonized-options)))
 158           (:documentation
 159            (unless (stringp (second option))
 160              (error "~S is not a legal :documentation value" (second option)))
 161            (setf documentation t)
 162            (push `(:documentation ,(second option)) canonized-options))
 163           (otherwise
 164            (push `(',(car option) ',(cdr option)) canonized-options))))
 165       (unless default-initargs
 166         (push '(:direct-default-initargs nil) canonized-options))
 167       (values (or metaclass 'standard-class) (nreverse canonized-options))))
 168
 169 (defun canonize-defclass-slots (class-name slots env)
 170   (let (canonized-specs)
 171     (dolist (spec slots)
 172       (when (atom spec)
 173         (setf spec (list spec)))
 174       (when (and (cdr spec) (null (cddr spec)))
 175         (error 'simple-program-error
 176                :format-control "~@<in DEFCLASS ~S, the slot specification ~S ~
 177                                 is invalid; the probable intended meaning may ~
 178                                 be achieved by specifiying ~S instead.~:>"
 179                :format-arguments (list class-name spec
 180                                        `(,(car spec) :initform ,(cadr spec)))))
 181       (let* ((name (car spec))
 182              (plist (cdr spec))
 183              (readers ())
 184              (writers ())
 185              (initargs ())
 186              (others ())
 187              (unsupplied (list nil))
 188              (type t)
 189              (initform unsupplied))
 190         (check-slot-name-for-defclass name class-name env)
 191         (push name *slot-names-for-this-defclass*)
 192         (flet ((note-reader (x)
 193                  (unless (symbolp x)
 194                    (error 'simple-program-error
 195                           :format-control "Slot reader name ~S for slot ~S in ~
 196                                            DEFCLASS ~S is not a symbol."
 197                           :format-arguments (list x name class-name)))
 198                  (push x readers)
 199                  (push x *readers-for-this-defclass*))
 200                (note-writer (x)
 201                  (push x writers)
 202                  (push x *writers-for-this-defclass*)))
 203           (doplist (key val) plist
 204             (case key
 205               (:accessor (note-reader val) (note-writer `(setf ,val)))
 206               (:reader   (note-reader val))
 207               (:writer   (note-writer val))
 208               (:initarg
 209                (unless (symbolp val)
 210                  (error 'simple-program-error
 211                         :format-control "Slot initarg name ~S for slot ~S in ~
 212                                          DEFCLASS ~S is not a symbol."
 213                         :format-arguments (list val name class-name)))
 214                (push val initargs))
 215               (otherwise
 216                (when (member key '(:initform :allocation :type :documentation))
 217                  (when (eq key :initform)
 218                    (setf initform val))
 219                  (when (eq key :type)
 220                    (setf type val))
 221                  (when (get-properties others (list key))
 222                    (error 'simple-program-error
 223                           :format-control "Duplicate slot option ~S for slot ~
 224                                            ~S in DEFCLASS ~S."
 225                           :format-arguments (list key name class-name))))
 226                ;; For non-standard options multiple entries go in a list
 227                (push val (getf others key))))))
 228         ;; Unwrap singleton lists (AMOP 5.4.2)
 229         (do ((head others (cddr head)))
 230             ((null head))
 231           (unless (cdr (second head))
 232             (setf (second head) (car (second head)))))
 233         (let ((canon `(:name ',name :readers ',readers :writers ',writers
 234                              :initargs ',initargs ',others)))
 235           (push (if (eq initform unsupplied)
 236                     `(list* ,@canon)
 237                     `(list* :initfunction ,(make-initfunction initform)
 238                             ,@canon))
 239                 canonized-specs))))
 240     (nreverse canonized-specs)))
 241
 242
 243 (defun check-slot-name-for-defclass (name class-name env)
 244   (flet ((slot-name-illegal (reason)
 245            (error 'simple-program-error
 246                   :format-control
 247                   (format nil "~~@<In DEFCLASS ~~S, the slot name ~~S ~
 248                                is ~A.~~@:>" reason)
 249                   :format-arguments (list class-name name))))
 250     (cond ((not (symbolp name))
 251            (slot-name-illegal "not a symbol"))
 252           ((keywordp name)
 253            (slot-name-illegal "a keyword"))
 254           ((constantp name env)
 255            (slot-name-illegal "a constant"))
 256           ((member name *slot-names-for-this-defclass* :test #'eq)
 257            (error 'simple-program-error
 258                   :format-control "Multiple slots named ~S in DEFCLASS ~S."
 259                   :format-arguments (list name class-name))))))
 260
 261 (defun make-initfunction (initform)
 262   (cond ((or (eq initform t)
 263              (equal initform ''t))
 264          '(function constantly-t))
 265         ((or (eq initform nil)
 266              (equal initform ''nil))
 267          '(function constantly-nil))
 268         ((or (eql initform 0)
 269              (equal initform ''0))
 270          '(function constantly-0))
 271         (t
 272          (let ((entry (assoc initform *initfunctions-for-this-defclass*
 273                              :test #'equal)))
 274            (unless entry
 275              (setq entry (list initform
 276                                (gensym)
 277                                `(function (lambda ()
 278                                   (declare (optimize
 279                                             (sb-c:store-coverage-data 0)))
 280                                   ,initform))))
 281              (push entry *initfunctions-for-this-defclass*))
 282            (cadr entry)))))
 283
 284 (defun %compiler-defclass (name readers writers slots)
 285   ;; ANSI says (Macro DEFCLASS, section 7.7) that DEFCLASS, if it
 286   ;; "appears as a top level form, the compiler must make the class
 287   ;; name be recognized as a valid type name in subsequent
 288   ;; declarations (as for deftype) and be recognized as a valid class
 289   ;; name for defmethod parameter specializers and for use as the
 290   ;; :metaclass option of a subsequent defclass."
 291   (preinform-compiler-about-class-type name)
 292   (preinform-compiler-about-accessors readers writers slots))
 293
 294 (defun preinform-compiler-about-class-type (name)
 295   ;; Unless the type system already has an actual type attached to
 296   ;; NAME (in which case (1) writing a placeholder value over that
 297   ;; actual type as a compile-time side-effect would probably be a bad
 298   ;; idea and (2) anyway we don't need to modify it in order to make
 299   ;; NAME be recognized as a valid type name)
 300   (with-single-package-locked-error (:symbol name "proclaiming ~S as a class"))
 301   (unless (info :type :kind name)
 302     ;; Tell the compiler to expect a class with the given NAME, by
 303     ;; writing a kind of minimal placeholder type information. This
 304     ;; placeholder will be overwritten later when the class is defined.
 305     (setf (info :type :kind name) :forthcoming-defclass-type))
 306   (values))
 307
 308 (defun preinform-compiler-about-accessors (readers writers slots)
 309   (flet ((inform (names type &key key)
 310            (mapc (lambda (name)
 311                    (let ((name (if key (funcall key name) name)))
 312                      (when (eq (info :function :where-from name) :assumed)
 313                        (sb-c:proclaim-ftype name type :defined))))
 314                  names)))
 315     (let ((rtype (specifier-type '(function (t) t)))
 316           (wtype (specifier-type '(function (t t) t))))
 317       (inform readers rtype)
 318       (inform writers wtype)
 319       (inform slots rtype :key #'slot-reader-name)
 320       (inform slots rtype :key #'slot-boundp-name)
 321       (inform slots wtype :key #'slot-writer-name))))
 322 \f
 323 ;;; This is the early definition of LOAD-DEFCLASS. It just collects up
 324 ;;; all the class definitions in a list. Later, in braid1.lisp, these
 325 ;;; are actually defined.
 326
 327 ;;; Each entry in *EARLY-CLASS-DEFINITIONS* is an EARLY-CLASS-DEFINITION.
 328 (defparameter *early-class-definitions* ())
 329
 330 (defun early-class-definition (class-name)
 331   (or (find class-name *early-class-definitions* :key #'ecd-class-name)
 332       (error "~S is not a class in *early-class-definitions*." class-name)))
 333
 334 (defun make-early-class-definition
 335        (name source-location metaclass
 336         superclass-names canonical-slots other-initargs)
 337   (list 'early-class-definition
 338         name source-location metaclass
 339         superclass-names canonical-slots other-initargs))
 340
 341 (defun ecd-class-name        (ecd) (nth 1 ecd))
 342 (defun ecd-source-location   (ecd) (nth 2 ecd))
 343 (defun ecd-metaclass         (ecd) (nth 3 ecd))
 344 (defun ecd-superclass-names  (ecd) (nth 4 ecd))
 345 (defun ecd-canonical-slots   (ecd) (nth 5 ecd))
 346 (defun ecd-other-initargs    (ecd) (nth 6 ecd))
 347
 348 (defvar *early-class-slots* nil)
 349
 350 (defun canonical-slot-name (canonical-slot)
 351   (getf canonical-slot :name))
 352
 353 (defun early-class-slots (class-name)
 354   (cdr (or (assoc class-name *early-class-slots*)
 355            (let ((a (cons class-name
 356                           (mapcar #'canonical-slot-name
 357                                   (early-collect-inheritance class-name)))))
 358              (push a *early-class-slots*)
 359              a))))
 360
 361 (defun early-class-size (class-name)
 362   (length (early-class-slots class-name)))
 363
 364 (defun early-collect-inheritance (class-name)
 365   ;;(declare (values slots cpl default-initargs direct-subclasses))
 366   (let ((cpl (early-collect-cpl class-name)))
 367     (values (early-collect-slots cpl)
 368             cpl
 369             (early-collect-default-initargs cpl)
 370             (let (collect)
 371               (dolist (definition *early-class-definitions*)
 372                 (when (memq class-name (ecd-superclass-names definition))
 373                   (push (ecd-class-name definition) collect)))
 374               (nreverse collect)))))
 375
 376 (defun early-collect-slots (cpl)
 377   (let* ((definitions (mapcar #'early-class-definition cpl))
 378          (super-slots (mapcar #'ecd-canonical-slots definitions))
 379          (slots (apply #'append (reverse super-slots))))
 380     (dolist (s1 slots)
 381       (let ((name1 (canonical-slot-name s1)))
 382         (dolist (s2 (cdr (memq s1 slots)))
 383           (when (eq name1 (canonical-slot-name s2))
 384             (error "More than one early class defines a slot with the~%~
 385                     name ~S. This can't work because the bootstrap~%~
 386                     object system doesn't know how to compute effective~%~
 387                     slots."
 388                    name1)))))
 389     slots))
 390
 391 (defun early-collect-cpl (class-name)
 392   (labels ((walk (c)
 393              (let* ((definition (early-class-definition c))
 394                     (supers (ecd-superclass-names definition)))
 395                (cons c
 396                      (apply #'append (mapcar #'early-collect-cpl supers))))))
 397     (remove-duplicates (walk class-name) :from-end nil :test #'eq)))
 398
 399 (defun early-collect-default-initargs (cpl)
 400   (let ((default-initargs ()))
 401     (dolist (class-name cpl)
 402       (let* ((definition (early-class-definition class-name))
 403              (others (ecd-other-initargs definition)))
 404         (loop (when (null others) (return nil))
 405               (let ((initarg (pop others)))
 406                 (unless (eq initarg :direct-default-initargs)
 407                  (error "~@<The defclass option ~S is not supported by ~
 408                         the bootstrap object system.~:@>"
 409                         initarg)))
 410               (setq default-initargs
 411                     (nconc default-initargs (reverse (pop others)))))))
 412     (reverse default-initargs)))
 413
 414 (defun !bootstrap-slot-index (class-name slot-name)
 415   (or (position slot-name (early-class-slots class-name))
 416       (error "~S not found" slot-name)))
 417
 418 ;;; !BOOTSTRAP-GET-SLOT and !BOOTSTRAP-SET-SLOT are used to access and
 419 ;;; change the values of slots during bootstrapping. During
 420 ;;; bootstrapping, there are only two kinds of objects whose slots we
 421 ;;; need to access, CLASSes and SLOT-DEFINITIONs. The first argument
 422 ;;; to these functions tells whether the object is a CLASS or a
 423 ;;; SLOT-DEFINITION.
 424 ;;;
 425 ;;; Note that the way this works it stores the slot in the same place
 426 ;;; in memory that the full object system will expect to find it
 427 ;;; later. This is critical to the bootstrapping process, the whole
 428 ;;; changeover to the full object system is predicated on this.
 429 ;;;
 430 ;;; One important point is that the layout of standard classes and
 431 ;;; standard slots must be computed the same way in this file as it is
 432 ;;; by the full object system later.
 433 (defmacro !bootstrap-get-slot (type object slot-name)
 434   `(clos-slots-ref (get-slots ,object)
 435                    (!bootstrap-slot-index ,type ,slot-name)))
 436 (defun !bootstrap-set-slot (type object slot-name new-value)
 437   (setf (!bootstrap-get-slot type object slot-name) new-value))
 438
 439 (defun early-class-name (class)
 440   (!bootstrap-get-slot 'class class 'name))
 441
 442 (defun early-class-precedence-list (class)
 443   (!bootstrap-get-slot 'pcl-class class '%class-precedence-list))
 444
 445 (defun early-class-name-of (instance)
 446   (early-class-name (class-of instance)))
 447
 448 (defun early-class-slotds (class)
 449   (!bootstrap-get-slot 'slot-class class 'slots))
 450
 451 (defun early-slot-definition-name (slotd)
 452   (!bootstrap-get-slot 'standard-effective-slot-definition slotd 'name))
 453
 454 (defun early-slot-definition-location (slotd)
 455   (!bootstrap-get-slot 'standard-effective-slot-definition slotd 'location))
 456
 457 (defun early-slot-definition-info (slotd)
 458   (!bootstrap-get-slot 'standard-effective-slot-definition slotd 'info))
 459
 460 (defun early-accessor-method-slot-name (method)
 461   (!bootstrap-get-slot 'standard-accessor-method method 'slot-name))
 462
 463 (unless (fboundp 'class-name-of)
 464   (setf (symbol-function 'class-name-of)
 465         (symbol-function 'early-class-name-of)))
 466 (unintern 'early-class-name-of)
 467
 468 (defun early-class-direct-subclasses (class)
 469   (!bootstrap-get-slot 'class class 'direct-subclasses))
 470
 471 (declaim (notinline load-defclass))
 472 (defun load-defclass (name metaclass supers canonical-slots canonical-options
 473                       readers writers slot-names source-location safe-p)
 474   ;; SAFE-P is used by REAL-LOAD-DEFCLASS, but can be ignored here, since
 475   ;; during the bootstrap we won't have (SAFETY 3).
 476   (declare (ignore safe-p))
 477   (%compiler-defclass name readers writers slot-names)
 478   (setq supers  (copy-tree supers)
 479         canonical-slots   (copy-tree canonical-slots)
 480         canonical-options (copy-tree canonical-options))
 481   (let ((ecd
 482          (make-early-class-definition name
 483                                       source-location
 484                                       metaclass
 485                                       supers
 486                                       canonical-slots
 487                                       canonical-options))
 488         (existing
 489          (find name *early-class-definitions* :key #'ecd-class-name)))
 490     (setq *early-class-definitions*
 491           (cons ecd (remove existing *early-class-definitions*)))
 492     ecd))