Whitespace

Haskellでhttp://compsoc.dur.ac.uk/whitespace/ 0.3のインタープリタを作った。

本家サイトにはあまり仕様が書いてないので、http://compsoc.dur.ac.uk/whitespace/examples.phpとhttp://compsoc.dur.ac.uk/whitespace/contrib.phpに置いてあるプログラムが動くように作った。

2ヵ所あるdebugというコメントの箇所を有効にすると、それぞれソースコード中の命令の並びと、実行される命令の並び(およびスタックの状態)を標準出力に表示する。

ソースはこちら(ツッコミ希望)。

import Data.Array
import qualified Data.Map as M
import Char (chr, ord)
import System
import IO

-- data type definitions
type Prog    = Array Addr Command
data Command = Push Number | Dup | Copy Number | Swap | Pop | Slide Number |
               Add | Sub | Mul | Div | Mod |
               Store | Load |
               Mark Addr | Call Addr | Jump Addr | Jeqz Addr | Jltz Addr |  -- with address
               Markl {label::Label} | Calll Label | Jumpl Label | Jeqzl Label | Jltzl Label |  -- with labels
               Return | Term |
               Putc | Puti | Getc | Geti
               deriving (Show)
type Number  = Bits
type Label   = Bits

data State   = State { stack::[Bits],
                       heap::M.Map Bits Bits,
                       ip::Addr,                    -- instruction pointer
                       calls::[Addr] }              -- subroutine call stack
               | End
               deriving (Show)

type Bits = [Bit]
data Bit = T | S deriving (Eq, Ord, Show)
type Addr = Int -- Instruction Address

-- main routine
main::IO()
main = do   [path] <- getArgs
            source <- readFile path
            execute source

execute :: String -> IO ()
execute src = do  let p = compile src
                      s = State [] M.empty 1 []
                  --mapM_ (\(l,c) -> putStrLn $ show l ++ " " ++ show c) $ assocs p -- debug
                  run p s
                  return ()

compile :: String -> Prog
compile cs = let cs' = filter (flip elem [' ', '\t', '\n']) cs
                 cmds = unlabels $ parse cs'
                 in listArray (1, length cmds) cmds
                 where parse :: String -> [Command]
                       parse []                  = []
                       parse (' ':cs)            = parseStack cs
                       parse ('\n':cs)           = parseFlow cs
                       parse ('\t':' ':cs)       = parseArith cs
                       parse ('\t':'\t':cs)      = parseHeap cs
                       parse ('\t':'\n':cs)      = parseIo cs
                       parse cs                  = parseError "Invalid IMP" cs
                       parseStack (' ':cs)       = let (cs', n) = parseBits cs in (Push n) : parse cs'
                       parseStack ('\t':' ':cs)  = let (cs', n) = parseBits cs in (Copy n) : parse cs'
                       parseStack ('\t':'\n':cs) = let (cs', n) = parseBits cs in (Slide n) : parse cs'
                       parseStack ('\n':' ':cs)  = Dup : parse cs
                       parseStack ('\n':'\t':cs) = Swap : parse cs
                       parseStack ('\n':'\n':cs) = Pop : parse cs
                       parseStack cs             = parseError "Invalid stack command" cs
                       parseFlow (' ':' ':cs)    = let (cs', l) = parseBits cs in (Markl l) : parse cs'
                       parseFlow (' ':'\t':cs)   = let (cs', l) = parseBits cs in (Calll l) : parse cs'
                       parseFlow (' ':'\n':cs)   = let (cs', l) = parseBits cs in (Jumpl l) : parse cs'
                       parseFlow ('\t':' ':cs)   = let (cs', l) = parseBits cs in (Jeqzl l) : parse cs'
                       parseFlow ('\t':'\t':cs)  = let (cs', l) = parseBits cs in (Jltzl l) : parse cs'
                       parseFlow ('\t':'\n':cs)  = Return : parse cs
                       parseFlow ('\n':'\n':cs)  = Term : parse cs
                       parseFlow cs              = parseError "Invalid flow control command" cs
                       parseArith (' ':' ':cs)   = Add : parse cs
                       parseArith (' ':'\t':cs)  = Sub : parse cs
                       parseArith (' ':'\n':cs)  = Mul : parse cs
                       parseArith ('\t':' ':cs)  = Div : parse cs
                       parseArith ('\t':'\t':cs) = Mod : parse cs
                       parseArith cs             = parseError "Invalid arithmetic command" cs
                       parseHeap (' ':cs)        = Store : parse cs
                       parseHeap ('\t':cs)       = Load : parse cs
                       parseHeap cs              = parseError "Invalid heap access command" cs
                       parseIo (' ':' ':cs)      = Putc : parse cs
                       parseIo (' ':'\t':cs)     = Puti : parse cs
                       parseIo ('\t':' ':cs)     = Getc : parse cs
                       parseIo ('\t':'\t':cs)    = Geti : parse cs
                       parseIo cs                = parseError "Invalid IO command" cs
                       parseError msg cs         = fail $ msg ++ " : " ++ (show $ parseBits $ take 10 cs) ++ ".."
                       parseBits :: String -> (String, Bits)
                       parseBits cs              = parseBit cs []
                       parseBit ('\n':cs) bs     = (cs, reverse bs)
                       parseBit (' ':cs) bs      = parseBit cs (S:bs)
                       parseBit ('\t':cs) bs     = parseBit cs (T:bs)
                       unlabels :: [Command] -> [Command]
                       unlabels cmds             = let marks = filter (\(n, c) -> isMarkl c) $ zip [1..] cmds
                                                       lamap = M.fromList $ map (\(n, c) -> (label c, n)) marks
                                                       in map (\c -> unlabel c lamap) cmds
                       isMarkl (Markl _)         = True
                       isMarkl _                 = False
                       unlabel (Markl l) m       = Mark (m M.! l)
                       unlabel (Calll l) m       = Call (m M.! l)
                       unlabel (Jumpl l) m       = Jump (m M.! l)
                       unlabel (Jeqzl l) m       = Jeqz (m M.! l)
                       unlabel (Jltzl l) m       = Jltz (m M.! l)
                       unlabel c         _       = c

run :: Prog -> State -> IO State
run p s = do  let c = fetch p s
              --putStrLn $ concat [(show $ ip s), " ", (show c), " : ", (show $ stack s)] -- debug
              s' <- dispatch c s
              case s' of
                   End -> return s'
                   _   -> run p s'

fetch :: Prog -> State -> Command
fetch p s = p ! (ip s)

dispatch :: Command -> State -> IO State
dispatch (Push b) s@(State st _ _ _) = returni $ s {stack = b:st}
dispatch Dup s@(State st@(x:_) _ _ _) = returni $ s {stack = x:st}
dispatch (Copy b) s@(State st _ _ _) = let n = toInt b - 1
                                           in returni $ s {stack = (st !! n) : st}
dispatch Swap s@(State (x:y:zs) _ _ _) = returni $ s {stack = y:x:zs}
dispatch Pop s@(State (_:xs) _ _ _) = returni $ s {stack = xs}
dispatch (Slide b) s@(State (x:xs) _ _ _) = let n = toInt b
                                                in returni $ s {stack = x : drop n xs}
dispatch Add s = returni $ arithmetic (+) s
dispatch Sub s = returni $ arithmetic (-) s
dispatch Mul s = returni $ arithmetic (*) s
dispatch Div s = returni $ arithmetic div s
dispatch Mod s = returni $ arithmetic mod s
dispatch Store s@(State (v:a:xs) h _ _) = returni $ s {stack = xs, heap = M.insert a v h}
dispatch Load s@(State (a:xs) h _ _) = case M.lookup a h of
                                            Just x -> returni $ s {stack = x:xs}
                                            _      -> fail $ "Load error : " ++ show a
dispatch (Mark _) s = returni s
dispatch (Call a) s@(State _ _ i cs) = return $ s {ip = a, calls = (i + 1):cs}
dispatch (Jump a) s = return $ s {ip = a}
dispatch (Jeqz a) s@(State (x:xs) _ _ _) = if isZero x
                                              then return $ s {stack = xs, ip = a}
                                              else returni $ s {stack = xs}
dispatch (Jltz a) s@(State (x:xs) _ _ _) = if isMinus x
                                              then return $ s {stack = xs, ip = a}
                                              else returni $ s {stack = xs}
dispatch Return s@(State _ _ _ (a:as))   = return $ s {ip = a, calls = as}
dispatch Term _     = return End
dispatch Putc s@(State (b:xs) _ _ _) = do putChar $ toChar b
                                          returni $ s {stack = xs}
dispatch Puti s@(State (b:xs) _ _ _) = do putStr $ show $ toInt b
                                          returni $ s {stack = xs}
dispatch Getc s@(State (a:xs) h _ _) = do c <- getChar
                                          let v = fromChar c
                                          returni $ s {stack = xs, heap = M.insert a v h}
dispatch Geti s@(State (a:xs) h _ _) = do i <- getInt
                                          let v = fromInt i
                                          returni $ s {stack = xs, heap = M.insert a v h}
dispatch c _                     = fail $ "Invalid command : " ++ show c

arithmetic :: (Int -> Int -> Int) -> State -> State
arithmetic f s@(State (x:y:zs) _ _ _) = let z = fromInt $ f (toInt y) (toInt x)
                                            in s {stack = z:zs}

returni :: State -> IO State
returni s@(State _ _ i _) = return (s {ip = i + 1})

getInt :: IO Int
getInt = do cs <- getLine
            return $ (read::String -> Int) cs

-- Bits data manipulation
toInt :: Bits -> Int
toInt (b:bs) | b == T     = negate $ toUint bs
             | otherwise  = toUint bs
             where toUint = foldl (\n b -> n * 2 + if b == S then 0 else 1) 0
toInt []                  = 0

toChar :: Bits -> Char
toChar = chr . toInt

fromInt :: Int -> Bits
fromInt i | i >= 0    = S:(reverse $ fromUint i)
          | otherwise = T:(reverse $ fromUint $ negate i)
          where fromUint 0 = []
                fromUint i = (if even i then S else T):(fromUint $ i `div` 2)

fromChar :: Char -> Bits
fromChar = fromInt . ord

isZero :: Bits -> Bool
isZero (_:bs) = all (== S) bs
isZero []     = True

isMinus :: Bits -> Bool
isMinus (T:bs) = any (== T) bs
isMinus _      = False