src/pcl/init.lisp

   1 ;;;; This file defines the initialization and related protocols.
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5
   6 ;;;; This software is derived from software originally released by Xerox
   7 ;;;; Corporation. Copyright and release statements follow. Later modifications
   8 ;;;; to the software are in the public domain and are provided with
   9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
  10 ;;;; information.
  11
  12 ;;;; copyright information from original PCL sources:
  13 ;;;;
  14 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  15 ;;;; All rights reserved.
  16 ;;;;
  17 ;;;; Use and copying of this software and preparation of derivative works based
  18 ;;;; upon this software are permitted. Any distribution of this software or
  19 ;;;; derivative works must comply with all applicable United States export
  20 ;;;; control laws.
  21 ;;;;
  22 ;;;; This software is made available AS IS, and Xerox Corporation makes no
  23 ;;;; warranty about the software, its performance or its conformity to any
  24 ;;;; specification.
  25
  26 (in-package "SB-PCL")
  27 \f
  28 (defmethod make-instance ((class symbol) &rest initargs)
  29   (apply #'make-instance (find-class class) initargs))
  30
  31 (defmethod make-instance ((class class) &rest initargs)
  32   (let ((instance-or-nil (maybe-call-ctor class initargs)))
  33     (when instance-or-nil
  34       (return-from make-instance instance-or-nil)))
  35   (unless (class-finalized-p class) (finalize-inheritance class))
  36   (let ((class-default-initargs (class-default-initargs class)))
  37     (when class-default-initargs
  38       (setf initargs (default-initargs initargs class-default-initargs)))
  39     (when initargs
  40       (when (eq **boot-state** 'complete)
  41         (check-mi-initargs class initargs)))
  42     (let ((instance (apply #'allocate-instance class initargs)))
  43       (apply #'initialize-instance instance initargs)
  44       instance)))
  45
  46 (defun default-initargs (supplied-initargs class-default-initargs)
  47   (loop for (key nil fun) in class-default-initargs
  48         when (eq (getf supplied-initargs key '.not-there.) '.not-there.)
  49           append (list key (funcall fun)) into default-initargs
  50         finally
  51           (return (append supplied-initargs default-initargs))))
  52
  53 (defmethod initialize-instance ((instance slot-object) &rest initargs)
  54   (apply #'shared-initialize instance t initargs))
  55
  56 (defmethod reinitialize-instance ((instance slot-object) &rest initargs)
  57   ;; the ctor machinery allows us to track when memoization of
  58   ;; validity of initargs should be cleared.
  59   (check-ri-initargs instance initargs)
  60   (apply #'shared-initialize instance nil initargs)
  61   instance)
  62
  63 (defglobal **typecheck-cache** (make-hash-table :test #'equal :synchronized t))
  64 (defvar *typecheck-stack* nil)
  65
  66 (defun generate-slotd-typecheck (slotd info)
  67   (let* ((type (slot-definition-type slotd))
  68          (class (slot-definition-class slotd))
  69          (cookie (cons class (slot-definition-name slotd))))
  70     (declare (dynamic-extent cookie))
  71     (when (and (neq t type) (safe-p class))
  72       (or
  73        ;; Have one already!
  74        (awhen (gethash type **typecheck-cache**)
  75          (setf (slot-info-typecheck info) it))
  76        ;; It is possible for compilation of a typecheck to trigger class
  77        ;; finalization, which in turn may trigger compilation of a
  78        ;; slot-typechecking function -- detects and break those cycles.
  79        ;;
  80        ;; We use the slow function here, but the outer call will replace it
  81        ;; with the fast one.
  82        (when (member cookie *typecheck-stack* :test #'equal)
  83          (setf (slot-info-typecheck info)
  84                (named-lambda slow-slot-typecheck (value)
  85                        (if (typep value type)
  86                            value
  87                            (error 'type-error
  88                                   :datum value
  89                                   :expected-type type)))))
  90        ;; The normal, good case: compile an efficient typecheck function.
  91        (let ((*typecheck-stack* (cons cookie *typecheck-stack*)))
  92          (handler-bind (((or style-warning compiler-note) #'muffle-warning))
  93            (let ((fun (compile
  94                        nil
  95                        `(named-lambda (slot-typecheck ,type) (value)
  96                           (declare (optimize (sb-c:store-coverage-data 0)
  97                                              (sb-c::type-check 3)
  98                                              (sb-c::verify-arg-count 0)))
  99                           (the ,type value)))))
 100              (setf (gethash type **typecheck-cache**) fun
 101                    (slot-info-typecheck info) fun))))))))
 102
 103 (define-condition slotd-initialization-error (reference-condition error)
 104   ((initarg :initarg :initarg :reader slotd-initialization-error-initarg)
 105    (kind :initarg :kind :reader slotd-initialization-error-kind)
 106    (value :initarg :value :initform nil :reader slotd-initialization-error-value))
 107   (:default-initargs :references (list '(:amop :initialization slot-definition)))
 108   (:report (lambda (condition stream)
 109              (let ((initarg (slotd-initialization-error-initarg condition))
 110                    (kind (slotd-initialization-error-kind condition))
 111                    (value (slotd-initialization-error-value condition)))
 112                (format stream
 113                        "~@<Invalid ~S initialization: the initialization ~
 114                         argument ~S was ~
 115                         ~[missing~*~;not a symbol: ~S~;constant: ~S~].~@:>"
 116                        'slot-definition initarg
 117                        (getf '(:missing 0 :symbol 1 :constant 2) kind)
 118                        value)))))
 119
 120 (define-condition slotd-initialization-type-error (slotd-initialization-error type-error)
 121   ((value :initarg :datum))
 122   (:report (lambda (condition stream)
 123              (let ((initarg (slotd-initialization-error-initarg condition))
 124                    (datum (type-error-datum condition))
 125                    (expected-type (type-error-expected-type condition)))
 126                (format stream
 127                        "~@<Invalid ~S initialization: the initialization ~
 128                         argument ~S was ~S, which is not of type ~S.~@:>"
 129                        'slot-definition initarg
 130                        datum expected-type)))))
 131
 132 (defmethod initialize-instance :before ((slotd slot-definition)
 133                                         &key (name nil namep)
 134                                           (initform nil initformp)
 135                                           (initfunction nil initfunp)
 136                                           (type nil typep)
 137                                           (allocation nil allocationp)
 138                                           (initargs nil initargsp)
 139                                           (documentation nil docp))
 140   (unless namep
 141     (error 'slotd-initialization-error :initarg :name :kind :missing))
 142   (unless (symbolp name)
 143     (error 'slotd-initialization-type-error :initarg :name :datum name :expected-type 'symbol))
 144   (when (and (constantp name)
 145              ;; KLUDGE: names of structure slots are weird, and their
 146              ;; weird behaviour gets grandfathered in this way.  (The
 147              ;; negative constraint is hard to express in normal
 148              ;; CLOS method terms).
 149              (not (typep slotd 'structure-slot-definition)))
 150     (error 'slotd-initialization-error :initarg :name :kind :constant :value name))
 151   (when (and initformp (not initfunp))
 152     (error 'slotd-initialization-error :initarg :initfunction :kind :missing))
 153   (when (and initfunp (not initformp))
 154     (error 'slotd-initialization-error :initarg :initform :kind :missing))
 155   (when (and typep (not t))
 156     ;; FIXME: do something.  Need SYNTACTICALLY-VALID-TYPE-SPECIFIER-P
 157     )
 158   (when (and allocationp (not (symbolp allocation)))
 159     (error 'slotd-initialization-type-error :initarg :allocation :datum allocation :expected-type 'symbol))
 160   (when initargsp
 161     (unless (typep initargs 'list)
 162       (error 'slotd-initialization-type-error :initarg :initarg :datum initargs :expected-type 'list))
 163     (do ((is initargs (cdr is)))
 164         ((atom is)
 165          (unless (null is)
 166            (error 'slotd-initialization-type-error :initarg :initarg :datum initargs :expected-type '(satisfies proper-list-p))))
 167       (unless (symbolp (car is))
 168         (error 'slotd-initialization-type-error :initarg :initarg :datum is :expected-type '(or null (cons symbol))))))
 169   (when docp
 170     (unless (typep documentation '(or null string))
 171       (error 'slotd-initialization-type-error :initarg :documentation :datum documentation :expected-type '(or null string)))))
 172
 173 (defmethod initialize-instance :before ((dslotd direct-slot-definition)
 174                                         &key
 175                                           (readers nil readersp)
 176                                           (writers nil writersp))
 177   (macrolet ((check (arg argp)
 178                `(when ,argp
 179                   (unless (typep ,arg 'list)
 180                     (error 'slotd-initialization-type-error
 181                            :initarg ,(keywordicate arg)
 182                            :datum ,arg :expected-type 'list))
 183                   (do ((as ,arg (cdr as)))
 184                       ((atom as)
 185                        (unless (null as)
 186                          (error 'slotd-initialization-type-error
 187                                 :initarg ,(keywordicate arg)
 188                                 :datum ,arg :expected-type '(satisfies proper-list-p))))
 189                     (unless (valid-function-name-p (car as))
 190                       (error 'slotd-initialization-type-error
 191                              :initarg ,(keywordicate arg)
 192                              :datum ,arg :expected-type '(or null (cons (satisfies valid-function-name-p)))))))))
 193     (check readers readersp)
 194     (check writers writersp)))
 195
 196 (defmethod initialize-instance :after ((slotd effective-slot-definition) &key)
 197   (let ((info (make-slot-info :slotd slotd)))
 198     (generate-slotd-typecheck slotd info)
 199     (setf (slot-definition-info slotd) info)))
 200
 201 ;;; FIXME: Do we need (SETF SLOT-DEFINITION-TYPE) at all?
 202 (defmethod (setf slot-definition-type) :after (new-type (slotd effective-slot-definition))
 203   (generate-slotd-typecheck slotd (slot-definition-info slotd)))
 204
 205 (defmethod update-instance-for-different-class
 206     ((previous standard-object) (current standard-object) &rest initargs)
 207   ;; First we must compute the newly added slots. The spec defines
 208   ;; newly added slots as "those local slots for which no slot of
 209   ;; the same name exists in the previous class."
 210   (let ((added-slots '())
 211         (current-slotds (class-slots (class-of current)))
 212         (previous-slot-names (mapcar #'slot-definition-name
 213                                      (class-slots (class-of previous)))))
 214     (dolist (slotd current-slotds)
 215       (if (and (not (memq (slot-definition-name slotd) previous-slot-names))
 216                (eq (slot-definition-allocation slotd) :instance))
 217           (push (slot-definition-name slotd) added-slots)))
 218     (check-initargs-1
 219      (class-of current) initargs
 220      (list (list* 'update-instance-for-different-class previous current initargs)
 221            (list* 'shared-initialize current added-slots initargs)))
 222     (apply #'shared-initialize current added-slots initargs)))
 223
 224 (defmethod update-instance-for-redefined-class
 225     ((instance standard-object) added-slots discarded-slots property-list
 226      &rest initargs)
 227   (check-initargs-1
 228    (class-of instance) initargs
 229    (list (list* 'update-instance-for-redefined-class
 230                 instance added-slots discarded-slots property-list initargs)
 231          (list* 'shared-initialize instance added-slots initargs)))
 232   (apply #'shared-initialize instance added-slots initargs))
 233
 234 (defmethod shared-initialize ((instance slot-object) slot-names &rest initargs)
 235   (flet ((initialize-slot-from-initarg (class instance slotd)
 236            (let ((slot-initargs (slot-definition-initargs slotd)))
 237              (doplist (initarg value) initargs
 238                (when (memq initarg slot-initargs)
 239                  (setf (slot-value-using-class class instance slotd)
 240                        value)
 241                  (return t)))))
 242          (initialize-slot-from-initfunction (class instance slotd)
 243            ;; CLHS: If a before method stores something in a slot,
 244            ;; that slot won't be initialized from its :INITFORM, if any.
 245            (let ((initfun (slot-definition-initfunction slotd)))
 246              (if (typep instance 'structure-object)
 247                  ;; We don't have a consistent unbound marker for structure
 248                  ;; object slots, and structure object redefinition is not
 249                  ;; really supported anyways -- so unconditionally
 250                  ;; initializing the slot should be fine.
 251                  (when initfun
 252                    (setf (slot-value-using-class class instance slotd)
 253                          (funcall initfun)))
 254                  (unless (or (not initfun)
 255                              (slot-boundp-using-class class instance slotd))
 256                    (setf (slot-value-using-class class instance slotd)
 257                          (funcall initfun)))))))
 258     (let* ((class (class-of instance))
 259            (initfn-slotds
 260             (loop for slotd in (class-slots class)
 261                   unless (initialize-slot-from-initarg class instance slotd)
 262                   collect slotd)))
 263       (dolist (slotd initfn-slotds)
 264         (when (or (eq t slot-names)
 265                   (memq (slot-definition-name slotd) slot-names))
 266           (initialize-slot-from-initfunction class instance slotd))))
 267     instance))
 268 \f
 269 ;;; If initargs are valid return nil, otherwise signal an error.
 270 (defun check-initargs-1 (class initargs call-list
 271                          &optional (plist-p t) (error-p t))
 272   (multiple-value-bind (legal allow-other-keys)
 273       (check-initargs-values class call-list)
 274     (unless allow-other-keys
 275       (if plist-p
 276           (check-initargs-2-plist initargs class legal error-p)
 277           (check-initargs-2-list initargs class legal error-p)))))
 278
 279 (defun check-initargs-values (class call-list)
 280   (let ((methods (mapcan (lambda (call)
 281                            (if (consp call)
 282                                (copy-list (compute-applicable-methods
 283                                            (gdefinition (car call))
 284                                            (cdr call)))
 285                                (list call)))
 286                          call-list))
 287         (legal (apply #'append (mapcar #'slot-definition-initargs
 288                                        (class-slots class)))))
 289     ;; Add to the set of slot-filling initargs the set of
 290     ;; initargs that are accepted by the methods. If at
 291     ;; any point we come across &allow-other-keys, we can
 292     ;; just quit.
 293     (dolist (method methods)
 294       (multiple-value-bind (nreq nopt keysp restp allow-other-keys keys)
 295           (analyze-lambda-list (if (consp method)
 296                                    (early-method-lambda-list method)
 297                                    (method-lambda-list method)))
 298         (declare (ignore nreq nopt keysp restp))
 299         (when allow-other-keys
 300           (return-from check-initargs-values (values nil t)))
 301         (setq legal (append keys legal))))
 302     (values legal nil)))
 303
 304 (define-condition initarg-error (reference-condition program-error)
 305   ((class :reader initarg-error-class :initarg :class)
 306    (initargs :reader initarg-error-initargs :initarg :initargs))
 307   (:default-initargs :references (list '(:ansi-cl :section (7 1 2))))
 308   (:report (lambda (condition stream)
 309              (format stream "~@<Invalid initialization argument~P: ~2I~_~
 310                              ~<~{~S~^, ~} ~@:>~I~_in call for class ~S.~:>"
 311                      (length (initarg-error-initargs condition))
 312                      (list (initarg-error-initargs condition))
 313                      (initarg-error-class condition)))))
 314
 315 (defun check-initargs-2-plist (initargs class legal &optional (error-p t))
 316   (let ((invalid-keys ()))
 317     (unless (getf initargs :allow-other-keys)
 318       ;; Now check the supplied-initarg-names and the default initargs
 319       ;; against the total set that we know are legal.
 320       (doplist (key val) initargs
 321         (unless (or (memq key legal)
 322                     ;; :ALLOW-OTHER-KEYS NIL gets here
 323                     (eq key :allow-other-keys))
 324           (push key invalid-keys)))
 325       (when (and invalid-keys error-p)
 326         (error 'initarg-error :class class :initargs invalid-keys)))
 327     invalid-keys))
 328
 329 (defun check-initargs-2-list (initkeys class legal &optional (error-p t))
 330   (let ((invalid-keys ()))
 331     (unless (memq :allow-other-keys initkeys)
 332       ;; Now check the supplied-initarg-names and the default initargs
 333       ;; against the total set that we know are legal.
 334       (dolist (key initkeys)
 335         (unless (memq key legal)
 336           (push key invalid-keys)))
 337       (when (and invalid-keys error-p)
 338         (error 'initarg-error :class class :initargs invalid-keys)))
 339     invalid-keys))
 340