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
|
(****************************************************************************)
(* *)
(* 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
*)
(* camlp4r *)
open Format;
(* FIXME
Study these 2 others implementations which change the ghost
handling:
type pos = ... the same ...
1/
type loc = {
file_name : string;
start : pos;
stop : pos
};
type t =
[ Nowhere
| Ghost of loc (* the closest non ghost loc *)
| Concrete of loc ];
2/
type loc = {
file_name : string;
start : pos;
stop : pos
};
type t = option loc;
3/
type t = {
file_name : option string;
start : pos;
stop : pos
};
*)
type pos = {
line : int;
bol : int;
off : int
};
type t = {
file_name : string;
start : pos;
stop : pos;
ghost : bool
};
(* Debug section *)
value dump_sel f x =
let s =
match x with
[ `start -> "`start"
| `stop -> "`stop"
| `both -> "`both"
| _ -> "<not-printable>" ]
in pp_print_string f s;
value dump_pos f x =
fprintf f "@[<hov 2>{ line = %d ;@ bol = %d ;@ off = %d } : pos@]"
x.line x.bol x.off;
value dump_long f x =
fprintf f
"@[<hov 2>{ file_name = %s ;@ start = %a (%d-%d);@ stop = %a (%d);@ ghost = %b@ } : Loc.t@]"
x.file_name dump_pos x.start (x.start.off - x.start.bol)
(x.stop.off - x.start.bol) dump_pos x.stop
(x.stop.off - x.stop.bol) x.ghost;
value dump f x =
fprintf f "[%S: %d:%d-%d %d:%d%t]"
x.file_name x.start.line (x.start.off - x.start.bol)
(x.stop.off - x.start.bol) x.stop.line (x.stop.off - x.stop.bol)
(fun o -> if x.ghost then fprintf o " (ghost)" else ());
value start_pos = { line = 1 ; bol = 0 ; off = 0 };
value ghost =
{ file_name = "ghost-location";
start = start_pos;
stop = start_pos;
ghost = True };
value mk file_name =
debug loc "mk %s@\n" file_name in
{ file_name = file_name;
start = start_pos;
stop = start_pos;
ghost = False };
value of_tuple (file_name, start_line, start_bol, start_off,
stop_line, stop_bol, stop_off, ghost) =
{ file_name = file_name;
start = { line = start_line ; bol = start_bol ; off = start_off };
stop = { line = stop_line ; bol = stop_bol ; off = stop_off };
ghost = ghost };
value to_tuple
{ file_name = file_name;
start = { line = start_line ; bol = start_bol ; off = start_off };
stop = { line = stop_line ; bol = stop_bol ; off = stop_off };
ghost = ghost } =
(file_name, start_line, start_bol, start_off,
stop_line, stop_bol, stop_off, ghost);
value pos_of_lexing_position p =
let pos =
{ line = p.Lexing.pos_lnum ;
bol = p.Lexing.pos_bol ;
off = p.Lexing.pos_cnum } in
debug loc "pos_of_lexing_position: %a@\n" dump_pos pos in
pos;
value pos_to_lexing_position p file_name =
(* debug loc "pos_to_lexing_position: %a@\n" dump_pos p in *)
{ Lexing.
pos_fname = file_name;
pos_lnum = p.line ;
pos_bol = p.bol ;
pos_cnum = p.off };
value better_file_name a b =
match (a, b) with
[ ("", "") -> a
| ("", x) -> x
| (x, "") -> x
| ("-", x) -> x
| (x, "-") -> x
| (x, _) -> x ];
value of_lexbuf lb =
let start = Lexing.lexeme_start_p lb
and stop = Lexing.lexeme_end_p lb in
let loc =
{ file_name = better_file_name start.Lexing.pos_fname stop.Lexing.pos_fname;
start = pos_of_lexing_position start;
stop = pos_of_lexing_position stop;
ghost = False } in
debug loc "of_lexbuf: %a@\n" dump loc in
loc;
value of_lexing_position pos =
let loc =
{ file_name = pos.Lexing.pos_fname;
start = pos_of_lexing_position pos;
stop = pos_of_lexing_position pos;
ghost = False } in
debug loc "of_lexing_position: %a@\n" dump loc in
loc;
value to_ocaml_location x =
debug loc "to_ocaml_location: %a@\n" dump x in
{ Camlp4_import.Location.
loc_start = pos_to_lexing_position x.start x.file_name;
loc_end = pos_to_lexing_position x.stop x.file_name;
loc_ghost = x.ghost };
value of_ocaml_location { Camlp4_import.Location.loc_start = a; loc_end = b; loc_ghost = g } =
let res =
{ file_name = better_file_name a.Lexing.pos_fname b.Lexing.pos_fname;
start = pos_of_lexing_position a;
stop = pos_of_lexing_position b;
ghost = g } in
debug loc "of_ocaml_location: %a@\n" dump res in
res;
value start_pos x = pos_to_lexing_position x.start x.file_name;
value stop_pos x = pos_to_lexing_position x.stop x.file_name;
value merge a b =
if a == b then
debug loc "trivial merge@\n" in
a
else
let r =
match (a.ghost, b.ghost) with
[ (False, False) ->
(* FIXME if a.file_name <> b.file_name then
raise (Invalid_argument
(sprintf "Loc.merge: Filenames must be equal: %s <> %s"
a.file_name b.file_name)) *)
(* else *)
{ (a) with stop = b.stop }
| (True, True) -> { (a) with stop = b.stop }
| (True, _) -> { (a) with stop = b.stop }
| (_, True) -> { (b) with start = a.start } ]
in debug loc "@[<hov 6>merge %a@ %a@ %a@]@\n" dump a dump b dump r in r;
value join x = { (x) with stop = x.start };
value map f start_stop_both x =
match start_stop_both with
[ `start -> { (x) with start = f x.start }
| `stop -> { (x) with stop = f x.stop }
| `both -> { (x) with start = f x.start; stop = f x.stop } ];
value move_pos chars x = { (x) with off = x.off + chars };
value move s chars x =
debug loc "move %a %d %a@\n" dump_sel s chars dump x in
map (move_pos chars) s x;
value move_line lines x =
debug loc "move_line %d %a@\n" lines dump x in
let move_line_pos x =
{ (x) with line = x.line + lines ; bol = x.off }
in map move_line_pos `both x;
value shift width x =
{ (x) with start = x.stop ; stop = move_pos width x.stop };
value file_name x = x.file_name;
value start_line x = x.start.line;
value stop_line x = x.stop.line;
value start_bol x = x.start.bol;
value stop_bol x = x.stop.bol;
value start_off x = x.start.off;
value stop_off x = x.stop.off;
value is_ghost x = x.ghost;
value set_file_name s x =
debug loc "set_file_name: %a@\n" dump x in
{ (x) with file_name = s };
value ghostify x =
debug loc "ghostify: %a@\n" dump x in
{ (x) with ghost = True };
value make_absolute x =
debug loc "make_absolute: %a@\n" dump x in
let pwd = Sys.getcwd () in
if Filename.is_relative x.file_name then
{ (x) with file_name = Filename.concat pwd x.file_name }
else x;
value strictly_before x y =
let b = x.stop.off < y.start.off && x.file_name = y.file_name in
debug loc "%a [strictly_before] %a => %b@\n" dump x dump y b in
b;
value to_string x = do {
let (a, b) = (x.start, x.stop) in
let res = sprintf "File \"%s\", line %d, characters %d-%d"
x.file_name a.line (a.off - a.bol) (b.off - a.bol) in
if x.start.line <> x.stop.line then
sprintf "%s (end at line %d, character %d)"
res x.stop.line (b.off - b.bol)
else res
};
value print out x = pp_print_string out (to_string x);
value check x msg =
if ((start_line x) > (stop_line x) ||
(start_bol x) > (stop_bol x) ||
(start_off x) > (stop_off x) ||
(start_line x) < 0 || (stop_line x) < 0 ||
(start_bol x) < 0 || (stop_bol x) < 0 ||
(start_off x) < 0 || (stop_off x) < 0)
(* Here, we don't check
(start_off x) < (start_bol x) || (stop_off x) < (start_bol x)
since the lexer is called on antiquotations, with off=0, but line and bolpos
have "correct" values *)
then do {
eprintf "*** Warning: (%s) strange positions ***\n%a@\n" msg print x;
False
}
else True;
exception Exc_located of t and exn;
ErrorHandler.register
(fun ppf ->
fun [ Exc_located loc exn ->
fprintf ppf "%a:@\n%a" print loc ErrorHandler.print exn
| exn -> raise exn ]);
value name = ref "_loc";
value raise loc exc =
match exc with
[ Exc_located _ _ -> raise exc
| _ -> raise (Exc_located loc exc) ]
;
|
