Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/branches/primop-branch/src/compiler/Elaborator/elaborate/elabcore.sml
ViewVC logotype

Annotation of /sml/branches/primop-branch/src/compiler/Elaborator/elaborate/elabcore.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1476 - (view) (download)

1 : blume 902 (* Copyright 1996 by AT&T Bell Laboratories *)
2 :     (* elabcore.sml *)
3 :    
4 :     signature ELABCORE =
5 :     sig
6 :    
7 :     val elabABSTYPEdec :
8 :     {abstycs: Ast.db list,withtycs: Ast.tb list,body: Ast.dec}
9 :     * StaticEnv.staticEnv * ElabUtil.context * (Types.tycon -> bool)
10 :     * InvPath.path * SourceMap.region * ElabUtil.compInfo
11 :     -> Absyn.dec * StaticEnv.staticEnv (* * Modules.entityEnv ??? *)
12 :    
13 :     val elabDec :
14 :     Ast.dec * StaticEnv.staticEnv * (Types.tycon -> bool)
15 :     * InvPath.path * SourceMap.region * ElabUtil.compInfo
16 :     -> Absyn.dec * StaticEnv.staticEnv
17 :    
18 :     val debugging : bool ref
19 :    
20 :     end (* signature ELABCORE *)
21 :    
22 :    
23 :     structure ElabCore: ELABCORE =
24 :     struct
25 :    
26 :     local structure EM = ErrorMsg
27 :     structure SP = SymPath
28 :     structure IP = InvPath
29 :     structure SE = StaticEnv
30 :     structure LU = Lookup
31 :     structure V = VarCon
32 :     structure B = Bindings
33 :     structure M = Modules
34 :     structure MU = ModuleUtil
35 :     structure T = Types
36 :     structure TU = TypesUtil
37 :     structure BT = BasicTypes
38 :     structure EE = EntityEnv
39 :     structure EU = ElabUtil
40 :     structure ED = ElabDebug
41 :     structure TS = TyvarSet
42 :     structure ET = ElabType
43 :     structure S = Symbol
44 :     (* structure II = InlInfo *)
45 :     structure A = Access
46 :    
47 :     open Absyn Ast BasicTypes Access ElabUtil Types VarCon
48 :     (*
49 :     open BasicTypes Symbol Absyn Ast PrintUtil AstUtil BasicTypes TyvarSet
50 :     Types EqTypes TypesUtil Access ElabUtil
51 :     *)
52 :     in
53 :    
54 :     val say = Control_Print.say
55 :     val debugging = ref false
56 :     fun debugmsg (msg: string) = if !debugging then (say msg; say "\n") else ()
57 :     fun bug msg = ErrorMsg.impossible("ElabCore: "^msg)
58 :    
59 :     val debugPrint = (fn x => ED.debugPrint debugging x)
60 :    
61 :     fun showDec(msg,dec,env) =
62 :     (* ED.withInternals(fn () => *)
63 :     debugPrint(msg,
64 :     (fn pps => fn dec =>
65 :     PPAbsyn.ppDec (env,NONE) pps (dec, 100)),
66 :     dec)(* ) *)
67 :    
68 :     infix -->
69 :    
70 :     (* tyvarset management *)
71 :     type tyvUpdate = TS.tyvarset -> unit
72 :     val --- = TS.diffPure
73 :     val union = TS.union
74 :     val diff = TS.diff
75 :     fun no_updt (_ : TS.tyvarset) = ()
76 :     fun noTyvars (dec,env) = (dec,env,TS.empty,no_updt)
77 :     infix ++ -- ---
78 :    
79 :     fun stripExpAbs (MARKexp(e,_)) = stripExpAbs e
80 :     | stripExpAbs (CONSTRAINTexp(e,_)) = stripExpAbs e
81 :     | stripExpAbs e = e
82 :    
83 :     fun stripExpAst(MarkExp(e,r'),r) = stripExpAst(e,r')
84 :     | stripExpAst(ConstraintExp{expr=e,...},r) = stripExpAst(e,r)
85 :     | stripExpAst(SeqExp[e],r) = stripExpAst(e,r)
86 :     | stripExpAst(FlatAppExp[{item,region,...}],r) = stripExpAst(item,region)
87 :     | stripExpAst x = x
88 :    
89 :     val internalSym = SpecialSymbols.internalVarId
90 :    
91 :     val dummyFNexp =
92 : macqueen 1476 FNexp([RULE(WILDpat,RAISEexp(CONexp(V.bogusEXN,UNDEFty),UNDEFty))],UNDEFty)
93 : blume 902
94 :     (* LAZY *)
95 :     (* clauseKind: used for communicating information about lazy fun decls
96 :     between preprocessing phase (makevar) and main part of elabFUNdec *)
97 :     datatype clauseKind = STRICT | LZouter | LZinner
98 :    
99 :     (*
100 :     (* capture the ":=" and "!" VALvars from PrimEnv.primEnv
101 :     * These VALvars are used in lrvbMakeY.
102 :     * Perhaps PrimEnv should just export these VALvars. *)
103 :     val dummyComplainer = (fn _ => fn _ => fn _ => ())
104 :     val assignVar =
105 :     case LU.lookVal(PrimEnv.primEnv,SP.SPATH[S.strSymbol "InLine",S.varSymbol ":="],
106 :     dummyComplainer)
107 :     of V.VAL v => v
108 :     | _ => bug "lazy 1"
109 :     val bangVar =
110 :     case LU.lookVal(PrimEnv.primEnv,SP.SPATH[S.strSymbol "InLine",S.varSymbol "!"],
111 :     dummyComplainer)
112 :     of V.VAL v => v
113 :     | _ => bug "lazy 2"
114 : macqueen 1377 val assignExp = VARexp(ref assignVar,UNDEFty)
115 :     val bangExp = VARexp(ref bangVar,UNDEFty)
116 : blume 902 *)
117 :    
118 :     local
119 : macqueen 1377 fun mkCoreExp name env = VARexp (ref (CoreAccess.getVar(env, name)), UNDEFty)
120 : blume 902 in
121 :     val mkAssignExp = mkCoreExp "assign"
122 :     val mkBangExp = mkCoreExp "deref"
123 :     end
124 :    
125 :     (**** ABSTRACT TYPE DECLARATIONS ****)
126 :     fun elabABSTYPEdec({abstycs,withtycs,body},env,context,isFree,
127 :     rpath,region,compInfo) =
128 :     let val (datatycs,withtycs,_,env1) =
129 :     ET.elabDATATYPEdec({datatycs=abstycs,withtycs=withtycs}, env,
130 :     [], EE.empty, isFree, rpath, region, compInfo)
131 :    
132 :     val (body,env2) =
133 :     elabDec(body,SE.atop(env1,env),isFree,rpath,region,compInfo)
134 :    
135 :     (* datatycs will be changed to abstycs during type checking
136 :     by changing the eqprop field *)
137 :     fun bind (x, e) = SE.bind(TU.tycName x, B.TYCbind x, e)
138 :     val envt = foldl bind (foldl bind SE.empty datatycs) withtycs
139 :    
140 :     in (ABSTYPEdec{abstycs=datatycs,withtycs=withtycs,body=body},
141 :     SE.atop(env2,envt))
142 :     end (* function elabABSTYPEdec *)
143 :    
144 :    
145 :     (**** ELABORATE GENERAL (core) DECLARATIONS ****)
146 :     and elabDec (dec, env, isFree, rpath, region,
147 :     compInfo as {mkLvar=mkv,error,errorMatch,...}) =
148 :    
149 :     let
150 :     val _ = debugmsg ">>ElabCore.elabDec"
151 :    
152 :     val completeMatch = EU.completeMatch(env,"Match")
153 :     val _ = debugmsg "--ElabCore.elabDec << completeBind Match"
154 :     val completeBind = EU.completeMatch(env,"Bind")
155 :     val _ = debugmsg "--ElabCore.elabDec << completeBind Bind"
156 :    
157 :     fun newVALvar s = V.mkVALvar(s, A.namedAcc(s, mkv))
158 :    
159 :    
160 :     (* LAZY: utilities for lazy sml translation *)
161 :    
162 :     (* will one forcingFun do, or should new ones be generated with
163 :     * different bound variables for each use? (DBM) *)
164 :    
165 :     fun forceExp e =
166 :     let val v = newVALvar(S.varSymbol "x")
167 :     in APPexp(FNexp(completeMatch[RULE(APPpat(BT.dollarDcon,[],VARpat v),
168 : macqueen 1377 VARexp(ref v,UNDEFty))],
169 : blume 902 UNDEFty),
170 :     e)
171 :     (* DBM: second arg of APPpat and VARexp = nil and
172 :     * of FNexp = UNDEFty ok? *)
173 :     end
174 :    
175 :     fun delayExp e =
176 : macqueen 1476 APPexp(CONexp(BT.dollarDcon,UNDEFty), e)
177 : blume 902
178 :     (* lrvbMakeY n: build declaration of n-ary Y combinator for lazy val rec *)
179 :     fun lrvbMakeY n =
180 :     let fun upto 0 = []
181 :     | upto n = n::(upto (n-1))
182 :     val base = rev(upto n) (* [1,2,...,n] *)
183 :     fun repeat f = map f base
184 :    
185 :     fun hold e = delayExp(forceExp e)
186 :    
187 :     (* capture Match exn from coreEnv as a random exn for use internally
188 :     in the Y combinator definition *)
189 : blume 904 val exn = CoreAccess.getExn (env,"Match")
190 : blume 902
191 :     (* val exn = V.bogusEXN (* see if this will work? *) *)
192 :    
193 :     (* Y variable and local variables ri and fi and d *)
194 :     val yvar (* as VALvar{path,typ,access,info} *) =
195 :     newVALvar(S.varSymbol("Y$"^(Int.toString n)))
196 :     fun mkVarSym s i = newVALvar(S.varSymbol(s^(Int.toString i)))
197 :     val rvars = repeat(mkVarSym "r$")
198 :     val fvars = repeat(mkVarSym "f$")
199 :     val dvar = newVALvar(S.varSymbol "d$")
200 :    
201 :     (* "ref($(raise Match))" *)
202 : macqueen 1476 fun rdrExp _ = APPexp(CONexp(BT.refDcon,UNDEFty),
203 :     delayExp(RAISEexp(CONexp(exn,UNDEFty),UNDEFty)))
204 : blume 902 val rpat = TUPLEpat (map VARpat rvars)
205 :     val rexp = TUPLEexp (repeat rdrExp)
206 :     val rdec = VALdec([VB{pat=rpat, exp=rexp, boundtvs=[], tyvars=ref[]}])
207 :    
208 :     (* "$(force(!ri))" *)
209 : macqueen 1377 fun dfbr rv = hold(APPexp(mkBangExp env,VARexp(ref rv,UNDEFty)))
210 : blume 902 val ddec = VALdec[VB{pat=VARpat dvar, exp=TUPLEexp(map dfbr rvars),
211 :     boundtvs=[],tyvars=ref[]}]
212 :    
213 : macqueen 1377 fun dexp () = VARexp(ref dvar,UNDEFty)
214 : blume 902 fun setrExp (rv,fv) =
215 :     APPexp(mkAssignExp env,
216 : macqueen 1377 TUPLEexp([VARexp(ref rv,UNDEFty),
217 : blume 902 hold(APPexp(VARexp(ref fv,[]),dexp()))]))
218 :     val updates = ListPair.map setrExp (rvars,fvars)
219 :    
220 :     val yexp = FNexp(completeMatch
221 :     [RULE(TUPLEpat(map VARpat fvars),
222 :     LETexp(SEQdec[rdec,ddec],
223 :     SEQexp(updates@[dexp()])))],
224 :     UNDEFty)
225 :    
226 :     in (yvar,VALdec[VB{pat=VARpat yvar, exp=yexp, boundtvs=[], tyvars=ref[]}])
227 :     end (* fun lrvbMakeY *)
228 :    
229 :    
230 :     (**** EXCEPTION DECLARATIONS ****)
231 :    
232 :     fun elabEb (region:region) (env:SE.staticEnv) (eb:Ast.eb) =
233 :     case eb
234 :     of EbGen{exn=id,etype=NONE} =>
235 :     let val exn =
236 :     DATACON{name=id, const=true, typ=exnTy, lazyp=false,
237 :     rep=EXN(LVAR(mkv(SOME id))), sign=CNIL}
238 :     in ([EBgen{exn=exn, etype=NONE,
239 :     ident=STRINGexp(S.name id)}],
240 :     SE.bind(id, B.CONbind exn, SE.empty),TS.empty)
241 :     end
242 :     | EbGen{exn=id,etype=SOME typ} =>
243 :     let val (ty,vt) = ET.elabType(typ,env,error,region)
244 :     val exn =
245 :     DATACON{name=id, const=false, typ=(ty --> exnTy), lazyp=false,
246 :     rep=EXN(LVAR(mkv(SOME id))), sign=CNIL}
247 :     in ([EBgen{exn=exn,etype=SOME ty,
248 :     ident=STRINGexp(S.name id)}],
249 :     SE.bind(id,B.CONbind exn, SE.empty),vt)
250 :     end
251 :     | EbDef{exn=id,edef=qid} =>
252 :     let val edef as DATACON{const,typ,sign,...} =
253 :     LU.lookExn(env,SP.SPATH qid,error region)
254 :     val nrep = EXN(LVAR(mkv(SOME id)))
255 :     val exn = DATACON{name=id, const=const, typ=typ, lazyp=false,
256 :     sign=sign, rep=nrep}
257 :     in ([EBdef{exn=exn,edef=edef}],
258 :     SE.bind(id,B.CONbind exn,SE.empty),TS.empty)
259 :     end
260 :     | MarkEb(eb,region) => elabEb region env eb
261 :    
262 :     fun elabEXCEPTIONdec(excbinds:Ast.eb list, env: SE.staticEnv, region) =
263 :     let val (ebs,env,vt) =
264 :     foldl
265 :     (fn (exc1,(ebs1,env1,vt1)) =>
266 :     let val (eb2,env2,vt2) = elabEb region env exc1
267 :     in (eb2@ebs1, SE.atop(env2,env1),
268 :     union(vt1,vt2,error region))
269 :     end)
270 :     ([],SE.empty,TS.empty) excbinds
271 :     fun getname(EBgen{exn=DATACON{name,...},...}) = name
272 :     | getname(EBdef{exn=DATACON{name,...},...}) = name
273 :     in EU.checkUniq (error region, "duplicate exception declaration",
274 :     map getname ebs);
275 :     (EXCEPTIONdec(rev ebs),env,vt,no_updt)
276 :     end
277 :    
278 :    
279 :     (**** PATTERNS ****)
280 :    
281 :     fun apply_pat (MarkPat(c,(l1,r1)),MarkPat(p,(l2,r2))) =
282 :     MarkPat(AppPat{constr=c, argument=p},(Int.min(l1,l2),Int.max(r1,r2)))
283 :     | apply_pat (c ,p) = AppPat{constr=c, argument=p}
284 :    
285 :     fun tuple_pat (MarkPat(a,(l,_)),MarkPat(b,(_,r))) =
286 :     MarkPat(TuplePat[a,b],(l,r))
287 :     | tuple_pat (a,b) = TuplePat[a,b]
288 :    
289 :     val patParse = Precedence.parse{apply=apply_pat, pair=tuple_pat}
290 :    
291 :     exception FreeOrVars
292 :     fun elabPat(pat:Ast.pat, env:SE.staticEnv, region:region)
293 :     : Absyn.pat * TS.tyvarset =
294 :     case pat
295 :     of WildPat => (WILDpat, TS.empty)
296 :     | VarPat path =>
297 :     (clean_pat (error region)
298 :     (pat_id(SP.SPATH path, env, error region, compInfo)),
299 :     TS.empty)
300 :     | IntPat s => (INTpat(s,TU.mkLITERALty(T.INT,region)),TS.empty)
301 :     | WordPat s => (WORDpat(s,TU.mkLITERALty(T.WORD,region)),TS.empty)
302 :     | StringPat s => (STRINGpat s,TS.empty)
303 :     | CharPat s => (CHARpat s,TS.empty)
304 :     | RecordPat {def,flexibility} =>
305 :     let val (lps,tyv) = elabPLabel region env def
306 :     in (makeRECORDpat (lps,flexibility,error region),tyv) end
307 :     | ListPat nil =>
308 :     (NILpat, TS.empty)
309 :     | ListPat (a::rest) =>
310 :     let val (p, tyv) = elabPat(TuplePat[a,ListPat rest], env, region)
311 :     in (CONSpat p, tyv)
312 :     end
313 :     | TuplePat pats =>
314 :     let val (ps,tyv) = elabPatList(pats, env, region)
315 :     in (TUPLEpat ps,tyv)
316 :     end
317 :     | VectorPat pats =>
318 :     let val (ps,tyv) = elabPatList(pats, env, region)
319 :     in (VECTORpat(ps,UNDEFty),tyv) end
320 :     | OrPat pats =>
321 :     (* Check that the sub-patterns of an or-pattern have exactly the same
322 :     * free variables, and rewrite the sub-pattersn so that all instances
323 :     * of a given free variable have the same type ref and the same
324 :     * access.
325 :     *)
326 :     let val (ps, tyv) = elabPatList(pats, env, region)
327 :     fun freeOrVars (pat::pats) =
328 :     let val tbl : (access * ty ref * int) IntStrMap.intstrmap =
329 :     IntStrMap.new(16, FreeOrVars)
330 :     fun symbToIntStr f symb =
331 :     (f tbl (S.number symb, S.name symb))
332 :     val ins =
333 :     let val ins' = IntStrMap.add tbl
334 :     in fn (symb, x) =>
335 :     ins' (S.number symb, S.name symb, x)
336 :     end
337 :     val look =
338 :     let val look' = IntStrMap.map tbl
339 :     in fn symb =>
340 :     look'(S.number symb, S.name symb)
341 :     end
342 :     fun errorMsg x =
343 :     error region EM.COMPLAIN
344 :     ("variable " ^ x ^
345 :     " does not occur in all branches of or-pattern")
346 :     EM.nullErrorBody
347 :     fun insFn (id, access, ty) =
348 :     (ins(id, (access, ty, 1)); (access,ty))
349 :     fun bumpFn (id, access0, ty0) =
350 :     (let val (access, ty, n) = look id
351 :     in ins (id, (access, ty, n+1)); (access,ty)
352 :     end
353 :     handle FreeOrVars =>
354 :     (errorMsg(S.name id); (access0,ty0)))
355 :     fun checkFn (id, access0, ty0) =
356 :     (let val (access, ty, _) = look id
357 :     in (access, ty)
358 :     end
359 :     handle FreeOrVars =>
360 :     (errorMsg(S.name id); (access0, ty0)))
361 :     fun doPat(insFn: (S.symbol*access*ty ref)
362 :     ->access*ty ref) =
363 :     let fun doPat' (VARpat(VALvar{access, info, path,
364 :     typ})) =
365 :     let val (access,typ) =
366 :     insFn(SymPath.first path,access,typ)
367 :     in VARpat(VALvar{access=access,
368 :     path=path,info=info,
369 :     typ=typ})
370 :     end
371 :     | doPat' (RECORDpat{fields, flex, typ}) =
372 :     RECORDpat
373 :     {fields =
374 :     map (fn (l, p) => (l, doPat' p))
375 :     fields,
376 :     flex = flex, typ = typ}
377 :     | doPat' (APPpat(dc, ty, pat)) =
378 :     APPpat(dc, ty, doPat' pat)
379 :     | doPat' (CONSTRAINTpat(pat, ty)) =
380 :     CONSTRAINTpat(doPat' pat, ty)
381 :     | doPat' (LAYEREDpat(p1, p2)) =
382 :     LAYEREDpat(doPat' p1, doPat' p2)
383 :     | doPat' (ORpat(p1, p2)) =
384 :     ORpat(doPat' p1, doPat checkFn p2)
385 :     | doPat' (VECTORpat(pats, ty)) =
386 :     VECTORpat(map doPat' pats, ty)
387 :     | doPat' pat = pat
388 :     in doPat'
389 :     end
390 :     (* check that each variable occurs in each sub-pattern *)
391 :     fun checkComplete m (_, id, (_, _, n:int)) =
392 :     if (n = m) then () else (errorMsg id)
393 :     val pats = (doPat insFn pat) ::
394 :     (map (doPat bumpFn) pats)
395 :     in IntStrMap.app (checkComplete (length pats)) tbl;
396 :     pats
397 :     end (* freeOrVars *)
398 :     | freeOrVars _ = bug "freeOrVars"
399 :     val (pat, pats) =
400 :     case freeOrVars ps of
401 :     (h::t) => (h, t)
402 :     | _ => bug "elabPat:no free or vars"
403 :     fun foldOr (p, []) = p
404 :     | foldOr (p, p'::r) = ORpat(p, foldOr(p', r))
405 :     in (foldOr(pat, pats), tyv)
406 :     end
407 :     | AppPat {constr, argument} =>
408 :     let fun getVar (MarkPat(p,region),region') = getVar(p,region)
409 :     | getVar (VarPat path, region') =
410 :     let val dcb = pat_id (SP.SPATH path, env,
411 :     error region', compInfo)
412 :     val (p,tv) = elabPat(argument, env, region)
413 :     in (makeAPPpat (error region) (dcb,p),tv) end
414 :     | getVar (_, region') =
415 :     (error region' EM.COMPLAIN
416 :     "non-constructor applied to argument in pattern"
417 :     EM.nullErrorBody;
418 :     (WILDpat,TS.empty))
419 :     in getVar(constr,region)
420 :     end
421 :     | ConstraintPat {pattern=pat,constraint=ty} =>
422 :     let val (p1,tv1) = elabPat(pat, env, region)
423 :     val (t2,tv2) = ET.elabType(ty,env,error,region)
424 :     in (CONSTRAINTpat(p1,t2), union(tv1,tv2,error region))
425 :     end
426 :     | LayeredPat {varPat,expPat} =>
427 :     let val (p1,tv1) = elabPat(varPat, env, region)
428 :     val (p2,tv2) = elabPat(expPat, env, region)
429 :     in (makeLAYEREDpat(p1,p2,error region),union(tv1,tv2,error region))
430 :     end
431 :     | MarkPat (pat,region) =>
432 :     let val (p,tv) = elabPat(pat, env, region)
433 :     in (p,tv)
434 :     end
435 :     | FlatAppPat pats => elabPat(patParse(pats,env,error), env, region)
436 :    
437 :     and elabPLabel (region:region) (env:SE.staticEnv) labs =
438 :     foldl
439 :     (fn ((lb1,p1),(lps1,lvt1)) =>
440 :     let val (p2,lvt2) = elabPat(p1, env, region)
441 :     in ((lb1,p2) :: lps1, union(lvt2,lvt1,error region)) end)
442 :     ([],TS.empty) labs
443 :    
444 :     and elabPatList(ps, env:SE.staticEnv, region:region) =
445 :     foldr
446 :     (fn (p1,(lps1,lvt1)) =>
447 :     let val (p2,lvt2) = elabPat(p1, env, region)
448 :     in (p2 :: lps1, union(lvt2,lvt1,error region)) end)
449 :     ([],TS.empty) ps
450 :    
451 :    
452 :     (**** EXPRESSIONS ****)
453 :    
454 :     val expParse = Precedence.parse
455 :     {apply=fn(f,a) => AppExp{function=f,argument=a},
456 :     pair=fn (a,b) => TupleExp[a,b]}
457 :    
458 :     fun elabExp(exp: Ast.exp, env: SE.staticEnv, region: region)
459 :     : (Absyn.exp * TS.tyvarset * tyvUpdate) =
460 :     (case exp
461 :     of VarExp path =>
462 :     ((case LU.lookVal(env,SP.SPATH path,error region)
463 : macqueen 1377 of V.VAL v => VARexp(ref v,UNDEFty)
464 : blume 902 | V.CON(d as DATACON{lazyp,const,...}) =>
465 :     if lazyp then (* LAZY *)
466 : macqueen 1476 if const then delayExp(CONexp(d,UNDEFty))
467 : blume 902 else let val var = newVALvar(S.varSymbol "x")
468 :     in FNexp(completeMatch
469 :     [RULE(VARpat(var),
470 :     delayExp(
471 : macqueen 1476 APPexp(CONexp(d,UNDEFty),
472 : macqueen 1377 VARexp(ref(var),UNDEFty))))],
473 : blume 902 UNDEFty (* DBM: ? *))
474 :     end
475 : macqueen 1476 else CONexp(d,UNDEFty)),
476 : blume 902 TS.empty, no_updt)
477 :     | IntExp s =>
478 :     (INTexp(s,TU.mkLITERALty(T.INT,region)),TS.empty,no_updt)
479 :     | WordExp s =>
480 :     (WORDexp(s,TU.mkLITERALty(T.WORD,region)),TS.empty,no_updt)
481 :     | RealExp r => (REALexp r,TS.empty,no_updt)
482 :     | StringExp s => (STRINGexp s,TS.empty,no_updt)
483 :     | CharExp s => (CHARexp s,TS.empty,no_updt)
484 :     | RecordExp cells =>
485 :     let val (les,tyv,updt) = elabELabel(cells,env,region)
486 :     in (makeRECORDexp (les,error region),tyv,updt)
487 :     end
488 :     | SeqExp exps =>
489 :     (case exps
490 :     of [e] => elabExp(e,env,region)
491 :     | [] => bug "elabExp(SeqExp[])"
492 :     | _ =>
493 :     let val (es,tyv,updt) = elabExpList(exps,env,region)
494 :     in (SEQexp es,tyv,updt)
495 :     end)
496 :     | ListExp nil => (NILexp, TS.empty, no_updt)
497 :     | ListExp (a::rest) =>
498 :     let val (e,tyv,updt) =
499 :     elabExp(TupleExp[a,ListExp rest],env,region)
500 :     in (APPexp(CONSexp,e), tyv, updt)
501 :     end
502 :     | TupleExp exps =>
503 :     let val (es,tyv,updt) = elabExpList(exps,env,region)
504 :     in (TUPLEexp es,tyv,updt)
505 :     end
506 :     | VectorExp exps =>
507 :     let val (es,tyv,updt) = elabExpList(exps,env,region)
508 :     in (VECTORexp(es,UNDEFty),tyv,updt)
509 :     end
510 :     | AppExp {function,argument} =>
511 :     let val (e1,tv1,updt1) = elabExp(function,env,region)
512 :     and (e2,tv2,updt2) = elabExp(argument,env,region)
513 :     fun updt tv = (updt1 tv;updt2 tv)
514 :     in (APPexp (e1,e2),union(tv1,tv2,error region),updt)
515 :     end
516 :     | ConstraintExp {expr=exp,constraint=ty} =>
517 :     let val (e1,tv1,updt) = elabExp(exp,env,region)
518 :     val (t2,tv2) = ET.elabType(ty,env,error,region)
519 :     in (CONSTRAINTexp(e1,t2), union(tv1,tv2,error region),updt)
520 :     end
521 :     | HandleExp {expr,rules} =>
522 :     let val (e1,tv1,updt1) = elabExp(expr,env,region)
523 :     val (rls2,tv2,updt2) = elabMatch(rules,env,region)
524 :     fun updt tv = (updt1 tv;updt2 tv)
525 :     in (makeHANDLEexp (e1, rls2, compInfo),
526 :     union(tv1,tv2,error region), updt)
527 :     end
528 :     | RaiseExp exp =>
529 :     let val (e,tyv,updt) = elabExp(exp,env,region)
530 :     in (RAISEexp(e,UNDEFty),tyv,updt)
531 :     end
532 :     | LetExp {dec,expr} =>
533 :     let val (d1,e1,tv1,updt1) =
534 :     elabDec'(dec,env,IP.IPATH[],region)
535 :     val (e2,tv2,updt2) = elabExp(expr,SE.atop(e1,env),region)
536 :     fun updt tv = (updt1 tv;updt2 tv)
537 :     in (LETexp(d1,e2), union(tv1,tv2,error region),updt)
538 :     end
539 :     | CaseExp {expr,rules} =>
540 :     let val (e1,tv1,updt1) = elabExp(expr,env,region)
541 :     val (rls2,tv2,updt2) = elabMatch(rules,env,region)
542 :     fun updt tv = (updt1 tv;updt2 tv)
543 :     in (CASEexp (e1,completeMatch rls2, true),
544 :     union(tv1,tv2,error region),updt)
545 :     end
546 :     | IfExp {test,thenCase,elseCase} =>
547 :     let val (e1,tv1,updt1) = elabExp(test,env,region)
548 :     and (e2,tv2,updt2) = elabExp(thenCase,env,region)
549 :     and (e3,tv3,updt3) = elabExp(elseCase,env,region)
550 :     fun updt tv = (updt1 tv;updt2 tv;updt3 tv)
551 : mblume 1332 in (Absyn.IFexp { test = e1, thenCase = e2, elseCase = e3 },
552 : blume 902 union(tv1,union(tv2,tv3,error region),error region),
553 :     updt)
554 :     end
555 :     | AndalsoExp (exp1,exp2) =>
556 :     let val (e1,tv1,updt1) = elabExp(exp1,env,region)
557 :     and (e2,tv2,updt2) = elabExp(exp2,env,region)
558 :     fun updt tv = (updt1 tv;updt2 tv)
559 : mblume 1332 in (ANDALSOexp(e1, e2), union(tv1,tv2,error region),updt)
560 : blume 902 end
561 :     | OrelseExp (exp1,exp2) =>
562 :     let val (e1,tv1,updt1) = elabExp(exp1,env,region)
563 :     and (e2,tv2,updt2) = elabExp(exp2,env,region)
564 :     fun updt tv = (updt1 tv;updt2 tv)
565 : mblume 1332 in (ORELSEexp(e1, e2), union(tv1,tv2,error region),updt)
566 : blume 902 end
567 :     | WhileExp {test,expr} =>
568 :     let val (e1,tv1,updt1) = elabExp(test,env,region)
569 :     and (e2,tv2,updt2) = elabExp(expr,env,region)
570 :     fun updt tv = (updt1 tv;updt2 tv)
571 : mblume 1332 in (Absyn.WHILEexp { test = e1, expr = e2 },
572 : blume 902 union(tv1,tv2,error region), updt)
573 :     end
574 :     | FnExp rules =>
575 :     let val (rls,tyv,updt) = elabMatch(rules,env,region)
576 :     in (FNexp (completeMatch rls,UNDEFty),tyv,updt)
577 :     end
578 :     | MarkExp (exp,region) =>
579 :     let val (e,tyv,updt) = elabExp(exp,env,region)
580 :     in (if !ElabControl.markabsyn then MARKexp(e,region) else e,
581 :     tyv, updt)
582 :     end
583 :     | SelectorExp s =>
584 :     (let val v = newVALvar s
585 :     in FNexp(completeMatch
586 :     [RULE(RECORDpat{fields=[(s,VARpat v)], flex=true,
587 :     typ= ref UNDEFty},
588 : macqueen 1377 MARKexp(VARexp(ref v,UNDEFty),region))],UNDEFty)
589 : blume 902 end,
590 :     TS.empty, no_updt)
591 :     | FlatAppExp items => elabExp(expParse(items,env,error),env,region))
592 :    
593 :    
594 :     and elabELabel(labs,env,region) =
595 :     let val (les1,lvt1,updt1) =
596 :     foldr
597 :     (fn ((lb2,e2),(les2,lvt2,updts2)) =>
598 :     let val (e3,lvt3,updt3) = elabExp(e2,env,region)
599 :     in ((lb2,e3) :: les2, union(lvt3,lvt2,error region),
600 :     updt3 :: updts2)
601 :     end)
602 :     ([],TS.empty,[]) labs
603 :     fun updt tv : unit = app (fn f => f tv) updt1
604 :     in (les1, lvt1, updt)
605 :     end
606 :    
607 :     and elabExpList(es,env,region) =
608 :     let val (les1,lvt1,updt1) =
609 :     foldr
610 :     (fn (e2,(es2,lvt2,updts2)) =>
611 :     let val (e3,lvt3,updt3) = elabExp(e2,env,region)
612 :     in (e3 :: es2, union(lvt3,lvt2,error region),
613 :     updt3 :: updts2)
614 :     end)
615 :     ([],TS.empty,[]) es
616 :     fun updt tv: unit = app (fn f => f tv) updt1
617 :     in (les1, lvt1, updt)
618 :     end
619 :    
620 :     and elabMatch(rs,env,region) =
621 :     let val (rs,lvt,updt1) =
622 :     foldr
623 :     (fn (r1,(rs1,lvt1,updt1)) =>
624 :     let val (r2,lvt2,updt2) = elabRule(r1,env,region)
625 :     in (r2 :: rs1, union(lvt2,lvt1,error region),
626 :     updt2::updt1)
627 :     end)
628 :     ([],TS.empty,[]) rs
629 :     fun updt tv: unit = app (fn f => f tv) updt1
630 :     in (rs, lvt, updt)
631 :     end
632 :    
633 :     and elabRule(Rule{pat,exp},env,region) =
634 :     let val region' = case pat of MarkPat (p,reg) => reg | _ => region
635 :     val (p,tv1) = elabPat(pat, env, region)
636 :     val env' = SE.atop(bindVARp ([p],error region'), env)
637 :     val (e,tv2,updt) = elabExp(exp,env',region)
638 :     in (RULE(p,e),union(tv1,tv2,error region),updt)
639 :     end
640 :    
641 :    
642 :     (**** SIMPLE DECLARATIONS ****)
643 :    
644 :     and elabDec'(dec,env,rpath,region)
645 :     : (Absyn.dec * SE.staticEnv * TS.tyvarset * tyvUpdate) =
646 :     (case dec
647 :     of TypeDec tbs =>
648 :     let val (dec', env') =
649 :     ET.elabTYPEdec(tbs,env,(* EU.TOP,??? *) rpath,region,compInfo)
650 :     in noTyvars(dec', env')
651 :     end
652 :     | DatatypeDec(x as {datatycs,withtycs}) =>
653 :     (case datatycs
654 :     of (Db{rhs=(Constrs _), ...}) :: _ =>
655 :     let val (dtycs, wtycs, _, env') =
656 :     ET.elabDATATYPEdec(x,env,[],EE.empty,isFree,
657 :     rpath,region,compInfo)
658 :     in noTyvars(DATATYPEdec{datatycs=dtycs,withtycs=wtycs}, env')
659 :     end
660 :     | (Db{tyc=name,rhs=Repl syms,tyvars=nil,lazyp=false}::nil) =>
661 :     (* LAZY: not allowing "datatype lazy t = datatype t'" *)
662 :     (* BUG: what to do if rhs is lazy "datatype"? (DBM) *)
663 :     (case withtycs
664 :     of nil =>
665 :     let val tyc = LU.lookTyc(env, SP.SPATH syms,
666 :     error region)
667 :     val dcons = TU.extractDcons tyc
668 :     val envDcons =
669 :     foldl (fn (d as T.DATACON{name,...},e)=>
670 :     SE.bind(name,B.CONbind d, e))
671 :     SE.empty
672 :     dcons
673 :     val env = SE.bind(name,B.TYCbind tyc,envDcons)
674 :     in noTyvars(DATATYPEdec{datatycs=[tyc], withtycs=[]},
675 :     env)
676 :     end
677 :     | _ => (error region EM.COMPLAIN
678 :     "withtype not allowed in datatype replication"
679 :     EM.nullErrorBody;
680 :     noTyvars(SEQdec[],SE.empty)))
681 :     | _ => (error region EM.COMPLAIN
682 :     "argument type variables in datatype replication"
683 :     EM.nullErrorBody;
684 :     noTyvars(SEQdec[],SE.empty)))
685 :     | AbstypeDec x =>
686 :     let val (dec', env') =
687 :     elabABSTYPEdec(x,env,EU.TOP,isFree,
688 :     rpath,region,compInfo)
689 :     in noTyvars(dec', env')
690 :     end
691 :     | ExceptionDec ebs => elabEXCEPTIONdec(ebs,env,region)
692 :     | ValDec(vbs,explicitTvs) =>
693 :     elabVALdec(vbs,explicitTvs,env,rpath,region)
694 :     | FunDec(fbs,explicitTvs) =>
695 :     elabFUNdec(fbs,explicitTvs,env,rpath,region)
696 :     | ValrecDec(rvbs,explicitTvs) =>
697 :     elabVALRECdec(rvbs,explicitTvs,env,rpath,region)
698 :     | SeqDec ds => elabSEQdec(ds,env,rpath,region)
699 :     | LocalDec ld => elabLOCALdec(ld,env,rpath,region)
700 :     | OpenDec ds => elabOPENdec(ds,env,region)
701 :     | FixDec (ds as {fixity,ops}) =>
702 :     let val env =
703 :     foldr (fn (id,env) => SE.bind(id,B.FIXbind fixity,env))
704 :     SE.empty ops
705 :     in (FIXdec ds,env,TS.empty,no_updt)
706 :     end
707 :     | OvldDec dec => elabOVERLOADdec(dec,env,rpath,region)
708 :     | MarkDec(dec,region') =>
709 :     let val (d,env,tv,updt)= elabDec'(dec,env,rpath,region')
710 :     in (if !ElabControl.markabsyn then MARKdec(d,region') else d,
711 :     env,tv,updt)
712 :     end
713 :     | StrDec _ => bug "strdec"
714 :     | AbsDec _ => bug "absdec"
715 :     | FctDec _ => bug "fctdec"
716 :     | SigDec _ => bug "sigdec"
717 :     | FsigDec _ => bug "fsigdec")
718 :    
719 :    
720 :     (**** OVERLOADING ****)
721 :    
722 :     and elabOVERLOADdec((id,typ,exps),env,rpath,region) =
723 :     let val (body,tyvars) = ET.elabType(typ,env,error,region)
724 :     val tvs = TS.elements tyvars
725 :     val scheme = (TU.bindTyvars tvs; TU.compressTy body;
726 :     TYFUN{arity=length tvs, body=body})
727 :     fun option (MARKexp(e,_)) = option e
728 :     | option (VARexp(ref (v as VALvar{typ,...}),_)) =
729 :     {indicator = TU.matchScheme(scheme,!typ), variant = v}
730 :     | option _ = bug "makeOVERLOADdec.option"
731 :     val exps = map (fn exp => elabExp(exp,env,region)) exps
732 :     val exps1 = map #1 exps
733 :     and exps3 = map #3 exps
734 :     fun updt tv: unit = app (fn f => f tv) exps3
735 :     val ovldvar = OVLDvar{name=id,scheme=scheme,
736 :     options=ref(map option exps1)}
737 :     in (OVLDdec ovldvar, SE.bind(id,B.VALbind ovldvar,SE.empty),
738 :     TS.empty, updt)
739 :     end
740 :    
741 :     (**** LOCAL ****)
742 :    
743 :     and elabLOCALdec((ldecs1,ldecs2),env,rpath:IP.path,region) =
744 :     let val (ld1,env1,tv1,updt1) = elabDec'(ldecs1,env,IP.IPATH[],region)
745 :     val (ld2,env2,tv2,updt2) =
746 :     elabDec'(ldecs2,SE.atop(env1,env),rpath,region)
747 :     fun updt tv = (updt1 tv;updt2 tv)
748 :     in (LOCALdec(ld1,ld2), env2,union(tv1,tv2,error region),updt)
749 :     end
750 :    
751 :     (**** OPEN ****)
752 :    
753 :     and elabOPENdec(spaths, env, region) =
754 :     let val err = error region
755 :     val strs = map (fn s => let val sp = SP.SPATH s
756 :     in (sp, LU.lookStr(env, sp, err))
757 :     end) spaths
758 :    
759 :     fun loop([], env) = (OPENdec strs, env, TS.empty, no_updt)
760 :     | loop((_, s)::r, env) = loop(r, MU.openStructure(env, s))
761 :    
762 :     in loop(strs, SE.empty)
763 :     end
764 :    
765 :     (**** VALUE DECLARATIONS ****)
766 :     and elabVB (MarkVb(vb,region),etvs,env,_) =
767 :     elabVB(vb,etvs,env,region)
768 :     | elabVB (Vb{pat,exp,lazyp},etvs,env,region) =
769 :     let val (pat,pv) = elabPat(pat, env, region)
770 :     val (exp,ev,updtExp) = elabExp(exp,env,region)
771 :     val exp = if lazyp (* LAZY *)
772 :     then delayExp(forceExp exp)
773 :     else exp
774 :     val tvref = ref []
775 :     fun updt tv: unit =
776 :     let fun a++b = union(a,b,error region)
777 :     fun a--b = diff(a,b,error region)
778 :     val localtyvars = (ev++pv++etvs) -- (tv---etvs)
779 :     (* etvs should be the second argument to union
780 :     * to avoid having the explicit type variables
781 :     * instantiated by the union operation. *)
782 :     val downtyvars = localtyvars ++ (tv---etvs)
783 :     in tvref := TS.elements localtyvars; updtExp downtyvars
784 :     end
785 :    
786 :     (*
787 :     * WARNING: the following code is trying to propagate the
788 :     * PRIMOP access through simple value binding. It is a old
789 :     * hack and should be cleaned up in the future. (ZHONG)
790 :     * This won't apply if lazyp=true. (DBM)
791 :     *)
792 :     val pat =
793 :     case stripExpAbs exp
794 :     of VARexp(ref(VALvar{info=dinfo,...}),_) =>
795 :     (if II.isSimple dinfo then
796 :     (case pat
797 :     of CONSTRAINTpat(VARpat(VALvar{path,typ,
798 :     access,...}), ty) =>
799 :     CONSTRAINTpat(VARpat(
800 :     VALvar{path=path, typ=typ, access=access,
801 :     info=dinfo}), ty)
802 :     | VARpat(VALvar{path, typ, access, ...}) =>
803 :     VARpat(VALvar{path=path, typ=typ, access=access,
804 :     info=dinfo})
805 :     | _ => pat)
806 :     else pat)
807 :     | _ => pat
808 :    
809 :     (* DBM: can the first two cases ever return NONE? *)
810 :     fun bindpat(VARpat(VALvar{access=acc, ...})) = A.accLvar acc
811 :     | bindpat(CONSTRAINTpat(VARpat(VALvar{access=acc, ...}),_)) =
812 :     A.accLvar acc
813 :     | bindpat _ = NONE
814 :    
815 :     in case bindpat(pat)
816 :     of NONE => (* DBM: pattern is not a variable? *)
817 :     (let val (newpat,oldvars,newvars) = patproc(pat, compInfo)
818 :     (* this is the only call of patproc *)
819 : macqueen 1377 val b = map (fn v => VARexp(ref v,UNDEFty)) newvars
820 : blume 902 val r = RULE(newpat, TUPLEexp(b))
821 :     val newexp = CASEexp(exp, completeBind[r], false)
822 :    
823 :     in case oldvars
824 :     of [] =>
825 :     (let val nvb = VB{exp=newexp, tyvars=tvref,
826 :     pat=WILDpat, boundtvs=[]}
827 :     in (VALdec [nvb], [], updt)
828 :     end)
829 :     | _ =>
830 :     (let val nv = newVALvar internalSym
831 :     val nvpat = VARpat(nv)
832 : macqueen 1377 val nvexp = VARexp(ref nv, UNDEFty)
833 : blume 902
834 :     val nvdec =
835 :     VALdec([VB{exp=newexp, tyvars=tvref,
836 :     pat=nvpat, boundtvs=[]}])
837 :    
838 :     fun h([], _, d) =
839 :     LOCALdec(nvdec, SEQdec(rev d))
840 :     | h(vp::r, i, d) =
841 :     let val nvb = VB{exp=TPSELexp(nvexp,i),
842 :     pat=vp, boundtvs=[],
843 :     tyvars=ref[]}
844 :    
845 :     in h(r, i+1, VALdec([nvb])::d)
846 :     end
847 :    
848 :     in (h(oldvars, 1, []), oldvars, updt)
849 :     end)
850 :     end)
851 :     | SOME _ =>
852 :     (VALdec([VB{exp=exp, tyvars=tvref, pat=pat, boundtvs=[]}]),
853 :     [pat], updt)
854 :     end
855 :    
856 :     and elabVALdec(vb,etvs,env,rpath,region) =
857 :     let val etvs = ET.elabTyvList(etvs,error,region)
858 :     val (ds,pats,updt1) =
859 :     foldr
860 :     (fn (vdec,(ds1,pats1,updt1)) =>
861 :     let val etvs = TS.mkTyvarset(map T.copyTyvar etvs)
862 :     val (d2,pats2,updt2) = elabVB(vdec,etvs,env,region)
863 :     in (d2::ds1,pats2@pats1,updt2::updt1)
864 :     end)
865 :     ([],[],[]) vb
866 :     fun updt tv : unit = app (fn f => f tv) updt1
867 :     in (SEQdec ds, bindVARp (pats,error region), TS.empty, updt)
868 :     end
869 :    
870 :     and elabRVB(MarkRvb(rvb,region),env,_) = elabRVB(rvb,env,region)
871 :     | elabRVB(Rvb{var,fixity,exp,resultty,lazyp},env,region) =
872 :     (case stripExpAst(exp,region)
873 :     of (FnExp _,region')=>
874 :     let val (e,ev,updt) = elabExp(exp,env,region')
875 :     val (t,tv) =
876 :     case resultty
877 :     of SOME t1 =>
878 :     let val (t2,tv2) = ET.elabType(t1,env,error,region)
879 :     in (SOME t2,tv2)
880 :     end
881 :     | NONE => (NONE,TS.empty)
882 :     in case fixity
883 :     of NONE => ()
884 :     | SOME(f,region) =>
885 :     (case LU.lookFix(env,f)
886 :     of Fixity.NONfix => ()
887 :     | _ =>
888 :     error region EM.COMPLAIN
889 :     ("infix symbol \""^ S.name f ^
890 :     "\" used where a nonfix identifier was expected")
891 :     EM.nullErrorBody);
892 :     ({match = e , ty = t, name=var},
893 :     union(ev,tv,error region),updt)
894 :     end
895 :     | _ =>
896 :     (error region EM.COMPLAIN
897 :     "fn expression required on rhs of val rec"
898 :     EM.nullErrorBody;
899 :     ({match = dummyFNexp, ty = NONE, name = var},TS.empty,no_updt)))
900 :    
901 :     and elabVALRECstrict(rvbs,etvs,env,region) =
902 :     let val env' = ref(SE.empty: SE.staticEnv)
903 :     fun makevar region (p as Rvb{var,...}) =
904 :     let val v = newVALvar var
905 :     val nv = newVALvar var (* DBM: what is this for? *)
906 :     in (* checkBoundConstructor(env,var,error region); -- fix bug 1357 *)
907 :     env' := SE.bind(var,B.VALbind v,!env');
908 :     (v, p)
909 :     end
910 :     | makevar _ (p as MarkRvb(rvb,region)) =
911 :     let val (v,_) = makevar region rvb in (v,p) end
912 :    
913 :     val rvbs' = map (makevar region) rvbs
914 :     val env'' = SE.atop(!env', env)
915 :     val (rvbs,tyvars,updts)=
916 :     foldl (fn((v,rvb1),(rvbs1,tvs1,updt1)) =>
917 :     let val (rvb2,tv2,updt2) =
918 :     elabRVB(rvb1,env'',region)
919 :     in ((v,rvb2)::rvbs1,
920 :     union(tv2,tvs1,error region),
921 :     updt2::updt1)
922 :     end)
923 :     ([],TS.empty,[]) rvbs'
924 :     val tvref = ref []
925 :     fun updt tvs : unit =
926 :     let fun a++b = union(a,b,error region)
927 :     fun a--b = diff(a,b,error region)
928 :     val localtyvars = (tyvars ++ etvs) -- (tvs --- etvs)
929 :     val downtyvars = localtyvars ++ (tvs --- etvs)
930 :     in tvref := TS.elements localtyvars;
931 :     app (fn f => f downtyvars) updts
932 :     end
933 :     val _ = EU.checkUniq(error region,
934 :     "duplicate function name in val rec dec",
935 :     (map (fn (v,{name,...}) => name) rvbs))
936 :    
937 :     val (ndec, nenv) =
938 :     wrapRECdec((map (fn (v,{ty,match,name}) =>
939 :     RVB{var=v,resultty=ty,tyvars=tvref, exp=match,
940 :     boundtvs=[]})
941 :     rvbs),
942 :     compInfo)
943 :     in (ndec, nenv, TS.empty, updt)
944 :     end (* fun elabVALRECstrict *)
945 :    
946 :     (* LAZY: "val rec lazy ..." *)
947 :     and elabVALREClazy (rvbs,etvs,env,region) =
948 :     let fun split [] = ([],[])
949 :     | split ((Rvb {var,exp,resultty,lazyp,...})::xs) =
950 :     let val (a,b) = split xs in ((var,resultty)::a,(exp,lazyp)::b) end
951 :     | split ((MarkRvb (x,_))::xs) = split (x::xs) (* loosing regions *)
952 :    
953 :     val (yvar,declY) = lrvbMakeY (length rvbs)
954 :    
955 :     val (lhss,exps) = split rvbs
956 :     val argpat = TuplePat(map (fn (sym,NONE) => VarPat[sym]
957 :     | (sym,SOME ty) =>
958 :     ConstraintPat{pattern=VarPat[sym],
959 :     constraint=ty})
960 :     lhss)
961 :    
962 :     fun elabFn((exp,lazyp),(fexps,tvs,updts)) =
963 :     let val (p,tv1) = elabPat(argpat, env, region)
964 :     val env' = SE.atop(bindVARp ([p],error region), env)
965 :     val (e,tv2,updt) = elabExp(exp,env',region)
966 :     in (FNexp(completeMatch[RULE(p,if lazyp then e else delayExp e)],
967 :     UNDEFty)::fexps,
968 :     union(union(tv1,tv2,error region),tvs,error region),
969 :     updt::updts)
970 :     end
971 :    
972 :     val (fns,tyvars,updts) = foldr elabFn ([],TS.empty,[]) exps
973 :    
974 :     val lhsSyms = map #1 lhss (* left hand side symbols *)
975 :     val lhsVars = map newVALvar lhsSyms
976 :    
977 :     (* copied from original elabVALRECdec *)
978 :     val tvref = ref []
979 :     fun updt tvs : unit =
980 :     let fun a++b = union(a,b,error region)
981 :     fun a--b = diff(a,b,error region)
982 :     val localtyvars = (tyvars ++ etvs) -- (tvs --- etvs)
983 :     val downtyvars = localtyvars ++ (tvs --- etvs)
984 :     in tvref := TS.elements localtyvars;
985 :     app (fn f => f downtyvars) updts
986 :     end
987 :    
988 :     val declAppY =
989 :     VALdec[VB{pat=TUPLEpat(map VARpat lhsVars),
990 : macqueen 1377 exp=APPexp(VARexp(ref yvar,UNDEFty),TUPLEexp fns),
991 : blume 902 tyvars=tvref,boundtvs=[]}]
992 :    
993 :     fun forceStrict ((sym,var1,lazyp),(vbs,vars)) =
994 :     let val var2 = newVALvar sym
995 :     val vb = if lazyp
996 :     then VB{pat=VARpat var2,
997 : macqueen 1377 exp=VARexp (ref var1,UNDEFty),boundtvs=[],
998 : blume 902 tyvars=ref[]}
999 :     else VB{pat=APPpat(BT.dollarDcon,[],(VARpat var2)),
1000 : macqueen 1377 exp=VARexp (ref var1,UNDEFty),boundtvs=[],
1001 : blume 902 tyvars=ref[]}
1002 :     in (vb::vbs,var2::vars)
1003 :     end
1004 :    
1005 :     fun zip3(x::xs,y::ys,z::zs) = (x,y,z)::zip3(xs,ys,zs)
1006 :     | zip3(nil,_,_) = nil
1007 :     | zip3 _ = bug "zip3"
1008 :    
1009 :     val (vbs,vars) =
1010 :     foldr forceStrict ([],[]) (zip3(lhsSyms,lhsVars,map #2 exps))
1011 :    
1012 :     val env' = foldl (fn ((s,v),env) => SE.bind(s,B.VALbind v,env)) SE.empty
1013 :     (ListPair.zip(lhsSyms,vars))
1014 :    
1015 :     val absyn = LOCALdec(SEQdec[declY,declAppY],VALdec vbs)
1016 :     in showDec("elabVALREClazy: ",absyn,env');
1017 :     (absyn,env',TS.empty(*?*),updt)
1018 :     end (* fun elabVALREClazy *)
1019 :    
1020 :     and elabVALRECdec(rvbs: rvb list,etvs,env,rpath:IP.path,region) =
1021 :     let val etvs = TS.mkTyvarset(ET.elabTyvList(etvs,error,region))
1022 :     fun isLazy(Rvb{lazyp,...}) = lazyp
1023 :     | isLazy(MarkRvb(rvb,_)) = isLazy rvb
1024 :     in if List.exists isLazy rvbs
1025 :     then elabVALREClazy(rvbs,etvs,env,region)
1026 :     else elabVALRECstrict(rvbs,etvs,env,region)
1027 :     end
1028 :    
1029 :     and elabFUNdec(fb,etvs,env,rpath,region) =
1030 :     let val etvs = TS.mkTyvarset(ET.elabTyvList(etvs,error,region))
1031 :     (* makevar: parse the function header to determine the function name *)
1032 :     fun makevar _ (MarkFb(fb,region),ctx) = makevar region (fb,ctx)
1033 :     | makevar region (Fb(clauses,lazyp),(lcl,env')) =
1034 :     let fun getfix(SOME f) = LU.lookFix(env,f)
1035 :     | getfix NONE = Fixity.NONfix
1036 :    
1037 :     fun ensureInfix{item,fixity,region} =
1038 :     (case getfix fixity
1039 :     of Fixity.NONfix =>
1040 :     error region EM.COMPLAIN
1041 :     "infix operator required, or delete parentheses"
1042 :     EM.nullErrorBody
1043 :     | _ => ();
1044 :     item)
1045 :    
1046 :     fun ensureNonfix{item,fixity,region} =
1047 :     (case (getfix fixity, fixity)
1048 :     of (Fixity.NONfix,_) => ()
1049 :     | (_,SOME sym) =>
1050 :     error region EM.COMPLAIN
1051 :     ("infix operator \"" ^ S.name sym ^
1052 :     "\" used without \"op\" in fun dec")
1053 :     EM.nullErrorBody
1054 :     | _ => bug "ensureNonfix";
1055 :     item)
1056 :    
1057 :     fun getname(MarkPat(p,region),_) = getname(p,region)
1058 :     | getname(VarPat[v], _) = v
1059 :     | getname(_, region) =
1060 :     (error region EM.COMPLAIN
1061 :     "illegal function symbol in clause"
1062 :     EM.nullErrorBody;
1063 :     bogusID)
1064 :    
1065 :     fun parse'({item=FlatAppPat[a,b as {region,...},c],...}
1066 :     ::rest) =
1067 :     (getname(ensureInfix b, region),
1068 :     tuple_pat(ensureNonfix a, ensureNonfix c)
1069 :     :: map ensureNonfix rest)
1070 :     | parse' [{item,region,...}] =
1071 :     (error region EM.COMPLAIN
1072 :     "can't find function arguments in clause"
1073 :     EM.nullErrorBody;
1074 :     (getname(item,region), [WildPat]))
1075 :     | parse' ((a as {region,...}) :: rest) =
1076 :     (getname(ensureNonfix a, region),
1077 :     map ensureNonfix rest)
1078 :     | parse' [] = bug "parse':[]"
1079 :    
1080 :     fun parse({item=MarkPat(p,_),region,fixity}::rest) =
1081 :     parse({item=p,region=region,fixity=fixity}::rest)
1082 :     | parse (pats as [a as {region=ra,...},
1083 :     b as {item,fixity,region},c]) =
1084 :     (case getfix fixity
1085 :     of Fixity.NONfix => parse' pats
1086 :     | _ => (getname(item,region),
1087 :     [tuple_pat(ensureNonfix a, ensureNonfix c)]))
1088 :     | parse pats = parse' pats
1089 :    
1090 :     fun parseClause(Clause{pats,resultty,exp}) =
1091 :     let val (funsym,argpats) = parse pats
1092 :     in {kind=STRICT,funsym=funsym,argpats=argpats,
1093 :     resultty=resultty,exp=exp}
1094 :     end
1095 :    
1096 :     val (clauses, var) =
1097 :     case map parseClause clauses of
1098 :     [] => bug "elabcore:no clauses"
1099 :     | (l as ({funsym=var,...}::_)) => (l,var)
1100 :    
1101 :     val _ = if List.exists (fn {funsym,...} =>
1102 :     not(S.eq(var,funsym))) clauses
1103 :     then error region EM.COMPLAIN
1104 :     "clauses don't all have same function name"
1105 :     EM.nullErrorBody
1106 :     else ()
1107 :    
1108 :     (* DBM: fix bug 1357
1109 :     val _ = checkBoundConstructor(env,var,error region)
1110 :     *)
1111 :     val v = newVALvar var
1112 :    
1113 :     val argcount =
1114 :     case clauses
1115 :     of ({argpats,...})::rest =>
1116 :     let val len = length argpats
1117 :     in if List.exists
1118 :     (fn {argpats,...} =>
1119 :     len <> length argpats) rest
1120 :     then error region EM.COMPLAIN
1121 :     "clauses don't all have same number of patterns"
1122 :     EM.nullErrorBody
1123 :     else ();
1124 :     len
1125 :     end
1126 :     | [] => bug "elabFUNdec: no clauses"
1127 :     in if lazyp (* LAZY *)
1128 :     then let fun newArgs(args,0) = args
1129 :     | newArgs(args,n) =
1130 :     newArgs([S.varSymbol("$"^Int.toString n)]::args,
1131 :     n-1)
1132 :     fun curryApp (f,[]) = f
1133 :     | curryApp (f,x::xs) =
1134 :     curryApp(AppExp{function=f, argument=x},xs)
1135 :     val lazyvar = S.varSymbol(S.name var ^ "_")
1136 :     val lv = newVALvar lazyvar
1137 :     fun mkLazy(new,resty,[]) = (rev new,resty)
1138 :     | mkLazy(new,resty,
1139 :     {kind,funsym,argpats,resultty,exp}::rest) =
1140 :     mkLazy({kind=LZinner,funsym=lazyvar,argpats=argpats,
1141 :     resultty=NONE, (* moved to outer clause *)
1142 :     exp=exp}
1143 :     ::new,
1144 :     case resty
1145 :     of NONE => resultty
1146 :     | _ => resty,
1147 :     rest)
1148 :     (* BUG: this captures the first resultty encountered,
1149 :     if any, and discards the rest, not checking
1150 :     consistency of redundant resultty constraints *)
1151 :     val (innerclauses,resultty) =
1152 :     mkLazy ([],NONE,clauses)
1153 :     val outerargs = newArgs([],argcount)
1154 :     val outerclause =
1155 :     {kind=LZouter, funsym=var, resultty=resultty,
1156 :     argpats=map VarPat outerargs,
1157 :     exp=curryApp(VarExp[lazyvar],
1158 :     map VarExp outerargs)}
1159 :     in ((lv,innerclauses,region)::(v,[outerclause],region)
1160 :     ::lcl,
1161 :     SE.bind(var,B.VALbind v,
1162 :     SE.bind(lazyvar,B.VALbind lv, env')))
1163 :     end
1164 :     else ((v,clauses,region)::lcl,SE.bind(var,B.VALbind v,env'))
1165 :     end (* makevar *)
1166 :     val (fundecs,env') = foldl (makevar region) ([],SE.empty) fb
1167 :     val env'' = SE.atop(env',env)
1168 :     fun elabClause(region,({kind,argpats,resultty,exp,funsym})) =
1169 :     let val (pats,tv1) = elabPatList(argpats, env, region)
1170 :     val nenv = SE.atop(bindVARp(pats,error region), env'')
1171 :     val (exp,tv2,updt) = elabExp(exp, nenv,region)
1172 :     (* LAZY: wrap delay or force around rhs as appropriate*)
1173 :     val exp =
1174 :     case kind
1175 :     of STRICT => exp
1176 :     | LZouter => delayExp exp
1177 :     | LZinner => forceExp exp
1178 :     val (ty,tv3) =
1179 :     case resultty
1180 :     of NONE => (NONE,TS.empty)
1181 :     | SOME t =>
1182 :     let val (t4,tv4) = ET.elabType(t,env,error,region)
1183 :     in (SOME t4,tv4)
1184 :     end
1185 :     in ({pats=pats,resultty=ty,exp=exp},
1186 :     union(tv1,union(tv2,tv3,error region),error region),updt)
1187 :     end
1188 :     fun elabFundec ((var,clauses,region),(fs,tvs,updt)) =
1189 :     let val (cs1,tvs1,updt1) =
1190 :     foldl (fn (c2,(cs2,tvs2,updt2)) =>
1191 :     let val (c3,tvs3,updt3) = elabClause(region,c2)
1192 :     in (c3::cs2,union(tvs3,tvs2,error region),
1193 :     updt3::updt2)
1194 :     end)
1195 :     ([],TS.empty,[]) clauses
1196 :     in ((var,rev cs1)::fs, union(tvs1,tvs,error region),
1197 :     updt1 @ updt)
1198 :     end
1199 :     val (fbs1,ftyvars,updts) = foldl elabFundec ([],TS.empty,[]) fundecs
1200 :     val tvref = ref [] (* common tvref cell for all bindings! *)
1201 :     fun updt tvs : unit =
1202 :     let fun a++b = union(a,b,error region)
1203 :     fun a--b = diff(a,b,error region)
1204 :     val localtyvars = (ftyvars ++ etvs) -- (tvs --- etvs)
1205 :     val downtyvars = localtyvars ++ (tvs --- etvs)
1206 :     in tvref := TS.elements localtyvars;
1207 :     app (fn f => f downtyvars) updts
1208 :     end
1209 :     fun makefb (v as VALvar{path=SymPath.SPATH[_],...},cs) =
1210 :     ({var=v,clauses=cs, tyvars=tvref})
1211 :     | makefb _ = bug "makeFUNdec.makefb"
1212 :     in EU.checkUniq(error region, "duplicate function names in fun dec",
1213 :     (map (fn (VALvar{path=SymPath.SPATH[x],...},_) => x
1214 :     | _ => bug "makeFUNdec:checkuniq")
1215 :     fbs1));
1216 :     (let val (ndec, nenv) =
1217 :     FUNdec(completeMatch,map makefb fbs1,region,compInfo)
1218 :     in showDec("elabFUNdec: ",ndec,nenv);
1219 :     (ndec, nenv, TS.empty, updt)
1220 :     end)
1221 :     end
1222 :    
1223 :     and elabSEQdec(ds,env,rpath:IP.path,region) =
1224 :     let val (ds1,env1,tv1,updt1) =
1225 :     foldl
1226 :     (fn (decl2,(ds2,env2,tvs2,updt2)) =>
1227 :     let val (d3,env3,tvs3,updt3) =
1228 :     elabDec'(decl2,SE.atop(env2,env),rpath,region)
1229 :     in (d3::ds2, SE.atop(env3,env2),
1230 :     union(tvs3,tvs2,error region), updt3::updt2)
1231 :     end)
1232 :     ([],SE.empty,TS.empty,[]) ds
1233 :     fun updt tv : unit = app (fn f => f tv) updt1
1234 :     in (SEQdec(rev ds1),env1,tv1,updt)
1235 :     end
1236 :    
1237 :     val _ = debugmsg ("EC.elabDec calling elabDec' - foo")
1238 :     val (dec',env',tyvars,tyvUpdate) = elabDec'(dec,env,rpath,region)
1239 :    
1240 :     in tyvUpdate tyvars;
1241 :     (dec',env')
1242 :    
1243 :     end (* function elabDec *)
1244 :    
1245 :     end (* top-level local *)
1246 :     end (* structure ElabCore *)

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