Added DROP intrinsic

1 files changed, 17 insertions, 6 deletions

diff --git a/DSL.hs b/DSL.hs
index 74259e8..3be234b 100644
--- a/DSL.hs
+++ b/DSL.hs
@@ -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