(* tr_env.ml: handling of the translation environment. *) open List Fnlib Mixture Const Prim Lambda Globals Units Types Asynt Asyntfn; type RenEnv = (string * int) list; datatype AccessPath =    Path_rec of int   | Path_local of int  | Path_global of (QualifiedIdent * int)  | Path_son of int * AccessPath  | Path_virtual_son of int * AccessPath; type TranslEnv = (Const.Id, AccessPath) Env * int;  fun lookupRenEnv asId q =  let val {qual, id = lid} = q       val id = (longIdentAsIdent lid "lookupRenEnv")      val mangled_id = mangle (asId id)  in (* cvr: TODO treat lond ids *)    if qual = "" then fatalError ("lookupRenEnv: empty qualifier for "^id)    else ();    if qual = currentUnitName() then      (mkUniqueGlobalName (mangled_id, Hasht.find (!currentRenEnv) (mangled_id))       handle Subscript => fatalError         ("lookupRenEnv: unknown variable: " ^ showQualId q))    else      ({qual=qual,id = [mangled_id]}, 0)  end; fun updateCurrentRenEnv RE =  app (fn (x,y) => Hasht.insert (!currentRenEnv) x y)      (rev RE); fun renameId id = (id, newValStamp()); (* Generating lambda expressions from access pahts *)local  (* cvr: TODO copied from Front.sml ---- code should be shared *)    fun mkDynexn exnname =	Lprim(Pmakeblock (CONtag(0,1)),	      [exnname, Lconst constUnit])    val bindExn  = 	mkDynexn (Lprim(Pget_global ({qual="General", id=["exn_bind"]}, 0), []));    val bindRaiser  = Lprim(Praise, [bindExn])infun translatePath depth = fn    Path_rec i => 	Llet([Lprim(Pfield 0,[Lvar (depth-(i+1))])],	     Lswitch(2,Lvar 0,		     [(CONtag(0,2),bindRaiser),		      (CONtag(1,2),Lprim(Pfield 0,[Lvar 0]))]))  | Path_local i => Lvar (depth-(i+1))  | Path_global uid => Lprim(Pget_global uid, [])  | Path_virtual_son(arity, p) =>      translatePath depth p  | Path_son(n, p)      => Lprim(Pfield n, [translatePath depth p])end fun translateTopOfPath depth = fn    Path_virtual_son(arity, Path_local i) =>      let val lvar = Lvar (depth-(i+1)) in        Lprim(Pmakeblock(CONtag(0,1)),              tabulate(arity, (fn n => Lprim(Pfield n, [lvar]))))      end  | Path_virtual_son(arity, p) =>      Llet([translatePath depth p],        Lprim(Pmakeblock(CONtag(0,1)),              tabulate(arity, (fn n => Lprim(Pfield n, [Lvar 0])))))  | p => translatePath depth p; fun translateLocalAccess asId (rho, depth) id =  translateTopOfPath depth (lookupEnv rho (asId id))  handle Subscript =>    fatalError ("translateLocalAccess"^id); fun lookupInLocalEnv asId env q =  let val {qual,id} = q in (* cvr: TODO handle long ids *)    if qual = "" orelse qual = currentUnitName() then      lookupEnv env (asId (longIdentAsIdent id "lookupInLocalEnv"))    else      raise Subscript  end; fun translateAccess asId (rho, depth) q =  translateTopOfPath depth (lookupInLocalEnv asId rho q)  handle Subscript =>    Lprim(Pget_global (lookupRenEnv asId q), []); (* cvr: added *) fun translateLongAccess asId env (ii:IdInfo) =     let val {info={idKind,idFields,...}, ...} = ii        val {qualid, ...} = !idKind    in     case qualid of        {qual,id=[]} => Lstruct []    |  {qual,id=[_]} => translateAccess asId env qualid    |  {qual,id} =>          let fun trLongAccess [id] _ =                     translateAccess ModId env {qual = qual,id = [id]}               | trLongAccess (id::ids) (field::fields) =                     Lprim(Pfield field, [trLongAccess ids fields])               | trLongAccess _ _ = fatalError "trLongAccess"         in trLongAccess id (!idFields)         end    end;  fun translateExName env (ii : IdInfo) =  let val {qualid, info} = ii in    case #info(!(#idKind info)) of        EXCONik _ =>          translateLongAccess ValId env ii      | _ => fatalError "translateExName"  end; fun pair x y = (x, y); fun pathsOfPatAcc path ((loc, pat') : Pat) acc =  case pat' of    SCONpat _ => acc  | VARpat ii =>      bindInEnv acc (ValId (hd(#id(#qualid ii)))) path  | WILDCARDpat => acc  | NILpat _ => acc  | CONSpat(ii, p) =>      let val ci = getConInfo ii in        if #conSpan(!ci) = 1 then          pathsOfPatAcc path p acc        else if #conIsGreedy(!ci) then          (if #conTag(!ci) = 0 then             pathsOfPatAcc path p acc           else             pathsOfPatAcc (Path_virtual_son(#conArity(!ci), path)) p acc)        else          pathsOfPatAcc (Path_son(0, path)) p acc      end  | EXNILpat _       => acc  | EXCONSpat(ii, p) => pathsOfPatAcc (Path_son(1, path)) p acc  | EXNAMEpat _      => fatalError "pathsOfPatAcc"  | REFpat p         => pathsOfPatAcc (Path_son(0, path)) p acc  | RECpat(ref (TUPLErp ps)) =>      foldR (fn(i,p) => fn acc => pathsOfPatAcc (Path_son(i,path)) p acc)            acc (mapFrom pair 0 ps)  | RECpat(ref (RECrp _)) =>      fatalError "pathsOfPatAcc: unresolved record pattern"  | VECpat ps =>      foldR (fn(i,p) => fn acc => pathsOfPatAcc (Path_son(i,path)) p acc)            acc (mapFrom pair 0 ps)  | INFIXpat _ => fatalError "pathsOfPatAcc"  | PARpat p         => pathsOfPatAcc path p acc  | TYPEDpat(p, _)   => pathsOfPatAcc path p acc  | LAYEREDpat(p1, p2) =>      pathsOfPatAcc path p1 (pathsOfPatAcc path p2 acc); fun pathsOfPat path pat = pathsOfPatAcc path pat NILenv; fun mutableVarsOfPatAcc ((loc, pat') : Pat) acc =  case pat' of    SCONpat _ => acc  | VARpat _ => acc  | WILDCARDpat => acc  | NILpat _ => acc  | CONSpat(_, p) =>      mutableVarsOfPatAcc p acc  | EXNILpat _ => acc  | EXCONSpat(ii, p) =>      mutableVarsOfPatAcc p acc  | EXNAMEpat _ => fatalError "mutableVarsOfPatAcc"  | REFpat p =>      domPatAcc p acc  | RECpat(ref (TUPLErp ps)) =>      foldR mutableVarsOfPatAcc acc ps  | RECpat(ref (RECrp _)) =>      fatalError "mutableVarsOfPatAcc: unresolved record pattern"  | VECpat ps =>      foldR mutableVarsOfPatAcc acc ps  | INFIXpat _ => fatalError "mutableVarsOfPatAcc"  | PARpat p =>      mutableVarsOfPatAcc p acc  | TYPEDpat(p, _) =>      mutableVarsOfPatAcc p acc  | LAYEREDpat(p1, p2) =>      mutableVarsOfPatAcc p1 (mutableVarsOfPatAcc p2 acc); (* Since the program is supposed to be well-typed, *)(* the patterns in a `val rec' can't contain mutable variables. *)(* Thus there's no danger in accessing variable values via *)(* their access paths... *) fun mkEnvOfRecPats depth pats =  foldL (fn pat => fn (rho, depth) =>           (pathsOfPatAcc (Path_local depth) pat rho, depth+1))        (NILenv, depth) pats; (* If a `val' declaration isn't recursive, the mutable variables *)(* appearing in its patterns must be taken special care of... *) fun mutableVarsOfPat pat = mutableVarsOfPatAcc pat []; fun addLetsToEnv varlist (env as (rho, depth)) =  case varlist of    [] => env  | var::rest =>      addLetsToEnv rest (bindInEnv rho (ValId var) (Path_local depth), depth+1); fun addLetsToExp varlist (rho, depth) exp =  case varlist of      [] => exp    | _ =>       Llet(mapFrom (fn i => fn var => translateLocalAccess ValId (rho, i) var)                    depth varlist,           exp); fun mkEnvOfPats depth pats =  let val env' = mkEnvOfRecPats depth pats      val mut_vars = foldR mutableVarsOfPatAcc [] pats  in (addLetsToEnv mut_vars env', addLetsToExp mut_vars env') end;