summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorimplementation <>2016-04-05 14:12:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2016-04-05 14:12:00 (GMT)
commitf75ed4787b1c5c1cda93f67a80f9ffe8f8e8f545 (patch)
treea1eb77057e48d86e724806eed1163ed0c935e459
parent00eb21af65cfe3fdf657275b427817183b26f935 (diff)
version 0.1.0.4HEAD0.1.0.4master
-rw-r--r--Text/CTPL.hs105
-rw-r--r--Text/CTPL0.hs95
-rw-r--r--Text/CTPL0n.hs581
-rw-r--r--compiler.hs38
-rw-r--r--ctpl.cabal28
-rw-r--r--debugger.hs89
6 files changed, 900 insertions, 36 deletions
diff --git a/Text/CTPL.hs b/Text/CTPL.hs
index 6ca1f66..34f6869 100644
--- a/Text/CTPL.hs
+++ b/Text/CTPL.hs
@@ -1,5 +1,8 @@
+-- | Compiler for CTPL, generating CTPL0 code.
+
module Text.CTPL where
+import Control.Applicative hiding (many, Const, some)
import Control.Monad
import Data.Char
import Data.Monoid
@@ -7,10 +10,35 @@ import Text.Chatty.Parser
import Text.Chatty.Parser.Carrier
import qualified Text.CTPL0 as Null
-data Procedure = Procedure { procName :: String, procInstr :: Instruction, procAddr :: Int }
-data CTPLState = CTPLState { definedProcs :: [Procedure] }
-data Exec a = Succ a | NoSuchProc String | SyntaxFault deriving Show
-data CTPL a = CTPL { runCTPL :: CTPLState -> Exec (a, CTPLState, String -> String) }
+-- | Compiler configuration.
+data CCConfig = CCConfig {
+ ccTarget :: CCTarget -- ^ Target VM
+ }
+
+-- | Target VM
+data CCTarget = OldVM -- ^ produce output compatible with the old VM (Text.CTPL0)
+ | NewVM -- ^ produce output for the new VM only (Text.CTPL0n)
+
+-- | A parsed CTPL procedure.
+data Procedure = Procedure {
+ procName :: String, -- ^ Name of the procedure
+ procInstr :: Instruction, -- ^ Instructions
+ procAddr :: Int -- ^ Address (if already known)
+ }
+
+-- | Compiler state record
+data CTPLState = CTPLState {
+ definedProcs :: [Procedure] -- ^ Procedure already encountered
+ }
+
+-- | Monad displaying success or failure.
+data Exec a = Succ a -- ^ Compilation succeeded :)
+ | NoSuchProc String -- ^ Nope. Encountered a call to a procedure I can`t find.
+ | SyntaxFault -- ^ Nope. Syntax fault. I have no idea what you`re trying to tell me.
+ deriving Show
+
+-- | The compiler's execution monad. Behaves like a 'StateT CTPLState' wrapped around a 'ReaderT CCConfig' wrapped around a 'WriterT String' wrapped around the 'Exec' monad.
+data CTPL a = CTPL { runCTPL :: CTPLState -> CCConfig -> Exec (a, CTPLState, String -> String) }
instance Monad Exec where
return a = Succ a
@@ -18,37 +46,61 @@ instance Monad Exec where
(NoSuchProc s) >>= f = NoSuchProc s
SyntaxFault >>= f = SyntaxFault
+instance Applicative Exec where
+ pure = return
+ (<*>) = ap
+
+instance Functor Exec where
+ fmap = liftM
+
instance Monad CTPL where
- return a = CTPL $ \s -> return (a, s, id)
- m >>= f = CTPL $ \s -> do
- (a', s', f') <- runCTPL m s
- (a'', s'', f'') <- runCTPL (f a') s'
+ return a = CTPL $ \s cfg -> return (a, s, id)
+ m >>= f = CTPL $ \s cfg -> do
+ (a', s', f') <- runCTPL m s cfg
+ (a'', s'', f'') <- runCTPL (f a') s' cfg
return (a'', s'', f' . f'')
+instance Applicative CTPL where
+ pure = return
+ (<*>) = ap
+
+instance Functor CTPL where
+ fmap = liftM
+
+-- | Predefined compiler configuration. Generated code is compatible to both VMs.
+oldConfig :: CCConfig
+oldConfig = CCConfig{ccTarget=OldVM}
+
+-- | Predefined compiler configuration. Generated code is compatible to the new VM only.
+newConfig :: CCConfig
+newConfig = CCConfig{ccTarget=NewVM}
+
+-- | Gets the carried 'CTPLState' and runs a function on it.
getState :: (CTPLState -> a) -> CTPL a
-getState f = CTPL $ \s -> return (f s, s, id)
+getState f = CTPL $ \s cfg -> return (f s, s, id)
+-- | RUns a function on the carried 'CTPLState'.
modState :: (CTPLState -> CTPLState) -> CTPL ()
-modState f = CTPL $ \s -> return ((), f s, id)
+modState f = CTPL $ \s cfg -> return ((), f s, id)
emit :: String -> CTPL ()
-emit str = CTPL $ \s -> return ((), s, (str++))
+emit str = CTPL $ \s cfg -> return ((), s, (str++))
getProc :: String -> (Procedure -> a) -> CTPL a
getProc nm f = do
ps <- getState definedProcs
case filter (\p -> procName p == nm) ps of
- [] -> CTPL $ \_ -> NoSuchProc nm
+ [] -> CTPL $ \_ _ -> NoSuchProc nm
[p] -> return (f p)
catchEmission :: CTPL () -> CTPL String
-catchEmission m = CTPL $ \s -> do
- (_,s',f') <- runCTPL m s
+catchEmission m = CTPL $ \s cfg -> do
+ (_,s',f') <- runCTPL m s cfg
return (f' [], s', id)
discardEmission :: CTPL a -> CTPL a
-discardEmission m = CTPL $ \s -> do
- (a,s',_) <- runCTPL m s
+discardEmission m = CTPL $ \s cfg -> do
+ (a,s',_) <- runCTPL m s cfg
return (a, s', id)
data NumSource = AX Int | CK0 Int | Buf NumSource Int | Const Int | Len Int | CP Int deriving Show
@@ -290,10 +342,10 @@ dumpCond cond jumper = case cond of
-- Cd[ldbuf]Cmkj|q#!t
EqCh d chs -> emit "Cd" >> dumpInstr (SetCK0 d) >> emit "Cmk" >> emit jumper >> emit (foldr q "!t" chs) >> return "" where q a b = "|q"++[a]++b
-compile :: [Procedure] -> Instruction -> Exec String
-compile ps main = do
+compile :: [Procedure] -> Instruction -> CCConfig -> Exec String
+compile ps main cfg = do
let s0 = CTPLState (ps++[Procedure [] main 0])
- (_, _, out) <- flip runCTPL s0 $ do
+ (_, _, out) <- runCTPL (do
ps <- getState definedProcs
ps' <- allocProcs 7 ps
modState $ \s -> s{definedProcs=ps'}
@@ -301,7 +353,7 @@ compile ps main = do
emit "+"
dumpAddr amain
emit "jt"
- forM_ ps' $ \p -> dumpInstr $ procInstr p
+ forM_ ps' $ \p -> dumpInstr $ procInstr p) s0 cfg
return $ out []
multiParse :: ChParser m => m ([Procedure], [Instruction])
@@ -549,15 +601,18 @@ parseCond = parseNot ??? parseIsLower ??? parseEq ??? parseEqCh ??? parseLt ???
return $ EqCh ns chs
parse :: String -> [] ([Procedure], [Instruction])
-parse s = runCarrierT s multiParse
+parse s = runCarrierT s $ do
+ p <- multiParse
+ many white
+ return p
-compileCTPL :: String -> Exec String
-compileCTPL s = case parse s of
+compileCTPL :: String -> CCConfig -> Exec String
+compileCTPL s cfg = case parse s of
[] -> SyntaxFault
- (ps, is):_ -> compile ps (Compound is)
+ (ps, is):_ -> compile ps (Compound is) cfg
evalCTPL :: String -> String -> Int -> Null.Exec String
evalCTPL program buffer limit =
- case compileCTPL program of
+ case compileCTPL program oldConfig of
Succ bc -> Null.evalCTPL0 bc buffer limit
_ -> Null.SynViol
diff --git a/Text/CTPL0.hs b/Text/CTPL0.hs
index fe57583..f2a4c66 100644
--- a/Text/CTPL0.hs
+++ b/Text/CTPL0.hs
@@ -1,15 +1,64 @@
-module Text.CTPL0 where
+-- | The old CTPL0 virtual machine. This one is outdated, but will still be supported for a while.
+module Text.CTPL0 (Exec(..), CTPL0(..), CTPL0State(..), BufferState(..), RegisterState(..), InfoState(..), unetx, endOfInstr, singleInstr, procInstrs, evalCTPL0', evalCTPL0) where
+
+import Control.Applicative
import Control.Monad
import Data.Char
import Data.Chatty.AVL
import Data.List
-data BufferState = BufferState { leftBehind :: String, thisChar :: Char, rightPending :: String }
-data RegisterState = RegisterState { ax :: Integer, mk :: [String], rk :: [Int], ck :: [Int], cp :: Bool }
-data InfoState = InfoState { instrStats :: AVL (Char, Int) }
-data CTPL0State = CTPL0State { bufferState :: BufferState, programState :: BufferState, registerState :: RegisterState, infoState :: InfoState }
-data Exec a = Succ a | Expired | ConfViol | SynViol deriving Show
+-- | A character buffer. Represented as a triplet of left behind chars, the current char and the pending chars.
+data BufferState = BufferState {
+ leftBehind :: String, -- ^ Already seen. String reversed!
+ thisChar :: Char, -- ^ The current char.
+ rightPending :: String -- ^ The pending chars.
+ }
+
+-- | A record for register and stack state.
+data RegisterState = RegisterState {
+ ax :: Integer, -- ^ Accumulator register (AX)
+ mk :: [String], -- ^ Tape stack (MK)
+ rk :: [Int], -- ^ Return address stack (RK)
+ ck :: [Int], -- ^ Number stack (CK). The top element may be used like a register.
+ cp :: Bool -- ^ If set, the next instruction will use the top element of CK instead of AX. (Say: ``SX is CK top'' in contrast to ``SX is AX'')
+ }
+
+-- | A statistics record (might be used by a profiler some time in future...)
+data InfoState = InfoState {
+ instrStats :: AVL (Char, Int) -- ^ Statistics on how often each instruction has been executed.
+ }
+
+-- | The overall state record.
+data CTPL0State = CTPL0State {
+ bufferState :: BufferState, -- ^ Tape buffer.
+ programState :: BufferState, -- ^ Program buffer.
+ registerState :: RegisterState, -- ^ Register state record.
+ infoState :: InfoState -- ^ Statistics record.
+ }
+
+-- | Monad displaying success or failure.
+data Exec a = Succ a -- ^ Execution succeeded :)
+ | Expired -- ^ Nope. Time has expired. Program took too long to finish. You might want to increase time limit.
+ | ConfViol -- ^ Nope. Confidence violation. This may have several reasons, e.g. popping from an empty stack, jumping out of program bounds, ...
+ | SynViol -- ^ Nope. Syntax violation. I encountered an instruction (or condition) I do not understand.
+ deriving Show
+
+instance Monad Exec where
+ return = Succ
+ (Succ a) >>= f = f a
+ Expired >>= f = Expired
+ ConfViol >>= f = ConfViol
+ SynViol >>= f = SynViol
+
+instance Applicative Exec where
+ pure = return
+ (<*>) = ap
+
+instance Functor Exec where
+ fmap = liftM
+
+-- | The VM's execution monad. Behaves like a 'StateT' carrying a 'CTPL0State' wrapped around the 'Exec' monad. Also responsible for time consumption and passing.
newtype CTPL0 a = CTPL0 { runCTPL0 :: Int -> CTPL0State -> Exec (a, CTPL0State, Int) }
instance Monad CTPL0 where
@@ -21,45 +70,64 @@ instance Monad CTPL0 where
ConfViol -> ConfViol
SynViol -> SynViol
+instance Applicative CTPL0 where
+ pure = return
+ (<*>) = ap
+
+instance Functor CTPL0 where
+ fmap = liftM
+
+-- | Gets the carried 'CTPL0State' and runs a function on it.
getState :: (CTPL0State -> a) -> CTPL0 a
getState f = CTPL0 $ \i k -> Succ (f k, k, i)
+-- | Runs a function on the carried 'CTPL0State'.
modState :: (CTPL0State -> CTPL0State) -> CTPL0 ()
modState f = CTPL0 $ \i k -> Succ ((), f k, i)
+-- | Consume virtual time. Raise 'Expired' if limit is reached.
consumeTime :: CTPL0 ()
consumeTime = CTPL0 $ \i k -> if i >= 1 then Succ ((), k, i-1) else Expired
+-- | Raise a 'ConfViol'.
confViol :: CTPL0 a
confViol = CTPL0 $ \_ _ -> ConfViol
+-- | Raise a 'SynViol'.
synViol :: CTPL0 a
synViol = CTPL0 $ \_ _ -> SynViol
+-- | Modify the tape buffer`s state by running a function on it.
modBufferState :: (BufferState -> BufferState) -> CTPL0 ()
modBufferState f = modState $ \s -> s{bufferState = f $ bufferState s}
+-- | Modify the program buffer`s state by running a function on it.
modProgramState :: (BufferState -> BufferState) -> CTPL0 ()
modProgramState f = modState $ \s -> s{programState = f $ programState s}
+-- | Modify the register state record by running a function on it.
modRegisterState :: (RegisterState -> RegisterState) -> CTPL0 ()
modRegisterState f = modState $ \s -> s{registerState = f $ registerState s}
+-- | Walk in the buffer. A positive number specifies walking to the right, a negative one to the left.
walkBuffer :: Int -> BufferState -> BufferState
walkBuffer 0 s = s
walkBuffer i s
| i < 0 = BufferState (drop (-i) $ leftBehind s) (head $ drop (-i-1) $ leftBehind s) (reverse (take (-i-1) $ leftBehind s) ++ [thisChar s] ++ rightPending s)
| i > 0 = BufferState (reverse (take (i-1) (rightPending s)) ++ [thisChar s] ++ leftBehind s) (head $ drop (i-1) $ rightPending s) (drop i $ rightPending s)
+-- | Fetch the next instruction.
getInstr :: CTPL0 Char
getInstr = do
k <- getState $ thisChar . programState
modProgramState $ walkBuffer 1
return k
+-- | Have we reached the end of the program tape?
endOfInstr :: CTPL0 Bool
endOfInstr = getState $ null . rightPending . programState
+-- | Fetch numeric argument (as many digits as we can get)
instrNumArg :: CTPL0 Int
instrNumArg = do
ks <- getState $ \s -> takeWhile isDigit (thisChar (programState s) : rightPending (programState s))
@@ -67,6 +135,7 @@ instrNumArg = do
modProgramState $ walkBuffer $ length ks
return $ read ks
+-- | Fetch string argument (delimited by '$')
instrDelimArg :: CTPL0 String
instrDelimArg = do
ks <- getState $ \s -> takeWhile (/='$') (thisChar (programState s) : rightPending (programState s))
@@ -76,24 +145,29 @@ instrDelimArg = do
modProgramState $ walkBuffer 1
return ks
+-- | Get position in program buffer.
getIP :: CTPL0 Int
getIP = getState $ length . leftBehind . programState
+-- | Get position in tape buffer.
getCP :: CTPL0 Int
getCP = getState $ length . leftBehind . bufferState
+-- | Are we able to walk that far in the program buffer?
canRelJump :: Int -> CTPL0 Bool
canRelJump 0 = return True
canRelJump i
| i < 0 = getState $ (>= -i) . length . leftBehind . programState
| i > 0 = getState $ (>= i) . length . rightPending . programState
+-- | Are we able to walk that far in the tape buffer?
canRelWalk :: Int -> CTPL0 Bool
canRelWalk 0 = return True
canRelWalk i
| i < 0 = getState $ (>= -i) . length . leftBehind . bufferState
| i > 0 = getState $ (>= i) . length . rightPending . bufferState
+-- | Run an action (first arg) iff the test (second arg) succeeds. Raise 'ConfViol' otherwise.
provided :: CTPL0 a -> CTPL0 Bool -> CTPL0 a
provided act test = do
b <- test
@@ -101,15 +175,17 @@ provided act test = do
then act
else confViol
--- SX points to AX by default, but to CK(0) after 'C'
+-- | SX is AX by default, but CK top after `C'
sx :: RegisterState -> Integer
sx r | cp r = fromIntegral $ head $ ck r
sx r = ax r
+-- | Set SX (AX or CK top) value.
setSX :: Integer -> RegisterState -> RegisterState
setSX i r | cp r = r{ck=fromIntegral i : tail (ck r)}
setSX i r = r{ax=i}
+-- | Run the next instruction in program.
singleInstr :: CTPL0 ()
singleInstr = do
i <- getInstr
@@ -314,12 +390,14 @@ singleCond = do
-- Catch others
o -> synViol
+-- | Run the entire program.
procInstrs :: CTPL0 ()
procInstrs = singleInstr `asLongAs` liftM not endOfInstr
where asLongAs act test = do
b <- test
when b $ act >> asLongAs act test
+-- | A handy wrapper around 'procInstrs'. Arguments: program, tape, time limit. Results: tape, leftover time, AX, CK top, instruction stats.
evalCTPL0' :: String -> String -> Int -> Exec (String, Int, Integer, Int, [] (Char, Int))
evalCTPL0' program buffer limit =
let state0 = CTPL0State buffer0 program0 register0 info0
@@ -338,6 +416,7 @@ evalCTPL0' program buffer limit =
SynViol -> SynViol
Expired -> Expired
+-- | Another handy wrapper around 'procInstr'. Less clumsy than 'evalCTPL0'', but provides less information. Arguments: program, tape, time limit. Results: tape only.
evalCTPL0 :: String -> String -> Int -> Exec String
evalCTPL0 program buffer limit =
case evalCTPL0' program buffer limit of
@@ -346,6 +425,7 @@ evalCTPL0 program buffer limit =
SynViol -> SynViol
Expired -> Expired
+-- | Remove a trailing ETX (if there is one).
unetx :: String -> String
unetx [] = []
unetx s
@@ -353,6 +433,7 @@ unetx s
| last s == chr 3 = init s
| otherwise = s
+-- | Append right before the trailing ETX. If there is no ETX, string will be appended at the end.
appendBeforeETX :: String -> String -> String
appendBeforeETX [] t = t
appendBeforeETX s t
diff --git a/Text/CTPL0n.hs b/Text/CTPL0n.hs
new file mode 100644
index 0000000..8614b2a
--- /dev/null
+++ b/Text/CTPL0n.hs
@@ -0,0 +1,581 @@
+{-# LANGUAGE TupleSections, FlexibleInstances #-}
+
+-- | The new CTPL0 virtual machine.
+
+module Text.CTPL0n where
+
+import Control.Applicative
+import Control.Arrow
+import Control.Monad
+import Control.Monad.ST
+import Data.Array.MArray as M
+import Data.Array.ST
+import Data.Array.Unboxed
+import Data.Char
+import Data.List
+import Data.STRef
+
+-- | The VM`s state record.
+data CTPL0State s = CTPL0State {
+ bufferContent :: !(Buffer s), -- ^ Tape buffer
+ programContent :: UArray Int Char, -- ^ Program buffer
+ bufferPointer :: !Int, -- ^ Tape pointer
+ programPointer :: !Int, -- ^ Program pointer
+ cp :: !Bool, -- ^ If set, the next instruction will use the top element of CK instead of AX. (Say: ``SX is CK top'' in contrast to ``SX is AX'')
+ ax :: !Int, -- ^ Accumulator register (AX)
+ mk :: [Buffer s], -- ^ Tape stack (MK)
+ rk :: [Int], -- ^ Return address stack (RK)
+ ck :: [Int] -- ^ Number stack (CK). The top element may be used like a register.
+ }
+
+-- | The VM`s configuration. Immutable during execution.
+data VMConfig = VMConfig {
+ maxTime :: !Int, -- ^ Initial time limit.
+ maxConditRecurs :: !Int, -- ^ Maximum recursion depth for `x' condition (FUTURE)
+ maxBufferMeasure :: !Int, -- ^ Maximum buffer size (FUTURE)
+ initBufferMeasure :: !Int, -- ^ Initial buffer size.
+ vmFeatures :: [VMFeature] -- ^ Enabled feature instructions.
+ }
+
+-- | Optional feature instructions.
+data VMFeature = RandomF -- ^ enable `Xr' instruction for random number retrieval (FUTURE)
+ | FilterF -- ^ enable `Xfs', `Xfd', `Xff' instructions for setting predefined filters on the tape (FUTURE)
+ | CustomFilterF -- ^ enable `Xfc' instruction for setting custom filters on the tape (FUTURE; won't work without FilterF)
+ | InterruptsF -- ^ enable `Xi' instruction for setting and calling interrupts (FUTURE)
+
+-- | Predefined VM configuration, very restrictive. Allows 10000 cycles, no recursive conditions, no feature instructions, at maximum 3000 chars on tape.
+safeVM :: VMConfig
+safeVM = VMConfig{ maxTime=10000, maxConditRecurs=0,
+ maxBufferMeasure=3000, initBufferMeasure=0,
+ vmFeatures=[] }
+
+-- | Predefined VM configuration, very permissive. Allows 10 million cycles, 10 levels of recursion, all available feature instructions, at maximum 30000 chars on tape.
+fullVM :: VMConfig
+fullVM = VMConfig{ maxTime=10000000, maxConditRecurs=10,
+ maxBufferMeasure=30000, initBufferMeasure=0,
+ vmFeatures=[RandomF, FilterF, CustomFilterF, InterruptsF] }
+
+-- | Monad displaying success or failure. A close relative of the 'Either' monad.
+data Exec a = Succ a -- ^ Execution succeeded :)
+ | Fail !Fail -- ^ Nope. See 'Fail' type.
+
+instance Monad Exec where
+ return = Succ
+ fail = Fail . Dead
+ (Succ a) >>= f = f a
+ (Fail e) >>= f = Fail e
+
+instance Applicative Exec where
+ pure = return
+ (<*>) = ap
+
+instance Functor Exec where
+ fmap = liftM
+
+-- | Possible errors.
+data Fail = Expired -- ^ Time has expired. Program took too long to finish. You might want to increase time limit.
+ | ConfViol -- ^ Confidence violation. This may have several reasons, e.g. popping from an empty stack, jumping out of program bounds, ...
+ | SynViol -- ^ Syntax violation. I encountered an instruction (or condition) I do not understand.
+ | Dead String -- ^ Program requested abort (FUTURE)
+
+-- | The VM's execution monad. Behaves like a 'ReaderT' carrying a 'CTPL0State' reference and a 'VMConfig' wrapped around the 'ST' and the 'Exec' monad. Also responsible for time consumption and passing.
+newtype CTPL0 s a = CTPL0 { runCTPL0 :: Int ->
+ STRef s (CTPL0State s) ->
+ VMConfig ->
+ ST s (Exec (a, Int)) }
+
+-- | A tape buffer, implemented by wrapping modifiers around a mutable array.
+data Buffer s = Insertion { insPlace :: !Int, insLength :: !Int, insContent :: String, insNext :: Buffer s } -- ^ Character insertion
+ | Deletion { delPlace :: !Int, delLength :: !Int, delNext :: Buffer s } -- ^ Character deletion
+ | MBuffer { bufArray :: STUArray s Int Char } -- ^ The core: the mutable array
+
+instance Show Fail where
+ show Expired = "<Fatal: Time expired.>"
+ show ConfViol = "<Fatal: Confidence violation.>"
+ show SynViol = "<Fatal: Syntax violation.>"
+ show (Dead s) = "<Error: "++s++">"
+
+instance Show (Exec String) where
+ show (Succ a) = a
+ show (Fail f) = show f
+
+-- | Read a char from a tape buffer.
+readBuffer :: Buffer s -> Int -> ST s Char
+readBuffer (MBuffer a) i = readArray a i
+readBuffer (Insertion p l c n) i
+ | i < p = readBuffer n i
+ | i >= p+l = readBuffer n (i-l)
+ | otherwise = return (c !! (i-p))
+readBuffer (Deletion p l n) i
+ | i < p = readBuffer n i
+ | otherwise = readBuffer n (i+l)
+
+-- | Write a char to the tape buffer.
+writeBuffer :: Buffer s -> Int -> Char -> ST s (Buffer s)
+writeBuffer (MBuffer a) i e = writeArray a i e >> return (MBuffer a)
+writeBuffer (Insertion p l c n) i e
+ | i < p = Insertion p l c <$> writeBuffer n i e
+ | i >= p+l = Insertion p l c <$> writeBuffer n (i-l) e
+ | otherwise = return $ Insertion p l (take (i-p) c ++ [e] ++ drop (i-p+1) c) n
+writeBuffer (Deletion p l n) i e
+ | i < p = Deletion p l <$> writeBuffer n i e
+ | otherwise = Deletion p l <$> writeBuffer n (i+l) e
+
+-- | Is the given position accessible in the tape buffer?
+accBuffer :: Buffer s -> Int -> ST s Bool
+accBuffer (MBuffer a) i = do
+ b <- M.getBounds a
+ return (snd b >= i)
+accBuffer (Insertion p l c n) i
+ | i < p = accBuffer n i
+ | i >= p+l = accBuffer n (i-l)
+ | otherwise = return True
+accBuffer (Deletion p l n) i
+ | i < p = accBuffer n i
+ | otherwise = accBuffer n (i+l)
+
+-- | Join the tape buffer to a string.
+joinBuffer :: Buffer s -> ST s String
+joinBuffer (MBuffer a) = M.getElems a
+joinBuffer (Insertion p l c n) = do
+ nb <- joinBuffer n
+ let (a,b) = splitAt p nb
+ return (a ++ c ++ b)
+joinBuffer (Deletion p l n) = do
+ nb <- joinBuffer n
+ let (a,b) = splitAt p nb
+ return (a ++ drop l b)
+
+-- | Insert a string into the tape buffer.
+insBuffer :: Buffer s -> Int -> String -> ST s (Buffer s)
+insBuffer (MBuffer a) i e = return $ Insertion i (length e) e (MBuffer a)
+insBuffer (Insertion p l c n) i e
+ | i < p = Insertion (p+length e) l c <$> insBuffer n i e
+ | i >= p+l = Insertion p l c <$> insBuffer n (i-l) e
+ | i >= p && (i+length e) <= p+l =
+ return $ Insertion p (l+length e) (a++e++b) n
+ | otherwise = return $ Insertion i (length e) e $ Insertion p l c n
+ where (a,b) = splitAt (i-p) c
+insBuffer (Deletion p l n) i e
+ | i < p = Deletion (p+length e) l <$> insBuffer n i e
+ | i > p = Deletion p l <$> insBuffer n (i+l) e
+ | otherwise = return $ Insertion i (length e) e $ Deletion p l n
+
+-- | Delete a char from the tape buffer.
+delBuffer :: Buffer s -> Int -> ST s (Buffer s)
+delBuffer (MBuffer a) i = return $ Deletion i 1 $ MBuffer a
+delBuffer (Insertion p l c n) i
+ | i < p = Insertion (p-1) l c <$> delBuffer n i
+ | i >= p+l = Insertion p l c <$> delBuffer n (i-l)
+ | otherwise = return $ Insertion p (l-1) (a++b) n
+ where (a,_:b) = splitAt (i-p) c
+delBuffer (Deletion p l n) i
+ | i < p = Deletion (p-1) l <$> delBuffer n i
+ | i > p = Deletion p l <$> delBuffer n (i+l)
+ | otherwise = return $ Deletion p (l+1) n
+
+-- | Get a list of ETX positions in the tape buffer.
+etxBuffer :: Buffer s -> ST s [Int]
+etxBuffer (MBuffer a) = do
+ es <- M.getElems a
+ return $ elemIndices '\3' es
+etxBuffer (Insertion p l c n) = do
+ ne <- etxBuffer n
+ let ie = elemIndices '\3' c
+ return $ sort (map (+p) ie ++ map (\ne' -> if ne' < p then ne' else ne' + l) ne)
+etxBuffer (Deletion p l n) = do
+ ne <- etxBuffer n
+ return $ map (\ne -> if ne < p then ne else ne-l) $ filter (/=p) ne
+
+-- | Clone the tape buffer (fixing all modifiers into the newly created mutable array)
+cloneBuffer :: Buffer s -> ST s (Buffer s)
+cloneBuffer b = do
+ s <- joinBuffer b
+ a <- M.newListArray (0, length s - 1) s
+ return $ MBuffer a
+
+-- | Get the tape buffer`s length.
+measBuffer :: Buffer s -> ST s Int
+measBuffer (MBuffer a) = snd <$> M.getBounds a
+measBuffer (Insertion p l c n) = (+l) <$> measBuffer n
+measBuffer (Deletion p l n) = subtract l <$> measBuffer n
+
+instance Monad (CTPL0 s) where
+ return a = CTPL0 $ \i ref cfg -> return $ Succ (a,i)
+ m >>= f = CTPL0 $ \i ref cfg -> do
+ r <- runCTPL0 m i ref cfg
+ case r of
+ Succ (a, i') -> runCTPL0 (f a) i' ref cfg
+ Fail f -> return $ Fail f
+
+instance Functor (CTPL0 s) where
+ fmap = liftM
+
+instance Applicative (CTPL0 s) where
+ pure = return
+ (<*>) = ap
+
+-- | Run an 'ST' action inside a compatible 'CTPL0' block
+liftST :: ST s a -> CTPL0 s a
+liftST m = CTPL0 $ \i ref cfg -> Succ <$> (,i) <$> m
+
+-- | A handy wrapper around 'procInstrs'. Arguments: program, tape, config. Results: tape, leftover time, AX, CK top.
+evalCTPL0' :: String -> String -> VMConfig -> Exec (String, Int, Int, Int)
+evalCTPL0' program buffer cfg = runST $ do
+ let limit = maxTime cfg
+ bufsize = max (initBufferMeasure cfg) (length buffer+1)
+ bc <- newListArray (0, bufsize-1) (buffer ++ '\3' : replicate (bufsize-length buffer-1) '\0')
+ let pc = listArray (0, length program - 1) program
+ st = CTPL0State (MBuffer bc) pc 0 0 False 0 [] [length program] [0]
+ ref <- newSTRef st
+ r <- runCTPL0 procInstrs limit ref cfg{initBufferMeasure=bufsize}
+ case r of
+ Succ (_, i') -> do
+ st <- readSTRef ref
+ buf <- joinBuffer (bufferContent st)
+ return $ Succ (takeWhile (/='\3') buf, i', ax st, if null (ck st) then 0 else head $ ck st)
+ Fail f -> return $ Fail f
+
+-- | Another handy wrapper around 'procInstrs'. Less clumsy than 'evalCTPL0'', but provides less information. Arguments: program, tape, config. Results: tape only.
+evalCTPL0 :: String -> String -> VMConfig -> Exec String
+evalCTPL0 program buffer cfg =
+ case evalCTPL0' program buffer cfg of
+ Succ (s,_,_,_) -> Succ s
+ Fail f -> Fail f
+
+-- | Gets the carried 'CTPL0State' and runs a function on it.
+getState :: (CTPL0State s -> a) -> CTPL0 s a
+getState f =
+ CTPL0 $ \i ref cfg -> do
+ st <- readSTRef ref
+ return $ Succ (f st, i)
+
+-- | Runs a function on the carried 'CTPL0State'.
+modState :: (CTPL0State s -> CTPL0State s) -> CTPL0 s ()
+modState f =
+ CTPL0 $ \i ref cfg -> do
+ modifySTRef ref f
+ return $ Succ ((), i)
+
+-- | Consume virtual time. Raise 'Expired' if limit is reached.
+consumeTime :: CTPL0 s ()
+consumeTime = CTPL0 $ \i ref cfg -> if i >= 1 then return (Succ ((), i-1)) else return (Fail Expired)
+
+-- | Raise a 'ConfViol'.
+confViol :: CTPL0 s a
+confViol = CTPL0 $ \_ _ _ -> return $ Fail ConfViol
+
+-- | Raise a 'SynViol'.
+synViol :: CTPL0 s a
+synViol = CTPL0 $ \_ _ _ -> return $ Fail SynViol
+
+-- | Raise a 'Dead'.
+die :: String -> CTPL0 s a
+die s = CTPL0 $ \_ _ _ -> return . Fail $ Dead s
+
+-- | Fetch the next instruction.
+getInstr :: CTPL0 s Char
+getInstr = do
+ (c,p) <- getState (programContent &&& programPointer)
+ modState (\st -> st{programPointer=programPointer st+1})
+ return (c ! p)
+
+-- | Have we reached the end of the program tape?
+endOfInstr :: CTPL0 s Bool
+endOfInstr = do
+ (m,p) <- getState (snd . bounds . programContent &&& programPointer)
+ return (m < p)
+
+-- | Fetch numeric argument (as many digits as we can get)
+instrNumArg :: CTPL0 s Int
+instrNumArg = do
+ (c,p) <- getState (programContent &&& programPointer)
+ if snd (bounds c) <= p || not (isDigit (c!p)) then synViol else
+ let coll p | snd (bounds c) <= p = ""
+ coll p | not (isDigit (c!p)) = ""
+ coll p = (c!p) : coll (p+1)
+ str = coll p
+ in do
+ modState $ \st -> st{programPointer=programPointer st+length str}
+ return $ read str
+
+-- | Fetch string argument (delimited by '$')
+instrDelimArg :: CTPL0 s String
+instrDelimArg = do
+ (c,p) <- getState (programContent &&& programPointer)
+ if snd (bounds c) < p then synViol else
+ let coll p | snd (bounds c) < p = ""
+ coll p | (c!p) == '$' = "$"
+ coll p = (c!p) : coll (p+1)
+ str = coll p
+ in do
+ modState $ \st -> st{programPointer=programPointer st+length str}
+ unless (last str == '$') synViol
+ return $ init str
+
+-- | Run an action (first arg) iff the test (second arg) succeeds. Raise 'ConfViol' otherwise.
+provided :: CTPL0 s a -> CTPL0 s Bool -> CTPL0 s a
+provided act test = do
+ b <- test
+ if b
+ then act
+ else confViol
+
+-- | SX is AX by default, but CK top after 'C'.
+sx :: CTPL0State s -> Int
+sx r | cp r = head $ ck r
+sx r = ax r
+
+-- | Set SX (AX or CK top) value.
+setSX :: Int -> CTPL0State s -> CTPL0State s
+setSX i r | cp r = if null (ck r) then r{ck=[i]} else r{ck=i:tail (ck r)}
+setSX i r = r{ax=i}
+
+-- | Run the next instruction in program.
+singleInstr :: CTPL0 s ()
+singleInstr = do
+ i <- getInstr
+ consumeTime
+ case i of
+ -- Walk left
+ '<' -> modState (\st -> st{bufferPointer=bufferPointer st-1})
+ `provided` getState (\st -> bufferPointer st > 0)
+ -- Walk right
+ '>' -> modState (\st -> st{bufferPointer=bufferPointer st+1})
+ `provided` do
+ (p,c) <- getState (bufferPointer &&& bufferContent)
+ liftST $ accBuffer c (p+1)
+
+ -- Inc SX
+ '+' -> do
+ num <- instrNumArg
+ modState $ \st -> setSX (sx st + num) st
+ -- Dec SX
+ '-' -> do
+ num <- instrNumArg
+ modState $ \st -> setSX (sx st - num) st
+ -- Insert char, go after
+ 'i' -> do
+ ch <- getInstr `provided` liftM not endOfInstr
+ (p,c) <- getState (bufferPointer &&& bufferContent)
+ c' <- liftST $ insBuffer c p [ch]
+ modState $ \st -> st{bufferContent=c',bufferPointer=bufferPointer st + 1}
+ -- Insert string, go after
+ 'I' -> do
+ str <- instrDelimArg
+ (p,c) <- getState (bufferPointer &&& bufferContent)
+ c' <- liftST $ insBuffer c p str
+ modState $ \st -> st{bufferContent=c',bufferPointer=bufferPointer st + length str}
+ -- Replace char, stay
+ 'r' -> do
+ ch <- getInstr `provided` liftM not endOfInstr
+ (p,c) <- getState (bufferPointer &&& bufferContent)
+ c' <- liftST $ writeBuffer c p ch
+ modState $ \st -> st{bufferContent=c'}
+ -- Delete char
+ 'x' -> do
+ (p,c) <- getState (bufferPointer &&& bufferContent)
+ c' <- liftST $ delBuffer c p
+ modState $ \st -> st{bufferContent=c'}
+ -- Append char, don't walk
+ 'a' -> do
+ ch <- getInstr `provided` liftM not endOfInstr
+ (p,c) <- getState (bufferPointer &&& bufferContent)
+ etx <- liftST $ etxBuffer c
+ case etx of
+ [] -> confViol
+ etx:_ -> do
+ c' <- liftST $ writeBuffer c etx ch
+ c'' <- liftST $ writeBuffer c' (etx+1) '\3'
+ modState $ \st -> st{bufferContent=c''}
+ when (etx<p) $ modState $ \st -> st{bufferPointer=bufferPointer st + 1}
+ -- Append string, don't walk
+ 'A' -> do
+ str <- instrDelimArg
+ (p,c) <- getState (bufferPointer &&& bufferContent)
+ etx <- liftST $ etxBuffer c
+ case etx of
+ [] -> confViol
+ etx:_ -> do
+ (c',etx') <- foldl (\l r -> do (c,etx) <- l; c' <- liftST $ writeBuffer c etx r; return (c,etx+1)) (return (c,etx)) str
+ c'' <- liftST $ writeBuffer c' etx' '\3'
+ modState $ \st -> st{bufferContent=c''}
+ when (etx<p) $ modState $ \st -> st{bufferPointer=bufferPointer st + 1}
+ -- Set SX=0
+ '0' -> do
+ modState $ setSX 0
+ -- Set SX=CP
+ 'Q' -> do
+ modState $ \st -> setSX (bufferPointer st) st
+ -- Set CP=SX
+ 'm' -> do
+ modState (\st -> st{bufferPointer=sx st}) `provided` do
+ (c,s) <- getState (bufferContent &&& sx)
+ liftST $ accBuffer c s
+ -- Choose CK(0) for SX
+ 'C' -> modState (\st -> st{cp=True}) `provided` getState (not . null . ck)
+ -- Load [CP] into SX
+ 'l' -> do
+ (p,c) <- getState (bufferPointer &&& bufferContent)
+ s <- liftST $ readBuffer c p
+ modState $ \st -> setSX (ord s) st
+ -- Save SX into [CP]
+ 's' -> do
+ (p,(c,s)) <- getState (bufferPointer &&& bufferContent &&& sx)
+ c' <- liftST $ writeBuffer c p (chr s)
+ modState $ \st -> st{bufferContent=c'}
+ -- Push SX onto CK
+ 'd' -> modState $ \st -> st{ck=sx st : ck st}
+ -- Pop AX from CK
+ 'D' -> modState (\st -> st{ax=head $ ck st, ck=tail $ ck st})
+ `provided` getState (not . null . ck)
+ -- Pop CK, discard
+ 'k' -> modState (\st -> st{ck=tail $ ck st})
+ `provided` getState (not . null . ck)
+ -- Set SX=LEN
+ 'L' -> do
+ c <- getState bufferContent
+ etx <- liftST $ etxBuffer c
+ case etx of
+ [] -> confViol
+ etx':_ -> modState $ setSX etx'
+ -- Swap tape and MK(0)
+ 'H' ->
+ modState (\st -> st{mk=bufferContent st : tail (mk st), bufferContent=head (mk st)})
+ `provided` getState (not . null . mk)
+ -- Push entire tape to MK
+ 't' -> do
+ c <- getState bufferContent
+ c' <- liftST $ cloneBuffer c
+ modState $ \st -> st{mk=c' : mk st}
+ -- Push [CP] to MK
+ 'y' -> do
+ (c,p) <- getState (bufferContent &&& bufferPointer)
+ (ch,len,a) <- liftST $ do
+ ch <- readBuffer c p
+ len <- measBuffer c
+ a <- newListArray (0,len) (ch : '\3' : replicate (len-1) '\0')
+ return (ch,len,a)
+ modState $ \st -> st{mk=MBuffer a : mk st}
+ -- Pop MK, discard content
+ 'p' -> modState (\st -> st{mk=tail $ mk st})
+ `provided` getState (not . null . mk)
+ -- Append [CP] to MK(0)
+ 'Y' -> (do
+ (c,(p,a)) <- getState (bufferContent &&& bufferPointer &&& head . mk)
+ ch <- liftST $ readBuffer c p
+ etx <- liftST $ etxBuffer a
+ case etx of
+ [] -> confViol
+ etx':_ -> do
+ a' <- liftST $ writeBuffer a etx' ch
+ a'' <- liftST $ writeBuffer a' (etx'+1) '\3'
+ modState (\st -> st{mk=a'':tail (mk st)}))
+ `provided` getState (not . null . mk)
+ -- Peek MK, insert, go after
+ 'P' -> (do
+ (c,(p,a)) <- getState (bufferContent &&& bufferPointer &&& head . mk)
+ js <- liftST $ joinBuffer a
+ let s = takeWhile (/='\3') js
+ c' <- liftST $ insBuffer c p s
+ modState $ \st -> st{bufferContent=c',bufferPointer=bufferPointer st+length s})
+ `provided` getState (not . null . mk)
+ -- Absolute jump to SX
+ 'j' -> do
+ a <- getState sx
+ b <- singleCond
+ when b $ modState $ \st -> st{programPointer=a}
+ -- Relative jump by SX
+ 'J' -> do
+ a <- getState sx
+ b <- singleCond
+ when b $ modState $ \st -> st{programPointer=a+programPointer st}
+ -- Call procedure at SX, push IP to RK
+ 'c' -> do
+ a <- getState sx
+ b <- singleCond
+ when b $ modState $ \st -> st{rk=(programPointer st):rk st, programPointer=a}
+ -- Return to RK(0), pop RK
+ 'f' -> (modState $ \st -> st{programPointer=head (rk st), rk=tail (rk st)})
+ `provided` getState (not . null . rk)
+ -- Swap MK(0) and MK(1)
+ 'h' ->
+ modState (\st -> st{mk=(mk st !! 1):(mk st !! 0):(drop 2 $ mk st)})
+ `provided` getState ((>=2) . length . mk)
+ -- Catch others
+ o -> synViol
+ {-do
+ ip <- getState programPointer
+ die ("SynViol in singleInstr: " ++ [o] ++ " (pos "++ show ip++")")-}
+ unless (i=='C') $ modState $ \st -> st{cp=False}
+
+
+-- | Evaluate a condition.
+singleCond :: CTPL0 s Bool
+singleCond = do
+ i <- getInstr `provided` liftM not endOfInstr
+ case i of
+ -- Is uppercase?
+ 'U' -> do
+ (c, p) <- getState (bufferContent &&& bufferPointer)
+ isUpper <$> liftST (readBuffer c p)
+ -- Is lowercase?
+ 'L' -> do
+ (c, p) <- getState (bufferContent &&& bufferPointer)
+ isLower <$> liftST (readBuffer c p)
+ -- SX = 0?
+ 'z' -> getState ((==0) . sx)
+ -- Always true
+ 't' -> return True
+ -- Is digit?
+ 'N' -> do
+ (c, p) <- getState (bufferContent &&& bufferPointer)
+ isDigit <$> liftST (readBuffer c p)
+ -- End of buffer?
+ 'e' -> do
+ (c, p) <- getState (bufferContent &&& bufferPointer)
+ realEnd <- not <$> liftST (accBuffer c (p+1))
+ etxEnd <- if realEnd then return '\3' else liftST (readBuffer c p)
+ return (etxEnd == '\3')
+ -- Negation
+ '!' -> not <$> singleCond
+ -- Disjunction
+ '|' -> (||) <$> singleCond <*> singleCond
+ -- Conjunction
+ '&' -> (&&) <$> singleCond <*> singleCond
+ -- match char?
+ 'q' -> do
+ ch <- getInstr `provided` liftM not endOfInstr
+ (c, p) <- getState (bufferContent &&& bufferPointer)
+ a <- liftST $ readBuffer c p
+ return (a == ch)
+ -- CP < SX ?
+ 'l' -> uncurry (<) <$> getState (bufferPointer &&& sx)
+ -- CP > SX ?
+ 'g' -> uncurry (>) <$> getState (bufferPointer &&& sx)
+ -- CP == SX ?
+ 'E' -> uncurry (==) <$> getState (bufferPointer &&& sx)
+ -- toggle SX
+ 'C' -> modState (\st -> st{cp=not $ cp st}) >> singleCond
+ `provided` getState (not . null . ck)
+ -- AX == CK(0) ?
+ '=' -> uncurry (==) <$> getState (ax &&& head . ck)
+ `provided` getState (not . null . ck)
+ -- AX < CK(0) ?
+ '<' -> uncurry (<) <$> getState (ax &&& head . ck)
+ `provided` getState (not . null . ck)
+ -- AX > CK(0) ?
+ '>' -> uncurry (>) <$> getState (ax &&& head . ck)
+ `provided` getState (not . null . ck)
+ -- pop CK, discard, continue
+ 'k' -> (modState (\st -> st{ck=tail $ ck st}) >> singleCond)
+ `provided` getState (not . null . ck)
+ -- Catch others
+ o -> synViol
+
+-- | Run the entire program.
+procInstrs :: CTPL0 s ()
+procInstrs = singleInstr `asLongAs` (not <$> endOfInstr)
+ where asLongAs act test = do
+ b <- test
+ when b $ act >> act `asLongAs` test
diff --git a/compiler.hs b/compiler.hs
new file mode 100644
index 0000000..2611a5f
--- /dev/null
+++ b/compiler.hs
@@ -0,0 +1,38 @@
+import System.Environment
+import System.IO
+import Text.CTPL
+
+comp :: String -> CCConfig -> IO ()
+comp str cfg =
+ case compileCTPL str cfg of
+ Succ a -> putStrLn a
+ NoSuchProc nm ->
+ hPutStrLn stderr ("Error: No such procedure \""++nm++"\".")
+ SyntaxFault ->
+ hPutStrLn stderr "Error: Syntax fault."
+
+main = do
+ args <- getArgs
+ case args of
+ ["--old"] -> do
+ str <- getContents
+ comp str oldConfig
+ ["--new"] -> do
+ str <- getContents
+ comp str newConfig
+ ["--old", f] -> do
+ str <- readFile f
+ comp str oldConfig
+ ["--new", f] -> do
+ str <- readFile f
+ comp str newConfig
+ ["--help"] -> do
+ putStrLn "ctplc 0.1"
+ putStrLn "-------------"
+ putStrLn "A compiler for CTPL."
+ putStrLn "Synapsis:"
+ putStrLn " ctplc --old [<program-file>]"
+ putStrLn " Compiles the given file (or stdin) for the old (and new) VM."
+ putStrLn " ctplc --new [<program-file>]"
+ putStrLn " Compiles the given file (or stdin) for the new VM only."
+ _ -> hPutStrLn stderr "Don't know what to do. See --help for help."
diff --git a/ctpl.cabal b/ctpl.cabal
index 8378e72..4b0ba64 100644
--- a/ctpl.cabal
+++ b/ctpl.cabal
@@ -10,7 +10,7 @@ name: ctpl
-- PVP summary: +-+------- breaking API changes
-- | | +----- non-breaking API additions
-- | | | +--- code changes with no API change
-version: 0.1.0.1
+version: 0.1.0.4
-- A short (one-line) description of the package.
synopsis: A programming language for text modification.
@@ -31,6 +31,8 @@ author: Marvin Cohrs
-- patches.
maintainer: m@doomanddarkness.eu
+homepage: http://doomanddarkness.eu/pub/ctpl
+
-- A copyright notice.
-- copyright:
@@ -48,7 +50,7 @@ cabal-version: >=1.10
library
-- Modules exported by the library.
- exposed-modules: Text.CTPL, Text.CTPL0
+ exposed-modules: Text.CTPL, Text.CTPL0, Text.CTPL0n
-- Modules included in this library but not exported.
-- other-modules:
@@ -57,11 +59,29 @@ library
-- other-extensions:
-- Other library packages from which modules are imported.
- build-depends: base >=4.6 && <4.8, chatty-text >=0.6 && <0.7, chatty-utils >=0.7.1.2 && <0.8
+ build-depends: base >=4.6 && <4.9,
+ chatty-text >=0.6,
+ chatty-utils >=0.7.1.2,
+ array >= 0.5
-- Directories containing source files.
-- hs-source-dirs:
-- Base language which the package is written in.
default-language: Haskell2010
- \ No newline at end of file
+
+executable ctpl0debug
+ build-depends: base >= 4.6 && <4.9,
+ chatty-text >=0.6,
+ chatty-utils >=0.7.1.2,
+ array >= 0.5
+ main-is: debugger.hs
+ default-language: Haskell2010
+
+executable ctplc
+ build-depends: base >= 4.6 && <4.9,
+ chatty-text >=0.6,
+ chatty-utils >=0.7.1.2,
+ array >= 0.5
+ main-is: compiler.hs
+ default-language: Haskell2010
diff --git a/debugger.hs b/debugger.hs
new file mode 100644
index 0000000..2fdaa3b
--- /dev/null
+++ b/debugger.hs
@@ -0,0 +1,89 @@
+import Control.Applicative
+import Control.Monad
+import Control.Monad.ST
+import Data.STRef
+import Data.Array.Unboxed
+import Data.Array.ST
+import Data.Char
+import Data.Chatty.AVL
+import Data.List
+import System.Environment
+import qualified Text.CTPL0 as Old
+import qualified Text.CTPL0n as New
+
+debugOld :: String -> String -> IO ()
+debugOld prog str =
+ let state0 = Old.CTPL0State buffer0 program0 register0 info0
+ buffer0
+ | null str = Old.BufferState [] (chr 3) []
+ | otherwise = Old.BufferState [] (head str) (tail str ++ [chr 3])
+ program0
+ | null prog = Old.BufferState [] (chr 3) []
+ | otherwise = Old.BufferState [] (head prog) (tail prog ++ [chr 3])
+ register0 = Old.RegisterState 0 [] [length prog] [0] False
+ info0 = Old.InfoState EmptyAVL
+ imprf avl = sortBy (\b a -> snd a `compare` snd b) $ avlInorder avl
+ in debugOldProg 10000 state0
+
+debugOldProg :: Int -> Old.CTPL0State -> IO ()
+debugOldProg limit state =
+ let prst (Old.CTPL0State b p r f) i m =
+ putStrLn (show (Old.unetx (reverse (Old.leftBehind b) ++ [Old.thisChar b] ++ Old.rightPending b)) ++ " I="++show i++" AX="++show (Old.ax r)++" CK="++concat(intersperse ":" (map show $ Old.ck r))++" IP=" ++ show (length $ Old.leftBehind p)++ " BP="++ show (length $ Old.leftBehind b) ++ " | "++m)
+ in case Old.runCTPL0 Old.endOfInstr limit state of
+ Old.Succ (True, st, i) -> prst st i "Program finished."
+ Old.Succ (False, st, i) ->
+ case Old.runCTPL0 Old.singleInstr limit state of
+ Old.Succ (_, st, i) -> do
+ prst st i "<>"
+ debugOldProg i st
+ Old.Expired -> putStrLn "Expired."
+ Old.SynViol -> putStrLn "Syntax violation."
+ Old.ConfViol -> putStrLn "Confidence violation."
+
+debugNew :: String -> String -> IO ()
+debugNew prog str = mapM_ putStrLn $ runST $ do
+ let limit = New.maxTime New.safeVM
+ bufsize = max (New.initBufferMeasure New.safeVM) (length str+1)
+ bc <- newListArray (0, bufsize-1) (str++'\3':replicate (bufsize-length str-1) '\0')
+ let pc = listArray (0, length prog - 1) prog
+ state0 = New.CTPL0State (New.MBuffer bc) pc 0 0 False 0 [] [length prog] [0]
+ ref <- newSTRef state0
+ debugNewProg limit ref New.safeVM
+
+debugNewProg :: Int -> STRef s (New.CTPL0State s) -> New.VMConfig -> ST s [String]
+debugNewProg limit state cfg =
+ let prst ref i m = do
+ New.CTPL0State bc pc bp pp cp ax mk rk ck <- readSTRef ref
+ buf <- New.joinBuffer bc
+ return (show buf ++ " I=" ++ show i ++ " AX=" ++ show ax ++ " CK="++concat(intersperse ":" $ map show ck) ++ " IP=" ++ show pp ++ " BP="++show bp++" | "++m)
+ in do
+ r <- New.runCTPL0 New.endOfInstr limit state cfg
+ case r of
+ New.Succ (True, i) -> return <$> prst state i "Program finished."
+ New.Succ (False, i) -> do
+ r <- New.runCTPL0 New.singleInstr limit state cfg
+ case r of
+ New.Succ (_, i) -> (:) <$> prst state i "<>" <*> debugNewProg i state cfg
+ New.Fail f -> return [show f]
+
+main = do
+ args <- getArgs
+ case args of
+ ["--old", progf, buff] -> do
+ prog <- readFile progf
+ buf <- readFile buff
+ debugOld (init prog) (init buf)
+ ["--new", progf, buff] -> do
+ prog <- readFile progf
+ buf <- readFile buff
+ debugNew (init prog) (init buf)
+ ["--help"] -> do
+ putStrLn "ctpl0debug 0.1"
+ putStrLn "----------------"
+ putStrLn "A debugger for CTPL0 (both VMs)"
+ putStrLn "Synapsis:"
+ putStrLn " ctpl0debug --old <program-file> <input-file>"
+ putStrLn " Debugs execution with the old VM"
+ putStrLn " ctpl0debug --new <program-file> <input-file>"
+ putStrLn " Debugs execution with the new VM"
+ _ -> putStrLn "Don't know what to do. See --help for help"