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
|
(*
*
* 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.
*
*)
(* Trace module implementation
* see trace.mli
*)
open Pretty;;
(* --------- traceSubsystems --------- *)
(* this is the list of tags (usually subsystem names) for which
* trace output will appear *)
let traceSubsystems : string list ref = ref [];;
let traceAddSys (subsys : string) : unit =
(* (ignore (printf "traceAddSys %s\n" subsys)); *)
traceSubsystems := subsys :: !traceSubsystems
;;
let traceActive (subsys : string) : bool =
(* (List.mem elt list) returns true if something in list equals ('=') elt *)
(List.mem subsys !traceSubsystems)
;;
let rec parseString (str : string) (delim : char) : string list =
begin
if (not (String.contains str delim)) then
if ((String.length str) = 0) then
[]
else
[str]
else
let d = ((String.index str delim) + 1) in
if (d = 1) then
(* leading delims are eaten *)
(parseString (String.sub str d ((String.length str) - d)) delim)
else
(String.sub str 0 (d-1)) ::
(parseString (String.sub str d ((String.length str) - d)) delim)
end;;
let traceAddMulti (systems : string) : unit =
begin
let syslist = (parseString systems ',') in
(List.iter traceAddSys syslist)
end;;
(* --------- traceIndent --------- *)
let traceIndentLevel : int ref = ref 0;;
let traceIndent (sys : string) : unit =
if (traceActive sys) then
traceIndentLevel := !traceIndentLevel + 2
;;
let traceOutdent (sys : string) : unit =
if ((traceActive sys) &&
(!traceIndentLevel >= 2)) then
traceIndentLevel := !traceIndentLevel - 2
;;
(* --------- trace --------- *)
(* return a tag to prepend to a trace output
* e.g. " %%% mysys: "
*)
let traceTag (sys : string) : Pretty.doc =
(* return string of 'i' spaces *)
let rec ind (i : int) : string =
if (i <= 0) then
""
else
" " ^ (ind (i-1))
in
(text ((ind !traceIndentLevel) ^ "%%% " ^ sys ^ ": "))
;;
(* this is the trace function; its first argument is a string
* tag, and subsequent arguments are like printf formatting
* strings ("%a" and whatnot) *)
let trace
(subsys : string) (* subsystem identifier for enabling tracing *)
(d : Pretty.doc) (* something made by 'dprintf' *)
: unit = (* no return value *)
(* (ignore (printf "trace %s\n" subsys)); *)
(* see if the subsystem's tracing is turned on *)
if (traceActive subsys) then
begin
(fprint stderr 80 (* print it *)
((traceTag subsys) ++ d)); (* with prepended subsys tag *)
(* mb: flush after every message; useful if the program hangs in an
infinite loop... *)
(flush stderr)
end
else
() (* eat it *)
;;
let tracei (sys : string) (d : Pretty.doc) : unit =
(* trace before indent *)
(trace sys d);
(traceIndent sys)
;;
let traceu (sys : string) (d : Pretty.doc) : unit =
(* trace after outdent *)
(* no -- I changed my mind -- I want trace *then* outdent *)
(trace sys d);
(traceOutdent sys)
;;
(* -------------------------- trash --------------------- *)
(* TRASH START
(* sm: more experimenting *)
(trace "no" (dprintf "no %d\n" 5));
(trace "yes" (dprintf "yes %d\n" 6));
(trace "maybe" (dprintf "maybe %d\n" 7));
TRASH END *)
|
