diff options
| -rw-r--r-- | DSL.hs | 51 |
1 files changed, 48 insertions, 3 deletions
@@ -35,6 +35,11 @@ data Intrinsic | I_MINUS | I_TIMES | I_DIVMOD + -- core boolean operations + | I_NOT + | I_AND + | I_OR + | I_XOR deriving (Show, Eq) data Operation @@ -59,6 +64,7 @@ data Machine = Machine { ok :: Bool data TokenData = T_WHITESPACE + | T_BOOL_LITERAL Bool | T_INT_LITERAL Integer | T_INTRINSIC Intrinsic deriving (Show, Eq) @@ -87,6 +93,12 @@ intrinsicL s i = buildDSLLexer (list s) (const $ T_INTRINSIC i) wsL :: DSLLexer wsL = buildDSLLexer (mult1 $ satisfy isSpace) (const T_WHITESPACE) +boolLiteralL :: DSLLexer +boolLiteralL = t `alt` f + where + t = buildDSLLexer (list "true") (const $ T_BOOL_LITERAL True) + f = buildDSLLexer (list "false") (const $ T_BOOL_LITERAL False) + intLiteralL :: DSLLexer intLiteralL = buildDSLLexer go (T_INT_LITERAL . read) where @@ -99,7 +111,8 @@ mainLexer :: Parser Char [DSLToken] mainLexer = phrase $ mult1 $ firstOf subLexers where subLexers = [wsL] ++ literals ++ intrinsics - literals = [ intLiteralL + literals = [ boolLiteralL + , intLiteralL ] intrinsics = map (uncurry intrinsicL) [ (".", I_DUMP) , ("DROP", I_DROP) @@ -111,6 +124,10 @@ mainLexer = phrase $ mult1 $ firstOf subLexers , ("-", I_MINUS) , ("*", I_TIMES) , ("/%", I_DIVMOD) + , ("!", I_NOT) + , ("&&", I_AND) + , ("||", I_OR) + , ("^", I_XOR) ] ------------------------------------------------------------------------------ @@ -128,8 +145,9 @@ dataLiteralP :: DSLParser StackData dataLiteralP = do t <- anyToken case tData t of - T_INT_LITERAL x -> result $ StackInt x - _ -> flunk + T_INT_LITERAL x -> result $ StackInt x + T_BOOL_LITERAL x -> result $ StackBool x + _ -> flunk pushDataP :: DSLParser Operation pushDataP = OpPushData <$> dataLiteralP @@ -250,6 +268,29 @@ times = binArithmetic "TIMES" $ \ x y -> [x * y] divMod' :: StackModifier divMod' = binArithmetic "DIVMOD" $ \ x y -> [mod x y, div x y] +not' :: StackModifier +not' = StackModifier { smName="NOT", smTypes=ts, smFunc=f } + where + ts = [tBool] + f (StackBool x:xs) = return $ StackBool (not x):xs + f _ = unreachable + +binBoolean :: String -> (Bool -> Bool -> [Bool]) -> StackModifier +binBoolean name f = StackModifier { smName=name, smTypes=ts, smFunc=f' } + where + ts = [tBool, tBool] + f' (StackBool x:StackBool y:xs) = return $ (StackBool <$> f x y) ++ xs + f' _ = unreachable + +and' :: StackModifier +and' = binBoolean "AND" $ \ x y -> [x && y] + +or' :: StackModifier +or' = binBoolean "OR" $ \ x y -> [x || y] + +xor :: StackModifier +xor = binBoolean "XOR" $ \ x y -> [x /= y] + ------------------------------------------------------------------------------ -- Core operations ------------------------------------------------------------------------------ @@ -287,6 +328,10 @@ applyIntrinsic i m = do I_MINUS -> minus I_TIMES -> times I_DIVMOD -> divMod' + I_NOT -> not' + I_AND -> and' + I_OR -> or' + I_XOR -> xor ------------------------------------------------------------------------------ -- Interpretation |