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
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
|
(* camlp4r *)
(* $Id$ *)
(*
Added statements:
At toplevel (structure item):
DEFINE <uident>
DEFINE <uident> = <expression>
DEFINE <uident> (<parameters>) = <expression>
IFDEF <uident> THEN <structure_items> END
IFDEF <uident> THEN <structure_items> ELSE <structure_items> END
IFNDEF <uident> THEN <structure_items> END
IFNDEF <uident> THEN <structure_items> ELSE <structure_items> END
In expressions:
IFDEF <uident> THEN <expression> ELSE <expression> END
IFNDEF <uident> THEN <expression> ELSE <expression> END
__FILE__
__LOCATION__
In patterns:
IFDEF <uident> THEN <pattern> ELSE <pattern> END
IFNDEF <uident> THEN <pattern> ELSE <pattern> END
As Camlp4 options:
-D<uident>
-U<uident>
After having used a DEFINE <uident> followed by "= <expression>", you
can use it in expressions *and* in patterns. If the expression defining
the macro cannot be used as a pattern, there is an error message if
it is used in a pattern.
The expression __FILE__ returns the current compiled file name.
The expression __LOCATION__ returns the current location of itself.
*)
#load "pa_extend.cmo";
#load "q_MLast.cmo";
open Pcaml;
type item_or_def 'a =
[ SdStr of 'a
| SdDef of string and option (list string * MLast.expr)
| SdUnd of string
| SdNop ]
;
value rec list_remove x =
fun
[ [(y, _) :: l] when y = x -> l
| [d :: l] -> [d :: list_remove x l]
| [] -> [] ]
;
value defined = ref [];
value is_defined i = List.mem_assoc i defined.val;
value loc = (0, 0);
value subst mloc env =
loop where rec loop =
fun
[ <:expr< let $opt:rf$ $list:pel$ in $e$ >> ->
let pel = List.map (fun (p, e) -> (p, loop e)) pel in
<:expr< let $opt:rf$ $list:pel$ in $loop e$ >>
| <:expr< if $e1$ then $e2$ else $e3$ >> ->
<:expr< if $loop e1$ then $loop e2$ else $loop e3$ >>
| <:expr< $e1$ $e2$ >> -> <:expr< $loop e1$ $loop e2$ >>
| <:expr< $lid:x$ >> | <:expr< $uid:x$ >> as e ->
try <:expr< $anti:List.assoc x env$ >> with
[ Not_found -> e ]
| <:expr< ($list:x$) >> -> <:expr< ($list:List.map loop x$) >>
| <:expr< { $list:pel$ } >> ->
let pel = List.map (fun (p, e) -> (p, loop e)) pel in
<:expr< { $list:pel$ } >>
| e -> e ]
;
value substp mloc env =
loop where rec loop =
fun
[ <:expr< $e1$ $e2$ >> -> <:patt< $loop e1$ $loop e2$ >>
| <:expr< $lid:x$ >> ->
try <:patt< $anti:List.assoc x env$ >> with
[ Not_found -> <:patt< $lid:x$ >> ]
| <:expr< $uid:x$ >> ->
try <:patt< $anti:List.assoc x env$ >> with
[ Not_found -> <:patt< $uid:x$ >> ]
| <:expr< $int:x$ >> -> <:patt< $int:x$ >>
| <:expr< ($list:x$) >> -> <:patt< ($list:List.map loop x$) >>
| <:expr< { $list:pel$ } >> ->
let ppl = List.map (fun (p, e) -> (p, loop e)) pel in
<:patt< { $list:ppl$ } >>
| x ->
Stdpp.raise_with_loc mloc
(Failure
"this macro cannot be used in a pattern (see its definition)") ]
;
value incorrect_number loc l1 l2 =
Stdpp.raise_with_loc loc
(Failure
(Printf.sprintf "expected %d parameters; found %d"
(List.length l2) (List.length l1)))
;
value define eo x =
do {
match eo with
[ Some ([], e) ->
EXTEND
expr: LEVEL "simple"
[ [ UIDENT $x$ -> Pcaml.expr_reloc (fun _ -> loc) 0 e ] ]
;
patt: LEVEL "simple"
[ [ UIDENT $x$ ->
let p = substp loc [] e in
Pcaml.patt_reloc (fun _ -> loc) 0 p ] ]
;
END
| Some (sl, e) ->
EXTEND
expr: LEVEL "apply"
[ [ UIDENT $x$; param = SELF ->
let el =
match param with
[ <:expr< ($list:el$) >> -> el
| e -> [e] ]
in
if List.length el = List.length sl then
let env = List.combine sl el in
let e = subst loc env e in
Pcaml.expr_reloc (fun _ -> loc) 0 e
else
incorrect_number loc el sl ] ]
;
patt: LEVEL "simple"
[ [ UIDENT $x$; param = SELF ->
let pl =
match param with
[ <:patt< ($list:pl$) >> -> pl
| p -> [p] ]
in
if List.length pl = List.length sl then
let env = List.combine sl pl in
let p = substp loc env e in
Pcaml.patt_reloc (fun _ -> loc) 0 p
else
incorrect_number loc pl sl ] ]
;
END
| None -> () ];
defined.val := [(x, eo) :: defined.val];
}
;
value undef x =
try
do {
let eo = List.assoc x defined.val in
match eo with
[ Some ([], _) ->
do {
DELETE_RULE expr: UIDENT $x$ END;
DELETE_RULE patt: UIDENT $x$ END;
}
| Some (_, _) ->
do {
DELETE_RULE expr: UIDENT $x$; SELF END;
DELETE_RULE patt: UIDENT $x$; SELF END;
}
| None -> () ];
defined.val := list_remove x defined.val;
}
with
[ Not_found -> () ]
;
EXTEND
GLOBAL: expr patt str_item sig_item;
str_item: FIRST
[ [ x = macro_def ->
match x with
[ SdStr [si] -> si
| SdStr sil -> <:str_item< declare $list:sil$ end >>
| SdDef x eo -> do { define eo x; <:str_item< declare end >> }
| SdUnd x -> do { undef x; <:str_item< declare end >> }
| SdNop -> <:str_item< declare end >> ] ] ]
;
macro_def:
[ [ "DEFINE"; i = uident; def = opt_macro_value -> SdDef i def
| "UNDEF"; i = uident -> SdUnd i
| "IFDEF"; i = uident; "THEN"; d = str_item_or_macro; "END" ->
if is_defined i then d else SdNop
| "IFDEF"; i = uident; "THEN"; d1 = str_item_or_macro; "ELSE";
d2 = str_item_or_macro; "END" ->
if is_defined i then d1 else d2
| "IFNDEF"; i = uident; "THEN"; d = str_item_or_macro; "END" ->
if is_defined i then SdNop else d
| "IFNDEF"; i = uident; "THEN"; d1 = str_item_or_macro; "ELSE";
d2 = str_item_or_macro; "END" ->
if is_defined i then d2 else d1 ] ]
;
str_item_or_macro:
[ [ d = macro_def -> d
| si = LIST1 str_item -> SdStr si ] ]
;
opt_macro_value:
[ [ "("; pl = LIST1 LIDENT SEP ","; ")"; "="; e = expr -> Some (pl, e)
| "="; e = expr -> Some ([], e)
| -> None ] ]
;
expr: LEVEL "top"
[ [ "IFDEF"; i = uident; "THEN"; e1 = expr; "ELSE"; e2 = expr; "END" ->
if is_defined i then e1 else e2
| "IFNDEF"; i = uident; "THEN"; e1 = expr; "ELSE"; e2 = expr; "END" ->
if is_defined i then e2 else e1 ] ]
;
expr: LEVEL "simple"
[ [ LIDENT "__FILE__" -> <:expr< $str:Pcaml.input_file.val$ >>
| LIDENT "__LOCATION__" ->
let bp = string_of_int (fst loc) in
let ep = string_of_int (snd loc) in
<:expr< ($int:bp$, $int:ep$) >> ] ]
;
patt:
[ [ "IFDEF"; i = uident; "THEN"; p1 = patt; "ELSE"; p2 = patt; "END" ->
if is_defined i then p1 else p2
| "IFNDEF"; i = uident; "THEN"; p1 = patt; "ELSE"; p2 = patt; "END" ->
if is_defined i then p2 else p1 ] ]
;
uident:
[ [ i = UIDENT -> i ] ]
;
END;
Pcaml.add_option "-D" (Arg.String (define None))
"<string> Define for IFDEF instruction."
;
Pcaml.add_option "-U" (Arg.String undef)
"<string> Undefine for IFDEF instruction."
;
|
