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