quasiquoting for patterns

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

diff --git a/datatype/Compiler.hs b/datatype/Compiler.hs
index 1070ecb..482bcee 100644 (file)
--- a/datatype/Compiler.hs
+++ b/datatype/Compiler.hs
@@ -91,6 +91,7 @@ instance Expression Compiler where
         p >> instr [Brf elselabel] >>
         t >> instr [Bra endiflabel, Lbl elselabel] >>
         e >> instr [Lbl endiflabel]
+    bottom msg = instr [Error msg]
 
 instance Function () Compiler where
     fun def = Main $
@@ -123,7 +124,7 @@ liftFunction lbl nargs body = do
     modify (\s->s { functions=DM.insert lbl instructions $ functions s })
 
 data Instr
-    = Push Int | Pop Int | Dup | Roll Int Int
+    = Push Int | Pop Int -- | Dup | Roll Int Int
     | Add | Sub | Mul | Div | Neg | Pow
     | And | Or | Not
     | Eq | Neq | Le | Ge | Leq | Geq
@@ -131,7 +132,7 @@ data Instr
     | Str Int | Ldr Int
     | Sth Int | Ldh Int
     | Jsr Int | Ret Int | Arg Int
-    | Halt
+    | Halt | Error String
   deriving Show
 
 data Registers = Registers
@@ -143,12 +144,15 @@ data Registers = Registers
     }
   deriving Show
 
-interpret :: Int -> [Instr] -> Array Int Int
-interpret memsize prog = runSTArray $ do
-    program <- newListArray (0, length prog) prog
-    mem <- newArray (0, memsize-1) 0
-    int program mem (Registers {pc=0, sp=memsize-1, mp=0, hp=0, gp=DM.empty})
+interpret :: Int -> [Instr] -> Int
+interpret memsize prog = runSTArray resultStack ! (memsize-1)
   where
+    resultStack :: ST s (STArray s Int Int)
+    resultStack = join $ int
+        <$> newListArray (0, length prog) prog
+        <*> newArray (0, memsize-1) 0
+        <*> pure (Registers {pc=0, sp=memsize-1, mp=0, hp=0, gp=DM.empty})
+
     pushh :: STArray s Int Int -> Int -> Registers -> ST s Registers
     pushh memory value reg = do
         writeArray memory (hp reg) value
@@ -195,19 +199,19 @@ interpret memsize prog = runSTArray $ 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
+--            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
+--            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
@@ -215,12 +219,12 @@ interpret memsize prog = runSTArray $ do
             Neg -> uop negate memory reg >>= int program memory
             Pow -> bop (^) memory reg >>= int program memory
             And -> bop ((b2i .) . on (&&) i2b) memory reg >>= int program memory
-            Or -> bop ((b2i .) . on (||) i2b) memory reg >>= int program memory
+            Or  -> bop ((b2i .) . on (||) i2b) memory reg >>= int program memory
             Not -> uop (b2i . Prelude.not . i2b) memory reg >>= int program memory
-            Eq -> bop ((b2i .) . (==)) memory reg >>= int program memory
+            Eq  -> bop ((b2i .) . (==)) memory reg >>= int program memory
             Neq -> bop ((b2i .) . (/=)) memory reg >>= int program memory
-            Le -> bop ((b2i .) . (<)) memory reg >>= int program memory
-            Ge -> bop ((b2i .) . (>)) memory reg >>= int program memory
+            Le  -> bop ((b2i .) . (<)) memory reg >>= int program memory
+            Ge  -> bop ((b2i .) . (>)) memory reg >>= int program memory
             Leq -> bop ((b2i .) . (<=)) memory reg >>= int program memory
             Geq -> bop ((b2i .) . (>=)) memory reg >>= int program memory
             Lbl _ -> int program memory reg
@@ -241,16 +245,14 @@ interpret memsize prog = runSTArray $ do
                 >>= branch i program
                 >>= \r->int program memory (r { mp = sp r})
             Ret n -> do
-                (reg1, rval) <- pop memory reg
-                (reg2, omp) <- pop memory reg1
-                (reg3, ra) <- pop memory reg2
-                (reg4, _) <- popn memory n reg3
-                reg5 <- push memory rval reg4
-                int program memory $ reg5 { pc=ra, mp=omp }
+                (reg1, rval:omp:ra:_) <- popn memory (3+n) reg
+                reg2 <- push memory rval reg1
+                int program memory $ reg2 { pc=ra, mp=omp }
             Arg n -> do
                 v <- readArray memory (mp reg + 3 + n)
                 push memory v reg >>= int program memory
             Halt -> pure memory
+            Error msg -> fail msg
 
     branch :: Int -> STArray s Int Instr -> Registers -> ST s Registers
     branch label program reg = case pc reg of