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