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
|
;;;; 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)))
(hq: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 getf-path (place &rest indicators)
"(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))"
(if
(null indicators) place
(reduce (lambda (nested key) `(getf ,nested ,key))
indicators
:initial-value place)))
(defmacro with-keypaths (keypaths plist &body body)
"Bind SETFable places to locations in a nested PLIST and evaluate BODY.
E.g.
> (defvar *pl* '(:x (:a 10 :b 20) :y (:c 30)))
*PL*
> (with-keypaths
((b :x :b)
(c :y :c)
(d :y :d))
(incf b)
(setf c (* c b))
(setf d :HELLO))
:HELLO
> *pl*
(:X (:A 10 :B 21) :Y (:D :HELLO :C 630))
"
(let ((tmp-plist (gensym "plist")))
`(let ((,tmp-plist ,plist))
(symbol-macrolet
,(loop :for (var . path) :in keypaths
:collect `(,var (getf-path ,tmp-plist ,@path)))
,@body))))
(defmacro slot-path-value (place &rest slots)
"(SLOT-PATH-VALUE PLACE S1 ... SN) expands into (SLOT-VALUE (...(SLOT-VALUE PLACE S1) ..) SN). It gives you a SETFable in a nested tree of class instances."
(if (null slots) place
(reduce (lambda (nested slot) `(slot-value ,nested ,slot))
slots
:initial-value place)))
(defmacro with-slot-paths (slotpaths root &body body)
" Bind SETFable places to locations in a nested tree of CLOS instances and evaluate BODY.
> (defclass moo ()
((x :initform 10)))
#<STANDARD-CLASS DERRIDA::MOO>
> (defclass zoo ()
((a-moo :initform (make-instance 'moo))))
#<STANDARD-CLASS DERRIDA::ZOO>
> (defvar *z* (make-instance 'zoo))
*Z*
> (with-slot-paths
((x 'a-moo 'x)) *z*
(setf x (+ x 20)))
30
> (describe (slot-value *z* 'a-moo))
#<MOO {100AEB1293}>
[standard-object]
Slots with :INSTANCE allocation:
X = 30
"
(let ((tmp-root (gensym "root")))
`(let ((,tmp-root ,root))
(symbol-macrolet
,(loop :for (var . path) :in slotpaths
:collect `(,var (slot-path-value ,tmp-root ,@path)))
,@body))))
|
