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
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
|
;;;; derrida.lisp
(in-package #:derrida)
(defmacro with-alist ((&optional (accessor 'cdr)) (&rest bindings) alist &body body)
"Bind variables to accessors into ALISTS. ACCESSOR, which should be
an accessor function, is called like (ACCESSOR (ASSOC ..)).
Each member of BINDINGS is either a symbol VAR or a list that
looks like (VAR KEY-TERM . KWARGS).
KWARGS are passed as keyword argments to (ASSOC KEY-TERM ALIST ...).
EXAMPLE:
(let ((al
(list (cons 'name \"colin\")
(list :hobbies \"fiddling\" \"diddling\")
(list \"job\" :executive \"crum bum\"))))
(with-alist ()
(name (hobbies :hobbies) (job \"job\" :test 'equalp))
al
(setf job (format nil \"~{~a~^ ~}\" job))
(format t \"---------------------------~%\")
(format t \"name: ~a~%hobbies: ~{~a~^,~}~%job: ~a~%\"
name hobbies job)
(format t \"---------------------------~%\")
al))
---------------------------
name: colin
hobbies: fiddling,diddling
job: EXECUTIVE crum bum
---------------------------
((NAME . \"colin\") (:HOBBIES \"fiddling\" \"diddling\")
(\"job\" . \"EXECUTIVE crum bum\"))
"
(let* ((alist-var
(gensym))
(macrolet-bindings
(loop for term in bindings
when (symbolp term )
collect `(,term (,accessor (assoc ',term ,alist-var)))
when (consp term)
collect `(,(first term)
(,accessor (assoc ',(second term) ,alist-var ,@(nthcdr 2 term)))))))
`(let ((,alist-var ,alist)) (symbol-macrolet ,macrolet-bindings ,@body))))
(defmacro with-plist (keys plist &body body)
"KEYS is a list, each member of which is either a symbol or a pair of symbols.
If a member is just a symbol, say KEY, then it is treated as the name
of a symbol-macro (defined using symbol-macrolet) that expands to the
expression (getf PLIST KEY). In this case, KEY is not allowed to be a
keyword symbol.
If a member is a pair of symbols, it is of the form (VAR KEY). Here,
key is a valid key into the PLIST and VAR is the name of the symbol
macrolet that will be bound to (getf PLIST KEY).
EXAMPLE:
(let ((pl
(list 'name \"colin\" :age 40 :|currentJob| :crumb-bum)))
(with-plist (name (age :age) (job :|currentJob|)) pl
(setf age (1+ age))
(format t \"~a the ~a had a birthday, and is now ~a years old~%\"
name job age)
pl))
The above would print out:
colin the CRUMB-BUM had a birthday, and is now 41 years old
And would return
(NAME \"colin\" :AGE 41 :|currentJob| :CRUMB-BUM)"
(let* ((plist-var
(gensym))
(macrolet-bindings
(loop for term in keys
when (consp term )
collect (destructuring-bind (var key) term
`(,var (getf ,plist-var ',key)))
else
collect `(,term (getf ,plist-var ',term)))))
`(let ((,plist-var ,plist)) (symbol-macrolet ,macrolet-bindings ,@body))))
(defmacro define-deep-place-accessor (name nester &optional docstring)
"An internal helper macro. It defines a macro named NAME. NESTER
should be a function passed to REDUCE. Its purpose is to construct
nested access. See applications of DEFINE-DEEP-PLACE-ACCESSOR for examples."
`(defmacro ,name (place &rest indicators)
,docstring
(if (null indicators) place
(reduce ,nester indicators :initial-value place))))
(defmacro define-with-deep-access (name accessor-macro &optional docstring)
"An internal helper macro for defining forms that behave like
WITH-SLOTS. NAME, a symbol, is the name of the macro being
defined. ACCESSOR-MACRO should be a symbol naming a macro defined with
DEFINE-DEEP-PLACE-ACCESSOR. See applications of this form for examples."
`(defmacro ,name (binding-paths place-form &body body)
,docstring
(let ((tmp-place (gensym "place")))
`(let ((,tmp-place ,place-form))
(symbol-macrolet
,(loop :for (var . path) :in binding-paths
:collect
(list var (list* ',accessor-macro tmp-place path)))
,@body)))))
(define-deep-place-accessor
gethash-path
(lambda (nested key) `(gethash ,key ,nested))
"(GETHASH-PATH HASH K1 ... KN) expends into (GETHASH ( ... (GETHASH K1 PLACE) ...) KN).")
(define-deep-place-accessor
slot-value-path
(lambda (nested slot) `(slot-value ,nested ,slot))
"(SLOT-VALUE-PATH PLACE S1 ... SN) expands into (SLOT-VALUE (...(SLOT-VALUE PLACE S1) ..) SN). It gives you a SETFable in a nested tree of class instances.")
(define-deep-place-accessor
getf-path
(lambda (nested key) `(getf ,nested ,key))
"(GETF-PATH PLACE K1 ... KN) expands to (GETF (... (GETF PLACE K1) ...) KN)
E.g
> (let ((pl '(:x (:a 10 :b 20) :y (:c 30))))
(incf (getf-path pl :x :b))
pl)
(:X (:A 10 :B 21) :Y (:C 30))")
(define-with-deep-access with-keypaths getf-path
"PLACE should evaluate to a PLIST. WITH-KEPATHS evaluates BODY in the
context of context established by BINDING-PATHS.
Example:
> (defvar *pl* '(:x (:a 10) :y (:b 20))
> (with-keypaths ((a :x :a)
(b :y :b)
(d :y :d)) *pl*
(incf a)
(setf d (* a b)))
220
> *pl*
(:X (:A 11) :Y (:D 220 :B 20))")
(define-with-deep-access with-slot-paths slot-value-path
"PLACE should evaluate to an instance of a CLOS class or a struct. WITH-SLOT-PATHS evaluates BODY in the context established by BINDING-PATHS.
Example:
> (defclass point () ((x :initform 0) (y :initform 0)))
#<STANDARD-CLASS DERRIDA::POINT>
> (defclass in-space ()
((location :initform (make-instance 'point))))
#<STANDARD-CLASS DERRIDA::IN-SPACE>
> (defvar *thing* (make-instance 'in-space))
*THING*
> (with-slot-paths
((x 'location 'x)
(y 'location 'y)) *thing*
(setf x 10
y -30))
-30
> (describe (slot-value *thing* 'location))
#<POINT {100781DB53}>
[standard-object]
Slots with :INSTANCE allocation:
X = 10
Y = -30")
(define-with-deep-access with-hash-paths gethash-path)
|
