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))
  64
  65 (defun generate-slotd-typecheck (slotd)
  66   (let ((type (slot-definition-type slotd)))
  67     (values
  68      (when (and (neq t type) (safe-p (slot-definition-class slotd)))
  69        (with-locked-hash-table (**typecheck-cache**)
  70          (or (gethash type **typecheck-cache**)
  71              (setf (gethash type **typecheck-cache**)
  72                    (handler-bind (((or style-warning compiler-note)
  73                                    #'muffle-warning))
  74                      (funcall (compile
  75                                nil
  76                                `(lambda ()
  77                                   (declare (optimize (sb-c:store-coverage-data 0)
  78                                                      (sb-c::type-check 3)
  79                                                      (sb-c::verify-arg-count 0)))
  80                                   (named-lambda (slot-typecheck ,type) (value)
  81                                     (the ,type value))))))))))
  82      type)))
  83
  84 (defmethod initialize-instance :after ((slotd effective-slot-definition) &key)
  85   (setf (slot-definition-info slotd)
  86         (multiple-value-bind (typecheck type) (generate-slotd-typecheck slotd)
  87           (make-slot-info :slotd slotd
  88                           :typecheck typecheck))))
  89
  90 ;;; FIXME: Do we need (SETF SLOT-DEFINITION-TYPE) at all?
  91 (defmethod (setf slot-definition-type) :after (new-type (slotd effective-slot-definition))
  92   (multiple-value-bind (typecheck type) (generate-slotd-typecheck slotd)
  93     (setf (slot-info-typecheck (slot-definition-info slotd)) typecheck)))
  94
  95 (defmethod update-instance-for-different-class
  96     ((previous standard-object) (current standard-object) &rest initargs)
  97   ;; First we must compute the newly added slots. The spec defines
  98   ;; newly added slots as "those local slots for which no slot of
  99   ;; the same name exists in the previous class."
 100   (let ((added-slots '())
 101         (current-slotds (class-slots (class-of current)))
 102         (previous-slot-names (mapcar #'slot-definition-name
 103                                      (class-slots (class-of previous)))))
 104     (dolist (slotd current-slotds)
 105       (if (and (not (memq (slot-definition-name slotd) previous-slot-names))
 106                (eq (slot-definition-allocation slotd) :instance))
 107           (push (slot-definition-name slotd) added-slots)))
 108     (check-initargs-1
 109      (class-of current) initargs
 110      (list (list* 'update-instance-for-different-class previous current initargs)
 111            (list* 'shared-initialize current added-slots initargs)))
 112     (apply #'shared-initialize current added-slots initargs)))
 113
 114 (defmethod update-instance-for-redefined-class
 115     ((instance standard-object) added-slots discarded-slots property-list
 116      &rest initargs)
 117   (check-initargs-1
 118    (class-of instance) initargs
 119    (list (list* 'update-instance-for-redefined-class
 120                 instance added-slots discarded-slots property-list initargs)
 121          (list* 'shared-initialize instance added-slots initargs)))
 122   (apply #'shared-initialize instance added-slots initargs))
 123
 124 (defmethod shared-initialize ((instance slot-object) slot-names &rest initargs)
 125   (flet ((initialize-slot-from-initarg (class instance slotd)
 126            (let ((slot-initargs (slot-definition-initargs slotd)))
 127              (doplist (initarg value) initargs
 128                (when (memq initarg slot-initargs)
 129                  (setf (slot-value-using-class class instance slotd)
 130                        value)
 131                  (return t)))))
 132          (initialize-slot-from-initfunction (class instance slotd)
 133            ;; CLHS: If a before method stores something in a slot,
 134            ;; that slot won't be initialized from its :INITFORM, if any.
 135            (let ((initfun (slot-definition-initfunction slotd)))
 136              (if (typep instance 'structure-object)
 137                  ;; We don't have a consistent unbound marker for structure
 138                  ;; object slots, and structure object redefinition is not
 139                  ;; really supported anyways -- so unconditionally
 140                  ;; initializing the slot should be fine.
 141                  (when initfun
 142                    (setf (slot-value-using-class class instance slotd)
 143                          (funcall initfun)))
 144                  (unless (or (not initfun)
 145                              (slot-boundp-using-class class instance slotd))
 146                    (setf (slot-value-using-class class instance slotd)
 147                          (funcall initfun)))))))
 148     (let* ((class (class-of instance))
 149            (initfn-slotds
 150             (loop for slotd in (class-slots class)
 151                   unless (initialize-slot-from-initarg class instance slotd)
 152                   collect slotd)))
 153       (dolist (slotd initfn-slotds)
 154         (when (or (eq t slot-names)
 155                   (memq (slot-definition-name slotd) slot-names))
 156           (initialize-slot-from-initfunction class instance slotd))))
 157     instance))
 158 \f
 159 ;;; If initargs are valid return nil, otherwise signal an error.
 160 (defun check-initargs-1 (class initargs call-list
 161                          &optional (plist-p t) (error-p t))
 162   (multiple-value-bind (legal allow-other-keys)
 163       (check-initargs-values class call-list)
 164     (unless allow-other-keys
 165       (if plist-p
 166           (check-initargs-2-plist initargs class legal error-p)
 167           (check-initargs-2-list initargs class legal error-p)))))
 168
 169 (defun check-initargs-values (class call-list)
 170   (let ((methods (mapcan (lambda (call)
 171                            (if (consp call)
 172                                (copy-list (compute-applicable-methods
 173                                            (gdefinition (car call))
 174                                            (cdr call)))
 175                                (list call)))
 176                          call-list))
 177         (legal (apply #'append (mapcar #'slot-definition-initargs
 178                                        (class-slots class)))))
 179     ;; Add to the set of slot-filling initargs the set of
 180     ;; initargs that are accepted by the methods. If at
 181     ;; any point we come across &allow-other-keys, we can
 182     ;; just quit.
 183     (dolist (method methods)
 184       (multiple-value-bind (nreq nopt keysp restp allow-other-keys keys)
 185           (analyze-lambda-list (if (consp method)
 186                                    (early-method-lambda-list method)
 187                                    (method-lambda-list method)))
 188         (declare (ignore nreq nopt keysp restp))
 189         (when allow-other-keys
 190           (return-from check-initargs-values (values nil t)))
 191         (setq legal (append keys legal))))
 192     (values legal nil)))
 193
 194 (define-condition initarg-error (reference-condition program-error)
 195   ((class :reader initarg-error-class :initarg :class)
 196    (initargs :reader initarg-error-initargs :initarg :initargs))
 197   (:default-initargs :references (list '(:ansi-cl :section (7 1 2))))
 198   (:report (lambda (condition stream)
 199              (format stream "~@<Invalid initialization argument~P: ~2I~_~
 200                              ~<~{~S~^, ~} ~@:>~I~_in call for class ~S.~:>"
 201                      (length (initarg-error-initargs condition))
 202                      (list (initarg-error-initargs condition))
 203                      (initarg-error-class condition)))))
 204
 205 (defun check-initargs-2-plist (initargs class legal &optional (error-p t))
 206   (let ((invalid-keys ()))
 207     (unless (getf initargs :allow-other-keys)
 208       ;; Now check the supplied-initarg-names and the default initargs
 209       ;; against the total set that we know are legal.
 210       (doplist (key val) initargs
 211         (unless (or (memq key legal)
 212                     ;; :ALLOW-OTHER-KEYS NIL gets here
 213                     (eq key :allow-other-keys))
 214           (push key invalid-keys)))
 215       (when (and invalid-keys error-p)
 216         (error 'initarg-error :class class :initargs invalid-keys)))
 217     invalid-keys))
 218
 219 (defun check-initargs-2-list (initkeys class legal &optional (error-p t))
 220   (let ((invalid-keys ()))
 221     (unless (memq :allow-other-keys initkeys)
 222       ;; Now check the supplied-initarg-names and the default initargs
 223       ;; against the total set that we know are legal.
 224       (dolist (key initkeys)
 225         (unless (memq key legal)
 226           (push key invalid-keys)))
 227       (when (and invalid-keys error-p)
 228         (error 'initarg-error :class class :initargs invalid-keys)))
 229     invalid-keys))
 230