Annotation of /sml/branches/primop-branch-2/src/compiler/FLINT/trans/translate.sml

Parent Directory | Revision Log

---

Revision 1976 - (view) (download)

1 :	monnier	16	(* COPYRIGHT (c) 1996 Bell Laboratories *)
2 :			(* translate.sml *)
3 :
4 :			signature TRANSLATE =
5 :			sig
6 :
7 :			(* Invariant: transDec always applies to a top-level absyn declaration *)
8 :	blume	1078	val transDec : { rootdec: Absyn.dec,
9 :			exportLvars: Access.lvar list,
10 :			env: StaticEnv.staticEnv,
11 :			cproto_conv: string,
12 :			compInfo: Absyn.dec CompInfo.compInfo }
13 :	monnier	45	-> {flint: FLINT.prog,
14 :	monnier	100	imports: (PersStamps.persstamp
15 :	blume	879	* ImportTree.importTree) list}
16 :	monnier	16
17 :			end (* signature TRANSLATE *)
18 :
19 :			structure Translate : TRANSLATE =
20 :			struct
21 :
22 :			local structure B = Bindings
23 :			structure BT = BasicTypes
24 :			structure DA = Access
25 :			structure DI = DebIndex
26 :			structure EM = ErrorMsg
27 :			structure LT = PLambdaType
28 :			structure M = Modules
29 :			structure MC = MatchComp
30 :			structure PO = PrimOp
31 :			structure PP = PrettyPrint
32 :			structure S = Symbol
33 :	monnier	100	structure SP = SymPath
34 :	monnier	16	structure LN = LiteralToNum
35 :			structure TT = TransTypes
36 :			structure TP = Types
37 :			structure TU = TypesUtil
38 :			structure V = VarCon
39 :	mblume	1347	structure EU = ElabUtil
40 :	monnier	16
41 :	mblume	1347	structure IIMap = RedBlackMapFn (type ord_key = IntInf.int
42 :			val compare = IntInf.compare)
43 :	monnier	16
44 :			open Absyn PLambda
45 :			in
46 :
47 :			(****************************************************************************
48 :			* CONSTANTS AND UTILITY FUNCTIONS *
49 :			****************************************************************************)
50 :
51 :			val debugging = ref true
52 :			fun bug msg = EM.impossible("Translate: " ^ msg)
53 :			val say = Control.Print.say
54 :			val ppDepth = Control.Print.printDepth
55 :
56 :			fun ppType ty =
57 :			ElabDebug.withInternals
58 :			(fn () => ElabDebug.debugPrint debugging
59 :			("type: ",PPType.ppType StaticEnv.empty, ty))
60 :
61 :			fun ident x = x
62 :			val unitLexp = RECORD []
63 :
64 :	monnier	100	fun getNameOp p = if SP.null p then NONE else SOME(SP.last p)
65 :
66 :	monnier	16	type pid = PersStamps.persstamp
67 :
68 :			(** old-style fold for cases where it is partially applied *)
69 :			fun fold f l init = foldr f init l
70 :
71 :			(** sorting the record fields for record types and record expressions *)
72 :			fun elemgtr ((LABEL{number=x,...},_),(LABEL{number=y,...},_)) = (x>y)
73 :	monnier	422	fun sorted x = ListMergeSort.sorted elemgtr x
74 :			fun sortrec x = ListMergeSort.sort elemgtr x
75 :	monnier	16
76 :	monnier	100	(** check if an access is external *)
77 :			fun extern (DA.EXTERN _) = true
78 :			| extern (DA.PATH(a, _)) = extern a
79 :			| extern _ = false
80 :
81 :	monnier	45	(** an exception raised if coreEnv is not available *)
82 :			exception NoCore
83 :
84 :			(****************************************************************************
85 :			* MAIN FUNCTION *
86 :			* *
87 :	monnier	100	* val transDec : Absyn.dec * Access.lvar list *
88 :			* * StaticEnv.staticEnv * CompBasic.compInfo *
89 :			* -> {flint: FLINT.prog, *
90 :			* imports: (PersStamps.persstamp *
91 :	blume	879	* * ImportTree.importTree) list} *
92 :	monnier	45	****************************************************************************)
93 :
94 :	blume	902	fun transDec
95 :	blume	1078	{ rootdec, exportLvars, env, cproto_conv,
96 :			compInfo as {errorMatch,error,...}: Absyn.dec CompInfo.compInfo } =
97 :	monnier	45	let
98 :
99 :	blume	903	(* We take mkLvar from compInfo. This should answer Zhong's question... *)
100 :			(*
101 :			(*
102 :			* MAJOR CLEANUP REQUIRED ! The function mkv is currently directly taken
103 :			* from the LambdaVar module; I think it should be taken from the
104 :			* "compInfo". Similarly, should we replace all mkLvar in the backend
105 :			* with the mkv in "compInfo" ? (ZHONG)
106 :			*)
107 :			val mkv = LambdaVar.mkLvar
108 :			fun mkvN NONE = mkv()
109 :			| mkvN (SOME s) = LambdaVar.namedLvar s
110 :			*)
111 :
112 :			val mkvN = #mkLvar compInfo
113 :			fun mkv () = mkvN NONE
114 :
115 :	monnier	45	(** generate the set of ML-to-FLINT type translation functions *)
116 :	blume	902	val {tpsKnd, tpsTyc, toTyc, toLty, strLty, fctLty, markLBOUND} =
117 :			TT.genTT()
118 :	monnier	45	fun toTcLt d = (toTyc d, toLty d)
119 :
120 :	monnier	16	(** translating the typ field in DATACON into lty; constant datacons
121 :			will take ltc_unit as the argument *)
122 :			fun toDconLty d ty =
123 :			(case ty
124 :			of TP.POLYty{sign, tyfun=TP.TYFUN{arity, body}} =>
125 :	monnier	45	if BT.isArrowType body then toLty d ty
126 :			else toLty d (TP.POLYty{sign=sign,
127 :	monnier	16	tyfun=TP.TYFUN{arity=arity,
128 :			body=BT.-->(BT.unitTy, body)}})
129 :	monnier	45	| _ => if BT.isArrowType ty then toLty d ty
130 :			else toLty d (BT.-->(BT.unitTy, ty)))
131 :	monnier	16
132 :			(** the special lookup functions for the Core environment *)
133 :			fun coreLookup(id, env) =
134 :	blume	592	let val sp = SymPath.SPATH [CoreSym.coreSym, S.varSymbol id]
135 :	monnier	16	val err = fn _ => fn _ => fn _ => raise NoCore
136 :			in Lookup.lookVal(env, sp, err)
137 :			end
138 :
139 :			fun CON' ((_, DA.REF, lt), ts, e) = APP (PRIM (PO.MAKEREF, lt, ts), e)
140 :			| CON' ((_, DA.SUSP (SOME(DA.LVAR d, _)), lt), ts, e) =
141 :	monnier	109	let val v = mkv ()
142 :			val fe = FN (v, LT.ltc_tuple [], e)
143 :			in APP(TAPP (VAR d, ts), fe)
144 :			end
145 :	monnier	16	| CON' x = CON x
146 :
147 :			(*
148 :			* The following code implements the exception tracking and
149 :			* errormsg reporting.
150 :			*)
151 :
152 :			local val region = ref(0,0)
153 :			val markexn = PRIM(PO.MARKEXN,
154 :	monnier	69	LT.ltc_parrow(LT.ltc_tuple [LT.ltc_exn, LT.ltc_string],
155 :			LT.ltc_exn), [])
156 :	monnier	16	in
157 :
158 :			fun withRegion loc f x =
159 :			let val r = !region
160 :			in (region := loc; f x before region:=r)
161 :			handle e => (region := r; raise e)
162 :			end
163 :
164 :			fun mkRaise(x, lt) =
165 :			let val e = if !Control.trackExn
166 :			then APP(markexn, RECORD[x, STRING(errorMatch(!region))])
167 :			else x
168 :			in RAISE(e, lt)
169 :			end
170 :
171 :			fun complain s = error (!region) s
172 :			fun repErr x = complain EM.COMPLAIN x EM.nullErrorBody
173 :	monnier	504	fun repPolyEq () =
174 :			if !Control.polyEqWarn then complain EM.WARN "calling polyEqual" EM.nullErrorBody
175 :			else ()
176 :	monnier	16
177 :			end (* markexn-local *)
178 :
179 :	monnier	100	(***************************************************************************
180 :			* SHARING AND LIFTING OF STRUCTURE IMPORTS AND ACCESSES *
181 :			***************************************************************************)
182 :
183 :	monnier	16	exception HASHTABLE
184 :			type key = int
185 :
186 :	monnier	100	(** hashkey of accesspath + accesspath + resvar *)
187 :			type info = (key * int list * lvar)
188 :	blume	733	val hashtable : info list IntHashTable.hash_table =
189 :			IntHashTable.mkTable(32,HASHTABLE)
190 :	monnier	16	fun hashkey l = foldr (fn (x,y) => ((x * 10 + y) mod 1019)) 0 l
191 :
192 :	monnier	100	fun buildHdr v =
193 :	blume	733	let val info = IntHashTable.lookup hashtable v
194 :	monnier	100	fun h((_, l, w), hdr) =
195 :	monnier	16	let val le = foldl (fn (k,e) => SELECT(k,e)) (VAR v) l
196 :	monnier	100	in fn e => hdr(LET(w, le, e))
197 :	monnier	16	end
198 :			in foldr h ident info
199 :			end handle _ => ident
200 :
201 :	monnier	100	fun bindvar (v, [], _) = v
202 :			| bindvar (v, l, nameOp) =
203 :	blume	733	let val info = (IntHashTable.lookup hashtable v) handle _ => []
204 :	monnier	100	val key = hashkey l
205 :			fun h [] =
206 :			let val u = mkvN nameOp
207 :	blume	733	in IntHashTable.insert hashtable (v,(key,l,u)::info); u
208 :	monnier	100	end
209 :			| h((k',l',w)::r) =
210 :			if (k' = key) then (if (l'=l) then w else h r) else h r
211 :			in h info
212 :			end
213 :	monnier	16
214 :	monnier	100	datatype pidInfo = ANON of (int * pidInfo) list
215 :			| NAMED of lvar * lty * (int * pidInfo) list
216 :
217 :			fun mkPidInfo (t, l, nameOp) =
218 :			let val v = mkvN nameOp
219 :			fun h [] = NAMED(v, t, [])
220 :			| h (a::r) = ANON [(a, h r)]
221 :			in (h l, v)
222 :	monnier	16	end
223 :
224 :	monnier	100	fun mergePidInfo (pi, t, l, nameOp) =
225 :			let fun h (z as NAMED(v,_,_), []) = (z, v)
226 :			| h (ANON xl, []) =
227 :			let val v = mkvN nameOp
228 :			in (NAMED(v, t, xl), v)
229 :			end
230 :			| h (z, a::r) =
231 :			let val (xl, mknode) =
232 :			case z of ANON c => (c, ANON)
233 :			| NAMED (v,tt,c) => (c, fn x => NAMED(v,tt,x))
234 :	monnier	16
235 :	monnier	100	fun dump ((np, v), z, y) =
236 :			let val nz = (a, np)::z
237 :			in (mknode((rev y) @ nz), v)
238 :			end
239 :
240 :			fun look ([], y) = dump(mkPidInfo(t, r, nameOp), [], y)
241 :			| look (u as ((x as (i,pi))::z), y) =
242 :			if i < a then look(z, x::y)
243 :			else if i = a then dump(h(pi, r), z, y)
244 :			else dump(mkPidInfo(t, r, nameOp), u, y)
245 :
246 :			in look(xl, [])
247 :			end
248 :			in h(pi, l)
249 :			end (* end of mergePidInfo *)
250 :
251 :	monnier	16	(** a map that stores information about external references *)
252 :	mblume	1347	val persmap = ref (PersMap.empty : pidInfo PersMap.map)
253 :	monnier	16
254 :	monnier	100	fun mkPid (pid, t, l, nameOp) =
255 :	mblume	1347	case PersMap.find (!persmap, pid)
256 :	monnier	422	of NONE =>
257 :			let val (pinfo, var) = mkPidInfo (t, l, nameOp)
258 :	mblume	1347	in persmap := PersMap.insert(!persmap, pid, pinfo);
259 :	monnier	422	var
260 :			end
261 :			| SOME pinfo =>
262 :			let val (npinfo, var) = mergePidInfo (pinfo, t, l, nameOp)
263 :			fun rmv (key, map) =
264 :	mblume	1347	let val (newMap, _) = PersMap.remove(map, key)
265 :	monnier	422	in newMap
266 :			end handle e => map
267 :	mblume	1347	in persmap := PersMap.insert(rmv(pid, !persmap), pid, npinfo);
268 :	monnier	422	var
269 :			end
270 :	monnier	16
271 :	mblume	1347	val iimap = ref (IIMap.empty : lvar IIMap.map)
272 :
273 :			fun getII n =
274 :			case IIMap.find (!iimap, n) of
275 :			SOME v => v
276 :			| NONE => let val v = mkv ()
277 :			in
278 :			iimap := IIMap.insert (!iimap, n, v);
279 :			v
280 :			end
281 :
282 :	monnier	16	(** converting an access w. type into a lambda expression *)
283 :	monnier	100	fun mkAccT (p, t, nameOp) =
284 :			let fun h(DA.LVAR v, l) = bindvar(v, l, nameOp)
285 :			| h(DA.EXTERN pid, l) = mkPid(pid, t, l, nameOp)
286 :	monnier	16	| h(DA.PATH(a,i), l) = h(a, i::l)
287 :			| h _ = bug "unexpected access in mkAccT"
288 :			in VAR (h(p, []))
289 :			end (* new def for mkAccT *)
290 :
291 :			(** converting an access into a lambda expression *)
292 :	monnier	100	fun mkAcc (p, nameOp) =
293 :			let fun h(DA.LVAR v, l) = bindvar(v, l, nameOp)
294 :	monnier	16	| h(DA.PATH(a,i), l) = h(a, i::l)
295 :			| h _ = bug "unexpected access in mkAcc"
296 :			in VAR (h(p, []))
297 :			end (* new def for mkAcc *)
298 :
299 :			(*
300 :			* These two functions are major gross hacks. The NoCore exceptions would
301 :			* be raised when compiling boot/dummy.sml, boot/assembly.sig, and
302 :			* boot/core.sml; the assumption is that the result of coreExn and coreAcc
303 :			* would never be used when compiling these three files. A good way to
304 :			* clean up this is to put all the core constructors and primitives into
305 :			* the primitive environment. (ZHONG)
306 :			*)
307 :	blume	904	exception NoCore
308 :
309 :	monnier	16	fun coreExn id =
310 :	blume	904	(case CoreAccess.getCon' (fn () => raise NoCore) (env, id) of
311 :			TP.DATACON { name, rep as DA.EXN _, typ, ... } =>
312 :			let val nt = toDconLty DI.top typ
313 :			val nrep = mkRep(rep, nt, name)
314 :	georgekuan	1974	val _ = print "coreExn in translate.sml: "
315 :			val _ = PPLexp.printLexp (CON'((name, nrep, nt), [], unitLexp))
316 :			val _ = print "\n"
317 :	blume	904	in CON'((name, nrep, nt), [], unitLexp)
318 :			end
319 :			| _ => bug "coreExn in translate")
320 :			handle NoCore => (say "WARNING: no Core access\n"; INT 0)
321 :	monnier	16
322 :			and coreAcc id =
323 :	blume	904	(case CoreAccess.getVar' (fn () => raise NoCore) (env, id) of
324 :			V.VALvar { access, typ, path, ... } =>
325 :			mkAccT(access, toLty DI.top (!typ), getNameOp path)
326 :			| _ => bug "coreAcc in translate")
327 :			handle NoCore => (say "WARNING: no Core access\n"; INT 0)
328 :	monnier	16
329 :			(** expands the flex record pattern and convert the EXN access pat *)
330 :			(** internalize the conrep's access, always exceptions *)
331 :	monnier	100	and mkRep (rep, lt, name) =
332 :			let fun g (DA.LVAR v, l, t) = bindvar(v, l, SOME name)
333 :			| g (DA.PATH(a, i), l, t) = g(a, i::l, t)
334 :			| g (DA.EXTERN p, l, t) = mkPid(p, t, l, SOME name)
335 :	monnier	16	| g _ = bug "unexpected access in mkRep"
336 :
337 :			in case rep
338 :			of (DA.EXN x) =>
339 :			let val (argt, _) = LT.ltd_parrow lt
340 :			in DA.EXN (DA.LVAR (g(x, [], LT.ltc_etag argt)))
341 :			end
342 :			| (DA.SUSP NONE) => (* a hack to support "delay-force" primitives *)
343 :			(case (coreAcc "delay", coreAcc "force")
344 :			of (VAR x, VAR y) => DA.SUSP(SOME (DA.LVAR x, DA.LVAR y))
345 :			| _ => bug "unexpected case on conrep SUSP 1")
346 :			| (DA.SUSP (SOME _)) => bug "unexpected case on conrep SUSP 2"
347 :			| _ => rep
348 :			end
349 :
350 :	macqueen	1967	(** converting a value of access+prim into the lambda expression
351 :			** [KM???} But it is ignoring the prim argument!!!
352 :			**)
353 :			fun mkAccInfo (acc, prim, getLty, nameOp) =
354 :	monnier	100	if extern acc then mkAccT(acc, getLty(), nameOp) else mkAcc (acc, nameOp)
355 :	monnier	16
356 :			fun fillPat(pat, d) =
357 :			let fun fill (CONSTRAINTpat (p,t)) = fill p
358 :			| fill (LAYEREDpat (p,q)) = LAYEREDpat(fill p, fill q)
359 :			| fill (RECORDpat {fields, flex=false, typ}) =
360 :			RECORDpat{fields = map (fn (lab, p) => (lab, fill p)) fields,
361 :			typ = typ, flex = false}
362 :			| fill (pat as RECORDpat {fields, flex=true, typ}) =
363 :			let exception DontBother
364 :			val fields' = map (fn (l,p) => (l, fill p)) fields
365 :
366 :			fun find (t as TP.CONty(TP.RECORDtyc labels, _)) =
367 :			(typ := t; labels)
368 :			| find _ = (complain EM.COMPLAIN "unresolved flexible record"
369 :			(fn ppstrm =>
370 :	macqueen	1344	(PP.newline ppstrm;
371 :			PP.string ppstrm "pattern: ";
372 :	monnier	16	PPAbsyn.ppPat env ppstrm
373 :			(pat,!Control.Print.printDepth)));
374 :			raise DontBother)
375 :
376 :			fun merge (a as ((id,p)::r), lab::s) =
377 :			if S.eq(id,lab) then (id,p) :: merge(r,s)
378 :			else (lab,WILDpat) :: merge(a,s)
379 :			| merge ([], lab::s) = (lab,WILDpat) :: merge([], s)
380 :			| merge ([], []) = []
381 :			| merge _ = bug "merge in translate"
382 :
383 :			in RECORDpat{fields = merge(fields',
384 :			find(TU.headReduceType (!typ))),
385 :			flex = false, typ = typ}
386 :			handle DontBother => WILDpat
387 :			end
388 :			| fill (VECTORpat(pats,ty)) = VECTORpat(map fill pats, ty)
389 :			| fill (ORpat(p1, p2)) = ORpat(fill p1, fill p2)
390 :	monnier	109	| fill (CONpat(TP.DATACON{name, const, typ, rep, sign, lazyp}, ts)) =
391 :			CONpat(TP.DATACON{name=name, const=const, typ=typ, lazyp=lazyp,
392 :	monnier	100	sign=sign, rep=mkRep(rep, toDconLty d typ, name)}, ts)
393 :	monnier	109	| fill (APPpat(TP.DATACON{name, const, typ, rep, sign, lazyp}, ts, pat)) =
394 :			APPpat(TP.DATACON{name=name, const=const, typ=typ, sign=sign, lazyp=lazyp,
395 :	monnier	100	rep=mkRep(rep, toDconLty d typ, name)}, ts, fill pat)
396 :	monnier	16	| fill xp = xp
397 :
398 :			in fill pat
399 :			end (* function fillPat *)
400 :
401 :			(** The runtime polymorphic equality and string equality dictionary. *)
402 :			val eqDict =
403 :			let val strEqRef : lexp option ref = ref NONE
404 :			val polyEqRef : lexp option ref = ref NONE
405 :	mblume	1347	val intInfEqRef : lexp option ref = ref NONE
406 :	monnier	16
407 :			fun getStrEq () =
408 :			(case (!strEqRef)
409 :			of SOME e => e
410 :			| NONE => (let val e = coreAcc "stringequal"
411 :			in strEqRef := (SOME e); e
412 :			end))
413 :
414 :	mblume	1347	fun getIntInfEq () = (* same as polyeq, but silent *)
415 :			case !intInfEqRef of
416 :			SOME e => e
417 :			| NONE => let val e =
418 :			TAPP (coreAcc "polyequal",
419 :			[toTyc DI.top BT.intinfTy])
420 :			in
421 :			intInfEqRef := SOME e; e
422 :			end
423 :
424 :	monnier	16	fun getPolyEq () =
425 :	monnier	504	(repPolyEq();
426 :			case (!polyEqRef)
427 :	monnier	16	of SOME e => e
428 :			| NONE => (let val e = coreAcc "polyequal"
429 :			in polyEqRef := (SOME e); e
430 :			end))
431 :	mblume	1347	in {getStrEq=getStrEq, getIntInfEq=getIntInfEq, getPolyEq=getPolyEq}
432 :	monnier	16	end
433 :
434 :	monnier	504	val eqGen = PEqual.equal (eqDict, env)
435 :	monnier	16
436 :			(***************************************************************************
437 :			* *
438 :			* Translating the primops; this should be moved into a separate file *
439 :			* in the future. (ZHONG) *
440 :			* *
441 :			***************************************************************************)
442 :
443 :			val lt_tyc = LT.ltc_tyc
444 :			val lt_arw = LT.ltc_parrow
445 :			val lt_tup = LT.ltc_tuple
446 :			val lt_int = LT.ltc_int
447 :			val lt_int32 = LT.ltc_int32
448 :			val lt_bool = LT.ltc_bool
449 :	mblume	1332	val lt_unit = LT.ltc_unit
450 :	monnier	16
451 :			val lt_ipair = lt_tup [lt_int, lt_int]
452 :	mblume	1683	val lt_i32pair = lt_tup [lt_int32, lt_int32]
453 :	monnier	16	val lt_icmp = lt_arw (lt_ipair, lt_bool)
454 :			val lt_ineg = lt_arw (lt_int, lt_int)
455 :			val lt_intop = lt_arw (lt_ipair, lt_int)
456 :	mblume	1332	val lt_u_u = lt_arw (lt_unit, lt_unit)
457 :	monnier	16
458 :			val boolsign = BT.boolsign
459 :			val (trueDcon', falseDcon') =
460 :			let val lt = LT.ltc_parrow(LT.ltc_unit, LT.ltc_bool)
461 :			fun h (TP.DATACON{name,rep,typ,...}) = (name, rep, lt)
462 :			in (h BT.trueDcon, h BT.falseDcon)
463 :			end
464 :
465 :			val trueLexp = CON(trueDcon', [], unitLexp)
466 :			val falseLexp = CON(falseDcon', [], unitLexp)
467 :
468 :			fun COND(a,b,c) =
469 :			SWITCH(a,boolsign, [(DATAcon(trueDcon', [], mkv()),b),
470 :			(DATAcon(falseDcon', [], mkv()),c)], NONE)
471 :
472 :			fun composeNOT (eq, t) =
473 :			let val v = mkv()
474 :			val argt = lt_tup [t, t]
475 :			in FN(v, argt, COND(APP(eq, VAR v), falseLexp, trueLexp))
476 :			end
477 :
478 :			fun cmpOp p = PRIM(p, lt_icmp, [])
479 :			fun inegOp p = PRIM(p, lt_ineg, [])
480 :
481 :			val LESSU = PO.CMP{oper=PO.LTU, kind=PO.UINT 31}
482 :
483 :			val lt_len = LT.ltc_poly([LT.tkc_mono], [lt_arw(LT.ltc_tv 0, lt_int)])
484 :			val lt_upd =
485 :			let val x = LT.ltc_ref (LT.ltc_tv 0)
486 :			in LT.ltc_poly([LT.tkc_mono],
487 :			[lt_arw(lt_tup [x, lt_int, LT.ltc_tv 0], LT.ltc_unit)])
488 :			end
489 :
490 :			fun lenOp(tc) = PRIM(PO.LENGTH, lt_len, [tc])
491 :
492 :			fun rshiftOp k = PO.ARITH{oper=PO.RSHIFT, overflow=false, kind=k}
493 :			fun rshiftlOp k = PO.ARITH{oper=PO.RSHIFTL, overflow=false, kind=k}
494 :			fun lshiftOp k = PO.ARITH{oper=PO.LSHIFT, overflow=false, kind=k}
495 :
496 :			fun lword0 (PO.UINT 31) = WORD 0w0
497 :			| lword0 (PO.UINT 32) = WORD32 0w0
498 :			| lword0 _ = bug "unexpected case in lword0"
499 :
500 :			fun baselt (PO.UINT 31) = lt_int
501 :			| baselt (PO.UINT 32) = lt_int32
502 :			| baselt _ = bug "unexpected case in baselt"
503 :
504 :			fun shiftTy k =
505 :			let val elem = baselt k
506 :			val tupt = lt_tup [elem, lt_int]
507 :			in lt_arw(tupt, elem)
508 :			end
509 :
510 :			fun inlineShift(shiftOp, kind, clear) =
511 :	mblume	1683	let fun shiftLimit (PO.UINT lim | PO.INT lim) = WORD(Word.fromInt lim)
512 :	monnier	16	| shiftLimit _ = bug "unexpected case in shiftLimit"
513 :
514 :			val p = mkv() val vp = VAR p
515 :			val w = mkv() val vw = VAR w
516 :			val cnt = mkv() val vcnt = VAR cnt
517 :
518 :			val argt = lt_tup [baselt(kind), lt_int]
519 :			val cmpShiftAmt =
520 :			PRIM(PO.CMP{oper=PO.LEU, kind=PO.UINT 31}, lt_icmp, [])
521 :			in FN(p, argt,
522 :			LET(w, SELECT(0, vp),
523 :			LET(cnt, SELECT(1, vp),
524 :			COND(APP(cmpShiftAmt, RECORD [shiftLimit(kind), vcnt]),
525 :			clear vw,
526 :			APP(PRIM(shiftOp(kind), shiftTy(kind), []),
527 :			RECORD [vw, vcnt])))))
528 :			end
529 :
530 :	blume	1183	fun inlops nk = let
531 :			val (lt_arg, zero, overflow) =
532 :			case nk of
533 :			PO.INT 31 => (LT.ltc_int, INT 0, true)
534 :			| PO.UINT 31 => (LT.ltc_int, WORD 0w0, false)
535 :			| PO.INT 32 => (LT.ltc_int32, INT32 0, true)
536 :			| PO.UINT 32 => (LT.ltc_int32, WORD32 0w0, false)
537 :			| PO.FLOAT 64 => (LT.ltc_real, REAL "0.0", false)
538 :			| _ => bug "inlops: bad numkind"
539 :			val lt_argpair = lt_tup [lt_arg, lt_arg]
540 :			val lt_cmp = lt_arw (lt_argpair, lt_bool)
541 :			val lt_neg = lt_arw (lt_arg, lt_arg)
542 :			val less = PRIM (PO.CMP { oper = PO.<, kind = nk }, lt_cmp, [])
543 :			val greater = PRIM (PO.CMP { oper = PO.>, kind = nk }, lt_cmp, [])
544 :			val negate =
545 :			PRIM (PO.ARITH { oper = PO.~, overflow = overflow, kind = nk },
546 :			lt_neg, [])
547 :			in
548 :			{ lt_arg = lt_arg, lt_argpair = lt_argpair, lt_cmp = lt_cmp,
549 :			less = less, greater = greater,
550 :			zero = zero, negate = negate }
551 :			end
552 :	monnier	16
553 :	blume	1183	fun inlminmax (nk, ismax) = let
554 :			val { lt_argpair, less, greater, lt_cmp, ... } = inlops nk
555 :			val x = mkv () and y = mkv () and z = mkv ()
556 :			val cmpop = if ismax then greater else less
557 :			val elsebranch =
558 :			case nk of
559 :			PO.FLOAT _ => let
560 :			(* testing for NaN *)
561 :			val fequal =
562 :			PRIM (PO.CMP { oper = PO.EQL, kind = nk }, lt_cmp, [])
563 :			in
564 :	blume	1249	COND (APP (fequal, RECORD [VAR y, VAR y]), VAR y, VAR x)
565 :	blume	1183	end
566 :			| _ => VAR y
567 :			in
568 :			FN (z, lt_argpair,
569 :			LET (x, SELECT (0, VAR z),
570 :			LET (y, SELECT (1, VAR z),
571 :			COND (APP (cmpop, RECORD [VAR x, VAR y]),
572 :			VAR x, elsebranch))))
573 :			end
574 :
575 :			fun inlabs nk = let
576 :			val { lt_arg, greater, zero, negate, ... } = inlops nk
577 :			val x = mkv ()
578 :			in
579 :			FN (x, lt_arg,
580 :			COND (APP (greater, RECORD [VAR x, zero]),
581 :			VAR x, APP (negate, VAR x)))
582 :			end
583 :
584 :	mblume	1347	fun inl_infPrec (what, corename, p, lt, is_from_inf) = let
585 :			val (orig_arg_lt, res_lt) =
586 :			case LT.ltd_arrow lt of
587 :			(_, [a], [r]) => (a, r)
588 :			| _ => bug ("unexpected type of " ^ what)
589 :			val extra_arg_lt =
590 :			LT.ltc_parrow (if is_from_inf then (orig_arg_lt, LT.ltc_int32)
591 :			else (LT.ltc_int32, orig_arg_lt))
592 :			val new_arg_lt = LT.ltc_tuple [orig_arg_lt, extra_arg_lt]
593 :			val new_lt = LT.ltc_parrow (new_arg_lt, res_lt)
594 :			val x = mkv ()
595 :			in
596 :			FN (x, orig_arg_lt,
597 :			APP (PRIM (p, new_lt, []),
598 :			RECORD [VAR x, coreAcc corename]))
599 :			end
600 :
601 :	monnier	16	fun transPrim (prim, lt, ts) =
602 :			let fun g (PO.INLLSHIFT k) = inlineShift(lshiftOp, k, fn _ => lword0(k))
603 :			| g (PO.INLRSHIFTL k) = inlineShift(rshiftlOp, k, fn _ => lword0(k))
604 :			| g (PO.INLRSHIFT k) = (* preserve sign bit with arithmetic rshift *)
605 :			let fun clear w = APP(PRIM(rshiftOp k, shiftTy k, []),
606 :			RECORD [w, WORD 0w31])
607 :			in inlineShift(rshiftOp, k, clear)
608 :			end
609 :
610 :	blume	1183	| g (PO.INLMIN nk) = inlminmax (nk, false)
611 :			| g (PO.INLMAX nk) = inlminmax (nk, true)
612 :			| g (PO.INLABS nk) = inlabs nk
613 :	monnier	16
614 :			| g (PO.INLNOT) =
615 :			let val x = mkv()
616 :			in FN(x, lt_bool, COND(VAR x, falseLexp, trueLexp))
617 :			end
618 :
619 :			| g (PO.INLCOMPOSE) =
620 :			let val (t1, t2, t3) =
621 :			case ts of [a,b,c] => (lt_tyc a, lt_tyc b, lt_tyc c)
622 :			| _ => bug "unexpected type for INLCOMPOSE"
623 :
624 :			val argt = lt_tup [lt_arw(t2, t3), lt_arw(t1, t2)]
625 :
626 :			val x = mkv() and z = mkv()
627 :			val f = mkv() and g = mkv()
628 :			in FN(z, argt,
629 :			LET(f, SELECT(0,VAR z),
630 :			LET(g,SELECT(1,VAR z),
631 :			FN(x, t1, APP(VAR f,APP(VAR g,VAR x))))))
632 :			end
633 :			| g (PO.INLBEFORE) =
634 :			let val (t1, t2) =
635 :			case ts of [a,b] => (lt_tyc a, lt_tyc b)
636 :			| _ => bug "unexpected type for INLBEFORE"
637 :			val argt = lt_tup [t1, t2]
638 :			val x = mkv()
639 :			in FN(x, argt, SELECT(0,VAR x))
640 :			end
641 :	blume	1183	| g (PO.INLIGNORE) =
642 :			let val argt =
643 :			case ts of [a] => lt_tyc a
644 :			| _ => bug "unexpected type for INLIGNORE"
645 :			in FN (mkv (), argt, unitLexp)
646 :			end
647 :	monnier	16
648 :	mblume	1347	| g (PO.INLIDENTITY) =
649 :			let val argt =
650 :			case ts of [a] => lt_tyc a
651 :			| _ => bug "unexpected type for INLIDENTITY"
652 :			val v = mkv ()
653 :			in
654 :			FN (v, argt, VAR v)
655 :			end
656 :
657 :	mblume	1683	| g (PO.CVT64) = let val v = mkv () in FN (v, lt_i32pair, VAR v) end
658 :
659 :	monnier	16	| g (PO.INLSUBSCRIPTV) =
660 :			let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)
661 :			| _ => bug "unexpected ty for INLSUBV"
662 :
663 :			val seqtc = LT.tcc_vector tc1
664 :			val argt = lt_tup [lt_tyc seqtc, lt_int]
665 :
666 :			val oper = PRIM(PO.SUBSCRIPT, lt, ts)
667 :			val p = mkv() and a = mkv() and i = mkv()
668 :			val vp = VAR p and va = VAR a and vi = VAR i
669 :			in FN(p, argt,
670 :			LET(a, SELECT(0,vp),
671 :			LET(i, SELECT(1,vp),
672 :			COND(APP(cmpOp(LESSU),
673 :			RECORD[vi, APP(lenOp seqtc, va)]),
674 :			APP(oper, RECORD[va, vi]),
675 :			mkRaise(coreExn "Subscript", t1)))))
676 :			end
677 :
678 :			| g (PO.INLSUBSCRIPT) =
679 :			let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)
680 :			| _ => bug "unexpected ty for INLSUB"
681 :
682 :			val seqtc = LT.tcc_array tc1
683 :			val argt = lt_tup [lt_tyc seqtc, lt_int]
684 :
685 :			val oper = PRIM(PO.SUBSCRIPT, lt, ts)
686 :			val p = mkv() and a = mkv() and i = mkv()
687 :			val vp = VAR p and va = VAR a and vi = VAR i
688 :			in FN(p, argt,
689 :			LET(a, SELECT(0, vp),
690 :			LET(i, SELECT(1, vp),
691 :			COND(APP(cmpOp(LESSU),
692 :			RECORD[vi, APP(lenOp seqtc, va)]),
693 :			APP(oper, RECORD[va, vi]),
694 :			mkRaise(coreExn "Subscript", t1)))))
695 :			end
696 :
697 :			| g (PO.NUMSUBSCRIPT{kind,checked=true,immutable}) =
698 :			let val (tc1, t1, t2) =
699 :			case ts of [a,b] => (a, lt_tyc a, lt_tyc b)
700 :			| _ => bug "unexpected type for NUMSUB"
701 :
702 :			val argt = lt_tup [t1, lt_int]
703 :			val p = mkv() and a = mkv() and i = mkv()
704 :			val vp = VAR p and va = VAR a and vi = VAR i
705 :			val oper = PO.NUMSUBSCRIPT{kind=kind,checked=false,
706 :			immutable=immutable}
707 :			val oper' = PRIM(oper, lt, ts)
708 :			in FN(p, argt,
709 :			LET(a, SELECT(0, vp),
710 :			LET(i, SELECT(1, vp),
711 :			COND(APP(cmpOp(LESSU), RECORD[vi,
712 :			APP(lenOp tc1, va)]),
713 :			APP(oper', RECORD [va, vi]),
714 :			mkRaise(coreExn "Subscript", t2)))))
715 :			end
716 :
717 :			| g (PO.INLUPDATE) =
718 :			let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)
719 :			| _ => bug "unexpected ty for INLSUB"
720 :
721 :			val seqtc = LT.tcc_array tc1
722 :			val argt = lt_tup [lt_tyc seqtc, lt_int, t1]
723 :
724 :			val oper = PRIM(PO.UPDATE, lt, ts)
725 :			val x = mkv() and a = mkv() and i = mkv() and v = mkv()
726 :			val vx = VAR x and va = VAR a and vi = VAR i and vv = VAR v
727 :
728 :			in FN(x, argt,
729 :			LET(a, SELECT(0, vx),
730 :			LET(i, SELECT(1, vx),
731 :			LET(v, SELECT(2, vx),
732 :			COND(APP(cmpOp(LESSU),
733 :			RECORD[vi,APP(lenOp seqtc, va)]),
734 :			APP(oper, RECORD[va,vi,vv]),
735 :	monnier	45	mkRaise(coreExn "Subscript", LT.ltc_unit))))))
736 :	monnier	16	end
737 :
738 :			| g (PO.NUMUPDATE{kind,checked=true}) =
739 :			let val (tc1, t1, t2) =
740 :			case ts of [a,b] => (a, lt_tyc a, lt_tyc b)
741 :			| _ => bug "unexpected type for NUMUPDATE"
742 :
743 :			val argt = lt_tup [t1, lt_int, t2]
744 :
745 :			val p=mkv() and a=mkv() and i=mkv() and v=mkv()
746 :			val vp=VAR p and va=VAR a and vi=VAR i and vv=VAR v
747 :
748 :			val oper = PO.NUMUPDATE{kind=kind,checked=false}
749 :			val oper' = PRIM(oper, lt, ts)
750 :			in FN(p, argt,
751 :			LET(a, SELECT(0, vp),
752 :			LET(i, SELECT(1, vp),
753 :			LET(v, SELECT(2, vp),
754 :			COND(APP(cmpOp(LESSU),
755 :			RECORD[vi,APP(lenOp tc1, va)]),
756 :			APP(oper', RECORD[va,vi,vv]),
757 :	monnier	45	mkRaise(coreExn "Subscript", LT.ltc_unit))))))
758 :	monnier	16	end
759 :
760 :	monnier	251	(**** ASSIGN(r, x) <> UPDATE(r, 0, x) under new array reps (JHR;1998-10-30)
761 :	monnier	16	| g (PO.ASSIGN) =
762 :			let val (tc1, t1) = case ts of [z] => (z, lt_tyc z)
763 :			| _ => bug "unexpected ty for ASSIGN"
764 :
765 :			val seqtc = LT.tcc_ref tc1
766 :			val argt = lt_tup [lt_tyc seqtc, t1]
767 :
768 :			val oper = PRIM(PO.UPDATE, lt_upd, [tc1])
769 :
770 :			val x = mkv()
771 :			val varX = VAR x
772 :
773 :			in FN(x, argt,
774 :			APP(oper, RECORD[SELECT(0, varX), INT 0, SELECT(1, varX)]))
775 :			end
776 :	monnier	251	****)
777 :	monnier	16
778 :	mblume	1347	(* Precision-conversion operations involving IntInf.
779 :			* These need to be translated specially by providing
780 :			* a second argument -- the routine from _Core that
781 :			* does the actual conversion to or from IntInf. *)
782 :
783 :			| g (p as PO.TEST_INF prec) =
784 :			inl_infPrec ("TEST_INF", "testInf", p, lt, true)
785 :			| g (p as PO.TRUNC_INF prec) =
786 :			inl_infPrec ("TRUNC_INF", "truncInf", p, lt, true)
787 :			| g (p as PO.EXTEND_INF prec) =
788 :			inl_infPrec ("EXTEND_INF", "finToInf", p, lt, false)
789 :			| g (p as PO.COPY_INF prec) =
790 :			inl_infPrec ("COPY", "finToInf", p, lt, false)
791 :
792 :			(* default handling for all other primops *)
793 :	monnier	16	| g p = PRIM(p, lt, ts)
794 :
795 :			in g prim
796 :			end (* function transPrim *)
797 :
798 :	mblume	1347	fun genintinfswitch (sv, cases, default) = let
799 :			val v = mkv ()
800 :
801 :			(* build a chain of equality tests for checking large pattern values *)
802 :			fun build [] = default
803 :			| build ((n, e) :: r) =
804 :			COND (APP (#getIntInfEq eqDict (), RECORD [VAR v, VAR (getII n)]),
805 :			e, build r)
806 :
807 :			(* split pattern values into small values and large values;
808 :			* small values can be handled directly using SWITCH *)
809 :			fun split ([], s, l) = (rev s, rev l)
810 :			| split ((n, e) :: r, sm, lg) =
811 :			(case LN.lowVal n of
812 :			SOME l => split (r, (INTcon l, e) :: sm, lg)
813 :			| NONE => split (r, sm, (n, e) :: lg))
814 :
815 :			fun gen () =
816 :			case split (cases, [], []) of
817 :			([], largeints) => build largeints
818 :			| (smallints, largeints) => let
819 :			val iv = mkv ()
820 :			in
821 :			LET (iv, APP (coreAcc "infLowValue", VAR v),
822 :			SWITCH (VAR iv,
823 :			DA.CNIL, smallints, SOME (build largeints)))
824 :			end
825 :			in
826 :			LET (v, sv, gen ())
827 :			end
828 :
829 :
830 :	monnier	16	(***************************************************************************
831 :			* *
832 :			* Translating various bindings into lambda expressions: *
833 :			* *
834 :			* val mkVar : V.var * DI.depth -> L.lexp *
835 :			* val mkVE : V.var * T.ty list -> L.lexp *
836 :			* val mkCE : T.datacon * T.ty list * L.lexp option * DI.depth -> L.lexp *
837 :			* val mkStr : M.Structure * DI.depth -> L.lexp *
838 :			* val mkFct : M.Functor * DI.depth -> L.lexp *
839 :			* val mkBnd : DI.depth -> B.binding -> L.lexp *
840 :			* *
841 :			***************************************************************************)
842 :	macqueen	1967	(* [KM???] mkVar is calling mkAccInfo, which just drops the prim!!! *)
843 :	macqueen	1961	fun mkVar (v as V.VALvar{access, prim, typ, path}, d) =
844 :			mkAccInfo(access, prim, fn () => toLty d (!typ), getNameOp path)
845 :	monnier	16	| mkVar _ = bug "unexpected vars in mkVar"
846 :
847 :	macqueen	1970	(* mkVE : V.var * type list * depth -> lexp
848 :			* This translates a variable, which might be bound to a primop.
849 :			* In the case of a primop variable, this function reconstructs the
850 :			* type parameters of instantiation of the intrinsic primop type relative
851 :			* to the variable occurrence type *)
852 :			fun mkVE (V.VALvar { typ, prim = PrimOpId.Prim p, ... }, ts, d) =
853 :			let val occty = (* compute the occurrence type of the variable *)
854 :			case ts
855 :			of [] => !typ
856 :			| _ => TU.applyPoly(!typ, ts)
857 :			val (primop,intrinsicType) =
858 :	macqueen	1976	case (PrimOpMap.primopMap p, PrimOpTypeMap.primopTypeMap p)
859 :			of (SOME p, SOME t) => (p,t)
860 :			| _ => bug "mkVE: unrecognized primop name"
861 :	macqueen	1970	val intrinsicParams =
862 :			(* compute intrinsic instantiation params of intrinsicType *)
863 :	georgekuan	1971	case ((TU.matchInstTypes(occty,intrinsicType)) : (TP.tyvar list * TP.tyvar list) option )
864 :	macqueen	1970	of SOME(_,tvs) => map TU.pruneTyvar tvs
865 :	georgekuan	1971	| NONE => bug "primop intrinsic type doesn't match occurence type"
866 :	macqueen	1970	in case (primop, intrinsicParams)
867 :			of (PO.POLYEQL, [t]) => eqGen(intrinsicType, t, toTcLt d)
868 :			| (PO.POLYNEQ, [t]) =>
869 :			composeNOT(eqGen(intrinsicType, t, toTcLt d), toLty d t)
870 :			| (PO.INLMKARRAY, [t]) =>
871 :			let val dict =
872 :			{default = coreAcc "mkNormArray",
873 :			table = [([LT.tcc_real], coreAcc "mkRealArray")]}
874 :			in GENOP (dict, primop, toLty d intrinsicType,
875 :			map (toTyc d) intrinsicParams)
876 :			end
877 :			| (PO.RAW_CCALL NONE, [a, b, c]) =>
878 :			let val i = SOME (CProto.decode cproto_conv
879 :			{ fun_ty = a, encoding = b })
880 :			handle CProto.BadEncoding => NONE
881 :			in PRIM (PO.RAW_CCALL i, toLty d intrinsicType,
882 :			map (toTyc d) intrinsicParams)
883 :			end
884 :			| _ => transPrim(primop, (toLty d intrinsicType),
885 :			map (toTyc d) intrinsicParams)
886 :			end
887 :	georgekuan	1971	| mkVE (v as V.VALvar{typ, prim = PrimOpId.NonPrim, ... }, ts, d) =
888 :	macqueen	1970	(* non primop variable *)
889 :			(case ts
890 :			of [] => mkVar (v, d)
891 :			| _ => TAPP(mkVar(v, d), map (toTyc d) ts))
892 :			(* dbm: when does this second case occur? *)
893 :			| mkVE _ = bug "non VALvar passed to mkVE"
894 :	monnier	16
895 :	macqueen	1970
896 :	monnier	16	fun mkCE (TP.DATACON{const, rep, name, typ, ...}, ts, apOp, d) =
897 :			let val lt = toDconLty d typ
898 :	monnier	100	val rep' = mkRep(rep, lt, name)
899 :	monnier	16	val dc = (name, rep', lt)
900 :	macqueen	1970	val ts' = map (toTyc d o TP.VARty) ts
901 :	monnier	16	in if const then CON'(dc, ts', unitLexp)
902 :			else (case apOp
903 :			of SOME le => CON'(dc, ts', le)
904 :			| NONE =>
905 :			let val (argT, _) = LT.ltd_parrow(LT.lt_pinst(lt, ts'))
906 :			val v = mkv()
907 :			in FN(v, argT, CON'(dc, ts', VAR v))
908 :			end)
909 :			end
910 :
911 :	georgekuan	1971	fun mkStr (s as M.STR { access, prim, ... }, d) =
912 :			mkAccInfo(access, prim, fn () => strLty(s, d, compInfo), NONE)
913 :	monnier	16	| mkStr _ = bug "unexpected structures in mkStr"
914 :
915 :	georgekuan	1971	fun mkFct (f as M.FCT { access, prim, ... }, d) =
916 :			mkAccInfo(access, prim, fn () => fctLty(f, d, compInfo), NONE)
917 :	monnier	16	| mkFct _ = bug "unexpected functors in mkFct"
918 :
919 :			fun mkBnd d =
920 :			let fun g (B.VALbind v) = mkVar(v, d)
921 :			| g (B.STRbind s) = mkStr(s, d)
922 :			| g (B.FCTbind f) = mkFct(f, d)
923 :	monnier	100	| g (B.CONbind (TP.DATACON{rep=(DA.EXN acc), name, typ, ...})) =
924 :	blume	587	let val nt = toDconLty d typ
925 :			val (argt,_) = LT.ltd_parrow nt
926 :			in mkAccT (acc, LT.ltc_etag argt, SOME name)
927 :			end
928 :	monnier	16	| g _ = bug "unexpected bindings in mkBnd"
929 :			in g
930 :			end
931 :
932 :
933 :			(***************************************************************************
934 :			* *
935 :			* Translating core absyn declarations into lambda expressions: *
936 :			* *
937 :	macqueen	1970	* val mkVBs : Absyn.vb list * depth -> PLambda.lexp -> PLambda.lexp *
938 :			* val mkRVBs : Absyn.rvb list * depth -> PLambda.lexp -> PLambda.lexp *
939 :			* val mkEBs : Absyn.eb list * depth -> PLambda.lexp -> PLambda.lexp *
940 :	monnier	16	* *
941 :			***************************************************************************)
942 :	macqueen	1970
943 :			(* mkPE : Absyn.exp * depth * Types.tyvar list -> PLambda.lexp
944 :			* translate an expression with potential type parameters *)
945 :	monnier	16	fun mkPE (exp, d, []) = mkExp(exp, d)
946 :			| mkPE (exp, d, boundtvs) =
947 :			let val savedtvs = map ! boundtvs
948 :	macqueen	1970	(* save original contents of boundtvs for later restoration
949 :			* by the restore function below *)
950 :	monnier	16
951 :	macqueen	1970	fun setbtvs (i, []) = ()
952 :			| setbtvs (i, (tv as ref (TP.OPEN _))::rest) =
953 :			let val m = markLBOUND (d, i)
954 :			in tv := TP.TV_MARK m;
955 :			setbtvs (i+1, rest)
956 :			end
957 :			| setbtvs (i, (tv as ref (TP.TV_MARK _))::res) =
958 :			bug ("unexpected tyvar TV_MARK in mkPE")
959 :			| setbtvs _ = bug "unexpected tyvar INSTANTIATED in mkPE"
960 :	monnier	16
961 :	macqueen	1970	val _ = setbtvs(0, boundtvs)
962 :			(* assign TV_MARKs to the boundtvs to mark them as type
963 :			* parameter variables during translation of exp *)
964 :
965 :	monnier	16	val exp' = mkExp(exp, DI.next d)
966 :	macqueen	1970	(* increase the depth to indicate that the expression is
967 :			* going to be wrapped by a type abstraction (TFN) *)
968 :	monnier	16
969 :	macqueen	1970	(* restore tyvar states to that before the translation *)
970 :	macqueen	1967	fun restore ([], []) = ()
971 :			| restore (a::r, b::z) = (b := a; restore(r, z))
972 :			| restore _ = bug "unexpected cases in mkPE"
973 :	monnier	16
974 :	macqueen	1948	(* [dbm, 6/22/06] Why do we need to restore the original
975 :	macqueen	1967	contents of the uninstantiated meta type variables?
976 :			Only seems to be necessary if a given tyvar gets generalized
977 :	macqueen	1970	in two different valbinds. We assume that this does not
978 :			happen (Single Generalization Conjecture) *)
979 :	macqueen	1948
980 :	macqueen	1967	val _ = restore(savedtvs, boundtvs)
981 :	monnier	16	val len = length(boundtvs)
982 :
983 :			in TFN(LT.tkc_arg(len), exp')
984 :			end
985 :
986 :			and mkVBs (vbs, d) =
987 :	macqueen	1970	let fun mkVB (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),
988 :			exp as VARexp (ref (w as (V.VALvar{typ,prim,...})), instvs),
989 :			boundtvs=btvs, ...}, b: lexp) =
990 :	macqueen	1967	(* [dbm: 7/10/06] Originally, the mkVar and mkPE translations
991 :			* were chosen based on whether btvs and instvs were the same
992 :			* list of tyvars, which would be the case for all non-primop
993 :			* variables, but also in the primop case whenever the rhs
994 :			* variable environment type (!typ) was the same (equalTypeP)
995 :			* to the intrinsic type of the primop (e.g. when they are
996 :			* both monotypes). So in most cases, the mkVar translation
997 :			* will be used, and this drops the primop information!!!
998 :			* This seems definitely wrong. *)
999 :			(case prim
1000 :			of PrimOpId.Prim name =>
1001 :	macqueen	1976	(case PrimOpTypeMap.primopTypeMap name
1002 :			of SOME(primopty) =>
1003 :	macqueen	1970	if TU.equalTypeP(!typ,primopty)
1004 :			then LET(v, mkVar(w, d), b)
1005 :			else LET(v, mkPE(exp, d, btvs), b)
1006 :			| NONE => bug "mkVBs: unknown primop name")
1007 :	georgekuan	1968	| _ => LET(v, mkVar(w, d), b))
1008 :	macqueen	1967	(* when generalized variables = instantiation params *)
1009 :	monnier	16
1010 :	macqueen	1970	| mkVB (VB{pat=VARpat(V.VALvar{access=DA.LVAR v, ...}),
1011 :			exp, boundtvs=btvs, ...}, b) =
1012 :			LET(v, mkPE(exp, d, btvs), b)
1013 :	monnier	16
1014 :	macqueen	1970	| mkVB (VB{pat=CONSTRAINTpat(VARpat(V.VALvar{access=DA.LVAR v, ...}),_),
1015 :			exp, boundtvs=tvs, ...}, b) =
1016 :			LET(v, mkPE(exp, d, tvs), b)
1017 :	monnier	16
1018 :	macqueen	1970	| mkVB (VB{pat, exp, boundtvs=tvs, ...}, b) =
1019 :			let val ee = mkPE(exp, d, tvs)
1020 :			val rules = [(fillPat(pat, d), b), (WILDpat, unitLexp)]
1021 :			val rootv = mkv()
1022 :			fun finish x = LET(rootv, ee, x)
1023 :			in MC.bindCompile(env, rules, finish, rootv, toTcLt d, complain,
1024 :			genintinfswitch)
1025 :			end
1026 :	monnier	16
1027 :	macqueen	1970	in fold mkVB vbs
1028 :			end (* mkVBs *)
1029 :
1030 :	monnier	16	and mkRVBs (rvbs, d) =
1031 :	macqueen	1970	let fun mkRVB (RVB{var=V.VALvar{access=DA.LVAR v, typ=ref ty, ...},
1032 :			exp, boundtvs=btvs, ...}, (vlist, tlist, elist)) =
1033 :			let val ee = mkExp(exp, d) (* was mkPE(exp, d, btvs) *)
1034 :			(* [ZHONG?] we no longer track type bindings at RVB anymore ! *)
1035 :			val vt = toLty d ty
1036 :			in (v::vlist, vt::tlist, ee::elist)
1037 :			end
1038 :			| mkRVB _ = bug "unexpected valrec bindings in mkRVBs"
1039 :	monnier	16
1040 :	macqueen	1970	val (vlist, tlist, elist) = foldr mkRVB ([], [], []) rvbs
1041 :	monnier	16
1042 :			in fn b => FIX(vlist, tlist, elist, b)
1043 :			end
1044 :
1045 :			and mkEBs (ebs, d) =
1046 :			let fun g (EBgen {exn=TP.DATACON{rep=DA.EXN(DA.LVAR v), typ, ...},
1047 :			ident, ...}, b) =
1048 :			let val nt = toDconLty d typ
1049 :			val (argt, _) = LT.ltd_parrow nt
1050 :			in LET(v, ETAG(mkExp(ident, d), argt), b)
1051 :			end
1052 :	monnier	100	| g (EBdef {exn=TP.DATACON{rep=DA.EXN(DA.LVAR v), typ, name, ...},
1053 :	monnier	16	edef=TP.DATACON{rep=DA.EXN(acc), ...}}, b) =
1054 :			let val nt = toDconLty d typ
1055 :			val (argt, _) = LT.ltd_parrow nt
1056 :	monnier	100	in LET(v, mkAccT(acc, LT.ltc_etag argt, SOME name), b)
1057 :	monnier	16	end
1058 :			| g _ = bug "unexpected exn bindings in mkEBs"
1059 :
1060 :			in fold g ebs
1061 :			end
1062 :
1063 :
1064 :			(***************************************************************************
1065 :			* *
1066 :			* Translating module exprs and decls into lambda expressions: *
1067 :			* *
1068 :	macqueen	1970	* val mkStrexp : Absyn.strexp * depth -> PLambda.lexp *
1069 :			* val mkFctexp : Absyn.fctexp * depth -> PLambda.lexp *
1070 :			* val mkStrbs : Absyn.strb list * depth -> PLambda.lexp -> PLambda.lexp *
1071 :			* val mkFctbs : Absyn.fctb list * depth -> PLambda.lexp -> PLambda.lexp *
1072 :	monnier	16	* *
1073 :			***************************************************************************)
1074 :			and mkStrexp (se, d) =
1075 :			let fun g (VARstr s) = mkStr(s, d)
1076 :			| g (STRstr bs) = SRECORD (map (mkBnd d) bs)
1077 :			| g (APPstr {oper, arg, argtycs}) =
1078 :			let val e1 = mkFct(oper, d)
1079 :	monnier	45	val tycs = map (tpsTyc d) argtycs
1080 :	monnier	16	val e2 = mkStr(arg, d)
1081 :			in APP(TAPP(e1, tycs), e2)
1082 :			end
1083 :			| g (LETstr (dec, b)) = mkDec (dec, d) (g b)
1084 :			| g (MARKstr (b, reg)) = withRegion reg g b
1085 :
1086 :			in g se
1087 :			end
1088 :
1089 :			and mkFctexp (fe, d) =
1090 :			let fun g (VARfct f) = mkFct(f, d)
1091 :	blume	587	| g (FCTfct {param as M.STR { access, ... }, argtycs, def }) =
1092 :			(case access of
1093 :			DA.LVAR v =>
1094 :			let val knds = map tpsKnd argtycs
1095 :			val nd = DI.next d
1096 :			val body = mkStrexp (def, nd)
1097 :			val hdr = buildHdr v
1098 :			(* binding of all v's components *)
1099 :			in
1100 :			TFN(knds, FN(v, strLty(param, nd, compInfo), hdr body))
1101 :			end
1102 :			| _ => bug "mkFctexp: unexpected access")
1103 :	monnier	16	| g (LETfct (dec, b)) = mkDec (dec, d) (g b)
1104 :			| g (MARKfct (b, reg)) = withRegion reg g b
1105 :			| g _ = bug "unexpected functor expressions in mkFctexp"
1106 :
1107 :			in g fe
1108 :			end
1109 :
1110 :			and mkStrbs (sbs, d) =
1111 :	blume	587	let fun g (STRB{str=M.STR { access, ... }, def, ... }, b) =
1112 :			(case access of
1113 :			DA.LVAR v =>
1114 :	monnier	16	let val hdr = buildHdr v
1115 :	blume	587	(* binding of all v's components *)
1116 :			in
1117 :			LET(v, mkStrexp(def, d), hdr b)
1118 :	monnier	16	end
1119 :	blume	587	| _ => bug "mkStrbs: unexpected access")
1120 :	monnier	16	| g _ = bug "unexpected structure bindings in mkStrbs"
1121 :	blume	587	in fold g sbs
1122 :	monnier	16	end
1123 :
1124 :			and mkFctbs (fbs, d) =
1125 :	blume	587	let fun g (FCTB{fct=M.FCT { access, ... }, def, ... }, b) =
1126 :			(case access of
1127 :			DA.LVAR v =>
1128 :	monnier	16	let val hdr = buildHdr v
1129 :	blume	587	in
1130 :			LET(v, mkFctexp(def, d), hdr b)
1131 :	monnier	16	end
1132 :	blume	587	| _ => bug "mkFctbs: unexpected access")
1133 :	monnier	16	| g _ = bug "unexpected functor bindings in mkStrbs"
1134 :	blume	587	in fold g fbs
1135 :	monnier	16	end
1136 :
1137 :
1138 :			(***************************************************************************
1139 :			* Translating absyn decls and exprs into lambda expression: *
1140 :			* *
1141 :	macqueen	1970	* val mkExp : A.exp * DI.depth -> PLambda.lexp *
1142 :			* val mkDec : A.dec * DI.depth -> PLambda.lexp -> PLambda.lexp *
1143 :	monnier	16	* *
1144 :			***************************************************************************)
1145 :			and mkDec (dec, d) =
1146 :			let fun g (VALdec vbs) = mkVBs(vbs, d)
1147 :			| g (VALRECdec rvbs) = mkRVBs(rvbs, d)
1148 :			| g (ABSTYPEdec{body,...}) = g body
1149 :			| g (EXCEPTIONdec ebs) = mkEBs(ebs, d)
1150 :			| g (STRdec sbs) = mkStrbs(sbs, d)
1151 :			| g (ABSdec sbs) = mkStrbs(sbs, d)
1152 :			| g (FCTdec fbs) = mkFctbs(fbs, d)
1153 :			| g (LOCALdec(ld, vd)) = (g ld) o (g vd)
1154 :			| g (SEQdec ds) = foldr (op o) ident (map g ds)
1155 :			| g (MARKdec(x, reg)) =
1156 :			let val f = withRegion reg g x
1157 :			in fn y => withRegion reg f y
1158 :			end
1159 :	monnier	100	| g (OPENdec xs) =
1160 :			let (* special hack to make the import tree simpler *)
1161 :	blume	587	fun mkos (_, s as M.STR { access = acc, ... }) =
1162 :			if extern acc then
1163 :	monnier	100	let val _ = mkAccT(acc, strLty(s, d, compInfo), NONE)
1164 :	blume	587	in ()
1165 :	monnier	100	end
1166 :	blume	587	else ()
1167 :	monnier	100	| mkos _ = ()
1168 :			in app mkos xs; ident
1169 :			end
1170 :	monnier	16	| g _ = ident
1171 :			in g dec
1172 :			end
1173 :
1174 :			and mkExp (exp, d) =
1175 :	monnier	45	let val tTyc = toTyc d
1176 :			val tLty = toLty d
1177 :	monnier	16
1178 :			fun mkRules xs = map (fn (RULE(p, e)) => (fillPat(p, d), g e)) xs
1179 :
1180 :	macqueen	1967	and g (VARexp (ref v, ts)) =
1181 :	macqueen	1970	mkVE(v, map TP.VARty ts, d)
1182 :	monnier	16
1183 :	georgekuan	1974	| g (CONexp (dc, ts)) = (let val _ = print "mkExp CONexp: "
1184 :			val c = mkCE(dc, ts, NONE, d)
1185 :			val _ = PPLexp.printLexp c
1186 :			in c end)
1187 :			| g (APPexp (CONexp(dc, ts), e2)) = (let val _ = print "mkExp APPexp: "
1188 :			val c = mkCE(dc, ts, SOME(g e2), d)
1189 :			val _ = PPLexp.printLexp c
1190 :			in c end)
1191 :	monnier	16	| g (INTexp (s, t)) =
1192 :			((if TU.equalType (t, BT.intTy) then INT (LN.int s)
1193 :			else if TU.equalType (t, BT.int32Ty) then INT32 (LN.int32 s)
1194 :	mblume	1347	else if TU.equalType (t, BT.intinfTy) then VAR (getII s)
1195 :	mblume	1682	else if TU.equalType (t, BT.int64Ty) then
1196 :			let val (hi, lo) = LN.int64 s
1197 :			in RECORD [WORD32 hi, WORD32 lo]
1198 :			end
1199 :	mblume	1347	else bug "translate INTexp")
1200 :			handle Overflow => (repErr "int constant too large"; INT 0))
1201 :	monnier	16
1202 :			| g (WORDexp(s, t)) =
1203 :			((if TU.equalType (t, BT.wordTy) then WORD (LN.word s)
1204 :	mblume	1682	else if TU.equalType (t, BT.word8Ty) then WORD (LN.word8 s)
1205 :			else if TU.equalType (t, BT.word32Ty) then WORD32 (LN.word32 s)
1206 :			else if TU.equalType (t, BT.word64Ty) then
1207 :			let val (hi, lo) = LN.word64 s
1208 :			in RECORD [WORD32 hi, WORD32 lo]
1209 :			end
1210 :			else (ppType t; bug "translate WORDexp"))
1211 :	monnier	16	handle Overflow => (repErr "word constant too large"; INT 0))
1212 :
1213 :			| g (REALexp s) = REAL s
1214 :			| g (STRINGexp s) = STRING s
1215 :			| g (CHARexp s) = INT (Char.ord(String.sub(s, 0)))
1216 :			(** NOTE: the above won't work for cross compiling to
1217 :			multi-byte characters **)
1218 :
1219 :	monnier	45	| g (RECORDexp []) = unitLexp
1220 :	monnier	16	| g (RECORDexp xs) =
1221 :			if sorted xs then RECORD (map (fn (_,e) => g e) xs)
1222 :			else let val vars = map (fn (l,e) => (l,(g e, mkv()))) xs
1223 :			fun bind ((_,(e,v)),x) = LET(v,e,x)
1224 :			val bexp = map (fn (_,(_,v)) => VAR v) (sortrec vars)
1225 :			in foldr bind (RECORD bexp) vars
1226 :			end
1227 :
1228 :			| g (SELECTexp (LABEL{number=i,...}, e)) = SELECT(i, g e)
1229 :
1230 :			| g (VECTORexp ([], ty)) =
1231 :			TAPP(coreAcc "vector0", [tTyc ty])
1232 :			| g (VECTORexp (xs, ty)) =
1233 :			let val tc = tTyc ty
1234 :			val vars = map (fn e => (g e, mkv())) xs
1235 :			fun bind ((e,v),x) = LET(v, e, x)
1236 :			val bexp = map (fn (_,v) => VAR v) vars
1237 :			in foldr bind (VECTOR (bexp, tc)) vars
1238 :			end
1239 :
1240 :			| g (PACKexp(e, ty, tycs)) = g e
1241 :	macqueen	1967	(* [dbm, 7/10/06]: Does PACKexp do anything now? What was it doing before
1242 :			* this was commented out? This appears to be the only place reformat was called
1243 :			* Is it also the only place the FLINT PACK constructor is used? [KM???] *)
1244 :	macqueen	1970	(* (commented out by whom, when why?)
1245 :	monnier	16	let val (nty, ks, tps) = TU.reformat(ty, tycs, d)
1246 :	monnier	45	val ts = map (tpsTyc d) tps
1247 :	monnier	16	(** use of LtyEnv.tcAbs is a temporary hack (ZHONG) **)
1248 :			val nts = ListPair.map LtyEnv.tcAbs (ts, ks)
1249 :			val nd = DI.next d
1250 :			in case (ks, tps)
1251 :			of ([], []) => g e
1252 :	monnier	45	| _ => PACK(LT.ltc_poly(ks, [toLty nd nty]),
1253 :			ts, nts , g e)
1254 :	monnier	16	end
1255 :			*)
1256 :			| g (SEQexp [e]) = g e
1257 :			| g (SEQexp (e::r)) = LET(mkv(), g e, g (SEQexp r))
1258 :
1259 :			| g (APPexp (e1, e2)) = APP(g e1, g e2)
1260 :			| g (MARKexp (e, reg)) = withRegion reg g e
1261 :			| g (CONSTRAINTexp (e,_)) = g e
1262 :
1263 :			| g (RAISEexp (e, ty)) = mkRaise(g e, tLty ty)
1264 :	mblume	1641	| g (HANDLEexp (e, (l, ty))) =
1265 :	monnier	16	let val rootv = mkv()
1266 :			fun f x = FN(rootv, tLty ty, x)
1267 :			val l' = mkRules l
1268 :	monnier	45	in HANDLE(g e, MC.handCompile(env, l', f,
1269 :	mblume	1347	rootv, toTcLt d, complain,
1270 :			genintinfswitch))
1271 :	monnier	16	end
1272 :
1273 :			| g (FNexp (l, ty)) =
1274 :			let val rootv = mkv()
1275 :			fun f x = FN(rootv, tLty ty, x)
1276 :	mblume	1347	in MC.matchCompile (env, mkRules l, f, rootv, toTcLt d,
1277 :			complain, genintinfswitch)
1278 :	monnier	16	end
1279 :
1280 :			| g (CASEexp (ee, l, isMatch)) =
1281 :			let val rootv = mkv()
1282 :			val ee' = g ee
1283 :			fun f x = LET(rootv, ee', x)
1284 :			val l' = mkRules l
1285 :			in if isMatch
1286 :	mblume	1347	then MC.matchCompile (env, l', f, rootv, toTcLt d,
1287 :			complain, genintinfswitch)
1288 :			else MC.bindCompile (env, l', f, rootv, toTcLt d,
1289 :			complain, genintinfswitch)
1290 :	monnier	16	end
1291 :
1292 :	mblume	1332	| g (IFexp { test, thenCase, elseCase }) =
1293 :			COND (g test, g thenCase, g elseCase)
1294 :
1295 :			| g (ANDALSOexp (e1, e2)) =
1296 :			COND (g e1, g e2, falseLexp)
1297 :
1298 :			| g (ORELSEexp (e1, e2)) =
1299 :			COND (g e1, trueLexp, g e2)
1300 :
1301 :			| g (WHILEexp { test, expr }) =
1302 :			let val fv = mkv ()
1303 :			val body =
1304 :			FN (mkv (), lt_unit,
1305 :			COND (g test,
1306 :			LET (mkv (), g expr, APP (VAR fv, unitLexp)),
1307 :			unitLexp))
1308 :			in
1309 :			FIX ([fv], [lt_u_u], [body], APP (VAR fv, unitLexp))
1310 :			end
1311 :
1312 :	monnier	16	| g (LETexp (dc, e)) = mkDec (dc, d) (g e)
1313 :
1314 :			| g e =
1315 :			EM.impossibleWithBody "untranslateable expression"
1316 :	macqueen	1344	(fn ppstrm => (PP.string ppstrm " expression: ";
1317 :	monnier	16	PPAbsyn.ppExp (env,NONE) ppstrm (e, !ppDepth)))
1318 :
1319 :			in g exp
1320 :			end
1321 :
1322 :	mblume	1347	and transIntInf d s =
1323 :			(* This is a temporary solution. Since IntInf literals
1324 :			* are created using a core function call, there is
1325 :			* no indication within the program that we are really
1326 :			* dealing with a constant value that -- in principle --
1327 :			* could be subject to such things as constant folding. *)
1328 :	georgekuan	1971	let val consexp = CONexp (BT.consDcon, [ref (TP.INSTANTIATED BT.wordTy)])
1329 :			fun build [] = CONexp (BT.nilDcon, [ref (TP.INSTANTIATED BT.wordTy)])
1330 :	mblume	1347	| build (d :: ds) = let
1331 :			val i = Word.toIntX d
1332 :			in
1333 :			APPexp (consexp,
1334 :			EU.TUPLEexp [WORDexp (IntInf.fromInt i, BT.wordTy),
1335 :			build ds])
1336 :			end
1337 :			fun small w =
1338 :			APP (coreAcc (if LN.isNegative s then "makeSmallNegInf"
1339 :			else "makeSmallPosInf"),
1340 :			mkExp (WORDexp (IntInf.fromInt (Word.toIntX w), BT.wordTy),
1341 :			d))
1342 :			in
1343 :			case LN.repDigits s of
1344 :			[] => small 0w0
1345 :			| [w] => small w
1346 :			| ws => APP (coreAcc (if LN.isNegative s then "makeNegInf"
1347 :			else "makePosInf"),
1348 :			mkExp (build ws, d))
1349 :			end
1350 :	monnier	16
1351 :	mblume	1347	(* Wrap bindings for IntInf.int literals around body. *)
1352 :			fun wrapII body = let
1353 :			fun one (n, v, b) = LET (v, transIntInf DI.top n, b)
1354 :			in
1355 :			IIMap.foldli one body (!iimap)
1356 :			end
1357 :
1358 :	monnier	100	(* wrapPidInfo: lexp * (pid * pidInfo) list -> lexp * importTree *)
1359 :			fun wrapPidInfo (body, pidinfos) =
1360 :			let val imports =
1361 :			let fun p2itree (ANON xl) =
1362 :	blume	879	ImportTree.ITNODE (map (fn (i,z) => (i, p2itree z)) xl)
1363 :			| p2itree (NAMED _) = ImportTree.ITNODE []
1364 :	monnier	100	in map (fn (p, pi) => (p, p2itree pi)) pidinfos
1365 :			end
1366 :			(*
1367 :			val _ = let val _ = say "\n ****************** \n"
1368 :			val _ = say "\n the current import tree is :\n"
1369 :	blume	879	fun tree (ImportTree.ITNODE []) = ["\n"]
1370 :			| tree (ImportTree.ITNODE xl) =
1371 :	monnier	100	foldr (fn ((i, x), z) =>
1372 :			let val ts = tree x
1373 :			val u = (Int.toString i) ^ " "
1374 :			in (map (fn y => (u ^ y)) ts) @ z
1375 :			end) [] xl
1376 :			fun pp (p, n) =
1377 :			(say ("Pid " ^ (PersStamps.toHex p) ^ "\n");
1378 :			app say (tree n))
1379 :			in app pp imports; say "\n ****************** \n"
1380 :			end
1381 :			*)
1382 :			val plexp =
1383 :			let fun get ((_, ANON xl), z) = foldl get z xl
1384 :			| get ((_, u as NAMED (_,t,_)), (n,cs,ts)) =
1385 :			(n+1, (n,u)::cs, t::ts)
1386 :	monnier	16
1387 :	monnier	100	(* get the fringe information *)
1388 :			val getp = fn ((_, pi), z) => get((0, pi), z)
1389 :			val (finfos, lts) =
1390 :			let val (_, fx, lx) = foldl getp (0,[],[]) pidinfos
1391 :			in (rev fx, rev lx)
1392 :			end
1393 :	monnier	16
1394 :	monnier	100	(* do the selection of all import variables *)
1395 :			fun mksel (u, xl, be) =
1396 :			let fun g ((i, pi), be) =
1397 :			let val (v, xs) = case pi of ANON z => (mkv(), z)
1398 :			| NAMED(v,_,z) => (v, z)
1399 :			in LET(v, SELECT(i, u), mksel(VAR v, xs, be))
1400 :			end
1401 :			in foldr g be xl
1402 :			end
1403 :			val impvar = mkv()
1404 :			val implty = LT.ltc_str lts
1405 :			val nbody = mksel (VAR impvar, finfos, body)
1406 :			in FN(impvar, implty, nbody)
1407 :			end
1408 :			in (plexp, imports)
1409 :			end (* function wrapPidInfo *)
1410 :	monnier	16
1411 :	monnier	100	(** the list of things being exported from the current compilation unit *)
1412 :	monnier	16	val exportLexp = SRECORD (map VAR exportLvars)
1413 :
1414 :	monnier	100	(** translating the ML absyn into the PLambda expression *)
1415 :			val body = mkDec (rootdec, DI.top) exportLexp
1416 :
1417 :	mblume	1347	(** add bindings for intinf constants *)
1418 :			val body = wrapII body
1419 :
1420 :	monnier	100	(** wrapping up the body with the imported variables *)
1421 :	mblume	1347	val (plexp, imports) = wrapPidInfo (body, PersMap.listItemsi (!persmap))
1422 :	monnier	100
1423 :			fun prGen (flag,printE) s e =
1424 :			if !flag then (say ("\n\n[After " ^ s ^ " ...]\n\n"); printE e) else ()
1425 :	monnier	122	val _ = prGen(Control.FLINT.print, PPLexp.printLexp) "Translate" plexp
1426 :	monnier	100
1427 :			(** normalizing the plambda expression into FLINT *)
1428 :	georgekuan	1974	val flint = let val _ = print "prenorm\n"
1429 :			val n = FlintNM.norm plexp
1430 :			val _ = print "postnorm\n"
1431 :			in n end
1432 :	monnier	100
1433 :			in {flint = flint, imports = imports}
1434 :	monnier	16	end (* function transDec *)
1435 :
1436 :			end (* top-level local *)
1437 :			end (* structure Translate *)

---

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