support all other patterns and nested patterns

[clean-tests.git] / datatype / Compiler.hs

diff --git a/datatype/Compiler.hs b/datatype/Compiler.hs
index 4785e94..adb148f 100644 (file)
--- a/datatype/Compiler.hs
+++ b/datatype/Compiler.hs
@@ -43,7 +43,7 @@ instr :: [Instr] -> Compiler a
 instr i = tell i >> pure undefined
 
 freshLabel :: Compiler Int
-freshLabel = get >>= \cs->put (cs { fresh=tail (fresh cs) }) >> pure (head $ fresh cs)
+freshLabel = gets fresh >>= \(f:fs)->modify (\s->s { fresh=fs }) >> pure f
 
 binop :: Instr -> Compiler a1 -> Compiler a2 -> Compiler b
 binop i l r = l >> r >> instr [i]
@@ -52,7 +52,7 @@ unop :: Instr -> Compiler a -> Compiler b
 unop i l = l >> instr [i]
 
 instance Expression Compiler where
-    lit v = instr $ map Push $ serialise v []
+    lit v = instr [Push $ serialise v]
     (+.) = binop Add
     (-.) = binop Sub
     (/.) = binop Div
@@ -177,27 +177,14 @@ interpret memsize prog = runSTArray resultStack ! (memsize-1)
     int :: STArray s Int Instr -> STArray s Int Int -> Registers -> ST s (STArray s Int Int)
     int program memory registers = do
         instruction <- readArray program $ pc registers
---        stack <- getElems memory
         let reg = registers { pc = pc registers + 1 }
---        case trace ("Interpret: " ++ show instruction ++ " with registers: " ++ show registers ++ " and stack: " ++ show stack) instruction of
         case instruction of
             Str r -> do
                 (reg', v) <- pop memory reg
                 int program memory $ reg' { gp = DM.insert r v (gp reg')}
             Ldr r -> push memory (DM.findWithDefault 0 r $ gp reg) reg >>= int program memory
---            Roll 0 _ -> int program memory reg
---            Roll 1 _ -> int program memory reg
---            Roll _ 0 -> int program memory reg
---            Roll depth num -> do
---                (reg', vs) <- popn memory depth reg
---                foldM (flip $ push memory) reg' (roll num [] $ reverse vs) >>= int program memory
---              where
---                roll 0 acc vs = vs ++ reverse acc
---                roll n acc [] = roll n [] $ reverse acc
---                roll n acc (v:vs) = roll (n-1) (v:acc) vs
             Pop n -> popn memory n reg >>= int program memory . fst
             Push v -> push memory v reg >>= int program memory
---            Dup -> pop memory reg >>= \(r', v)->push memory v r' >>= push memory v >>= int program memory
             Add -> bop (+) memory reg >>= int program memory
             Sub -> bop (-) memory reg >>= int program memory
             Mul -> bop (*) memory reg >>= int program memory