More core stack operations

1 files changed, 30 insertions, 5 deletions

diff --git a/DSL.hs b/DSL.hs
index 3be234b..46ab664 100644
--- a/DSL.hs
+++ b/DSL.hs
@@ -21,12 +21,13 @@ instance Show StackData where
 type Stack = [StackData]
 
 data Intrinsic
+  -- core/stack operations
   = I_DUMP
-  | I_DROP {-
+  | I_DROP
   | I_SWAP
   | I_DUP
   | I_OVER
-  | I_ROT -}
+  | I_ROT
     deriving (Show, Eq)
 
 data Operation
@@ -79,8 +80,12 @@ mainLexer = phrase $ mult1 $ firstOf subLexers
     subLexers = [wsL] ++ literals ++ intrinsics
     literals = [ intLiteralL
                ]
-    intrinsics = map (uncurry intrinsicL) [ (".", I_DUMP)
+    intrinsics = map (uncurry intrinsicL) [ (".",    I_DUMP)
                                           , ("DROP", I_DROP)
+                                          , ("SWAP", I_SWAP)
+                                          , ("DUP",  I_DUP)
+                                          , ("OVER", I_OVER)
+                                          , ("ROT",  I_ROT)
                                           ]
 
 ------------------------------------------------------------------------------
@@ -135,12 +140,28 @@ stringToProgram str = do
 ------------------------------------------------------------------------------
 
 dump :: Machine -> IO Machine
-dump m@Machine{ stack=[] }   = hcf m "DUMP: stack underflow"
 dump m@Machine{ stack=x:xs } = putStrLn (show x) >> return m{ stack=xs }
+dump m                       = hcf m "DUMP: stack underflow"
 
 drop' :: Machine -> IO Machine
-drop' m@Machine{ stack=[] }   = hcf m "DROP: stack underflow"
 drop' m@Machine{ stack=_:xs } = return m{ stack=xs }
+drop' m                       = hcf m "DROP: stack underflow"
+
+swap :: Machine -> IO Machine
+swap m@Machine{ stack=x:y:xs } = return m{ stack=y:x:xs }
+swap m                         = hcf m "SWAP: stack underflow"
+
+dup :: Machine -> IO Machine
+dup m@Machine{ stack=x:xs } = return m{ stack=x:x:xs }
+dup m                       = hcf m "DUP: stack underflow"
+
+over :: Machine -> IO Machine
+over m@Machine{ stack=x:y:xs } = return m{ stack=y:x:y:xs }
+over m                         = hcf m "OVER: stack underflow"
+
+rot :: Machine -> IO Machine
+rot m@Machine{ stack=x:y:z:xs } = return m{ stack=y:z:x:xs }
+rot m                           = hcf m "ROT: stack underflow"
 
 ------------------------------------------------------------------------------
 -- Core operations
@@ -156,6 +177,10 @@ pushData m@Machine{ stack=xs } x = m{ stack=x:xs }
 applyIntrinsic :: Intrinsic -> Machine -> IO Machine
 applyIntrinsic I_DUMP = dump
 applyIntrinsic I_DROP = drop'
+applyIntrinsic I_SWAP = swap
+applyIntrinsic I_DUP  = dup
+applyIntrinsic I_OVER = over
+applyIntrinsic I_ROT  = rot
 
 ------------------------------------------------------------------------------
 -- Interpretation