-----------------------------------------------------------------------------
--
--                       Compiling Exceptions Correctly
--
--                        Graham Hutton and Joel Wright
--                          University of Nottingham
--
--                                February 2005
--
-----------------------------------------------------------------------------



-----------------------------------------------------------------------------
-- Expressions
-----------------------------------------------------------------------------

data Expr                       =  Val Int | Add Expr Expr |
                                   Throw | Catch Expr Expr
                                   deriving Show

eval                            :: Expr -> Maybe Int
eval (Val n)                    =  Just n
eval (Add x y)                  =  case eval x of
                                      Nothing -> Nothing
                                      Just n  -> case eval y of
                                         Nothing -> Nothing
                                         Just m  -> Just (n+m)
eval (Throw)                    =  Nothing
eval (Catch x h)                =  case eval x of
                                      Nothing -> eval h
                                      Just n  -> Just n

-----------------------------------------------------------------------------
-- Compiler
-----------------------------------------------------------------------------

type Code                       =  [Op]

data Op                         =  PUSH Int | ADD | THROW | MARK Code | UNMARK
                                   deriving Show

comp                            :: Expr -> Code
comp (Val n)                    =  [PUSH n]
comp (Add x y)                  =  comp x ++ comp y ++ [ADD]
comp (Throw)                    =  [THROW]
comp (Catch x h)                =  [MARK (comp h)] ++ comp x ++ [UNMARK]

-----------------------------------------------------------------------------
-- Virtual machine
-----------------------------------------------------------------------------

type Stack                      =  [Item]

data Item                       =  VAL Int | HAN Code
                                   deriving Show

exec                            :: Stack -> Code -> Stack
exec s []                       =  s
exec s (PUSH n : ops)           =  exec (VAL n : s) ops
exec s (ADD : ops)              =  case s of
                                      (VAL m : VAL n : s') ->
                                         exec (VAL (n+m) : s') ops
exec s (THROW : ops)            =  unwind s (skip ops)
exec s (MARK ops' : ops)        =  exec (HAN ops' : s) ops
exec s (UNMARK : ops)           =  case s of
                                      (x : HAN _ : s') ->
                                         exec (x:s') ops

unwind                          :: Stack -> Code -> Stack
unwind []             _         =  []
unwind (VAL _    : s) ops       =  unwind s ops
unwind (HAN ops' : s) ops       =  exec s (ops' ++ ops)

skip                            :: Code -> Code
skip []                         =  []
skip (UNMARK : ops)             =  ops
skip (MARK _ : ops)             =  skip (skip ops)
skip (_      : ops)             =  skip ops

-----------------------------------------------------------------------------