0.9.1.7: "fix" SB-SPROF on non-gencgc platforms
[sbcl.git] / src / pcl / init.lisp
1 ;;;; This file defines the initialization and related protocols.
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5
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
10 ;;;; information.
11
12 ;;;; copyright information from original PCL sources:
13 ;;;;
14 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
15 ;;;; All rights reserved.
16 ;;;;
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
20 ;;;; control laws.
21 ;;;;
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
24 ;;;; specification.
25
26 (in-package "SB-PCL")
27 \f
28 (defmethod make-instance ((class symbol) &rest initargs)
29   (apply #'make-instance (find-class class) initargs))
30
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)))
36     (when initargs
37       (when (and (eq *boot-state* 'complete)
38                  (not (getf initargs :allow-other-keys)))
39         (let ((class-proto (class-prototype class)))
40           (check-initargs-1
41            class initargs
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)
50       instance)))
51
52 (defmethod default-initargs ((class slot-class)
53                              supplied-initargs
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
58         finally
59           (return (append supplied-initargs default-initargs))))
60
61 (defmethod initialize-instance ((instance slot-object) &rest initargs)
62   (apply #'shared-initialize instance t initargs))
63
64 (defmethod reinitialize-instance ((instance slot-object) &rest initargs)
65   ;; the ctor machinery allows us to track when memoization of
66   ;; validity of initargs should be cleared.
67   (check-ri-initargs instance initargs)
68   (apply #'shared-initialize instance nil initargs)
69   instance)
70
71 (defmethod update-instance-for-different-class ((previous std-object)
72                                                 (current std-object)
73                                                 &rest initargs)
74   ;; First we must compute the newly added slots. The spec defines
75   ;; newly added slots as "those local slots for which no slot of
76   ;; the same name exists in the previous class."
77   (let ((added-slots '())
78         (current-slotds (class-slots (class-of current)))
79         (previous-slot-names (mapcar #'slot-definition-name
80                                      (class-slots (class-of previous)))))
81     (dolist (slotd current-slotds)
82       (if (and (not (memq (slot-definition-name slotd) previous-slot-names))
83                (eq (slot-definition-allocation slotd) :instance))
84           (push (slot-definition-name slotd) added-slots)))
85     (check-initargs-1
86      (class-of current) initargs
87      (list (list* 'update-instance-for-different-class previous current initargs)
88            (list* 'shared-initialize current added-slots initargs)))
89     (apply #'shared-initialize current added-slots initargs)))
90
91 (defmethod update-instance-for-redefined-class ((instance std-object)
92                                                 added-slots
93                                                 discarded-slots
94                                                 property-list
95                                                 &rest initargs)
96   (check-initargs-1
97    (class-of instance) initargs
98    (list (list* 'update-instance-for-redefined-class
99                 instance added-slots discarded-slots property-list initargs)
100          (list* 'shared-initialize instance added-slots initargs)))
101   (apply #'shared-initialize instance added-slots initargs))
102
103 (defmethod shared-initialize ((instance slot-object) slot-names &rest initargs)
104   (flet ((initialize-slot-from-initarg (class instance slotd)
105            (let ((slot-initargs (slot-definition-initargs slotd)))
106              (doplist (initarg value) initargs
107                       (when (memq initarg slot-initargs)
108                         (setf (slot-value-using-class class instance slotd)
109                               value)
110                         (return t)))))
111          (initialize-slot-from-initfunction (class instance slotd)
112            ;; CLHS: If a before method stores something in a slot,
113            ;; that slot won't be initialized from its :INITFORM, if any.
114            (if (typep instance 'structure-object)
115                (when (eq (funcall
116                           ;; not SLOT-VALUE-USING-CLASS, as that
117                           ;; throws an error if the value is the
118                           ;; unbound marker.
119                           (slot-definition-internal-reader-function slotd)
120                           instance)
121                          +slot-unbound+)
122                  (setf (slot-value-using-class class instance slotd)
123                        (let ((initfn (slot-definition-initfunction slotd)))
124                          (when initfn
125                            (funcall initfn)))))
126                (unless (or (null (slot-definition-initfunction slotd))
127                            (slot-boundp-using-class class instance slotd))
128                  (setf (slot-value-using-class class instance slotd)
129                        (funcall (slot-definition-initfunction slotd)))))))
130     (let* ((class (class-of instance))
131            (initfn-slotds
132             (loop for slotd in (class-slots class)
133                   unless (initialize-slot-from-initarg class instance slotd)
134                     collect slotd)))
135       (dolist (slotd initfn-slotds)
136         (if (eq (slot-definition-allocation slotd) :class)
137             (when (or (eq t slot-names)
138                       (memq (slot-definition-name slotd) slot-names))
139               (unless (slot-boundp-using-class class instance slotd)
140                 (initialize-slot-from-initfunction class instance slotd)))
141             (when (or (eq t slot-names)
142                       (memq (slot-definition-name slotd) slot-names))
143               (initialize-slot-from-initfunction class instance slotd)))))
144     instance))
145 \f
146 ;;; If initargs are valid return nil, otherwise signal an error.
147 (defun check-initargs-1 (class initargs call-list
148                          &optional (plist-p t) (error-p t))
149   (multiple-value-bind (legal allow-other-keys)
150       (check-initargs-values class call-list)
151     (unless allow-other-keys
152       (if plist-p
153           (check-initargs-2-plist initargs class legal error-p)
154           (check-initargs-2-list initargs class legal error-p)))))
155
156 (defun check-initargs-values (class call-list)
157   (let ((methods (mapcan (lambda (call)
158                            (if (consp call)
159                                (copy-list (compute-applicable-methods
160                                            (gdefinition (car call))
161                                            (cdr call)))
162                                (list call)))
163                          call-list))
164         (legal (apply #'append (mapcar #'slot-definition-initargs
165                                        (class-slots class)))))
166     ;; Add to the set of slot-filling initargs the set of
167     ;; initargs that are accepted by the methods. If at
168     ;; any point we come across &allow-other-keys, we can
169     ;; just quit.
170     (dolist (method methods)
171       (multiple-value-bind (nreq nopt keysp restp allow-other-keys keys)
172           (analyze-lambda-list (if (consp method)
173                                    (early-method-lambda-list method)
174                                    (method-lambda-list method)))
175         (declare (ignore nreq nopt keysp restp))
176         (when allow-other-keys
177           (return-from check-initargs-values (values nil t)))
178         (setq legal (append keys legal))))
179     (values legal nil)))
180
181 (define-condition initarg-error (reference-condition program-error)
182   ((class :reader initarg-error-class :initarg :class)
183    (initargs :reader initarg-error-initargs :initarg :initargs))
184   (:default-initargs :references (list '(:ansi-cl :section (7 1 2))))
185   (:report (lambda (condition stream)
186              (format stream "~@<Invalid initialization argument~P: ~2I~_~
187                              ~<~{~S~^, ~} ~@:>~I~_in call for class ~S.~:>"
188                      (length (initarg-error-initargs condition))
189                      (list (initarg-error-initargs condition))
190                      (initarg-error-class condition)))))
191
192 (defun check-initargs-2-plist (initargs class legal &optional (error-p t))
193   (let ((invalid-keys ()))
194     (unless (getf initargs :allow-other-keys)
195       ;; Now check the supplied-initarg-names and the default initargs
196       ;; against the total set that we know are legal.
197       (doplist (key val) initargs
198         (unless (or (memq key legal)
199                     ;; :ALLOW-OTHER-KEYS NIL gets here
200                     (eq key :allow-other-keys))
201           (push key invalid-keys)))
202       (when (and invalid-keys error-p)
203         (error 'initarg-error :class class :initargs invalid-keys)))
204     invalid-keys))
205
206 (defun check-initargs-2-list (initkeys class legal &optional (error-p t))
207   (let ((invalid-keys ()))
208     (unless (memq :allow-other-keys initkeys)
209       ;; Now check the supplied-initarg-names and the default initargs
210       ;; against the total set that we know are legal.
211       (dolist (key initkeys)
212         (unless (memq key legal)
213           (push key invalid-keys)))
214       (when (and invalid-keys error-p)
215         (error 'initarg-error :class class :initargs invalid-keys)))
216     invalid-keys))
217