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

SCM Repository

[smlnj] Annotation of /sml/trunk/src/compiler/Semant/elaborate/elabcore.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/Semant/elaborate/elabcore.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 675 - (view) (download)

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

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