From cc1e9cdb77a92a03487dd6f80b002121e481f064 Mon Sep 17 00:00:00 2001 From: tomsmeding Date: Wed, 16 Sep 2015 21:36:31 +0200 Subject: Add functions Sorry for the de-patterning of parenpairs. I hate the resulting function, but ghc didn't like my generalisation of the open and closing paren. It claimed that there were overlapping patterns, which there were, but it should've just evaluated them in order ... Just like it does with guards. So I went with those guards. --- functions.rip | 3 ++ rip-lang.txt | 2 + rip.hs | 147 ++++++++++++++++++++++++++++++++++++++++------------------ 3 files changed, 107 insertions(+), 45 deletions(-) create mode 100644 functions.rip diff --git a/functions.rip b/functions.rip new file mode 100644 index 0000000..add2900 --- /dev/null +++ b/functions.rip @@ -0,0 +1,3 @@ +F[98mDo 58madDo 6so] + + diff --git a/rip-lang.txt b/rip-lang.txt index 52de72c..75ed5bf 100644 --- a/rip-lang.txt +++ b/rip-lang.txt @@ -20,6 +20,8 @@ W: I, but then "while" instead of "if" o: outputs the top value as an ascii char O: outputs the top value as a number g: gets a character and pushes the ascii value +F[code]: define a function named "bla" with the body "code" +: call the function named "bla" $: outputs a stackdump whitespace: nop diff --git a/rip.hs b/rip.hs index 9e390cd..c1571bb 100644 --- a/rip.hs +++ b/rip.hs @@ -7,6 +7,9 @@ import Control.Exception import Control.Monad import Data.Char import Data.Either +import Data.Maybe +import Data.List as List +import Data.Map.Strict as Map type Stackelem = Integer @@ -42,62 +45,97 @@ safeGetChar = ((\ex -> if isEOFError ex then return Nothing else ioError ex) :: IOError -> IO (Maybe Char)) -parenpairs :: String -> Either String [(Int,Int)] -parenpairs = go 0 [] - -- index stack string - where go _ [] [] = Right [] - go i st ('[':cs) = go (i+1) (i:st) cs - go i (s:st) (']':cs) = either Left (\x -> Right $ (s,i):x) $ go (i+1) st cs - go i [] (']':cs) = Left "Unmatched closing bracket" - go i st (_:cs) = go (i+1) st cs - go _ (_:_) [] = Left "Unmatched open bracket" + +parenpairs :: Char -> Char -> String -> Either String [(Int,Int)] +parenpairs open close s = go 0 [] s -- index, stack, string + where + go _ [] [] = Right [] + go i st s + | length s /= 0 && head s == open = + go (i+1) (i:st) (tail s) + | length st == 0 && length s /= 0 && head s == close = + Left $ "Unmatched closing '" ++ [close,'\''] + | length st /= 0 && length s == 0 = + Left $ "Unmatched open '" ++ [open,'\''] + | length st /= 0 && length s /= 0 && head s == close = + either Left (\x -> Right $ (head st,i):x) $ go (i+1) (tail st) (tail s) + | otherwise = + go (i+1) st (tail s) + +bracketpairs :: String -> Either String [(Int,Int)] +bracketpairs = parenpairs '[' ']' + -- returns string in and after codeblock getcodeblock :: String -> Either String (String,String) -getcodeblock s = if head (dropWhile isSpace s) == '[' then getcodeblock' s else Left "No codeblock when expected" +getcodeblock s = + if length afterwhite /= 0 && head afterwhite == '[' + then getcodeblock' afterwhite + else Left "No codeblock when expected" + where afterwhite = dropWhile isSpace s +-- assumes that s starts immediately with '[' getcodeblock' :: String -> Either String (String,String) getcodeblock' s = either Left (\_ -> Right (inblock,afterblock)) parenserr where - afterwhite = dropWhile isSpace s - parenserr = parenpairs afterwhite + parenserr = bracketpairs s parens = fromRight parenserr mainpair = minimum parens blockend = snd mainpair - inblock = drop 1 $ take blockend afterwhite - afterblock = drop (blockend + 1) afterwhite + inblock = drop 1 $ take blockend s + afterblock = drop (blockend + 1) s + +-- code substr error / name +getfuncname :: String -> Either String String +getfuncname s = + if length afterwhite /= 0 && head afterwhite == '<' + then getfuncname' afterwhite + else Left "No function name when expected" + where + afterwhite = dropWhile isSpace s + +-- assumes that the argument starts immediately with '<' +getfuncname' :: String -> Either String String +getfuncname' (_:xs) = + if isNothing maybeidx + then Left "No closing '>' in function name" + else Right name + where + maybeidx = List.findIndex (== '>') xs + name = take (fromJust maybeidx) xs -- returns the resulting stack -- rip: Rip InterPreter (recursive acronym) rip :: String -> IO [Stackelem] -rip s = rip' s [] +rip s = rip' s Map.empty [] -rip' :: String -> [Stackelem] -> IO [Stackelem] -rip' [] st = return st -rip' (x:xs) st = do +-- code function map stack resulting stack +rip' :: String -> Map.Map String String -> [Stackelem] -> IO [Stackelem] +rip' [] _ st = return st +rip' code@(x:xs) fns st = do if c_debugmode then print st else return () case x of n | '0' <= n && n <= '9' -> - rip' xs (fromIntegral (ord n - ord '0') : st) + rip' xs fns (fromIntegral (ord n - ord '0') : st) 'P' -> - rip' xs (tail st) + rip' xs fns (tail st) 'S' -> - rip' xs (b:a:cs) + rip' xs fns (b:a:cs) where (a:b:cs) = st 'D' -> - rip' xs (head st : st) + rip' xs fns (head st : st) 'i' -> - rip' xs (head st + 1 : tail st) + rip' xs fns (head st + 1 : tail st) 'd' -> - rip' xs (head st - 1 : tail st) + rip' xs fns (head st - 1 : tail st) 'r' -> - rip' xs res + rip' xs fns res where n = fromIntegral $ head st newst = tail st @@ -105,7 +143,7 @@ rip' (x:xs) st = do res = tail begin ++ head begin : rest 'R' -> - rip' xs res + rip' xs fns res where n = fromIntegral $ head st newst = tail st @@ -113,35 +151,35 @@ rip' (x:xs) st = do res = last begin : init begin ++ rest --SLOW! 'a' -> - rip' xs (a + b : cs) + rip' xs fns (a + b : cs) where (b:a:cs) = st 's' -> - rip' xs (a - b : cs) + rip' xs fns (a - b : cs) where (b:a:cs) = st 'm' -> - rip' xs (a * b : cs) + rip' xs fns (a * b : cs) where (b:a:cs) = st 'q' -> - rip' xs (a `div` b : cs) + rip' xs fns (a `div` b : cs) where (b:a:cs) = st 'G' -> - rip' xs (booltoint (a > b) : cs) + rip' xs fns (booltoint (a > b) : cs) where (b:a:cs) = st 'L' -> - rip' xs (booltoint (a < b) : cs) + rip' xs fns (booltoint (a < b) : cs) where (b:a:cs) = st 'E' -> - rip' xs (booltoint (a == b) : cs) + rip' xs fns (booltoint (a == b) : cs) where (b:a:cs) = st 'n' -> - rip' xs (booltoint (head st == 0) : tail st) + rip' xs fns (booltoint (head st == 0) : tail st) 'I' -> let maybecb = getcodeblock xs @@ -151,9 +189,9 @@ rip' (x:xs) st = do Right (inblock,afterblock) -> if head st /= 0 then do - newstack <- rip' inblock (tail st) - rip' afterblock newstack - else rip' afterblock (tail st) + newstack <- rip' inblock fns (tail st) + rip' afterblock fns newstack + else rip' afterblock fns (tail st) 'W' -> let maybecb = getcodeblock xs @@ -163,15 +201,15 @@ rip' (x:xs) st = do Right (inblock,afterblock) -> let doloop st = do - newstack <- rip' inblock st + newstack <- rip' inblock fns st if head newstack /= 0 then doloop $ tail newstack else return newstack in if head st /= 0 then do newstack <- doloop (tail st) - rip' afterblock newstack - else rip' afterblock (tail st) + rip' afterblock fns newstack + else rip' afterblock fns (tail st) 'o' -> do let n = fromIntegral (head st) @@ -180,23 +218,42 @@ rip' (x:xs) st = do (\ex -> riperror $ "Invalid character value " ++ (show n)) (\c -> do putChar c - rip' xs (tail st)) + rip' xs fns (tail st)) res 'O' -> do putStr $ show (head st) - rip' xs (tail st) + rip' xs fns (tail st) 'g' -> do n <- liftM (maybe (-1) ord) safeGetChar - rip' xs (fromIntegral n : st) + rip' xs fns (fromIntegral n : st) + + '<' -> + case (getfuncname code) of + Left s -> riperror s + Right name -> case (Map.lookup name fns) of + Nothing -> riperror $ "Function '" ++ name ++ "' not found" + Just s -> let newcode = drop (length name + 1) xs + in do + newstack <- rip' s fns st + rip' newcode fns newstack + + 'F' -> case (getfuncname xs) of + Left s -> riperror s + Right name -> case (Map.lookup name fns) of + Just _ -> riperror $ "Function '" ++ name ++ "' already exists" + Nothing -> case (getcodeblock $ drop (length name + 2) xs) of + Left s -> riperror s + Right (inblock,afterblock) -> + rip' afterblock (Map.insert name inblock fns) st '$' -> do print st - rip' xs st + rip' xs fns st c | isSpace c -> - rip' xs st + rip' xs fns st _ -> riperror $ "Unknown command '" ++ [x,'\''] -- cgit v1.2.3-54-g00ecf