Don't go through fdefn when referencing #'known-functions.
[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   (let ((instance-or-nil (maybe-call-ctor class initargs)))
33     (when instance-or-nil
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)))
39     (when 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)
44       instance)))
45
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
50         finally
51           (return (append supplied-initargs default-initargs))))
52
53 (defmethod initialize-instance ((instance slot-object) &rest initargs)
54   (apply #'shared-initialize instance t initargs))
55
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)
61   instance)
62
63 (defglobal **typecheck-cache** (make-hash-table :test #'equal :synchronized t))
64 (defvar *typecheck-stack* nil)
65
66 (defun generate-slotd-typecheck (slotd info)
67   (let* ((type (slot-definition-type slotd))
68          (class (slot-definition-class slotd))
69          (cookie (cons class (slot-definition-name slotd))))
70     (declare (dynamic-extent cookie))
71     (when (and (neq t type) (safe-p class))
72       (or
73        ;; Have one already!
74        (awhen (gethash type **typecheck-cache**)
75          (setf (slot-info-typecheck info) it))
76        ;; It is possible for compilation of a typecheck to trigger class
77        ;; finalization, which in turn may trigger compilation of a
78        ;; slot-typechecking function -- detects and break those cycles.
79        ;;
80        ;; We use the slow function here, but the outer call will replace it
81        ;; with the fast one.
82        (when (member cookie *typecheck-stack* :test #'equal)
83          (setf (slot-info-typecheck info)
84                (named-lambda slow-slot-typecheck (value)
85                        (if (typep value type)
86                            value
87                            (error 'type-error
88                                   :datum value
89                                   :expected-type type)))))
90        ;; The normal, good case: compile an efficient typecheck function.
91        (let ((*typecheck-stack* (cons cookie *typecheck-stack*)))
92          (handler-bind (((or style-warning compiler-note) #'muffle-warning))
93            (let ((fun (compile
94                        nil
95                        `(named-lambda (slot-typecheck ,type) (value)
96                           (declare (optimize (sb-c:store-coverage-data 0)
97                                              (sb-c::type-check 3)
98                                              (sb-c::verify-arg-count 0)))
99                           (the ,type value)))))
100              (setf (gethash type **typecheck-cache**) fun
101                    (slot-info-typecheck info) fun))))))))
102
103 (defmethod initialize-instance :after ((slotd effective-slot-definition) &key)
104   (let ((info (make-slot-info :slotd slotd)))
105     (generate-slotd-typecheck slotd info)
106     (setf (slot-definition-info slotd) info)))
107
108 ;;; FIXME: Do we need (SETF SLOT-DEFINITION-TYPE) at all?
109 (defmethod (setf slot-definition-type) :after (new-type (slotd effective-slot-definition))
110   (generate-slotd-typecheck slotd (slot-definition-info slotd)))
111
112 (defmethod update-instance-for-different-class
113     ((previous standard-object) (current standard-object) &rest initargs)
114   ;; First we must compute the newly added slots. The spec defines
115   ;; newly added slots as "those local slots for which no slot of
116   ;; the same name exists in the previous class."
117   (let ((added-slots '())
118         (current-slotds (class-slots (class-of current)))
119         (previous-slot-names (mapcar #'slot-definition-name
120                                      (class-slots (class-of previous)))))
121     (dolist (slotd current-slotds)
122       (if (and (not (memq (slot-definition-name slotd) previous-slot-names))
123                (eq (slot-definition-allocation slotd) :instance))
124           (push (slot-definition-name slotd) added-slots)))
125     (check-initargs-1
126      (class-of current) initargs
127      (list (list* 'update-instance-for-different-class previous current initargs)
128            (list* 'shared-initialize current added-slots initargs)))
129     (apply #'shared-initialize current added-slots initargs)))
130
131 (defmethod update-instance-for-redefined-class
132     ((instance standard-object) added-slots discarded-slots property-list
133      &rest initargs)
134   (check-initargs-1
135    (class-of instance) initargs
136    (list (list* 'update-instance-for-redefined-class
137                 instance added-slots discarded-slots property-list initargs)
138          (list* 'shared-initialize instance added-slots initargs)))
139   (apply #'shared-initialize instance added-slots initargs))
140
141 (defmethod shared-initialize ((instance slot-object) slot-names &rest initargs)
142   (flet ((initialize-slot-from-initarg (class instance slotd)
143            (let ((slot-initargs (slot-definition-initargs slotd)))
144              (doplist (initarg value) initargs
145                (when (memq initarg slot-initargs)
146                  (setf (slot-value-using-class class instance slotd)
147                        value)
148                  (return t)))))
149          (initialize-slot-from-initfunction (class instance slotd)
150            ;; CLHS: If a before method stores something in a slot,
151            ;; that slot won't be initialized from its :INITFORM, if any.
152            (let ((initfun (slot-definition-initfunction slotd)))
153              (if (typep instance 'structure-object)
154                  ;; We don't have a consistent unbound marker for structure
155                  ;; object slots, and structure object redefinition is not
156                  ;; really supported anyways -- so unconditionally
157                  ;; initializing the slot should be fine.
158                  (when initfun
159                    (setf (slot-value-using-class class instance slotd)
160                          (funcall initfun)))
161                  (unless (or (not initfun)
162                              (slot-boundp-using-class class instance slotd))
163                    (setf (slot-value-using-class class instance slotd)
164                          (funcall initfun)))))))
165     (let* ((class (class-of instance))
166            (initfn-slotds
167             (loop for slotd in (class-slots class)
168                   unless (initialize-slot-from-initarg class instance slotd)
169                   collect slotd)))
170       (dolist (slotd initfn-slotds)
171         (when (or (eq t slot-names)
172                   (memq (slot-definition-name slotd) slot-names))
173           (initialize-slot-from-initfunction class instance slotd))))
174     instance))
175 \f
176 ;;; If initargs are valid return nil, otherwise signal an error.
177 (defun check-initargs-1 (class initargs call-list
178                          &optional (plist-p t) (error-p t))
179   (multiple-value-bind (legal allow-other-keys)
180       (check-initargs-values class call-list)
181     (unless allow-other-keys
182       (if plist-p
183           (check-initargs-2-plist initargs class legal error-p)
184           (check-initargs-2-list initargs class legal error-p)))))
185
186 (defun check-initargs-values (class call-list)
187   (let ((methods (mapcan (lambda (call)
188                            (if (consp call)
189                                (copy-list (compute-applicable-methods
190                                            (gdefinition (car call))
191                                            (cdr call)))
192                                (list call)))
193                          call-list))
194         (legal (apply #'append (mapcar #'slot-definition-initargs
195                                        (class-slots class)))))
196     ;; Add to the set of slot-filling initargs the set of
197     ;; initargs that are accepted by the methods. If at
198     ;; any point we come across &allow-other-keys, we can
199     ;; just quit.
200     (dolist (method methods)
201       (multiple-value-bind (nreq nopt keysp restp allow-other-keys keys)
202           (analyze-lambda-list (if (consp method)
203                                    (early-method-lambda-list method)
204                                    (method-lambda-list method)))
205         (declare (ignore nreq nopt keysp restp))
206         (when allow-other-keys
207           (return-from check-initargs-values (values nil t)))
208         (setq legal (append keys legal))))
209     (values legal nil)))
210
211 (define-condition initarg-error (reference-condition program-error)
212   ((class :reader initarg-error-class :initarg :class)
213    (initargs :reader initarg-error-initargs :initarg :initargs))
214   (:default-initargs :references (list '(:ansi-cl :section (7 1 2))))
215   (:report (lambda (condition stream)
216              (format stream "~@<Invalid initialization argument~P: ~2I~_~
217                              ~<~{~S~^, ~} ~@:>~I~_in call for class ~S.~:>"
218                      (length (initarg-error-initargs condition))
219                      (list (initarg-error-initargs condition))
220                      (initarg-error-class condition)))))
221
222 (defun check-initargs-2-plist (initargs class legal &optional (error-p t))
223   (let ((invalid-keys ()))
224     (unless (getf initargs :allow-other-keys)
225       ;; Now check the supplied-initarg-names and the default initargs
226       ;; against the total set that we know are legal.
227       (doplist (key val) initargs
228         (unless (or (memq key legal)
229                     ;; :ALLOW-OTHER-KEYS NIL gets here
230                     (eq key :allow-other-keys))
231           (push key invalid-keys)))
232       (when (and invalid-keys error-p)
233         (error 'initarg-error :class class :initargs invalid-keys)))
234     invalid-keys))
235
236 (defun check-initargs-2-list (initkeys class legal &optional (error-p t))
237   (let ((invalid-keys ()))
238     (unless (memq :allow-other-keys initkeys)
239       ;; Now check the supplied-initarg-names and the default initargs
240       ;; against the total set that we know are legal.
241       (dolist (key initkeys)
242         (unless (memq key legal)
243           (push key invalid-keys)))
244       (when (and invalid-keys error-p)
245         (error 'initarg-error :class class :initargs invalid-keys)))
246     invalid-keys))
247