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 3124 - (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 3124 ( print (Stamps.toString stamp ^ " ");
207 :     print_tycon' tycon;
208 : gatien 3100 print " ";
209 :     print (stoS name);
210 :     print " ";
211 :     print (rtoS def);
212 : gatien 3120 print_type_usage usage
213 :     )
214 :    
215 :     fun print_cons_usage usage =
216 :     ( List.app
217 :     (fn (x, y) =>
218 :     (print ("\n\t" ^ rtoS x ^ " with type "); print_ty' y))
219 : gatien 3100 (!usage);
220 :     print "\n"
221 :     )
222 : gatien 3120
223 : gatien 3090 (*print the different type constructors and uses*)
224 : gatien 3100 fun print_cons ({name, ty, dataty, def, usage} : cons_elem) = (
225 : gatien 3124 print (Stamps.toString dataty ^ " ");
226 : gatien 3100 print (stoS name);
227 :     print " ";
228 : gatien 3103 print_ty' ty;
229 : gatien 3100 print " ";
230 :     print (rtoS def);
231 : gatien 3120 print_cons_usage usage
232 : gatien 3090 )
233 : gatien 3100
234 : gatien 3120 fun print_str_usage usage =
235 :     ( print " and is used at : ";
236 :     List.app (fn x => print ("\n\t" ^ rtoS x)) (!usage);
237 :     print "\n"
238 :     )
239 :    
240 : gatien 3090 fun print_str ({name, access, parent, sign, def, elements, usage}:str_elem)=
241 :     let
242 :     fun print_key k =
243 :     case k of
244 : gatien 3097 (Var a|Str a) => Access.prAcc a
245 : gatien 3090 | _ => "others"
246 :     in
247 :     print ("(" ^ A.prAcc access ^ ") " ^ stoS name ^
248 : gatien 3093 " " ^ rtoS def ^ " defined in ");
249 :     case parent of
250 :     NONE => print "the toplevel"
251 :     | SOME parent' => print (A.prAcc parent');
252 :     case elements of
253 :     Def el => (
254 :     print " contains ";
255 :     List.app ( fn (x, y, z)=>
256 :     print ("\n\t(" ^ Int.toString x ^ "," ^
257 :     stoS y ^ "," ^ print_key z ^ ")")
258 :     ) el
259 :     )
260 :     | Constraint (el, a) =>
261 :     ( print (" constrains " ^ A.prAcc a ^ " : ");
262 :     List.app ( fn (x, y, z) =>
263 :     print ("\n\t(" ^ Int.toString x ^ "," ^
264 :     stoS y ^ ","^Int.toString z ^ ")")
265 :     ) el
266 :     )
267 :     | Alias a => print (" aliases " ^ A.prAcc a);
268 : gatien 3120 print_str_usage usage
269 : gatien 3090 end
270 :    
271 : gatien 3120 fun print_sig_usage usage =
272 :     ( print " and is used at :";
273 :     List.app
274 :     (fn (x, y) => print ("\n\t"^(rtoS x)^" with name "^stoS y))
275 :     (!usage);
276 :     print "\n"
277 :     )
278 :    
279 :     fun print_sig ({name,stamp,inferred,def,elements,usage,alias} : sig_elem) =
280 : gatien 3090 let
281 : gatien 3103 fun print_elem l pref =
282 :     let fun print_symbol_spec (s, spec) =
283 :     let fun print_spec (Typ tycon') =
284 :     (print "typ:"; print_tycon' tycon')
285 :     | print_spec (Val ty') =
286 :     (print "val:"; print_ty' ty')
287 :     | print_spec (Exception ty') =
288 :     (print "exn:"; print_ty' ty')
289 :     | print_spec (NamedStr (symb, stamp)) =
290 :     print ("named:"^Symbol.name symb)
291 :     | print_spec (InlineStr l) =
292 :     print_elem l (pref ^ " ")
293 :     in print (Symbol.name s ^ " : ");
294 :     print_spec spec
295 :     end
296 :     in
297 :     List.app
298 :     (fn x => ( print ("\n" ^ pref ^ " ");
299 :     print_symbol_spec x)
300 :     )
301 :     l
302 :     end
303 : gatien 3090 in
304 : gatien 3120 print (Stamps.toString stamp ^ " " ^ stoS name ^
305 :     (if inferred then " (inferred)" else "")
306 : gatien 3103 ^ " : " ^ rtoS def);
307 :     print_elem elements " ";
308 : gatien 3090 List.app
309 : gatien 3100 (fn (x, symb) =>
310 :     print ("\n\thas alias "^ stoS symb ^ " " ^ (rtoS x)))
311 : gatien 3090 (!alias);
312 : gatien 3120 print_sig_usage usage
313 : gatien 3090 end
314 :    
315 : gatien 3120 fun print_ext ext =
316 :     case ext of
317 :     ExtVar {access, usage} =>
318 :     ( print ("ExtVar (" ^ A.prAcc access ^ ")");
319 :     print_var_usage usage
320 :     )
321 :     | ExtStr {access, usage} =>
322 :     ( print ("ExtStr (" ^ A.prAcc access ^ ")");
323 :     print_str_usage usage
324 :     )
325 :     | ExtType {stamp, usage} =>
326 :     ( print ("ExtType " ^ Stamps.toString stamp);
327 :     print_type_usage usage
328 :     )
329 :     | ExtCons {stamp, usage, name} =>
330 :     ( print ("ExtCons " ^ Symbol.name name ^ " " ^
331 :     Stamps.toString stamp);
332 :     print_cons_usage usage
333 :     )
334 :     | ExtSig {stamp, usage} =>
335 :     ( print ("ExtSig " ^ Stamps.toString stamp);
336 :     print_sig_usage usage
337 :     )
338 :    
339 :    
340 : gatien 3090 end
341 :     end (* structure Ens_print *)

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