diff options
| -rw-r--r-- | functions.rip | 3 | ||||
| -rw-r--r-- | rip-lang.txt | 2 | ||||
| -rw-r--r-- | rip.hs | 147 |
3 files changed, 107 insertions, 45 deletions
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<hoi>[98mDo 58madDo 6so] +<hoi> +<hoi> 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<bla>[code]: define a function named "bla" with the body "code" +<bla>: call the function named "bla" $: outputs a stackdump whitespace: nop @@ -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,'\''] |