1 2 -- ==========================================================-- 3 -- === Reduction of abstract expressions ===-- 4 -- === AbstractEval2.hs ===-- 5 -- ==========================================================-- 6 7 module AbstractEval2 where 8 import BaseDefs 9 import Utils 10 import MyUtils 11 import AbstractVals2 12 import Apply 13 14 -- ==========================================================-- 15 -- 16 aeEval :: HExpr Naam -> HExpr Naam 17 18 aeEval (HVar _) = panic "aeEval(1)" 19 aeEval (HLam _ _) = panic "aeEval(2)" 20 aeEval (HTable _) = panic "aeEval(3)" 21 22 aeEval h@(HPoint _) = h 23 24 aeEval (HMeet es) = HPoint (foldr1 (\/) (map aeEvalConst es)) 25 26 aeEval (HApp (HTable t) e2) 27 = aeEval (utSureLookup t "aeEval(5)" (aeEvalConst e2)) 28 29 aeEval (HVAp (HPoint f) es) 30 = HPoint (apApply f (map aeEvalConst es)) 31 32 aeEval (HApp f@(HApp _ _) someArg) 33 = aeEval (HApp (aeEval f) someArg) 34 35 aeEval (HApp f@(HPoint _) e) 36 = aeEval (HVAp f [e]) 37 38 aeEval x = panic "aeEval(4)" 39 40 41 -- ==========================================================-- 42 -- 43 aeEvalConst :: HExpr Naam -> Route 44 45 aeEvalConst e 46 = case aeEval e of {HPoint p -> p; _ -> panic "aeEvalConst"} 47 48 49 -- ==========================================================-- 50 -- 51 aeEvalExact :: HExpr Naam -> [HExpr Naam] -> Route 52 53 aeEvalExact (HLam vs e) args 54 = case aeEval (aeSubst (myZip2 vs args) e) of 55 {HPoint p -> p; _ -> panic "aeEvalExact"} 56 57 58 -- ==========================================================-- 59 -- 60 aeSubst :: AList Naam (HExpr Naam) -> HExpr Naam -> HExpr Naam 61 62 aeSubst rho (HVar v) = utSureLookup rho "aeSubst" v 63 aeSubst rho h@(HPoint p) = h 64 aeSubst rho (HLam _ _) = panic "aeSubst(1)" 65 aeSubst rho (HMeet es) = HMeet (map (aeSubst rho) es) 66 aeSubst rho (HTable t) = HTable (map2nd (aeSubst rho) t) 67 aeSubst rho (HApp e1 e2) = HApp (aeSubst rho e1) (aeSubst rho e2) 68 aeSubst rho (HVAp f es) = HVAp (aeSubst rho f) (map (aeSubst rho) es) 69 70 71 -- ==========================================================-- 72 -- 73 aeMkMeet :: HExpr Naam -> [HExpr Naam] -> HExpr Naam 74 75 aeMkMeet bottom [] = bottom 76 aeMkMeet bottom [x] = x 77 aeMkMeet bottom xs = HMeet xs 78 79 80 -- ==========================================================-- 81 -- === end AbstractEval2.hs ===-- 82 -- ==========================================================--