summaryrefslogtreecommitdiff
path: root/cil/ocamlutil/errormsg.ml
diff options
context:
space:
mode:
Diffstat (limited to 'cil/ocamlutil/errormsg.ml')
-rw-r--r--cil/ocamlutil/errormsg.ml337
1 files changed, 337 insertions, 0 deletions
diff --git a/cil/ocamlutil/errormsg.ml b/cil/ocamlutil/errormsg.ml
new file mode 100644
index 0000000..07e935d
--- /dev/null
+++ b/cil/ocamlutil/errormsg.ml
@@ -0,0 +1,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 }
+
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-04 11:59:43 +0000