@@ -1,102 +0,0 @@
|
||||
(module
|
||||
(import
|
||||
"gyehoek"
|
||||
"write"
|
||||
(func $gh-write (param (ref eq))))
|
||||
(import
|
||||
"gyehoek"
|
||||
"truthy?"
|
||||
(func $gh-truthy? (param (ref eq)) (result i32)))
|
||||
(type $heap-object (sub (struct (field $hash (mut i32)))))
|
||||
(type $cont-type (func (param i32)))
|
||||
(type $cont-stack-type (array (mut (ref null $cont-type))))
|
||||
(type
|
||||
$closure
|
||||
(sub
|
||||
$heap-object
|
||||
(struct
|
||||
(field $hash (mut i32))
|
||||
(field $code (ref $cont-type)))))
|
||||
(global $cont-stack-top (mut i32) (i32.const 0))
|
||||
(global
|
||||
$cont-stack
|
||||
(ref $cont-stack-type)
|
||||
(array.new_default $cont-stack-type (i32.const 128)))
|
||||
(type $arg-array-type (array (mut (ref null eq))))
|
||||
(global
|
||||
$arg-array
|
||||
(ref $arg-array-type)
|
||||
(array.new_default $arg-array-type (i32.const 32)))
|
||||
(global $result (mut (ref null eq)) (ref.null eq))
|
||||
(func
|
||||
$halt
|
||||
(param i32)
|
||||
(global.get $arg-array)
|
||||
(i32.const 0)
|
||||
(array.get $arg-array-type)
|
||||
ref.as_non_null
|
||||
(global.set $result))
|
||||
(func
|
||||
$scm-entry
|
||||
(param i32)
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
(i32.const 3)
|
||||
(i32.const 1)
|
||||
i32.shl
|
||||
ref.i31
|
||||
(i31.get_s (ref.cast (ref i31)))
|
||||
(i32.const 1)
|
||||
i32.shr_u
|
||||
(i32.const 4)
|
||||
(i32.const 1)
|
||||
i32.shl
|
||||
ref.i31
|
||||
(i31.get_s (ref.cast (ref i31)))
|
||||
(i32.const 1)
|
||||
i32.shr_u
|
||||
i32.mul
|
||||
(i32.const 1)
|
||||
i32.shl
|
||||
ref.i31
|
||||
(local.set 1)
|
||||
(i32.const 2)
|
||||
(i32.const 1)
|
||||
i32.shl
|
||||
ref.i31
|
||||
(i31.get_s (ref.cast (ref i31)))
|
||||
(i32.const 1)
|
||||
i32.shr_u
|
||||
(i32.const 5)
|
||||
(i32.const 1)
|
||||
i32.shl
|
||||
ref.i31
|
||||
(i31.get_s (ref.cast (ref i31)))
|
||||
(i32.const 1)
|
||||
i32.shr_u
|
||||
i32.mul
|
||||
(i32.const 1)
|
||||
i32.shl
|
||||
ref.i31
|
||||
(local.set 2)
|
||||
(local.get 1)
|
||||
(i31.get_s (ref.cast (ref i31)))
|
||||
(i32.const 1)
|
||||
i32.shr_u
|
||||
(local.get 2)
|
||||
(i31.get_s (ref.cast (ref i31)))
|
||||
(i32.const 1)
|
||||
i32.shr_u
|
||||
i32.add
|
||||
(i32.const 1)
|
||||
i32.shl
|
||||
ref.i31
|
||||
(local.set 3)
|
||||
(global.get $arg-array)
|
||||
(global.get 0)
|
||||
(local.get 3)
|
||||
(array.set $arg-array-type)
|
||||
(return_call $halt (i32.const 1)))
|
||||
(func
|
||||
(export "main")
|
||||
(call $scm-entry (i32.const 0))
|
||||
(call $gh-write (ref.as_non_null (global.get $result)))))
|
||||
@@ -1,68 +0,0 @@
|
||||
(module
|
||||
(import
|
||||
"gyehoek"
|
||||
"write"
|
||||
(func $gh-write (param (ref eq))))
|
||||
(import
|
||||
"gyehoek"
|
||||
"truthy?"
|
||||
(func $gh-truthy? (param (ref eq)) (result i32)))
|
||||
(type $heap-object (sub (struct (field $hash (mut i32)))))
|
||||
(type $cont-type (func (param i32)))
|
||||
(type $cont-stack-type (array (mut (ref null $cont-type))))
|
||||
(type
|
||||
$closure
|
||||
(sub
|
||||
$heap-object
|
||||
(struct
|
||||
(field $hash (mut i32))
|
||||
(field $code (ref $cont-type)))))
|
||||
(global $cont-stack-top (mut i32) (i32.const 0))
|
||||
(global
|
||||
$cont-stack
|
||||
(ref $cont-stack-type)
|
||||
(array.new_default $cont-stack-type (i32.const 128)))
|
||||
(type $arg-array-type (array (mut (ref null eq))))
|
||||
(global
|
||||
$arg-array
|
||||
(ref $arg-array-type)
|
||||
(array.new_default $arg-array-type (i32.const 32)))
|
||||
(global $result (mut (ref null eq)) (ref.null eq))
|
||||
(func
|
||||
$halt
|
||||
(param i32)
|
||||
(global.get $arg-array)
|
||||
(i32.const 0)
|
||||
(array.get $arg-array-type)
|
||||
ref.as_non_null
|
||||
(global.set $result))
|
||||
(func
|
||||
$scm-entry
|
||||
(param i32)
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
(i32.const 1)
|
||||
ref.i31
|
||||
(call $gh-truthy?)
|
||||
(if
|
||||
(then
|
||||
(global.get $arg-array)
|
||||
(global.get 0)
|
||||
(i32.const 777)
|
||||
(i32.const 1)
|
||||
i32.shl
|
||||
ref.i31
|
||||
(array.set $arg-array-type)
|
||||
(return_call $halt (i32.const 1)))
|
||||
(else
|
||||
(global.get $arg-array)
|
||||
(global.get 0)
|
||||
(i32.const 555)
|
||||
(i32.const 1)
|
||||
i32.shl
|
||||
ref.i31
|
||||
(array.set $arg-array-type)
|
||||
(return_call $halt (i32.const 1)))))
|
||||
(func
|
||||
(export "main")
|
||||
(call $scm-entry (i32.const 0))
|
||||
(call $gh-write (ref.as_non_null (global.get $result)))))
|
||||
@@ -1,70 +0,0 @@
|
||||
(module
|
||||
(import
|
||||
"gyehoek"
|
||||
"write"
|
||||
(func $gh-write (param (ref eq))))
|
||||
(import
|
||||
"gyehoek"
|
||||
"truthy?"
|
||||
(func $gh-truthy? (param (ref eq)) (result i32)))
|
||||
(type $heap-object (sub (struct (field $hash (mut i32)))))
|
||||
(type $cont-type (func (param i32)))
|
||||
(type $cont-stack-type (array (mut (ref null $cont-type))))
|
||||
(type
|
||||
$closure
|
||||
(sub
|
||||
$heap-object
|
||||
(struct
|
||||
(field $hash (mut i32))
|
||||
(field $code (ref $cont-type)))))
|
||||
(global $cont-stack-top (mut i32) (i32.const 0))
|
||||
(global
|
||||
$cont-stack
|
||||
(ref $cont-stack-type)
|
||||
(array.new_default $cont-stack-type (i32.const 128)))
|
||||
(type $arg-array-type (array (mut (ref null eq))))
|
||||
(global
|
||||
$arg-array
|
||||
(ref $arg-array-type)
|
||||
(array.new_default $arg-array-type (i32.const 32)))
|
||||
(global $result (mut (ref null eq)) (ref.null eq))
|
||||
(func
|
||||
$halt
|
||||
(param i32)
|
||||
(global.get $arg-array)
|
||||
(i32.const 0)
|
||||
(array.get $arg-array-type)
|
||||
ref.as_non_null
|
||||
(global.set $result))
|
||||
(func
|
||||
$scm-entry
|
||||
(param i32)
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
(i32.const 123)
|
||||
(i32.const 1)
|
||||
i32.shl
|
||||
ref.i31
|
||||
(call $gh-truthy?)
|
||||
(if
|
||||
(then
|
||||
(global.get $arg-array)
|
||||
(global.get 0)
|
||||
(i32.const 777)
|
||||
(i32.const 1)
|
||||
i32.shl
|
||||
ref.i31
|
||||
(array.set $arg-array-type)
|
||||
(return_call $halt (i32.const 1)))
|
||||
(else
|
||||
(global.get $arg-array)
|
||||
(global.get 0)
|
||||
(i32.const 555)
|
||||
(i32.const 1)
|
||||
i32.shl
|
||||
ref.i31
|
||||
(array.set $arg-array-type)
|
||||
(return_call $halt (i32.const 1)))))
|
||||
(func
|
||||
(export "main")
|
||||
(call $scm-entry (i32.const 0))
|
||||
(call $gh-write (ref.as_non_null (global.get $result)))))
|
||||
@@ -1,68 +0,0 @@
|
||||
(module
|
||||
(import
|
||||
"gyehoek"
|
||||
"write"
|
||||
(func $gh-write (param (ref eq))))
|
||||
(import
|
||||
"gyehoek"
|
||||
"truthy?"
|
||||
(func $gh-truthy? (param (ref eq)) (result i32)))
|
||||
(type $heap-object (sub (struct (field $hash (mut i32)))))
|
||||
(type $cont-type (func (param i32)))
|
||||
(type $cont-stack-type (array (mut (ref null $cont-type))))
|
||||
(type
|
||||
$closure
|
||||
(sub
|
||||
$heap-object
|
||||
(struct
|
||||
(field $hash (mut i32))
|
||||
(field $code (ref $cont-type)))))
|
||||
(global $cont-stack-top (mut i32) (i32.const 0))
|
||||
(global
|
||||
$cont-stack
|
||||
(ref $cont-stack-type)
|
||||
(array.new_default $cont-stack-type (i32.const 128)))
|
||||
(type $arg-array-type (array (mut (ref null eq))))
|
||||
(global
|
||||
$arg-array
|
||||
(ref $arg-array-type)
|
||||
(array.new_default $arg-array-type (i32.const 32)))
|
||||
(global $result (mut (ref null eq)) (ref.null eq))
|
||||
(func
|
||||
$halt
|
||||
(param i32)
|
||||
(global.get $arg-array)
|
||||
(i32.const 0)
|
||||
(array.get $arg-array-type)
|
||||
ref.as_non_null
|
||||
(global.set $result))
|
||||
(func
|
||||
$scm-entry
|
||||
(param i32)
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
(i32.const 3)
|
||||
ref.i31
|
||||
(call $gh-truthy?)
|
||||
(if
|
||||
(then
|
||||
(global.get $arg-array)
|
||||
(global.get 0)
|
||||
(i32.const 777)
|
||||
(i32.const 1)
|
||||
i32.shl
|
||||
ref.i31
|
||||
(array.set $arg-array-type)
|
||||
(return_call $halt (i32.const 1)))
|
||||
(else
|
||||
(global.get $arg-array)
|
||||
(global.get 0)
|
||||
(i32.const 555)
|
||||
(i32.const 1)
|
||||
i32.shl
|
||||
ref.i31
|
||||
(array.set $arg-array-type)
|
||||
(return_call $halt (i32.const 1)))))
|
||||
(func
|
||||
(export "main")
|
||||
(call $scm-entry (i32.const 0))
|
||||
(call $gh-write (ref.as_non_null (global.get $result)))))
|
||||
@@ -1,78 +0,0 @@
|
||||
(module
|
||||
(import
|
||||
"gyehoek"
|
||||
"write"
|
||||
(func $gh-write (param (ref eq))))
|
||||
(import
|
||||
"gyehoek"
|
||||
"truthy?"
|
||||
(func $gh-truthy? (param (ref eq)) (result i32)))
|
||||
(type $heap-object (sub (struct (field $hash (mut i32)))))
|
||||
(type $cont-type (func (param i32)))
|
||||
(type $cont-stack-type (array (mut (ref null $cont-type))))
|
||||
(type
|
||||
$closure
|
||||
(sub
|
||||
$heap-object
|
||||
(struct
|
||||
(field $hash (mut i32))
|
||||
(field $code (ref $cont-type)))))
|
||||
(global $cont-stack-top (mut i32) (i32.const 0))
|
||||
(global
|
||||
$cont-stack
|
||||
(ref $cont-stack-type)
|
||||
(array.new_default $cont-stack-type (i32.const 128)))
|
||||
(type $arg-array-type (array (mut (ref null eq))))
|
||||
(global
|
||||
$arg-array
|
||||
(ref $arg-array-type)
|
||||
(array.new_default $arg-array-type (i32.const 32)))
|
||||
(global $result (mut (ref null eq)) (ref.null eq))
|
||||
(func
|
||||
$halt
|
||||
(param i32)
|
||||
(global.get $arg-array)
|
||||
(i32.const 0)
|
||||
(array.get $arg-array-type)
|
||||
ref.as_non_null
|
||||
(global.set $result))
|
||||
(func
|
||||
(param i32)
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
(global.get $arg-array)
|
||||
(i32.const 0)
|
||||
(array.get $arg-array-type)
|
||||
ref.as_non_null
|
||||
(local.set 1)
|
||||
(global.get $arg-array)
|
||||
(global.get 0)
|
||||
(local.get 1)
|
||||
(array.set $arg-array-type)
|
||||
(i32.const 1)
|
||||
(global.get $cont-stack)
|
||||
(global.get $cont-stack-top)
|
||||
(array.get $cont-stack-type)
|
||||
ref.as_non_null
|
||||
(global.get $cont-stack-top)
|
||||
(i32.const 1)
|
||||
i32.sub
|
||||
(global.set $cont-stack-top)
|
||||
(return_call_ref $cont-type))
|
||||
(elem declare funcref (ref.func 3))
|
||||
(func
|
||||
$scm-entry
|
||||
(param i32)
|
||||
(local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
|
||||
(i32.const 0)
|
||||
(ref.func 3)
|
||||
(struct.new $closure)
|
||||
(local.set 1)
|
||||
(global.get $arg-array)
|
||||
(global.get 0)
|
||||
(local.get 1)
|
||||
(array.set $arg-array-type)
|
||||
(return_call $halt (i32.const 1)))
|
||||
(func
|
||||
(export "main")
|
||||
(call $scm-entry (i32.const 0))
|
||||
(call $gh-write (ref.as_non_null (global.get $result)))))
|
||||
@@ -94,10 +94,13 @@ test-suite test
|
||||
type: exitcode-stdio-1.0
|
||||
hs-source-dirs: test
|
||||
main-is: Main.hs
|
||||
other-modules:
|
||||
Gyehoek.Test.Golden
|
||||
build-depends: base
|
||||
, gyehoek
|
||||
, filepath
|
||||
, tasty
|
||||
, tasty-silver
|
||||
, directory
|
||||
, process-extras
|
||||
default-language: GHC2024
|
||||
|
||||
@@ -67,10 +67,14 @@ withFile "-" FS.ReadMode k = k FS.stdin
|
||||
withFile "-" (FS.WriteMode; FS.AppendMode) k = k FS.stdout
|
||||
withFile f m k = FS.withFile f m k
|
||||
|
||||
fileName :: FilePath -> FilePath
|
||||
fileName "-" = "<interactive>"
|
||||
fileName e = e
|
||||
|
||||
readScm :: FileSystem :> es => FilePath -> Eff es Scm.Program
|
||||
readScm f =
|
||||
withFile f FS.ReadMode $ \h ->
|
||||
Sexp.parseSexps @Scm.CommandOrDef f <$> hGetContents h
|
||||
Sexp.parseSexps @Scm.CommandOrDef (fileName f) <$> hGetContents h
|
||||
>>= either error (pure . Scm.MkProgram)
|
||||
|
||||
driver
|
||||
|
||||
@@ -0,0 +1,45 @@
|
||||
module Gyehoek.Test.Golden (root) where
|
||||
|
||||
import Test.Tasty (TestTree, testGroup)
|
||||
import Test.Tasty.Silver
|
||||
import Gyehoek.Driver qualified as Driver
|
||||
import System.FilePath
|
||||
import Data.List (List)
|
||||
import Data.Functor ((<&>))
|
||||
import System.Directory
|
||||
import Data.Function
|
||||
import System.Environment.Blank (getEnvDefault)
|
||||
import qualified System.Process.Text as PT
|
||||
|
||||
|
||||
disabled :: List String
|
||||
disabled =
|
||||
[ "square"
|
||||
]
|
||||
|
||||
root :: IO TestTree
|
||||
root = do
|
||||
all_cases <- listDirectory "golden"
|
||||
let tests = all_cases
|
||||
& filter (`notElem` disabled)
|
||||
& fmap ("golden"</>)
|
||||
testGroup "golden" <$> sequenceA
|
||||
[ executionTests tests
|
||||
]
|
||||
|
||||
executionTests :: List FilePath -> IO TestTree
|
||||
executionTests files = do
|
||||
cmd <- getEnvDefault "GYEHOEK_RUNTIME"
|
||||
"runtime/target/debug/gyehoek-runtime"
|
||||
pure $ testGroup "execution" $ files <&> \test ->
|
||||
let testname = takeFileName test
|
||||
scmfile = test </> "source.scm"
|
||||
resultfile = test </> "exec"
|
||||
action = do
|
||||
t <- Driver.lower_e2e scmfile
|
||||
PT.readProcessWithExitCode cmd ["-"] t
|
||||
in goldenVsAction
|
||||
testname
|
||||
resultfile
|
||||
action
|
||||
printProcResult
|
||||
+7
-51
@@ -1,60 +1,16 @@
|
||||
module Main (main) where
|
||||
|
||||
import Test.Tasty (TestTree, testGroup)
|
||||
import Test.Tasty.Silver
|
||||
import Test.Tasty.Silver.Interactive (defaultMain)
|
||||
import Data.Traversable
|
||||
import Gyehoek.Driver qualified as Driver
|
||||
import System.FilePath
|
||||
import qualified Gyehoek.Test.Golden
|
||||
import Data.List (List)
|
||||
import Data.Functor ((<&>))
|
||||
import System.Directory
|
||||
import Data.Function
|
||||
import System.Environment.Blank (getEnvDefault)
|
||||
|
||||
|
||||
disabled :: List String
|
||||
disabled =
|
||||
[ "square"
|
||||
main :: IO ()
|
||||
main = defaultMain =<< root
|
||||
|
||||
root :: IO TestTree
|
||||
root = testGroup "test" <$> sequenceA
|
||||
[ Gyehoek.Test.Golden.root
|
||||
]
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain =<< goldenTests
|
||||
|
||||
goldenTests :: IO TestTree
|
||||
goldenTests = do
|
||||
all_cases <- listDirectory "golden"
|
||||
let tests = all_cases
|
||||
& filter (`notElem` disabled)
|
||||
& fmap ("golden"</>)
|
||||
testGroup "golden" <$> sequenceA
|
||||
[ pure $ watTests tests
|
||||
, executionTests tests
|
||||
]
|
||||
|
||||
watTests :: List FilePath -> TestTree
|
||||
watTests files =
|
||||
testGroup "wat" $ files <&> \test ->
|
||||
let source = test </> "source.scm"
|
||||
golden = test </> "out.wat"
|
||||
testname = takeFileName test
|
||||
in goldenVsAction
|
||||
testname
|
||||
golden
|
||||
(Driver.lower_e2e source)
|
||||
id
|
||||
|
||||
executionTests :: List FilePath -> IO TestTree
|
||||
executionTests files = do
|
||||
cmd <- getEnvDefault "GYEHOEK_RUNTIME"
|
||||
"runtime/target/debug/gyehoek-runtime"
|
||||
pure $ testGroup "execution" $ files <&> \test ->
|
||||
let wat = test </> "out.wat"
|
||||
testname = takeFileName test
|
||||
resultfile = test </> "exec"
|
||||
in goldenVsProg
|
||||
testname
|
||||
resultfile
|
||||
cmd
|
||||
[wat]
|
||||
"" -- stdin
|
||||
|
||||
Reference in New Issue
Block a user