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
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
|
(* -*- camlp4r -*- *)
(****************************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the Objective *)
(* Caml source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
module Make (Structure : Structure.S) = struct
module Tools = Tools.Make Structure;
module Parser = Parser.Make Structure;
open Structure;
open Format;
open Sig.Grammar;
value is_before s1 s2 =
match (s1, s2) with
[ (Skeyword _ | Stoken _, Skeyword _ | Stoken _) -> False
| (Skeyword _ | Stoken _, _) -> True
| _ -> False ]
;
value rec derive_eps =
fun
[ Slist0 _ | Slist0sep _ _ | Sopt _ -> True
| Stry s -> derive_eps s
| Stree t -> tree_derive_eps t
| Slist1 _ | Slist1sep _ _ | Stoken _ | Skeyword _ ->
(* For sure we cannot derive epsilon from these *)
False
| Smeta _ _ _ | Snterm _ | Snterml _ _ | Snext | Sself ->
(* Approximation *)
False ]
and tree_derive_eps =
fun
[ LocAct _ _ -> True
| Node {node = s; brother = bro; son = son} ->
derive_eps s && tree_derive_eps son || tree_derive_eps bro
| DeadEnd -> False ]
;
value empty_lev lname assoc =
let assoc =
match assoc with
[ Some a -> a
| None -> LeftA ]
in
{assoc = assoc; lname = lname; lsuffix = DeadEnd; lprefix = DeadEnd}
;
value change_lev entry lev n lname assoc =
let a =
match assoc with
[ None -> lev.assoc
| Some a ->
do {
if a <> lev.assoc && entry.egram.warning_verbose.val then do {
eprintf "<W> Changing associativity of level \"%s\"\n" n;
flush Pervasives.stderr
}
else ();
a
} ]
in
do {
match lname with
[ Some n ->
if lname <> lev.lname && entry.egram.warning_verbose.val then do {
eprintf "<W> Level label \"%s\" ignored\n" n; flush Pervasives.stderr
}
else ()
| None -> () ];
{assoc = a; lname = lev.lname; lsuffix = lev.lsuffix;
lprefix = lev.lprefix}
}
;
value change_to_self entry =
fun
[ Snterm e when e == entry -> Sself
| x -> x ]
;
value get_level entry position levs =
match position with
[ Some First -> ([], empty_lev, levs)
| Some Last -> (levs, empty_lev, [])
| Some (Level n) ->
let rec get =
fun
[ [] ->
do {
eprintf "No level labelled \"%s\" in entry \"%s\"\n" n
entry.ename;
flush Pervasives.stderr;
failwith "Grammar.extend"
}
| [lev :: levs] ->
if Tools.is_level_labelled n lev then ([], change_lev entry lev n, levs)
else
let (levs1, rlev, levs2) = get levs in
([lev :: levs1], rlev, levs2) ]
in
get levs
| Some (Before n) ->
let rec get =
fun
[ [] ->
do {
eprintf "No level labelled \"%s\" in entry \"%s\"\n" n
entry.ename;
flush Pervasives.stderr;
failwith "Grammar.extend"
}
| [lev :: levs] ->
if Tools.is_level_labelled n lev then ([], empty_lev, [lev :: levs])
else
let (levs1, rlev, levs2) = get levs in
([lev :: levs1], rlev, levs2) ]
in
get levs
| Some (After n) ->
let rec get =
fun
[ [] ->
do {
eprintf "No level labelled \"%s\" in entry \"%s\"\n" n
entry.ename;
flush Pervasives.stderr;
failwith "Grammar.extend"
}
| [lev :: levs] ->
if Tools.is_level_labelled n lev then ([lev], empty_lev, levs)
else
let (levs1, rlev, levs2) = get levs in
([lev :: levs1], rlev, levs2) ]
in
get levs
| None ->
match levs with
[ [lev :: levs] -> ([], change_lev entry lev "<top>", levs)
| [] -> ([], empty_lev, []) ] ]
;
value rec check_gram entry =
fun
[ Snterm e ->
if e.egram != entry.egram then do {
eprintf "\
Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n"
entry.ename e.ename;
flush Pervasives.stderr;
failwith "Grammar.extend error"
}
else ()
| Snterml e _ ->
if e.egram != entry.egram then do {
eprintf "\
Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n"
entry.ename e.ename;
flush Pervasives.stderr;
failwith "Grammar.extend error"
}
else ()
| Smeta _ sl _ -> List.iter (check_gram entry) sl
| Slist0sep s t -> do { check_gram entry t; check_gram entry s }
| Slist1sep s t -> do { check_gram entry t; check_gram entry s }
| Slist0 s | Slist1 s | Sopt s | Stry s -> check_gram entry s
| Stree t -> tree_check_gram entry t
| Snext | Sself | Stoken _ | Skeyword _ -> () ]
and tree_check_gram entry =
fun
[ Node {node = n; brother = bro; son = son} ->
do {
check_gram entry n;
tree_check_gram entry bro;
tree_check_gram entry son
}
| LocAct _ _ | DeadEnd -> () ]
;
value get_initial =
fun
[ [Sself :: symbols] -> (True, symbols)
| symbols -> (False, symbols) ]
;
value insert_tokens gram symbols =
let rec insert =
fun
[ Smeta _ sl _ -> List.iter insert sl
| Slist0 s | Slist1 s | Sopt s | Stry s -> insert s
| Slist0sep s t -> do { insert s; insert t }
| Slist1sep s t -> do { insert s; insert t }
| Stree t -> tinsert t
| Skeyword kwd -> using gram kwd
| Snterm _ | Snterml _ _ | Snext | Sself | Stoken _ -> () ]
and tinsert =
fun
[ Node {node = s; brother = bro; son = son} ->
do { insert s; tinsert bro; tinsert son }
| LocAct _ _ | DeadEnd -> () ]
in
List.iter insert symbols
;
value insert_tree entry gsymbols action tree =
let rec insert symbols tree =
match symbols with
[ [s :: sl] -> insert_in_tree s sl tree
| [] ->
match tree with
[ Node {node = s; son = son; brother = bro} ->
Node {node = s; son = son; brother = insert [] bro}
| LocAct old_action action_list ->
let () =
if entry.egram.warning_verbose.val then
eprintf "<W> Grammar extension: in [%s] some rule has been masked@."
entry.ename
else ()
in LocAct action [old_action :: action_list]
| DeadEnd -> LocAct action [] ] ]
and insert_in_tree s sl tree =
match try_insert s sl tree with
[ Some t -> t
| None -> Node {node = s; son = insert sl DeadEnd; brother = tree} ]
and try_insert s sl tree =
match tree with
[ Node {node = s1; son = son; brother = bro} ->
if Tools.eq_symbol s s1 then
let t = Node {node = s1; son = insert sl son; brother = bro} in
Some t
else if is_before s1 s || derive_eps s && not (derive_eps s1) then
let bro =
match try_insert s sl bro with
[ Some bro -> bro
| None ->
Node {node = s; son = insert sl DeadEnd; brother = bro} ]
in
let t = Node {node = s1; son = son; brother = bro} in
Some t
else
match try_insert s sl bro with
[ Some bro ->
let t = Node {node = s1; son = son; brother = bro} in
Some t
| None -> None ]
| LocAct _ _ | DeadEnd -> None ]
and insert_new =
fun
[ [s :: sl] -> Node {node = s; son = insert_new sl; brother = DeadEnd}
| [] -> LocAct action [] ]
in
insert gsymbols tree
;
value insert_level entry e1 symbols action slev =
match e1 with
[ True ->
{assoc = slev.assoc; lname = slev.lname;
lsuffix = insert_tree entry symbols action slev.lsuffix;
lprefix = slev.lprefix}
| False ->
{assoc = slev.assoc; lname = slev.lname; lsuffix = slev.lsuffix;
lprefix = insert_tree entry symbols action slev.lprefix} ]
;
value levels_of_rules entry position rules =
let elev =
match entry.edesc with
[ Dlevels elev -> elev
| Dparser _ ->
do {
eprintf "Error: entry not extensible: \"%s\"\n" entry.ename;
flush Pervasives.stderr;
failwith "Grammar.extend"
} ]
in
if rules = [] then elev
else
let (levs1, make_lev, levs2) = get_level entry position elev in
let (levs, _) =
List.fold_left
(fun (levs, make_lev) (lname, assoc, level) ->
let lev = make_lev lname assoc in
let lev =
List.fold_left
(fun lev (symbols, action) ->
let symbols = List.map (change_to_self entry) symbols in
do {
List.iter (check_gram entry) symbols;
let (e1, symbols) = get_initial symbols;
insert_tokens entry.egram symbols;
insert_level entry e1 symbols action lev
})
lev level
in
([lev :: levs], empty_lev))
([], make_lev) rules
in
levs1 @ List.rev levs @ levs2
;
value extend entry (position, rules) =
let elev = levels_of_rules entry position rules in
do {
entry.edesc := Dlevels elev;
entry.estart :=
fun lev strm ->
let f = Parser.start_parser_of_entry entry in
do { entry.estart := f; f lev strm };
entry.econtinue :=
fun lev bp a strm ->
let f = Parser.continue_parser_of_entry entry in
do { entry.econtinue := f; f lev bp a strm }
};
end;
|
