1 ;;;; This file defines the initialization and related protocols.
3 ;;;; This software is part of the SBCL system. See the README file for
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
12 ;;;; copyright information from original PCL sources:
14 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
15 ;;;; All rights reserved.
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
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
28 (defmethod make-instance ((class symbol) &rest initargs)
29 (apply #'make-instance (find-class class) initargs))
31 (defmethod make-instance ((class class) &rest initargs)
32 (let ((instance-or-nil (maybe-call-ctor class initargs)))
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)))
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)
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
51 (return (append supplied-initargs default-initargs))))
53 (defmethod initialize-instance ((instance slot-object) &rest initargs)
54 (apply #'shared-initialize instance t initargs))
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)
63 (defglobal **typecheck-cache** (make-hash-table :test #'equal))
65 (defun generate-slotd-typecheck (slotd)
66 (let ((type (slot-definition-type slotd)))
68 (when (and (neq t type) (safe-p (slot-definition-class slotd)))
69 (with-locked-system-table (**typecheck-cache**)
70 (or (gethash type **typecheck-cache**)
71 (setf (gethash type **typecheck-cache**)
72 (handler-bind (((or style-warning compiler-note)
77 (declare (optimize (sb-c:store-coverage-data 0)
79 (sb-c::verify-arg-count 0)))
80 (named-lambda (slot-typecheck ,type) (value)
81 (the ,type value))))))))))
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))))
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)))
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)))
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)))
114 (defmethod update-instance-for-redefined-class
115 ((instance standard-object) added-slots discarded-slots property-list
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))
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)
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.
142 (setf (slot-value-using-class class instance slotd)
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))
150 (loop for slotd in (class-slots class)
151 unless (initialize-slot-from-initarg class instance 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))))
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
166 (check-initargs-2-plist initargs class legal error-p)
167 (check-initargs-2-list initargs class legal error-p)))))
169 (defun check-initargs-values (class call-list)
170 (let ((methods (mapcan (lambda (call)
172 (copy-list (compute-applicable-methods
173 (gdefinition (car call))
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
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))))
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)))))
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)))
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)))