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
|
(* camlp5r *)
(* ploc.ml,v *)
(* Copyright (c) INRIA 2007-2017 *)
type t =
{ fname : string;
line_nb : int;
bol_pos : int;
line_nb_last : int;
bol_pos_last : int;
bp : int;
ep : int;
comm : string;
ecomm : string }
let make_loc fname line_nb bol_pos (bp, ep) comm =
{fname = fname; line_nb = line_nb; bol_pos = bol_pos;
line_nb_last = line_nb; bol_pos_last = bol_pos; bp = bp; ep = ep;
comm = comm; ecomm = ""}
let make_unlined (bp, ep) =
{fname = ""; line_nb = 1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0;
bp = bp; ep = ep; comm = ""; ecomm = ""}
let dummy =
{fname = ""; line_nb = 1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0;
bp = 0; ep = 0; comm = ""; ecomm = ""}
let file_name loc = loc.fname
let first_pos loc = loc.bp
let last_pos loc = loc.ep
let line_nb loc = loc.line_nb
let bol_pos loc = loc.bol_pos
let line_nb_last loc = loc.line_nb_last
let bol_pos_last loc = loc.bol_pos_last
let comment loc = loc.comm
let comment_last loc = loc.ecomm
(* *)
let encl loc1 loc2 =
if loc1.bp < loc2.bp then
if loc1.ep < loc2.ep then
{fname = loc1.fname; line_nb = loc1.line_nb; bol_pos = loc1.bol_pos;
line_nb_last = loc2.line_nb_last; bol_pos_last = loc2.bol_pos_last;
bp = loc1.bp; ep = loc2.ep; comm = loc1.comm; ecomm = loc2.comm}
else loc1
else if loc2.ep < loc1.ep then
{fname = loc2.fname; line_nb = loc2.line_nb; bol_pos = loc2.bol_pos;
line_nb_last = loc1.line_nb_last; bol_pos_last = loc1.bol_pos_last;
bp = loc2.bp; ep = loc1.ep; comm = loc2.comm; ecomm = loc1.comm}
else loc2
let shift sh loc = {loc with bp = sh + loc.bp; ep = sh + loc.ep}
let sub loc sh len = {loc with bp = loc.bp + sh; ep = loc.bp + sh + len}
let after loc sh len = {loc with bp = loc.ep + sh; ep = loc.ep + sh + len}
let with_comment loc comm = {loc with comm = comm}
let name = ref "loc"
let from_file fname loc =
let (bp, ep) = first_pos loc, last_pos loc in
try
let ic = open_in_bin fname in
let strm = Stream.of_channel ic in
let rec loop fname lin =
let rec not_a_line_dir col (strm__ : _ Stream.t) =
let cnt = Stream.count strm__ in
match Stream.peek strm__ with
Some c ->
Stream.junk strm__;
let s = strm__ in
if cnt < bp then
if c = '\n' then loop fname (lin + 1)
else not_a_line_dir (col + 1) s
else let col = col - (cnt - bp) in fname, lin, col, col + ep - bp
| _ -> fname, lin, col, col + 1
in
let rec a_line_dir str n col (strm__ : _ Stream.t) =
match Stream.peek strm__ with
Some '\n' -> Stream.junk strm__; loop str n
| Some _ -> Stream.junk strm__; a_line_dir str n (col + 1) strm__
| _ -> raise Stream.Failure
in
let rec spaces col (strm__ : _ Stream.t) =
match Stream.peek strm__ with
Some ' ' -> Stream.junk strm__; spaces (col + 1) strm__
| _ -> col
in
let rec check_string str n col (strm__ : _ Stream.t) =
match Stream.peek strm__ with
Some '"' ->
Stream.junk strm__;
let col =
try spaces (col + 1) strm__ with
Stream.Failure -> raise (Stream.Error "")
in
a_line_dir str n col strm__
| Some c when c <> '\n' ->
Stream.junk strm__;
check_string (str ^ String.make 1 c) n (col + 1) strm__
| _ -> not_a_line_dir col strm__
in
let check_quote n col (strm__ : _ Stream.t) =
match Stream.peek strm__ with
Some '"' -> Stream.junk strm__; check_string "" n (col + 1) strm__
| _ -> not_a_line_dir col strm__
in
let rec check_num n col (strm__ : _ Stream.t) =
match Stream.peek strm__ with
Some ('0'..'9' as c) ->
Stream.junk strm__;
check_num (10 * n + Char.code c - Char.code '0') (col + 1) strm__
| _ -> let col = spaces col strm__ in check_quote n col strm__
in
let begin_line (strm__ : _ Stream.t) =
match Stream.peek strm__ with
Some '#' ->
Stream.junk strm__;
let col =
try spaces 1 strm__ with
Stream.Failure -> raise (Stream.Error "")
in
check_num 0 col strm__
| _ -> not_a_line_dir 0 strm__
in
begin_line strm
in
let r =
try loop fname 1 with
Stream.Failure ->
let bol = bol_pos loc in fname, line_nb loc, bp - bol, ep - bol
in
close_in ic; r
with Sys_error _ -> fname, 1, bp, ep
let second_line fname ep0 (line, bp) ep =
let ic = open_in fname in
seek_in ic bp;
let rec loop line bol p =
if p = ep then
begin close_in ic; if bol = bp then line, ep0 else line, ep - bol end
else
let (line, bol) =
match input_char ic with
'\n' -> line + 1, p + 1
| _ -> line, bol
in
loop line bol (p + 1)
in
loop line bp bp
let get loc =
if loc.fname = "" || loc.fname = "-" then
loc.line_nb, loc.bp - loc.bol_pos, loc.line_nb, loc.ep - loc.bol_pos,
loc.ep - loc.bp
else
let (bl, bc, ec) =
loc.line_nb, loc.bp - loc.bol_pos, loc.ep - loc.bol_pos
in
let (el, eep) = second_line loc.fname ec (bl, loc.bp) loc.ep in
bl, bc, el, eep, ec - bc
let call_with r v f a =
let saved = !r in
try r := v; let b = f a in r := saved; b with e -> r := saved; raise e
exception Exc of t * exn
let raise loc exc =
match exc with
Exc (_, _) -> raise exc
| _ -> raise (Exc (loc, exc))
type 'a vala =
VaAnt of string
| VaVal of 'a
|
