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 3108 - (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 :     val print_all : Ens_types2.all -> unit
20 :    
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 3100 (ListPair.zip (ll, tyl));
126 :     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 :     | Ibound {depth, index} =>
145 :     print ("'" ^ str (Char.chr (Char.ord #"a" + index)))
146 :     | Ubound s => print (stoS s)
147 :     | Poly {body, arity} => print_ty' body
148 : gatien 3100
149 : gatien 3090 (*print a type with an environment*)
150 :     fun printer0 ty env =
151 :     (
152 :     (
153 :     (PP.with_default_pp
154 :     (fn ppstrm =>
155 :     (PPType.resetPPType(); PPType.ppType env ppstrm ty)))
156 :     handle _ => print "fail to print anything"
157 :     )
158 :     )
159 :    
160 :     (*print a type with the environment of the structure*)
161 :     fun printer ty = printer0 ty (!stat_env)
162 :    
163 :     (*print the usage and instance of the environments*)
164 :     fun print_instance usage = (
165 :     print " is used at :";
166 :     List.app
167 :     (fn (x, y) => (print ("\n\t" ^ rtoS x ^ " with type "); printer y))
168 :     (!usage);
169 :     print "\n"
170 :     )
171 :    
172 :     fun print_var ({access, name, parent, typ, def, usage}:var_elem) = (
173 :     print (A.prAcc access ^ ": \"" ^ stoS name ^
174 :     "\" " ^ rtoS def ^ " has type ");
175 : gatien 3103 print_ty' typ;
176 : gatien 3093 print (", is defined in " ^ A.prAcc parent ^ " and");
177 :     print " is used at :";
178 :     List.app
179 :     ( fn (x, y, z) =>
180 :     ( print ("\n\t" ^ rtoS x ^ " with type ");
181 : gatien 3103 print_ty' y;
182 : gatien 3093 print (", access " ^ A.prAcc z)
183 :     )
184 :     )
185 :     (!usage);
186 :     print "\n"
187 : gatien 3090 )
188 :    
189 :     (*print the different type and datatype definitions and explicit uses*)
190 : gatien 3100 fun print_type ({tycon, stamp, name, def, usage} : type_elem) =
191 : gatien 3103 ( print_tycon' tycon;
192 : gatien 3100 print " ";
193 :     print (stoS name);
194 :     print " ";
195 :     print (rtoS def);
196 :     print " is used at: ";
197 :     List.app
198 :     (fn x => print ("\n\t" ^ rtoS x))
199 :     (!usage);
200 :     print "\n"
201 :     )
202 : gatien 3090
203 :     (*print the different type constructors and uses*)
204 : gatien 3100 fun print_cons ({name, ty, dataty, def, usage} : cons_elem) = (
205 :     print (stoS name);
206 :     print " ";
207 : gatien 3103 print_ty' ty;
208 : gatien 3100 print " ";
209 :     print (rtoS def);
210 :     List.app
211 : gatien 3103 (fn (x, y)=>(print ("\n\t" ^ rtoS x ^ " with type "); print_ty' y))
212 : gatien 3100 (!usage);
213 :     print "\n"
214 : gatien 3090 )
215 : gatien 3100
216 : gatien 3090 fun print_str ({name, access, parent, sign, def, elements, usage}:str_elem)=
217 :     let
218 :     fun print_key k =
219 :     case k of
220 : gatien 3097 (Var a|Str a) => Access.prAcc a
221 : gatien 3090 | _ => "others"
222 :     in
223 :     print ("(" ^ A.prAcc access ^ ") " ^ stoS name ^
224 : gatien 3093 " " ^ rtoS def ^ " defined in ");
225 :     case parent of
226 :     NONE => print "the toplevel"
227 :     | SOME parent' => print (A.prAcc parent');
228 :     case elements of
229 :     Def el => (
230 :     print " contains ";
231 :     List.app ( fn (x, y, z)=>
232 :     print ("\n\t(" ^ Int.toString x ^ "," ^
233 :     stoS y ^ "," ^ print_key z ^ ")")
234 :     ) el
235 :     )
236 :     | Constraint (el, a) =>
237 :     ( print (" constrains " ^ A.prAcc a ^ " : ");
238 :     List.app ( fn (x, y, z) =>
239 :     print ("\n\t(" ^ Int.toString x ^ "," ^
240 :     stoS y ^ ","^Int.toString z ^ ")")
241 :     ) el
242 :     )
243 :     | Alias a => print (" aliases " ^ A.prAcc a);
244 : gatien 3090 print " and is used at : ";
245 :     List.app (fn x => print ("\n\t" ^ rtoS x)) (!usage);
246 :     print "\n"
247 :     end
248 :    
249 : gatien 3103 fun print_sig ({name, stamp, inferred, def, elements, usage, alias}:sig_elem)=
250 : gatien 3090 let
251 :     fun print_inst usage = (
252 :     print " and is used at :";
253 :     List.app
254 :     (fn (x, y) => print ("\n\t"^(rtoS x)^" with name "^stoS y))
255 :     (!usage);
256 :     print "\n"
257 :     )
258 : gatien 3103 fun print_elem l pref =
259 :     let fun print_symbol_spec (s, spec) =
260 :     let fun print_spec (Typ tycon') =
261 :     (print "typ:"; print_tycon' tycon')
262 :     | print_spec (Val ty') =
263 :     (print "val:"; print_ty' ty')
264 :     | print_spec (Exception ty') =
265 :     (print "exn:"; print_ty' ty')
266 :     | print_spec (NamedStr (symb, stamp)) =
267 :     print ("named:"^Symbol.name symb)
268 :     | print_spec (InlineStr l) =
269 :     print_elem l (pref ^ " ")
270 :     in print (Symbol.name s ^ " : ");
271 :     print_spec spec
272 :     end
273 :     in
274 :     List.app
275 :     (fn x => ( print ("\n" ^ pref ^ " ");
276 :     print_symbol_spec x)
277 :     )
278 :     l
279 :     end
280 : gatien 3090 in
281 : gatien 3103 print (stoS name ^ (if inferred then " (inferred)" else "")
282 :     ^ " : " ^ rtoS def);
283 :     print_elem elements " ";
284 : gatien 3090 List.app
285 : gatien 3100 (fn (x, symb) =>
286 :     print ("\n\thas alias "^ stoS symb ^ " " ^ (rtoS x)))
287 : gatien 3090 (!alias);
288 :     print_inst usage
289 :     end
290 :    
291 :     fun print_all (a, b, c, d, e) = (
292 :     List.app print_var a;
293 :     List.app print_type b;
294 :     List.app print_cons c;
295 :     List.app print_str d;
296 :     List.app print_sig e
297 :     )
298 :     end
299 :     end (* structure Ens_print *)

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