0.6.11.16:
[sbcl.git] / src / pcl / slots-boot.lisp
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3
4 ;;;; This software is derived from software originally released by Xerox
5 ;;;; Corporation. Copyright and release statements follow. Later modifications
6 ;;;; to the software are in the public domain and are provided with
7 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
8 ;;;; information.
9
10 ;;;; copyright information from original PCL sources:
11 ;;;;
12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
13 ;;;; All rights reserved.
14 ;;;;
15 ;;;; Use and copying of this software and preparation of derivative works based
16 ;;;; upon this software are permitted. Any distribution of this software or
17 ;;;; derivative works must comply with all applicable United States export
18 ;;;; control laws.
19 ;;;;
20 ;;;; This software is made available AS IS, and Xerox Corporation makes no
21 ;;;; warranty about the software, its performance or its conformity to any
22 ;;;; specification.
23
24 (in-package "SB-PCL")
25 \f
26 (defmacro slot-symbol (slot-name type)
27   `(if (and (symbolp ,slot-name) (symbol-package ,slot-name))
28        (or (get ,slot-name ',(ecase type
29                                (reader 'reader-symbol)
30                                (writer 'writer-symbol)
31                                (boundp 'boundp-symbol)))
32            (intern (format nil "~A ~A slot ~A"
33                            (package-name (symbol-package ,slot-name))
34                            (symbol-name ,slot-name)
35                            ,(symbol-name type))
36                    *slot-accessor-name-package*))
37        (progn
38          (error "Non-symbol and non-interned symbol slot name accessors~
39                  are not yet implemented.")
40          ;;(make-symbol (format nil "~A ~A" ,slot-name ,type))
41          )))
42
43 (defun slot-reader-symbol (slot-name)
44   (slot-symbol slot-name reader))
45
46 (defun slot-writer-symbol (slot-name)
47   (slot-symbol slot-name writer))
48
49 (defun slot-boundp-symbol (slot-name)
50   (slot-symbol slot-name boundp))
51
52 (defmacro asv-funcall (sym slot-name type &rest args)
53   (declare (ignore type))
54   `(if (fboundp ',sym)
55        (,sym ,@args)
56        (no-slot ',sym ',slot-name)))
57
58 (defun no-slot (sym slot-name)
59   (error "No class has a slot named ~S (~S has no function binding)."
60          slot-name sym))
61
62 (defmacro accessor-slot-value (object slot-name)
63   (unless (constantp slot-name)
64     (error "~S requires its slot-name argument to be a constant"
65            'accessor-slot-value))
66   (let* ((slot-name (eval slot-name))
67          (sym (slot-reader-symbol slot-name)))
68     `(asv-funcall ,sym ,slot-name reader ,object)))
69
70 (defmacro accessor-set-slot-value (object slot-name new-value &environment env)
71   (unless (constantp slot-name)
72     (error "~S requires its slot-name argument to be a constant"
73            'accessor-set-slot-value))
74   (setq object (macroexpand object env))
75   (setq slot-name (macroexpand slot-name env))
76   (let* ((slot-name (eval slot-name))
77          (bindings (unless (or (constantp new-value) (atom new-value))
78                      (let ((object-var (gensym)))
79                        (prog1 `((,object-var ,object))
80                          (setq object object-var)))))
81          (sym (slot-writer-symbol slot-name))
82          (form `(asv-funcall ,sym ,slot-name writer ,new-value ,object)))
83     (if bindings
84         `(let ,bindings ,form)
85         form)))
86
87 ;;; FIXME: Why is this defined in two different places? And what does
88 ;;; it mean anyway? And can we just eliminate it completely (replacing
89 ;;; it with NIL, then hand-eliminating any resulting dead code)?
90 (defconstant +optimize-slot-boundp+ nil)
91
92 (defmacro accessor-slot-boundp (object slot-name)
93   (unless (constantp slot-name)
94     (error "~S requires its slot-name argument to be a constant"
95            'accessor-slot-boundp))
96   (let* ((slot-name (eval slot-name))
97          (sym (slot-boundp-symbol slot-name)))
98     (if (not +optimize-slot-boundp+)
99         `(slot-boundp-normal ,object ',slot-name)
100         `(asv-funcall ,sym ,slot-name boundp ,object))))
101
102 (defun structure-slot-boundp (object)
103   (declare (ignore object))
104   t)
105
106 (defun make-structure-slot-boundp-function (slotd)
107   (let* ((reader (slot-definition-internal-reader-function slotd))
108          (fun #'(lambda (object)
109                   (not (eq (funcall reader object) +slot-unbound+)))))
110     (declare (type function reader))
111     fun))
112
113 (defun get-optimized-std-accessor-method-function (class slotd name)
114   (if (structure-class-p class)
115       (ecase name
116         (reader (slot-definition-internal-reader-function slotd))
117         (writer (slot-definition-internal-writer-function slotd))
118         (boundp (make-structure-slot-boundp-function slotd)))
119       (let* ((fsc-p (cond ((standard-class-p class) nil)
120                           ((funcallable-standard-class-p class) t)
121                           ((std-class-p class)
122                            ;; Shouldn't be using the optimized-std-accessors
123                            ;; in this case.
124                            #+nil (format t "* warning: ~S ~S~%   ~S~%"
125                                    name slotd class)
126                            nil)
127                           (t (error "~S is not a STANDARD-CLASS." class))))
128              (slot-name (slot-definition-name slotd))
129              (index (slot-definition-location slotd))
130              (function (ecase name
131                          (reader #'make-optimized-std-reader-method-function)
132                          (writer #'make-optimized-std-writer-method-function)
133                          (boundp #'make-optimized-std-boundp-method-function)))
134              (value (funcall function fsc-p slot-name index)))
135         (declare (type function function))
136         (values value index))))
137
138 (defun make-optimized-std-reader-method-function (fsc-p slot-name index)
139   (declare #.*optimize-speed*)
140   (set-function-name
141    (etypecase index
142      (fixnum (if fsc-p
143                  (lambda (instance)
144                    (let ((value (clos-slots-ref (fsc-instance-slots instance)
145                                                 index)))
146                      (if (eq value +slot-unbound+)
147                          (slot-unbound (class-of instance) instance slot-name)
148                          value)))
149                  (lambda (instance)
150                    (let ((value (clos-slots-ref (std-instance-slots instance)
151                                               index)))
152                      (if (eq value +slot-unbound+)
153                          (slot-unbound (class-of instance) instance slot-name)
154                          value)))))
155      (cons   (lambda (instance)
156                (let ((value (cdr index)))
157                  (if (eq value +slot-unbound+)
158                      (slot-unbound (class-of instance) instance slot-name)
159                      value)))))
160    `(reader ,slot-name)))
161
162 (defun make-optimized-std-writer-method-function (fsc-p slot-name index)
163   (declare #.*optimize-speed*)
164   (set-function-name
165    (etypecase index
166      (fixnum (if fsc-p
167                  (lambda (nv instance)
168                    (setf (clos-slots-ref (fsc-instance-slots instance) index)
169                          nv))
170                  (lambda (nv instance)
171                    (setf (clos-slots-ref (std-instance-slots instance) index)
172                          nv))))
173      (cons   (lambda (nv instance)
174                (declare (ignore instance))
175                (setf (cdr index) nv))))
176    `(writer ,slot-name)))
177
178 (defun make-optimized-std-boundp-method-function (fsc-p slot-name index)
179   (declare #.*optimize-speed*)
180   (set-function-name
181    (etypecase index
182      (fixnum (if fsc-p
183                  #'(lambda (instance)
184                      (not (eq (clos-slots-ref (fsc-instance-slots instance)
185                                              index)
186                               +slot-unbound+)))
187                  #'(lambda (instance)
188                      (not (eq (clos-slots-ref (std-instance-slots instance)
189                                              index)
190                               +slot-unbound+)))))
191      (cons   #'(lambda (instance)
192                  (declare (ignore instance))
193                  (not (eq (cdr index) +slot-unbound+)))))
194    `(boundp ,slot-name)))
195
196 (defun make-optimized-structure-slot-value-using-class-method-function (function)
197   (declare (type function function))
198   (lambda (class object slotd)
199     (let ((value (funcall function object)))
200       (if (eq value +slot-unbound+)
201           (slot-unbound class object (slot-definition-name slotd))
202           value))))
203
204 (defun make-optimized-structure-setf-slot-value-using-class-method-function (function)
205   (declare (type function function))
206   #'(lambda (nv class object slotd)
207       (declare (ignore class slotd))
208       (funcall function nv object)))
209
210 (defun make-optimized-structure-slot-boundp-using-class-method-function (function)
211   (declare (type function function))
212   #'(lambda (class object slotd)
213       (declare (ignore class slotd))
214       (not (eq (funcall function object) +slot-unbound+))))
215
216 (defun get-optimized-std-slot-value-using-class-method-function (class
217                                                                  slotd
218                                                                  name)
219   (if (structure-class-p class)
220       (ecase name
221         (reader (make-optimized-structure-slot-value-using-class-method-function
222                  (slot-definition-internal-reader-function slotd)))
223         (writer (make-optimized-structure-setf-slot-value-using-class-method-function
224                  (slot-definition-internal-writer-function slotd)))
225         (boundp (make-optimized-structure-slot-boundp-using-class-method-function
226                  (slot-definition-internal-writer-function slotd))))
227       (let* ((fsc-p (cond ((standard-class-p class) nil)
228                           ((funcallable-standard-class-p class) t)
229                           (t (error "~S is not a standard-class" class))))
230              (slot-name (slot-definition-name slotd))
231              (index (slot-definition-location slotd))
232              (function
233               (ecase name
234                 (reader
235                  #'make-optimized-std-slot-value-using-class-method-function)
236                 (writer
237                  #'make-optimized-std-setf-slot-value-using-class-method-function)
238                 (boundp
239                  #'make-optimized-std-slot-boundp-using-class-method-function))))
240         (declare (type function function))
241         (values (funcall function fsc-p slot-name index) index))))
242
243 (defun make-optimized-std-slot-value-using-class-method-function
244     (fsc-p slot-name index)
245   (declare #.*optimize-speed*)
246   (etypecase index
247     (fixnum (if fsc-p
248                 (lambda (class instance slotd)
249                   (declare (ignore slotd))
250                   (unless (fsc-instance-p instance) (error "not fsc"))
251                   (let ((value (clos-slots-ref (fsc-instance-slots instance)
252                                                index)))
253                     (if (eq value +slot-unbound+)
254                         (slot-unbound class instance slot-name)
255                         value)))
256                 (lambda (class instance slotd)
257                   (declare (ignore slotd))
258                   (unless (std-instance-p instance) (error "not std"))
259                   (let ((value (clos-slots-ref (std-instance-slots instance)
260                                                index)))
261                     (if (eq value +slot-unbound+)
262                         (slot-unbound class instance slot-name)
263                         value)))))
264     (cons   (lambda (class instance slotd)
265               (declare (ignore slotd))
266               (let ((value (cdr index)))
267                 (if (eq value +slot-unbound+)
268                     (slot-unbound class instance slot-name)
269                     value))))))
270
271 (defun make-optimized-std-setf-slot-value-using-class-method-function
272     (fsc-p slot-name index)
273   (declare #.*optimize-speed*)
274   (declare (ignore slot-name))
275   (etypecase index
276     (fixnum (if fsc-p
277                 (lambda (nv class instance slotd)
278                   (declare (ignore class slotd))
279                   (setf (clos-slots-ref (fsc-instance-slots instance) index)
280                         nv))
281                 (lambda (nv class instance slotd)
282                   (declare (ignore class slotd))
283                   (setf (clos-slots-ref (std-instance-slots instance) index)
284                         nv))))
285     (cons  (lambda (nv class instance slotd)
286              (declare (ignore class instance slotd))
287              (setf (cdr index) nv)))))
288
289 (defun make-optimized-std-slot-boundp-using-class-method-function
290     (fsc-p slot-name index)
291   (declare #.*optimize-speed*)
292   (declare (ignore slot-name))
293   (etypecase index
294     (fixnum (if fsc-p
295                 (lambda (class instance slotd)
296                   (declare (ignore class slotd))
297                   (not (eq (clos-slots-ref (fsc-instance-slots instance) index)
298                            +slot-unbound+)))
299                 (lambda (class instance slotd)
300                   (declare (ignore class slotd))
301                   (not (eq (clos-slots-ref (std-instance-slots instance) index)
302                            +slot-unbound+)))))
303     (cons   (lambda (class instance slotd)
304               (declare (ignore class instance slotd))
305               (not (eq (cdr index) +slot-unbound+))))))
306
307 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
308   (macrolet ((emf-funcall (emf &rest args)
309                `(invoke-effective-method-function ,emf nil ,@args)))
310     (set-function-name
311      (case name
312        (reader (lambda (instance)
313                  (emf-funcall sdfun class instance slotd)))
314        (writer (lambda (nv instance)
315                  (emf-funcall sdfun nv class instance slotd)))
316        (boundp (lambda (instance)
317                  (emf-funcall sdfun class instance slotd))))
318      `(,name ,(class-name class) ,(slot-definition-name slotd)))))
319
320 (defun make-internal-reader-method-function (class-name slot-name)
321   (list* ':method-spec `(internal-reader-method ,class-name ,slot-name)
322          (make-method-function
323           (lambda (instance)
324             (let ((wrapper (get-instance-wrapper-or-nil instance)))
325               (if wrapper
326                   (let* ((class (wrapper-class* wrapper))
327                          (index (or (instance-slot-index wrapper slot-name)
328                                     (assq slot-name
329                                           (wrapper-class-slots wrapper)))))
330                     (typecase index
331                       (fixnum   
332                        (let ((value (clos-slots-ref (get-slots instance)
333                                                     index)))
334                          (if (eq value +slot-unbound+)
335                              (slot-unbound (class-of instance)
336                                            instance
337                                            slot-name)
338                              value)))
339                       (cons
340                        (let ((value (cdr index)))
341                          (if (eq value +slot-unbound+)
342                              (slot-unbound (class-of instance)
343                                            instance
344                                            slot-name)
345                              value)))
346                       (t
347                        (error "~@<The wrapper for class ~S does not have ~
348                                the slot ~S~@:>"
349                               class slot-name))))
350                   (slot-value instance slot-name)))))))
351 \f
352 (defun make-std-reader-method-function (class-name slot-name)
353   (let* ((pv-table-symbol (gensym))
354          (initargs (copy-tree
355                     (make-method-function
356                      (lambda (instance)
357                        (pv-binding1 (.pv. .calls.
358                                           (symbol-value pv-table-symbol)
359                                           (instance) (instance-slots))
360                          (instance-read-internal
361                           .pv. instance-slots 1
362                           (slot-value instance slot-name))))))))
363     (setf (getf (getf initargs ':plist) ':slot-name-lists)
364           (list (list nil slot-name)))
365     (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
366     (list* ':method-spec `(reader-method ,class-name ,slot-name)
367            initargs)))
368
369 (defun make-std-writer-method-function (class-name slot-name)
370   (let* ((pv-table-symbol (gensym))
371          (initargs (copy-tree
372                     (make-method-function
373                      (lambda (nv instance)
374                        (pv-binding1 (.pv. .calls.
375                                           (symbol-value pv-table-symbol)
376                                           (instance) (instance-slots))
377                          (instance-write-internal
378                           .pv. instance-slots 1 nv
379                           (setf (slot-value instance slot-name) nv))))))))
380     (setf (getf (getf initargs ':plist) ':slot-name-lists)
381           (list nil (list nil slot-name)))
382     (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
383     (list* ':method-spec `(writer-method ,class-name ,slot-name)
384            initargs)))
385
386 (defun make-std-boundp-method-function (class-name slot-name)
387   (let* ((pv-table-symbol (gensym))
388          (initargs (copy-tree
389                     (make-method-function
390                      (lambda (instance)
391                        (pv-binding1 (.pv. .calls.
392                                           (symbol-value pv-table-symbol)
393                                           (instance) (instance-slots))
394                           (instance-boundp-internal
395                            .pv. instance-slots 1
396                            (slot-boundp instance slot-name))))))))
397     (setf (getf (getf initargs ':plist) ':slot-name-lists)
398           (list (list nil slot-name)))
399     (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
400     (list* ':method-spec `(boundp-method ,class-name ,slot-name)
401            initargs)))
402
403 (defun initialize-internal-slot-gfs (slot-name &optional type)
404   (when (or (null type) (eq type 'reader))
405     (let* ((name (slot-reader-symbol slot-name))
406            (gf (ensure-generic-function name)))
407       (unless (generic-function-methods gf)
408         (add-reader-method *the-class-slot-object* gf slot-name))))
409   (when (or (null type) (eq type 'writer))
410     (let* ((name (slot-writer-symbol slot-name))
411            (gf (ensure-generic-function name)))
412       (unless (generic-function-methods gf)
413         (add-writer-method *the-class-slot-object* gf slot-name))))
414   (when (and +optimize-slot-boundp+
415              (or (null type) (eq type 'boundp)))
416     (let* ((name (slot-boundp-symbol slot-name))
417            (gf (ensure-generic-function name)))
418       (unless (generic-function-methods gf)
419         (add-boundp-method *the-class-slot-object* gf slot-name))))
420   nil)
421
422 (defun initialize-internal-slot-gfs* (readers writers boundps)
423   (dolist (reader readers)
424     (initialize-internal-slot-gfs reader 'reader))
425   (dolist (writer writers)
426     (initialize-internal-slot-gfs writer 'writer))
427   (dolist (boundp boundps)
428     (initialize-internal-slot-gfs boundp 'boundp)))