diff options
Diffstat (limited to 'DSL.hs')
| -rw-r--r-- | DSL.hs | 23 |
1 files changed, 17 insertions, 6 deletions
@@ -22,6 +22,11 @@ type Stack = [StackData] data Intrinsic = I_DUMP + | I_DROP {- + | I_SWAP + | I_DUP + | I_OVER + | I_ROT -} deriving (Show, Eq) data Operation @@ -75,7 +80,9 @@ mainLexer = phrase $ mult1 $ firstOf subLexers literals = [ intLiteralL ] intrinsics = map (uncurry intrinsicL) [ (".", I_DUMP) + , ("DROP", I_DROP) ] + ------------------------------------------------------------------------------ -- Parsing ------------------------------------------------------------------------------ @@ -128,9 +135,12 @@ stringToProgram str = do ------------------------------------------------------------------------------ dump :: Machine -> IO Machine -dump m = case stack m of - [] -> hcf m "DUMP: stack underflow" - x:xs -> putStrLn (show x) >> return m{ stack=xs } +dump m@Machine{ stack=[] } = hcf m "DUMP: stack underflow" +dump m@Machine{ stack=x:xs } = putStrLn (show x) >> return m{ stack=xs } + +drop' :: Machine -> IO Machine +drop' m@Machine{ stack=[] } = hcf m "DROP: stack underflow" +drop' m@Machine{ stack=_:xs } = return m{ stack=xs } ------------------------------------------------------------------------------ -- Core operations @@ -143,8 +153,9 @@ hcf m msg = putStrLn msg >> return m{ ok=False } pushData :: Machine -> StackData -> Machine pushData m@Machine{ stack=xs } x = m{ stack=x:xs } -applyIntrinsic :: Machine -> Intrinsic -> IO Machine -applyIntrinsic m I_DUMP = dump m +applyIntrinsic :: Intrinsic -> Machine -> IO Machine +applyIntrinsic I_DUMP = dump +applyIntrinsic I_DROP = drop' ------------------------------------------------------------------------------ -- Interpretation @@ -157,7 +168,7 @@ applyOperation :: Machine -> Operation -> IO Machine -- take no action if a previous step failed applyOperation m@Machine{ ok=False } _ = return m applyOperation m (OpPushData x) = return $ pushData m x -applyOperation m (OpIntrinsic i) = applyIntrinsic m i +applyOperation m (OpIntrinsic i) = applyIntrinsic i m applyLinear :: Machine -> [Operation] -> IO Machine applyLinear = foldlM applyOperation |