first order simple patterns

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

diff --git a/datatype/Compiler.hs b/datatype/Compiler.hs
index 482bcee..4785e94 100644 (file)
--- a/datatype/Compiler.hs
+++ b/datatype/Compiler.hs
@@ -57,26 +57,6 @@ instance Expression Compiler where
     (-.) = binop Sub
     (/.) = binop Div
     (*.) = binop Mul
-    (^.) = binop Pow
---    (^.) l r = freshLabel >>= \lblstart->freshLabel >>= \lblend->
---        l >> r >> instr -- pow (x, y) {
---            [ Str 1
---            , Str 0
---            , Push 1        -- res = 1
---            , Lbl lblstart  -- while
---            , Ldr 1         -- (y == 0)
---            , Push 0        --
---            , Neq           --
---            , Brf lblend    --
---            , Ldr 0         -- res *= x
---            , Mul           --
---            , Ldr 1         -- y -= 1
---            , Push 1        --
---            , Sub           --
---            , Str 1         --
---            , Bra lblstart  --
---            , Lbl lblend    --
---            ]
     neg = unop Neg
     (&.) = binop And
     (|.) = binop Or
@@ -117,6 +97,12 @@ instance Function (Compiler a, Compiler b, Compiler c) Compiler where
         let g :- m = def (\(a, b, c)->a >> b >> c >> instr [Jsr funlabel])
         in  liftFunction funlabel 3 (g (instr [Arg 2], instr [Arg 1], instr [Arg 0])) >> unmain m
 
+instance Function (Compiler a, Compiler b, Compiler c, Compiler d) Compiler where
+    fun def = Main $
+        freshLabel >>= \funlabel->
+        let g :- m = def (\(a, b, c, d)->a >> b >> c >> d >> instr [Jsr funlabel])
+        in  liftFunction funlabel 4 (g (instr [Arg 3], instr [Arg 2], instr [Arg 1], instr [Arg 0])) >> unmain m
+
 liftFunction :: Int -> Int -> Compiler a -> Compiler ()
 liftFunction lbl nargs body = do
     is <- snd <$> censor (\_->[]) (listen body)
@@ -124,8 +110,8 @@ 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
-    | Add | Sub | Mul | Div | Neg | Pow
+    = Push Int | Pop Int
+    | Add | Sub | Mul | Div | Neg
     | And | Or | Not
     | Eq | Neq | Le | Ge | Leq | Geq
     | Lbl Int | Bra Int | Brf Int
@@ -191,10 +177,10 @@ 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
+--        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
+--        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')}
@@ -217,7 +203,6 @@ interpret memsize prog = runSTArray resultStack ! (memsize-1)
             Mul -> bop (*) memory reg >>= int program memory
             Div -> bop div memory reg >>= int program memory
             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
             Not -> uop (b2i . Prelude.not . i2b) memory reg >>= int program memory