diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/dyn.ml | 9 | ||||
| -rw-r--r-- | lib/errors.ml | 6 | ||||
| -rw-r--r-- | lib/pp.ml | 2 | ||||
| -rw-r--r-- | lib/system.ml | 11 |
4 files changed, 15 insertions, 13 deletions
diff --git a/lib/dyn.ml b/lib/dyn.ml index a5e8fb9c2b..056b687313 100644 --- a/lib/dyn.ml +++ b/lib/dyn.ml @@ -7,6 +7,7 @@ (************************************************************************) open Errors +open Pp (* Dynamics, programmed with DANGER !!! *) @@ -23,7 +24,7 @@ let create (s : string) = let () = if Int.Map.mem hash !dyntab then let old = Int.Map.find hash !dyntab in - let msg = Pp.str ("Dynamic tag collision: " ^ s ^ " vs. " ^ old) in + let msg = str "Dynamic tag collision: " ++ str s ++ str " vs. " ++ str old in anomaly ~label:"Dyn.create" msg in let () = dyntab := Int.Map.add hash s !dyntab in @@ -31,8 +32,7 @@ let create (s : string) = let outfun (nh, rv) = if Int.equal hash nh then Obj.magic rv else - let msg = (Pp.str ("dyn_out: expected " ^ s)) in - anomaly msg + anomaly (str "dyn_out: expected " ++ str s) in (infun, outfun) @@ -43,8 +43,7 @@ let has_tag (s, _) tag = let tag (s,_) = try Int.Map.find s !dyntab with Not_found -> - let msg = Pp.str ("Unknown dynamic tag " ^ (string_of_int s)) in - anomaly msg + anomaly (str "Unknown dynamic tag " ++ int s) let pointer_equal (t1,o1) (t2,o2) = t1 = t2 && o1 == o2 diff --git a/lib/errors.ml b/lib/errors.ml index 13f3916477..999d99ee08 100644 --- a/lib/errors.ml +++ b/lib/errors.ml @@ -69,12 +69,12 @@ let rec print_gen bottom stk e = let where = function | None -> mt () | Some s -> - if !Flags.debug then str ("in "^s^":") ++ spc () else mt () + if !Flags.debug then str "in " ++ str s ++ str ":" ++ spc () else mt () let raw_anomaly e = match e with | Anomaly (s, pps) -> where s ++ pps ++ str "." - | Assert_failure _ | Match_failure _ -> str (Printexc.to_string e ^ ".") - | _ -> str ("Uncaught exception " ^ Printexc.to_string e ^ ".") + | Assert_failure _ | Match_failure _ -> str (Printexc.to_string e) ++ str "." + | _ -> str "Uncaught exception " ++ str (Printexc.to_string e) ++ str "." let print_backtrace e = match Backtrace.get_backtrace e with | None -> mt () @@ -249,7 +249,7 @@ let escape_string s = else escape_at s (i-1) in escape_at s (String.length s - 1) -let qstring s = str ("\""^escape_string s^"\"") +let qstring s = str "\"" ++ str (escape_string s) ++ str "\"" let qs = qstring let quote s = h 0 (str "\"" ++ s ++ str "\"") diff --git a/lib/system.ml b/lib/system.ml index 73095f9cd6..d1cdd8efc9 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -118,7 +118,8 @@ let is_in_system_path filename = let open_trapping_failure name = try open_out_bin name - with e when Errors.noncritical e -> error ("Can't open " ^ name) + with e when Errors.noncritical e -> + errorlabstrm "System.open" (str "Can't open " ++ str name) let try_remove filename = try Sys.remove filename @@ -126,7 +127,8 @@ let try_remove filename = msg_warning (str"Could not remove file " ++ str filename ++ str" which is corrupted!") -let error_corrupted file s = error (file ^": " ^ s ^ ". Try to rebuild it.") +let error_corrupted file s = + errorlabstrm "System" (str file ++ str ": " ++ str s ++ str ". Try to rebuild it.") let input_binary_int f ch = try input_binary_int ch @@ -201,7 +203,8 @@ let extern_intern ?(warn=true) magic = let reraise = Errors.push reraise in let () = try_remove filename in iraise reraise - with Sys_error s -> error ("System error: " ^ s) + with Sys_error s -> + errorlabstrm "System.extern_state" (str "System error: " ++ str s) and intern_state paths name = try let _,filename = find_file_in_path ~warn paths name in @@ -210,7 +213,7 @@ let extern_intern ?(warn=true) magic = close_in channel; v with Sys_error s -> - error("System error: " ^ s) + errorlabstrm "System.intern_state" (str "System error: " ++ str s) in (extern_state,intern_state) |