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, 0 insertions, 337 deletions
diff --git a/cil/ocamlutil/errormsg.ml b/cil/ocamlutil/errormsg.ml
deleted file mode 100644
index 07e935d..0000000
--- a/cil/ocamlutil/errormsg.ml
+++ /dev/null
@@ -1,337 +0,0 @@
-(*
- *
- * 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-05-28 19:38:07 +0000