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 (setq initargs (default-initargs class initargs))
37 (list (list* 'allocate-instance class initargs)
38 (list* 'initialize-instance (class-prototype class) initargs)
39 (list* 'shared-initialize (class-prototype class) t initargs)))
41 (let* ((info (initialize-info class initargs))
42 (valid-p (initialize-info-valid-p info)))
43 (when (and (consp valid-p) (eq (car valid-p) :invalid))
44 (error 'simple-program-error
45 :format-control "Invalid initialization argument ~S for class ~S"
46 :format-arguments (list (cdr valid-p) (class-name class)))))
47 (let ((instance (apply #'allocate-instance class initargs)))
48 (apply #'initialize-instance instance initargs)
51 (defvar *default-initargs-flag* (list nil))
53 (defmethod default-initargs ((class slot-class) supplied-initargs)
54 (call-initialize-function
55 (initialize-info-default-initargs-function
56 (initialize-info class supplied-initargs))
57 nil supplied-initargs)
59 ;; This implementation of default initargs is critically dependent
60 ;; on all-default-initargs not having any duplicate initargs in it.
61 (let ((all-default (class-default-initargs class))
62 (miss *default-initargs-flag*))
63 (flet ((getf* (plist key)
66 (if (eq (car plist) key)
68 (setq plist (cddr plist))))))
69 (labels ((default-1 (tail)
72 (if (eq (getf* supplied-initargs (caar tail)) miss)
74 (funcall (cadar tail))
75 (default-1 (cdr tail)))
76 (default-1 (cdr tail))))))
77 (append supplied-initargs (default-1 all-default)))))
80 (defmethod initialize-instance ((instance slot-object) &rest initargs)
81 (apply #'shared-initialize instance t initargs))
83 (defmethod reinitialize-instance ((instance slot-object) &rest initargs)
86 (class-of instance) initargs
87 (list (list* 'reinitialize-instance instance initargs)
88 (list* 'shared-initialize instance nil initargs)))
90 (let* ((class (class-of instance))
91 (info (initialize-info class initargs))
92 (valid-p (initialize-info-ri-valid-p info)))
93 (when (and (consp valid-p) (eq (car valid-p) :invalid))
94 (error 'simple-program-error
95 :format-control "Invalid initialization argument ~S for class ~S"
96 :format-arguments (list (cdr valid-p) (class-name class)))))
97 (apply #'shared-initialize instance nil initargs)
100 (defmethod update-instance-for-different-class ((previous std-object)
103 ;; First we must compute the newly added slots. The spec defines
104 ;; newly added slots as "those local slots for which no slot of
105 ;; the same name exists in the previous class."
106 (let ((added-slots '())
107 (current-slotds (class-slots (class-of current)))
108 (previous-slot-names (mapcar #'slot-definition-name
109 (class-slots (class-of previous)))))
110 (dolist (slotd current-slotds)
111 (if (and (not (memq (slot-definition-name slotd) previous-slot-names))
112 (eq (slot-definition-allocation slotd) ':instance))
113 (push (slot-definition-name slotd) added-slots)))
115 (class-of current) initargs
116 (list (list* 'update-instance-for-different-class previous current initargs)
117 (list* 'shared-initialize current added-slots initargs)))
118 (apply #'shared-initialize current added-slots initargs)))
120 (defmethod update-instance-for-redefined-class ((instance std-object)
126 (class-of instance) initargs
127 (list (list* 'update-instance-for-redefined-class
128 instance added-slots discarded-slots property-list initargs)
129 (list* 'shared-initialize instance added-slots initargs)))
130 (apply #'shared-initialize instance added-slots initargs))
132 (defmethod shared-initialize
133 ((instance slot-object) slot-names &rest initargs)
134 (when (eq slot-names t)
135 (return-from shared-initialize
136 (call-initialize-function
137 (initialize-info-shared-initialize-t-fun
138 (initialize-info (class-of instance) initargs))
140 (when (eq slot-names nil)
141 (return-from shared-initialize
142 (call-initialize-function
143 (initialize-info-shared-initialize-nil-fun
144 (initialize-info (class-of instance) initargs))
146 ;; Initialize the instance's slots in a two step process:
147 ;; (1) A slot for which one of the initargs in initargs can set
148 ;; the slot, should be set by that initarg. If more than
149 ;; one initarg in initargs can set the slot, the leftmost
150 ;; one should set it.
151 ;; (2) Any slot not set by step 1, may be set from its initform
152 ;; by step 2. Only those slots specified by the slot-names
153 ;; argument are set. If slot-names is:
155 ;; then any slot not set in step 1 is set from its
157 ;; <list of slot names>
158 ;; then any slot in the list, and not set in step 1
159 ;; is set from its initform.
161 ;; then no slots are set from initforms.
162 (let* ((class (class-of instance))
163 (slotds (class-slots class))
164 (std-p (pcl-instance-p instance)))
165 (dolist (slotd slotds)
166 (let ((slot-name (slot-definition-name slotd))
167 (slot-initargs (slot-definition-initargs slotd)))
169 ;; Try to initialize the slot from one of the initargs.
170 ;; If we succeed return T, otherwise return nil.
171 (doplist (initarg val) initargs
172 (when (memq initarg slot-initargs)
173 (setf (slot-value-using-class class
178 ;; Try to initialize the slot from its initform.
180 (or (eq slot-names t)
181 (memq slot-name slot-names))
182 (or (and (not std-p) (eq slot-names t))
183 (not (slot-boundp-using-class class instance slotd))))
184 (let ((initfunction (slot-definition-initfunction slotd)))
186 (setf (slot-value-using-class class instance slotd)
187 (funcall initfunction))))))))
190 ;;; If initargs are valid return nil, otherwise signal an error.
191 (defun check-initargs-1 (class initargs call-list
192 &optional (plist-p t) (error-p t))
193 (multiple-value-bind (legal allow-other-keys)
194 (check-initargs-values class call-list)
195 (unless allow-other-keys
197 (check-initargs-2-plist initargs class legal error-p)
198 (check-initargs-2-list initargs class legal error-p)))))
200 (defun check-initargs-values (class call-list)
201 (let ((methods (mapcan (lambda (call)
203 (copy-list (compute-applicable-methods
204 (gdefinition (car call))
208 (legal (apply #'append (mapcar #'slot-definition-initargs
209 (class-slots class)))))
210 ;; Add to the set of slot-filling initargs the set of
211 ;; initargs that are accepted by the methods. If at
212 ;; any point we come across &allow-other-keys, we can
214 (dolist (method methods)
215 (multiple-value-bind (nreq nopt keysp restp allow-other-keys keys)
216 (analyze-lambda-list (if (consp method)
217 (early-method-lambda-list method)
218 (method-lambda-list method)))
219 (declare (ignore nreq nopt keysp restp))
220 (when allow-other-keys
221 (return-from check-initargs-values (values nil t)))
222 (setq legal (append keys legal))))
225 (defun check-initargs-2-plist (initargs class legal &optional (error-p t))
226 (unless (getf initargs :allow-other-keys)
227 ;; Now check the supplied-initarg-names and the default initargs
228 ;; against the total set that we know are legal.
229 (doplist (key val) initargs
230 (unless (memq key legal)
232 (error 'simple-program-error
233 :format-control "Invalid initialization argument ~S for class ~S"
234 :format-arguments (list key (class-name class)))
235 (return-from check-initargs-2-plist nil)))))
238 (defun check-initargs-2-list (initkeys class legal &optional (error-p t))
239 (unless (memq :allow-other-keys initkeys)
240 ;; Now check the supplied-initarg-names and the default initargs
241 ;; against the total set that we know are legal.
242 (dolist (key initkeys)
243 (unless (memq key legal)
245 (error 'simple-program-error
246 :format-control "Invalid initialization argument ~S for class ~S"
247 :format-arguments (list key (class-name class)))
248 (return-from check-initargs-2-list nil)))))