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