Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/branches/gatien-branch/compiler/Elaborator/srcinfo/ens_print2.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 3099, Wed Jul 9 21:19:55 2008 UTC revision 3100, Thu Jul 10 17:53:13 2008 UTC
# Line 7  Line 7 
7     val ptoS : Symbol.symbol list -> string     val ptoS : Symbol.symbol list -> string
8     val rptoS : InvPath.path -> string     val rptoS : InvPath.path -> string
9    
10       val print_ty'  : Ens_types2.ty' -> string
11       val print_ty'' : Ens_types2.ty' -> unit
12     val printer : Types.ty -> unit     val printer : Types.ty -> unit
13       val scanty' : string -> Ens_types2.ty'
14    
15     val print_var : Ens_types2.var_elem -> unit     val print_var : Ens_types2.var_elem -> unit
16     val print_type : Ens_types2.type_elem -> unit     val print_type : Ens_types2.type_elem -> unit
# Line 31  Line 34 
34      open Ens_types2      open Ens_types2
35  in  in
36    
37     fun bug msg = ErrorMsg.impossible("Bugs in Ens_print: "^msg);     fun bug msg = ErrorMsg.impossible("Bugs in Ens_print2: "^msg);
38    
39     val stat_env = ref (StaticEnv.empty);     val stat_env = ref (StaticEnv.empty);
40     fun maj e = stat_env := e;     fun maj e = stat_env := e;
# Line 42  Line 45 
45         "(" ^ filename ^ "," ^ Int.toString int1 ^ ","^Int.toString int2 ^ ")";         "(" ^ filename ^ "," ^ Int.toString int1 ^ ","^Int.toString int2 ^ ")";
46    
47     (*tranform symbol to string*)     (*tranform symbol to string*)
48     fun stoS symbol = let val S.SYMBOL(_, str) = symbol in str end     fun stoS symbol = S.name symbol
49    
50     (*transform list of symbol to string*)     (*transform list of symbol to string*)
51     fun ptoS nil  = ""     fun ptoS nil  = ""
# Line 56  Line 59 
59    
60    
61    
62       (*fun print_ty (ty:T.ty) =
63             case ty of
64                 T.VARty (ref v) => (
65                 case v of
66                     T.INSTANTIATED ty =>
67                     (print "(instantiated "; print_ty ty; print ")")
68                   | T.OPEN _ => print "open"
69                   | T.UBOUND _ => print "ubound"
70                   | T.LITERAL _ => print "literal"
71                   | T.SCHEME _ => print "scheme"
72                   | T.LBOUND _ => print "lbound"
73                 )
74               | T.IBOUND i => print ("(ibound " ^ Int.toString i ^ ")")
75               | T.CONty (tyc, tyl) =>
76                 ( print "(conty ";
77                   print_tyc tyc;
78                   print ", ";
79                   List.app print_ty tyl;
80                   print ")"
81                 )
82                    | T.POLYty {tyfun = T.TYFUN {body, ...}, ...} =>
83                      (print "(polyty "; print_ty body; print ")")
84                    | _ => print "other_ty"
85    
86        and print_tyc (tyc:T.tycon) = (
87            case tyc of
88                T.GENtyc _ => print "gentyc"
89              | T.DEFtyc _ => print "deftyc"
90              | T.RECORDtyc _ => print "recordtyc"
91              | _ => print "other_tyc";
92            print ("_" ^ stoS (TypesUtil.tycName tyc))
93        )*)
94       fun pr_list pr l sep =
95           let
96               fun pr_list' [] = ""
97                 | pr_list' [h] = pr h
98                 | pr_list' (h::q) = (pr h ^ sep ^ pr_list' q)
99           in
100               pr_list' l
101           end
102    
103       fun pr_path (InvPath.IPATH path) =
104           pr_list Symbol.symbolToString (rev path) "."
105    
106       fun print_ty' ty =
107           case ty of
108               Conty (General (stamp, path), tyl) =>
109               let fun conv s =
110                       Stamps.Case
111                           (Stamps.newConverter ())
112                           s
113                           { fresh = fn x => "fresh " ^ Int.toString x,
114                             global = fn {pid, cnt} =>
115                                         "global " ^ PersStamps.toHex pid ^
116                                         " " ^ Int.toString cnt,
117                             special = fn x => "special " ^ x
118                           }
119               in
120                   "Conty General " ^ conv stamp ^ " " ^ pr_path path(*rptoS path*) ^ " ( " ^
121                   pr_list print_ty' tyl " " ^ " )"
122               end
123             | Conty (Record ll, tyl) =>
124               "Conty Record ( " ^ pr_list Symbol.symbolToString ll " " ^ " ) ( " ^ pr_list print_ty' tyl " " ^ " )"
125             | Ibound i => "Ibound " ^ Int.toString i
126    
127       fun get_int s =
128           Option.valOf (Int.fromString s)
129    
130       fun scan_stamp sl =
131           case sl of
132               "fresh" :: x :: sl' =>
133               (Stamps.fresh' (get_int x), sl')
134             | "global" :: x :: y :: sl' =>
135               (Stamps.global {pid = Option.valOf (PersStamps.fromHex x),
136                               cnt = get_int y}, sl')
137             | "special" :: x :: sl' =>
138               (Stamps.special x, sl')
139             | h :: _ => bug ("scan_stamp: " ^ h)
140             | [] => bug "scan_stamp: []"
141    
142       fun get_symbol s =
143           case String.tokens (fn c => c = #"$") s of
144              ["VAL",  name] => S.varSymbol  name
145            | ["SIG",  name] => S.sigSymbol  name
146            | ["STR",  name] => S.strSymbol  name
147            | ["FSIG", name] => S.fsigSymbol name
148            | ["FCT",  name] => S.fctSymbol  name
149            | ["TYC",  name] => S.tycSymbol  name
150            | ["LAB",  name] => S.labSymbol  name
151            | ["TYV",  name] => S.tyvSymbol  name
152            | ["FIX",  name] => S.fixSymbol  name
153            | _ => bug ("get_symbol: " ^ s)
154    
155       fun scan_symbol (sl:string list) =
156           case sl of
157               h :: sl' => (get_symbol h, sl')
158             | [] => bug "scan_symbol: []"
159    
160       fun scan_path sl =
161           case sl of
162               h :: sl' =>
163               let val sl2 = String.tokens (fn c => c = #".") h
164                   val path : InvPath.path= List.foldl
165                                  (fn (y,x) => InvPath.extend (x, get_symbol y))
166                                  InvPath.empty
167                                  sl2
168               in
169                   (path, sl')
170               end
171             | [] => bug "scan_path: []"
172    
173       fun scan_list sc sl =
174           case sl of
175               "(" :: sl' =>
176               let
177                   fun scan (")"::sl') = ([], sl')
178                     | scan sl' =
179                       let
180                           val (h', sl'') = sc sl'
181                           val (q', sl''') = scan sl''
182                       in
183                           (h' :: q', sl''')
184                       end
185               in
186                   scan sl'
187               end
188             | h :: _ => bug ("scan_list: " ^ h)
189             | [] => bug "scan_list: []"
190    
191       fun scan_ty' sl : (ty' * string list) =
192           case sl of
193               "Conty" :: "General" :: sl' =>
194               let
195                   val (s, sl'') = scan_stamp sl';
196                   val (p, sl''') = scan_path sl'';
197                   val (tyl : ty' list, sl'''') = scan_list scan_ty' sl'''
198               in
199                   (Conty (General (s, p), tyl), sl''')
200               end
201             | "Conty" :: "Record" :: sl' =>
202               let
203                   val (ll, sl'') = scan_list scan_symbol sl'
204                   val (tyl, sl''') = scan_list scan_ty' sl''
205               in
206                   (Conty (Record ll, tyl), sl''')
207               end
208             | "Ibound" :: x :: sl' =>
209               (Ibound (get_int x), sl')
210             | sl => bug ("scan_ty': " ^ String.concatWith " " sl)
211    
212       fun scanty' s =
213           #1 (scan_ty' (String.tokens (fn c => #" " = c) s))
214    
215       fun print_tyc' tyc =
216           case tyc of
217               Datatype (b, sl) =>
218               ( print ("datatype " ^ Bool.toString b ^ " ( ");
219                 print (pr_list Symbol.symbolToString sl " ");
220                 print " )"
221               )
222             | Abstract sl =>
223               ( print ("abstract ( ");
224                 print (pr_list Symbol.symbolToString sl " ");
225                 print " )"
226               )
227             | Deftyc => print "deftyc"
228             | Primtyc b => print ("primtyc "  ^ Bool.toString b)
229    
230       fun print_ty'' ty =
231           case ty of
232               Conty (Record [], []) => print "unit"
233             | Conty (Record (ll as h::_), tyl) =>
234               if stoS h = "1" then
235                   let fun p [] = ErrorMsg.impossible "Ens_var2: print_ty''.1"
236                         | p [x] = print_ty'' x
237                         | p (x::y) = (print_ty'' x; print " * "; p y)
238                   in
239                       p tyl
240                   end
241               else
242                   ( print "{";
243                     List.app
244                         (fn (x, y) =>
245                             (print (stoS x ^ ":"); print_ty'' y; print ", "))
246                         (ListPair.zip (ll, tyl));
247                     print "}"
248                   )
249             | Conty (General (_, path), []) =>
250               print (rptoS path)
251             | Conty (General (_, path), [t]) =>
252               ( print_ty'' t;
253                 print " ";
254                 print (rptoS path)
255               )
256             | Conty (General (_, path), [t1, t2]) =>
257               ( print_ty'' t1;
258                 print " ";
259                 print (rptoS path);
260                 print " ";
261                 print_ty'' t2
262               )
263             | Conty _ =>
264               ErrorMsg.impossible "Ens_var2: print_ty''.2"
265             | Ibound i =>
266               print ("'" ^ str (Char.chr (Char.ord #"a" + i)))
267    
268     (*print a type with an environment*)     (*print a type with an environment*)
269     fun printer0 ty env =     fun printer0 ty env =
270         (         (
# Line 82  Line 291 
291     fun print_var ({access, name, parent, typ, def, usage}:var_elem) = (     fun print_var ({access, name, parent, typ, def, usage}:var_elem) = (
292         print (A.prAcc access ^ ": \"" ^ stoS name ^         print (A.prAcc access ^ ": \"" ^ stoS name ^
293                "\" " ^ rtoS def ^ " has type ");                "\" " ^ rtoS def ^ " has type ");
294         printer typ;         print_ty'' typ;
295         print (", is defined in " ^ A.prAcc parent ^ " and");         print (", is defined in " ^ A.prAcc parent ^ " and");
296         print " is used at :";         print " is used at :";
297         List.app         List.app
298             ( fn (x, y, z) =>             ( fn (x, y, z) =>
299                  ( print ("\n\t" ^ rtoS x ^ " with type ");                  ( print ("\n\t" ^ rtoS x ^ " with type ");
300                    printer y;                    print_ty'' y;
301                    print (", access " ^ A.prAcc z)                    print (", access " ^ A.prAcc z)
302                  )                  )
303             )             )
# Line 97  Line 306 
306     )     )
307    
308     (*print the different type and datatype definitions and explicit uses*)     (*print the different type and datatype definitions and explicit uses*)
309     fun print_type ({tycon, def, usage}:type_elem) =     fun print_type ({tycon, stamp, name, def, usage} : type_elem) =
310         case tycon of         ( print_tyc' tycon;
311             (T.DEFtyc {tyfun = T.TYFUN {arity, body}, path, ...}) =>           print " ";
            (  
             print (rptoS path ^ " (arity " ^ Int.toString arity ^") "^  
                    rtoS def ^" : ");  
             printer (body);  
             print_instance usage  
            )  
          | (T.GENtyc {kind = T.DATATYPE {index, family, ...}, ...}) =>  
            let  
                fun temp ({dcons, ...}:T.dtmember) =  
                    List.app (fn ({name, domain, ...}:T.dconDesc) => (  
312                                  print (stoS name);                                  print (stoS name);
313                                  case domain of           print " ";
314                                      NONE => ()           print (rtoS def);
315                                    | SOME ty => (print " of "; printer ty);           print " is used at: ";
316                                  print ", "           List.app
317                                  )               (fn x => print ("\n\t" ^ rtoS x))
318                              )               (!usage);
319                              dcons           print "\n"
                val (sub as {tycname, arity, ...}) =  
                    Vector.sub (#members family,index)  
            in  
                print (stoS tycname ^ " (arity "^ Int.toString arity ^  
                       ") "^ rtoS def ^ " : ");  
                temp sub;  
                print_instance usage  
            end  
          | _ => (  
            print ("other type : " ^ rtoS def);  
            print_instance usage  
320             )             )
321    
322     (*print the different type constructors and uses*)     (*print the different type constructors and uses*)
323     fun print_cons ({name, typ, gen_typ, def, usage}:cons_elem) = (     fun print_cons ({name, ty, dataty, def, usage} : cons_elem) = (
324         print (stoS name ^ " " ^ rtoS def ^ " has type ");         print (stoS name);
325         printer typ;         print " ";
326         print " and";         print_ty'' ty;
327         print_instance usage         print " ";
328           print (rtoS def);
329           List.app
330               (fn (x, y)=>(print ("\n\t" ^ rtoS x ^ " with type "); print_ty'' y))
331               (!usage);
332           print "\n"
333     )     )
334    
335     fun print_str ({name, access, parent, sign, def, elements, usage}:str_elem)=     fun print_str ({name, access, parent, sign, def, elements, usage}:str_elem)=
# Line 184  Line 377 
377         in         in
378             print (stoS name ^ " : " ^ rtoS def);             print (stoS name ^ " : " ^ rtoS def);
379             List.app             List.app
380                 (fn (x, S.SYMBOL (_, str)) =>                 (fn (x, symb) =>
381                     print ("\n\thas alias "^ str ^ " " ^ (rtoS x)))                     print ("\n\thas alias "^ stoS symb ^ " " ^ (rtoS x)))
382                 (!alias);                 (!alias);
383             print_inst usage             print_inst usage
384         end         end

Legend:
Removed from v.3099  
changed lines
  Added in v.3100

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