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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 177 - (download) (annotate)
Sat Nov 7 22:42:44 1998 UTC (20 years, 11 months ago) by monnier
File size: 44648 byte(s)
Initial revision
(* Copyright 1996 by AT&T Bell Laboratories *)
(* elabcore.sml *)

signature ELABCORE =
sig

  val elabABSTYPEdec :
        {abstycs: Ast.db list,withtycs: Ast.tb list,body: Ast.dec} 
        * StaticEnv.staticEnv * ElabUtil.context * (Types.tycon -> bool)
        * InvPath.path * SourceMap.region * ElabUtil.compInfo
        -> Absyn.dec * StaticEnv.staticEnv (* * Modules.entityEnv ??? *)

  val elabDec : 
        Ast.dec * StaticEnv.staticEnv * (Types.tycon -> bool)
        * InvPath.path * SourceMap.region * ElabUtil.compInfo
        -> Absyn.dec * StaticEnv.staticEnv

  val debugging : bool ref

end (* signature ELABCORE *)


structure ElabCore: ELABCORE =
struct

local structure EM = ErrorMsg
      structure SP = SymPath
      structure IP = InvPath
      structure SE = StaticEnv
      structure LU = Lookup
      structure V = VarCon
      structure B  = Bindings
      structure M  = Modules
      structure MU = ModuleUtil
      structure T  = Types
      structure TU = TypesUtil
      structure BT = BasicTypes
      structure EE = EntityEnv
      structure EU = ElabUtil
      structure ED = ElabDebug
      structure TS = TyvarSet
      structure ET = ElabType
      structure S = Symbol
      structure II = InlInfo
      structure A = Access

      open Absyn Ast BasicTypes Access ElabUtil Types VarCon
   (*
      open BasicTypes Symbol Absyn Ast PrintUtil AstUtil BasicTypes TyvarSet
           Types EqTypes TypesUtil Access ElabUtil
    *)
in

val say = Control.Print.say
val debugging = ref false
fun debugmsg (msg: string) = if !debugging then (say msg; say "\n") else ()
fun bug msg = ErrorMsg.impossible("ElabCore: "^msg)

val debugPrint = (fn x => ED.debugPrint debugging x)

fun showDec(msg,dec,env) =
(*    ED.withInternals(fn () => *)
      debugPrint(msg,
		 (fn pps => fn dec =>
		   PPAbsyn.ppDec (env,NONE) pps (dec, 100)),
		 dec)(* ) *)

infix -->

(* tyvarset management *)
type tyvUpdate = TS.tyvarset -> unit
val --- = TS.diffPure
val union = TS.union
val diff = TS.diff
fun no_updt (_ : TS.tyvarset) = ()
fun noTyvars (dec,env) = (dec,env,TS.empty,no_updt)
infix ++ -- ---

fun stripExpAbs (MARKexp(e,_)) = stripExpAbs e
  | stripExpAbs (CONSTRAINTexp(e,_)) = stripExpAbs e
  | stripExpAbs e = e

fun stripExpAst(MarkExp(e,r'),r) = stripExpAst(e,r')
  | stripExpAst(ConstraintExp{expr=e,...},r) = stripExpAst(e,r)
  | stripExpAst(SeqExp[e],r) = stripExpAst(e,r)
  | stripExpAst(FlatAppExp[{item,region,...}],r) = stripExpAst(item,region)
  | stripExpAst x = x

val internalSym = S.varSymbol "<InternalVar>"

val dummyFNexp =
    FNexp([RULE(WILDpat,RAISEexp(CONexp(V.bogusEXN,[]),UNDEFty))],UNDEFty)

(* LAZY *)
(* clauseKind: used for communicating information about lazy fun decls
   between preprocessing phase (makevar) and main part of elabFUNdec *)
datatype clauseKind = STRICT | LZouter | LZinner

(* capture the  ":=" and "!" VALvars from PrimEnv.primEnv 
 *  These VALvars are used in lrvbMakeY.
 *  Perhaps PrimEnv should just export these VALvars. *)
val dummyComplainer = (fn _ => fn _ => fn _ => ())
val assignVar = 
    case LU.lookVal(PrimEnv.primEnv,SP.SPATH[S.strSymbol "InLine",S.varSymbol ":="],
		    dummyComplainer)
      of V.VAL v => v
       | _ => bug "lazy 1"
val bangVar = 
    case LU.lookVal(PrimEnv.primEnv,SP.SPATH[S.strSymbol "InLine",S.varSymbol "!"],
		    dummyComplainer)
      of V.VAL v => v
       | _ => bug "lazy 2"
val assignExp = VARexp(ref assignVar,[])
val bangExp = VARexp(ref bangVar,[])


(**** ABSTRACT TYPE DECLARATIONS ****)
fun elabABSTYPEdec({abstycs,withtycs,body},env,context,isFree,
                   rpath,region,compInfo) =
  let val (datatycs,withtycs,_,env1) =
        ET.elabDATATYPEdec({datatycs=abstycs,withtycs=withtycs}, env,
                           [], EE.empty, isFree, rpath, region, compInfo)

      val (body,env2) = 
        elabDec(body,Env.atop(env1,env),isFree,rpath,region,compInfo)

      (* datatycs will be changed to abstycs during type checking
	 by changing the eqprop field *)
      fun bind (x, e) = Env.bind(TU.tycName x, B.TYCbind x, e)
      val envt = foldl bind (foldl bind Env.empty datatycs) withtycs 

   in (ABSTYPEdec{abstycs=datatycs,withtycs=withtycs,body=body},
       Env.atop(env2,envt))
  end (* function elabABSTYPEdec *)


(**** ELABORATE GENERAL (core) DECLARATIONS ****)
and elabDec (dec, env, isFree, rpath, region,
             compInfo as {mkLvar=mkv,error,errorMatch,coreEnv,...}) =

let
    val _ = debugmsg ">>ElabCore.elabDec"

    val completeMatch = EU.completeMatch(coreEnv,"Match")
    val _ = debugmsg "--ElabCore.elabDec << completeBind Match"
    val completeBind = EU.completeMatch(coreEnv,"Bind")
    val _ = debugmsg "--ElabCore.elabDec << completeBind Bind"

    fun newVALvar s = V.mkVALvar(s, A.namedAcc(s, mkv))


    (* LAZY: utilities for lazy sml translation *)
  
    (* will one forcingFun do, or should new ones be generated with
     * different bound variables for each use? (DBM) *)

    fun forceExp e = 
	let val v = newVALvar(S.varSymbol "x")
	 in APPexp(FNexp(completeMatch[RULE(APPpat(BT.dollarDcon,[],VARpat v),
				     VARexp(ref v,[]))],
			 UNDEFty),
		   e)
	     (* DBM: second arg of APPpat and VARexp = nil and 
	      * of FNexp = UNDEFty ok? *)
	end

    fun delayExp e = 
	APPexp(CONexp(BT.dollarDcon,[]), e)

    (* lrvbMakeY n: build declaration of n-ary Y combinator for lazy val rec *)
    fun lrvbMakeY n =
	let fun upto 0 = []
	      | upto n = n::(upto (n-1))
	    val base = rev(upto n)  (* [1,2,...,n] *)
	    fun repeat f = map f base

	    fun hold e = delayExp(forceExp e)

	    (* capture Match exn from coreEnv as a random exn for use internally
	       in the Y combinator definition *)
	    val exn = EU.getCoreExn(coreEnv,"Match")

	    (* val exn = V.bogusEXN (* see if this will work? *) *)

	    (* Y variable and local variables ri and fi and d *)
	    val yvar (* as VALvar{path,typ,access,info} *) =
		newVALvar(S.varSymbol("Y$"^(Int.toString n)))
	    fun mkVarSym s i = newVALvar(S.varSymbol(s^(Int.toString i)))
	    val rvars = repeat(mkVarSym "r$")
	    val fvars = repeat(mkVarSym "f$")
	    val dvar  = newVALvar(S.varSymbol "d$")

	    (* "ref($(raise Match))" *)
	    fun rdrExp _ = APPexp(CONexp(BT.refDcon,[]),
				  delayExp(RAISEexp(CONexp(exn,[]),UNDEFty)))
	    val rpat  = TUPLEpat (map VARpat rvars)
	    val rexp  = TUPLEexp (repeat rdrExp)
	    val rdec  = VALdec([VB{pat=rpat, exp=rexp, boundtvs=[], tyvars=ref[]}])

	    (* "$(force(!ri))" *)
	    fun dfbr rv = hold(APPexp(bangExp,VARexp(ref rv,[])))
	    val ddec  = VALdec[VB{pat=VARpat dvar, exp=TUPLEexp(map dfbr rvars),
				  boundtvs=[],tyvars=ref[]}]

	    fun dexp () = VARexp(ref dvar,[])
	    fun setrExp (rv,fv) =
		APPexp(assignExp,
		       TUPLEexp([VARexp(ref rv,[]),
				 hold(APPexp(VARexp(ref fv,[]),dexp()))]))
	    val updates = ListPair.map setrExp (rvars,fvars)

	    val yexp = FNexp(completeMatch
			       [RULE(TUPLEpat(map VARpat fvars),
				     LETexp(SEQdec[rdec,ddec],
					    SEQexp(updates@[dexp()])))],
			     UNDEFty)

	 in (yvar,VALdec[VB{pat=VARpat yvar, exp=yexp, boundtvs=[], tyvars=ref[]}])
	end (* fun lrvbMakeY *)


    (**** EXCEPTION DECLARATIONS ****)

    fun elabEb (region:region) (env:SE.staticEnv) (eb:Ast.eb) =
	case eb
	  of EbGen{exn=id,etype=NONE} =>
	       let val exn =
		     DATACON{name=id, const=true, typ=exnTy, lazyp=false,
			     rep=EXN(LVAR(mkv(SOME id))), sign=CNIL}
		in ([EBgen{exn=exn, etype=NONE, 
                           ident=STRINGexp(S.name id)}], 
		    Env.bind(id, B.CONbind exn, Env.empty),TS.empty)
	       end
	   | EbGen{exn=id,etype=SOME typ} =>
	       let val (ty,vt) = ET.elabType(typ,env,error,region)
		   val exn = 
                     DATACON{name=id, const=false, typ=(ty --> exnTy), lazyp=false,
			     rep=EXN(LVAR(mkv(SOME id))), sign=CNIL}
		in ([EBgen{exn=exn,etype=SOME ty,
			   ident=STRINGexp(S.name id)}],
		    Env.bind(id,B.CONbind exn, Env.empty),vt) 
	       end
	   | EbDef{exn=id,edef=qid} =>
	       let val edef as DATACON{const,typ,sign,...} =
		     LU.lookExn(env,SP.SPATH qid,error region)
                   val nrep = EXN(LVAR(mkv(SOME id)))
	           val exn = DATACON{name=id, const=const, typ=typ, lazyp=false,
                                     sign=sign, rep=nrep}
		in ([EBdef{exn=exn,edef=edef}],
		    Env.bind(id,B.CONbind exn,Env.empty),TS.empty)
	       end
	   | MarkEb(eb,region) => elabEb region env eb

    fun elabEXCEPTIONdec(excbinds:Ast.eb list, env: SE.staticEnv, region) =
	let val (ebs,env,vt) = 
	      foldl
		(fn (exc1,(ebs1,env1,vt1)) =>
		   let val (eb2,env2,vt2) = elabEb region env exc1
		    in (eb2@ebs1, Env.atop(env2,env1),
                        union(vt1,vt2,error region))
		   end)
		 ([],Env.empty,TS.empty) excbinds
	    fun getname(EBgen{exn=DATACON{name,...},...}) = name
	      | getname(EBdef{exn=DATACON{name,...},...}) = name
	 in EU.checkUniq (error region, "duplicate exception declaration",
		       map getname ebs);
	    (EXCEPTIONdec(rev ebs),env,vt,no_updt)
	end


    (**** PATTERNS ****)

    fun apply_pat (MarkPat(c,(l1,r1)),MarkPat(p,(l2,r2))) = 
	  MarkPat(AppPat{constr=c, argument=p},(Int.min(l1,l2),Int.max(r1,r2)))
      | apply_pat (c ,p) = AppPat{constr=c, argument=p}

    fun tuple_pat (MarkPat(a,(l,_)),MarkPat(b,(_,r))) =
	  MarkPat(TuplePat[a,b],(l,r))
      | tuple_pat (a,b) = TuplePat[a,b]

    val patParse = Precedence.parse{apply=apply_pat, pair=tuple_pat}

    exception FreeOrVars
    fun elabPat(pat:Ast.pat, env:SE.staticEnv, region:region) 
		 : Absyn.pat * TS.tyvarset =
      case pat
      of WildPat => (WILDpat, TS.empty)
       | VarPat path => 
	   (clean_pat (error region) 
              (pat_id(SP.SPATH path, env, error region, compInfo)),
	    TS.empty)
       | IntPat s => (INTpat(s,TU.mkLITERALty(T.INT,region)),TS.empty)
       | WordPat s => (WORDpat(s,TU.mkLITERALty(T.WORD,region)),TS.empty)
       | StringPat s => (STRINGpat s,TS.empty)
       | CharPat s => (CHARpat s,TS.empty)
       | RecordPat {def,flexibility} =>
	    let val (lps,tyv) = elabPLabel region env def
	    in (makeRECORDpat (lps,flexibility,error region),tyv) end
       | ListPat nil =>
	      (NILpat, TS.empty)
       | ListPat (a::rest) =>
	    let val (p, tyv) = elabPat(TuplePat[a,ListPat rest], env, region)
	     in (CONSpat p, tyv)
	    end
       | TuplePat pats =>
	    let val (ps,tyv) = elabPatList(pats, env, region)
	     in (TUPLEpat ps,tyv)
	    end
       | VectorPat pats =>
	    let val (ps,tyv) = elabPatList(pats, env, region)
	    in (VECTORpat(ps,UNDEFty),tyv) end
       | OrPat pats =>
         (* Check that the sub-patterns of an or-pattern have exactly the same
          * free variables, and rewrite the sub-pattersn so that all instances
          * of a given free variable have the same type ref and the same 
          * access.
          *)
	   let val (ps, tyv) = elabPatList(pats, env, region)
	       fun freeOrVars (pat::pats) =
		   let val tbl : (access * ty ref * int) IntStrMap.intstrmap =
			   IntStrMap.new(16, FreeOrVars)
		       fun symbToIntStr f symb =
			   (f tbl (S.number symb, S.name symb))
		       val ins =
			   let val ins' = IntStrMap.add tbl
			    in fn (symb, x) =>
				 ins' (S.number symb, S.name symb, x)
			   end
		       val look =
			   let val look' = IntStrMap.map tbl
			    in fn symb => 
			         look'(S.number symb, S.name symb)
			   end
		       fun errorMsg x = 
			     error region EM.COMPLAIN
			       ("variable " ^ x ^
			        " does not occur in all branches of or-pattern")
			       EM.nullErrorBody
		       fun insFn (id, access, ty) =
			   (ins(id, (access, ty, 1)); (access,ty))
		       fun bumpFn (id, access0, ty0) =
			   (let val (access, ty, n) = look id
			     in ins (id, (access, ty, n+1)); (access,ty)
			    end
			    handle FreeOrVars => 
				    (errorMsg(S.name id); (access0,ty0)))
		       fun checkFn (id, access0, ty0) = 
                           (let val (access, ty, _) = look id 
                             in (access, ty) 
                            end
			    handle FreeOrVars => 
				   (errorMsg(S.name id); (access0, ty0)))
		       fun doPat(insFn: (S.symbol*access*ty ref)
                                          ->access*ty ref) =
			   let fun doPat' (VARpat(VALvar{access, info, path, 
                                                         typ})) =
				     let val (access,typ) = 
					 insFn(SymPath.first path,access,typ)
				      in VARpat(VALvar{access=access, 
                                                       path=path,info=info,
						       typ=typ})
				     end
				 | doPat' (RECORDpat{fields, flex, typ}) =
				     RECORDpat
				       {fields = 
                                            map (fn (l, p) => (l, doPat' p))
						     fields,
					flex = flex, typ = typ}
				 | doPat' (APPpat(dc, ty, pat)) =
				     APPpat(dc, ty, doPat' pat)
				 | doPat' (CONSTRAINTpat(pat, ty)) =
				     CONSTRAINTpat(doPat' pat, ty)
				 | doPat' (LAYEREDpat(p1, p2)) =
				     LAYEREDpat(doPat' p1, doPat' p2)
				 | doPat' (ORpat(p1, p2)) =
				     ORpat(doPat' p1, doPat checkFn p2)
				 | doPat' (VECTORpat(pats, ty)) =
				     VECTORpat(map doPat' pats, ty)
				 | doPat' pat = pat
			      in doPat'
			     end
		     (* check that each variable occurs in each sub-pattern *)
		       fun checkComplete m (_, id, (_, _, n)) =
			   if (n = m) then () else (errorMsg id)
		       val pats = (doPat insFn pat) :: 
                                      (map (doPat bumpFn) pats)
		    in IntStrMap.app (checkComplete (length pats)) tbl;
		       pats
		   end (* freeOrVars *)
	       val (pat::pats) = freeOrVars ps
	       fun foldOr (p, []) = p
		 | foldOr (p, p'::r) = ORpat(p, foldOr(p', r))
	    in (foldOr(pat, pats), tyv)
	   end
       | AppPat {constr, argument} =>
	   let fun getVar (MarkPat(p,region),region') = getVar(p,region)
		 | getVar (VarPat path, region') = 
		      let val dcb = pat_id (SP.SPATH path, env, 
                                            error region', compInfo)
			  val (p,tv) = elabPat(argument, env, region)
		      in (makeAPPpat (error region) (dcb,p),tv) end
		 | getVar (_, region') = 
		   (error region' EM.COMPLAIN 
			 "non-constructor applied to argument in pattern"
			 EM.nullErrorBody;
		    (WILDpat,TS.empty))
	    in getVar(constr,region)
	   end
       | ConstraintPat {pattern=pat,constraint=ty} =>
	   let val (p1,tv1) = elabPat(pat, env, region)
	       val (t2,tv2) = ET.elabType(ty,env,error,region)
	    in (CONSTRAINTpat(p1,t2), union(tv1,tv2,error region))
	   end
       | LayeredPat {varPat,expPat} =>
	   let val (p1,tv1) = elabPat(varPat, env, region)
	       val (p2,tv2) = elabPat(expPat, env, region)
	    in (makeLAYEREDpat(p1,p2,error region),union(tv1,tv2,error region))
	   end
       | MarkPat (pat,region) =>
	   let val (p,tv) = elabPat(pat, env, region)
	    in (p,tv)
	   end
       | FlatAppPat pats => elabPat(patParse(pats,env,error), env, region) 

    and elabPLabel (region:region) (env:SE.staticEnv) labs =
	foldl
	  (fn ((lb1,p1),(lps1,lvt1)) => 
	      let val (p2,lvt2) = elabPat(p1, env, region)
	      in ((lb1,p2) :: lps1, union(lvt2,lvt1,error region)) end)
	  ([],TS.empty) labs

    and elabPatList(ps, env:SE.staticEnv, region:region) =
	foldr
	  (fn (p1,(lps1,lvt1)) => 
	      let val (p2,lvt2) = elabPat(p1, env, region)
	      in (p2 :: lps1, union(lvt2,lvt1,error region)) end)
	  ([],TS.empty) ps


    (**** EXPRESSIONS ****)

    val expParse = Precedence.parse
		     {apply=fn(f,a) => AppExp{function=f,argument=a},
		      pair=fn (a,b) => TupleExp[a,b]}

    fun elabExp(exp: Ast.exp, env: SE.staticEnv, region: region) 
		: (Absyn.exp * TS.tyvarset * tyvUpdate) =
	(case exp
	  of VarExp path =>
	       ((case LU.lookVal(env,SP.SPATH path,error region)
		  of V.VAL v => VARexp(ref v,[])  
		   | V.CON(d as DATACON{lazyp,const,...}) =>
		      if lazyp then  (* LAZY *)
		        if const then delayExp(CONexp(d,[]))
			else let val var = newVALvar(S.varSymbol "x")
			      in FNexp(completeMatch
				        [RULE(VARpat(var),
					      delayExp(
					        APPexp(CONexp(d,[]),
						       VARexp(ref(var),[]))))],
				       UNDEFty (* DBM: ? *))
			     end
		      else CONexp(d, [])), 
		TS.empty, no_updt)
	   | IntExp s => 
               (INTexp(s,TU.mkLITERALty(T.INT,region)),TS.empty,no_updt)
           | WordExp s => 
               (WORDexp(s,TU.mkLITERALty(T.WORD,region)),TS.empty,no_updt)
	   | RealExp r => (REALexp r,TS.empty,no_updt)
	   | StringExp s => (STRINGexp s,TS.empty,no_updt)
	   | CharExp s => (CHARexp s,TS.empty,no_updt)
	   | RecordExp cells => 
	       let val (les,tyv,updt) = elabELabel(cells,env,region)
		in (makeRECORDexp (les,error region),tyv,updt)
	       end
	   | SeqExp exps =>
	       (case exps
		  of [e] => elabExp(e,env,region)
		   | [] => bug "elabExp(SeqExp[])"
		   | _ =>
		     let val (es,tyv,updt) = elabExpList(exps,env,region)
		      in (SEQexp es,tyv,updt)
		     end)
	   | ListExp nil => (NILexp, TS.empty, no_updt)
	   | ListExp (a::rest) =>
	       let val (e,tyv,updt) = 
                     elabExp(TupleExp[a,ListExp rest],env,region)
		in (APPexp(CONSexp,e), tyv, updt)
	       end
	   | TupleExp exps =>
	       let val (es,tyv,updt) = elabExpList(exps,env,region)
		in (TUPLEexp es,tyv,updt)
	       end
	   | VectorExp exps =>
	       let val (es,tyv,updt) = elabExpList(exps,env,region)
		in (VECTORexp(es,UNDEFty),tyv,updt)
	       end
	   | AppExp {function,argument} =>
	       let val (e1,tv1,updt1) = elabExp(function,env,region)
		   and (e2,tv2,updt2) = elabExp(argument,env,region)
		   fun updt tv = (updt1 tv;updt2 tv)
		in (APPexp (e1,e2),union(tv1,tv2,error region),updt)
	       end
	   | ConstraintExp {expr=exp,constraint=ty} =>
	       let val (e1,tv1,updt) = elabExp(exp,env,region)
		   val (t2,tv2) = ET.elabType(ty,env,error,region)
		in (CONSTRAINTexp(e1,t2), union(tv1,tv2,error region),updt)
	       end
	   | HandleExp {expr,rules} =>
	       let val (e1,tv1,updt1) = elabExp(expr,env,region)
		   val (rls2,tv2,updt2) = elabMatch(rules,env,region)
		   fun updt tv = (updt1 tv;updt2 tv)
		in (makeHANDLEexp (e1, rls2, compInfo), 
                    union(tv1,tv2,error region), updt)
	       end
	   | RaiseExp exp =>
	       let val (e,tyv,updt) = elabExp(exp,env,region)
		in (RAISEexp(e,UNDEFty),tyv,updt)
	       end
	   | LetExp {dec,expr} => 
	       let val (d1,e1,tv1,updt1) =
			  elabDec'(dec,env,IP.IPATH[],region)
		   val (e2,tv2,updt2) = elabExp(expr,Env.atop(e1,env),region)
		   fun updt tv = (updt1 tv;updt2 tv)
		in (LETexp(d1,e2), union(tv1,tv2,error region),updt)
	       end
	   | CaseExp {expr,rules} =>
	       let val (e1,tv1,updt1) = elabExp(expr,env,region)
		   val (rls2,tv2,updt2) = elabMatch(rules,env,region)
		   fun updt tv = (updt1 tv;updt2 tv)
		in (CASEexp (e1,completeMatch rls2, true),
		    union(tv1,tv2,error region),updt)
	       end
	   | IfExp {test,thenCase,elseCase} =>
	       let val (e1,tv1,updt1) = elabExp(test,env,region)
		   and (e2,tv2,updt2) = elabExp(thenCase,env,region)
		   and (e3,tv3,updt3) = elabExp(elseCase,env,region)
		   fun updt tv = (updt1 tv;updt2 tv;updt3 tv)
		in (IFexp(e1,e2,e3),
		    union(tv1,union(tv2,tv3,error region),error region),
		    updt)
	       end
	   | AndalsoExp (exp1,exp2) =>
	       let val (e1,tv1,updt1) = elabExp(exp1,env,region)
		   and (e2,tv2,updt2) = elabExp(exp2,env,region)
		   fun updt tv = (updt1 tv;updt2 tv)
		in (IFexp(e1, e2, FALSEexp), union(tv1,tv2,error region),updt)
	       end
	   | OrelseExp (exp1,exp2) =>
	       let val (e1,tv1,updt1) = elabExp(exp1,env,region)
		   and (e2,tv2,updt2) = elabExp(exp2,env,region)
		   fun updt tv = (updt1 tv;updt2 tv)
		in (IFexp(e1 ,TRUEexp, e2), union(tv1,tv2,error region),updt)
	       end
	   | WhileExp {test,expr} =>
	       let val (e1,tv1,updt1) = elabExp(test,env,region)
		   and (e2,tv2,updt2) = elabExp(expr,env,region)
		   fun updt tv = (updt1 tv;updt2 tv)
		in (WHILEexp(e1,e2,compInfo), 
                    union(tv1,tv2,error region), updt)
	       end
	   | FnExp rules => 
	       let val (rls,tyv,updt) = elabMatch(rules,env,region)
		in (FNexp (completeMatch rls,UNDEFty),tyv,updt)
	       end
	   | MarkExp (exp,region) => 
	       let val (e,tyv,updt) = elabExp(exp,env,region)
		in (if !Control.markabsyn then MARKexp(e,region) else e,
                    tyv, updt)
	       end
	   | SelectorExp s => 
	       (let val v = newVALvar s
		 in FNexp(completeMatch
			  [RULE(RECORDpat{fields=[(s,VARpat v)], flex=true,
					  typ= ref UNDEFty},
				MARKexp(VARexp(ref v,[]),region))],UNDEFty)
		end,
		TS.empty, no_updt)
	   | FlatAppExp items => elabExp(expParse(items,env,error),env,region))


    and elabELabel(labs,env,region) =
	let val (les1,lvt1,updt1) =
	      foldr 
		(fn ((lb2,e2),(les2,lvt2,updts2)) => 
		    let val (e3,lvt3,updt3) = elabExp(e2,env,region)
		     in ((lb2,e3) :: les2, union(lvt3,lvt2,error region),
			 updt3 :: updts2)
		    end)
		([],TS.empty,[]) labs
	    fun updt tv : unit = app (fn f => f tv) updt1
	 in (les1, lvt1, updt)
	end

    and elabExpList(es,env,region) =
	let val (les1,lvt1,updt1) =
	      foldr 
		(fn (e2,(es2,lvt2,updts2)) => 
		    let val (e3,lvt3,updt3) = elabExp(e2,env,region)
		     in (e3 :: es2, union(lvt3,lvt2,error region), 
                         updt3 :: updts2)
		    end)
		([],TS.empty,[]) es
	    fun updt tv: unit = app (fn f => f tv) updt1
	 in (les1, lvt1, updt)
	end

    and elabMatch(rs,env,region) =
	let val (rs,lvt,updt1) =
	      foldr 
		(fn (r1,(rs1,lvt1,updt1)) => 
		    let val (r2,lvt2,updt2) = elabRule(r1,env,region)
		     in (r2 :: rs1, union(lvt2,lvt1,error region), 
                         updt2::updt1) 
                    end)
		([],TS.empty,[]) rs
	    fun updt tv: unit = app (fn f => f tv) updt1
	 in (rs, lvt, updt)
	end

    and elabRule(Rule{pat,exp},env,region)  =
	let val region' = case pat of MarkPat (p,reg) => reg | _ => region
	    val (p,tv1) = elabPat(pat, env, region)
	    val env' = Env.atop(bindVARp ([p],error region'), env)
	    val (e,tv2,updt) = elabExp(exp,env',region)
	 in (RULE(p,e),union(tv1,tv2,error region),updt)
	end


    (**** SIMPLE DECLARATIONS ****)

    and elabDec'(dec,env,rpath,region)
		: (Absyn.dec * SE.staticEnv * TS.tyvarset * tyvUpdate) =
	(case dec 
	  of TypeDec tbs => 
	      let val (dec', env') =
		  ET.elabTYPEdec(tbs,env,(* EU.TOP,??? *) rpath,region,compInfo)
	       in noTyvars(dec', env')
	      end
	   | DatatypeDec(x as {datatycs,withtycs}) => 
	     (case datatycs
		of (Db{rhs=(Constrs _), ...}) :: _ =>
		     let val (dtycs, wtycs, _, env') =
			 ET.elabDATATYPEdec(x,env,[],EE.empty,isFree,
                                            rpath,region,compInfo)
		      in noTyvars(DATATYPEdec{datatycs=dtycs,withtycs=wtycs}, env')
		     end
	         | (Db{tyc=name,rhs=Repl syms,tyvars=nil,lazyp=false}::nil) =>
		     (* LAZY: not allowing "datatype lazy t = datatype t'" *)
		     (* BUG: what to do if rhs is lazy "datatype"? (DBM) *)
		     (case withtycs
			of nil =>
			    let val tyc = LU.lookTyc(env, SP.SPATH syms,
						    error region)
				val dcons = TU.extractDcons tyc
				val envDcons =
				     foldl (fn (d as T.DATACON{name,...},e)=>
					       SE.bind(name,B.CONbind d, e))
					   SE.empty 
					   dcons
				val env = SE.bind(name,B.TYCbind tyc,envDcons)
			     in noTyvars(DATATYPEdec{datatycs=[tyc], withtycs=[]},
					 env)
			    end
			 | _ => (error region EM.COMPLAIN
				  "withtype not allowed in datatype replication"
				  EM.nullErrorBody;
				 noTyvars(SEQdec[],SE.empty)))
		  | _ => (error region EM.COMPLAIN
			   "argument type variables in datatype replication"
			   EM.nullErrorBody;
			  noTyvars(SEQdec[],SE.empty)))
	   | AbstypeDec x => 
	      let val (dec', env') =
  		    elabABSTYPEdec(x,env,EU.TOP,isFree,
                                   rpath,region,compInfo)
	       in noTyvars(dec', env')
	      end
	   | ExceptionDec ebs => elabEXCEPTIONdec(ebs,env,region)
	   | ValDec(vbs,explicitTvs) =>
	       elabVALdec(vbs,explicitTvs,env,rpath,region)
	   | FunDec(fbs,explicitTvs) =>
	       elabFUNdec(fbs,explicitTvs,env,rpath,region)
	   | ValrecDec(rvbs,explicitTvs) =>
	       elabVALRECdec(rvbs,explicitTvs,env,rpath,region)
	   | SeqDec ds => elabSEQdec(ds,env,rpath,region)
	   | LocalDec ld => elabLOCALdec(ld,env,rpath,region)
	   | OpenDec ds => elabOPENdec(ds,env,region)
	   | FixDec (ds as {fixity,ops}) => 
	       let val env = 
		 foldr (fn (id,env) => Env.bind(id,B.FIXbind fixity,env))
			Env.empty ops
		in (FIXdec ds,env,TS.empty,no_updt)
	       end
	   | OvldDec dec  => elabOVERLOADdec(dec,env,rpath,region)
	   | MarkDec(dec,region') =>
	       let val (d,env,tv,updt)= elabDec'(dec,env,rpath,region')
		in (if !Control.markabsyn then MARKdec(d,region') else d,
		    env,tv,updt)
	       end
	   | StrDec _ => bug "strdec"
	   | AbsDec _ => bug "absdec"
	   | FctDec _ => bug "fctdec"
	   | SigDec _ => bug "sigdec"
	   | FsigDec _ => bug "fsigdec")
              

    (**** OVERLOADING ****)

    and elabOVERLOADdec((id,typ,exps),env,rpath,region) =
	let val (body,tyvars) = ET.elabType(typ,env,error,region)
	    val tvs = TS.elements tyvars
	    val scheme = (TU.bindTyvars tvs; TU.compressTy body;
			  TYFUN{arity=length tvs, body=body})
	    fun option (MARKexp(e,_)) = option e
	      | option (VARexp(ref (v as VALvar{typ,...}),_)) =
		  {indicator = TU.matchScheme(scheme,!typ), variant = v}
	      | option _ = bug "makeOVERLOADdec.option"
	    val exps = map (fn exp => elabExp(exp,env,region)) exps
	    val exps1 = map #1 exps
	    and exps3 = map #3 exps
	    fun updt tv: unit = app (fn f => f tv) exps3
	    val ovldvar = OVLDvar{name=id,scheme=scheme,
				  options=ref(map option exps1)}
	 in (OVLDdec ovldvar, Env.bind(id,B.VALbind ovldvar,Env.empty),
             TS.empty, updt)
	end

    (**** LOCAL ****)

    and elabLOCALdec((ldecs1,ldecs2),env,rpath:IP.path,region) =
	let val (ld1,env1,tv1,updt1) = elabDec'(ldecs1,env,IP.IPATH[],region)
	    val (ld2,env2,tv2,updt2) =
		  elabDec'(ldecs2,Env.atop(env1,env),rpath,region)
	    fun updt tv = (updt1 tv;updt2 tv)
	 in (LOCALdec(ld1,ld2), env2,union(tv1,tv2,error region),updt)
	end

    (**** OPEN ****)

    and elabOPENdec(spaths, env, region) = 
        let val err = error region
            val strs = map (fn s => let val sp = SP.SPATH s
                                     in (sp, LU.lookStr(env, sp, err))
                                    end) spaths

            fun loop([], env) = (OPENdec strs, env, TS.empty, no_updt)
              | loop((_, s)::r, env) = loop(r, MU.openStructure(env, s))

         in loop(strs, SE.empty)
        end 

    (****  VALUE DECLARATIONS ****)
    and elabVB (MarkVb(vb,region),etvs,env,_) =
	  elabVB(vb,etvs,env,region)
      | elabVB (Vb{pat,exp,lazyp},etvs,env,region) =
	  let val (pat,pv) = elabPat(pat, env, region)
	      val (exp,ev,updtExp) = elabExp(exp,env,region)
	      val exp = if lazyp  (* LAZY *)
		        then delayExp(forceExp exp)
			else exp
	      val tvref = ref []
	      fun updt tv: unit =
		let fun a++b = union(a,b,error region)
                    fun a--b = diff(a,b,error region)
		    val localtyvars = (ev++pv++etvs) -- (tv---etvs)
			 (* etvs should be the second argument to union
			  * to avoid having the explicit type variables
			  * instantiated by the union operation. *)
		    val downtyvars = localtyvars ++ (tv---etvs)
		 in tvref := TS.elements localtyvars; updtExp downtyvars
	        end

              (* 
               * WARNING: the following code is trying to propagate the 
               * PRIMOP access through simple value binding. It is a old
               * hack and should be cleaned up in the future. (ZHONG)
	       * This won't apply if lazyp=true. (DBM)
               *)
	      val pat = 
		case stripExpAbs exp
		 of VARexp(ref(VALvar{info=dinfo,...}),_) =>
                      (if II.isPrimInfo(dinfo) then
		        (case pat
			  of CONSTRAINTpat(VARpat(VALvar{path,typ,
                                                         access,...}), ty) =>
			      CONSTRAINTpat(VARpat(
                                   VALvar{path=path, typ=typ, access=access,
                                          info=dinfo}), ty)
			   | VARpat(VALvar{path, typ, access, ...}) =>
			      VARpat(VALvar{path=path, typ=typ, access=access,
                                            info=dinfo})
			   | _ => pat)
                       else pat)
		  | _ => pat

	      (* DBM: can the first two cases ever return NONE? *)
              fun bindpat(VARpat(VALvar{access=acc, ...})) = A.accLvar acc
                | bindpat(CONSTRAINTpat(VARpat(VALvar{access=acc, ...}),_)) = 
                      A.accLvar acc
                | bindpat _ = NONE

	   in case bindpat(pat) 
               of NONE => (* DBM: pattern is not a variable? *)
		(let val (newpat,oldvars,newvars) = patproc(pat, compInfo)
		         (* this is the only call of patproc *)
                     val b = map (fn v => VARexp(ref v,[])) newvars 
		     val r = RULE(newpat, TUPLEexp(b))
                     val newexp = CASEexp(exp, completeBind[r], false)

                  in case oldvars
                      of [] => 
                           (let val nvb = VB{exp=newexp, tyvars=tvref,
                                             pat=WILDpat, boundtvs=[]}
                             in (VALdec [nvb], [], updt)
                            end)
                       | _ => 
                           (let val nv = newVALvar internalSym
                                val nvpat = VARpat(nv)
                                val nvexp = VARexp(ref nv, [])

                                val nvdec = 
                                  VALdec([VB{exp=newexp, tyvars=tvref, 
                                             pat=nvpat, boundtvs=[]}])

                                fun h([], _, d) =  
                                      LOCALdec(nvdec, SEQdec(rev d))
                                  | h(vp::r, i, d) = 
                                      let val nvb = VB{exp=TPSELexp(nvexp,i),
                                                       pat=vp, boundtvs=[],
                                                       tyvars=ref[]}

                                       in h(r, i+1, VALdec([nvb])::d)
                                      end

                             in (h(oldvars, 1, []), oldvars, updt)
                            end)
                 end)
               | SOME _ => 
                   (VALdec([VB{exp=exp, tyvars=tvref, pat=pat, boundtvs=[]}]),
                    [pat], updt) 
	  end

    and elabVALdec(vb,etvs,env,rpath,region) =
       let val etvs = ET.elabTyvList(etvs,error,region)
	   val (ds,pats,updt1) = 
	      foldr 
		(fn (vdec,(ds1,pats1,updt1)) => 
		   let val etvs = TS.mkTyvarset(map T.copyTyvar etvs)
		       val (d2,pats2,updt2) = elabVB(vdec,etvs,env,region)
		    in (d2::ds1,pats2@pats1,updt2::updt1) 
                   end)
		([],[],[]) vb
	    fun updt tv : unit = app (fn f => f tv) updt1
	in (SEQdec ds, bindVARp (pats,error region), TS.empty, updt)
       end

    and elabRVB(MarkRvb(rvb,region),env,_) = elabRVB(rvb,env,region)
      | elabRVB(Rvb{var,fixity,exp,resultty,lazyp},env,region) =
         (case stripExpAst(exp,region)
	    of (FnExp _,region')=>
	        let val (e,ev,updt) = elabExp(exp,env,region')
		    val (t,tv) = 
			case resultty 
			  of SOME t1 => 
			       let val (t2,tv2) = ET.elabType(t1,env,error,region)
				in (SOME t2,tv2)
			       end
			   | NONE => (NONE,TS.empty)
		 in case fixity 
		      of NONE => ()
		       | SOME(f,region) => 
			 (case LU.lookFix(env,f) 
			   of Fixity.NONfix => ()
			    | _ =>
			      error region EM.COMPLAIN
			        ("infix symbol \""^ S.name f ^
				 "\" used where a nonfix identifier was expected")
				EM.nullErrorBody);
		    ({match = e , ty = t, name=var},
		     union(ev,tv,error region),updt)
		end
	     | _ =>
		(error region EM.COMPLAIN
		  "fn expression required on rhs of val rec"
		  EM.nullErrorBody;
		 ({match = dummyFNexp, ty = NONE, name = var},TS.empty,no_updt)))

    and elabVALRECstrict(rvbs,etvs,env,region) = 
	let val env' = ref(SE.empty: SE.staticEnv)
	    fun makevar region (p as Rvb{var,...}) =
		  let val v = newVALvar var
                      val nv = newVALvar var (* DBM: what is this for? *)
		   in (* checkBoundConstructor(env,var,error region); -- fix bug 1357 *)
		      env' := Env.bind(var,B.VALbind v,!env');
		      (v, p)
		  end
	      | makevar _ (p as MarkRvb(rvb,region)) = 
		  let val (v,_) = makevar region rvb in (v,p) end

	    val rvbs' = map (makevar region) rvbs
	    val env'' = Env.atop(!env', env)
	    val (rvbs,tyvars,updts)=
		foldl (fn((v,rvb1),(rvbs1,tvs1,updt1)) =>
			   let val (rvb2,tv2,updt2) =
				   elabRVB(rvb1,env'',region)
			    in ((v,rvb2)::rvbs1, 
				union(tv2,tvs1,error region),
				updt2::updt1)
			   end) 
			([],TS.empty,[]) rvbs' 
	    val tvref = ref []
	    fun updt tvs : unit =  
		let fun a++b = union(a,b,error region)
		    fun a--b = diff(a,b,error region)
		    val localtyvars = (tyvars ++ etvs) -- (tvs --- etvs)
		    val downtyvars = localtyvars ++ (tvs --- etvs)
		 in tvref := TS.elements localtyvars;
		    app (fn f => f downtyvars) updts
		end
	    val _ = EU.checkUniq(error region,
                        "duplicate function name in val rec dec",
  		        (map (fn (v,{name,...}) => name) rvbs))

            val (ndec, nenv) = 
  	        wrapRECdec((map (fn (v,{ty,match,name}) =>
				    RVB{var=v,resultty=ty,tyvars=tvref, exp=match,
					boundtvs=[]})
			        rvbs),
			   compInfo)
         in (ndec, nenv, TS.empty, updt)
	end (* fun elabVALRECstrict *)

    (* LAZY: "val rec lazy ..." *)
    and elabVALREClazy (rvbs,etvs,env,region) = 
	let fun split [] = ([],[])
	      | split ((Rvb {var,exp,resultty,lazyp,...})::xs) =
		 let val (a,b) = split xs in ((var,resultty)::a,(exp,lazyp)::b) end
	      | split ((MarkRvb (x,_))::xs) = split (x::xs) (* loosing regions *)

	    val (yvar,declY) = lrvbMakeY (length rvbs)

	    val (lhss,exps) = split rvbs
	    val argpat = TuplePat(map (fn (sym,NONE) => VarPat[sym]
					| (sym,SOME ty) =>
					    ConstraintPat{pattern=VarPat[sym],
							  constraint=ty})
				      lhss)

	    fun elabFn((exp,lazyp),(fexps,tvs,updts)) =
		let val (p,tv1) = elabPat(argpat, env, region)
		    val env' = Env.atop(bindVARp ([p],error region), env)
		    val (e,tv2,updt) = elabExp(exp,env',region)
		in (FNexp(completeMatch[RULE(p,if lazyp then e else delayExp e)],
			  UNDEFty)::fexps,
		    union(union(tv1,tv2,error region),tvs,error region),
		    updt::updts)
		end

	    val (fns,tyvars,updts) = foldr elabFn ([],TS.empty,[]) exps

	    val lhsSyms = map #1 lhss  (* left hand side symbols *)
	    val lhsVars = map newVALvar lhsSyms

	    (* copied from original elabVALRECdec *)
	    val tvref = ref []
	    fun updt tvs : unit =  
		let fun a++b = union(a,b,error region)
		    fun a--b = diff(a,b,error region)
		    val localtyvars = (tyvars ++ etvs) -- (tvs --- etvs)
		    val downtyvars = localtyvars ++ (tvs --- etvs)
		 in tvref := TS.elements localtyvars;
		    app (fn f => f downtyvars) updts
		end

	    val declAppY =
		VALdec[VB{pat=TUPLEpat(map VARpat lhsVars),
			  exp=APPexp(VARexp(ref yvar,[]),TUPLEexp fns),
			  tyvars=tvref,boundtvs=[]}]

	    fun forceStrict ((sym,var1,lazyp),(vbs,vars)) =
		  let val var2 = newVALvar sym
		      val vb = if lazyp
			       then VB{pat=VARpat var2, 
				       exp=VARexp (ref var1,[]),boundtvs=[],
				       tyvars=ref[]}
			       else VB{pat=APPpat(BT.dollarDcon,[],(VARpat var2)), 
				       exp=VARexp (ref var1,[]),boundtvs=[],
				       tyvars=ref[]}
		  in  (vb::vbs,var2::vars)
		  end

	    fun zip3(x::xs,y::ys,z::zs) = (x,y,z)::zip3(xs,ys,zs)
	      | zip3(nil,_,_) = nil

	    val (vbs,vars) =
		foldr forceStrict ([],[]) (zip3(lhsSyms,lhsVars,map #2 exps))

	    val env' = foldl (fn ((s,v),env) => SE.bind(s,B.VALbind v,env)) SE.empty
			     (ListPair.zip(lhsSyms,vars))

	    val absyn = LOCALdec(SEQdec[declY,declAppY],VALdec vbs)
	 in showDec("elabVALREClazy: ",absyn,env');
	    (absyn,env',TS.empty(*?*),updt)
	end (* fun elabVALREClazy *)

    and elabVALRECdec(rvbs: rvb list,etvs,env,rpath:IP.path,region) = 
	let val etvs = TS.mkTyvarset(ET.elabTyvList(etvs,error,region))
	    fun isLazy(Rvb{lazyp,...}) = lazyp
	      | isLazy(MarkRvb(rvb,_)) = isLazy rvb
         in if List.exists isLazy rvbs
	    then elabVALREClazy(rvbs,etvs,env,region)
	    else elabVALRECstrict(rvbs,etvs,env,region) 
	end

    and elabFUNdec(fb,etvs,env,rpath,region) =
	let val etvs = TS.mkTyvarset(ET.elabTyvList(etvs,error,region))
            (* makevar: parse the function header to determine the function name *)
	    fun makevar _ (MarkFb(fb,region),ctx) = makevar region (fb,ctx)
	      | makevar region (Fb(clauses,lazyp),(lcl,env')) =
		 let fun getfix(SOME f) = LU.lookFix(env,f)
		       | getfix NONE = Fixity.NONfix

		     fun ensureInfix{item,fixity,region} =
			 (case getfix fixity
			   of Fixity.NONfix =>
			        error region EM.COMPLAIN
			          "infix operator required, or delete parentheses" 
			          EM.nullErrorBody
			    | _ => ();
			  item)

		     fun ensureNonfix{item,fixity,region} =
			 (case (getfix fixity, fixity)
			   of (Fixity.NONfix,_) => ()
			    | (_,SOME sym) =>
			       error region EM.COMPLAIN
				 ("infix operator \"" ^ S.name sym ^
				  "\" used without \"op\" in fun dec")
				 EM.nullErrorBody;
			  item)

		     fun getname(MarkPat(p,region),_) = getname(p,region)
		       | getname(VarPat[v], _) = v
		       | getname(_, region) = 
                           (error region EM.COMPLAIN
			      "illegal function symbol in clause"
			      EM.nullErrorBody;
			    bogusID)

   	             fun parse'({item=FlatAppPat[a,b as {region,...},c],...}
                                ::rest) = 
			   (getname(ensureInfix b, region),
			    tuple_pat(ensureNonfix a, ensureNonfix c)
			     :: map ensureNonfix rest)
		       | parse' [{item,region,...}] = 
			   (error region EM.COMPLAIN
			      "can't find function arguments in clause"
			      EM.nullErrorBody;
			    (getname(item,region), [WildPat]))
		       | parse' ((a as {region,...}) :: rest) =
			   (getname(ensureNonfix a, region), 
			    map ensureNonfix rest)

		     fun parse({item=MarkPat(p,_),region,fixity}::rest) = 
			   parse({item=p,region=region,fixity=fixity}::rest)
		       | parse (pats as [a as {region=ra,...},
					 b as {item,fixity,region},c]) =
			   (case getfix fixity
			      of Fixity.NONfix => parse' pats
			       | _ => (getname(item,region),
				  [tuple_pat(ensureNonfix a, ensureNonfix c)]))
		       | parse pats = parse' pats

		     fun parseClause(Clause{pats,resultty,exp}) =
			 let val (funsym,argpats) = parse pats
			  in {kind=STRICT,funsym=funsym,argpats=argpats,
			      resultty=resultty,exp=exp}
			 end

		     val clauses as {funsym=var,...}::_ = 
                         map parseClause clauses

		     val _ = if List.exists (fn {funsym,...} => 
					not(S.eq(var,funsym))) clauses
			     then  error region EM.COMPLAIN 
				     "clauses don't all have same function name"
				     EM.nullErrorBody
			     else ()

(* DBM: fix bug 1357
		     val _ = checkBoundConstructor(env,var,error region)
*)
		     val v = newVALvar var

		     val argcount = 
			 case clauses
			   of ({argpats,...})::rest => 
				let val len = length argpats
				 in if List.exists
					(fn {argpats,...} => 
					      len <> length argpats) rest
				    then error region EM.COMPLAIN 
				   "clauses don't all have same number of patterns"
					  EM.nullErrorBody
				    else ();
				    len
				end
			    | [] => bug "elabFUNdec: no clauses"
		  in if lazyp (* LAZY *)
		     then let fun newArgs(args,0) = args
				| newArgs(args,n) = 
				  newArgs([S.varSymbol("$"^Int.toString n)]::args,
					  n-1)
			      fun curryApp (f,[]) = f
				| curryApp (f,x::xs) =
				  curryApp(AppExp{function=f, argument=x},xs)
			      val lazyvar = S.varSymbol(S.name var ^ "_")
			      val lv = newVALvar lazyvar
			      fun mkLazy(new,resty,[]) = (rev new,resty)
			        | mkLazy(new,resty,
					 {kind,funsym,argpats,resultty,exp}::rest) =
				  mkLazy({kind=LZinner,funsym=lazyvar,argpats=argpats,
					  resultty=NONE, (* moved to outer clause *)
					  exp=exp}
				         ::new,
				         case resty
					   of NONE => resultty
					    | _ => resty,
					 rest)
                              (* BUG: this captures the first resultty encountered,
			         if any, and discards the rest, not checking
				 consistency of redundant resultty constraints *)
			      val (innerclauses,resultty) =
				  mkLazy ([],NONE,clauses)
                              val outerargs = newArgs([],argcount)
			      val outerclause = 
				  {kind=LZouter, funsym=var, resultty=resultty,
				   argpats=map VarPat outerargs,
				   exp=curryApp(VarExp[lazyvar],
						     map VarExp outerargs)}
			   in ((lv,innerclauses,region)::(v,[outerclause],region)
			       ::lcl,
			       Env.bind(var,B.VALbind v,
					Env.bind(lazyvar,B.VALbind lv, env')))
			  end
		     else ((v,clauses,region)::lcl,Env.bind(var,B.VALbind v,env'))
		 end (* makevar *)
	    val (fundecs,env') = foldl (makevar region) ([],Env.empty) fb
	    val env'' = Env.atop(env',env)
	    fun elabClause(region,({kind,argpats,resultty,exp,funsym})) =
		let val (pats,tv1) = elabPatList(argpats, env, region)
                    val nenv = Env.atop(bindVARp(pats,error region), env'')
		    val (exp,tv2,updt) = elabExp(exp, nenv,region)
		    (* LAZY: wrap delay or force around rhs as appropriate*)
		    val exp = 
			case kind
			  of STRICT => exp
			   | LZouter => delayExp exp
			   | LZinner => forceExp exp
		    val (ty,tv3) =
		      case resultty
		       of NONE => (NONE,TS.empty)
			| SOME t => 
			    let val (t4,tv4) = ET.elabType(t,env,error,region)
			     in (SOME t4,tv4)
			    end
		 in ({pats=pats,resultty=ty,exp=exp},
		     union(tv1,union(tv2,tv3,error region),error region),updt)
		end
	    fun elabFundec ((var,clauses,region),(fs,tvs,updt)) = 
		let val (cs1,tvs1,updt1) =
		      foldl (fn (c2,(cs2,tvs2,updt2)) =>
			     let val (c3,tvs3,updt3) = elabClause(region,c2)
			      in (c3::cs2,union(tvs3,tvs2,error region),
				  updt3::updt2)
			     end) 
			  ([],TS.empty,[]) clauses
		 in ((var,rev cs1)::fs, union(tvs1,tvs,error region),
                     updt1 @ updt)
		end
	    val (fbs1,ftyvars,updts) = foldl elabFundec ([],TS.empty,[]) fundecs
	    val tvref = ref [] (* common tvref cell for all bindings! *)
	    fun updt tvs : unit =  
		let fun a++b = union(a,b,error region)
		    fun a--b = diff(a,b,error region)
		    val localtyvars = (ftyvars ++ etvs) -- (tvs --- etvs)
		    val downtyvars = localtyvars ++ (tvs --- etvs)
		 in tvref := TS.elements localtyvars;
		    app (fn f => f downtyvars) updts
		end
	    fun makefb (v as VALvar{path=SymPath.SPATH[_],...},cs) =
		  ({var=v,clauses=cs, tyvars=tvref})
	      | makefb _ = bug "makeFUNdec.makefb"
	 in EU.checkUniq(error region, "duplicate function names in fun dec",
		      (map (fn (VALvar{path=SymPath.SPATH[x],...},_) => x
			     | _ => bug "makeFUNdec:checkuniq")
			   fbs1));
	    (let val (ndec, nenv) = 
                   FUNdec(completeMatch,map makefb fbs1,region,compInfo)
              in showDec("elabFUNdec: ",ndec,nenv);
		 (ndec, nenv, TS.empty, updt)
             end)
	end

    and elabSEQdec(ds,env,rpath:IP.path,region) =
	let val (ds1,env1,tv1,updt1) = 
	      foldl 
	       (fn (decl2,(ds2,env2,tvs2,updt2)) =>
		  let val (d3,env3,tvs3,updt3) =
			   elabDec'(decl2,Env.atop(env2,env),rpath,region)
		   in (d3::ds2, Env.atop(env3,env2), 
                       union(tvs3,tvs2,error region), updt3::updt2)
		  end)
	       ([],Env.empty,TS.empty,[]) ds 
	    fun updt tv : unit = app (fn f => f tv) updt1
	 in (SEQdec(rev ds1),env1,tv1,updt)
	end

    val _ = debugmsg ("EC.elabDec calling elabDec' - foo")
    val (dec',env',tyvars,tyvUpdate) = elabDec'(dec,env,rpath,region)

 in tyvUpdate tyvars;
    (dec',env')

end (* function elabDec *)

end (* top-level local *)
end (* structure ElabCore *)

(*
 * $Log: elabcore.sml,v $
 * Revision 1.5  1998/08/19 18:17:11  dbm
 * bug fixes for 110.9 [dbm]
 *
 * Revision 1.4  1998/07/22 17:53:47  dbm
 * fix bug 1397 and other problems related to lazy decls
 *
 * Revision 1.3  1998/05/23 14:10:00  george
 *   Fixed RCS keyword syntax
 *
 *
 *)

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