diff options
| -rw-r--r-- | lllars/fac.lll | 17 | ||||
| -rw-r--r-- | lllars/parser.hs | 117 |
2 files changed, 115 insertions, 19 deletions
diff --git a/lllars/fac.lll b/lllars/fac.lll new file mode 100644 index 0000000..6502411 --- /dev/null +++ b/lllars/fac.lll @@ -0,0 +1,17 @@ +!!! all rights reserved to lars <3 !!! + +lars initial values: @0 is n, @1 is result +0lars50 +1lars1 + +larslars loop +@lars +sral|lars sral0 sral +1larssral1*sral0 +0larssral0-1 +srallars lars + +larslarslars end: print number +@sral +8159larssral1 +larssral lars diff --git a/lllars/parser.hs b/lllars/parser.hs index 03bbf02..0e828b7 100644 --- a/lllars/parser.hs +++ b/lllars/parser.hs @@ -1,11 +1,19 @@ +import Control.Monad.State +import Data.Bits ( (.&.) + , (.^.) + , (.|.) + ) import Data.Functor ( ($>) ) +import Data.HashMap.Strict ( HashMap ) +import qualified Data.HashMap.Strict as M import Data.List ( intercalate ) import Data.Void import Text.Megaparsec hiding ( Label , Pos + , State , label ) -import Text.Megaparsec.Char +import Text.Megaparsec.Char hiding ( space ) import qualified Text.Megaparsec.Char.Lexer as L type Parser = Parsec Void String @@ -15,14 +23,14 @@ type Address = Int type Label = String data Access = Access Address | SAccess Access -data Operation = ADD | MUL | SUB | DIV | AND | OR | XOR +data Operator = ADD | MUL | SUB | DIV | AND | OR | XOR deriving Show -data Addressation = Address Access | BinaryOperation Access Operation Access +data Addressation = Address Access | BinaryOperation Access Operator Access data Call = WriteCall | ReadCall deriving Show data BranchPolarity = IfTrue | IfFalse deriving Show -data Instr = Comment String | Write Address Addressation | LarsCall Call | Label Label | GoTo Label | Branch BranchPolarity Address Label +data Instr = Comment String | Write Address Addressation | LarsCall Call | Label Label | GoTo Label | Branch BranchPolarity Access Label instance Show Access where show (Access address) = "{ \"address\": " <> show address <> " }" @@ -59,14 +67,18 @@ instance Show Instr where <> show label <> "}}" +space :: Parser () +space = some (char ' ') $> () + comment :: Parser Instr -comment = Comment <$> (some (string "lars") *> many (satisfy (/= '\n'))) +comment = + Comment <$> (some (string "lars") *> space *> many (satisfy (/= '\n'))) access :: Parser Access access = (SAccess <$> (string "sral" *> access)) <|> (Access <$> L.decimal) -binaryOperation :: Parser Operation -binaryOperation = +binaryOperator :: Parser Operator +binaryOperator = (char '+' $> ADD) <|> (char '-' $> SUB) <|> (char '*' $> MUL) @@ -74,7 +86,7 @@ binaryOperation = addressation :: Parser Addressation addressation = - try (BinaryOperation <$> access <*> binaryOperation <*> access) + try (BinaryOperation <$> access <*> binaryOperator <*> access) <|> (Address <$> access) -- TODO: arguments @@ -82,6 +94,7 @@ call :: Parser Instr call = LarsCall <$> ( string "larssral" + *> space *> ((string "lars" $> ReadCall) <|> (string "sral" $> WriteCall)) ) @@ -93,30 +106,96 @@ write = do return $ Write target source label :: Parser Label -label = char '@' *> (concat <$> some (string "lars" <|> string "sral")) +label = concat <$> some (string "lars" <|> string "sral") namedLabel :: Parser Instr -namedLabel = Label <$> label +namedLabel = Label <$> (char '@' *> label) goto :: Parser Instr -goto = GoTo <$> (string "sralllars " *> label) +goto = GoTo <$> (string "srallars " *> label) branch :: Parser Instr branch = Branch - <$> ((string "lars|sral" $> IfTrue) <|> (string "sral|lars" $> IfFalse)) - <*> L.decimal + <$> ( ((string "lars|sral" $> IfTrue) <|> (string "sral|lars" $> IfFalse)) + <* space + ) + <*> (access <* space) <*> label instr :: Parser Instr -instr = comment <|> write <|> call <|> namedLabel <|> goto <|> branch +instr = try comment <|> write <|> call <|> namedLabel <|> goto <|> branch + +preamble :: Parser String +preamble = string "!!! all rights reserved to lars <3 !!!\n\n" program :: Parser Program -program = sepEndBy instr (some $ char '\n') +program = preamble *> sepEndBy instr (some $ char '\n') + +type EvalState = HashMap Address Int + +evalAccess :: Access -> State EvalState Int +evalAccess = go 0 + where + go 0 (Access address) = return address + go n (Access address) = do + m <- get + go (n - 1) (Access $ M.lookupDefault 0 address m) + go n (SAccess access) = go (n + 1) access + +evilOperation :: Int -> Operator -> Int -> Int +evilOperation a ADD b = a + b +evilOperation a MUL b = a * b +evilOperation a SUB b = a - b +evilOperation a DIV b = a `div` b +evilOperation a AND b = a .&. b +evilOperation a OR b = a .|. b +evilOperation a XOR b = a .^. b + +evalAddressation :: Addressation -> State EvalState Int +evalAddressation (Address access ) = evalAccess access +evalAddressation (BinaryOperation a operator b) = do + resA <- evalAccess a + resB <- evalAccess b + return $ evilOperation resA operator resB + +-- data Instr = Comment String | Write Address Addressation | LarsCall Call | Label Label | GoTo Label | Branch BranchPolarity Address Label +eval :: Int -> Program -> State EvalState () +eval n p = go (drop n p) + where + go ((Comment _ ) : ps) = go ps + go ((Write address addressation) : ps) = do + source <- evalAddressation addressation + modify (M.insert address source) + go ps + go ((LarsCall call ) : ps) = go ps -- TODO + go ((Label _ ) : ps) = go ps -- TODO: better + go ((GoTo label) : ps) = do + let is = [ i | (i, l@(Label n)) <- zip [0 ..] p, n == label ] + case is of + [i] -> eval (i + 1) p + _ -> error $ "invalid jump " <> label + go ((Branch IfTrue access label) : ps) = do + address <- evalAccess access + m <- get + case address of + 0 -> go ps + _ -> go [GoTo label] + go ((Branch IfFalse access label) : ps) = do + address <- evalAccess access + m <- get + case address of + 0 -> go [GoTo label] + _ -> go ps + go [] = return () main :: IO () main = do - f <- readFile "lars.lll" - case runParser (program <* eof) "" f of - Right res -> putStrLn $ "[" <> intercalate "," (show <$> res) <> "]" - Left err -> putStrLn $ errorBundlePretty err + f <- readFile "fac.lll" + case runParser (program <* many (char '\n') <* eof) "" f of + Right ps -> do + print ps + let ev = runState (eval 0 ps) M.empty + print ev + -- putStrLn $ "[" <> intercalate "," (show <$> ps) <> "]" + Left err -> putStrLn $ errorBundlePretty err |