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