diff --git a/array-forth.cabal b/array-forth.cabal --- a/array-forth.cabal +++ b/array-forth.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.2.0.3 +version: 0.2.0.4 -- A short (one-line) description of the package. synopsis: A simple interpreter for arrayForth, the language used on GreenArrays chips. @@ -80,3 +80,10 @@ Main-is: src/Run.hs build-depends: base >3 && <=5, vector ==0.9.*, split ==0.1.*, array-forth GHC-options: -Wall -rtsopts + +test-suite test-array-forth + Type: exitcode-stdio-1.0 + Main-is: test/Language/ArrayForth/Test.hs + build-depends: base >3 && <=5, QuickCheck >= 2 && <3, HUnit >= 1 && < 2, + test-framework-th ==0.*, test-framework-quickcheck2 ==0.*, + test-framework-hunit ==0.*, array-forth diff --git a/test/Language/ArrayForth/Test.hs b/test/Language/ArrayForth/Test.hs new file mode 100644 --- /dev/null +++ b/test/Language/ArrayForth/Test.hs @@ -0,0 +1,347 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} +module Main where + +import Control.Applicative ((<$>), (<*>)) + +import Data.Bits (complement, xor, (.&.)) + +import Language.ArrayForth.Interpreter +import Language.ArrayForth.NativeProgram +import Language.ArrayForth.Opcode +import Language.ArrayForth.Parse () +import Language.ArrayForth.Program +import Language.ArrayForth.Stack +import Language.ArrayForth.State hiding (State (..)) +import qualified Language.ArrayForth.State as S + +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import Test.Framework.TH +import Test.HUnit +import Test.QuickCheck (forAll, (==>)) +import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary) +import Test.QuickCheck.Gen (Gen, elements, listOf, + oneof) + +instance Arbitrary F18Word where arbitrary = fromInteger <$> arbitrary + +wordBits bits = (((2 ^ bits) - 1) .&.) <$> arbitrary + +instance Arbitrary Stack where arbitrary = foldl push empty <$> arbitrary + +instance Arbitrary Opcode where arbitrary = elements opcodes + +straight, jumps, fast, slow, inSlot3 :: Gen Opcode +straight = elements $ filter (not . isJump) opcodes +jumps = elements $ filter isJump opcodes +fast = elements $ filter (\ e -> opcodeTime e == 1.5) opcodes +slow = elements $ filter (\ e -> opcodeTime e == 5) opcodes +inSlot3 = elements $ filter slot3 opcodes + +instance Arbitrary Instrs where arbitrary = oneof [instrs, jump3, jump2, jump1, constant] + +instrs, jump3, jump2, jump1, constant :: Gen Instrs +instrs = Instrs <$> straight <*> straight <*> straight <*> inSlot3 +jump3 = Jump3 <$> straight <*> straight <*> jumps <*> wordBits 3 +jump2 = Jump2 <$> straight <*> jumps <*> wordBits 8 +jump1 = Jump1 <$> jumps <*> wordBits 10 +constant = Constant <$> arbitrary + +instance Arbitrary Instruction where + arbitrary = oneof [opcode, number, unused] + +opcode, number, unused :: Gen Instruction +opcode = Opcode <$> straight +jump = Jump <$> jumps <*> (Concrete <$> arbitrary) +number = Number <$> arbitrary +unused = return Unused + +straightlineProgram :: Gen Program +straightlineProgram = listOf $ oneof [Opcode <$> straight, number, unused] + +main = $(defaultMainGenerator) + +run = runNativeProgram startState . read + +-- Instruction utilities tests: +prop_bits word = word == (toBits $ fromBits word) +prop_opcode word = word < 0x20 ==> word == (fromOpcode $ toOpcode word) +prop_pushPop word stack = word == snd (pop $ push stack word) +prop_pop stack = stack == foldl1 (.) (replicate 8 $ fst . pop) stack +prop_runningTimeConstant program = forAll constant $ \ c -> + runningTime (program ++ [c]) == runningTime program + +prop_showReadProgram :: Program -> Bool +prop_showReadProgram program = program == read (show program) + +prop_showReadNative :: NativeProgram -> Bool +prop_showReadNative program = program == read (show program) + +-- Returns whether the given instruction word has jump addresses for +-- all the jumps and has no jumps without addresses. +isValid :: Instrs -> Bool +isValid (Instrs a b c d) = all (not . isJump) [a, b, c] && slot3 d +isValid (Jump3 a b c addr) = all (not . isJump) [a, b] && isJump c +isValid (Jump2 a b addr) = not (isJump a) && isJump b +isValid (Jump1 a addr) = isJump a +isValid Constant{} = True + +-- For now, we do not really support jumps in the Program type. +prop_validNative = forAll straightlineProgram $ \ p -> all isValid $ toNative p + +case_runningTime = do let time = runningTime . read + 11.0 @=? time ". . . . @p . . . 10" + 0 @=? time ". . . ." + 20 @=? time "@p @p @p @p 1 2 3 4" + +-- Testing the utility functions for actually synthesizing programs: +case_toNative = do read "@p . @p . 2 10 or . . ." @=? + toNative [Number 2, Opcode Nop, Number 10, Opcode Or] + read "@p . @p . 2 10 + . . ." @=? + toNative [Number 2, Opcode Nop, Number 10, Opcode Plus] + read "jump 5 . + @p @p 1 2 @p . . . 3" @=? + toNative (read ":foo jump :bar + 1 2 3 :bar") +case_fromNative = do [Opcode Nop, Opcode Nop, Opcode Nop, Opcode Nop] @=? + fromNative (read ". . . .") + [Opcode Nop, Number 1, Number 2, Opcode Nop] @=? + fromNative (read ". @p @p . 1 2") + +-- Interpreter tests (ported from Racket): +unchanged = assertBool "Something changed!" . all (== 0) +a,b,p,r,s,t :: (?res :: S.State) => F18Word +a = S.a ?res +b = S.b ?res +p = S.p ?res +r = S.r ?res +s = S.s ?res +t = S.t ?res + +memory :: (?res :: S.State) => Memory +memory = S.memory ?res + +dataStack :: (?res :: S.State) => Stack +dataStack = S.dataStack ?res + +case_1 = do let ?res = run "@p @p . + 2 3" + 3 @=? p + 5 @=? t + unchanged [a, b, r, s] +case_2 = do let ?res = run "@p - . . 0" + 2 @=? p + (- 1) @=? t + unchanged [a, b, r, s] +case_3 = do let ?res = run "@p b! @p . 4 42 !b @p . ." + 5 @=? p + 42 @=? t + 4 @=? b + 42 @=? memory ! 4 + unchanged [a, r, s] +case_4 = do let ?res = run "- dup dup dup dup dup dup dup" + 2 @=? p + (- 1) @=? t + (- 1) @=? s + fill empty [0, 0, -1, -1, -1, -1, -1, -1] @=? dataStack + unchanged [a, b, r] +case_5 = do let ?res = run "dup or a! @p 123 !+ @p ! . 456 dup or a! . @+ 2* @+ . 2/ + ! ." + 2 @=? a + 123 @=? memory ! 0 + 456 @=? memory ! 1 + 474 @=? memory ! 2 + 7 @=? p + unchanged [b, r, s, t] +case_ret = do let ?res = run "call 2 . . . . ; . . ." + 1 @=? p + unchanged [a, b, r, s, t] +case_jump = do let ?res = run "jump 42" + 42 @=? p + unchanged [a, b, r, s, t] +case_call = do let ?res = run "call 10" + 1 @=? r + 10 @=? p + unchanged [a, b, s, t] +case_unext = do let ?res = run ". . unext ." + 1 @=? p + unchanged [a, b, r, s, t] +case_unext' = do let ?res = run "@p push . . 41 @+ . . unext" + 3 @=? p + 42 @=? a + unchanged [b, r, s, t] +case_if = do let ?res = run "if 42" + 1 @=? p + unchanged [a, b, r, s, t] +case_if' = do let ?res = run "@p if 42 10" + 42 @=? p + unchanged [a, b, r, s] +case_minusIf = do let ?res = run "-if 42" + 42 @=? p + unchanged [a, b, r, s, t] +case_minusIf' = do let ?res = run "- -if 42" + 1 @=? p + unchanged [a, b, r, s] +case_fetchP = do let ?res = run "@p . . . 42" + 2 @=? p + 42 @=? t + unchanged [a, b, r, s] +case_fetchPlus = do let ?res = run "@+ . . ." + 1 @=? a + memory ! 0 @=? t + unchanged [b, r, s] +case_fetchB = do let ?res = run "@b . . ." + memory ! 0 @=? t + unchanged [b, r, s] +case_fetch = do let ?res = run "@ . . ." + memory ! 0 @=? t + unchanged [b, r, s] +case_storeP = do let ?res = run "@p !p . . 42" + 3 @=? p + 42 @=? memory ! (p - 1) + unchanged [a, b, r, s] +case_storePlus = do let ?res = run "@p !+ . . 42" + 1 @=? a + 2 @=? p + 42 @=? memory ! 0 + unchanged [b, r, s] +case_storePlus' = do let ?res = run "@p @p a! . 42 10 !+ . . ." + 11 @=? a + 4 @=? p + 42 @=? memory ! 10 + unchanged [b, r, s] +case_storePlus'' = do let ?res = run "dup or a! @p 123 !+ @p ! . 456" + 1 @=? a + 123 @=? memory ! 0 + 456 @=? memory ! 1 + unchanged [b, r, s, t] +case_storeB = do let ?res = run "@p !b . . 42" + 2 @=? p + 42 @=? memory ! 0 + unchanged [a, b, r, s] +case_storeB' = do let ?res = run "@p @p b! . 42 10 !b . . ." + 4 @=? p + 42 @=? memory ! 10 + 10 @=? b + unchanged [a, r, s] +case_store = do let ?res = run "@p ! . . 42" + 2 @=? p + 42 @=? memory ! 0 + unchanged [a, b, r, s] +case_store' = do let ?res = run "@p @p a! . 42 10 ! . . ." + 10 @=? a + 4 @=? p + 42 @=? memory ! 10 + unchanged [b, r, s] +case_store'' = do let ?res = run "dup or a! @p 123 ! . . ." + 0 @=? a + 123 @=? memory ! 0 + unchanged [b, r, s, t] +case_multiplyStepEven = do let ?res = run "@p @p @p . 10 0 10 a! +* . ." + 5 @=? a + 10 @=? s + 0 @=? t + unchanged [b, r] +case_multiplyStepOdd = do let ?res = run "@p @p @p . 10 0 11 a! +* . ." + 5 @=? a + 10 @=? s + 5 @=? t + unchanged [b, r] +case_multiplyStep = do let ?res = run "@p @p @p . 262143 0 1 a! +* . ." + 0x20000 @=? a + 0x3ffff @=? s + 0x3ffff @=? t + unchanged [b, r] +case_multiply = do let ?res = run "@p @p @p . 10 0 11 a! +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* ." + 110 @=? a + 10 @=? s + 0 @=? t + unchanged [b, r] +case_multiply' = do let ?res = run "@p @p @p . 262143 0 1 a! +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* ." + 0x3ffff @=? a + 0x3ffff @=? s + 0x3ffff @=? t + unchanged [b, r] +case_multiply'' = do let ?res = run "@p @p @p . 262143 0 262143 a! +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* ." + 1 @=? a + 0x3ffff @=? s + 0x3ffff @=? t + unchanged [b, r] +case_multiply''' = do let ?res = run "@p @p @p . 1 0 262143 a! +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* ." + 0x3ffff @=? a + 1 @=? s + 0 @=? t + unchanged [b, r] +case_multiply'''' = do let ?res = run "@p @p @p . 261612 0 7276 a! +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* +* ." + 0xef90 @=? a + 0x3fdec @=? s + 0x3fff1 @=? t + unchanged [b, r] +case_times2 = do let ?res = run "@p 2* . . 2" + 4 @=? t + 2 @=? p + unchanged [a, b, r, s] +case_div2 = do let ?res = run "@p 2/ . . 4" + 2 @=? t + 2 @=? p + unchanged [a, b, r, s] +case_not = do let ?res = run "- . . ." + (- 1) @=? t + 1 @=? p + unchanged [a, b, r, s] +case_not' = do let ?res = run "@p - . . 42" + complement 42 @=? t + 2 @=? p + unchanged [a, b, r, s] +case_plus = do let ?res = run "@p @p . + 12 30" + 42 @=? t + 3 @=? p + unchanged [a, b, r, s] +case_and = do let ?res = run "@p @p and . 12 30" + 12 .&. 30 @=? t + 3 @=? p + unchanged [a, b, r, s] +case_or = do let ?res = run "@p @p or . 12 30" + 12 `xor` 30 @=? t + 3 @=? p + unchanged [a, b, r, s] +case_drop = do let ?res = run "@p @p drop . 1 2" + 1 @=? t + 3 @=? p + unchanged [a, b, r, s] +case_dup = do let ?res = run "@p dup . . 42" + 42 @=? t + 42 @=? s + 2 @=? p + unchanged [a, b, r] +case_dup' = do let ?res = run "@p dup or . 42" + 0 @=? t + 2 @=? p + unchanged [a, b, r, s] +case_pop = do let ?res = run "call 2 0 pop . . ." + 1 @=? t + unchanged [a, b, r, s] +case_over = do let ?res = run "@p @p over . 1 2" + 1 @=? t + 2 @=? s + 3 @=? p + unchanged [a, b, r] +case_a = do let ?res = run "@p a! a . 42" + 42 @=? a + 42 @=? t + 2 @=? p + unchanged [b, r, s] +case_nop = do let ?res = step $ run ". . . ." + 1 @=? p + unchanged [a, b, r, s, t] +case_push = do let ?res = run "@p push . . 42" + 42 @=? r + 2 @=? p + unchanged [a, b, s, t] +case_setB = do let ?res = run "@p b! . . 42" + 42 @=? b + 2 @=? p + unchanged [a, r, s, t] +case_setA = do let ?res = run "@p a! . . 42" + 42 @=? a + 2 @=? p + unchanged [b, r, s, t]