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 (unless (class-finalized-p class) (finalize-inheritance class))
33 (let ((class-default-initargs (class-default-initargs class)))
34 (when class-default-initargs
35 (setf initargs (default-initargs initargs class-default-initargs)))
37 (when (and (eq **boot-state** 'complete)
38 (not (getf initargs :allow-other-keys)))
39 (let ((class-proto (class-prototype class)))
42 (append (compute-applicable-methods
43 #'allocate-instance (list class))
44 (compute-applicable-methods
45 #'initialize-instance (list class-proto))
46 (compute-applicable-methods
47 #'shared-initialize (list class-proto t)))))))
48 (let ((instance (apply #'allocate-instance class initargs)))
49 (apply #'initialize-instance instance initargs)
52 (defun default-initargs (supplied-initargs class-default-initargs)
53 (loop for (key nil fun) in class-default-initargs
54 when (eq (getf supplied-initargs key '.not-there.) '.not-there.)
55 append (list key (funcall fun)) into default-initargs
57 (return (append supplied-initargs default-initargs))))
59 (defmethod initialize-instance ((instance slot-object) &rest initargs)
60 (apply #'shared-initialize instance t initargs))
62 (defmethod reinitialize-instance ((instance slot-object) &rest initargs)
63 ;; the ctor machinery allows us to track when memoization of
64 ;; validity of initargs should be cleared.
65 (check-ri-initargs instance initargs)
66 (apply #'shared-initialize instance nil initargs)
69 (defmethod update-instance-for-different-class
70 ((previous standard-object) (current standard-object) &rest initargs)
71 ;; First we must compute the newly added slots. The spec defines
72 ;; newly added slots as "those local slots for which no slot of
73 ;; the same name exists in the previous class."
74 (let ((added-slots '())
75 (current-slotds (class-slots (class-of current)))
76 (previous-slot-names (mapcar #'slot-definition-name
77 (class-slots (class-of previous)))))
78 (dolist (slotd current-slotds)
79 (if (and (not (memq (slot-definition-name slotd) previous-slot-names))
80 (eq (slot-definition-allocation slotd) :instance))
81 (push (slot-definition-name slotd) added-slots)))
83 (class-of current) initargs
84 (list (list* 'update-instance-for-different-class previous current initargs)
85 (list* 'shared-initialize current added-slots initargs)))
86 (apply #'shared-initialize current added-slots initargs)))
88 (defmethod update-instance-for-redefined-class
89 ((instance standard-object) added-slots discarded-slots property-list
92 (class-of instance) initargs
93 (list (list* 'update-instance-for-redefined-class
94 instance added-slots discarded-slots property-list initargs)
95 (list* 'shared-initialize instance added-slots initargs)))
96 (apply #'shared-initialize instance added-slots initargs))
98 (defmethod shared-initialize ((instance slot-object) slot-names &rest initargs)
99 (flet ((initialize-slot-from-initarg (class instance slotd)
100 (let ((slot-initargs (slot-definition-initargs slotd)))
101 (doplist (initarg value) initargs
102 (when (memq initarg slot-initargs)
103 (setf (slot-value-using-class class instance slotd)
106 (initialize-slot-from-initfunction (class instance slotd)
107 ;; CLHS: If a before method stores something in a slot,
108 ;; that slot won't be initialized from its :INITFORM, if any.
109 (let ((initfun (slot-definition-initfunction slotd)))
110 (if (typep instance 'structure-object)
111 ;; We don't have a consistent unbound marker for structure
112 ;; object slots, and structure object redefinition is not
113 ;; really supported anyways -- so unconditionally
114 ;; initializing the slot should be fine.
116 (setf (slot-value-using-class class instance slotd)
118 (unless (or (not initfun)
119 (slot-boundp-using-class class instance slotd))
120 (setf (slot-value-using-class class instance slotd)
121 (funcall initfun)))))))
122 (let* ((class (class-of instance))
124 (loop for slotd in (class-slots class)
125 unless (initialize-slot-from-initarg class instance slotd)
127 (dolist (slotd initfn-slotds)
128 (when (or (eq t slot-names)
129 (memq (slot-definition-name slotd) slot-names))
130 (initialize-slot-from-initfunction class instance slotd))))
133 ;;; If initargs are valid return nil, otherwise signal an error.
134 (defun check-initargs-1 (class initargs call-list
135 &optional (plist-p t) (error-p t))
136 (multiple-value-bind (legal allow-other-keys)
137 (check-initargs-values class call-list)
138 (unless allow-other-keys
140 (check-initargs-2-plist initargs class legal error-p)
141 (check-initargs-2-list initargs class legal error-p)))))
143 (defun check-initargs-values (class call-list)
144 (let ((methods (mapcan (lambda (call)
146 (copy-list (compute-applicable-methods
147 (gdefinition (car call))
151 (legal (apply #'append (mapcar #'slot-definition-initargs
152 (class-slots class)))))
153 ;; Add to the set of slot-filling initargs the set of
154 ;; initargs that are accepted by the methods. If at
155 ;; any point we come across &allow-other-keys, we can
157 (dolist (method methods)
158 (multiple-value-bind (nreq nopt keysp restp allow-other-keys keys)
159 (analyze-lambda-list (if (consp method)
160 (early-method-lambda-list method)
161 (method-lambda-list method)))
162 (declare (ignore nreq nopt keysp restp))
163 (when allow-other-keys
164 (return-from check-initargs-values (values nil t)))
165 (setq legal (append keys legal))))
168 (define-condition initarg-error (reference-condition program-error)
169 ((class :reader initarg-error-class :initarg :class)
170 (initargs :reader initarg-error-initargs :initarg :initargs))
171 (:default-initargs :references (list '(:ansi-cl :section (7 1 2))))
172 (:report (lambda (condition stream)
173 (format stream "~@<Invalid initialization argument~P: ~2I~_~
174 ~<~{~S~^, ~} ~@:>~I~_in call for class ~S.~:>"
175 (length (initarg-error-initargs condition))
176 (list (initarg-error-initargs condition))
177 (initarg-error-class condition)))))
179 (defun check-initargs-2-plist (initargs class legal &optional (error-p t))
180 (let ((invalid-keys ()))
181 (unless (getf initargs :allow-other-keys)
182 ;; Now check the supplied-initarg-names and the default initargs
183 ;; against the total set that we know are legal.
184 (doplist (key val) initargs
185 (unless (or (memq key legal)
186 ;; :ALLOW-OTHER-KEYS NIL gets here
187 (eq key :allow-other-keys))
188 (push key invalid-keys)))
189 (when (and invalid-keys error-p)
190 (error 'initarg-error :class class :initargs invalid-keys)))
193 (defun check-initargs-2-list (initkeys class legal &optional (error-p t))
194 (let ((invalid-keys ()))
195 (unless (memq :allow-other-keys initkeys)
196 ;; Now check the supplied-initarg-names and the default initargs
197 ;; against the total set that we know are legal.
198 (dolist (key initkeys)
199 (unless (memq key legal)
200 (push key invalid-keys)))
201 (when (and invalid-keys error-p)
202 (error 'initarg-error :class class :initargs invalid-keys)))