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 3122 - (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 3103 val print_ty' : Ens_types2.ty' -> unit
11 :     val print_tycon' : Ens_types2.tycon' -> unit
12 : gatien 3098 val printer : Types.ty -> unit
13 :    
14 : gatien 3090 val print_var : Ens_types2.var_elem -> unit
15 :     val print_type : Ens_types2.type_elem -> unit
16 :     val print_cons : Ens_types2.cons_elem -> unit
17 :     val print_str : Ens_types2.str_elem -> unit
18 :     val print_sig : Ens_types2.sig_elem -> unit
19 : gatien 3120 val print_ext : Ens_types2.ext_elem -> unit
20 : gatien 3090
21 :     end (* signature ENS_PRINT*)
22 :    
23 :     structure Ens_print2 : ENS_PRINT2 =
24 :     struct
25 :    
26 :     local
27 :     structure A = Access
28 :     structure S = Symbol
29 :     structure T = Types
30 :     structure PP = PrettyPrintNew
31 :     structure VC = VarCon
32 :     structure M = Modules
33 :     open Ens_types2
34 :     in
35 :    
36 : gatien 3100 fun bug msg = ErrorMsg.impossible("Bugs in Ens_print2: "^msg);
37 : gatien 3090
38 :     val stat_env = ref (StaticEnv.empty);
39 :     fun maj e = stat_env := e;
40 :    
41 :    
42 :     (*tranform a region in a string*)
43 :     fun rtoS (filename, int1, int2) =
44 :     "(" ^ filename ^ "," ^ Int.toString int1 ^ ","^Int.toString int2 ^ ")";
45 :    
46 :     (*tranform symbol to string*)
47 : gatien 3100 fun stoS symbol = S.name symbol
48 : gatien 3090
49 :     (*transform list of symbol to string*)
50 :     fun ptoS nil = ""
51 :     | ptoS [s] = stoS s
52 :     | ptoS (t::q) = stoS t ^ "." ^ ptoS q
53 :    
54 :     (* rpath to string *)
55 :     fun rptoS (InvPath.IPATH p) =
56 :     ptoS (rev p)
57 :    
58 :    
59 :    
60 :    
61 : gatien 3100 (*fun print_ty (ty:T.ty) =
62 :     case ty of
63 :     T.VARty (ref v) => (
64 :     case v of
65 :     T.INSTANTIATED ty =>
66 :     (print "(instantiated "; print_ty ty; print ")")
67 :     | T.OPEN _ => print "open"
68 :     | T.UBOUND _ => print "ubound"
69 :     | T.LITERAL _ => print "literal"
70 :     | T.SCHEME _ => print "scheme"
71 :     | T.LBOUND _ => print "lbound"
72 :     )
73 :     | T.IBOUND i => print ("(ibound " ^ Int.toString i ^ ")")
74 :     | T.CONty (tyc, tyl) =>
75 :     ( print "(conty ";
76 :     print_tyc tyc;
77 :     print ", ";
78 :     List.app print_ty tyl;
79 :     print ")"
80 :     )
81 :     | T.POLYty {tyfun = T.TYFUN {body, ...}, ...} =>
82 :     (print "(polyty "; print_ty body; print ")")
83 :     | _ => print "other_ty"
84 :    
85 :     and print_tyc (tyc:T.tycon) = (
86 :     case tyc of
87 :     T.GENtyc _ => print "gentyc"
88 :     | T.DEFtyc _ => print "deftyc"
89 :     | T.RECORDtyc _ => print "recordtyc"
90 :     | _ => print "other_tyc";
91 :     print ("_" ^ stoS (TypesUtil.tycName tyc))
92 :     )*)
93 :    
94 : gatien 3103 fun print_tycon' tyc =
95 : gatien 3100 case tyc of
96 :     Datatype (b, sl) =>
97 : gatien 3108 ( print ("datatype " ^ (if b then "(eq)" else "") ^ " (");
98 :     print (String.concatWith " " (List.map Symbol.name sl));
99 :     print ")"
100 : gatien 3100 )
101 :     | Abstract sl =>
102 : gatien 3108 ( print ("abstract (");
103 :     print (String.concatWith " " (List.map Symbol.name sl));
104 :     print ")"
105 : gatien 3100 )
106 :     | Deftyc => print "deftyc"
107 : gatien 3108 | Primtyc b => print ("primtyc " ^ (if b then "(eq)" else ""))
108 : gatien 3100
109 : gatien 3103 fun print_ty' ty =
110 : gatien 3100 case ty of
111 :     Conty (Record [], []) => print "unit"
112 :     | Conty (Record (ll as h::_), tyl) =>
113 :     if stoS h = "1" then
114 : gatien 3103 let fun p [] = ErrorMsg.impossible "Ens_var2: print_ty'.1"
115 :     | p [x] = print_ty' x
116 :     | p (x::y) = (print_ty' x; print " * "; p y)
117 : gatien 3100 in
118 :     p tyl
119 :     end
120 :     else
121 :     ( print "{";
122 :     List.app
123 :     (fn (x, y) =>
124 : gatien 3103 (print (stoS x ^ ":"); print_ty' y; print ", "))
125 : gatien 3122 (ListPair.zipEq (ll, tyl));
126 : gatien 3100 print "}"
127 :     )
128 :     | Conty (General (_, path), []) =>
129 :     print (rptoS path)
130 :     | Conty (General (_, path), [t]) =>
131 : gatien 3103 ( print_ty' t;
132 : gatien 3100 print " ";
133 :     print (rptoS path)
134 :     )
135 :     | Conty (General (_, path), [t1, t2]) =>
136 : gatien 3103 ( print_ty' t1;
137 : gatien 3100 print " ";
138 :     print (rptoS path);
139 :     print " ";
140 : gatien 3103 print_ty' t2
141 : gatien 3100 )
142 :     | Conty _ =>
143 : gatien 3103 ErrorMsg.impossible "Ens_var2: print_ty'.2"
144 : gatien 3120 | Ibound index =>
145 :     print ("'" ^ str (Char.chr (Char.ord #"a" + index)))
146 :     | Lbound {depth, index} =>
147 :     print ("'" ^ str (Char.chr (Char.ord #"A" + index)) ^
148 :     Int.toString depth)
149 : gatien 3103 | Ubound s => print (stoS s)
150 :     | Poly {body, arity} => print_ty' body
151 : gatien 3100
152 : gatien 3090 (*print a type with an environment*)
153 :     fun printer0 ty env =
154 :     (
155 :     (
156 :     (PP.with_default_pp
157 :     (fn ppstrm =>
158 :     (PPType.resetPPType(); PPType.ppType env ppstrm ty)))
159 :     handle _ => print "fail to print anything"
160 :     )
161 :     )
162 :    
163 :     (*print a type with the environment of the structure*)
164 :     fun printer ty = printer0 ty (!stat_env)
165 :    
166 :     (*print the usage and instance of the environments*)
167 :     fun print_instance usage = (
168 :     print " is used at :";
169 :     List.app
170 :     (fn (x, y) => (print ("\n\t" ^ rtoS x ^ " with type "); printer y))
171 :     (!usage);
172 :     print "\n"
173 :     )
174 : gatien 3120
175 :     fun print_var_usage usage =
176 :     ( print " is used at :";
177 :     List.app
178 :     ( fn (x, y, z) =>
179 :     ( print ("\n\t" ^ rtoS x ^ " with type ");
180 :     print_ty' y;
181 :     print (", access " ^ A.prAcc z)
182 :     )
183 :     )
184 :     (!usage);
185 :     print "\n"
186 :     )
187 :    
188 : gatien 3090 fun print_var ({access, name, parent, typ, def, usage}:var_elem) = (
189 :     print (A.prAcc access ^ ": \"" ^ stoS name ^
190 :     "\" " ^ rtoS def ^ " has type ");
191 : gatien 3103 print_ty' typ;
192 : gatien 3093 print (", is defined in " ^ A.prAcc parent ^ " and");
193 : gatien 3120 print_var_usage usage
194 : gatien 3090 )
195 : gatien 3120
196 :     fun print_type_usage usage =
197 :     ( print " is used at: ";
198 :     List.app
199 :     (fn x => print ("\n\t" ^ rtoS x))
200 :     (!usage);
201 :     print "\n"
202 :     )
203 :    
204 : gatien 3090 (*print the different type and datatype definitions and explicit uses*)
205 : gatien 3100 fun print_type ({tycon, stamp, name, def, usage} : type_elem) =
206 : gatien 3103 ( print_tycon' tycon;
207 : gatien 3100 print " ";
208 :     print (stoS name);
209 :     print " ";
210 :     print (rtoS def);
211 : gatien 3120 print_type_usage usage
212 :     )
213 :    
214 :     fun print_cons_usage usage =
215 :     ( List.app
216 :     (fn (x, y) =>
217 :     (print ("\n\t" ^ rtoS x ^ " with type "); print_ty' y))
218 : gatien 3100 (!usage);
219 :     print "\n"
220 :     )
221 : gatien 3120
222 : gatien 3090 (*print the different type constructors and uses*)
223 : gatien 3100 fun print_cons ({name, ty, dataty, def, usage} : cons_elem) = (
224 :     print (stoS name);
225 :     print " ";
226 : gatien 3103 print_ty' ty;
227 : gatien 3100 print " ";
228 :     print (rtoS def);
229 : gatien 3120 print_cons_usage usage
230 : gatien 3090 )
231 : gatien 3100
232 : gatien 3120 fun print_str_usage usage =
233 :     ( print " and is used at : ";
234 :     List.app (fn x => print ("\n\t" ^ rtoS x)) (!usage);
235 :     print "\n"
236 :     )
237 :    
238 : gatien 3090 fun print_str ({name, access, parent, sign, def, elements, usage}:str_elem)=
239 :     let
240 :     fun print_key k =
241 :     case k of
242 : gatien 3097 (Var a|Str a) => Access.prAcc a
243 : gatien 3090 | _ => "others"
244 :     in
245 :     print ("(" ^ A.prAcc access ^ ") " ^ stoS name ^
246 : gatien 3093 " " ^ rtoS def ^ " defined in ");
247 :     case parent of
248 :     NONE => print "the toplevel"
249 :     | SOME parent' => print (A.prAcc parent');
250 :     case elements of
251 :     Def el => (
252 :     print " contains ";
253 :     List.app ( fn (x, y, z)=>
254 :     print ("\n\t(" ^ Int.toString x ^ "," ^
255 :     stoS y ^ "," ^ print_key z ^ ")")
256 :     ) el
257 :     )
258 :     | Constraint (el, a) =>
259 :     ( print (" constrains " ^ A.prAcc a ^ " : ");
260 :     List.app ( fn (x, y, z) =>
261 :     print ("\n\t(" ^ Int.toString x ^ "," ^
262 :     stoS y ^ ","^Int.toString z ^ ")")
263 :     ) el
264 :     )
265 :     | Alias a => print (" aliases " ^ A.prAcc a);
266 : gatien 3120 print_str_usage usage
267 : gatien 3090 end
268 :    
269 : gatien 3120 fun print_sig_usage usage =
270 :     ( print " and is used at :";
271 :     List.app
272 :     (fn (x, y) => print ("\n\t"^(rtoS x)^" with name "^stoS y))
273 :     (!usage);
274 :     print "\n"
275 :     )
276 :    
277 :     fun print_sig ({name,stamp,inferred,def,elements,usage,alias} : sig_elem) =
278 : gatien 3090 let
279 : gatien 3103 fun print_elem l pref =
280 :     let fun print_symbol_spec (s, spec) =
281 :     let fun print_spec (Typ tycon') =
282 :     (print "typ:"; print_tycon' tycon')
283 :     | print_spec (Val ty') =
284 :     (print "val:"; print_ty' ty')
285 :     | print_spec (Exception ty') =
286 :     (print "exn:"; print_ty' ty')
287 :     | print_spec (NamedStr (symb, stamp)) =
288 :     print ("named:"^Symbol.name symb)
289 :     | print_spec (InlineStr l) =
290 :     print_elem l (pref ^ " ")
291 :     in print (Symbol.name s ^ " : ");
292 :     print_spec spec
293 :     end
294 :     in
295 :     List.app
296 :     (fn x => ( print ("\n" ^ pref ^ " ");
297 :     print_symbol_spec x)
298 :     )
299 :     l
300 :     end
301 : gatien 3090 in
302 : gatien 3120 print (Stamps.toString stamp ^ " " ^ stoS name ^
303 :     (if inferred then " (inferred)" else "")
304 : gatien 3103 ^ " : " ^ rtoS def);
305 :     print_elem elements " ";
306 : gatien 3090 List.app
307 : gatien 3100 (fn (x, symb) =>
308 :     print ("\n\thas alias "^ stoS symb ^ " " ^ (rtoS x)))
309 : gatien 3090 (!alias);
310 : gatien 3120 print_sig_usage usage
311 : gatien 3090 end
312 :    
313 : gatien 3120 fun print_ext ext =
314 :     case ext of
315 :     ExtVar {access, usage} =>
316 :     ( print ("ExtVar (" ^ A.prAcc access ^ ")");
317 :     print_var_usage usage
318 :     )
319 :     | ExtStr {access, usage} =>
320 :     ( print ("ExtStr (" ^ A.prAcc access ^ ")");
321 :     print_str_usage usage
322 :     )
323 :     | ExtType {stamp, usage} =>
324 :     ( print ("ExtType " ^ Stamps.toString stamp);
325 :     print_type_usage usage
326 :     )
327 :     | ExtCons {stamp, usage, name} =>
328 :     ( print ("ExtCons " ^ Symbol.name name ^ " " ^
329 :     Stamps.toString stamp);
330 :     print_cons_usage usage
331 :     )
332 :     | ExtSig {stamp, usage} =>
333 :     ( print ("ExtSig " ^ Stamps.toString stamp);
334 :     print_sig_usage usage
335 :     )
336 :    
337 :    
338 : gatien 3090 end
339 :     end (* structure Ens_print *)

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