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
328
329
330
331
332
333
334
335
336
337
|
(*
*
* Copyright (c) 2001-2002,
* George C. Necula <necula@cs.berkeley.edu>
* Scott McPeak <smcpeak@cs.berkeley.edu>
* Wes Weimer <weimer@cs.berkeley.edu>
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are
* met:
*
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* 3. The names of the contributors may not be used to endorse or promote
* products derived from this software without specific prior written
* permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
* IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
* OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
*)
open Pretty
let debugFlag = ref false (* If set then print debugging info *)
let verboseFlag = ref false
(**** Error reporting ****)
exception Error
let s (d : 'a) = raise Error
let hadErrors = ref false
let errorContext = ref []
let pushContext f = errorContext := f :: (!errorContext)
let popContext () =
match !errorContext with
_ :: t -> errorContext := t
| [] -> s (eprintf "Bug: cannot pop error context")
let withContext ctx f x =
pushContext ctx;
try
let res = f x in
popContext ();
res
with e -> begin
popContext ();
raise e
end
(* Make sure that showContext calls
* each f with its appropriate
* errorContext as it was when it was
* pushed *)
let showContext () =
let rec loop = function
[] -> ()
| f :: rest -> (errorContext := rest; (* Just in case f raises an error *)
ignore (eprintf " Context : %t@!" f);
loop rest)
in
let old = !errorContext in
try
loop old;
errorContext := old
with e -> begin
errorContext := old;
raise e
end
let contextMessage (name: string) (d: doc) =
ignore (eprintf "@!%s: %a@!" name insert d);
showContext ()
let warnFlag = ref false
let logChannel : out_channel ref = ref stderr
let bug (fmt : ('a,unit,doc,unit) format4) : 'a =
let f d =
hadErrors := true; contextMessage "Bug" d;
flush !logChannel
in
Pretty.gprintf f fmt
let error (fmt : ('a,unit,doc,unit) format4) : 'a =
let f d = hadErrors := true; contextMessage "Error" d;
flush !logChannel
in
Pretty.gprintf f fmt
let unimp (fmt : ('a,unit,doc,unit) format4) : 'a =
let f d = hadErrors := true; contextMessage "Unimplemented" d;
flush !logChannel
in
Pretty.gprintf f fmt
let warn (fmt : ('a,unit,doc,unit) format4) : 'a =
let f d = contextMessage "Warning" d; flush !logChannel in
Pretty.gprintf f fmt
let warnOpt (fmt : ('a,unit,doc,unit) format4) : 'a =
let f d =
if !warnFlag then contextMessage "Warning" d;
flush !logChannel in
Pretty.gprintf f fmt
let log (fmt : ('a,unit,doc,unit) format4) : 'a =
let f d = fprint !logChannel 80 d; flush !logChannel in
Pretty.gprintf f fmt
let logg (fmt : ('a,unit,doc,unit) format4) : 'a =
let f d = fprint !logChannel 10000000 d; flush !logChannel in
Pretty.gprintf f fmt
let null (fmt : ('a,unit,doc,unit) format4) : 'a =
let f d = () in
Pretty.gprintf f fmt
let theLexbuf = ref (Lexing.from_string "")
let fail format = Pretty.gprintf (fun x -> Pretty.fprint stderr 80 x;
raise (Failure "")) format
(***** Handling parsing errors ********)
type parseinfo =
{ mutable linenum: int ; (* Current line *)
mutable linestart: int ; (* The position in the buffer where the
* current line starts *)
mutable fileName : string ; (* Current file *)
mutable hfile : string ; (* High-level file *)
mutable hline : int; (* High-level line *)
lexbuf : Lexing.lexbuf;
inchan : in_channel option; (* None, if from a string *)
mutable num_errors : int; (* Errors so far *)
}
let dummyinfo =
{ linenum = 1;
linestart = 0;
fileName = "" ;
lexbuf = Lexing.from_string "";
inchan = None;
hfile = "";
hline = 0;
num_errors = 0;
}
let current = ref dummyinfo
let setHLine (l: int) : unit =
!current.hline <- l
let setHFile (f: string) : unit =
!current.hfile <- f
let rem_quotes str = String.sub str 1 ((String.length str) - 2)
(* Change \ into / in file names. To avoid complications with escapes *)
let cleanFileName str =
let str1 =
if str <> "" && String.get str 0 = '"' (* '"' ( *)
then rem_quotes str else str in
let l = String.length str1 in
let rec loop (copyto: int) (i: int) =
if i >= l then
String.sub str1 0 copyto
else
let c = String.get str1 i in
if c <> '\\' then begin
String.set str1 copyto c; loop (copyto + 1) (i + 1)
end else begin
String.set str1 copyto '/';
if i < l - 2 && String.get str1 (i + 1) = '\\' then
loop (copyto + 1) (i + 2)
else
loop (copyto + 1) (i + 1)
end
in
loop 0 0
let readingFromStdin = ref false
let startParsing ?(useBasename=true) (fname: string) =
(* We only support one open file at a time *)
if !current != dummyinfo then begin
s (error "Errormsg.startParsing supports only one open file: You want to open %s and %s is still open\n" fname !current.fileName);
end;
let inchan =
try if fname = "-" then begin
readingFromStdin := true;
stdin
end else begin
readingFromStdin := false;
open_in fname
end
with e -> s (error "Cannot find input file %s (exception %s"
fname (Printexc.to_string e)) in
let lexbuf = Lexing.from_channel inchan in
let i =
{ linenum = 1; linestart = 0;
fileName =
cleanFileName (if useBasename then Filename.basename fname else fname);
lexbuf = lexbuf; inchan = Some inchan;
hfile = ""; hline = 0;
num_errors = 0 } in
current := i;
lexbuf
let startParsingFromString ?(file="<string>") ?(line=1) (str: string) =
let lexbuf = Lexing.from_string str in
let i =
{ linenum = line; linestart = line - 1;
fileName = file;
hfile = ""; hline = 0;
lexbuf = lexbuf;
inchan = None;
num_errors = 0 }
in
current := i;
lexbuf
let finishParsing () =
let i = !current in
(match i.inchan with Some c -> close_in c | _ -> ());
current := dummyinfo
(* Call this function to announce a new line *)
let newline () =
let i = !current in
i.linenum <- 1 + i.linenum;
i.linestart <- Lexing.lexeme_start i.lexbuf
let newHline () =
let i = !current in
i.hline <- 1 + i.hline
let setCurrentLine (i: int) =
!current.linenum <- i
let setCurrentFile (n: string) =
!current.fileName <- cleanFileName n
let max_errors = 20 (* Stop after 20 errors *)
let parse_error (msg: string) : 'a =
(* Sometimes the Ocaml parser raises errors in symbol_start and symbol_end *)
let token_start, token_end =
try Parsing.symbol_start (), Parsing.symbol_end ()
with e -> begin
ignore (warn "Parsing raised %s\n" (Printexc.to_string e));
0, 0
end
in
let i = !current in
let adjStart =
if token_start < i.linestart then 0 else token_start - i.linestart in
let adjEnd =
if token_end < i.linestart then 0 else token_end - i.linestart in
output_string
stderr
(i.fileName ^ "[" ^ (string_of_int i.linenum) ^ ":"
^ (string_of_int adjStart) ^ "-"
^ (string_of_int adjEnd)
^ "]"
^ " : " ^ msg);
output_string stderr "\n";
flush stderr ;
i.num_errors <- i.num_errors + 1;
if i.num_errors > max_errors then begin
output_string stderr "Too many errors. Aborting.\n" ;
exit 1
end;
hadErrors := true;
raise Parsing.Parse_error
(* More parsing support functions: line, file, char count *)
let getPosition () : int * string * int =
let i = !current in
i.linenum, i.fileName, Lexing.lexeme_start i.lexbuf
let getHPosition () =
!current.hline, !current.hfile
(** Type for source-file locations *)
type location =
{ file: string; (** The file name *)
line: int; (** The line number *)
hfile: string; (** The high-level file name, or "" if not present *)
hline: int; (** The high-level line number, or 0 if not present *)
}
let d_loc () l =
text (l.file ^ ":" ^ string_of_int l.line)
let d_hloc () (l: location) =
dprintf "%s:%d%a" l.file l.line
insert (if l.hline > 0 then dprintf " (%s:%d)" l.hfile l.hline else nil)
let locUnknown = { file = ""; hfile = ""; line = -1; hline = -1 }
let getLocation () =
let hl, hf = getHPosition () in
let l, f, c = getPosition () in
{ hfile = hf; hline = hl;
file = f; line = l }
|