diff options
Diffstat (limited to 'rip.hs')
| -rw-r--r-- | rip.hs | 167 |
1 files changed, 114 insertions, 53 deletions
@@ -2,14 +2,18 @@ module Main where import System.Environment import System.Exit +import System.IO import System.IO.Error 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 +import Data.List +import qualified Data.Map.Strict as Map +import Data.Map.Strict ((!)) +import Network.Socket +import Numeric type Stackelem = Integer @@ -41,13 +45,36 @@ fromLeft (Left l) = l ordI :: (Integral a) => Char -> a ordI = fromIntegral . ord -safeGetChar :: IO (Maybe Char) -safeGetChar = +pad :: a -> Int -> [a] -> [a] +pad c n s + | length s >= n = s + | otherwise = c : pad c (n-1) s + +getBytes :: Stackelem -> [Int] +getBytes = reverse . getBytes' + +getBytes' :: Stackelem -> [Int] +getBytes' 0 = [] +getBytes' n = fromIntegral m : getBytes' q + where (q,m) = divMod n 256 + +hex :: (Integral a, Show a) => a -> String +hex n = showHex n "" + +pairs :: [a] -> [(a,a)] +pairs [] = [] +pairs (a:b:cs) = (a,b) : pairs cs + +safeHGetChar :: Handle -> IO (Maybe Char) +safeHGetChar h = catch - (liftM Just getChar) + (liftM Just $ hGetChar h) ((\ex -> if isEOFError ex then return Nothing else ioError ex) :: IOError -> IO (Maybe Char)) +safeGetChar :: IO (Maybe Char) +safeGetChar = safeHGetChar stdin + parenpairs :: Char -> Char -> String -> Either String [(Int,Int)] parenpairs open close s = go 0 [] s -- index, stack, string @@ -104,41 +131,45 @@ getfuncname' (_:xs) = then Left "No closing '>' in function name" else Right name where - maybeidx = List.findIndex (== '>') xs + maybeidx = findIndex (== '>') xs name = take (fromJust maybeidx) xs -- returns the resulting stack -- rip: Rip InterPreter (recursive acronym) -rip :: String -> IO [Stackelem] -rip s = rip' s Map.empty [] - --- 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 +rip :: String -> IO ([Stackelem],Map.Map Stackelem Handle) +rip s = rip' s Map.empty Map.empty [] + +-- code function map filedesc table stack resulting stack +rip' :: String -- code + -> Map.Map String String -- function map + -> Map.Map Stackelem Handle -- filedecs table + -> [Stackelem] -- stack + -> IO ([Stackelem],Map.Map Stackelem Handle) -- resulting stack and filedesc table +rip' [] _ conns st = return (st,conns) +rip' code@(x:xs) fns conns st = do if c_debugmode then print st else return () case x of n | '0' <= n && n <= '9' -> - rip' xs fns (fromIntegral (ord n - ord '0') : st) + rip' xs fns conns (fromIntegral (ord n - ord '0') : st) 'P' -> - rip' xs fns (tail st) + rip' xs fns conns (tail st) 'S' -> - rip' xs fns (b:a:cs) + rip' xs fns conns (b:a:cs) where (a:b:cs) = st 'D' -> - rip' xs fns (head st : st) + rip' xs fns conns (head st : st) 'i' -> - rip' xs fns (head st + 1 : tail st) + rip' xs fns conns (head st + 1 : tail st) 'd' -> - rip' xs fns (head st - 1 : tail st) + rip' xs fns conns (head st - 1 : tail st) 'r' -> - rip' xs fns res + rip' xs fns conns res where n = fromIntegral $ head st newst = tail st @@ -146,7 +177,7 @@ rip' code@(x:xs) fns st = do res = tail begin ++ head begin : rest 'R' -> - rip' xs fns res + rip' xs fns conns res where n = fromIntegral $ head st newst = tail st @@ -154,46 +185,46 @@ rip' code@(x:xs) fns st = do res = last begin : init begin ++ rest --SLOW! 'l' -> - rip' xs fns (fromIntegral (length st) : st) + rip' xs fns conns (fromIntegral (length st) : st) 'a' -> - rip' xs fns (a + b : cs) + rip' xs fns conns (a + b : cs) where (b:a:cs) = st 's' -> - rip' xs fns (a - b : cs) + rip' xs fns conns (a - b : cs) where (b:a:cs) = st 'm' -> - rip' xs fns (a * b : cs) + rip' xs fns conns (a * b : cs) where (b:a:cs) = st 'q' -> - rip' xs fns (a `div` b : cs) + rip' xs fns conns (a `div` b : cs) where (b:a:cs) = st 'M' -> - rip' xs fns (a `mod` b : cs) + rip' xs fns conns (a `mod` b : cs) where (b:a:cs) = st 'p' -> - rip' xs fns (a ^ b : cs) + rip' xs fns conns (a ^ b : cs) where (b:a:cs) = st 'G' -> - rip' xs fns (booltoint (a > b) : cs) + rip' xs fns conns (booltoint (a > b) : cs) where (b:a:cs) = st 'L' -> - rip' xs fns (booltoint (a < b) : cs) + rip' xs fns conns (booltoint (a < b) : cs) where (b:a:cs) = st 'E' -> - rip' xs fns (booltoint (a == b) : cs) + rip' xs fns conns (booltoint (a == b) : cs) where (b:a:cs) = st 'n' -> - rip' xs fns (booltoint (head st == 0) : tail st) + rip' xs fns conns (booltoint (head st == 0) : tail st) 'I' -> let maybecb = getcodeblock xs @@ -203,9 +234,9 @@ rip' code@(x:xs) fns st = do Right (inblock,afterblock) -> if head st /= 0 then do - newstack <- rip' inblock fns (tail st) - rip' afterblock fns newstack - else rip' afterblock fns (tail st) + (newstack,newconns) <- rip' inblock fns conns (tail st) + rip' afterblock fns newconns newstack + else rip' afterblock fns conns (tail st) 'W' -> let maybecb = getcodeblock xs @@ -214,16 +245,16 @@ rip' code@(x:xs) fns st = do Right (inblock,afterblock) -> let - doloop st = do - newstack <- rip' inblock fns st + doloop st cn = do + (newstack,newconns) <- rip' inblock fns cn st if head newstack /= 0 - then doloop $ tail newstack - else return $ tail newstack + then doloop (tail newstack) newconns + else return (tail newstack,newconns) in if head st /= 0 then do - newstack <- doloop (tail st) - rip' afterblock fns newstack - else rip' afterblock fns (tail st) + (newstack,newconns) <- doloop (tail st) conns + rip' afterblock fns newconns newstack + else rip' afterblock fns conns (tail st) 'o' -> do let n = fromIntegral (head st) @@ -232,16 +263,46 @@ rip' code@(x:xs) fns st = do (\ex -> riperror $ "Invalid character value " ++ (show n)) (\c -> do putChar c - rip' xs fns (tail st)) + rip' xs fns conns (tail st)) res 'O' -> do putStr $ show (head st) - rip' xs fns (tail st) + rip' xs fns conns (tail st) 'g' -> do n <- liftM (maybe (-1) ord) safeGetChar - rip' xs fns (fromIntegral n : st) + rip' xs fns conns (fromIntegral n : st) + + 'C' -> do + let (portint:hostnameint:newst) = st + hostname = + if hostnameint < 2^32 + then intercalate "." $ map show $ getBytes hostnameint + else intercalate ":" $ map (\(a,b) -> pad '0' 2 (hex a) ++ pad '0' 2 (hex b)) $ pairs $ pad 0 16 $ getBytes hostnameint + addrinfo <- liftM head $ getAddrInfo (Just $ defaultHints {addrSocketType = Stream}) (Just hostname) (Just $ show portint) + sock <- socket (addrFamily addrinfo) Stream defaultProtocol + connect sock (addrAddress addrinfo) + h <- socketToHandle sock ReadWriteMode + let ident = fromIntegral $ succ $ Map.size conns + rip' xs fns (Map.insert ident h conns) $ ident : newst + + 'c' -> do + let (ident:newst) = st + hClose $ conns ! ident + let newconns = Map.delete ident conns + rip' xs fns newconns newst + + 'w' -> do + let (c:newst@(ident:_)) = st + hPutChar (conns ! ident) $ chr $ fromIntegral c + rip' xs fns conns newst + + 't' -> do + let (ident:_) = st + c <- liftM (maybe (-1) ordI) $ safeHGetChar $ conns ! ident + --c <- liftM ordI $ hGetChar $ conns ! ident + rip' xs fns conns $ c : st '<' -> case (getfuncname code) of @@ -250,8 +311,8 @@ rip' code@(x:xs) fns st = do 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 + (newstack,newconns) <- rip' s fns conns st + rip' newcode fns newconns newstack 'F' -> case (getfuncname xs) of Left s -> riperror s @@ -260,22 +321,22 @@ rip' code@(x:xs) fns st = do Nothing -> case (getcodeblock $ drop (length name + 2) xs) of Left s -> riperror s Right (inblock,afterblock) -> - rip' afterblock (Map.insert name inblock fns) st + rip' afterblock (Map.insert name inblock fns) conns st '#' -> case (getfuncname xs) of Left s -> riperror s Right name -> do contents <- readFile name - rip' (contents ++ drop (length name + 2) xs) fns st + rip' (contents ++ drop (length name + 2) xs) fns conns st - '\'' -> rip' (tail xs) fns $ ordI (head xs) : st + '\'' -> rip' (tail xs) fns conns $ ordI (head xs) : st '$' -> do - (putStrLn . List.intercalate " " . List.map show . reverse) st - rip' xs fns st + (putStrLn . intercalate " " . map show . reverse) st + rip' xs fns conns st c | isSpace c -> - rip' xs fns st + rip' xs fns conns st _ -> riperror $ "Unknown command '" ++ [x,'\''] |