1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
|
;;; -*- package: pcl -*-
(in-package :pcl)
;;; pw-- enhanced (11/96) to derive slot types from slot definition
;;; if class name is available via (the class instance). Note this
;;; may cause problems if the class layout changes and the forms that
;;; use this trick are not re-compiled. Maybe this isn't a good idea.
(defmacro with-slots (slots instance &body body)
"The macro WITH-SLOTS establishes a lexical environment for referring
to the SLOTS in the INSTANCE named by the given slot-names as though they
were variables. Within such a context the value of the slot can be
specified by using its slot name, as if it were a lexically bound variable.
Both setf and setq can be used to set the value of the slot.
The macro with-slots translates an appearance of the slot name as a
variable into a call to slot-value.
"
(flet ((find-slot-type (class slot-name)
(let ((slotd (find-slot-definition class slot-name)))
(if slotd
(slot-definition-type slotd)
(warn "Slot ~a not defined in class ~a."
slot-name (class-name class))))))
(let ((in (gensym))
;; Use any available hints to derive the slot types.
;; Slot-value on defstruct objects are already optimized
;; so don't mess with them. I key on (the foo x).
(class
(and (consp instance)
(eq (car instance) 'the)
(symbolp (second instance))
(let ((class (find-class (second instance))))
(and (not (structure-class-p class)) class)))))
`(let ((,in ,instance))
#+cmu (declare (ignorable ,in))
,@(let ((instance (if (and (consp instance) (eq (car instance) 'the))
(third instance)
instance)))
(and (symbolp instance)
`((declare (variable-rebinding ,in ,instance)))))
,in
(symbol-macrolet
,(mapcar #'(lambda (slot-entry)
(let* ((variable-name
(if (symbolp slot-entry)
slot-entry
(car slot-entry)))
(slot-name
(if (symbolp slot-entry)
slot-entry
(cadr slot-entry)))
(slot-type
(and class
(find-slot-type class slot-name))))
`(,variable-name
,(if slot-type
`(the ,slot-type
(slot-value ,in ',slot-name))
`(slot-value ,in ',slot-name)))))
slots)
,@body)))))
|
