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
26;;;; ANSI CL condition for unbound slots
27
28(define-condition unbound-slot (cell-error)
29  ((instance :reader unbound-slot-instance :initarg :instance))
30  (:report (lambda (condition stream)
31             (handler-case
32                 (format stream "~@<The slot ~/sb-ext:print-symbol-with-prefix/ ~
33                         is unbound in the object ~A.~@:>"
34                         (cell-error-name condition)
35                         (unbound-slot-instance condition))
36               (serious-condition ()
37                 ;; In case of an error try again avoiding custom PRINT-OBJECT's.
38                 (format stream "~&Error during printing.~%~@<The slot ~
39                         ~/sb-ext:print-symbol-with-prefix/ ~
40                         is unbound in an instance of ~
41                         ~/sb-ext:print-symbol-with-prefix/.~@:>"
42                         (cell-error-name condition)
43                         (type-of (unbound-slot-instance condition))))))))
44
45(defmethod wrapper-fetcher ((class standard-class))
46  'std-instance-wrapper)
47
48(defmethod slots-fetcher ((class standard-class))
49  'std-instance-slots)
50
51(defmethod raw-instance-allocator ((class standard-class))
52  'allocate-standard-instance)
53
54;;; These three functions work on std-instances and fsc-instances. These are
55;;; instances for which it is possible to change the wrapper and the slots.
56;;;
57;;; For these kinds of instances, most specified methods from the instance
58;;; structure protocol are promoted to the implementation-specific class
59;;; std-class. Many of these methods call these four functions.
60
61(defun %swap-wrappers-and-slots (i1 i2) ; old -> new
62  (cond ((std-instance-p i1)
63         #+(and compact-instance-header x86-64)
64         (let ((oslots (std-instance-slots i1))
65               (nslots (std-instance-slots i2)))
66           ;; The hash val is in the header of the slots. Copying is race-free
67           ;; because it is immutable once memoized by STD-INSTANCE-HASH.
68           (sb-vm::cas-header-data-high
69            nslots 0 (sb-impl::%std-instance-hash oslots)))
70         ;; FIXME: If a backend supports two-word primitive instances
71         ;; and double-wide CAS, it's probably best to use that.
72         ;; Maybe we're inside a mutex here anyway though?
73         (let ((w1 (std-instance-wrapper i1))
74               (s1 (std-instance-slots i1)))
75           (setf (std-instance-wrapper i1) (std-instance-wrapper i2))
76           (setf (std-instance-slots i1) (std-instance-slots i2))
77           (setf (std-instance-wrapper i2) w1)
78           (setf (std-instance-slots i2) s1)))
79        ((fsc-instance-p i1)
80         (let ((w1 (fsc-instance-wrapper i1))
81               (s1 (fsc-instance-slots i1)))
82           (setf (fsc-instance-wrapper i1) (fsc-instance-wrapper i2))
83           (setf (fsc-instance-slots i1) (fsc-instance-slots i2))
84           (setf (fsc-instance-wrapper i2) w1)
85           (setf (fsc-instance-slots i2) s1)))
86        (t
87         (error "unrecognized instance type"))))
88
89;;;; STANDARD-INSTANCE-ACCESS
90
91(declaim (inline standard-instance-access
92                 (setf standard-instance-access)
93                 (cas stadard-instance-access)
94                 funcallable-standard-instance-access
95                 (setf funcallable-standard-instance-access)
96                 (cas funcallable-standard-instance-access)))
97
98(defun standard-instance-access (instance location)
99  (clos-slots-ref (std-instance-slots instance) location))
100
101(defun (setf standard-instance-access) (new-value instance location)
102  (setf (clos-slots-ref (std-instance-slots instance) location) new-value))
103
104(defun (cas standard-instance-access) (old-value new-value instance location)
105  ;; FIXME: Maybe get rid of CLOS-SLOTS-REF entirely?
106  (cas (svref (std-instance-slots instance) location) old-value new-value))
107
108(defun funcallable-standard-instance-access (instance location)
109  (clos-slots-ref (fsc-instance-slots instance) location))
110
111(defun (setf funcallable-standard-instance-access) (new-value instance location)
112  (setf (clos-slots-ref (fsc-instance-slots instance) location) new-value))
113
114(defun (cas funcallable-standard-instance-access) (old-value new-value instance location)
115  ;; FIXME: Maybe get rid of CLOS-SLOTS-REF entirely?
116  (cas (svref (fsc-instance-slots instance) location) old-value new-value))
117
118;;;; SLOT-VALUE, (SETF SLOT-VALUE), SLOT-BOUNDP, SLOT-MAKUNBOUND
119
120(declaim (ftype (sfunction (t symbol) t) slot-value))
121(defun slot-value (object slot-name)
122  (let* ((wrapper (valid-wrapper-of object))
123         (cell (find-slot-cell wrapper slot-name))
124         (location (car cell))
125         (value
126          (cond ((fixnump location)
127                 (if (std-instance-p object)
128                     (standard-instance-access object location)
129                     (funcallable-standard-instance-access object location)))
130                ((not location)
131                 (return-from slot-value
132                   (if cell
133                       (funcall (slot-info-reader (cdr cell)) object)
134                       (values (slot-missing (wrapper-class* wrapper) object
135                                             slot-name 'slot-value)))))
136                ;; this next test means CONSP, but the transform that weakens
137                ;; CONSP to LISTP isn't working here for some reason.
138                ((listp location)
139                 (cdr location))
140                (t
141                 (bug "Bogus slot cell in SLOT-VALUE: ~S" cell)))))
142    (if (eq +slot-unbound+ value)
143        (slot-unbound (wrapper-class* wrapper) object slot-name)
144        value)))
145
146(defun set-slot-value (object slot-name new-value)
147  (let* ((wrapper (valid-wrapper-of object))
148         (cell (or (find-slot-cell wrapper slot-name)
149                   (return-from set-slot-value
150                     (progn (slot-missing (wrapper-class* wrapper)
151                                          object slot-name 'setf new-value)
152                            new-value))))
153         (location (car cell))
154         (info (cdr cell))
155         (typecheck (slot-info-typecheck info)))
156    (when typecheck
157      (funcall typecheck new-value))
158    (cond ((fixnump location)
159           (if (std-instance-p object)
160               (setf (standard-instance-access object location) new-value)
161               (setf (funcallable-standard-instance-access object location)
162                     new-value)))
163          ((not location)
164           (funcall (slot-info-writer info) new-value object))
165          ((listp location) ; forcibly transform CONSP to LISTP
166           (setf (cdr location) new-value))
167          (t
168           (bug "Bogus slot-cell in SET-SLOT-VALUE: ~S" cell))))
169  new-value)
170
171;;; A version of SET-SLOT-VALUE for use in safe code, where we want to
172;;; check types when writing to slots:
173;;;   * Doesn't have an optimizing compiler-macro
174;;;   * Isn't special-cased in WALK-METHOD-LAMBDA
175(defun safe-set-slot-value (object slot-name new-value)
176  (set-slot-value object slot-name new-value))
177
178(defun (cas slot-value) (old-value new-value object slot-name)
179  (let* ((wrapper (valid-wrapper-of object))
180         (cell (or (find-slot-cell wrapper slot-name)
181                   (return-from slot-value
182                     (values (slot-missing (wrapper-class* wrapper) object slot-name
183                                           'cas (list old-value new-value))))))
184         (location (car cell))
185         (info (cdr cell))
186         (typecheck (slot-info-typecheck info)))
187    (when typecheck
188      (funcall typecheck new-value))
189    (let ((old (cond ((fixnump location)
190                      (if (std-instance-p object)
191                          (cas (standard-instance-access object location) old-value new-value)
192                          (cas (funcallable-standard-instance-access object location)
193                               old-value new-value)))
194                     ((not location)
195                      ;; FIXME: (CAS SLOT-VALUE-USING-CLASS)...
196                      (error "Cannot compare-and-swap slot ~S on: ~S" slot-name object))
197                     ((listp location) ; forcibly transform CONSP to LISTP
198                      (cas (cdr location) old-value new-value))
199                     (t
200                      (bug "Bogus slot-cell in (CAS SLOT-VALUE): ~S" cell)))))
201      (if (and (eq +slot-unbound+ old)
202               (neq old old-value))
203          (slot-unbound (wrapper-class* wrapper) object slot-name)
204          old))))
205
206(defun slot-boundp (object slot-name)
207  (let* ((wrapper (valid-wrapper-of object))
208         (cell (find-slot-cell wrapper slot-name))
209         (location (car cell))
210         (value
211          (cond ((fixnump location)
212                 (if (std-instance-p object)
213                     (standard-instance-access object location)
214                     (funcallable-standard-instance-access object location)))
215                ((not location)
216                 (return-from slot-boundp
217                   (if cell
218                       (funcall (slot-info-boundp (cdr cell)) object)
219                       (and (slot-missing (wrapper-class* wrapper) object
220                                          slot-name 'slot-boundp)
221                            t))))
222                ((listp location) ; forcibly transform CONSP to LISTP
223                 (cdr location))
224                (t
225                 (bug "Bogus slot cell in SLOT-VALUE: ~S" cell)))))
226    (not (eq +slot-unbound+ value))))
227
228(defun slot-makunbound (object slot-name)
229  (let* ((wrapper (valid-wrapper-of object))
230         (cell (find-slot-cell wrapper slot-name))
231         (location (car cell)))
232    (cond ((fixnump location)
233           (if (std-instance-p object)
234               (setf (standard-instance-access object location) +slot-unbound+)
235               (setf (funcallable-standard-instance-access object location)
236                     +slot-unbound+)))
237          ((not location)
238           (if cell
239               (let ((class (wrapper-class* wrapper)))
240                 (slot-makunbound-using-class class object
241                                              (find-slot-definition class slot-name)))
242               (slot-missing (wrapper-class* wrapper) object slot-name
243                             'slot-makunbound)))
244          ((listp location) ; forcibly transform CONSP to LISTP
245           (setf (cdr location) +slot-unbound+))
246          (t
247           (bug "Bogus slot-cell in SLOT-MAKUNBOUND: ~S" cell))))
248  object)
249
250;; Note that CLHS "encourages" implementors to base this on
251;; SLOT-EXISTS-P-USING-CLASS, whereas 88-002R made no such claim,
252;; however Appendix D of AMOP sketches out such an implementation.
253(defun slot-exists-p (object slot-name)
254  (not (null (find-slot-cell (valid-wrapper-of object) slot-name))))
255
256(defun slot-value-for-printing (object slot-name)
257  (if (slot-boundp object slot-name)
258      (slot-value object slot-name)
259      (load-time-value (make-unprintable-object "unbound slot") t)))
260
261(defmethod slot-value-using-class ((class std-class)
262                                   (object standard-object)
263                                   (slotd standard-effective-slot-definition))
264  ;; FIXME: Do we need this? SLOT-VALUE checks for obsolete
265  ;; instances. Are users allowed to call this directly?
266  (check-obsolete-instance object)
267  (let* ((location (slot-definition-location slotd))
268         (value
269          (typecase location
270            (fixnum
271             (cond ((std-instance-p object)
272                    (clos-slots-ref (std-instance-slots object)
273                                    location))
274                   ((fsc-instance-p object)
275                    (clos-slots-ref (fsc-instance-slots object)
276                                    location))
277                   (t (bug "unrecognized instance type in ~S"
278                           'slot-value-using-class))))
279            (cons
280             (cdr location))
281            (t
282             (instance-structure-protocol-error slotd
283                                                'slot-value-using-class)))))
284    (if (eq value +slot-unbound+)
285        (values (slot-unbound class object (slot-definition-name slotd)))
286        value)))
287
288(defmethod (setf slot-value-using-class)
289           (new-value (class std-class)
290                      (object standard-object)
291                      (slotd standard-effective-slot-definition))
292  ;; FIXME: Do we need this? SET-SLOT-VALUE checks for obsolete
293  ;; instances. Are users allowed to call this directly?
294  (check-obsolete-instance object)
295  (let* ((info (slot-definition-info slotd))
296         (location (slot-definition-location slotd))
297         (typecheck (slot-info-typecheck info))
298         (new-value (if typecheck
299                        (funcall (the function typecheck) new-value)
300                        new-value)))
301    (typecase location
302      (fixnum
303       (cond ((std-instance-p object)
304              (setf (clos-slots-ref (std-instance-slots object) location)
305                    new-value))
306             ((fsc-instance-p object)
307              (setf (clos-slots-ref (fsc-instance-slots object) location)
308                    new-value))
309             (t (bug "unrecognized instance type in ~S"
310                     '(setf slot-value-using-class)))))
311      (cons
312       (setf (cdr location) new-value))
313      (t
314       (instance-structure-protocol-error
315        slotd '(setf slot-value-using-class))))))
316
317(defmethod slot-boundp-using-class
318           ((class std-class)
319            (object standard-object)
320            (slotd standard-effective-slot-definition))
321  ;; FIXME: Do we need this? SLOT-BOUNDP checks for obsolete
322  ;; instances. Are users allowed to call this directly?
323  (check-obsolete-instance object)
324  (let* ((location (slot-definition-location slotd))
325         (value
326          (typecase location
327            (fixnum
328             (cond ((std-instance-p object)
329                          (clos-slots-ref (std-instance-slots object)
330                                          location))
331                   ((fsc-instance-p object)
332                    (clos-slots-ref (fsc-instance-slots object)
333                                    location))
334                   (t (bug "unrecognized instance type in ~S"
335                           'slot-boundp-using-class))))
336            (cons
337             (cdr location))
338            (t
339             (instance-structure-protocol-error slotd
340                                                'slot-boundp-using-class)))))
341    (not (eq value +slot-unbound+))))
342
343(defmethod slot-makunbound-using-class
344           ((class std-class)
345            (object standard-object)
346            (slotd standard-effective-slot-definition))
347  (check-obsolete-instance object)
348  (let ((location (slot-definition-location slotd)))
349    (typecase location
350      (fixnum
351       (cond ((std-instance-p object)
352              (setf (clos-slots-ref (std-instance-slots object) location)
353                    +slot-unbound+))
354             ((fsc-instance-p object)
355              (setf (clos-slots-ref (fsc-instance-slots object) location)
356                    +slot-unbound+))
357             (t (bug "unrecognized instance type in ~S"
358                     'slot-makunbound-using-class))))
359      (cons
360       (setf (cdr location) +slot-unbound+))
361      (t
362       (instance-structure-protocol-error slotd
363                                          'slot-makunbound-using-class))))
364  object)
365
366(defmethod slot-value-using-class
367    ((class condition-class)
368     (object condition)
369     (slotd condition-effective-slot-definition))
370  (let ((fun (slot-info-reader (slot-definition-info slotd))))
371    (funcall fun object)))
372
373(defmethod (setf slot-value-using-class)
374    (new-value
375     (class condition-class)
376     (object condition)
377     (slotd condition-effective-slot-definition))
378  (let ((fun (slot-info-writer (slot-definition-info slotd))))
379    (funcall fun new-value object)))
380
381(defmethod slot-boundp-using-class
382    ((class condition-class)
383     (object condition)
384     (slotd condition-effective-slot-definition))
385  (let ((fun (slot-info-boundp (slot-definition-info slotd))))
386    (funcall fun object)))
387
388(defmethod slot-makunbound-using-class ((class condition-class) object slot)
389  (error "attempt to unbind slot ~S in condition object ~S."
390         slot object))
391
392(defmethod slot-value-using-class
393    ((class structure-class)
394     (object structure-object)
395     (slotd structure-effective-slot-definition))
396  (let* ((function (slot-definition-internal-reader-function slotd))
397         (value (funcall function object)))
398    (declare (type function function))
399    ;; FIXME: Is this really necessary? Structure slots should surely
400    ;; never be unbound!
401    (if (eq value +slot-unbound+)
402        (values (slot-unbound class object (slot-definition-name slotd)))
403        value)))
404
405(defmethod (setf slot-value-using-class)
406    (new-value (class structure-class)
407               (object structure-object)
408               (slotd structure-effective-slot-definition))
409  (let ((function (slot-definition-internal-writer-function slotd)))
410    (declare (type function function))
411    (funcall function new-value object)))
412
413(defmethod slot-boundp-using-class
414           ((class structure-class)
415            (object structure-object)
416            (slotd structure-effective-slot-definition))
417  t)
418
419(defmethod slot-makunbound-using-class
420           ((class structure-class)
421            (object structure-object)
422            (slotd structure-effective-slot-definition))
423  (error "Structure slots can't be unbound."))
424
425(defmethod slot-missing
426           ((class t) instance slot-name operation &optional new-value)
427  (error "~@<When attempting to ~A, the slot ~S is missing from the ~
428          object ~S.~@:>"
429         (ecase operation
430           (slot-value "read the slot's value (slot-value)")
431           (setf (format nil
432                         "set the slot's value to ~S (SETF of SLOT-VALUE)"
433                         new-value))
434           (slot-boundp "test to see whether slot is bound (SLOT-BOUNDP)")
435           (slot-makunbound "make the slot unbound (SLOT-MAKUNBOUND)"))
436         slot-name
437         instance))
438
439(defmethod slot-unbound ((class t) instance slot-name)
440  (restart-case
441      (error 'unbound-slot :name slot-name :instance instance)
442    (use-value (v)
443      :report "Return a value as the slot-value."
444      :interactive read-evaluated-form
445      v)
446    (store-value (v)
447      :report "Store and return a value as the slot-value."
448      :interactive read-evaluated-form
449      (setf (slot-value instance slot-name) v))))
450
451(defun slot-unbound-internal (instance position)
452  (values
453   (slot-unbound
454    (class-of instance)
455    instance
456    (etypecase position
457      (fixnum
458       ;; In the vast majority of cases location corresponds to the position
459       ;; in list. The only exceptions are when there are non-local slots
460       ;; before the one we want.
461       (let* ((slots (layout-slot-list (layout-of instance)))
462              (guess (nth position slots)))
463         (if (eql position (slot-definition-location guess))
464             (slot-definition-name guess)
465             (slot-definition-name
466              (car (member position (class-slots instance) :key #'slot-definition-location))))))
467      (cons
468       (car position))))))
469
470;;; FIXME: AMOP says that allocate-instance implies finalize-inheritance
471;;; if the class is not yet finalized, but we don't seem to be taking
472;;; care of this for non-standard-classes.
473(defmethod allocate-instance ((class standard-class) &rest initargs)
474  (declare (ignore initargs)
475           (inline ensure-class-finalized))
476  (allocate-standard-instance
477   (class-wrapper (ensure-class-finalized class))))
478
479(defmethod allocate-instance ((class structure-class) &rest initargs)
480  (declare (ignore initargs))
481  (let ((constructor (class-defstruct-constructor class)))
482    (if constructor
483        (funcall constructor)
484        (error "Don't know how to allocate ~S" class))))
485
486(defmethod allocate-instance ((class condition-class) &rest initargs)
487  (declare (ignore initargs))
488  (values (allocate-condition (class-name class))))
489
490(defmethod allocate-instance ((class system-class) &rest initargs)
491  (declare (ignore initargs))
492  (error "Cannot allocate an instance of ~S." class))
493
494;;; AMOP says that CLASS-SLOTS signals an error for unfinalized classes.
495(defmethod class-slots :before ((class slot-class))
496  (unless (class-finalized-p class)
497    (error 'simple-reference-error
498           :format-control "~S called on ~S, which is not yet finalized."
499           :format-arguments (list 'class-slots class)
500           :references (list '(:amop :generic-function class-slots)))))
501
502(defun %set-slots (object names &rest values)
503  (mapc (lambda (name value)
504          (if (eq value +slot-unbound+)
505              ;; SLOT-MAKUNBOUND-USING-CLASS might do something nonstandard.
506              (slot-makunbound object name)
507              (setf (slot-value object name) value)))
508        names values))
509