-- | A single register imperative language.
module Imp where
import Prelude hiding (init)
--
-- * Syntax
--
-- $ Here's the syntax of the small imperative programming language, similar
-- to the language from Homework 4, after refactoring to eliminate the
-- potential for type errors.
--
-- int ::= (any integer)
--
-- reg ::= `A` | `B` | `R`
--
-- expr ::= int
-- | reg
-- | expr + expr
--
-- test ::= expr <= expr
-- | `not` test
--
-- stmt ::= reg := expr
-- | `while` test `do` stmt
-- | `begin` stmt* `end`
-- | Named registers.
data Reg = A | B | R
deriving (Eq,Show)
data Expr
= Lit Int
| Get Reg
| Add Expr Expr
deriving (Eq,Show)
data Test
= LTE Expr Expr
| Not Test
deriving (Eq,Show)
data Stmt
= Set Reg Expr
| While Test Stmt
| Begin [Stmt]
deriving (Eq,Show)
--
-- * Examples
--
-- Example program: double R until it is greater than 100.
-- begin
-- R := 1
-- while R <= 100 do
-- R := R + R
-- end
keepDoubling :: Stmt
keepDoubling =
Begin [
Set R (Lit 1),
While (LTE (Get R) (Lit 100))
(Set R (Add (Get R) (Get R)))
]
-- | Generate a program that multiplies two integers together.
genMult :: Int -> Int -> Stmt
genMult x y =
Begin [
Set A (Lit x)
, Set B (Lit y)
, Set R (Lit 0)
, While (Not (LTE (Get A) (Lit 0)))
(Begin [
Set R (Add (Get R) (Get B))
, Set A (Add (Get A) (Lit (-1)))
])
]
--
-- * Semantics
--
-- | The current values of the registers.
type State = (Int, Int, Int)
-- Semantic domains:
-- * expr: State -> Int
-- * test: State -> Bool
-- * stmt: State -> State
-- What if tests were part of the syntactic category of expressions
-- (like before refactoring the syntax in Homework 4)?
-- * expr: State -> Maybe (Either Int Bool)
-- * stmt: State -> Maybe State
-- | An initial state, for convenience.
init :: State
init = (0,0,0)
-- | Get the value of a register.
get :: Reg -> State -> Int
get A (a,_,_) = a
get B (_,b,_) = b
get R (_,_,r) = r
-- | Set the value of a register.
set :: Reg -> Int -> State -> State
set A i (_,b,r) = (i,b,r)
set B i (a,_,r) = (a,i,r)
set R i (a,b,_) = (a,b,i)
-- | Valuation function for expressions.
expr :: Expr -> State -> Int
expr (Lit i) = \s -> i
expr (Get r) = \s -> get r s
expr (Add l r) = \s -> expr l s + expr r s
-- | Valuation function for tests.
test :: Test -> State -> Bool
test (Not t) = \s -> not (test t s)
test (LTE l r) = \s -> expr l s <= expr r s
-- | Valuation function for statements.
stmt :: Stmt -> State -> State
stmt (Set r e) = \s -> set r (expr e s) s
stmt (While t b) = \s -> if test t s
then stmt (While t b) (stmt b s)
else s
stmt (Begin ss) = \s -> stmts ss s
-- stmt (Begin ss) = \s -> foldl (flip stmt) s ss
-- | Helper function for executing a sequence of statements.
stmts :: [Stmt] -> State -> State
stmts [] s = s
stmts (h:t) s = stmts t (stmt h s)
-- ** Regaining compositionality
-- | Compute least fix point. Defined in Data.Function.
fix f = let x = f x in x
-- | Compositional valuation function for statements using least fix point.
-- (Note that in Haskell this is exactly the same as the previous definition;
-- this is just illustrating what the compositional definition looks like.)
stmt' :: Stmt -> State -> State
stmt' (Set r e) = \s -> set r (expr e s) s
stmt' (While t b) = fix (\f s -> if test t s
then f (stmt' b s)
else s)
stmt' (Begin ss) = \s -> foldl (flip stmt') s ss