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 class 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 (defmethod default-initargs ((class slot-class)
54 class-default-initargs)
55 (loop for (key fn) in class-default-initargs
56 when (eq (getf supplied-initargs key '.not-there.) '.not-there.)
57 append (list key (funcall fn)) into default-initargs
59 (return (append supplied-initargs default-initargs))))
61 (defmethod initialize-instance ((instance slot-object) &rest initargs)
62 (apply #'shared-initialize instance t initargs))
64 (defmethod reinitialize-instance ((instance slot-object) &rest initargs)
65 (apply #'shared-initialize instance nil initargs)
68 (defmethod update-instance-for-different-class ((previous std-object)
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 ((instance std-object)
94 (class-of instance) initargs
95 (list (list* 'update-instance-for-redefined-class
96 instance added-slots discarded-slots property-list initargs)
97 (list* 'shared-initialize instance added-slots initargs)))
98 (apply #'shared-initialize instance added-slots initargs))
100 (defmethod shared-initialize ((instance slot-object) slot-names &rest initargs)
101 (flet ((initialize-slot-from-initarg (class instance slotd)
102 (let ((slot-initargs (slot-definition-initargs slotd)))
103 (doplist (initarg value) initargs
104 (when (memq initarg slot-initargs)
105 (setf (slot-value-using-class class instance slotd)
108 (initialize-slot-from-initfunction (class instance slotd)
109 ;; CLHS: If a before method stores something in a slot,
110 ;; that slot won't be initialized from its :INITFORM, if any.
111 (if (typep instance 'structure-object)
113 ;; not SLOT-VALUE-USING-CLASS, as that
114 ;; throws an error if the value is the
116 (slot-definition-internal-reader-function slotd)
119 (setf (slot-value-using-class class instance slotd)
120 (let ((initfn (slot-definition-initfunction slotd)))
123 (unless (or (slot-boundp-using-class class instance slotd)
124 (null (slot-definition-initfunction slotd)))
125 (setf (slot-value-using-class class instance slotd)
126 (funcall (slot-definition-initfunction slotd)))))))
127 (let* ((class (class-of instance))
129 (loop for slotd in (class-slots class)
130 unless (initialize-slot-from-initarg class instance slotd)
132 (loop for slotd in initfn-slotds
133 when (and (not (eq :class (slot-definition-allocation slotd)))
134 (or (eq t slot-names)
135 (memq (slot-definition-name slotd) slot-names))) do
136 (initialize-slot-from-initfunction class instance slotd)))
139 ;;; If initargs are valid return nil, otherwise signal an error.
140 (defun check-initargs-1 (class initargs call-list
141 &optional (plist-p t) (error-p t))
142 (multiple-value-bind (legal allow-other-keys)
143 (check-initargs-values class call-list)
144 (unless allow-other-keys
146 (check-initargs-2-plist initargs class legal error-p)
147 (check-initargs-2-list initargs class legal error-p)))))
149 (defun check-initargs-values (class call-list)
150 (let ((methods (mapcan (lambda (call)
152 (copy-list (compute-applicable-methods
153 (gdefinition (car call))
157 (legal (apply #'append (mapcar #'slot-definition-initargs
158 (class-slots class)))))
159 ;; Add to the set of slot-filling initargs the set of
160 ;; initargs that are accepted by the methods. If at
161 ;; any point we come across &allow-other-keys, we can
163 (dolist (method methods)
164 (multiple-value-bind (nreq nopt keysp restp allow-other-keys keys)
165 (analyze-lambda-list (if (consp method)
166 (early-method-lambda-list method)
167 (method-lambda-list method)))
168 (declare (ignore nreq nopt keysp restp))
169 (when allow-other-keys
170 (return-from check-initargs-values (values nil t)))
171 (setq legal (append keys legal))))
174 (defun check-initargs-2-plist (initargs class legal &optional (error-p t))
175 (unless (getf initargs :allow-other-keys)
176 ;; Now check the supplied-initarg-names and the default initargs
177 ;; against the total set that we know are legal.
178 (doplist (key val) initargs
179 (unless (memq key legal)
181 (error 'simple-program-error
182 :format-control "Invalid initialization argument ~S for class ~S"
183 :format-arguments (list key (class-name class)))
184 (return-from check-initargs-2-plist nil)))))
187 (defun check-initargs-2-list (initkeys class legal &optional (error-p t))
188 (unless (memq :allow-other-keys initkeys)
189 ;; Now check the supplied-initarg-names and the default initargs
190 ;; against the total set that we know are legal.
191 (dolist (key initkeys)
192 (unless (memq key legal)
194 (error 'simple-program-error
195 :format-control "Invalid initialization argument ~S for class ~S"
196 :format-arguments (list key (class-name class)))
197 (return-from check-initargs-2-list nil)))))