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