0.6.11.16:
[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   (setq initargs (default-initargs class initargs))
34   #||
35   (check-initargs-1
36    class initargs
37    (list (list* 'allocate-instance class initargs)
38          (list* 'initialize-instance (class-prototype class) initargs)
39          (list* 'shared-initialize (class-prototype class) t initargs)))
40   ||#
41   (let* ((info (initialize-info class initargs))
42          (valid-p (initialize-info-valid-p info)))
43     (when (and (consp valid-p) (eq (car valid-p) :invalid))
44       (error "Invalid initialization argument ~S for class ~S"
45              (cdr valid-p) (class-name class))))
46   (let ((instance (apply #'allocate-instance class initargs)))
47     (apply #'initialize-instance instance initargs)
48     instance))
49
50 (defvar *default-initargs-flag* (list nil))
51
52 (defmethod default-initargs ((class slot-class) supplied-initargs)
53   (call-initialize-function
54    (initialize-info-default-initargs-function
55     (initialize-info class supplied-initargs))
56    nil supplied-initargs)
57   #||
58   ;; This implementation of default initargs is critically dependent
59   ;; on all-default-initargs not having any duplicate initargs in it.
60   (let ((all-default (class-default-initargs class))
61         (miss *default-initargs-flag*))
62     (flet ((getf* (plist key)
63              (do ()
64                  ((null plist) miss)
65                (if (eq (car plist) key)
66                    (return (cadr plist))
67                    (setq plist (cddr plist))))))
68       (labels ((default-1 (tail)
69                  (if (null tail)
70                      nil
71                      (if (eq (getf* supplied-initargs (caar tail)) miss)
72                          (list* (caar tail)
73                                 (funcall (cadar tail))
74                                 (default-1 (cdr tail)))
75                          (default-1 (cdr tail))))))
76         (append supplied-initargs (default-1 all-default)))))
77   ||#)
78
79 (defmethod initialize-instance ((instance slot-object) &rest initargs)
80   (apply #'shared-initialize instance t initargs))
81
82 (defmethod reinitialize-instance ((instance slot-object) &rest initargs)
83   #||
84   (check-initargs-1
85    (class-of instance) initargs
86    (list (list* 'reinitialize-instance instance initargs)
87          (list* 'shared-initialize instance nil initargs)))
88   ||#
89   (let* ((class (class-of instance))
90          (info (initialize-info class initargs))
91          (valid-p (initialize-info-ri-valid-p info)))
92     (when (and (consp valid-p) (eq (car valid-p) :invalid))
93       (error "Invalid initialization argument ~S for class ~S"
94              (cdr valid-p) (class-name class))))
95   (apply #'shared-initialize instance nil initargs)
96   instance)
97
98 (defmethod update-instance-for-different-class ((previous std-object)
99                                                 (current std-object)
100                                                 &rest initargs)
101   ;; First we must compute the newly added slots. The spec defines
102   ;; newly added slots as "those local slots for which no slot of
103   ;; the same name exists in the previous class."
104   (let ((added-slots '())
105         (current-slotds (class-slots (class-of current)))
106         (previous-slot-names (mapcar #'slot-definition-name
107                                      (class-slots (class-of previous)))))
108     (dolist (slotd current-slotds)
109       (if (and (not (memq (slot-definition-name slotd) previous-slot-names))
110                (eq (slot-definition-allocation slotd) ':instance))
111           (push (slot-definition-name slotd) added-slots)))
112     (check-initargs-1
113      (class-of current) initargs
114      (list (list* 'update-instance-for-different-class previous current initargs)
115            (list* 'shared-initialize current added-slots initargs)))
116     (apply #'shared-initialize current added-slots initargs)))
117
118 (defmethod update-instance-for-redefined-class ((instance std-object)
119                                                 added-slots
120                                                 discarded-slots
121                                                 property-list
122                                                 &rest initargs)
123   (check-initargs-1
124    (class-of instance) initargs
125    (list (list* 'update-instance-for-redefined-class
126                 instance added-slots discarded-slots property-list initargs)
127          (list* 'shared-initialize instance added-slots initargs)))
128   (apply #'shared-initialize instance added-slots initargs))
129
130 (defmethod shared-initialize
131     ((instance slot-object) slot-names &rest initargs)
132   (when (eq slot-names t)
133     (return-from shared-initialize
134       (call-initialize-function
135        (initialize-info-shared-initialize-t-function
136         (initialize-info (class-of instance) initargs))
137        instance initargs)))
138   (when (eq slot-names nil)
139     (return-from shared-initialize
140       (call-initialize-function
141        (initialize-info-shared-initialize-nil-function
142         (initialize-info (class-of instance) initargs))
143        instance initargs)))
144   ;; Initialize the instance's slots in a two step process:
145   ;;   (1) A slot for which one of the initargs in initargs can set
146   ;;       the slot, should be set by that initarg. If more than
147   ;;       one initarg in initargs can set the slot, the leftmost
148   ;;       one should set it.
149   ;;   (2) Any slot not set by step 1, may be set from its initform
150   ;;       by step 2. Only those slots specified by the slot-names
151   ;;       argument are set. If slot-names is:
152   ;;       T
153   ;;          then any slot not set in step 1 is set from its
154   ;;          initform.
155   ;;       <list of slot names>
156   ;;          then any slot in the list, and not set in step 1
157   ;;          is set from its initform.
158   ;;       ()
159   ;;          then no slots are set from initforms.
160   (let* ((class (class-of instance))
161          (slotds (class-slots class))
162          (std-p (pcl-instance-p instance)))
163     (dolist (slotd slotds)
164       (let ((slot-name (slot-definition-name slotd))
165             (slot-initargs (slot-definition-initargs slotd)))
166         (unless (progn
167                   ;; Try to initialize the slot from one of the initargs.
168                   ;; If we succeed return T, otherwise return nil.
169                   (doplist (initarg val) initargs
170                            (when (memq initarg slot-initargs)
171                              (setf (slot-value-using-class class
172                                                            instance
173                                                            slotd)
174                                    val)
175                              (return t))))
176           ;; Try to initialize the slot from its initform.
177           (if (and slot-names
178                    (or (eq slot-names t)
179                        (memq slot-name slot-names))
180                    (or (and (not std-p) (eq slot-names t))
181                        (not (slot-boundp-using-class class instance slotd))))
182               (let ((initfunction (slot-definition-initfunction slotd)))
183                 (when initfunction
184                   (setf (slot-value-using-class class instance slotd)
185                         (funcall initfunction))))))))
186     instance))
187 \f
188 ;;; If initargs are valid return nil, otherwise signal an error.
189 (defun check-initargs-1 (class initargs call-list
190                          &optional (plist-p t) (error-p t))
191   (multiple-value-bind (legal allow-other-keys)
192       (check-initargs-values class call-list)
193     (unless allow-other-keys
194       (if plist-p
195           (check-initargs-2-plist initargs class legal error-p)
196           (check-initargs-2-list initargs class legal error-p)))))
197
198 (defun check-initargs-values (class call-list)
199   (let ((methods (mapcan #'(lambda (call)
200                              (if (consp call)
201                                  (copy-list (compute-applicable-methods
202                                              (gdefinition (car call))
203                                              (cdr call)))
204                                  (list call)))
205                          call-list))
206         (legal (apply #'append (mapcar #'slot-definition-initargs
207                                        (class-slots class)))))
208     ;; Add to the set of slot-filling initargs the set of
209     ;; initargs that are accepted by the methods. If at
210     ;; any point we come across &allow-other-keys, we can
211     ;; just quit.
212     (dolist (method methods)
213       (multiple-value-bind (nreq nopt keysp restp allow-other-keys keys)
214           (analyze-lambda-list (if (consp method)
215                                    (early-method-lambda-list method)
216                                    (method-lambda-list method)))
217         (declare (ignore nreq nopt keysp restp))
218         (when allow-other-keys
219           (return-from check-initargs-values (values nil t)))
220         (setq legal (append keys legal))))
221     (values legal nil)))
222
223 (defun check-initargs-2-plist (initargs class legal &optional (error-p t))
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 (memq key legal)
229          (if error-p
230              (error "Invalid initialization argument ~S for class ~S"
231                     key
232                     (class-name class))
233              (return-from check-initargs-2-plist nil)))))
234   t)
235
236 (defun check-initargs-2-list (initkeys class legal &optional (error-p t))
237   (unless (memq :allow-other-keys initkeys)
238     ;; Now check the supplied-initarg-names and the default initargs
239     ;; against the total set that we know are legal.
240     (dolist (key initkeys)
241       (unless (memq key legal)
242         (if error-p
243             (error "Invalid initialization argument ~S for class ~S"
244                    key
245                    (class-name class))
246             (return-from check-initargs-2-list nil)))))
247   t)
248