Deprecated: The each() function is deprecated. This message will be suppressed on further calls in /home/zhenxiangba/zhenxiangba.com/public_html/phproxy-improved-master/index.php on line 456
-- syntax of While type Var = String data AExpr = Var Var | Num Integer | AExpr :+ AExpr | AExpr :- AExpr | AExpr :* AExpr data BExpr = T | F | AExpr :== AExpr | AExpr :<= AExpr | Not BExpr | BExpr :&& BExpr | BExpr :|| BExpr data Stm = Var ::= AExpr | Skip | Stm :\ Stm | If BExpr Stm Stm | While BExpr Stm -- semantic categories for denotational semantics {- type Store = Var -> Integer empty :: Store empty x = error ("variable " ++ x ++ " has no value") -- empty x = undefined lkp :: Var -> Store -> Integer lkp x st = st x upd :: Var -> Integer -> Store -> Store upd x n st = st' where st' x' | x' == x = n | otherwise = st x' -} type Store = [(Var, Integer)] empty :: [(a, b)] empty = [] lkp :: Eq a => a -> [(a,b)] -> b lkp x [] = undefined lkp x ((x',n) : st) = if x' == x then n else lkp x st upd :: Eq a => a -> b -> [(a,b)] -> [(a,b)] upd x n [] = [(x, n)] upd x n ((x', m) : st) = if x' == x then (x', n) : st else (x', m) : upd x n st -- syntax of AM data Inst = Push Integer | Add | Mult | Sub | TT | FF | EQ | LE | And | Neg | Fetch Var | Store Var | Branch Code Code | Loop Code deriving (Eq, Show) data Value = I Integer | B Bool instance Show Value where --show :: Value -> String show (I n) = show n show (B b) = show b type Code = [Inst] type Stack = [Value] type Conf = (Code, Stack, Store) -- operation of AM trans :: Conf -> Conf trans (Push n : c, vs, st) = (c, I n : vs, st) trans (Add : c, I n1 : I n2 : vs, st) = (c, I (n2 + n1) : vs, st) trans (Mult : c, I n1 : I n2 : vs, st) = (c, I (n2 * n1) : vs, st) trans (Sub : c, I n1 : I n2 : vs, st) = (c, I (n2 - n1) : vs, st) trans (TT : c, vs, st) = (c, B True : vs, st) trans (FF : c, vs, st) = (c, B False : vs, st) trans (EQ : c, I n1 : I n2 : vs, st) = (c, B (n2 == n1) : vs, st) trans (LE : c, I n1 : I n2 : vs, st) = (c, B (n2 <= n1) : vs, st) trans (And : c, B b1 : B b2 : vs, st) = (c, B (b2 && b1) : vs, st) trans (Neg : c, B b : vs, st) = (c, B (not b) : vs, st) trans (Fetch x : c, vs, st) = (c, I (lkp x st) : vs, st) trans (Store x : c, I n : vs, st) = (c, vs, upd x n st) trans (Branch c1 c2 : c, B True : vs, st) = (c1 ++ c, vs, st) trans (Branch c1 c2 : c, B False : vs, st) = (c2 ++ c, vs, st) trans (Loop cc : c, vs, st) = (Branch (cc ++ [Loop cc]) [] : c, vs, st) {- run :: Conf -> Conf run conf = case conf of ([], _, _) -> conf (_ : _, _, _) -> run (trans conf) -} run :: Conf -> IO Conf run conf = do printconf conf case conf of ([], _, _) -> return conf (_ : _, _, _) -> run (trans conf) printconf :: Conf -> IO () printconf (c, vs, st) = do print vs print st if c == [] then putStrLn "done" else print (head c) -- compilation compA :: AExpr -> Code compA (Var x) = [Fetch x] compA (Num n) = [Push n] compA (a1 :+ a2) = compA a1 ++ compA a2 ++ [Add] compA (a1 :* a2) = compA a1 ++ compA a2 ++ [Mult] compA (a1 :- a2) = compA a1 ++ compA a2 ++ [Sub] compB :: BExpr -> Code compB T = [TT] compB F = [FF] compB (a1 :== a2) = compA a1 ++ compA a2 ++ [EQ] compB (a1 :<= a2) = compA a1 ++ compA a2 ++ [LE] compB (b1 :&& b2) = compB b1 ++ compB b2 ++ [And] compB (Not b) = compB b ++ [Neg] compS :: Stm -> Code compS (x ::= a) = compA a ++ [Store x] compS Skip = [] compS (s1 :\ s2) = compS s1 ++ compS s2 compS (If b s1 s2) = compB b ++ [Branch (compS s1) (compS s2)] compS (While b s) = compB b ++ [Loop (compS s ++ compB b)] fact :: Stm fact = ("y" ::= Num 1) :\ (While (Not (Var "x" :== Num 1)) (("y" ::= (Var "y" :* Var "x")) :\ ("x" ::= (Var "x" :- Num 1)) ) ) {- testfact :: Integer -> (Integer, Integer) testfact n = case run (compS fact, [], upd "x" n empty) of (_, _, st) -> (lkp "x" st, lkp "y" st) -} testfact :: Integer -> IO () testfact n = do run (compS fact, [], upd "x" n empty) return () -- a more realistic abstract machine AM' type Label = Integer data Inst' = Push' Integer | Add' | Mult' | Sub' | TT' | FF' | EQ' | LE' | And' | Neg' | Fetch' Var | Store' Var | JumpF Label | Jump Label | Halt deriving (Eq, Show) type Code' = [(Label, Inst')] -- write trans, run for AM' trans' :: Inst' -> (Label, Stack, Store) -> (Label, Stack, Store) trans' (Push' n) (l, vs, st) = (l + 1, I n : vs, st) trans' Add' (l, I n1 : I n2 : vs, st) = (l + 1, I (n2 + n1) : vs, st) trans' Mult' (l, I n1 : I n2 : vs, st) = (l + 1, I (n2 * n1) : vs, st) trans' Sub' (l, I n1 : I n2 : vs, st) = (l + 1, I (n2 - n1) : vs, st) trans' TT' (l, vs, st) = (l + 1, B True : vs, st) trans' FF' (l, vs, st) = (l + 1, B False : vs, st) trans' EQ' (l, I n1 : I n2 : vs, st) = (l + 1, B (n2 == n1) : vs, st) trans' LE' (l, I n1 : I n2 : vs, st) = (l + 1, B (n2 <= n1) : vs, st) trans' And' (l, B b1 : B b2 : vs, st) = (l + 1, B (b2 && b1) : vs, st) trans' Neg' (l, B b : vs, st) = (l + 1, B (not b) : vs, st) trans' (Fetch' x) (l, vs, st) = (l + 1, I (lkp x st) : vs, st) trans' (Store' x) (l, I n : vs, st) = (l + 1, vs, upd x n st) trans' (JumpF l') (l, B True : vs, st) = (l + 1, vs, st) trans' (JumpF l') (l, B False : vs, st) = (l', vs, st) trans' (Jump l') (l, vs, st) = (l', vs, st) run' :: Code' -> (Label, Stack, Store) -> (Stack, Store) run' code (l, vs, st) = case lkp l code of Halt -> (vs, st) instr -> run' code (trans' instr (l, vs, st)) -- write a converter from AM code to AM' code convert :: Code -> Code' convert code = c' ++ [(l', Halt)] where (c', l') = convert' code 0 convert' :: Code -> Label -> (Code', Label) convert' [] l = ([], l) convert' (Branch c1 c2 : c) l = (((l, JumpF (l1 + 1)) : c1') ++ ((l1, Jump l2) : c2') ++ c', l') where (c1', l1) = convert' c1 (l + 1) (c2', l2) = convert' c2 (l1 + 1) (c', l') = convert' c l2 convert' (Loop c0 : c) l = (((l, JumpF (l0 + 1)) : c0') ++ ((l0, Jump l) : c'), l') where (c0', l0) = convert' c0 (l + 1) (c', l') = convert' c (l0 + 1) convert' (instr : c) l = ((l, prime instr) : c', l') where (c', l') = convert' c (l + 1) prime :: Inst -> Inst' prime (Push n) = Push' n prime Add = Add' prime Mult = Mult' prime Sub = Sub' prime TT = TT' prime FF = FF' prime EQ = EQ' prime LE = LE' prime And = And' prime Neg = Neg' prime (Fetch x) = Fetch' x prime (Store x) = Store' x testfact' :: Integer -> (Stack, Store) testfact' n = run' (convert (compS fact)) (0, [], upd "x" n empty)