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/primop-branch-3/compiler/FLINT/kernel/ltybasic.sml
ViewVC logotype

Diff of /sml/branches/primop-branch-3/compiler/FLINT/kernel/ltybasic.sml

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

revision 17, Wed Mar 11 21:00:18 1998 UTC revision 24, Thu Mar 12 00:49:58 1998 UTC
# Line 47  Line 47 
47     in h(n, [])     in h(n, [])
48    end    end
49    
50  val tkc_fn1 = tkc_fun(tkc_arg 1, tkc_mono)  val tkc_fn1 = tkc_fun(tkc_seq(tkc_arg 1), tkc_mono)
51  val tkc_fn2 = tkc_fun(tkc_arg 2, tkc_mono)  val tkc_fn2 = tkc_fun(tkc_seq(tkc_arg 2), tkc_mono)
52  val tkc_fn3 = tkc_fun(tkc_arg 3, tkc_mono)  val tkc_fn3 = tkc_fun(tkc_seq(tkc_arg 3), tkc_mono)
53    
54  fun tkc_int 0 = tkc_mono  fun tkc_int 0 = tkc_mono
55    | tkc_int 1 = tkc_fn1    | tkc_int 1 = tkc_fn1
56    | tkc_int 2 = tkc_fn2    | tkc_int 2 = tkc_fn2
57    | tkc_int 3 = tkc_fn3    | tkc_int 3 = tkc_fn3
58    | tkc_int i = tkc_fun(tkc_arg i, tkc_mono)    | tkc_int i = tkc_fun(tkc_seq(tkc_arg i), tkc_mono)
59    
60  (** utility functions for constructing tycs *)  (** utility functions for constructing tycs *)
61  val tcc_int    = tcc_prim PT.ptc_int31  val tcc_int    = tcc_prim PT.ptc_int31
# Line 128  Line 128 
128  fun tk_print (x : tkind) =  fun tk_print (x : tkind) =
129    let fun g (LK.TK_MONO) = "K0"    let fun g (LK.TK_MONO) = "K0"
130          | g (LK.TK_BOX) = "KB0"          | g (LK.TK_BOX) = "KB0"
131          | g (LK.TK_FUN (ks, k)) =          | g (LK.TK_FUN z) =  (parw(tk_print, z))
                "<" ^ (plist(tk_print, ks)) ^ "->" ^ (tk_print k) ^ ">"  
132          | g (LK.TK_SEQ zs) = "KS(" ^ (plist(tk_print, zs)) ^ ")"          | g (LK.TK_SEQ zs) = "KS(" ^ (plist(tk_print, zs)) ^ ")"
133     in g (tk_out x)     in g (tk_out x)
134    end    end
# Line 139  Line 138 
138          | g (LK.TC_NVAR(v,d,i)) = "NTV(v" ^ (itos v) ^ "," ^ (itos d)          | g (LK.TC_NVAR(v,d,i)) = "NTV(v" ^ (itos v) ^ "," ^ (itos d)
139                                 ^ "," ^ (itos i) ^ ")"                                 ^ "," ^ (itos i) ^ ")"
140          | g (LK.TC_PRIM pt) = PT.pt_print pt          | g (LK.TC_PRIM pt) = PT.pt_print pt
141            | g (LK.TC_FN([], t)) = "TF(0," ^ (tc_print t) ^ ")"
142          | g (LK.TC_FN(ks, t)) =          | g (LK.TC_FN(ks, t)) =
143                "(\\[" ^ plist(tk_print, ks) ^ "]." ^ (tc_print t) ^ ")"                "\\" ^ (itos (length ks)) ^ ".(" ^ (tc_print t) ^ ")"
144          | g (LK.TC_APP(t, [])) = tc_print t ^ "[]"          | g (LK.TC_APP(t, [])) = tc_print t ^ "[]"
145          | g (LK.TC_APP(t, zs)) =          | g (LK.TC_APP(t, zs)) =
146                (tc_print t) ^ "[" ^ (plist(tc_print, zs)) ^ "]"                (tc_print t) ^ "[" ^ (plist(tc_print, zs)) ^ "]"
# Line 158  Line 158 
158                           end)                           end)
159          | g (LK.TC_ABS t) = "Ax(" ^ (tc_print t) ^ ")"          | g (LK.TC_ABS t) = "Ax(" ^ (tc_print t) ^ ")"
160          | g (LK.TC_BOX t) = "Bx(" ^ (tc_print t) ^ ")"          | g (LK.TC_BOX t) = "Bx(" ^ (tc_print t) ^ ")"
161          | g (LK.TC_TUPLE(_,zs)) = "TT<" ^ (plist(tc_print, zs)) ^ ">"          | g (LK.TC_TUPLE zs) = "TT<" ^ (plist(tc_print, zs)) ^ ">"
162          | g (LK.TC_ARROW (_,z1,z2)) = parw(fn u => plist(tc_print,u), (z1,z2))          | g (LK.TC_ARROW (_,z1,z2)) = parw(fn u => plist(tc_print,u), (z1,z2))
163          | g (LK.TC_PARROW _) = bug "unexpected TC_PARROW in tc_print"          | g (LK.TC_PARROW _) = bug "unexpected TC_PARROW in tc_print"
164          | g (LK.TC_CONT ts) = "Cnt(" ^ (plist(tc_print,ts)) ^ ")"          | g (LK.TC_CONT ts) = "Cnt(" ^ (plist(tc_print,ts)) ^ ")"
# Line 177  Line 177 
177               "(" ^ (plist(lt_print, ts1)) ^ ") ==> ("               "(" ^ (plist(lt_print, ts1)) ^ ") ==> ("
178                   ^ (plist(lt_print, ts2)) ^ ")"                   ^ (plist(lt_print, ts2)) ^ ")"
179          | g (LK.LT_POLY(ks, ts)) =          | g (LK.LT_POLY(ks, ts)) =
180               "(Q[" ^ plist(tk_print, ks) ^ "]." ^ (plist(lt_print,ts)) ^ ")"               "Q" ^ (itos (length ks)) ^ ".(" ^ (plist(lt_print,ts)) ^ ")"
181          | g (LK.LT_CONT ts) = "CNT(" ^ (plist(lt_print, ts)) ^ ")"          | g (LK.LT_CONT ts) = "CNT(" ^ (plist(lt_print, ts)) ^ ")"
182          | g (LK.LT_IND _) = bug "unexpected LT_IND in lt_print"          | g (LK.LT_IND _) = bug "unexpected LT_IND in lt_print"
183          | g (LK.LT_ENV _) = bug "unexpected LT_ENV in lt_print"          | g (LK.LT_ENV _) = bug "unexpected LT_ENV in lt_print"
# Line 191  Line 191 
191    
192  (** adjusting an lty or tyc from one depth to another *)  (** adjusting an lty or tyc from one depth to another *)
193  fun lt_adj (lt, d, nd) =  fun lt_adj (lt, d, nd) =
194    if d = nd then lt    if d = nd then lt else lt_norm(ltc_env(lt, 0, nd - d, LK.initTycEnv))
   else (* lt_norm *) (ltc_env(lt, 0, nd - d, LK.initTycEnv))  
195    
196  fun tc_adj (tc, d, nd) =  fun tc_adj (tc, d, nd) =
197    if d = nd then tc    if d = nd then tc else tc_norm(tcc_env(tc, 0, nd - d, LK.initTycEnv))
   else (* tc_norm *) (tcc_env(tc, 0, nd - d, LK.initTycEnv))  
   
 (** the following functions does the smiliar thing as lt_adj and  
     tc_adj; it adjusts an lty (or tyc) from depth d+k to depth nd+k,  
     assuming the last k levels are type abstractions. So lt_adj  
     is really lt_adj_k with k set to 0. Both functions are currently  
     called inside the lcontract.sml only. *)  
 local  
 fun mkTycEnv (i, k, dd, e) =  
   if i >= k then e else mkTycEnv(i+1, k, dd, LK.tcInsert(e,(NONE, dd+i)))  
   
 in  
 fun lt_adj_k (lt, d, nd, k) =  
   if d = nd then lt  
   else ltc_env(lt, k, nd-d+k, mkTycEnv(0, k, nd-d, LK.initTycEnv))  
198    
199  fun tc_adj_k (tc, d, nd, k) =  (** the following function is called only inside transtype.sml *)
200    fun tc_adj_one (tc, d, nd) =
201    if d = nd then tc    if d = nd then tc
202    else tcc_env(tc, k, nd-d+k, mkTycEnv(0, k, nd-d, LK.initTycEnv))    else (let val dd = nd - d
203             in tc_norm(tcc_env(tc, 1, dd + 1,
204  end (* lt_adj_k and tc_adj_k *)                              LK.tcInsert(LK.initTycEnv, (NONE, dd))))
205            end)
206    
207  (** automatically flattening the argument or the result type *)  (** automatically flattening the argument or the result type *)
208  val lt_autoflat : lty -> bool * lty list * bool = LK.lt_autoflat  val lt_autoflat : lty -> bool * lty list * bool = LK.lt_autoflat

Legend:
Removed from v.17  
changed lines
  Added in v.24

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