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 (defmethod update-instance-for-different-class
64 ((previous standard-object) (current standard-object) &rest initargs)
65 ;; First we must compute the newly added slots. The spec defines
66 ;; newly added slots as "those local slots for which no slot of
67 ;; the same name exists in the previous class."
68 (let ((added-slots '())
69 (current-slotds (class-slots (class-of current)))
70 (previous-slot-names (mapcar #'slot-definition-name
71 (class-slots (class-of previous)))))
72 (dolist (slotd current-slotds)
73 (if (and (not (memq (slot-definition-name slotd) previous-slot-names))
74 (eq (slot-definition-allocation slotd) :instance))
75 (push (slot-definition-name slotd) added-slots)))
77 (class-of current) initargs
78 (list (list* 'update-instance-for-different-class previous current initargs)
79 (list* 'shared-initialize current added-slots initargs)))
80 (apply #'shared-initialize current added-slots initargs)))
82 (defmethod update-instance-for-redefined-class
83 ((instance standard-object) added-slots discarded-slots property-list
86 (class-of instance) initargs
87 (list (list* 'update-instance-for-redefined-class
88 instance added-slots discarded-slots property-list initargs)
89 (list* 'shared-initialize instance added-slots initargs)))
90 (apply #'shared-initialize instance added-slots initargs))
92 (defmethod shared-initialize ((instance slot-object) slot-names &rest initargs)
93 (flet ((initialize-slot-from-initarg (class instance slotd)
94 (let ((slot-initargs (slot-definition-initargs slotd)))
95 (doplist (initarg value) initargs
96 (when (memq initarg slot-initargs)
97 (setf (slot-value-using-class class instance slotd)
100 (initialize-slot-from-initfunction (class instance slotd)
101 ;; CLHS: If a before method stores something in a slot,
102 ;; that slot won't be initialized from its :INITFORM, if any.
103 (let ((initfun (slot-definition-initfunction slotd)))
104 (if (typep instance 'structure-object)
105 ;; We don't have a consistent unbound marker for structure
106 ;; object slots, and structure object redefinition is not
107 ;; really supported anyways -- so unconditionally
108 ;; initializing the slot should be fine.
110 (setf (slot-value-using-class class instance slotd)
112 (unless (or (not initfun)
113 (slot-boundp-using-class class instance slotd))
114 (setf (slot-value-using-class class instance slotd)
115 (funcall initfun)))))))
116 (let* ((class (class-of instance))
118 (loop for slotd in (class-slots class)
119 unless (initialize-slot-from-initarg class instance slotd)
121 (dolist (slotd initfn-slotds)
122 (when (or (eq t slot-names)
123 (memq (slot-definition-name slotd) slot-names))
124 (initialize-slot-from-initfunction class instance slotd))))
127 ;;; If initargs are valid return nil, otherwise signal an error.
128 (defun check-initargs-1 (class initargs call-list
129 &optional (plist-p t) (error-p t))
130 (multiple-value-bind (legal allow-other-keys)
131 (check-initargs-values class call-list)
132 (unless allow-other-keys
134 (check-initargs-2-plist initargs class legal error-p)
135 (check-initargs-2-list initargs class legal error-p)))))
137 (defun check-initargs-values (class call-list)
138 (let ((methods (mapcan (lambda (call)
140 (copy-list (compute-applicable-methods
141 (gdefinition (car call))
145 (legal (apply #'append (mapcar #'slot-definition-initargs
146 (class-slots class)))))
147 ;; Add to the set of slot-filling initargs the set of
148 ;; initargs that are accepted by the methods. If at
149 ;; any point we come across &allow-other-keys, we can
151 (dolist (method methods)
152 (multiple-value-bind (nreq nopt keysp restp allow-other-keys keys)
153 (analyze-lambda-list (if (consp method)
154 (early-method-lambda-list method)
155 (method-lambda-list method)))
156 (declare (ignore nreq nopt keysp restp))
157 (when allow-other-keys
158 (return-from check-initargs-values (values nil t)))
159 (setq legal (append keys legal))))
162 (define-condition initarg-error (reference-condition program-error)
163 ((class :reader initarg-error-class :initarg :class)
164 (initargs :reader initarg-error-initargs :initarg :initargs))
165 (:default-initargs :references (list '(:ansi-cl :section (7 1 2))))
166 (:report (lambda (condition stream)
167 (format stream "~@<Invalid initialization argument~P: ~2I~_~
168 ~<~{~S~^, ~} ~@:>~I~_in call for class ~S.~:>"
169 (length (initarg-error-initargs condition))
170 (list (initarg-error-initargs condition))
171 (initarg-error-class condition)))))
173 (defun check-initargs-2-plist (initargs class legal &optional (error-p t))
174 (let ((invalid-keys ()))
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 (or (memq key legal)
180 ;; :ALLOW-OTHER-KEYS NIL gets here
181 (eq key :allow-other-keys))
182 (push key invalid-keys)))
183 (when (and invalid-keys error-p)
184 (error 'initarg-error :class class :initargs invalid-keys)))
187 (defun check-initargs-2-list (initkeys class legal &optional (error-p t))
188 (let ((invalid-keys ()))
189 (unless (memq :allow-other-keys initkeys)
190 ;; Now check the supplied-initarg-names and the default initargs
191 ;; against the total set that we know are legal.
192 (dolist (key initkeys)
193 (unless (memq key legal)
194 (push key invalid-keys)))
195 (when (and invalid-keys error-p)
196 (error 'initarg-error :class class :initargs invalid-keys)))