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 (constantp name)
 145     (error 'slotd-initialization-error :initarg :name :kind :constant :value name))
 146   (when (and initformp (not initfunp))
 147     (error 'slotd-initialization-error :initarg :initfunction :kind :missing))
 148   (when (and initfunp (not initformp))
 149     (error 'slotd-initialization-error :initarg :initform :kind :missing))
 150   (when (and typep (not t))
 151     ;; FIXME: do something.  Need SYNTACTICALLY-VALID-TYPE-SPECIFIER-P
 152     )
 153   (when (and allocationp (not (symbolp allocation)))
 154     (error 'slotd-initialization-type-error :initarg :allocation :datum allocation :expected-type 'symbol))
 155   (when initargsp
 156     (unless (typep initargs 'list)
 157       (error 'slotd-initialization-type-error :initarg :initarg :datum initargs :expected-type 'list))
 158     (do ((is initargs (cdr is)))
 159         ((atom is)
 160          (unless (null is)
 161            (error 'slotd-initialization-type-error :initarg :initarg :datum initargs :expected-type '(satisfies proper-list-p))))
 162       (unless (symbolp (car is))
 163         (error 'slotd-initialization-type-error :initarg :initarg :datum is :expected-type '(or null (cons symbol))))))
 164   (when docp
 165     (unless (typep documentation '(or null string))
 166       (error 'slotd-initialization-type-error :initarg :documentation :datum documentation :expected-type '(or null string)))))
 167
 168 (defmethod initialize-instance :before ((dslotd direct-slot-definition)
 169                                         &key
 170                                           (readers nil readersp)
 171                                           (writers nil writersp))
 172   (macrolet ((check (arg argp)
 173                `(when ,argp
 174                   (unless (typep ,arg 'list)
 175                     (error 'slotd-initialization-type-error
 176                            :initarg ,(keywordicate arg)
 177                            :datum ,arg :expected-type 'list))
 178                   (do ((as ,arg (cdr as)))
 179                       ((atom as)
 180                        (unless (null as)
 181                          (error 'slotd-initialization-type-error
 182                                 :initarg ,(keywordicate arg)
 183                                 :datum ,arg :expected-type '(satisfies proper-list-p))))
 184                     (unless (valid-function-name-p (car as))
 185                       (error 'slotd-initialization-type-error
 186                              :initarg ,(keywordicate arg)
 187                              :datum ,arg :expected-type '(or null (cons (satisfies valid-function-name-p)))))))))
 188     (check readers readersp)
 189     (check writers writersp)))
 190
 191 (defmethod initialize-instance :after ((slotd effective-slot-definition) &key)
 192   (let ((info (make-slot-info :slotd slotd)))
 193     (generate-slotd-typecheck slotd info)
 194     (setf (slot-definition-info slotd) info)))
 195
 196 ;;; FIXME: Do we need (SETF SLOT-DEFINITION-TYPE) at all?
 197 (defmethod (setf slot-definition-type) :after (new-type (slotd effective-slot-definition))
 198   (generate-slotd-typecheck slotd (slot-definition-info slotd)))
 199
 200 (defmethod update-instance-for-different-class
 201     ((previous standard-object) (current standard-object) &rest initargs)
 202   ;; First we must compute the newly added slots. The spec defines
 203   ;; newly added slots as "those local slots for which no slot of
 204   ;; the same name exists in the previous class."
 205   (let ((added-slots '())
 206         (current-slotds (class-slots (class-of current)))
 207         (previous-slot-names (mapcar #'slot-definition-name
 208                                      (class-slots (class-of previous)))))
 209     (dolist (slotd current-slotds)
 210       (if (and (not (memq (slot-definition-name slotd) previous-slot-names))
 211                (eq (slot-definition-allocation slotd) :instance))
 212           (push (slot-definition-name slotd) added-slots)))
 213     (check-initargs-1
 214      (class-of current) initargs
 215      (list (list* 'update-instance-for-different-class previous current initargs)
 216            (list* 'shared-initialize current added-slots initargs)))
 217     (apply #'shared-initialize current added-slots initargs)))
 218
 219 (defmethod update-instance-for-redefined-class
 220     ((instance standard-object) added-slots discarded-slots property-list
 221      &rest initargs)
 222   (check-initargs-1
 223    (class-of instance) initargs
 224    (list (list* 'update-instance-for-redefined-class
 225                 instance added-slots discarded-slots property-list initargs)
 226          (list* 'shared-initialize instance added-slots initargs)))
 227   (apply #'shared-initialize instance added-slots initargs))
 228
 229 (defmethod shared-initialize ((instance slot-object) slot-names &rest initargs)
 230   (flet ((initialize-slot-from-initarg (class instance slotd)
 231            (let ((slot-initargs (slot-definition-initargs slotd)))
 232              (doplist (initarg value) initargs
 233                (when (memq initarg slot-initargs)
 234                  (setf (slot-value-using-class class instance slotd)
 235                        value)
 236                  (return t)))))
 237          (initialize-slot-from-initfunction (class instance slotd)
 238            ;; CLHS: If a before method stores something in a slot,
 239            ;; that slot won't be initialized from its :INITFORM, if any.
 240            (let ((initfun (slot-definition-initfunction slotd)))
 241              (if (typep instance 'structure-object)
 242                  ;; We don't have a consistent unbound marker for structure
 243                  ;; object slots, and structure object redefinition is not
 244                  ;; really supported anyways -- so unconditionally
 245                  ;; initializing the slot should be fine.
 246                  (when initfun
 247                    (setf (slot-value-using-class class instance slotd)
 248                          (funcall initfun)))
 249                  (unless (or (not initfun)
 250                              (slot-boundp-using-class class instance slotd))
 251                    (setf (slot-value-using-class class instance slotd)
 252                          (funcall initfun)))))))
 253     (let* ((class (class-of instance))
 254            (initfn-slotds
 255             (loop for slotd in (class-slots class)
 256                   unless (initialize-slot-from-initarg class instance slotd)
 257                   collect slotd)))
 258       (dolist (slotd initfn-slotds)
 259         (when (or (eq t slot-names)
 260                   (memq (slot-definition-name slotd) slot-names))
 261           (initialize-slot-from-initfunction class instance slotd))))
 262     instance))
 263 \f
 264 ;;; If initargs are valid return nil, otherwise signal an error.
 265 (defun check-initargs-1 (class initargs call-list
 266                          &optional (plist-p t) (error-p t))
 267   (multiple-value-bind (legal allow-other-keys)
 268       (check-initargs-values class call-list)
 269     (unless allow-other-keys
 270       (if plist-p
 271           (check-initargs-2-plist initargs class legal error-p)
 272           (check-initargs-2-list initargs class legal error-p)))))
 273
 274 (defun check-initargs-values (class call-list)
 275   (let ((methods (mapcan (lambda (call)
 276                            (if (consp call)
 277                                (copy-list (compute-applicable-methods
 278                                            (gdefinition (car call))
 279                                            (cdr call)))
 280                                (list call)))
 281                          call-list))
 282         (legal (apply #'append (mapcar #'slot-definition-initargs
 283                                        (class-slots class)))))
 284     ;; Add to the set of slot-filling initargs the set of
 285     ;; initargs that are accepted by the methods. If at
 286     ;; any point we come across &allow-other-keys, we can
 287     ;; just quit.
 288     (dolist (method methods)
 289       (multiple-value-bind (nreq nopt keysp restp allow-other-keys keys)
 290           (analyze-lambda-list (if (consp method)
 291                                    (early-method-lambda-list method)
 292                                    (method-lambda-list method)))
 293         (declare (ignore nreq nopt keysp restp))
 294         (when allow-other-keys
 295           (return-from check-initargs-values (values nil t)))
 296         (setq legal (append keys legal))))
 297     (values legal nil)))
 298
 299 (define-condition initarg-error (reference-condition program-error)
 300   ((class :reader initarg-error-class :initarg :class)
 301    (initargs :reader initarg-error-initargs :initarg :initargs))
 302   (:default-initargs :references (list '(:ansi-cl :section (7 1 2))))
 303   (:report (lambda (condition stream)
 304              (format stream "~@<Invalid initialization argument~P: ~2I~_~
 305                              ~<~{~S~^, ~} ~@:>~I~_in call for class ~S.~:>"
 306                      (length (initarg-error-initargs condition))
 307                      (list (initarg-error-initargs condition))
 308                      (initarg-error-class condition)))))
 309
 310 (defun check-initargs-2-plist (initargs class legal &optional (error-p t))
 311   (let ((invalid-keys ()))
 312     (unless (getf initargs :allow-other-keys)
 313       ;; Now check the supplied-initarg-names and the default initargs
 314       ;; against the total set that we know are legal.
 315       (doplist (key val) initargs
 316         (unless (or (memq key legal)
 317                     ;; :ALLOW-OTHER-KEYS NIL gets here
 318                     (eq key :allow-other-keys))
 319           (push key invalid-keys)))
 320       (when (and invalid-keys error-p)
 321         (error 'initarg-error :class class :initargs invalid-keys)))
 322     invalid-keys))
 323
 324 (defun check-initargs-2-list (initkeys class legal &optional (error-p t))
 325   (let ((invalid-keys ()))
 326     (unless (memq :allow-other-keys initkeys)
 327       ;; Now check the supplied-initarg-names and the default initargs
 328       ;; against the total set that we know are legal.
 329       (dolist (key initkeys)
 330         (unless (memq key legal)
 331           (push key invalid-keys)))
 332       (when (and invalid-keys error-p)
 333         (error 'initarg-error :class class :initargs invalid-keys)))
 334     invalid-keys))
 335