Commit fad36872 authored by ian@well-typed.com's avatar ian@well-typed.com
Browse files

Merge branch 'master' of darcs.haskell.org:/srv/darcs//testsuite

Conflicts:
	mk/test.mk
parents 7d7410f5 a7e40468
......@@ -7,22 +7,22 @@ main = do
info <- readProcess ghc ["+RTS", "--info"] ""
let fields = read info :: [(String,String)]
getGhcField fields "HostOS" "Host OS"
getGhcField fields "WORDSIZE" "Word size"
getGhcField fields "TARGETPLATFORM" "Target platform"
getGhcField fields "TargetOS_CPP" "Target OS"
getGhcField fields "TargetARCH_CPP" "Target architecture"
getGhcFieldOrFail fields "HostOS" "Host OS"
getGhcFieldOrFail fields "WORDSIZE" "Word size"
getGhcFieldOrFail fields "TARGETPLATFORM" "Target platform"
getGhcFieldOrFail fields "TargetOS_CPP" "Target OS"
getGhcFieldOrFail fields "TargetARCH_CPP" "Target architecture"
info <- readProcess ghc ["--info"] ""
let fields = read info :: [(String,String)]
getGhcField fields "GhcStage" "Stage"
getGhcField fields "GhcWithNativeCodeGen" "Have native code generator"
getGhcField fields "GhcWithInterpreter" "Have interpreter"
getGhcField fields "GhcUnregisterised" "Unregisterised"
getGhcField fields "GhcWithSMP" "Support SMP"
getGhcField fields "GhcRTSWays" "RTS ways"
getGhcField fields "GhcDynamicByDefault" "Dynamic by default"
getGhcFieldOrFail fields "GhcStage" "Stage"
getGhcFieldOrFail fields "GhcWithNativeCodeGen" "Have native code generator"
getGhcFieldOrFail fields "GhcWithInterpreter" "Have interpreter"
getGhcFieldOrFail fields "GhcUnregisterised" "Unregisterised"
getGhcFieldOrFail fields "GhcWithSMP" "Support SMP"
getGhcFieldOrFail fields "GhcRTSWays" "RTS ways"
getGhcFieldOrDefault fields "GhcDynamicByDefault" "Dynamic by default" "NO"
getGhcFieldProgWithDefault fields "AR" "ar command" "ar"
let pkgdb_flag = case lookup "Project version" fields of
......@@ -32,20 +32,36 @@ main = do
putStrLn $ "GhcPackageDbFlag" ++ '=':pkgdb_flag
getGhcField :: [(String,String)] -> String -> String -> IO ()
getGhcField fields mkvar key =
case lookup key fields of
Nothing -> fail ("No field: " ++ key)
Just val -> putStrLn (mkvar ++ '=':val)
getGhcFieldOrFail :: [(String,String)] -> String -> String -> IO ()
getGhcFieldOrFail fields mkvar key
= getGhcField fields mkvar key id (fail ("No field: " ++ key))
getGhcFieldOrDefault :: [(String,String)] -> String -> String -> String -> IO ()
getGhcFieldOrDefault fields mkvar key deflt
= getGhcField fields mkvar key id on_fail
where
on_fail = putStrLn (mkvar ++ '=' : deflt)
getGhcFieldProgWithDefault
:: [(String,String)]
-> String -> String -> String
-> IO ()
getGhcFieldProgWithDefault fields mkvar key deflt
= getGhcField fields mkvar key fix on_fail
where
fix val = fixSlashes (fixTopdir topdir val)
topdir = fromMaybe "" (lookup "LibDir" fields)
on_fail = putStrLn (mkvar ++ '=' : deflt)
getGhcFieldProgWithDefault :: [(String,String)]
-> String -> String -> String -> IO ()
getGhcFieldProgWithDefault fields mkvar key deflt = do
getGhcField
:: [(String,String)] -> String -> String
-> (String -> String)
-> IO ()
-> IO ()
getGhcField fields mkvar key fix on_fail =
case lookup key fields of
Nothing -> putStrLn (mkvar ++ '=' : deflt)
Just val -> putStrLn (mkvar ++ '=' : fixSlashes (fixTopdir topdir val))
where
topdir = fromMaybe "" (lookup "LibDir" fields)
Nothing -> on_fail
Just val -> putStrLn (mkvar ++ '=' : fix val)
fixTopdir :: String -> String -> String
fixTopdir t "" = ""
......
{-# LANGUAGE BangPatterns, MagicHash #-}
import Control.Exception
import System.Environment
import GHC.Exts
main = do
args <- getArgs
foo args
foo _ = let !e = toException (ErrorCall "test") in
raise# e
*** Exception (reporting due to +RTS -xc): (base:GHC.Exception.SomeException), stack trace:
Main.foo,
called from Main.main,
called from Main.CAF
T7319: test
......@@ -94,3 +94,9 @@ test('setByteArray', normal, compile_and_run, [''])
test('6146', normal, compile_and_run, [''])
test('T5900', normal, compile_and_run, [''])
test('T7163', normal, compile_and_run, [''])
# Gives different results when optimised, so restrict to just one way
test('T7319', [ extra_ways(['prof']), only_ways(['prof']), exit_code(1),
req_profiling,
extra_hc_opts('-fprof-auto'),
extra_run_opts('+RTS -xc') ], compile_and_run, [''])
......@@ -16,8 +16,8 @@ _result :: a
Stopped at <exception thrown>
_exception :: e
already at the beginning of the history
_exception = SomeException (ErrorCall "foo")
_exception = SomeException "foo"
_result :: a = _
_exception :: SomeException = SomeException (ErrorCall "foo")
_exception :: SomeException = SomeException "foo"
*** Exception: foo
*** Exception: foo
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment