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/gatien-branch/compiler/Elaborator/srcinfo/ens_print2.sml
ViewVC logotype

Annotation of /sml/branches/gatien-branch/compiler/Elaborator/srcinfo/ens_print2.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3098 - (view) (download)

1 : gatien 3090 signature ENS_PRINT2 =
2 :     sig
3 :     val maj : StaticEnv.staticEnv -> unit
4 :    
5 :     val rtoS : Ens_types2.location -> string
6 :     val stoS : Symbol.symbol -> string
7 :     val ptoS : Symbol.symbol list -> string
8 :     val rptoS : InvPath.path -> string
9 :    
10 : gatien 3098 val printer : Types.ty -> unit
11 :    
12 : gatien 3090 val print_var : Ens_types2.var_elem -> unit
13 :     val print_type : Ens_types2.type_elem -> unit
14 :     val print_cons : Ens_types2.cons_elem -> unit
15 :     val print_str : Ens_types2.str_elem -> unit
16 :     val print_sig : Ens_types2.sig_elem -> unit
17 :     val print_all : Ens_types2.all -> unit
18 :    
19 :     end (* signature ENS_PRINT*)
20 :    
21 :     structure Ens_print2 : ENS_PRINT2 =
22 :     struct
23 :    
24 :     local
25 :     structure A = Access
26 :     structure S = Symbol
27 :     structure T = Types
28 :     structure PP = PrettyPrintNew
29 :     structure VC = VarCon
30 :     structure M = Modules
31 :     open Ens_types2
32 :     in
33 :    
34 :     fun bug msg = ErrorMsg.impossible("Bugs in Ens_print: "^msg);
35 :    
36 :     val stat_env = ref (StaticEnv.empty);
37 :     fun maj e = stat_env := e;
38 :    
39 :    
40 :     (*tranform a region in a string*)
41 :     fun rtoS (filename, int1, int2) =
42 :     "(" ^ filename ^ "," ^ Int.toString int1 ^ ","^Int.toString int2 ^ ")";
43 :    
44 :     (*tranform symbol to string*)
45 :     fun stoS symbol = let val S.SYMBOL(_, str) = symbol in str end
46 :    
47 :     (*transform list of symbol to string*)
48 :     fun ptoS nil = ""
49 :     | ptoS [s] = stoS s
50 :     | ptoS (t::q) = stoS t ^ "." ^ ptoS q
51 :    
52 :     (* rpath to string *)
53 :     fun rptoS (InvPath.IPATH p) =
54 :     ptoS (rev p)
55 :    
56 :    
57 :    
58 :    
59 :     (*print a type with an environment*)
60 :     fun printer0 ty env =
61 :     (
62 :     (
63 :     (PP.with_default_pp
64 :     (fn ppstrm =>
65 :     (PPType.resetPPType(); PPType.ppType env ppstrm ty)))
66 :     handle _ => print "fail to print anything"
67 :     )
68 :     )
69 :    
70 :     (*print a type with the environment of the structure*)
71 :     fun printer ty = printer0 ty (!stat_env)
72 :    
73 :     (*print the usage and instance of the environments*)
74 :     fun print_instance usage = (
75 :     print " is used at :";
76 :     List.app
77 :     (fn (x, y) => (print ("\n\t" ^ rtoS x ^ " with type "); printer y))
78 :     (!usage);
79 :     print "\n"
80 :     )
81 :    
82 :     fun print_var ({access, name, parent, typ, def, usage}:var_elem) = (
83 :     print (A.prAcc access ^ ": \"" ^ stoS name ^
84 :     "\" " ^ rtoS def ^ " has type ");
85 :     printer typ;
86 : gatien 3093 print (", is defined in " ^ A.prAcc parent ^ " and");
87 :     print " is used at :";
88 :     List.app
89 :     ( fn (x, y, z) =>
90 :     ( print ("\n\t" ^ rtoS x ^ " with type ");
91 :     printer y;
92 :     print (", access " ^ A.prAcc z)
93 :     )
94 :     )
95 :     (!usage);
96 :     print "\n"
97 : gatien 3090 )
98 :    
99 :     (*print the different type and datatype definitions and explicit uses*)
100 :     fun print_type ({tycon, def, usage}:type_elem) =
101 :     case tycon of
102 :     (T.DEFtyc {tyfun = T.TYFUN {arity, body}, path, ...}) =>
103 :     (
104 :     print (rptoS path ^ " (arity " ^ Int.toString arity ^") "^
105 :     rtoS def ^" : ");
106 :     printer (body);
107 :     print_instance usage
108 :     )
109 :     | (T.GENtyc {kind = T.DATATYPE {index, family, ...}, ...}) =>
110 :     let
111 :     fun temp ({dcons, ...}:T.dtmember) =
112 :     List.app (fn ({name, domain, ...}:T.dconDesc) => (
113 :     print (stoS name);
114 :     case domain of
115 :     NONE => ()
116 :     | SOME ty => (print " of "; printer ty);
117 :     print ", "
118 :     )
119 :     )
120 :     dcons
121 :     val (sub as {tycname, arity, ...}) =
122 :     Vector.sub (#members family,index)
123 :     in
124 :     print (stoS tycname ^ " (arity "^ Int.toString arity ^
125 :     ") "^ rtoS def ^ " : ");
126 :     temp sub;
127 :     print_instance usage
128 :     end
129 :     | _ => (
130 :     print ("other type : " ^ rtoS def);
131 :     print_instance usage
132 :     )
133 :    
134 :     (*print the different type constructors and uses*)
135 :     fun print_cons ({name, typ, gen_typ, def, usage}:cons_elem) = (
136 :     print (stoS name ^ " " ^ rtoS def ^ " has type ");
137 :     printer typ;
138 :     print " and";
139 :     print_instance usage
140 :     )
141 :    
142 :     fun print_str ({name, access, parent, sign, def, elements, usage}:str_elem)=
143 :     let
144 :     fun print_key k =
145 :     case k of
146 : gatien 3097 (Var a|Str a) => Access.prAcc a
147 : gatien 3090 | _ => "others"
148 :     in
149 :     print ("(" ^ A.prAcc access ^ ") " ^ stoS name ^
150 : gatien 3093 " " ^ rtoS def ^ " defined in ");
151 :     case parent of
152 :     NONE => print "the toplevel"
153 :     | SOME parent' => print (A.prAcc parent');
154 :     case elements of
155 :     Def el => (
156 :     print " contains ";
157 :     List.app ( fn (x, y, z)=>
158 :     print ("\n\t(" ^ Int.toString x ^ "," ^
159 :     stoS y ^ "," ^ print_key z ^ ")")
160 :     ) el
161 :     )
162 :     | Constraint (el, a) =>
163 :     ( print (" constrains " ^ A.prAcc a ^ " : ");
164 :     List.app ( fn (x, y, z) =>
165 :     print ("\n\t(" ^ Int.toString x ^ "," ^
166 :     stoS y ^ ","^Int.toString z ^ ")")
167 :     ) el
168 :     )
169 :     | Alias a => print (" aliases " ^ A.prAcc a);
170 : gatien 3090 print " and is used at : ";
171 :     List.app (fn x => print ("\n\t" ^ rtoS x)) (!usage);
172 :     print "\n"
173 :     end
174 :    
175 :     fun print_sig ({name, stamp, def, parent, elements, usage, alias}:sig_elem)=
176 :     let
177 :     fun print_inst usage = (
178 :     print " and is used at :";
179 :     List.app
180 :     (fn (x, y) => print ("\n\t"^(rtoS x)^" with name "^stoS y))
181 :     (!usage);
182 :     print "\n"
183 :     )
184 :     in
185 :     print (stoS name ^ " : " ^ rtoS def);
186 :     List.app
187 :     (fn (x, S.SYMBOL (_, str)) =>
188 :     print ("\n\thas alias "^ str ^ " " ^ (rtoS x)))
189 :     (!alias);
190 :     print_inst usage
191 :     end
192 :    
193 :     fun print_all (a, b, c, d, e) = (
194 :     List.app print_var a;
195 :     List.app print_type b;
196 :     List.app print_cons c;
197 :     List.app print_str d;
198 :     List.app print_sig e
199 :     )
200 :     end
201 :     end (* structure Ens_print *)

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