Commit a5483bce authored by Sarah Müller's avatar Sarah Müller

added booleans, and, or and comparison operators

parent 8cf8d131
Pipeline #15476 failed with stages
in 9 minutes and 43 seconds
......@@ -13,7 +13,6 @@ module ConcreteInterpreter where
import Prelude hiding (id,fail,lookup,read)
import Data.Bits
-- import Data.Fixed
import Data.Hashable
-- import Data.List (replicate,repeat,find,splitAt)
......@@ -62,6 +61,9 @@ import GHC.Exts
import Data.Int
import Data.Bits
import Data.Word
import Data.Bool
--import Prelude.Num
import qualified Prelude as P
-- WRONG: use correct haskell types that implement the byte sizes of JVM types: https://docs.oracle.com/javase/specs/jls/se12/html/jls-4.html#jls-4.2
data Val
......@@ -77,6 +79,7 @@ data Val
| NullVal
| RefVal Addr
| ArrayVal [Val]
| BoolVal Bool
-- | ObjectVal String (Map FieldSignature Val)
deriving (Eq)
......@@ -93,6 +96,7 @@ instance Show Val where
show NullVal = "null"
show (RefVal a) = "@" ++ show a
show (ArrayVal xs) = show xs
show (BoolVal b) = show b
-- show (ObjectVal c m) = show c ++ "{" ++ show m ++ "}"
instance Hashable Val where
......@@ -149,6 +153,7 @@ instance (IsString err, ArrowFail err c, ArrowChoice c) => IsVal Val (ConcreteT
nullConstant = arr $ const NullVal
stringConstant = arr StringVal
classConstant = arr ClassVal
boolConstant = arr BoolVal
and = withBits (.&.)
or = withBits (.|.)
......@@ -161,13 +166,11 @@ instance (IsString err, ArrowFail err c, ArrowChoice c) => IsVal Val (ConcreteT
CharVal c -> returnA -< CharVal Data.Bits.complement c -- TEST: do we need "data.bits" or simply "Bits"?
_ -> fail -< "Expected a number as argument for -"
-- rem = withInt mod <+> withFloat mod'
-- shl = withInt shiftL
-- shr = withInt shiftR
-- ushr = withInt shiftR -- WRONG: This should be an unsigned shift.
-- unplus = withUnaryInt (+)
-- unminus = withUnaryInt (-)
neg = proc v -> case v of
ByteVal b -> returnA -< ByteVal (-b)
ShortVal s -> returnA -< ShortVal (-s)
......@@ -331,6 +334,51 @@ instance (IsString err, ArrowFail err c, ArrowChoice c) => IsVal Val (ConcreteT
-- ConstantCase n -> x == n
-- DefaultCase -> True
--instance (IsString err, ArrowFail err c, ArrowChoice c) => IsVal Val (ConcreteT c) where
--instance UseBool Bool Val Interp where
instance (IsString err, ArrowFail err c, ArrowChoice c) => UseBool Bool (ConcreteT c) where
--eq = arr (uncurry (==))
eq = proc (v1,v2,_) -> case (v1,v2) of
(NumVal n1,NumVal n2) -> returnA -< BoolVal (n1 P.== n2)
(BoolVal b1,BoolVal b2) -> returnA -< BoolVal (b1 P.== b2)
_ -> fail -< "Expected two values of the same type as arguments for 'eq'"
--neq = arr (uncurry (/=))
neq = proc (v1,v2,_) -> case (v1,v2) of
(NumVal n1,NumVal n2) -> returnA -< BoolVal (n1 P./= n2)
(BoolVal b1,BoolVal b2) -> returnA -< BoolVal (b1 P./= b2)
_ -> fail -< "Expected two values of the same type as arguments for 'neq'"
--gt = swap ^>> cmpNum id
gt = proc (v1,v2,_) -> case (v1,v2) of
(NumVal n1,NumVal n2) -> returnA -< BoolVal (n1 P.> n2)
(BoolVal b1,BoolVal b2) -> returnA -< BoolVal (b1 P.> b2)
_ -> fail -< "Expected two values of the same type as arguments for 'gt'"
--ge = cmpNum not
ge = proc (v1,v2,_) -> case (v1,v2) of
(NumVal n1,NumVal n2) -> returnA -< BoolVal (n1 P.>= n2)
(BoolVal b1,BoolVal b2) -> returnA -< BoolVal (b1 P.>= b2)
_ -> fail -< "Expected two values of the same type as arguments for 'ge'"
--lt = cmpNum id
lt = proc (v1,v2,_) -> case (v1,v2) of
(NumVal n1,NumVal n2) -> returnA -< BoolVal (n1 P.< n2)
(BoolVal b1,BoolVal b2) -> returnA -< BoolVal (b1 P.< b2)
_ -> fail -< "Expected two values of the same type as arguments for 'lt'"
--le = swap ^>> cmpNum not
le = proc (v1,v2,_) -> case (v1,v2) of
(NumVal n1,NumVal n2) -> returnA -< BoolVal (n1 P.<= n2)
(BoolVal b1,BoolVal b2) -> returnA -< BoolVal (b1 P.<= b2)
_ -> fail -< "Expected two values of the same type as arguments for 'le'"
--if_ f1 f2 = proc ((v,_),(x,y)) -> if v then f1 -< x else f2 -< y
if_ f1 f2 = proc ((v,_),(x,y)) -> case v of
BoolVal True -> f1 -< x
BoolVal False -> f2 -< y
_ -> fail -< "Expected boolean as argument for 'if'"
band = proc (v1,v2,_) -> case (v1,v2) of
(BoolVal b1,BoolVal b2) -> returnA -< BoolVal (b1 && b2)
_ -> fail -< "Expected two booleans as arguments for 'and'"
bor = proc (v1,v2,_) -> case (v1,v2) of
(BoolVal b1,BoolVal b2) -> returnA -< BoolVal (b1 || b2)
_ -> fail -< "Expected two booleans as arguments for 'or'"
-- instance UseException Exception Val Interp where
-- catch f = proc (ex,clauses) -> case ex of
-- StaticException _ -> fail -< ex
......@@ -344,15 +392,6 @@ instance (IsString err, ArrowFail err c, ArrowChoice c) => IsVal Val (ConcreteT
-- failDynamic = DynamicException ^>> fail
-- failStatic = StaticException ^>> fail
-- instance UseBool Bool Val Interp where
-- eq = arr (uncurry (==))
-- neq = arr (uncurry (/=))
-- gt = swap ^>> cmpNum id
-- ge = cmpNum not
-- lt = cmpNum id
-- le = swap ^>> cmpNum not
-- if_ f1 f2 = proc ((v,_),(x,y)) -> if v then f1 -< x else f2 -< y
-- instance UseEnv (Env String Addr) Interp where
-- emptyEnv = arr $ const E.empty
......@@ -401,9 +440,11 @@ withBits op =
-- (ShortVal x1,LongVal x2) -> returnA -< LongVal $ op x1 x2
-- (ShortVal x1,IntVal x2) -> returnA -< IntVal $ op x1 x2
-- (IntVal x1,LongVal x2) -> returnA -< LongVal $ op x1 x2
--TODO: Type can be Boolean?
_ -> fail -< "Expected integer variables for op"
--implement unary functions only if they are needed more than one time!
--withUnaryBits :: (IsString e, ArrowFail e c, ArrowChoice c) => (forall a. Bits a => a -> a) -> c (Val,Val) Val
--withUnaryBits op =
-- proc v -> case v of
......@@ -415,24 +456,24 @@ withBits op =
--
-- _ -> fail -< "Expected integer variables for op"
withInt :: (IsString e, ArrowFail e c, ArrowChoice c) => (Int -> Int -> Int) -> c (Val,Val) Val
withInt :: (IsString e, ArrowFail e c, ArrowChoice c) => (forall a. Num a => a -> a -> a) -> c (Val,Val) Val
withInt op =
proc (v1,v2) -> case (v1,v2) of
(ByteVal x1,ByteVal x2) -> returnA -< IntVal $ op x1 x2
(ShortVal x1,ShortVal x2) -> returnA -< IntVal $ op x1 x2
(IntVal x1,IntVal x2) -> returnA -< IntVal $ op x1 x2
(LongVal x1,LongVal x2) -> returnA -< LongVal $ op x1 x2
(CharVal x1,CharVal x2) -> returnA -< CharVal $ op x1 x2
(LongVal x1,IntVal x2) -> returnA -< LongVal $ op x1 x2
(LongVal x1,ShortVal x2) -> returnA -< LongVal $ op x1 x2
(LongVal x1,ByteVal x2) -> returnA -< LongVal $ op x1 x2
(LongVal x1,CharVal x2) -> returnA -< LongVal $ op x1 x2
(IntVal x1,ShortVal x2) -> returnA -< IntVal $ op x1 x2
(IntVal x1,ByteVal x2) -> returnA -< IntVal $ op x1 x2
(IntVal x1,CharVal x2) -> returnA -< IntVal $ op x1 x2
(ShortVal x1,ByteVal x2) -> returnA -< IntVal $ op x1 x2
(ShortVal x1,CharVal x2) -> returnA -< IntVal $ op x1 x2
(ByteVal x1,CharVal x2) -> returnA -< IntVal $ op x1 x2
(ByteVal x1,ByteVal x2) -> returnA -< IntVal $ op (fromInteger x1) (fromInteger x2)
(ShortVal x1,ShortVal x2) -> returnA -< IntVal $ op (fromInteger x1) (fromInteger x2)
(IntVal x1,IntVal x2) -> returnA -< IntVal $ op (fromInteger x1) (fromInteger x2)
(LongVal x1,LongVal x2) -> returnA -< LongVal $ op (fromLong x1) (fromLong x2)
(CharVal x1,CharVal x2) -> returnA -< CharVal $ op (fromInteger x1) (fromInteger x2)
(LongVal x1,IntVal x2) -> returnA -< LongVal $ op (fromLong x1) (fromInteger x2)
(LongVal x1,ShortVal x2) -> returnA -< LongVal $ op (fromLong x1) (fromInteger x2)
(LongVal x1,ByteVal x2) -> returnA -< LongVal $ op (fromLong x1) (fromInteger x2)
(LongVal x1,CharVal x2) -> returnA -< LongVal $ op (fromLong x1) (fromInteger x2)
(IntVal x1,ShortVal x2) -> returnA -< IntVal $ op (fromInteger x1) (fromInteger x2)
(IntVal x1,ByteVal x2) -> returnA -< IntVal $ op (fromInteger x1) (fromInteger x2)
(IntVal x1,CharVal x2) -> returnA -< IntVal $ op (fromInteger x1) (fromInteger x2)
(ShortVal x1,ByteVal x2) -> returnA -< IntVal $ op (fromInteger x1) (fromInteger x2)
(ShortVal x1,CharVal x2) -> returnA -< IntVal $ op (fromInteger x1) (fromInteger x2)
(ByteVal x1,CharVal x2) -> returnA -< IntVal $ op (fromInteger x1) (fromInteger x2)
_ -> fail -< "Expected integer variables for op"
--withUnaryInt :: (IsString e, ArrowFail e c, ArrowChoice c) => (Int -> Int) -> c (Val,Val) Val
......
......@@ -24,6 +24,7 @@ import Syntax
import GHC.Exts
import Data.Int
import Data.Bool
evalLiteral :: (ArrowChoice c,IsVal val c) => c Literal val
evalLiteral = proc i -> case i of
......@@ -38,6 +39,7 @@ evalLiteral = proc i -> case i of
NullConstant -> nullConstant -< ()
StringConstant s -> stringConstant -< s
ClassConstant c -> classConstant -< c
BoolConstant b -> boolConstant -< b
evalBool :: (ArrowChoice c,IsVal val c) => c BoolExpr val
evalBool = proc (BoolExpr i1 op i2) -> do
......@@ -50,6 +52,8 @@ evalBool = proc (BoolExpr i1 op i2) -> do
Cmpge -> ge -< (v1,v2)
Cmplt -> lt -< (v1,v2)
Cmple -> le -< (v1,v2)
Cmpand -> band -< (v1,v2) --boolean and
Cmpor -> bor -< (v1,v2) --boolean or
eval :: CanInterp env envval val exc err c => c Expr val
eval = proc e -> case e of
......@@ -95,10 +99,8 @@ eval = proc e -> case e of
v <- evalLiteral -< i
case op of
Complement -> complement -< v
UnaryMinus -> unminus -< v --TODO.
UnaryPlus -> unplus -< v --TODO.
-- Lengthof -> lengthOf -< v
-- Neg -> neg -< v -- is this unminus??
-- Neg -> neg -< v
-- LiteralExpr i -> evalLiteral -< i
-- MethodHandle _ -> failStatic -< "Evaluation of method handles is not implemented"
......@@ -234,6 +236,7 @@ class Arrow c => IsVal v c | c -> v where
nullConstant :: c () v
stringConstant :: c String v
classConstant :: c String v
boolConstant :: c Bool v
and :: c (v,v) v
or :: c (v,v) v
......@@ -242,18 +245,18 @@ class Arrow c => IsVal v c | c -> v where
rem :: c (v,v) v -- ??
cmp :: c (v,v) v -- ??
cmpg :: c (v,v) v -- ??
cmpl :: c (v,v) v -- ??
cmpl :: c (v,v) v -- complement of two float variables?
shl :: c (v,v) v --shift left?
shr :: c (v,v) v --shift right?
ushr :: c (v,v) v -- ??
unplus :: c v v --unary plus
unminus :: c v v --unary minus
--unplus :: c v v --unary plus
--unminus :: c v v --unary minus
plus :: c (v,v) v
minus :: c (v,v) v
mult :: c (v,v) v
div :: c (v,v) v
lengthOf :: c v v
neg :: c v v --same as unminus?
neg :: c v v --negative
eq :: c (v,v) v --equals
neq :: c (v,v) v --not equals
gt :: c (v,v) v --greater than
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment