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

Annotation of /sml/branches/primop-branch-2/src/compiler/FLINT/kernel/ltybasic.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2064 - (view) (download)

1 : monnier 16 (* Copyright (c) 1997 YALE FLINT PROJECT *)
2 :     (* ltybasic.sml *)
3 :    
4 :     structure LtyBasic : LTYBASIC =
5 :     struct
6 :    
7 :     local structure PT = PrimTyc
8 :     structure DI = DebIndex
9 : macqueen 2014 structure LT = Lty
10 : monnier 16 structure LK = LtyKernel
11 :    
12 :     fun bug msg = ErrorMsg.impossible("LtyExtern: "^msg)
13 :     val say = Control.Print.say
14 :    
15 :     (** common utility functions *)
16 :     val tk_inj = LK.tk_inj
17 :     val tk_out = LK.tk_out
18 :    
19 :     val tc_inj = LK.tc_inj
20 :     val tc_out = LK.tc_out
21 :    
22 :     val lt_inj = LK.lt_inj
23 :     val lt_out = LK.lt_out
24 :    
25 :     val tcc_env = LK.tcc_env
26 :     val ltc_env = LK.ltc_env
27 :    
28 : macqueen 1993 (* duplicated in ltykernel.sml *)
29 :    
30 : monnier 16 val itos = Int.toString
31 : macqueen 1993
32 : monnier 16 fun plist(p, []) = ""
33 :     | plist(p, x::xs) =
34 :     (p x) ^ (String.concat (map (fn z => ("," ^ (p z))) xs))
35 :    
36 : macqueen 2014 fun pfflag (LT.FF_VAR b) =
37 : monnier 45 let fun pff (true, true) = "rr" | pff (true, false) = "rc"
38 :     | pff (false, true) = "cr" | pff (false, false) = "cc"
39 :     in pff b
40 :     end
41 : macqueen 2014 | pfflag (LT.FF_FIXED) = "f"
42 : monnier 45
43 :     fun parw(p, (ff, t1, t2)) =
44 :     "<" ^ (p t1) ^ "> -" ^ pfflag ff ^ "-> <" ^ (p t2) ^ ">"
45 : macqueen 1993
46 : monnier 16 in
47 :    
48 : macqueen 2040 open Lty LtyDef
49 : monnier 16
50 :     (** new a type variable, currently not used *)
51 : macqueen 2014 val mkTvar : unit -> tvar = LT.mkTvar
52 : monnier 16
53 :     (** utility functions for constructing tkinds *)
54 :     fun tkc_arg n =
55 :     let fun h (n, r) = if n < 1 then r else h(n-1, tkc_mono::r)
56 :     in h(n, [])
57 :     end
58 :    
59 : monnier 45 val tkc_fn1 = tkc_fun(tkc_arg 1, tkc_mono)
60 :     val tkc_fn2 = tkc_fun(tkc_arg 2, tkc_mono)
61 :     val tkc_fn3 = tkc_fun(tkc_arg 3, tkc_mono)
62 : monnier 16
63 :     fun tkc_int 0 = tkc_mono
64 :     | tkc_int 1 = tkc_fn1
65 :     | tkc_int 2 = tkc_fn2
66 :     | tkc_int 3 = tkc_fn3
67 : monnier 45 | tkc_int i = tkc_fun(tkc_arg i, tkc_mono)
68 : monnier 16
69 : monnier 45 (** primitive fflags and rflags *)
70 :     val ffc_plambda = ffc_var (false, false)
71 :     val ffc_rrflint = ffc_var (true, true)
72 :    
73 : macqueen 2014 fun ffc_fspec (x as LT.FF_FIXED, (true,true)) = x
74 :     | ffc_fspec (x as LT.FF_VAR _, nx) = ffc_var nx
75 : monnier 45 | ffc_fspec _ = bug "unexpected case in ffc_fspec"
76 :    
77 : macqueen 2014 fun ffd_fspec (LT.FF_FIXED) = (true,true)
78 :     | ffd_fspec (LT.FF_VAR x) = x
79 : monnier 45
80 : monnier 16 (** utility functions for constructing tycs *)
81 :     val tcc_int = tcc_prim PT.ptc_int31
82 :     val tcc_int32 = tcc_prim PT.ptc_int32
83 :     val tcc_real = tcc_prim PT.ptc_real
84 :     val tcc_string = tcc_prim PT.ptc_string
85 :     val tcc_exn = tcc_prim PT.ptc_exn
86 :     val tcc_void = tcc_prim PT.ptc_void
87 :     val tcc_unit = tcc_tuple []
88 :     val tcc_bool =
89 :     let val tbool = tcc_sum [tcc_unit, tcc_unit]
90 :     val tsig_bool = tcc_fn ([tkc_mono], tbool)
91 : macqueen 2049 in tcc_fix((1, #["bool"], tsig_bool, []), 0)
92 : monnier 16 end
93 :    
94 :     val tcc_list = (* not exported, used for the printing purpose *)
95 :     let val alpha = tcc_var (DI.innermost, 0)
96 :     val tlist = tcc_var (DI.innersnd, 0)
97 :     val alist = tcc_app (tlist, [alpha])
98 :     val tcc_cons = tcc_tuple [alpha, alist]
99 :     val tlist = tcc_fn([tkc_mono], tcc_sum [tcc_cons, tcc_unit])
100 :     (** the order here should be consistent with
101 :     that in basics/basictypes.sml **)
102 :     val tsig_list = tcc_fn([tkc_int 1], tlist)
103 : macqueen 2049 in tcc_fix((1, #["list"], tsig_list, []), 0)
104 : monnier 16 end
105 :    
106 :     fun tcc_tv i = tcc_var(DI.innermost, i)
107 :     fun tcc_ref x = tcc_app(tcc_prim PT.ptc_ref, [x])
108 :     fun tcc_array x = tcc_app(tcc_prim PT.ptc_array, [x])
109 :     fun tcc_vector x = tcc_app(tcc_prim PT.ptc_vector, [x])
110 :     fun tcc_etag x = tcc_app(tcc_prim PT.ptc_etag, [x])
111 :    
112 :     (** primitive lambda ltys *)
113 :     val ltc_int = ltc_tyc tcc_int
114 :     val ltc_int32 = ltc_tyc tcc_int32
115 :     val ltc_real = ltc_tyc tcc_real
116 :     val ltc_string = ltc_tyc tcc_string
117 :     val ltc_exn = ltc_tyc tcc_exn
118 :     val ltc_void = ltc_tyc tcc_void
119 :     val ltc_unit = ltc_tyc tcc_unit
120 :     val ltc_bool = ltc_tyc tcc_bool
121 :    
122 :     val ltc_tv = ltc_tyc o tcc_tv
123 :     val ltc_ref = ltc_tyc o tcc_ref o ltd_tyc
124 :     val ltc_array = ltc_tyc o tcc_array o ltd_tyc
125 :     val ltc_vector = ltc_tyc o tcc_vector o ltd_tyc
126 :     val ltc_etag = ltc_tyc o tcc_etag o ltd_tyc
127 :    
128 :     val ltc_top = ltc_ppoly([tkc_mono], ltc_tv 0)
129 :    
130 :     (***************************************************************************
131 :     * UTILITY FUNCTIONS FOR TESTING EQUIVALENCE *
132 :     ***************************************************************************)
133 :    
134 : monnier 45 (** testing equivalence of tkinds, tycs, ltys, fflags, and rflags *)
135 : monnier 16 val tk_eqv : tkind * tkind -> bool = LK.tk_eqv
136 :     val tc_eqv : tyc * tyc -> bool = LK.tc_eqv
137 :     val lt_eqv : lty * lty -> bool = LK.lt_eqv
138 : monnier 45 val ff_eqv : fflag * fflag -> bool = LK.ff_eqv
139 :     val rf_eqv : rflag * rflag -> bool = LK.rf_eqv
140 : monnier 16
141 :    
142 :     (***************************************************************************
143 :     * UTILITY FUNCTIONS FOR PRETTY PRINTING *
144 :     ***************************************************************************)
145 :    
146 : macqueen 2014 (** (pretty?) printing of tkinds, tycs, and ltys -- see pplty.sml for real
147 :     ** pretty printing **)
148 : monnier 16 fun tk_print (x : tkind) =
149 : macqueen 2014 (case tk_out x
150 :     of LT.TK_MONO => "K0"
151 :     | LT.TK_BOX => "KB0"
152 :     | LT.TK_FUN(ks, k) =>
153 :     "<" ^ (plist(tk_print, ks)) ^ "->" ^ (tk_print k) ^ ">"
154 :     | LT.TK_SEQ zs => "KS(" ^ (plist(tk_print, zs)) ^ ")")
155 : monnier 16
156 :     fun tc_print (x : tyc) =
157 : macqueen 2014 (case (tc_out x)
158 :     of LT.TC_VAR(i,j) => "TV(" ^ (DI.di_print i) ^ "," ^ (itos j) ^ ")"
159 :     | LT.TC_NVAR v => "NTV(v" ^ (itos v) ^ ")"
160 :     | LT.TC_PRIM pt => PT.pt_print pt
161 :     | LT.TC_FN(ks, t) =>
162 :     "(\\[" ^ plist(tk_print, ks) ^ "]." ^ (tc_print t) ^ ")"
163 :     | LT.TC_APP(t, []) => tc_print t ^ "[]"
164 :     | LT.TC_APP(t, zs) =>
165 :     (tc_print t) ^ "[" ^ (plist(tc_print, zs)) ^ "]"
166 :     | LT.TC_SEQ zs => "TS(" ^ (plist(tc_print,zs)) ^ ")"
167 :     | LT.TC_PROJ (t, i) =>
168 :     "TP(" ^ (tc_print t) ^ "," ^ (itos i) ^ ")"
169 :     | LT.TC_SUM tcs =>
170 :     "TSUM(" ^ (plist(tc_print, tcs)) ^ ")"
171 : macqueen 2049 | LT.TC_FIX {family={gen=tc,params=ts,...}, index=i} =>
172 : macqueen 2014 if tc_eqv(x,tcc_bool) then "B"
173 :     else if tc_eqv(x,tcc_list) then "LST"
174 :     else (let (* val ntc = case ts of [] => tc
175 :     | _ => tcc_app(tc, ts) *)
176 :     val _ = 1
177 :     in ("DT{" ^ "DATA" ^ (* "[" ^ (tc_print tc)
178 :     ^ "] &&" ^ (plist(tc_print, ts))
179 :     ^ "&&" ^*) "===" ^ (itos i) ^ "}")
180 :     end)
181 :     | LT.TC_ABS t => "Ax(" ^ (tc_print t) ^ ")"
182 :     | LT.TC_BOX t => "Bx(" ^ (tc_print t) ^ ")"
183 :     | LT.TC_TUPLE(_,zs) => "TT<" ^ (plist(tc_print, zs)) ^ ">"
184 :     | LT.TC_ARROW (ff,z1,z2) =>
185 :     parw(fn u => plist(tc_print,u),(ff,z1,z2))
186 :     | LT.TC_PARROW _ => bug "unexpected TC_PARROW in tc_print"
187 :     | LT.TC_TOKEN (k, t) =>
188 :     if LT.token_isvalid k then
189 :     (LT.token_abbrev k) ^ "(" ^ (tc_print t) ^ ")"
190 :     else bug "unexpected TC_TOKEN tyc in tc_print"
191 :     | LT.TC_CONT ts => "Cnt(" ^ (plist(tc_print,ts)) ^ ")"
192 :     | LT.TC_IND _ => bug "unexpected TC_IND in tc_print"
193 :     | LT.TC_ENV _ => bug "unexpected TC_ENV in tc_print")
194 : monnier 16
195 :     fun lt_print (x : lty) =
196 : macqueen 2014 (case lt_out x
197 :     of LT.LT_TYC t => tc_print t
198 :     | LT.LT_STR zs => "S{" ^ (plist(lt_print, zs)) ^ "}"
199 :     | LT.LT_FCT (ts1,ts2) =>
200 :     "(" ^ (plist(lt_print, ts1)) ^ ") ==> ("
201 :     ^ (plist(lt_print, ts2)) ^ ")"
202 :     | LT.LT_POLY(ks, ts) =>
203 :     "(Q[" ^ plist(tk_print, ks) ^ "]." ^ (plist(lt_print,ts)) ^ ")"
204 :     | LT.LT_CONT ts => "CNT(" ^ (plist(lt_print, ts)) ^ ")"
205 :     | LT.LT_IND _ => bug "unexpected LT_IND in lt_print"
206 :     | LT.LT_ENV _ => bug "unexpected LT_ENV in lt_print")
207 : monnier 16
208 : macqueen 2050
209 : monnier 16 (** finding out the depth for a tyc's innermost-bound free variables *)
210 :     val tc_depth : tyc * depth -> depth = LK.tc_depth
211 :     val tcs_depth: tyc list * depth -> depth = LK.tcs_depth
212 :    
213 :     (** adjusting an lty or tyc from one depth to another *)
214 :     fun lt_adj (lt, d, nd) =
215 : monnier 45 if d = nd then lt
216 : macqueen 2027 else ltc_env(lt, 0, nd - d, LT.teEmpty)
217 : monnier 16
218 :     fun tc_adj (tc, d, nd) =
219 : monnier 45 if d = nd then tc
220 : macqueen 2027 else tcc_env(tc, 0, nd - d, LT.teEmpty)
221 : monnier 16
222 : macqueen 2014 (** The following functions are similiar to lt_adj and tc_adj;
223 :     they adjust an lty (or tyc) from depth d+k to depth nd+k,
224 : monnier 45 assuming the last k levels are type abstractions. So lt_adj
225 :     is really lt_adj_k with k set to 0. Both functions are currently
226 : macqueen 2014 called only in lcontract.sml. *)
227 : monnier 45 local
228 : macqueen 2027 fun mkTycEnv (i, k, dd, te) =
229 :     if i >= k then te
230 :     else mkTycEnv(i+1, k, dd, LT.teCons(LT.Lamb(dd+i,[]),te))
231 :     (* dbm: no ks available *)
232 : monnier 45
233 :     in
234 :     fun lt_adj_k (lt, d, nd, k) =
235 :     if d = nd then lt
236 : macqueen 2027 else ltc_env(lt, k, nd-d+k, mkTycEnv(0, k, nd-d, LT.teEmpty))
237 : monnier 45
238 :     fun tc_adj_k (tc, d, nd, k) =
239 : monnier 16 if d = nd then tc
240 : macqueen 2027 else tcc_env(tc, k, nd-d+k, mkTycEnv(0, k, nd-d, LT.teEmpty))
241 : monnier 16
242 : monnier 45 end (* lt_adj_k and tc_adj_k *)
243 :    
244 : monnier 16 (** automatically flattening the argument or the result type *)
245 :     val lt_autoflat : lty -> bool * lty list * bool = LK.lt_autoflat
246 :    
247 : monnier 45 (** testing if a tyc is a unknown constructor *)
248 :     val tc_unknown : tyc -> bool = LK.tc_unknown
249 :    
250 : monnier 16 (***************************************************************************
251 :     * UTILITY FUNCTIONS ON TKIND ENVIRONMENT *
252 :     ***************************************************************************)
253 :    
254 : macqueen 2014 type tkindEnv = LT.tkindEnv
255 :     exception tkUnbound = LT.tkUnbound
256 :     val initTkEnv = LT.initTkEnv
257 :     val tkLookup = LT.tkLookup
258 :     val tkInsert = LT.tkInsert
259 : monnier 71
260 : monnier 16 (***************************************************************************
261 :     * UTILITY FUNCTIONS ON TYC ENVIRONMENT *
262 :     ***************************************************************************)
263 :    
264 : macqueen 2014 type tycEnv = LT.tycEnv
265 : macqueen 2027 datatype teBinder = datatype LT.teBinder
266 :     val teEmpty = LT.teEmpty
267 :     val teCons = LT.teCons
268 : monnier 16
269 :     (***************************************************************************
270 :     * UTILITY FUNCTIONS ON LTY ENVIRONMENT *
271 :     ***************************************************************************)
272 :    
273 :     (** utility values and functions on ltyEnv *)
274 : monnier 504 type ltyEnv = (lty * DebIndex.depth) IntRedBlackMap.map
275 : monnier 16
276 :     exception ltUnbound
277 : monnier 504 val initLtyEnv : ltyEnv = IntRedBlackMap.empty
278 : monnier 16
279 :     fun ltLookup (venv, lv, nd) =
280 : monnier 504 (case IntRedBlackMap.find(venv, lv)
281 : monnier 422 of NONE =>
282 :     (say "**** hmmm, I didn't find the variable ";
283 :     say (Int.toString lv); say "\n";
284 :     raise ltUnbound)
285 :     | SOME (lt, d) =>
286 :     if d=nd then lt
287 :     else if d > nd then bug "unexpected depth info in ltLookup"
288 : macqueen 2027 else ltc_env(lt, 0, nd - d, LT.teEmpty)
289 : monnier 422 (*easc*))
290 : monnier 16
291 : monnier 504 fun ltInsert (venv, lv, lt, d) = IntRedBlackMap.insert(venv, lv, (lt, d))
292 : monnier 16
293 :     end (* top-level local *)
294 :     end (* structure LtyBasic *)

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