/exercise3/CESMachine.lhs

  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}