/exercise3/CESMachine.lhs
Haskell | 112 lines | 104 code | 8 blank | 0 comment | 0 complexity | efff94ec767675f62f8583d2717e6a7f MD5 | raw file
1\begin{code} 2 3module CESMachine where 4import Debug.Trace 5import qualified IntegerArithmetic as I 6import qualified DeBruijn as DB 7 8data Inst = Int Integer 9 | Bool Bool 10 | Bop BOP 11 | Bpr BPR 12 | Access Int 13 | Close Code 14 | Let 15 | EndLet 16 | Apply 17 | Return 18 | If 19 | Fix 20 deriving Show 21 22data BOP = Add | Sub | Mul | Div | Nand 23instance Show BOP where 24 show Add = "+" 25 show Sub = "-" 26 show Mul = "*" 27 show Div = "/" 28 show Nand = "^" 29 30data BPR = Eq | Lt 31instance Show BPR where 32 show Eq = "=" 33 show Lt = "<" 34 35type Code = [ Inst ] 36data Value = BoolVal Bool | IntVal Integer | Clo Code Env 37 deriving Show 38type Env = [Value] 39data Slot = Value Value | Code Code | Env Env 40 deriving Show 41type Stack = [Slot] 42type State = (Code, Env, Stack) 43compile :: DB.Term -> Code 44compile t = case t of 45 DB.Var n -> [Access n] 46 DB.IntConst n -> [Int n] 47 DB.Abs tp t0 -> case compile t0 of t1 -> [Close (t1 ++ [Return])] 48 DB.App t1 t2 -> case compile t1 of 49 t1' -> case compile t2 of 50 t2' -> t1' ++ t2' ++ [Apply] 51 DB.If t0 t1 t2 -> case compile t0 of 52 t0' -> case compile t1 of 53 t1' -> case compile t2 of 54 t2' -> t0' ++ t1' ++ t2' ++ [If] 55 DB.Tru -> [Bool True] 56 DB.Fls -> [Bool False] 57 DB.Fix t0 -> case compile t0 of t0' -> t0' ++ [Fix] 58 DB.Let t1 t2 -> case compile t1 of 59 t1' -> case compile t2 of 60 t2' -> t1' ++ [Let] ++ t2' ++ [EndLet] 61 62 DB.Bop bop t1 t2 -> case compile t1 of 63 t1' -> case compile t2 of 64 t2' -> case bop of 65 DB.Add -> t1' ++ t2' ++ [Bop Add] 66 DB.Sub -> t1' ++ t2' ++ [Bop Sub] 67 DB.Mul -> t1' ++ t2' ++ [Bop Mul] 68 DB.Div -> t1' ++ t2' ++ [Bop Div] 69 DB.Nand -> t1' ++ t2' ++ [Bop Nand] 70 71 DB.Bpr bpr t1 t2 -> case compile t1 of 72 t1' -> case compile t2 of 73 t2' -> case bpr of 74 DB.Eq -> t1' ++ t2' ++ [Bpr Eq] 75 DB.Lt -> t1' ++ t2' ++ [Bpr Lt] 76step :: State -> Maybe State 77step state = case state of 78 (Access i : c, e, s) -> Just (c, e,Value (e !! i) : s) 79 (If:c, e, s2:s1:(Value (BoolVal v0)):s) -> case v0 of 80 True -> Just(c, e, s1:s) 81 False -> Just(c, e, s2:s) 82 (Close code':code, env, s) -> Just(code, env, Env [Clo code' env]:s) 83 (Apply:code, env, (Value v):(Env [Clo code' env']):s) -> Just(code', v:env', (Code code):(Env env):s) 84 (Apply:code, env, (Value v):(Value (Clo code' env')):s) -> Just(code', v:env', (Code code):(Env env):s) 85 (Return:c, e, s':(Code c'):(Env e'):s) -> Just(c', e', s':s) 86 (Int n:c, e, s) -> Just(c, e, (Value (IntVal n)):s) 87 (Bool b:c, e, s) -> Just(c, e, (Value (BoolVal b)):s) 88 ((Bop bop):c, e, (Value (IntVal v2)):(Value (IntVal v1)):s) -> case bop of 89 Add -> Just (c, e, (Value (IntVal (I.intAdd v1 v2))):s) 90 Sub -> Just (c, e, (Value (IntVal (I.intSub v1 v2))):s) 91 Mul -> Just (c, e, (Value (IntVal (I.intMul v1 v2))):s) 92 Div -> Just (c, e, (Value (IntVal (I.intDiv v1 v2))):s) 93 Nand-> Just (c, e, (Value (IntVal (I.intNand v1 v2))):s) 94 ((Bpr bpr):c, e, (Value (IntVal v2)):(Value (IntVal v1)):s) -> case bpr of 95 Eq -> Just (c, e, (Value (BoolVal (I.intEq v1 v2))):s) 96 Lt -> Just (c, e, (Value (BoolVal (I.intLt v1 v2))):s) 97 (Let:code, env, (Value v):s) -> Just(code, v:env, s) 98 (Let:code, env, (Env env'):s) -> Just(code, env'++env, s) 99 (EndLet:code, v:env, s) -> Just(code, env, s) 100 (Fix:code, env, (Env [Clo code' env']):s) -> Just(code', (Clo [Close code', Fix] []):env, (Code code):(Env env):s) 101 _ -> Nothing 102loop :: State -> State 103loop state = 104 case step state of 105 Just state'-> loop state' 106 Nothing -> state 107 108eval :: DB.Term -> Value 109eval t = case loop (compile t, [], []) of 110 (_,_,Value v:_) -> v 111 _ -> error "not a value" 112\end{code}