blob: cbd30922768166ca78d08a0ec2bda45dd9072773 (
plain)
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
|
(****************************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the Objective *)
(* Caml source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
(* camlp4r *)
open Format;
module Debug = struct value mode _ = False; end;
type section = string;
value out_channel =
try
let f = Sys.getenv "CAMLP4_DEBUG_FILE" in
open_out_gen [Open_wronly; Open_creat; Open_append; Open_text]
0o666 f
with
[ Not_found -> Pervasives.stderr ];
module StringSet = Set.Make String;
value mode =
try
let str = Sys.getenv "CAMLP4_DEBUG" in
let rec loop acc i =
try
let pos = String.index_from str i ':' in
loop (StringSet.add (String.sub str i (pos - i)) acc) (pos + 1)
with
[ Not_found ->
StringSet.add (String.sub str i (String.length str - i)) acc ] in
let sections = loop StringSet.empty 0 in
if StringSet.mem "*" sections then fun _ -> True
else fun x -> StringSet.mem x sections
with [ Not_found -> fun _ -> False ];
value formatter =
let header = "camlp4-debug: " in
let normal s =
let rec self from accu =
try
let i = String.index_from s from '\n'
in self (i + 1) [String.sub s from (i - from + 1) :: accu]
with
[ Not_found -> [ String.sub s from (String.length s - from) :: accu ] ]
in String.concat header (List.rev (self 0 [])) in
let after_new_line str = header ^ normal str in
let f = ref after_new_line in
let output str chr = do {
output_string out_channel (f.val str);
output_char out_channel chr;
f.val := if chr = '\n' then after_new_line else normal;
} in
(make_formatter
(fun buf pos len ->
let p = pred len in output (String.sub buf pos p) buf.[pos + p])
(fun () -> flush out_channel));
value printf section fmt = fprintf formatter ("%s: " ^^ fmt) section;
|
