Commit 481e06b5 authored by simonmar's avatar simonmar

[project @ 2001-08-17 16:16:21 by simonmar]

Knock this into slightly better shape and bring over some more tests
from the old test suite.
parent 3f4e9857
#!/bin/sh
# Run the tests in this directory in an easy way
# The next line is the only one you need to modify
# should this directory change location relative to
# the top of the testsuite dir
TESTSUITE_ROOT=../../../..
# We assume that $TESTSUITE_ROOT/config/default/default.T is a symlink
# to the real config file you wish to use.
exec $TESTSUITE_ROOT/driver/runtests \
--tool=$TESTSUITE_ROOT/../ghc/compiler/ghc-inplace \
--config=$TESTSUITE_ROOT/config/default/default.T \
--rootdir=. \
$*
......@@ -9,13 +9,15 @@ def myvtc($extra_comp_args)
vtc(" -fglasgow-exts -package lang " ++ $extra_comp_args)
}
$compile_to_hc = "True"
test "cc001" { myvtc("") }
test "cc002" { myvtc("") }
test "cc003" { myvtc("") }
test "cc004" { myvtc("-fvia-C") }
test "cc005" { myvtc("-fvia-C") }
test "cc006" { myvtc("-fvia-C -fno-prune-tydecls") }
test "cc004" { myvtc("") }
test "cc005" { myvtc("") }
test "cc006" { myvtc("-fno-prune-tydecls") }
test "cc007" { myvtc("") }
test "cc008" { myvtc("") }
test "cc009" { myvtc("") }
test "cc010" { myvtc("-fvia-C") }
test "cc010" { myvtc("") }
......@@ -5,7 +5,7 @@ include ($confdir ++ "/../vanilla-test.T")
def myvtcf ( $args )
{
vtcf ( " -package lang " ++ $args)
vtcf ( " -fglasgow-exts -package lang " ++ $args)
}
test "cc001" { myvtcf("") }
......
cc001.hs:5:
./cc001.hs:5:
Ambiguous type variable(s) `t'
in the constraint `PrelGHC.CCallable t'
arising from an argument in the _ccall_ to `foo', namely `(undefined ())' at cc001.hs:5
in the definition of function `f': _ccall_ foo (undefined ())
arising from an argument in the _ccall_ to `foo', namely `(undefined ())' at ./cc001.hs:5
In the definition of `f': _ccall_ foo (undefined ())
cc002.hs:10:
./cc002.hs:10:
No instance for `PrelGHC.CReturnable ForeignObj'
arising from the result of the _ccall_ to `a' at cc002.hs:10
in the definition of function `a': _ccall_ a
arising from the result of the _ccall_ to `a' at ./cc002.hs:10
In the definition of `a': _ccall_ a
Cannot generalise these overloadings (in a _ccall_):
PrelGHC.CReturnable a arising from the result of the _ccall_ to `f' at cc004.hs:8
Cannot generalise these overloadings (in a _ccall_):
PrelGHC.CReturnable a arising from the result of the _ccall_ to `f' at cc004.hs:15
cc004.hs:8:
./cc004.hs:8:
Ambiguous type variable(s) `a'
in the constraint `PrelGHC.CReturnable a'
arising from the result of the _ccall_ to `f' at cc004.hs:8
arising from the result of the _ccall_ to `f' at ./cc004.hs:8
In the first argument of `thenADR', namely `_ccall_ f'
in the definition of function `foo':
In the definition of `foo':
(_ccall_ f) `thenADR` (\ a -> return (a + 1))
cc004.hs:8:
./cc004.hs:8:
Ambiguous type variable(s) `a' in the constraint `Num a'
arising from the literal `1' at cc004.hs:8
arising from the literal `1' at ./cc004.hs:8
In the second argument of `(+)', namely `1'
In the first argument of `return', namely `(a + 1)'
cc004.hs:15:
./cc004.hs:15:
Ambiguous type variable(s) `a'
in the constraint `PrelGHC.CReturnable a'
arising from the result of the _ccall_ to `f' at cc004.hs:15
arising from the result of the _ccall_ to `f' at ./cc004.hs:15
In the first argument of `thenADR', namely `_ccall_ f'
in the definition of function `bar':
In the definition of `bar':
(_ccall_ f) `thenADR` (\ a -> return (a + 1))
cc004.hs:15:
./cc004.hs:15:
Ambiguous type variable(s) `a' in the constraint `Num a'
arising from the literal `1' at cc004.hs:15
arising from the literal `1' at ./cc004.hs:15
In the second argument of `(+)', namely `1'
In the first argument of `return', namely `(a + 1)'
cc005.hs:7:
./cc005.hs:7:
Unacceptable argument type in foreign declaration: Int#
When checking declaration:
foreign export _ccall "foo" foo :: Int# -> IO ()
When checking declaration: foreign export foo foo :: Int# -> IO ()
cc005.hs:10:
./cc005.hs:10:
Unacceptable result type in foreign declaration: Int#
When checking declaration:
foreign export _ccall "bar" bar :: Int -> Int#
When checking declaration: foreign export bar bar :: Int -> Int#
#!/bin/sh
# Run the tests in this directory in an easy way
# The next line is the only one you need to modify
# should this directory change location relative to
# the top of the testsuite dir
TESTSUITE_ROOT=../../../..
# We assume that $TESTSUITE_ROOT/config/default/default.T is a symlink
# to the real config file you wish to use.
exec $TESTSUITE_ROOT/driver/runtests \
--tool=$TESTSUITE_ROOT/../ghc/compiler/ghc-inplace \
--config=$TESTSUITE_ROOT/config/default/default.T \
--rootdir=. \
$*
......@@ -5,8 +5,6 @@ include ($confdir ++ "/../vanilla-test.T")
-- extra run flags
-- expected process return value, if not zero
test "callback" { vtr("-fglasgow-exts -package lang -fvia-C callback_stub.o",
"", "") }
test "fed001" { vtr("-fglasgow-exts -package lang",
"", "") }
test "ffi001" { vtr("-fglasgow-exts -package lang",
......
module Main (main, hputc) where
import IO
main = _casm_GC_ ``rts_evalIO(
rts_apply(
&Main_hputc_closure,
rts_mkChar('x')
),
NULL
);'' :: IO ()
hputc :: Char -> IO ()
hputc c = hPutChar stdout c >> hPutChar stdout '\n'
foreign export hputc :: Char -> IO ()
#!/bin/sh
# Run the tests in this directory in an easy way
# The next line is the only one you need to modify
# should this directory change location relative to
# the top of the testsuite dir
TESTSUITE_ROOT=../../../..
# We assume that $TESTSUITE_ROOT/config/default/default.T is a symlink
# to the real config file you wish to use.
exec $TESTSUITE_ROOT/driver/runtests \
--tool=$TESTSUITE_ROOT/../ghc/compiler/ghc-inplace \
--config=$TESTSUITE_ROOT/config/default/default.T \
--rootdir=. \
$*
#!/bin/sh
# Run the tests in this directory in an easy way
# The next line is the only one you need to modify
# should this directory change location relative to
# the top of the testsuite dir
TESTSUITE_ROOT=../../../..
# We assume that $TESTSUITE_ROOT/config/default/default.T is a symlink
# to the real config file you wish to use.
exec $TESTSUITE_ROOT/driver/runtests \
--tool=$TESTSUITE_ROOT/../ghc/compiler/ghc-inplace \
--config=$TESTSUITE_ROOT/config/default/default.T \
--rootdir=. \
$*
......@@ -11,9 +11,6 @@ def myvtr ( $args_c, $args_r, $ret_res )
$args_r, $ret_res )
}
--conc009_RUNTEST_OPTS = -x 1
--conc021_RUNTEST_OPTS = -x 250 -o2 conc021.stderr-mingw
test "conc001" { myvtr("", "", "") }
test "conc002" { myvtr("", "", "") }
test "conc003" { myvtr("", "", "") }
......@@ -22,7 +19,7 @@ test "conc005" { myvtr("", "", "") }
test "conc006" { myvtr("", "", "") }
test "conc007" { myvtr("", "+RTS -H128M -RTS", "") }
test "conc008" { myvtr("", "", "") }
test "conc009" { myvtr("", "", "") }
test "conc009" { myvtr("", "", "1") }
test "conc010" { myvtr("", "", "") }
test "conc012" { myvtr("", "", "") }
test "conc013" { myvtr("", "", "") }
......@@ -34,11 +31,11 @@ test "conc018" { myvtr("", "", "") }
test "conc019" { myvtr("", "", "") }
--# conc020 *should* work on mingw32
test "conc020" { skip when $platform == "i386-unknown-mingw32"
test "conc020" { skip when $os == "mingw32"
myvtr("", "", "") }
test "conc021" { skip when $platform == "i386-unknown-mingw32"
myvtr("", "", "") }
test "conc021" { skip when $os == "mingw32"
myvtr("", "", "250") }
test "conc022" { myvtr("", "", "") }
test "conc023" { myvtr("", "", "") }
......
conc021.bin: main thread exited (uncaught exception)
conc021: main thread exited (uncaught exception)
#!/bin/sh
# Run the tests in this directory in an easy way
# The next line is the only one you need to modify
# should this directory change location relative to
# the top of the testsuite dir
TESTSUITE_ROOT=../../../..
# We assume that $TESTSUITE_ROOT/config/default/default.T is a symlink
# to the real config file you wish to use.
exec $TESTSUITE_ROOT/driver/runtests \
--tool=$TESTSUITE_ROOT/../ghc/compiler/ghc-inplace \
--config=$TESTSUITE_ROOT/config/default/default.T \
--rootdir=. \
$*
#!/bin/sh
# Run the tests in this directory in an easy way
# The next line is the only one you need to modify
# should this directory change location relative to
# the top of the testsuite dir
TESTSUITE_ROOT=../../../..
# We assume that $TESTSUITE_ROOT/config/default/default.T is a symlink
# to the real config file you wish to use.
exec $TESTSUITE_ROOT/driver/runtests \
--tool=$TESTSUITE_ROOT/../ghc/compiler/ghc-inplace \
--config=$TESTSUITE_ROOT/config/default/default.T \
--rootdir=. \
$*
Fail: dsrun005.hs:42: Non-exhaustive patterns in function f
Fail: ./dsrun005.hs:42: Non-exhaustive patterns in function f
Fail: dsrun007.hs:5: Missing field in record construction
Fail: ./dsrun007.hs:5: Missing field in record construction
drvfail004.hs:5:
./drvfail004.hs:5:
Could not deduce `Eq (Foo a b)' from the context (Ord a, Ord b)
Probable fix:
Add `Eq (Foo a b)' to the instance declaration context
Or add an instance declaration for `Eq (Foo a b)'
arising from an instance declaration at drvfail004.hs:5
arising from the instance declaration at ./drvfail004.hs:5
In the instance declaration for `Ord (Foo a b)'
......@@ -9,7 +9,7 @@ test "drvrun001" { vtr("", "", "") }
test "drvrun002" { vtr("", "", "") }
test "drvrun003" { vtr("", "", "") }
test "drvrun004" { vtr("", "", "") }
test "drvrun005" { vtr("", "-fail", "") }
test "drvrun005" { vtr("", "", "2") }
test "drvrun006" { vtr("", "", "") }
test "drvrun007" { vtr("", "", "") }
test "drvrun008" { vtr("-funbox-strict-fields", "", "") }
-- !!! Test getCPUTime
import IO
import CPUTime
main :: IO ()
main = do
t28 <- timeFib 28
t29 <- timeFib 29
t30 <- timeFib 30
print (t28 <= t29, t29 <= t30)
timeFib :: Integer -> IO Integer
timeFib n = do
start <- getCPUTime
print (nfib n)
end <- getCPUTime
return (end - start)
nfib :: Integer -> Integer
nfib n
| n <= 1 = 1
| otherwise = (n1 + n2 + 1)
where
n1 = nfib (n-1)
n2 = nfib (n-2)
include ($confdir ++ "/../vanilla-test.T")
test "CPUTime001" { vtr("","","") }
include ($confdir ++ "/../vanilla-test.T")
test "currentDirectory001" { vtr("","","") }
test "directory001" { vtr("","","") }
test "getDirectoryContents001" { vtr("","","") }
test "getPermissions001" { vtr("","","") }
import Directory (getCurrentDirectory, setCurrentDirectory,
createDirectory, removeDirectory, getDirectoryContents)
main = do
oldpwd <- getCurrentDirectory
createDirectory "foo"
setCurrentDirectory "foo"
~[n1, n2] <- getDirectoryContents "."
if dot n1 && dot n2
then do
setCurrentDirectory oldpwd
removeDirectory "foo"
putStr "Okay\n"
else
ioError (userError "Oops")
dot :: String -> Bool
dot "." = True
dot ".." = True
dot _ = False
import IO
import Directory
main = do
createDirectory "foo"
h <- openFile "foo/bar" WriteMode
hPutStr h "Okay\n"
hClose h
renameFile "foo/bar" "foo/baz"
renameDirectory "foo" "bar"
h <- openFile "bar/baz" ReadMode
stuff <- hGetContents h
putStr stuff
-- hClose h -- an error !
removeFile "bar/baz"
removeDirectory "bar"
import Directory (getDirectoryContents)
import List (sort, isPrefixOf, isSuffixOf)
main = do
names <- getDirectoryContents "."
putStrLn (unlines (sort (filter ok names)))
ok name = "getDirectoryContents" `isPrefixOf` name
&& not ("bak" `isSuffixOf` name)
getDirectoryContents001
getDirectoryContents001.comp.stderr
getDirectoryContents001.hs
getDirectoryContents001.o
getDirectoryContents001.run.stderr
getDirectoryContents001.run.stdout
getDirectoryContents001.stdout
import Directory
main = do
p <- getPermissions "."
print p
p <- getPermissions "getPermissions001.hs"
print p
p <- getPermissions "getPermissions001"
print p
Permissions{readable=True,writable=True,executable=False,searchable=True}
Permissions{readable=True,writable=True,executable=False,searchable=False}
Permissions{readable=True,writable=True,executable=True,searchable=False}
Permissions{readable=True,writable=True,executable=True,searchable=True}
Permissions{readable=True,writable=True,executable=True,searchable=True}
Permissions{readable=True,writable=True,executable=True,searchable=True}
-- test for a bug in GHC <= 4.08.2: handles were being left locked after
-- being shown in an error message.
main = do
getContents
catch getChar (\e -> print e >> return 'x')
catch getChar (\e -> print e >> return 'x')
illegal operation
Action: hGetChar
Handle: {loc=<stdin>,type=semi-closed,binary=False,buffering=block (8192)}
Reason: handle is closed
File: <stdin>
illegal operation
Action: hGetChar
Handle: {loc=<stdin>,type=semi-closed,binary=False,buffering=block (8192)}
Reason: handle is closed
File: <stdin>
illegal operation
Action: hGetChar
Handle: {loc=<stdin>,type=semi-closed,binary=False,buffering=block (512)}
Reason: handle is closed
File: <stdin>
illegal operation
Action: hGetChar
Handle: {loc=<stdin>,type=semi-closed,binary=False,buffering=block (512)}
Reason: handle is closed
File: <stdin>
include ($confdir ++ "/../vanilla-test.T")
test "IOError001" { $stdin = "IOError001.hs"
vtr("","","") }