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 45 - (view) (download)
Original Path: sml/branches/SMLNJ/src/compiler/FLINT/plambda/flintnm.sml

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.TAPP (f,tycs) =>
149 :     (* similar to APP *)
150 :     tovalue(venv, d, f,
151 :     fn (f_val,f_lty) =>
152 :     let val r_lty = LT.lt_pinst(f_lty, tycs)
153 : monnier 45 val x = mkv()
154 :     val u = F.VAR x
155 :     val (vs,wrap) = (#2(FL.v_pflatten r_lty)) u
156 :     in (F.LET([x], F.TAPP(f_val, map FL.tcc_raw tycs),
157 :     wrap(F.RET(vs))), r_lty)
158 : monnier 16 end)
159 :    
160 :     | L.RAISE (le, r_lty) =>
161 :     tovalue(venv, d, le,
162 :     fn (le_val,le_lty) =>
163 : monnier 45 let val (_, r_ltys, _) = FL.t_pflatten r_lty
164 : monnier 16 in (F.RAISE(le_val, map FL.ltc_raw r_ltys), r_lty)
165 :     end)
166 :    
167 :     | L.HANDLE (body, handler) =>
168 :     tovalue(venv, d, handler,
169 :     fn (h_val,h_lty) =>
170 :     let val (body', body_lty) = tolexp (venv, d) body
171 :     in (F.HANDLE(body', h_val), body_lty)
172 :     end)
173 :    
174 : monnier 45 | L.SWITCH (le,acs,[],NONE) => bug "unexpected case in L.SWITCH"
175 : monnier 16 (* tovalue(venv, d, le, fn _ => (F.RET[], [])) *)
176 :     | L.SWITCH (le,acs,[],SOME lexp) =>
177 :     tovalue(venv, d, le, fn (v,lty) => tolexp (venv,d) lexp)
178 :     | L.SWITCH (le,acs,conlexps,default) =>
179 :     let fun f (L.DATAcon((s,cr,lty),tycs,lvar),le) =
180 :     let val (lv_lty,_) = LT.ltd_parrow(LT.lt_pinst(lty,tycs))
181 :     val newvenv = LT.ltInsert(venv,lvar,lv_lty,d)
182 :     val (le, le_lty) = tolexp (newvenv,d) le
183 :     in
184 : monnier 45 ((F.DATAcon((s, cr, force_raw lty),
185 :     map FL.tcc_raw tycs, lvar),
186 : monnier 16 le),
187 :     le_lty)
188 :     end
189 :     | f (con,le) =
190 :     let val (lexp,lty) = tolexp (venv,d) le
191 :     in ((tocon con, lexp), lty)
192 :     end
193 :     in tovalue(venv, d, le,
194 :     fn (v, lty) =>
195 :     let val default = optmap (#1 o tolexp(venv,d)) default
196 :     val conlexps as ((_,lty)::_) = map f conlexps
197 :     in (F.SWITCH(v, acs, map #1 conlexps, default), lty)
198 :     end)
199 :     end
200 :    
201 :     (* for mere values, use tovalues *)
202 :     | _ => default_tovalues ()
203 :     end
204 :    
205 :     (*
206 :     * tovalue: turns a PLambda lexp into a value+type and then calls
207 :     * the continuation that will turn it into an Flint lexp+type
208 :     * (ltyenv * DebIndex * L.lexp * ((value * lty) -> (F.lexp * lty list))) -> (F.lexp * lty)
209 :     *
210 :     * - venv is the type environment for values
211 :     * - conts is the continuation
212 :     *)
213 :     and tovalue (venv,d,lexp,cont) =
214 :     let val _ = 1
215 :     in case lexp of
216 :     (* for simple values, it's trivial *)
217 :     L.VAR v => cont(F.VAR v, LT.ltLookup(venv, v, d))
218 : monnier 45 | L.INT i =>
219 :     ((i+i+2; cont(F.INT i, LT.ltc_int)) handle Overflow =>
220 :     (let val z = i div 2
221 :     val ne = L.APP(iadd_prim, L.RECORD [L.INT z, L.INT (i-z)])
222 :     in tovalue(venv, d, ne, cont)
223 :     end))
224 :     | L.WORD i =>
225 :     let val maxWord = 0wx20000000
226 :     in if Word.<(i, maxWord) then cont(F.WORD i, LT.ltc_int)
227 :     else let val x1 = Word.div(i, 0w2)
228 :     val x2 = Word.-(i, x1)
229 :     val ne = L.APP(uadd_prim,
230 :     L.RECORD [L.WORD x1, L.WORD x2])
231 :     in tovalue(venv, d, ne, cont)
232 :     end
233 :     end
234 : monnier 16 | L.INT32 n => cont(F.INT32 n, LT.ltc_int32)
235 :     | L.WORD32 n => cont(F.WORD32 n, LT.ltc_int32)
236 :     | L.REAL x => cont(F.REAL x, LT.ltc_real)
237 :     | L.STRING s => cont(F.STRING s, LT.ltc_string)
238 :    
239 :     (* for cases where tolvar is more convenient *)
240 :     | _ =>
241 :     let val lv = mkv()
242 :     in tolvar(venv, d, lv, lexp, fn lty => cont(F.VAR lv, lty))
243 :     end
244 :     end
245 :    
246 :    
247 :     (*
248 :     * tovalues: turns a PLambda lexp into a list of values and a list of types
249 :     * and then calls the continuation that will turn it into an Flint lexp+type
250 :     *
251 :     * (ltyenv * DebIndex * L.lexp * ((value list * lty list) -> (F.lexp * lty list))) -> (F.lexp * lty)
252 :     *
253 :     * - venv is the type environment for values
254 :     * - cont is the continuation
255 :     *)
256 :     and tovalues (venv,d,lexp,cont) =
257 :     let val _ = 1
258 :     in case lexp of
259 :     L.RECORD (lexps) =>
260 :     lexps2values(venv,d,lexps,
261 :     fn (vals,ltys) =>
262 :     let val lty = LT.ltc_tuple ltys
263 : monnier 45 val (_, ltys, _) = FL.t_pflatten lty
264 : monnier 16 in
265 :     (* detect the case where flattening is trivial *)
266 :     if LT.lt_eqv(lty, LT.ltc_tuple ltys) then
267 :     cont(vals,lty)
268 :     else
269 :     let val lv = mkv()
270 : monnier 45 val (_, pflatten) = FL.v_pflatten lty
271 :     val (vs,wrap) = pflatten (F.VAR lv)
272 : monnier 16 val (c_lexp,c_lty) = cont(vs, lty)
273 :     in
274 : monnier 45 (F.RECORD(FU.rk_tuple,
275 : monnier 16 vals, lv, wrap c_lexp),
276 :     c_lty)
277 :     end
278 :     end)
279 :    
280 :     | _ => tovalue(venv,d,lexp,
281 :     fn (v, lty) =>
282 : monnier 45 let val (vs,wrap) = (#2(FL.v_pflatten lty)) v
283 : monnier 16 val (c_lexp, c_lty) = cont(vs, lty)
284 :     in (wrap c_lexp, c_lty)
285 :     end)
286 :     end
287 :    
288 :     (* eval each lexp to a value *)
289 :     and lexps2values (venv,d,lexps,cont) =
290 :     let val _ = 1
291 :     fun f [] (vals,ltys) = cont (rev vals, rev ltys)
292 :     | f (lexp::lexps) (vals,ltys) =
293 :     tovalue(venv,d,lexp,
294 :     fn (v, lty) =>
295 :     f lexps (v::vals, lty::ltys))
296 :     in
297 :     f lexps ([], [])
298 :     end
299 :    
300 :     (*
301 :     * tolvar: same as tovalue except that it binds the value of the PLambda
302 :     * to the indicated lvar and passes just the type to the continutation
303 :     *)
304 :     and tolvar (venv,d,lvar,lexp,cont) =
305 :     let fun eta_expand (f, f_lty) =
306 :     let val lv = mkv()
307 :     val (arg_lty, ret_lty) = (LT.ltd_parrow f_lty)
308 :     in tolvar(venv, d, lvar,
309 :     L.FN(lv, arg_lty, L.APP(f, L.VAR lv)),
310 :     cont)
311 :     end
312 :    
313 :     (* inbetween tolvar and tovalue: it binds the lexp to a variable but
314 :     * is free to choose the lvar and passes it to the continutation *)
315 :     fun tolvarvalue (venv,d,lexp,cont) =
316 :     tovalue(venv, d, lexp,
317 :     fn (v,lty) =>
318 :     case v of
319 :     F.VAR lv => cont(lv, lty)
320 :     | _ => let val lv = mkv()
321 :     val (lexp',lty) = cont(lv, lty)
322 :     in (F.LET ([lv], F.RET [v], lexp'), lty)
323 :     end)
324 :    
325 : monnier 45 fun PO_helper (arg,f_lty,tycs,filler) =
326 :     (* invariants: primop's types are always fully closed *)
327 :     let (* pty is the resulting FLINT type of the underlying primop,
328 :     r_lty is the result PLambda type of this primop expression,
329 :     and flat indicates whether we should flatten the arguments
330 :     or not. The results of primops are never flattened.
331 :     *)
332 :     val (pty, r_lty, flat) =
333 :     (case (LT.ltp_ppoly f_lty, tycs)
334 :     of (true, _) =>
335 :     let val (ks, lt) = LT.ltd_ppoly f_lty
336 :     val (aty, rty) = LT.ltd_parrow lt
337 :     val r_lty =
338 :     LT.lt_pinst(LT.ltc_ppoly(ks, rty), tycs)
339 : monnier 16
340 : monnier 45 val (_, atys, flat) = FL.t_pflatten aty
341 :     (*** you really want to have a simpler
342 :     flattening heuristics here; in fact,
343 :     primop can have its own flattening
344 :     strategy. The key is that primop's
345 :     type never escape outside.
346 :     ***)
347 :    
348 :     val atys = map FL.ltc_raw atys
349 :     val nrty = FL.ltc_raw rty
350 :     val pty = LT.ltc_arrow(LT.ffc_rrflint,atys,[nrty])
351 :     in ( LT.ltc_ppoly(ks, pty), r_lty, flat)
352 :     end
353 :     | (false, []) => (* monomorphic case *)
354 :     let val (aty, rty) = LT.ltd_parrow f_lty
355 :     val (_, atys, flat) = FL.t_pflatten aty
356 :     val atys = map FL.ltc_raw atys
357 :     val nrty = FL.ltc_raw rty
358 :     val pty = LT.ltc_arrow(LT.ffc_rrflint,atys,[nrty])
359 :     in (pty, rty, flat)
360 :     end
361 :     | _ => bug "unexpected case in PO_helper")
362 :     in if flat then
363 :     (* ZHONG asks: is the following definitely safe ?
364 :     what would happen if ltc_raw is not an identity function ?
365 :     *)
366 :     tovalues(venv, d, arg,
367 :     fn (arg_vals, arg_lty) =>
368 :     let val (c_lexp, c_lty) = cont(r_lty)
369 :     (* put the filling inbetween *)
370 :     in (filler(arg_vals, pty, c_lexp), c_lty)
371 :     end)
372 :     else
373 :     tovalue(venv, d, arg,
374 :     fn (arg_val, arg_lty) =>
375 :     let val (c_lexp, c_lty) = cont(r_lty)
376 :     (* put the filling inbetween *)
377 :     in (filler([arg_val], pty, c_lexp), c_lty)
378 :     end)
379 :     end (* function PO_helper *)
380 :    
381 : monnier 16 fun default_tolexp () =
382 :     let val (lexp', lty) = tolexp (venv, d) lexp
383 :     val (c_lexp, c_lty) = cont(lty)
384 : monnier 45 val (_, punflatten) = FL.v_punflatten lty
385 :     val (lvs,c_lexp') = punflatten (lvar, c_lexp)
386 : monnier 16 in (F.LET(lvs, lexp', c_lexp'), c_lty)
387 :     end
388 :    
389 :     (* fun default_tovalue () = *)
390 :     (* tovalue(venv, d, lexp, *)
391 :     (* fn (v,lty) => *)
392 :     (* let val (lexp', ltys) = cont(lty) *)
393 :     (* in (F.LET([lvar], F.RET[v], lexp'), ltys) *)
394 :     (* end) *)
395 :    
396 :     in case lexp of
397 :     (* primops have to be eta-expanded since they're not valid
398 :     * function values anymore in Flint *)
399 :     L.PRIM (po,lty,tycs) => eta_expand(lexp, LT.lt_pinst(lty, tycs))
400 :     | L.GENOP (dict,po,lty,tycs) => eta_expand(lexp, LT.lt_pinst(lty, tycs))
401 :    
402 :     | L.FN (arg_lv,arg_lty,body) =>
403 :     (* translate the body with the extended env into a fundec *)
404 :     let val (fundec as (fk,f_lv,args,body'), f_lty) =
405 :     tofundec(venv, d, lvar, arg_lv, arg_lty, body, false)
406 :     val (lexp, lty) = cont(f_lty)
407 :     in (F.FIX([fundec], lexp), lty)
408 :     end
409 :    
410 :     (* this is were we really deal with primops *)
411 :     | L.APP (L.PRIM ((po,f_lty,tycs)),arg) =>
412 : monnier 45 PO_helper(arg, f_lty, tycs,
413 :     fn (arg_vals,pty, c_lexp) =>
414 :     F.PRIMOP((NONE, po, pty, map FL.tcc_raw tycs),
415 : monnier 16 arg_vals, lvar, c_lexp))
416 :    
417 :     | L.APP (L.GENOP({default,table},po,f_lty,tycs),arg) =>
418 :     let fun f ([],table,cont) = cont (table)
419 :     | f ((tycs,le)::t1,t2,cont) =
420 :     tolvarvalue(venv,d,le,
421 :     fn (le_lv,le_lty) =>
422 :     f(t1, (map FL.tcc_raw tycs,le_lv)::t2, cont))
423 :     (* first, eval default *)
424 :     in tolvarvalue(venv,d,default,
425 :     fn (dflt_lv,dflt_lty) =>
426 :     (* then eval the table *)
427 :     f(table, [],
428 :     fn table' =>
429 : monnier 45 PO_helper(arg, f_lty, tycs,
430 :     fn (arg_vals,pty,c_lexp) =>
431 :     F.PRIMOP((SOME {default=dflt_lv,
432 :     table=table'},
433 :     po, pty,
434 :     map FL.tcc_raw tycs),
435 : monnier 16 arg_vals, lvar, c_lexp))))
436 :     end
437 :    
438 :    
439 :     | L.TFN (tks, body) =>
440 : monnier 45 let val (body', body_lty) =
441 :     tovalue(venv, DI.next d, body,
442 :     fn (le_val, le_lty) => (F.RET [le_val], le_lty))
443 : monnier 16 val lty = LT.ltc_ppoly(tks, body_lty)
444 :     val (lexp', lty) = cont(lty)
445 : monnier 45 in (F.TFN((lvar, map (fn tk => (mkv(), tk)) tks, body'), lexp'),
446 :     lty)
447 : monnier 16 end
448 :    
449 :     | L.ETAG (le,lty) =>
450 :     tovalue(venv, d, le,
451 :     fn (le_lv, le_lty) =>
452 :     let val (c_lexp, c_lty) = cont(LT.ltc_etag lty)
453 : monnier 45 val mketag = FU.mketag (FL.tcc_raw (LT.ltd_tyc lty))
454 :     in (F.PRIMOP(mketag, [le_lv], lvar, c_lexp), c_lty)
455 : monnier 16 end)
456 :     | L.CON ((s,cr,lty),tycs,le) =>
457 : monnier 45 tovalue(venv, d, le,
458 :     fn (v,_) =>
459 : monnier 16 let val r_lty = LT.lt_pinst(lty, tycs)
460 : monnier 45 val (_,v_lty) = LT.ltd_parrow r_lty
461 : monnier 16 val (c_lexp, c_lty) = cont(v_lty)
462 : monnier 45 in (F.CON((s, cr, force_raw lty),
463 :     map FL.tcc_raw tycs, v, lvar, c_lexp),
464 : monnier 16 c_lty)
465 :     end)
466 :    
467 :     | L.VECTOR (lexps,tyc) =>
468 :     lexps2values(venv,d,lexps,
469 :     fn (vals, ltys) =>
470 :     let val lty = LT.ltc_tyc(LT.tcc_vector tyc)
471 :     val (c_lexp, c_lty) = cont(lty)
472 :     in (F.RECORD(F.RK_VECTOR (FL.tcc_raw tyc),
473 :     vals, lvar, c_lexp),
474 :     c_lty)
475 :     end)
476 :     | L.RECORD lexps =>
477 :     lexps2values(venv,d,lexps,
478 :     fn (vals, ltys) =>
479 :     let val lty = LT.ltc_tuple ltys
480 :     val (c_lexp, c_lty) = cont(lty)
481 : monnier 45 in (F.RECORD(FU.rk_tuple,
482 :     vals, lvar, c_lexp), c_lty)
483 : monnier 16 end)
484 :     | L.SRECORD lexps =>
485 :     lexps2values(venv,d,lexps,
486 :     fn (vals, ltys) =>
487 :     let val lty = LT.ltc_str(ltys)
488 :     val (c_lexp, c_lty) = cont(lty)
489 :     in (F.RECORD(F.RK_STRUCT, vals, lvar, c_lexp), c_lty)
490 :     end)
491 :    
492 :     | L.SELECT (n,lexp) =>
493 :     tovalue(venv, d, lexp,
494 :     fn (v, lty) =>
495 :     let val lty = (LT.lt_select(lty, n))
496 :     val (c_lexp, c_lty) = cont(lty)
497 :     in (F.SELECT(v, n, lvar, c_lexp), c_lty)
498 :     end)
499 :    
500 :     | L.PACK (lty,otycs,ntycs,lexp) =>
501 :     bug "PACK is not currently supported"
502 :     (*
503 :     tovalue(venv, d, lexp,
504 :     fn (v, v_lty) =>
505 :     let val nlty = LT.lt_pinst(lty, ntycs)
506 :     val (c_lexp, c_lty) = cont(nlty)
507 :     in (F.PACK(lty,
508 :     map FL.tcc_raw otycs,
509 :     map FL.tcc_raw ntycs,
510 :     v, lvar, c_lexp),
511 :     c_lty)
512 :     end)
513 :     *)
514 :    
515 :     (* these ones shouldn't matter because they shouldn't appear *)
516 : monnier 45 (* | L.WRAP _ => bug "unexpected WRAP in plambda" *)
517 :     (* | L.UNWRAP _ => bug "unexpected UNWRAP in plambda" *)
518 : monnier 16
519 :     | _ => default_tolexp ()
520 :     end
521 :    
522 :     fun norm (lexp as L.FN(arg_lv,arg_lty,e)) =
523 :     (#1(tofundec(LT.initLtyEnv, DI.top, mkv(), arg_lv, arg_lty, e, false))
524 :     handle x => raise x)
525 :     (* | norm _ = bug "unexpected toplevel lexp" *)
526 :    
527 :     end (* toplevel local *)
528 :     end (* structure FlintNM *)
529 :    

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