My implementation of SICKBAY: see https://github.com/catseye/SICKBAY for the reference implementation.

sickbay.hs

{-
My implementation of http://catseye.tc/node/SICKBAY
By Jeremy List
Public domain
-}

import qualified Data.Map as M
import Data.Maybe
import Data.List
import Data.IORef
import Control.Monad
import Control.Applicative hiding (Const)
import Data.Function (on)

import Text.ParserCombinators.ReadP hiding (some,many,get,skipSpaces)
import Control.Monad.State
import Control.Monad.Trans.Class
import Data.Char

import System.Random
import System.IO
import System.Environment (getArgs)

data IntExpr =
  Var (IORef (M.Map Int Int)) IntExpr |
  Const Int |
  Rnd IntExpr |
  Infix Char IntExpr IntExpr

{-# INLINE eval_IntExpr #-}
eval_IntExpr :: IntExpr -> IO Int
eval_IntExpr = go where
  go :: IntExpr -> IO Int
  go (Var a i') = do
    i <- eval_IntExpr i'
    fmap (maybe 0 id . M.lookup i) $ readIORef a
  go (Const c) = return c
  go (Rnd e) = go e >>= randomRIO . ((,) 0)
  go (Infix o a b) = (`fmap` go b) . op =<< go a where
    op = case o of
      '+' -> (+)
      '-' -> (-)
      '*' -> (*)
      '/' -> \a b -> if b == 0 then 0 else a `div` b

newtype QNode a = QNode (IORef (Maybe (QNode a), a, Maybe (QNode a)))
-- Not a real ring buffer: use a linked list queue instead
newtype RingBuffer a = RingBuffer (IORef (Maybe (QNode a, QNode a)))

newQNode :: a -> IO (QNode a)
newQNode = fmap QNode . newIORef . flip ((,,) Nothing) Nothing

newRingBuffer = fmap RingBuffer $ newIORef Nothing

pushEnd :: RingBuffer a -> a -> IO ()
pushEnd (RingBuffer r) a = readIORef r >>= \r' -> case r' of
  Nothing -> do
    n <- newQNode a
    writeIORef r (Just (n,n))
  Just (h,t@(QNode t0)) -> do
    t1 <- fmap QNode $ newIORef (Just t, a, Nothing)
    atomicModifyIORef t0 (\(p,b,_) -> ((p,b,Just t1),()))
    writeIORef r (Just (h,t1))

pushBegin :: RingBuffer a -> a -> IO ()
pushBegin (RingBuffer r) a = readIORef r >>= \r' -> case r' of
  Nothing -> do
    n <- newQNode a
    writeIORef r (Just (n,n))
  Just (h@(QNode h0),t) -> do
    h1 <- fmap QNode $ newIORef (Nothing, a, Just h)
    atomicModifyIORef h0 (\(_,b,n) -> ((Just h1,b,n),()))
    writeIORef r (Just (h1,t))

popEnd :: RingBuffer a -> IO (Maybe a)
popEnd (RingBuffer r) = readIORef r >>= \r' -> case r' of
  Nothing -> return Nothing
  Just (h,(QNode t)) -> do
    (t0,a,_) <- readIORef t
    case t0 of
      Nothing -> writeIORef r Nothing
      Just (QNode t0') -> do
        (t0p,b,_) <- readIORef t0'
        writeIORef t0' (t0p,b,Nothing)
        writeIORef r (Just (h, QNode t0'))
    return (Just a)

popBegin :: RingBuffer a -> IO (Maybe a)
popBegin (RingBuffer r) = readIORef r >>= \r' -> case r' of
  Nothing -> return Nothing
  Just ((QNode h),t) -> do
    (_,a,h0) <- readIORef h
    case h0 of
      Nothing -> writeIORef r Nothing
      Just (QNode h0') -> do
        (_,b,h0n) <- readIORef h0'
        writeIORef h0' (Nothing,b,h0n)
        writeIORef r (Just (QNode h0', t))
    return (Just a)

data Statement =
  REM String |
  LET (IORef (M.Map Int Int)) IntExpr IntExpr |
  GOTO Int |
  GOSUB Int |
  RETURN |
  END |
  PROLONG Int |
  CUTSHORT |
  DIMRING | -- Ignore dim ring because we are not really using a ring buffer
  PRINT PrintArg Bool |
  INPUT (IORef (M.Map Int Int)) IntExpr Bool

data PrintArg =
  StrConst String |
  IntExpr IntExpr |
  Char IntExpr

data RunEnv = RunEnv (RingBuffer Int) (IORef PC)
data PC =
  ContinueFrom Int |
  Goto Int |
  Exit Bool

-- Returns False from control flow statements and True from other statements
execStatement _ (REM _) = return True
execStatement _ (LET var idx exp) = do
  exp' <- eval_IntExpr exp
  idx' <- eval_IntExpr idx
  if exp' /= 0
    then atomicModifyIORef var (flip (,) () . M.insert idx' exp')
    else atomicModifyIORef var (flip (,) () . M.delete idx')
  return True
execStatement (RunEnv _ pc0) (GOTO pc') = writeIORef pc0 (Goto pc') >>
  return False
execStatement (RunEnv rq pc0) (GOSUB pc') = do
  pc0' <- readIORef pc0
  case pc0' of
    ContinueFrom pc0'' -> do
      pushEnd rq pc0''
      writeIORef pc0 (Goto pc')
    _ -> writeIORef pc0 (Exit True)
  return False
execStatement (RunEnv rq pc0) RETURN = do
  pc <- popEnd rq
  case pc of
    Nothing -> writeIORef pc0 (Exit True) >> return False
    Just pc' -> writeIORef pc0 (Goto pc') >> return False
execStatement (RunEnv rq pc0) END = writeIORef pc0 (Exit False) >>
  return False
execStatement (RunEnv rq pc0) (PROLONG p) = pushBegin rq p >> return True
execStatement (RunEnv rq pc0) CUTSHORT = popBegin rq >> return True
execStatement _ DIMRING = return True
execStatement _ (PRINT a n) = let
  pf = if n then putStr else putStrLn
  s = case a of
    StrConst s -> return s
    IntExpr e -> fmap show $ eval_IntExpr e
    Char c -> fmap ((:[]) . toEnum) $ eval_IntExpr c
  in s >>= pf >> return True
execStatement _ (INPUT v i True) = do
  c <- fmap fromEnum getChar
  idx <- eval_IntExpr i
  atomicModifyIORef v (flip (,) True . case c of
    0 -> M.delete idx
    _ -> M.insert idx c
   )
execStatement (RunEnv rq pc0) (INPUT v i False) = do
  eatWhitespace
 where
  eatWhitespace = do
    c <- getChar
    case () of
     _ | isSpace c -> eatWhitespace
       | isDigit c -> go True $ digitToInt c
       | c == '-' -> go False 0
       | otherwise -> writeIORef pc0 (Exit True) >> return False
  go s n = do
    c <- getChar
    case () of
     _ | isSpace c -> do
          idx <- eval_IntExpr i
          atomicModifyIORef v (flip (,) True . case n of
            0 -> M.delete idx
            _ -> M.insert idx (if s then n else (- n))
           )
          return True
       | isDigit c -> let
          n' = n * 10 + digitToInt c
          in n' `seq` go s n'
       | otherwise -> writeIORef pc0 (Exit True) >> return False

execLine env = go where
  go [] = return True
  go (s1:r) = do
    cl <- execStatement env s1
    if cl then go r else return False

data Line = Line IntExpr [Statement]

-- I'm a bit surprised this isn't anywhere in the base package
findM :: (Monad m) => (a -> m Bool) -> [a] -> m (Maybe a)
findM p = go where
  go [] = return Nothing
  go (a:r) = do
    s <- p a
    if s then return (Just a) else go r

getLine (RunEnv _ pc0) lns = do
  pc <- readIORef pc0
  case pc of
    ContinueFrom ln -> do
      lns' <- fmap (sortBy (compare `on` fst) . filter ((> ln) . fst)) $
        forM lns $
        \(Line e s) -> eval_IntExpr e >>= \e' -> return (e',s)
      case lns' of
        [] -> return $ Left False
        ((pc1,s):_) -> writeIORef pc0 (ContinueFrom pc1) >> return (Right s)
    Goto ln -> do
      a <- findM (\(Line i _) -> fmap (== ln) $ eval_IntExpr i) lns
      case a of
        Nothing -> return $ Left True
        Just (Line _ s) -> writeIORef pc0 (ContinueFrom ln) >>
          return (Right s)
    Exit s -> return (Left s)

runProgram p = do
  rq <- newRingBuffer
  pc <- newIORef (ContinueFrom minBound)
  let
    re = RunEnv rq pc
    go = do
      l <- Main.getLine re p
      case l of
        Left False -> return ()
        Left True -> hPutStrLn stderr "Sickbay program exited with error"
        Right ln -> execLine re ln >> go
  go

-- Redefine this function to avoid consuming newlines
skipSpaces = munch (\c -> isSpace c && c /= '\n')

int_p = go 0 where
  go acc = do
    d <- satisfy isDigit
    let acc' = acc * 10 + digitToInt d
    acc' `seq` (go acc' +++ return acc')

varname_p = do
  c1 <- fmap toUpper $ satisfy isAlpha
  r <- fmap (map toUpper) $ munch (\c -> isAlpha c || isDigit c)
  char '%'
  return (c1:r)

getVariable :: String -> StateT
  (M.Map String (IORef (M.Map Int Int)))
  IO (IORef (M.Map Int Int))
getVariable v = do
  m <- get
  case M.lookup v m of
    Nothing -> do
      r' <- lift $ newIORef M.empty
      modify (M.insert v r')
      return r'
    Just r' -> return r'

-- The complexity of this type is because creating IORefs must be done in IO
intExpr_p :: ReadP
  (StateT (M.Map String (IORef (M.Map Int Int))) IO IntExpr)
intExpr_p = intvar +++ intconst +++ rnd +++ ifix where
  intvar = do
    v <- varname_p
    i <- return (return $ Const 0) +++ do
      skipSpaces
      char '('
      skipSpaces
      i' <- intExpr_p
      skipSpaces
      char ')'
      return i'
    return $ do
      r <- getVariable v
      i' <- i
      return (Var r i')
  intconst = fmap (return . Const) int_p
  rnd = do
    string "RND%"
    skipSpaces
    char '('
    skipSpaces
    m <- intExpr_p
    skipSpaces
    char ')'
    return $ fmap Rnd m
  ifix = do
    char '('
    skipSpaces
    l <- intExpr_p
    skipSpaces
    o <- satisfy (`elem` "+-*/")
    skipSpaces
    r <- intExpr_p
    skipSpaces
    char ')'
    return $ do
      l' <- l
      r' <- r
      return $ Infix o l' r'

statement_p :: ReadP
  (StateT (M.Map String (IORef (M.Map Int Int))) IO Statement)
statement_p =
  rem_p +++
  let_p +++
  goto_p +++
  gosub_p +++
  return_p +++
  end_p +++
  prolong_p +++
  cutshort_p +++
  dimring_p +++
  print_p +++
  input_p
 where
  rem_p = do
    string "REM "
    b <- munch (/= '\n')
    return $ return $ REM b
  let_p = do
    string "LET "
    v <- varname_p
    i <- return (return $ Const 0) +++ do
      char '('
      skipSpaces
      i' <- intExpr_p
      skipSpaces
      char ')'
      return i'
    skipSpaces
    char '='
    skipSpaces
    r <- intExpr_p
    return $ LET <$> getVariable v <*> i <*> r
  goto_p = do
    string "GOTO "
    ln <- int_p
    return $ return $ GOTO ln
  gosub_p = do
    string "GOSUB "
    ln <- int_p
    return $ return $ GOSUB ln
  return_p = string "RETURN" >> return (return RETURN)
  end_p = string "END" >> return (return END)
  prolong_p = do
    string "PROLONG "
    ln <- int_p
    return $ return $ GOSUB ln
  cutshort_p = string "CUTSHORT" >> return (return CUTSHORT)
  dimring_p = do
    string "DIM "
    skipSpaces
    string "RING "
    skipSpaces
    char '('
    skipSpaces
    intExpr_p
    skipSpaces
    char ')'
    return $ return $ DIMRING
  print_p = do
    string "PRINT "
    skipSpaces
    o <- printarg_p
    n <- return False +++ (char ';' >> return True)
    return $ PRINT <$> o <*> pure n
  printarg_p = strlit +++ (fmap . fmap) IntExpr intExpr_p +++ printarg_char
  strlit = do
    char '\"'
    l <- munch (/= '\"')
    char '\"'
    return $ return $ StrConst l
  printarg_char = do
    string "CHR$"
    skipSpaces
    v <- intExpr_p
    return $ fmap IntExpr v
  input_p = do
    string "INPUT "
    skipSpaces
    c <- return False +++ (string "CHR$" >> skipSpaces >> return True)
    v <- varname_p
    e <- intExpr_p
    return $ INPUT <$> getVariable v <*> e <*> pure c

line_p = do
  ln <- intExpr_p
  char ' '
  stmts <- fmap sequence $ sepBy statement_p
    (skipSpaces >> char ':' >> skipSpaces)
  return $ Line <$> ln <*> stmts

program_p = fmap (flip evalStateT M.empty . sequence) $
  sepBy line_p (skipSpaces >> char '\n')

readProgram = fmap fst . find (null . snd) . readP_to_S
  ((munch isSpace >>) . return =<< program_p)

main = do
  args <- getArgs
  case args of
    [fn] -> do
      src <- readFile fn
      case readProgram src of
        Just p -> p >>= runProgram
        Nothing -> hPutStrLn stderr "Could not parse the program"
    _ -> hPutStrLn stderr "Please use program filename as argument"

I haven't found any bugs so far. Assuming there are a few: they're probably in the parser (the grammar in the spec isn't clear in all places about where whitespace is tolerated, not tolerated, and required; and I haven't had a decent look at the reference implementation yet)