Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/branches/SMLNJ/src/eXene/lib/misc/xdebug.sml
ViewVC logotype

Annotation of /sml/branches/SMLNJ/src/eXene/lib/misc/xdebug.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 8 - (view) (download)

1 : monnier 2 (* xdebug.sml
2 :     *
3 :     * COPYRIGHT (c) 1990,1991 by John H. Reppy. See COPYRIGHT file for details.
4 :     *)
5 :    
6 :     structure XDebug =
7 :     struct
8 :    
9 :     (* the root of all eXene trace modules *)
10 :     val eXeneTM = TraceCML.traceModule (TraceCML.traceRoot, "eXene")
11 :    
12 :     (* a trace module for controlling the printing of error messages *)
13 :     val errorTM = TraceCML.traceModule (eXeneTM, "errors")
14 :    
15 :     (* a trace module for controlling xspawn output *)
16 :     val xspawnTM = TraceCML.traceModule (eXeneTM, "xspawn")
17 :    
18 :     (* eXene library-level trace modules *)
19 :     val libTM = TraceCML.traceModule (eXeneTM, "lib")
20 :     val ioTM = TraceCML.traceModule (libTM, "io")
21 :     val fontTM = TraceCML.traceModule (libTM, "font")
22 :     val colorTM = TraceCML.traceModule (libTM, "color")
23 :     val drawTM = TraceCML.traceModule (libTM, "draw")
24 :     val dmTM = TraceCML.traceModule (libTM, "draw-master")
25 :     val winregTM = TraceCML.traceModule (libTM, "winreg")
26 :     val topTM = TraceCML.traceModule (libTM, "top-level")
27 :     val gcTM = TraceCML.traceModule (libTM, "gc")
28 :     val selTM = TraceCML.traceModule (libTM, "selection")
29 :    
30 :     (* the root of the widgets trace modules *)
31 :     val widgetsTM = TraceCML.traceModule (eXeneTM, "widgets")
32 :    
33 :     val trace = TraceCML.trace
34 :     fun errTrace f = trace(errorTM, f)
35 :    
36 :     fun reset () = (
37 :     TraceCML.traceOff eXeneTM;
38 :     TraceCML.traceOn errorTM)
39 :    
40 :     val _ = reset() (** make sure error reporting is turned on **)
41 :    
42 :     (* initialiize the state of the trace modules according to the argument
43 :     * list. The format of an argument is:
44 :     * [!|-|+]name
45 :     * where
46 :     * "-name" means TraceCML.traceOff "name"
47 :     * "+name" means TraceCML.traceOn "name"
48 :     * "!name" means TraceCML.traceOnly "name"
49 :     * and "name" is an abbreviation for "+name".
50 :     *)
51 :     fun init args = let
52 :     fun tail s = substring(s, 1, size s - 1)
53 :     fun doArg "" = ()
54 :     | doArg s = (case String.sub(s, 0)
55 :     of #"+" => TraceCML.traceOn(TraceCML.moduleOf(tail s))
56 :     | #"-" => TraceCML.traceOff(TraceCML.moduleOf(tail s))
57 :     | #"!" => TraceCML.traceOnly(TraceCML.moduleOf(tail s))
58 :     | _ => TraceCML.traceOn (TraceCML.moduleOf s)
59 :     (* end case *))
60 :     in
61 :     reset();
62 :     app doArg args
63 :     end
64 :     (***
65 :     val listLen = ref 16
66 :     val lineLen = ref 20
67 :    
68 :     fun prBuf lvl s = let
69 :     val pr = pr lvl
70 :     fun f (i, 1, 0) = (pr "\n "; pr(makestring(ordof(s, i))))
71 :     | f (i, 1, _) = pr(makestring(ordof(s, i)))
72 :     | f (i, n, 0) = (pr "\n "; f (i, n, !lineLen))
73 :     | f (i, n, k) = (
74 :     pr(makestring(ordof(s, i)));
75 :     pr ", ";
76 :     f(i+1, n-1, k-1))
77 :     val n = String.size s
78 :     in
79 :     pr "[ ";
80 :     if (n <= !listLen)
81 :     then (f(0, n, !lineLen); pr " ]\n")
82 :     else (f(0, !listLen, !lineLen); pr " ...]\n")
83 :     end
84 :     ***)
85 :    
86 :     local
87 :     (** NOTE: the "raisedAt" function probably should be provided by SML/NJ **)
88 :     fun raisedAt exn = (case List.rev(SMLofNJ.exnHistory exn)
89 :     of [] => ""
90 :     | (s::_) => "raised at " ^ s
91 :     (* end case *))
92 :     fun handleXERROR (tid, exn as MLXError.XERROR s) = (
93 :     TraceCML.trace(errorTM, fn () => [
94 :     "exception (XERROR ", s, ") in ", CML.tidToString tid,
95 :     raisedAt exn, "\n"
96 :     ]);
97 :     true)
98 :     | handleXERROR _ = false
99 :     in
100 :     val _ = TraceCML.setHandleFn handleXERROR
101 :     end;
102 :    
103 :     fun xspawn (name, f) = let
104 :     open CML
105 :     fun wrapf () = (let
106 :     val tid = getTid()
107 :     in
108 : monnier 8 TraceCML.watch (name, tid);
109 : monnier 2 trace (xspawnTM, fn () => [
110 :     "xspawn ", name, " ", tidToString tid, "\n"
111 :     ]);
112 :     f ();
113 :     trace (xspawnTM, fn () => [
114 :     "thread ", name, " ", tidToString tid, "exiting.\n"
115 :     ]);
116 :     TraceCML.unwatch tid
117 :     end
118 :     handle ex => let
119 :     fun f (s, l) = " ** " :: s :: "\n" :: l
120 :     val traceBack = List.foldr f [] (SMLofNJ.exnHistory ex)
121 :     in
122 :     case ex
123 :     of (MLXError.XERROR s) => trace (errorTM, fn () => [
124 :     "exception (XERROR ", s, ") in ", name, " thread\n"
125 :     ] @ traceBack)
126 :     | (Fail s) => trace (errorTM, fn () => [
127 :     "exception Fail(", s, ") in ", name, " thread\n"
128 :     ] @ traceBack)
129 :     | _ => trace (errorTM, fn () => [
130 :     "exception ", exnMessage ex, " in ", name,
131 :     " thread\n"
132 :     ] @ traceBack)
133 :     (* end case *);
134 :     TraceCML.unwatch(getTid())
135 :     end)
136 :     in
137 : monnier 8 spawn wrapf
138 : monnier 2 end
139 :    
140 :     (* wrapper to report uncaught exceptions *)
141 :     fun diag (f, s) x = (f x) handle ex => (
142 :     trace (errorTM, fn () => [
143 :     "exception ", exnName ex, " in ", s, "\n"
144 :     ]);
145 :     raise ex)
146 :    
147 :     end (* XDebug *)

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0