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/trunk/src/compiler/FLINT/plambda/flintnm.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/FLINT/plambda/flintnm.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 50 - (view) (download)

1 : monnier 16 (* COPYRIGHT (c) 1997 YALE FLINT PROJECT *)
2 :     (* flintnm.sml *)
3 :    
4 :     (* Converting the Standard PLambda.lexp into the FLINT IL *)
5 :     signature FLINTNM =
6 :     sig
7 :     val norm : PLambda.lexp -> FLINT.fundec
8 :     end (* signature FLINTNM *)
9 :    
10 :     structure FlintNM : FLINTNM =
11 :     struct
12 :    
13 :     local structure LT = PLambdaType
14 :     structure FL = PFlatten (* argument flattening *)
15 :     structure LV = LambdaVar
16 :     structure DI = DebIndex
17 :     structure PT = PrimTyc
18 : monnier 45 structure PO = PrimOp
19 : monnier 16 structure L = PLambda
20 :     structure F = FLINT
21 : monnier 45 structure FU = FlintUtil
22 : monnier 16 structure DA = Access
23 :     in
24 :    
25 :     val say = Control.Print.say
26 :     val mkv = LambdaVar.mkLvar
27 :     val ident = fn le : L.lexp => le
28 : monnier 45
29 :     val (iadd_prim, uadd_prim) =
30 :     let val lt_int = LT.ltc_int
31 :     val intOpTy = LT.ltc_parrow(LT.ltc_tuple[lt_int,lt_int],lt_int)
32 :     val addu = PO.ARITH{oper=PO.+, overflow=false, kind=PO.UINT 31}
33 :     in (L.PRIM(PO.IADD,intOpTy,[]), L.PRIM(addu, intOpTy, []))
34 :     end
35 :    
36 : monnier 16 fun bug msg = ErrorMsg.impossible("FlintNM: "^msg)
37 :    
38 :     fun optmap f (SOME v) = SOME (f v)
39 :     | optmap _ NONE = NONE
40 :    
41 : monnier 45 (* force_raw freezes the calling conventions of a data constructor;
42 :     strictly used by the CON and DATAcon only
43 :     *)
44 :     fun force_raw (pty) =
45 :     if LT.ltp_ppoly pty then
46 :     let val (ks, body) = LT.ltd_ppoly pty
47 :     val (aty, rty) = LT.ltd_parrow body
48 :     in LT.ltc_ppoly(ks,
49 :     LT.ltc_arrow(LT.ffc_rrflint, [FL.ltc_raw aty], [FL.ltc_raw rty]))
50 :     end
51 :     else
52 :     let val (aty, rty) = LT.ltd_parrow pty
53 :     in LT.ltc_arrow(LT.ffc_rrflint, [FL.ltc_raw aty], [FL.ltc_raw rty])
54 :     end (* function force_raw *)
55 :    
56 : monnier 16 fun tocon con =
57 :     let val _ = 1
58 :     in case con of
59 :     L.INTcon x => F.INTcon x
60 :     | L.INT32con x => F.INT32con x
61 :     | L.WORDcon x => F.WORDcon x
62 :     | L.WORD32con x => F.WORD32con x
63 :     | L.REALcon x => F.REALcon x
64 :     | L.STRINGcon x => F.STRINGcon x
65 :     | L.VLENcon x => F.VLENcon x
66 :     | L.DATAcon x => bug "unexpected case in tocon"
67 :     end
68 :    
69 :     fun tofundec (venv,d,f_lv,arg_lv,arg_lty,body,isrec) =
70 :     let val (body',body_lty) =
71 :     (* first, we translate the body (in the extended env) *)
72 :     tolexp (LT.ltInsert(venv, arg_lv, arg_lty, d), d) body
73 :    
74 :     (* detuple the arg type *)
75 : monnier 45 val ((arg_raw, arg_ltys, _), unflatten) = FL.v_punflatten arg_lty
76 : monnier 16
77 :     (* now, we add tupling code at the beginning of the body *)
78 :     val (arg_lvs, body'') = unflatten(arg_lv, body')
79 :    
80 :     (* construct the return type if necessary *)
81 : monnier 45 val (body_raw, body_ltys, _) = FL.t_pflatten body_lty
82 : monnier 16 val rettype = if not isrec then NONE
83 :     else SOME(map FL.ltc_raw body_ltys)
84 :    
85 :     val isfct = not (LT.ltp_tyc arg_lty andalso LT.ltp_tyc body_lty)
86 :     val f_lty = if isfct then LT.ltc_pfct(arg_lty, body_lty)
87 :     else LT.ltc_parrow(arg_lty, body_lty)
88 : monnier 45
89 :     val fkind = if isfct then F.FK_FCT
90 :     else F.FK_FUN{isrec=rettype,
91 :     fixed=LT.ffc_var(arg_raw, body_raw),
92 :     known=false,
93 :     inline=not isrec}
94 : monnier 16
95 : monnier 45 in ((fkind, f_lv, ListPair.zip(arg_lvs, map FL.ltc_raw arg_ltys), body''),
96 : monnier 16 f_lty)
97 :     end
98 :    
99 :    
100 :     (* used to translate expressions whose structure is the same
101 :     * in Flint as in PLambda (either both binding or both non-binding)
102 :     * a continuation is unnecessary *)
103 :     and tolexp (venv,d) lexp =
104 :     let fun default_tovalues () =
105 :     tovalues(venv, d, lexp,
106 :     fn (vals, lty) =>
107 :     (F.RET vals, lty))
108 :     in case lexp of
109 :     L.APP (L.PRIM _, arg) => default_tovalues()
110 :     | L.APP (L.GENOP _,arg) => default_tovalues()
111 :     | L.APP (L.FN (arg_lv,arg_lty,body), arg_le) =>
112 :     tolexp (venv,d) (L.LET(arg_lv, arg_le, body))
113 :     | L.APP (f,arg) =>
114 :     (* first, evaluate f to a mere value *)
115 :     tovalue(venv, d, f,
116 :     fn (f_val, f_lty) =>
117 :     (* then eval the argument *)
118 :     tovalues(venv, d, arg,
119 :     fn (arg_vals, arg_lty) =>
120 :     (* now find the return type *)
121 :     let val (_, r_lty) = LT.ltd_pfun f_lty
122 :     (* and finally do the call *)
123 :     in (F.APP(f_val,arg_vals), r_lty)
124 :     end))
125 :    
126 :     | L.FIX (lvs,ltys,lexps,lexp) =>
127 :     (* first, let's setup the enriched environment with those funs *)
128 :     let val venv' = foldl (fn ((lv,lty),ve) =>
129 :     LT.ltInsert(ve, lv, lty, d))
130 :     venv (ListPair.zip(lvs, ltys))
131 :    
132 :     (* then translate each function in turn *)
133 :     val funs = map (fn ((f_lv,f_lty),L.FN(arg_lv,arg_lty,body)) =>
134 :     #1(tofundec(venv', d,
135 :     f_lv, arg_lv, arg_lty, body, true)))
136 :     (ListPair.zip(ListPair.zip(lvs,ltys),lexps))
137 :    
138 :     (* finally, translate the lexp *)
139 :     val (lexp',lty) = tolexp (venv',d) lexp
140 :     in (F.FIX(funs,lexp'), lty)
141 :     end
142 :    
143 :     | L.LET (lvar,lexp1,lexp2) =>
144 :     tolvar(venv, d, lvar, lexp1,
145 :     fn lty1 =>
146 :     tolexp (LT.ltInsert(venv,lvar,lty1,d), d) lexp2)
147 :    
148 :     | L.RAISE (le, r_lty) =>
149 :     tovalue(venv, d, le,
150 :     fn (le_val,le_lty) =>
151 : monnier 45 let val (_, r_ltys, _) = FL.t_pflatten r_lty
152 : monnier 16 in (F.RAISE(le_val, map FL.ltc_raw r_ltys), r_lty)
153 :     end)
154 :    
155 :     | L.HANDLE (body, handler) =>
156 :     tovalue(venv, d, handler,
157 :     fn (h_val,h_lty) =>
158 :     let val (body', body_lty) = tolexp (venv, d) body
159 :     in (F.HANDLE(body', h_val), body_lty)
160 :     end)
161 :    
162 : monnier 45 | L.SWITCH (le,acs,[],NONE) => bug "unexpected case in L.SWITCH"
163 : monnier 16 (* tovalue(venv, d, le, fn _ => (F.RET[], [])) *)
164 :     | L.SWITCH (le,acs,[],SOME lexp) =>
165 :     tovalue(venv, d, le, fn (v,lty) => tolexp (venv,d) lexp)
166 :     | L.SWITCH (le,acs,conlexps,default) =>
167 :     let fun f (L.DATAcon((s,cr,lty),tycs,lvar),le) =
168 :     let val (lv_lty,_) = LT.ltd_parrow(LT.lt_pinst(lty,tycs))
169 :     val newvenv = LT.ltInsert(venv,lvar,lv_lty,d)
170 :     val (le, le_lty) = tolexp (newvenv,d) le
171 :     in
172 : monnier 45 ((F.DATAcon((s, cr, force_raw lty),
173 :     map FL.tcc_raw tycs, lvar),
174 : monnier 16 le),
175 :     le_lty)
176 :     end
177 :     | f (con,le) =
178 :     let val (lexp,lty) = tolexp (venv,d) le
179 :     in ((tocon con, lexp), lty)
180 :     end
181 :     in tovalue(venv, d, le,
182 :     fn (v, lty) =>
183 :     let val default = optmap (#1 o tolexp(venv,d)) default
184 :     val conlexps as ((_,lty)::_) = map f conlexps
185 :     in (F.SWITCH(v, acs, map #1 conlexps, default), lty)
186 :     end)
187 :     end
188 :    
189 :     (* for mere values, use tovalues *)
190 :     | _ => default_tovalues ()
191 :     end
192 :    
193 :     (*
194 :     * tovalue: turns a PLambda lexp into a value+type and then calls
195 :     * the continuation that will turn it into an Flint lexp+type
196 :     * (ltyenv * DebIndex * L.lexp * ((value * lty) -> (F.lexp * lty list))) -> (F.lexp * lty)
197 :     *
198 :     * - venv is the type environment for values
199 :     * - conts is the continuation
200 :     *)
201 :     and tovalue (venv,d,lexp,cont) =
202 :     let val _ = 1
203 :     in case lexp of
204 :     (* for simple values, it's trivial *)
205 :     L.VAR v => cont(F.VAR v, LT.ltLookup(venv, v, d))
206 : monnier 45 | L.INT i =>
207 :     ((i+i+2; cont(F.INT i, LT.ltc_int)) handle Overflow =>
208 :     (let val z = i div 2
209 :     val ne = L.APP(iadd_prim, L.RECORD [L.INT z, L.INT (i-z)])
210 :     in tovalue(venv, d, ne, cont)
211 :     end))
212 :     | L.WORD i =>
213 :     let val maxWord = 0wx20000000
214 :     in if Word.<(i, maxWord) then cont(F.WORD i, LT.ltc_int)
215 :     else let val x1 = Word.div(i, 0w2)
216 :     val x2 = Word.-(i, x1)
217 :     val ne = L.APP(uadd_prim,
218 :     L.RECORD [L.WORD x1, L.WORD x2])
219 :     in tovalue(venv, d, ne, cont)
220 :     end
221 :     end
222 : monnier 16 | L.INT32 n => cont(F.INT32 n, LT.ltc_int32)
223 :     | L.WORD32 n => cont(F.WORD32 n, LT.ltc_int32)
224 :     | L.REAL x => cont(F.REAL x, LT.ltc_real)
225 :     | L.STRING s => cont(F.STRING s, LT.ltc_string)
226 :    
227 :     (* for cases where tolvar is more convenient *)
228 :     | _ =>
229 :     let val lv = mkv()
230 :     in tolvar(venv, d, lv, lexp, fn lty => cont(F.VAR lv, lty))
231 :     end
232 :     end
233 :    
234 :    
235 :     (*
236 :     * tovalues: turns a PLambda lexp into a list of values and a list of types
237 :     * and then calls the continuation that will turn it into an Flint lexp+type
238 :     *
239 :     * (ltyenv * DebIndex * L.lexp * ((value list * lty list) -> (F.lexp * lty list))) -> (F.lexp * lty)
240 :     *
241 :     * - venv is the type environment for values
242 :     * - cont is the continuation
243 :     *)
244 :     and tovalues (venv,d,lexp,cont) =
245 :     let val _ = 1
246 :     in case lexp of
247 :     L.RECORD (lexps) =>
248 :     lexps2values(venv,d,lexps,
249 :     fn (vals,ltys) =>
250 :     let val lty = LT.ltc_tuple ltys
251 : monnier 45 val (_, ltys, _) = FL.t_pflatten lty
252 : monnier 16 in
253 :     (* detect the case where flattening is trivial *)
254 :     if LT.lt_eqv(lty, LT.ltc_tuple ltys) then
255 :     cont(vals,lty)
256 :     else
257 :     let val lv = mkv()
258 : monnier 45 val (_, pflatten) = FL.v_pflatten lty
259 :     val (vs,wrap) = pflatten (F.VAR lv)
260 : monnier 16 val (c_lexp,c_lty) = cont(vs, lty)
261 :     in
262 : monnier 45 (F.RECORD(FU.rk_tuple,
263 : monnier 16 vals, lv, wrap c_lexp),
264 :     c_lty)
265 :     end
266 :     end)
267 :    
268 :     | _ => tovalue(venv,d,lexp,
269 :     fn (v, lty) =>
270 : monnier 45 let val (vs,wrap) = (#2(FL.v_pflatten lty)) v
271 : monnier 16 val (c_lexp, c_lty) = cont(vs, lty)
272 :     in (wrap c_lexp, c_lty)
273 :     end)
274 :     end
275 :    
276 :     (* eval each lexp to a value *)
277 :     and lexps2values (venv,d,lexps,cont) =
278 :     let val _ = 1
279 :     fun f [] (vals,ltys) = cont (rev vals, rev ltys)
280 :     | f (lexp::lexps) (vals,ltys) =
281 :     tovalue(venv,d,lexp,
282 :     fn (v, lty) =>
283 :     f lexps (v::vals, lty::ltys))
284 :     in
285 :     f lexps ([], [])
286 :     end
287 :    
288 :     (*
289 :     * tolvar: same as tovalue except that it binds the value of the PLambda
290 :     * to the indicated lvar and passes just the type to the continutation
291 :     *)
292 :     and tolvar (venv,d,lvar,lexp,cont) =
293 :     let fun eta_expand (f, f_lty) =
294 :     let val lv = mkv()
295 :     val (arg_lty, ret_lty) = (LT.ltd_parrow f_lty)
296 :     in tolvar(venv, d, lvar,
297 :     L.FN(lv, arg_lty, L.APP(f, L.VAR lv)),
298 :     cont)
299 :     end
300 :    
301 :     (* inbetween tolvar and tovalue: it binds the lexp to a variable but
302 :     * is free to choose the lvar and passes it to the continutation *)
303 :     fun tolvarvalue (venv,d,lexp,cont) =
304 :     tovalue(venv, d, lexp,
305 :     fn (v,lty) =>
306 :     case v of
307 :     F.VAR lv => cont(lv, lty)
308 :     | _ => let val lv = mkv()
309 :     val (lexp',lty) = cont(lv, lty)
310 :     in (F.LET ([lv], F.RET [v], lexp'), lty)
311 :     end)
312 :    
313 : monnier 45 fun PO_helper (arg,f_lty,tycs,filler) =
314 :     (* invariants: primop's types are always fully closed *)
315 :     let (* pty is the resulting FLINT type of the underlying primop,
316 :     r_lty is the result PLambda type of this primop expression,
317 :     and flat indicates whether we should flatten the arguments
318 :     or not. The results of primops are never flattened.
319 :     *)
320 :     val (pty, r_lty, flat) =
321 :     (case (LT.ltp_ppoly f_lty, tycs)
322 :     of (true, _) =>
323 :     let val (ks, lt) = LT.ltd_ppoly f_lty
324 :     val (aty, rty) = LT.ltd_parrow lt
325 :     val r_lty =
326 :     LT.lt_pinst(LT.ltc_ppoly(ks, rty), tycs)
327 : monnier 16
328 : monnier 45 val (_, atys, flat) = FL.t_pflatten aty
329 :     (*** you really want to have a simpler
330 :     flattening heuristics here; in fact,
331 :     primop can have its own flattening
332 :     strategy. The key is that primop's
333 :     type never escape outside.
334 :     ***)
335 :    
336 :     val atys = map FL.ltc_raw atys
337 :     val nrty = FL.ltc_raw rty
338 :     val pty = LT.ltc_arrow(LT.ffc_rrflint,atys,[nrty])
339 :     in ( LT.ltc_ppoly(ks, pty), r_lty, flat)
340 :     end
341 :     | (false, []) => (* monomorphic case *)
342 :     let val (aty, rty) = LT.ltd_parrow f_lty
343 :     val (_, atys, flat) = FL.t_pflatten aty
344 :     val atys = map FL.ltc_raw atys
345 :     val nrty = FL.ltc_raw rty
346 :     val pty = LT.ltc_arrow(LT.ffc_rrflint,atys,[nrty])
347 :     in (pty, rty, flat)
348 :     end
349 :     | _ => bug "unexpected case in PO_helper")
350 :     in if flat then
351 :     (* ZHONG asks: is the following definitely safe ?
352 :     what would happen if ltc_raw is not an identity function ?
353 :     *)
354 :     tovalues(venv, d, arg,
355 :     fn (arg_vals, arg_lty) =>
356 :     let val (c_lexp, c_lty) = cont(r_lty)
357 :     (* put the filling inbetween *)
358 :     in (filler(arg_vals, pty, c_lexp), c_lty)
359 :     end)
360 :     else
361 :     tovalue(venv, d, arg,
362 :     fn (arg_val, arg_lty) =>
363 :     let val (c_lexp, c_lty) = cont(r_lty)
364 :     (* put the filling inbetween *)
365 :     in (filler([arg_val], pty, c_lexp), c_lty)
366 :     end)
367 :     end (* function PO_helper *)
368 :    
369 : monnier 16 fun default_tolexp () =
370 :     let val (lexp', lty) = tolexp (venv, d) lexp
371 :     val (c_lexp, c_lty) = cont(lty)
372 : monnier 45 val (_, punflatten) = FL.v_punflatten lty
373 :     val (lvs,c_lexp') = punflatten (lvar, c_lexp)
374 : monnier 16 in (F.LET(lvs, lexp', c_lexp'), c_lty)
375 :     end
376 :    
377 :     (* fun default_tovalue () = *)
378 :     (* tovalue(venv, d, lexp, *)
379 :     (* fn (v,lty) => *)
380 :     (* let val (lexp', ltys) = cont(lty) *)
381 :     (* in (F.LET([lvar], F.RET[v], lexp'), ltys) *)
382 :     (* end) *)
383 :    
384 :     in case lexp of
385 :     (* primops have to be eta-expanded since they're not valid
386 :     * function values anymore in Flint *)
387 :     L.PRIM (po,lty,tycs) => eta_expand(lexp, LT.lt_pinst(lty, tycs))
388 :     | L.GENOP (dict,po,lty,tycs) => eta_expand(lexp, LT.lt_pinst(lty, tycs))
389 :    
390 :     | L.FN (arg_lv,arg_lty,body) =>
391 :     (* translate the body with the extended env into a fundec *)
392 :     let val (fundec as (fk,f_lv,args,body'), f_lty) =
393 :     tofundec(venv, d, lvar, arg_lv, arg_lty, body, false)
394 :     val (lexp, lty) = cont(f_lty)
395 :     in (F.FIX([fundec], lexp), lty)
396 :     end
397 :    
398 :     (* this is were we really deal with primops *)
399 :     | L.APP (L.PRIM ((po,f_lty,tycs)),arg) =>
400 : monnier 45 PO_helper(arg, f_lty, tycs,
401 :     fn (arg_vals,pty, c_lexp) =>
402 :     F.PRIMOP((NONE, po, pty, map FL.tcc_raw tycs),
403 : monnier 16 arg_vals, lvar, c_lexp))
404 :    
405 :     | L.APP (L.GENOP({default,table},po,f_lty,tycs),arg) =>
406 :     let fun f ([],table,cont) = cont (table)
407 :     | f ((tycs,le)::t1,t2,cont) =
408 :     tolvarvalue(venv,d,le,
409 :     fn (le_lv,le_lty) =>
410 :     f(t1, (map FL.tcc_raw tycs,le_lv)::t2, cont))
411 :     (* first, eval default *)
412 :     in tolvarvalue(venv,d,default,
413 :     fn (dflt_lv,dflt_lty) =>
414 :     (* then eval the table *)
415 :     f(table, [],
416 :     fn table' =>
417 : monnier 45 PO_helper(arg, f_lty, tycs,
418 :     fn (arg_vals,pty,c_lexp) =>
419 :     F.PRIMOP((SOME {default=dflt_lv,
420 :     table=table'},
421 :     po, pty,
422 :     map FL.tcc_raw tycs),
423 : monnier 16 arg_vals, lvar, c_lexp))))
424 :     end
425 :    
426 :    
427 :     | L.TFN (tks, body) =>
428 : monnier 45 let val (body', body_lty) =
429 :     tovalue(venv, DI.next d, body,
430 :     fn (le_val, le_lty) => (F.RET [le_val], le_lty))
431 : monnier 16 val lty = LT.ltc_ppoly(tks, body_lty)
432 :     val (lexp', lty) = cont(lty)
433 : monnier 45 in (F.TFN((lvar, map (fn tk => (mkv(), tk)) tks, body'), lexp'),
434 :     lty)
435 : monnier 16 end
436 :    
437 : monnier 50 | L.TAPP (f,tycs) =>
438 :     (* similar to APP *)
439 :     tovalue(venv, d, f,
440 :     fn (f_val,f_lty) =>
441 :     let val f_lty = LT.lt_pinst(f_lty, tycs)
442 :     val (c_lexp, c_lty) = cont(f_lty)
443 :     in (F.LET([lvar], F.TAPP(f_val, map FL.tcc_raw tycs),
444 :     c_lexp), c_lty)
445 :     end)
446 :    
447 : monnier 16 | L.ETAG (le,lty) =>
448 :     tovalue(venv, d, le,
449 :     fn (le_lv, le_lty) =>
450 :     let val (c_lexp, c_lty) = cont(LT.ltc_etag lty)
451 : monnier 45 val mketag = FU.mketag (FL.tcc_raw (LT.ltd_tyc lty))
452 :     in (F.PRIMOP(mketag, [le_lv], lvar, c_lexp), c_lty)
453 : monnier 16 end)
454 :     | L.CON ((s,cr,lty),tycs,le) =>
455 : monnier 45 tovalue(venv, d, le,
456 :     fn (v,_) =>
457 : monnier 16 let val r_lty = LT.lt_pinst(lty, tycs)
458 : monnier 45 val (_,v_lty) = LT.ltd_parrow r_lty
459 : monnier 16 val (c_lexp, c_lty) = cont(v_lty)
460 : monnier 45 in (F.CON((s, cr, force_raw lty),
461 :     map FL.tcc_raw tycs, v, lvar, c_lexp),
462 : monnier 16 c_lty)
463 :     end)
464 :    
465 :     | L.VECTOR (lexps,tyc) =>
466 :     lexps2values(venv,d,lexps,
467 :     fn (vals, ltys) =>
468 :     let val lty = LT.ltc_tyc(LT.tcc_vector tyc)
469 :     val (c_lexp, c_lty) = cont(lty)
470 :     in (F.RECORD(F.RK_VECTOR (FL.tcc_raw tyc),
471 :     vals, lvar, c_lexp),
472 :     c_lty)
473 :     end)
474 :     | L.RECORD lexps =>
475 :     lexps2values(venv,d,lexps,
476 :     fn (vals, ltys) =>
477 :     let val lty = LT.ltc_tuple ltys
478 :     val (c_lexp, c_lty) = cont(lty)
479 : monnier 45 in (F.RECORD(FU.rk_tuple,
480 :     vals, lvar, c_lexp), c_lty)
481 : monnier 16 end)
482 :     | L.SRECORD lexps =>
483 :     lexps2values(venv,d,lexps,
484 :     fn (vals, ltys) =>
485 :     let val lty = LT.ltc_str(ltys)
486 :     val (c_lexp, c_lty) = cont(lty)
487 :     in (F.RECORD(F.RK_STRUCT, vals, lvar, c_lexp), c_lty)
488 :     end)
489 :    
490 :     | L.SELECT (n,lexp) =>
491 :     tovalue(venv, d, lexp,
492 :     fn (v, lty) =>
493 :     let val lty = (LT.lt_select(lty, n))
494 :     val (c_lexp, c_lty) = cont(lty)
495 :     in (F.SELECT(v, n, lvar, c_lexp), c_lty)
496 :     end)
497 :    
498 :     | L.PACK (lty,otycs,ntycs,lexp) =>
499 :     bug "PACK is not currently supported"
500 :     (*
501 :     tovalue(venv, d, lexp,
502 :     fn (v, v_lty) =>
503 :     let val nlty = LT.lt_pinst(lty, ntycs)
504 :     val (c_lexp, c_lty) = cont(nlty)
505 :     in (F.PACK(lty,
506 :     map FL.tcc_raw otycs,
507 :     map FL.tcc_raw ntycs,
508 :     v, lvar, c_lexp),
509 :     c_lty)
510 :     end)
511 :     *)
512 :    
513 :     (* these ones shouldn't matter because they shouldn't appear *)
514 : monnier 45 (* | L.WRAP _ => bug "unexpected WRAP in plambda" *)
515 :     (* | L.UNWRAP _ => bug "unexpected UNWRAP in plambda" *)
516 : monnier 16
517 :     | _ => default_tolexp ()
518 :     end
519 :    
520 :     fun norm (lexp as L.FN(arg_lv,arg_lty,e)) =
521 :     (#1(tofundec(LT.initLtyEnv, DI.top, mkv(), arg_lv, arg_lty, e, false))
522 :     handle x => raise x)
523 :     (* | norm _ = bug "unexpected toplevel lexp" *)
524 :    
525 :     end (* toplevel local *)
526 :     end (* structure FlintNM *)
527 :    

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