1.0.5.50: some compare-and-swap changes
[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 (defun ensure-accessor (type fun-name slot-name)
27   (unless (fboundp fun-name)
28     (multiple-value-bind (lambda-list specializers method-class initargs doc)
29         (ecase type
30           ;; FIXME: change SLOT-OBJECT here to T to get SLOT-MISSING
31           ;; behaviour for non-slot-objects too?
32           (reader
33            (values '(object) '(slot-object) 'global-reader-method
34                    (make-std-reader-method-function 'slot-object slot-name)
35                    "automatically-generated reader method"))
36           (writer
37            (values '(new-value object) '(t slot-object) 'global-writer-method
38                    (make-std-writer-method-function 'slot-object slot-name)
39                    "automatically-generated writer method"))
40           (boundp
41            (values '(object) '(slot-object) 'global-boundp-method
42                    (make-std-boundp-method-function 'slot-object slot-name)
43                    "automatically-generated boundp method")))
44       (let ((gf (ensure-generic-function fun-name :lambda-list lambda-list)))
45         (add-method gf (make-a-method method-class
46                                       () lambda-list specializers
47                                       initargs doc :slot-name slot-name)))))
48   t)
49
50 (defmacro accessor-slot-value (object slot-name)
51   (aver (constantp slot-name))
52   (let* ((slot-name (constant-form-value slot-name))
53          (reader-name (slot-reader-name slot-name)))
54     `(let ((.ignore. (load-time-value
55                       (ensure-accessor 'reader ',reader-name ',slot-name))))
56       (declare (ignore .ignore.))
57       (truly-the (values t &optional)
58                  (funcall #',reader-name ,object)))))
59
60 (defmacro accessor-set-slot-value (object slot-name new-value &environment env)
61   (aver (constantp slot-name))
62   (setq object (macroexpand object env))
63   (setq slot-name (macroexpand slot-name env))
64   (let* ((slot-name (constant-form-value slot-name))
65          (bindings (unless (or (constantp new-value) (atom new-value))
66                      (let ((object-var (gensym)))
67                        (prog1 `((,object-var ,object))
68                          (setq object object-var)))))
69          (writer-name (slot-writer-name slot-name))
70          (form
71           `(let ((.ignore.
72                   (load-time-value
73                    (ensure-accessor 'writer ',writer-name ',slot-name)))
74                  (.new-value. ,new-value))
75             (declare (ignore .ignore.))
76             (funcall #',writer-name .new-value. ,object)
77             .new-value.)))
78     (if bindings
79         `(let ,bindings ,form)
80         form)))
81
82 (defmacro accessor-slot-boundp (object slot-name)
83   (aver (constantp slot-name))
84   (let* ((slot-name (constant-form-value slot-name))
85          (boundp-name (slot-boundp-name slot-name)))
86     `(let ((.ignore. (load-time-value
87                       (ensure-accessor 'boundp ',boundp-name ',slot-name))))
88       (declare (ignore .ignore.))
89       (funcall #',boundp-name ,object))))
90
91 (defun make-structure-slot-boundp-function (slotd)
92   (declare (ignore slotd))
93   (lambda (object)
94     (declare (ignore object))
95     t))
96
97 (define-condition instance-structure-protocol-error
98     (reference-condition error)
99   ((slotd :initarg :slotd :reader instance-structure-protocol-error-slotd)
100    (fun :initarg :fun :reader instance-structure-protocol-error-fun))
101   (:report
102    (lambda (c s)
103      (format s "~@<The slot ~S has neither ~S nor ~S ~
104                 allocation, so it can't be ~A by the default ~
105                 ~S method.~@:>"
106              (instance-structure-protocol-error-slotd c)
107              :instance :class
108              (cond
109                ((member (instance-structure-protocol-error-fun c)
110                         '(slot-value-using-class slot-boundp-using-class))
111                 "read")
112                (t "written"))
113              (instance-structure-protocol-error-fun c)))))
114
115 (defun instance-structure-protocol-error (slotd fun)
116   (error 'instance-structure-protocol-error
117          :slotd slotd :fun fun
118          :references (list `(:amop :generic-function ,fun)
119                            '(:amop :section (5 5 3)))))
120
121 (defun get-optimized-std-accessor-method-function (class slotd name)
122   (cond
123     ((structure-class-p class)
124      (ecase name
125        (reader (slot-definition-internal-reader-function slotd))
126        (writer (slot-definition-internal-writer-function slotd))
127        (boundp (make-structure-slot-boundp-function slotd))))
128     ((condition-class-p class)
129      (ecase name
130        (reader (slot-definition-reader-function slotd))
131        (writer (slot-definition-writer-function slotd))
132        (boundp (slot-definition-boundp-function slotd))))
133     (t
134      (let* ((fsc-p (cond ((standard-class-p class) nil)
135                          ((funcallable-standard-class-p class) t)
136                          ((std-class-p class)
137                           ;; Shouldn't be using the optimized-std-accessors
138                           ;; in this case.
139                           #+nil (format t "* warning: ~S ~S~%   ~S~%"
140                                         name slotd class)
141                           nil)
142                          (t (error "~S is not a STANDARD-CLASS." class))))
143             (slot-name (slot-definition-name slotd))
144             (location (slot-definition-location slotd))
145             (function (ecase name
146                         (reader #'make-optimized-std-reader-method-function)
147                         (writer #'make-optimized-std-writer-method-function)
148                         (boundp #'make-optimized-std-boundp-method-function)))
149             ;; KLUDGE: we need this slightly hacky calling convention
150             ;; for these functions for bootstrapping reasons: see
151             ;; !BOOTSTRAP-MAKE-SLOT-DEFINITION in braid.lisp.  -- CSR,
152             ;; 2004-07-12
153             (value (funcall function fsc-p slotd slot-name location)))
154        (declare (type function function))
155        (values value (slot-definition-location slotd))))))
156
157 (defun make-optimized-std-reader-method-function
158     (fsc-p slotd slot-name location)
159   (declare #.*optimize-speed*)
160   (set-fun-name
161    (etypecase location
162      (fixnum
163       (if fsc-p
164           (lambda (instance)
165             (check-obsolete-instance instance)
166             (let ((value (clos-slots-ref (fsc-instance-slots instance)
167                                          location)))
168               (if (eq value +slot-unbound+)
169                   (values
170                    (slot-unbound (class-of instance) instance slot-name))
171                   value)))
172           (lambda (instance)
173             (check-obsolete-instance instance)
174             (let ((value (clos-slots-ref (std-instance-slots instance)
175                                          location)))
176               (if (eq value +slot-unbound+)
177                   (values
178                    (slot-unbound (class-of instance) instance slot-name))
179                   value)))))
180      (cons
181       (lambda (instance)
182         (check-obsolete-instance instance)
183         (let ((value (cdr location)))
184           (if (eq value +slot-unbound+)
185               (values (slot-unbound (class-of instance) instance slot-name))
186               value))))
187      (null
188       (lambda (instance)
189         (instance-structure-protocol-error slotd 'slot-value-using-class))))
190    `(reader ,slot-name)))
191
192 (defun make-optimized-std-writer-method-function
193     (fsc-p slotd slot-name location)
194   (declare #.*optimize-speed*)
195   (let* ((safe-p (and slotd
196                       (slot-definition-class slotd)
197                       (safe-p (slot-definition-class slotd))))
198          (writer-fun (etypecase location
199                        (fixnum (if fsc-p
200                                    (lambda (nv instance)
201                                      (check-obsolete-instance instance)
202                                      (setf (clos-slots-ref (fsc-instance-slots instance)
203                                                            location)
204                                            nv))
205                                    (lambda (nv instance)
206                                      (check-obsolete-instance instance)
207                                      (setf (clos-slots-ref (std-instance-slots instance)
208                                                            location)
209                                            nv))))
210                        (cons (lambda (nv instance)
211                                (check-obsolete-instance instance)
212                                (setf (cdr location) nv)))
213                        (null
214                         (lambda (nv instance)
215                           (declare (ignore nv instance))
216                           (instance-structure-protocol-error
217                            slotd
218                            '(setf slot-value-using-class))))))
219          (checking-fun (lambda (new-value instance)
220                          (check-obsolete-instance instance)
221                          ;; If the SLOTD had a TYPE-CHECK-FUNCTION, call it.
222                          (let* (;; Note that this CLASS is not neccessarily
223                                 ;; the SLOT-DEFINITION-CLASS of the
224                                 ;; SLOTD passed to M-O-S-W-M-F, since it's
225                                 ;; e.g. possible for a subclass to define
226                                 ;; a slot of the same name but with no
227                                 ;; accessors. So we need to fetch the SLOTD
228                                 ;; when CHECKING-FUN is called, instead of
229                                 ;; just closing over it.
230                                 (class (class-of instance))
231                                 (slotd (find-slot-definition class slot-name))
232                                 (type-check-function
233                                  (when slotd
234                                    (slot-definition-type-check-function slotd))))
235                            (when type-check-function
236                              (funcall type-check-function new-value)))
237                          ;; Then call the real writer.
238                          (funcall writer-fun new-value instance))))
239     (set-fun-name (if safe-p
240                       checking-fun
241                       writer-fun)
242                   `(writer ,slot-name))))
243
244 (defun make-optimized-std-boundp-method-function
245     (fsc-p slotd slot-name location)
246   (declare #.*optimize-speed*)
247   (set-fun-name
248    (etypecase location
249      (fixnum (if fsc-p
250                  (lambda (instance)
251                    (check-obsolete-instance instance)
252                    (not (eq (clos-slots-ref (fsc-instance-slots instance)
253                                             location)
254                             +slot-unbound+)))
255                  (lambda (instance)
256                    (check-obsolete-instance instance)
257                    (not (eq (clos-slots-ref (std-instance-slots instance)
258                                             location)
259                             +slot-unbound+)))))
260      (cons (lambda (instance)
261              (check-obsolete-instance instance)
262              (not (eq (cdr location) +slot-unbound+))))
263      (null
264       (lambda (instance)
265         (instance-structure-protocol-error slotd 'slot-boundp-using-class))))
266    `(boundp ,slot-name)))
267
268 (defun make-optimized-structure-slot-value-using-class-method-function
269     (function)
270   (declare (type function function))
271   (lambda (class object slotd)
272     (declare (ignore class slotd))
273     (funcall function object)))
274
275 (defun make-optimized-structure-setf-slot-value-using-class-method-function
276     (function)
277   (declare (type function function))
278   (lambda (nv class object slotd)
279     (declare (ignore class slotd))
280     (funcall function nv object)))
281
282 (defun make-optimized-structure-slot-boundp-using-class-method-function ()
283   (lambda (class object slotd)
284     (declare (ignore class object slotd))
285     t))
286
287 (defun get-optimized-std-slot-value-using-class-method-function
288     (class slotd name)
289   (cond
290     ((structure-class-p class)
291      (ecase name
292        (reader (make-optimized-structure-slot-value-using-class-method-function
293                 (slot-definition-internal-reader-function slotd)))
294        (writer (make-optimized-structure-setf-slot-value-using-class-method-function
295                 (slot-definition-internal-writer-function slotd)))
296        (boundp (make-optimized-structure-slot-boundp-using-class-method-function))))
297     ((condition-class-p class)
298      (ecase name
299        (reader
300         (let ((fun (slot-definition-reader-function slotd)))
301           (declare (type function fun))
302           (lambda (class object slotd)
303             (declare (ignore class slotd))
304             (funcall fun object))))
305        (writer
306         (let ((fun (slot-definition-writer-function slotd)))
307           (declare (type function fun))
308           (lambda (new-value class object slotd)
309             (declare (ignore class slotd))
310             (funcall fun new-value object))))
311        (boundp
312         (let ((fun (slot-definition-boundp-function slotd)))
313           (declare (type function fun))
314           (lambda (class object slotd)
315             (declare (ignore class slotd))
316             (funcall fun object))))))
317     (t
318      (let* ((fsc-p (cond ((standard-class-p class) nil)
319                          ((funcallable-standard-class-p class) t)
320                          (t (error "~S is not a standard-class" class))))
321             (function
322              (ecase name
323                (reader
324                 #'make-optimized-std-slot-value-using-class-method-function)
325                (writer
326                 #'make-optimized-std-setf-slot-value-using-class-method-function)
327                (boundp
328                 #'make-optimized-std-slot-boundp-using-class-method-function))))
329        (declare (type function function))
330        (values (funcall function fsc-p slotd)
331                (slot-definition-location slotd))))))
332
333 (defun make-optimized-std-slot-value-using-class-method-function (fsc-p slotd)
334   (declare #.*optimize-speed*)
335   (let ((location (slot-definition-location slotd))
336         (slot-name (slot-definition-name slotd)))
337     (etypecase location
338       (fixnum (if fsc-p
339                   (lambda (class instance slotd)
340                     (declare (ignore slotd))
341                     (check-obsolete-instance instance)
342                     (let ((value (clos-slots-ref (fsc-instance-slots instance)
343                                                  location)))
344                       (if (eq value +slot-unbound+)
345                           (values (slot-unbound class instance slot-name))
346                           value)))
347                   (lambda (class instance slotd)
348                     (declare (ignore slotd))
349                     (check-obsolete-instance instance)
350                     (let ((value (clos-slots-ref (std-instance-slots instance)
351                                                  location)))
352                       (if (eq value +slot-unbound+)
353                           (values (slot-unbound class instance slot-name))
354                           value)))))
355       (cons (lambda (class instance slotd)
356               (declare (ignore slotd))
357               (check-obsolete-instance instance)
358               (let ((value (cdr location)))
359                 (if (eq value +slot-unbound+)
360                     (values (slot-unbound class instance slot-name))
361                     value))))
362       (null
363        (lambda (class instance slotd)
364          (declare (ignore class instance))
365          (instance-structure-protocol-error slotd 'slot-value-using-class))))))
366
367 (defun make-optimized-std-setf-slot-value-using-class-method-function
368     (fsc-p slotd)
369   (declare #.*optimize-speed*)
370   (let ((location (slot-definition-location slotd))
371         (type-check-function
372          (when (and slotd
373                     (slot-definition-class slotd)
374                     (safe-p (slot-definition-class slotd)))
375            (slot-definition-type-check-function slotd))))
376     (macrolet ((make-mf-lambda (&body body)
377                  `(lambda (nv class instance slotd)
378                     (declare (ignore class slotd))
379                     (check-obsolete-instance instance)
380                     ,@body))
381                (make-mf-lambdas (&body body)
382                  ;; Having separate lambdas for the NULL / not-NULL cases of
383                  ;; TYPE-CHECK-FUNCTION is done to avoid runtime overhead
384                  ;; for CLOS typechecking when it's not in use.
385                  `(if type-check-function
386                       (make-mf-lambda
387                        (funcall (the function type-check-function) nv)
388                        ,@body)
389                       (make-mf-lambda
390                        ,@body))))
391       (etypecase location
392         (fixnum
393          (if fsc-p
394              (make-mf-lambdas
395               (setf (clos-slots-ref (fsc-instance-slots instance) location)
396                     nv))
397              (make-mf-lambdas
398               (setf (clos-slots-ref (std-instance-slots instance) location)
399                     nv))))
400         (cons
401          (make-mf-lambdas (setf (cdr location) nv)))
402         (null (lambda (nv class instance slotd)
403                 (declare (ignore nv class instance))
404                 (instance-structure-protocol-error
405                  slotd '(setf slot-value-using-class))))))))
406
407 (defun make-optimized-std-slot-boundp-using-class-method-function
408     (fsc-p slotd)
409   (declare #.*optimize-speed*)
410   (let ((location (slot-definition-location slotd)))
411     (etypecase location
412       (fixnum
413        (if fsc-p
414            (lambda (class instance slotd)
415              (declare (ignore class slotd))
416              (check-obsolete-instance instance)
417              (not (eq (clos-slots-ref (fsc-instance-slots instance) location)
418                       +slot-unbound+)))
419            (lambda (class instance slotd)
420              (declare (ignore class slotd))
421              (check-obsolete-instance instance)
422              (not (eq (clos-slots-ref (std-instance-slots instance) location)
423                       +slot-unbound+)))))
424       (cons (lambda (class instance slotd)
425               (declare (ignore class slotd))
426               (check-obsolete-instance instance)
427               (not (eq (cdr location) +slot-unbound+))))
428       (null
429        (lambda (class instance slotd)
430          (declare (ignore class instance))
431          (instance-structure-protocol-error slotd
432                                             'slot-boundp-using-class))))))
433
434 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
435   (macrolet ((emf-funcall (emf &rest args)
436                `(invoke-effective-method-function ,emf nil
437                                                   :required-args ,args)))
438     (set-fun-name
439      (case name
440        (reader (lambda (instance)
441                  (emf-funcall sdfun class instance slotd)))
442        (writer (lambda (nv instance)
443                  (emf-funcall sdfun nv class instance slotd)))
444        (boundp (lambda (instance)
445                  (emf-funcall sdfun class instance slotd))))
446      `(,name ,(class-name class) ,(slot-definition-name slotd)))))
447 \f
448 (defun make-std-reader-method-function (class-or-name slot-name)
449   (declare (ignore class-or-name))
450   (let* ((initargs (copy-tree
451                     (make-method-function
452                      (lambda (instance)
453                        (pv-binding1 (.pv. .calls.
454                                           (bug "Please report this")
455                                           (instance) (instance-slots))
456                          (instance-read-internal
457                           .pv. instance-slots 0
458                           (slot-value instance slot-name))))))))
459     (setf (getf (getf initargs 'plist) :slot-name-lists)
460           (list (list nil slot-name)))
461     initargs))
462
463 (defun make-std-writer-method-function (class-or-name slot-name)
464   (let* ((class (when (eq *boot-state* 'complete)
465                   (if (typep class-or-name 'class)
466                       class-or-name
467                       (find-class class-or-name nil))))
468          (safe-p (and class
469                       (safe-p class)))
470          (check-fun (lambda (new-value instance)
471                       (let* ((class (class-of instance))
472                              (slotd (find-slot-definition class slot-name))
473                              (type-check-function
474                               (when slotd
475                                 (slot-definition-type-check-function slotd))))
476                         (when type-check-function
477                           (funcall type-check-function new-value)))))
478          (initargs (copy-tree
479                     (if safe-p
480                         (make-method-function
481                          (lambda (nv instance)
482                            (funcall check-fun nv instance)
483                            (pv-binding1 (.pv. .calls.
484                                               (bug "Please report this")
485                                               (instance) (instance-slots))
486                              (instance-write-internal
487                               .pv. instance-slots 0 nv
488                               (setf (slot-value instance slot-name) nv)))))
489                         (make-method-function
490                          (lambda (nv instance)
491                            (pv-binding1 (.pv. .calls.
492                                               (bug "Please report this")
493                                               (instance) (instance-slots))
494                              (instance-write-internal
495                               .pv. instance-slots 0 nv
496                               (setf (slot-value instance slot-name) nv)))))))))
497     (setf (getf (getf initargs 'plist) :slot-name-lists)
498           (list nil (list nil slot-name)))
499     initargs))
500
501 (defun make-std-boundp-method-function (class-or-name slot-name)
502   (declare (ignore class-or-name))
503   (let* ((initargs (copy-tree
504                     (make-method-function
505                      (lambda (instance)
506                        (pv-binding1 (.pv. .calls.
507                                           (bug "Please report this")
508                                           (instance) (instance-slots))
509                           (instance-boundp-internal
510                            .pv. instance-slots 0
511                            (slot-boundp instance slot-name))))))))
512     (setf (getf (getf initargs 'plist) :slot-name-lists)
513           (list (list nil slot-name)))
514     initargs))