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/trunk/src/compiler/Semant/elaborate/elabdebug.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/Semant/elaborate/elabdebug.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 16 - (view) (download)

1 : monnier 16 (* COPYRIGHT (c) 1996 Bell Laboratories*)
2 :     (* elabdebug.sml *)
3 :    
4 :     signature ELABDEBUG =
5 :     sig
6 :     val debugPrint : bool ref
7 :     -> (string *
8 :     (PrettyPrint.ppstream -> 'a -> unit) *
9 :     'a)
10 :     -> unit
11 :     val ppSymList : PrettyPrint.ppstream -> Symbol.symbol list -> unit
12 :     val envSymbols : StaticEnv.staticEnv -> Symbol.symbol list
13 :     val checkEnv : StaticEnv.staticEnv * Symbol.symbol -> string
14 :     val withInternals : (unit -> 'a) -> 'a
15 :    
16 :     end (* signature ELABDEBUG *)
17 :    
18 :    
19 :     structure ElabDebug : ELABDEBUG =
20 :     struct
21 :    
22 :     local structure S = Symbol
23 :     structure SE = StaticEnv
24 :     structure PP = PrettyPrint
25 :     structure PPU = PPUtil
26 :     structure EM = ErrorMsg
27 :    
28 :     open PP
29 :    
30 :     in
31 :    
32 :     fun debugPrint (debugging: bool ref)
33 :     (msg: string, printfn: ppstream -> 'a -> unit, arg: 'a) =
34 :     if (!debugging) then
35 :     with_pp (EM.defaultConsumer())
36 :     (fn ppstrm =>
37 :     (begin_block ppstrm CONSISTENT 0;
38 :     add_string ppstrm msg;
39 :     add_newline ppstrm;
40 :     add_string ppstrm " ";
41 :     begin_block ppstrm CONSISTENT 0;
42 :     printfn ppstrm arg;
43 :     end_block ppstrm;
44 :     add_newline ppstrm;
45 :     end_block ppstrm;
46 :     flush_ppstream ppstrm))
47 :     else ()
48 :    
49 :     fun ppSymList ppstrm (syms: S.symbol list) =
50 :     PPU.ppClosedSequence ppstrm
51 :     {front=(fn pps => PP.add_string pps "["),
52 :     sep=(fn pps => (PP.add_string pps ",")),
53 :     back=(fn pps => PP.add_string pps "]"),
54 :     style=PP.INCONSISTENT,
55 :     pr=PPU.ppSym}
56 :     syms
57 :    
58 :    
59 :     (* more debugging *)
60 :     fun envSymbols (env: SE.staticEnv) =
61 :     SE.fold (fn ((s,_),sl) => s::sl) nil env
62 :    
63 :     fun checkEnv (env: SE.staticEnv, sym: S.symbol) =
64 :     (SE.look(env,sym); "YES") handle SE.Unbound => "NO"
65 :    
66 :     fun withInternals (f: unit -> 'a) =
67 :     let val internals = !Control.internals
68 :     in Control.internals := true;
69 :     (f() before
70 :     Control.internals := internals)
71 :     handle exn => (Control.internals := internals; raise exn)
72 :     end
73 :    
74 :     end (* local *)
75 :     end (* structure ElabDebug *)
76 :    
77 :     (*
78 :     * $Log: elabdebug.sml,v $
79 :     * Revision 1.1.1.1 1997/01/14 01:38:35 george
80 :     * Version 109.24
81 :     *
82 :     *)

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