Commit 43e1ff2d authored by Simon Peyton Jones's avatar Simon Peyton Jones

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

parents af0bf03c 3528d0ad
......@@ -18,11 +18,6 @@ from testglobals import *
# value.
os.environ['TERM'] = 'vt100'
if sys.platform == "cygwin":
cygwin = True
else:
cygwin = False
global config
config = getConfig() # get it from testglobals
......@@ -115,15 +110,20 @@ if config.use_threads == 1:
config.cygwin = False
config.msys = False
if windows:
if cygwin:
h = os.popen('uname -s', 'r')
v = h.read()
h.close()
if v.startswith("CYGWIN"):
config.cygwin = True
else:
elif v.startswith("MINGW32"):
config.msys = True
else:
raise Exception("Can't detect Windows terminal type")
# Try to use UTF8
if windows:
import ctypes
if cygwin:
if config.cygwin:
# Is this actually right? Which calling convention does it use?
# As of the time of writing, ctypes.windll doesn't exist in the
# cygwin python, anyway.
......@@ -182,7 +182,7 @@ if windows or darwin:
path = re.sub('^"(.*)"$', '\\1', path)
path = re.sub('\\\\(.)', '\\1', path)
if windows:
if cygwin:
if config.cygwin:
# On cygwin we can't put "c:\foo" in $PATH, as : is a
# field separator. So convert to /cygdrive/c/foo instead.
# Other pythons use ; as the separator, so no problem.
......
......@@ -1466,9 +1466,15 @@ def dump_stderr( name ):
print read_no_crs(qualify(name, 'run.stderr'))
def read_no_crs(file):
h = open(file)
str = h.read()
h.close
str = ''
try:
h = open(file)
str = h.read()
h.close
except:
# On Windows, if the program fails very early, it seems the
# files stdout/stderr are redirected to may not get created
pass
return re.sub('\r', '', str)
def write_file(file, str):
......@@ -1700,8 +1706,8 @@ def rawSystem(cmd_and_args):
def runCmd( cmd ):
if_verbose( 1, cmd )
r = 0
if config.platform == 'i386-unknown-mingw32':
# On MinGW, we will always have timeout
if config.os == 'mingw32':
# On MinGW, we will always have timeout
assert config.timeout_prog!=''
if config.timeout_prog != '':
......@@ -1713,8 +1719,8 @@ def runCmd( cmd ):
def runCmdFor( name, cmd ):
if_verbose( 1, cmd )
r = 0
if config.platform == 'i386-unknown-mingw32':
# On MinGW, we will always have timeout
if config.os == 'mingw32':
# On MinGW, we will always have timeout
assert config.timeout_prog!=''
if config.timeout_prog != '':
......@@ -1980,28 +1986,20 @@ def platform_wordsize_qualify( name, suff ):
basepath = qualify(name, suff)
fns = [ lambda x: x + '-' + config.compiler_type,
lambda x: x + '-' + config.compiler_maj_version,
lambda x: x + '-ws-' + config.wordsize ]
paths = [ basepath ]
for fn in fns:
paths = paths + map(fn, paths)
paths.reverse()
plat_paths = map (lambda x: x + '-' + config.platform, paths)
paths = [(platformSpecific, basepath + comp + vers + ws + plat)
for (platformSpecific, plat) in [(1, '-' + config.platform),
(1, '-' + config.os),
(0, '')]
for ws in ['-ws-' + config.wordsize, '']
for comp in ['-' + config.compiler_type, '']
for vers in ['-' + config.compiler_maj_version, '']]
dir = glob.glob(basepath + '*')
dir = map (lambda d: normalise_slashes_(d), dir)
for f in plat_paths:
if f in dir:
return (1,f)
for f in paths:
for (platformSpecific, f) in paths:
if f in dir:
return (0,f)
return (platformSpecific,f)
return (0, basepath)
......
......@@ -116,10 +116,6 @@ ifeq "$(shell test -x '$(HPC)' && echo exists)" ""
$(error Cannot find hpc: $(HPC))
endif
ifeq "$(AR)" ""
AR = ar
endif
# Be careful when using this. On Windows it ends up looking like
# c:/foo/bar which confuses make, as make thinks that the : is Makefile
# syntax
......@@ -149,7 +145,9 @@ $(ghc-config-mk) : $(TOP)/mk/ghc-config
$(TOP)/mk/ghc-config "$(TEST_HC)" >"$@"; if [ $$? != 0 ]; then $(RM) "$@"; exit 1; fi
# If the ghc-config fails, remove $@, and fail
ifeq "$(findstring clean,$(MAKECMDGOALS))" ""
include $(ghc-config-mk)
endif
# -----------------------------------------------------------------------------
......
import System.Environment
import System.Process
import Data.Maybe
main = do
[ghc] <- getArgs
......@@ -14,13 +15,14 @@ main = do
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"
getGhcFieldWithDefault fields "AR" "ar command" "ar"
getGhcFieldProgWithDefault fields "AR" "ar command" "ar"
getGhcField :: [(String,String)] -> String -> String -> IO ()
getGhcField fields mkvar key =
......@@ -28,8 +30,22 @@ getGhcField fields mkvar key =
Nothing -> fail ("No field: " ++ key)
Just val -> putStrLn (mkvar ++ '=':val)
getGhcFieldWithDefault :: [(String,String)] -> String -> String -> String -> IO ()
getGhcFieldWithDefault fields mkvar key deflt = do
getGhcFieldProgWithDefault :: [(String,String)]
-> String -> String -> String -> IO ()
getGhcFieldProgWithDefault fields mkvar key deflt = do
case lookup key fields of
Nothing -> putStrLn (mkvar ++ '=':deflt)
Just val -> putStrLn (mkvar ++ '=':val)
Nothing -> putStrLn (mkvar ++ '=' : deflt)
Just val -> putStrLn (mkvar ++ '=' : fixSlashes (fixTopdir topdir val))
where
topdir = fromMaybe "" (lookup "LibDir" fields)
fixTopdir :: String -> String -> String
fixTopdir t "" = ""
fixTopdir t ('$':'t':'o':'p':'d':'i':'r':s) = t ++ s
fixTopdir t (c:s) = c : fixTopdir t s
fixSlashes :: FilePath -> FilePath
fixSlashes = map f
where f '\\' = '/'
f c = c
......@@ -4,7 +4,7 @@ module Main where
import GHC
import MonadUtils ( liftIO )
import DynFlags ( defaultLogAction )
import DynFlags ( defaultLogAction, defaultFlushOut )
import Annotations ( AnnTarget(..), CoreAnnTarget )
import Serialized ( deserializeWithData )
import Panic
......@@ -17,7 +17,7 @@ import Data.List
import Data.Function
main :: IO ()
main = defaultErrorHandler defaultLogAction
main = defaultErrorHandler defaultLogAction defaultFlushOut
$ runGhc (Just cTop) $ do
liftIO $ putStrLn "Initializing Package Database"
dflags <- getSessionDynFlags
......
......@@ -295,7 +295,7 @@ test('2499', normal, compile_fail, [''])
test('mode001', normal, run_command,
['$MAKE -s --no-print-directory mode001'])
if config.platform == 'i386-unknown-mingw32':
if config.os == 'mingw32':
only_windows = normal
else:
only_windows = skip
......
......@@ -19,7 +19,7 @@ T4464:
$(RM) T4464H_stub.c T4464H_stub.h T4464H_stub.o
$(RM) HS4464.dll HS4464.dll.a t4464.exe
'$(TEST_HC)' $(TEST_HC_OPTS) -v0 -shared T4464H.hs T4464B.c -optc-DRTSOPTS=RtsOptsSafeOnly -o HS4464.dll
'$(TEST_HC)' $(TEST_HC_OPTS) -v0 T4464C.c HS4464.dll.a -o t4464.exe -no-hs-main
'$(TEST_HC)' $(filter-out -rtsopts,$(TEST_HC_OPTS)) -v0 T4464C.c HS4464.dll.a -o t4464.exe -no-hs-main
-./t4464.exe
echo "====="
echo "=====" >&2
......@@ -27,7 +27,7 @@ T4464:
$(RM) T4464H_stub.c T4464H_stub.h T4464H_stub.o
$(RM) HS4464.dll HS4464.dll.a t4464.exe
'$(TEST_HC)' $(TEST_HC_OPTS) -v0 -shared T4464H.hs T4464B.c -optc-DRTSOPTS=RtsOptsAll -o HS4464.dll
'$(TEST_HC)' $(TEST_HC_OPTS) -v0 T4464C.c HS4464.dll.a -o t4464.exe -no-hs-main
'$(TEST_HC)' $(filter-out -rtsopts,$(TEST_HC_OPTS)) -v0 T4464C.c HS4464.dll.a -o t4464.exe -no-hs-main
./t4464.exe
.PHONY: T5373
......
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE ForeignFunctionInterface, CPP #-}
import Foreign
import Foreign.C
......@@ -21,7 +21,7 @@ foreign import ccall "dynamic" f_io :: FunPtr IOF -> IOF
--
-- On *nix systems, the C stack size can be examined and changed by
-- the "ulimit -s" command.
--
n = 300
f :: Int -> IO Int
......
......@@ -81,7 +81,7 @@ test('ffi011', normal, compile_and_run, [''])
# because it's difficult to discover whether a given Linux supports
# it.
if config.platform == 'i386-unknown-mingw32':
if config.os == 'mingw32':
skip_if_not_windows = normal
else:
skip_if_not_windows = skip
......@@ -161,7 +161,7 @@ test('ffi021', normal, compile_and_run, [''])
test('ffi022', normal, compile_and_run, [''])
if config.platform == 'i386-unknown-mingw32':
if config.os == 'mingw32':
# This test needs a larger C stack than we get by default on Windows
flagsFor4038 = ['-optl-Wl,--stack,10485760']
else:
......
#include "capi_value_c.h"
const int i = 23;
int i = 23;
......@@ -12,7 +12,7 @@ ghcilink001 :
$(RM) -rf dir001
mkdir dir001
"$(TEST_HC)" -c f.c -o dir001/foo.o
$(AR) cqs dir001/libfoo.a dir001/foo.o
"$(AR)" cqs dir001/libfoo.a dir001/foo.o
echo "test" | "$(TEST_HC)" --interactive -ignore-dot-ghci -v0 -Ldir001 -lfoo TestLink.hs
# Test 2: ghci -Ldir -lfoo
......@@ -57,16 +57,16 @@ ghcilink004 :
mkdir dir004
#
rm -f $(PKG004)
echo "name: test" >>$(PKG004)
echo "version: 1.0" >>$(PKG004)
echo "id: test-XXX" >>$(PKG004)
echo "library-dirs: `pwd`/dir004" >>$(PKG004)
echo "extra-libraries: foo" >>$(PKG004)
echo "[]" >$(LOCAL_PKGCONF004)
echo 'name: test' >>$(PKG004)
echo 'version: 1.0' >>$(PKG004)
echo 'id: test-XXX' >>$(PKG004)
echo 'library-dirs: $${pkgroot}' >>$(PKG004)
echo 'extra-libraries: foo' >>$(PKG004)
echo '[]' >$(LOCAL_PKGCONF004)
'$(GHC_PKG)' --no-user-package-conf -f $(LOCAL_PKGCONF004) register $(PKG004) -v0
#
"$(TEST_HC)" -c f.c -o dir004/foo.o
$(AR) cqs dir004/libfoo.a dir004/foo.o
"$(AR)" cqs dir004/libfoo.a dir004/foo.o
echo "test" | "$(TEST_HC)" --interactive -ignore-dot-ghci -v0 -package-conf $(LOCAL_PKGCONF004) -package test TestLink.hs
......@@ -85,12 +85,12 @@ ghcilink005 :
mkdir dir005
#
rm -f $(PKG005)
echo "name: test" >>$(PKG005)
echo "version: 1.0" >>$(PKG005)
echo "id: test-XXX" >>$(PKG005)
echo "library-dirs: `pwd`/dir005" >>$(PKG005)
echo "extra-libraries: foo" >>$(PKG005)
echo "[]" >$(LOCAL_PKGCONF005)
echo 'name: test' >>$(PKG005)
echo 'version: 1.0' >>$(PKG005)
echo 'id: test-XXX' >>$(PKG005)
echo 'library-dirs: $${pkgroot}' >>$(PKG005)
echo 'extra-libraries: foo' >>$(PKG005)
echo '[]' >$(LOCAL_PKGCONF005)
'$(GHC_PKG)' --no-user-package-conf -f $(LOCAL_PKGCONF005) register $(PKG005) -v0
#
"$(TEST_HC)" -c -dynamic f.c -o dir005/foo.o
......
import System.IO (does_not_exist)
import Data.Maybe
<interactive>:1:19:
Module `System.IO' does not export `does_not_exist'
<interactive>:1:20:
Module `Data.Maybe' does not export `does_not_exist'
......@@ -12,7 +12,7 @@ test('2589', just_ghci, compile_and_run, [''])
test('2881', just_ghci, compile_and_run, [''])
test('3171',
[if_platform('i386-unknown-mingw32',skip),
[if_os('mingw32',skip),
req_interp,
combined_output],
run_command,
......
......@@ -21,8 +21,7 @@ test('hsc2hs004',
test('3837',
[extra_clean(['3837.hs', '3837_hsc_make.c']),
if_platform('i386-unknown-mingw32', expect_broken(3929))],
[extra_clean(['3837.hs', '3837_hsc_make.c'])],
run_command,
['$MAKE -s --no-print-directory 3837'])
TOP=../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
def win_only(opts):
if config.platform != "i386-unknown-mingw32" and \
config.platform != "i386-unknown-cygwin32":
opts.skip = 1
# This isn't a very good test to run automatically at the moment, since
# it doesn't terminate
test('win32001', skip, compile_and_run, ['-package lang -package win32'])
test('win32002', win_only, compile_and_run, ['-package Win32'])
-- Haskell version of "Hello, World" using the Win32 library.
-- Demonstrates how the Win32 library can be put to use.
-- (c) sof 1999
module Main(main) where
import qualified Win32
import Addr
-- Toplevel main just creates a window and pumps messages.
-- The window procedure (wndProc) we pass in is partially
-- applied with the user action that takes care of responding
-- to repaint messages (WM_PAINT).
main :: IO ()
main = do
lpps <- Win32.malloc Win32.sizeofPAINTSTRUCT
hwnd <- createWindow 200 200 (wndProc lpps onPaint)
messagePump hwnd
-- OnPaint handler for a window - draw a string centred
-- inside it.
onPaint :: Win32.RECT -> Win32.HDC -> IO ()
onPaint (_,_,w,h) hdc = do
Win32.setBkMode hdc Win32.tRANSPARENT
Win32.setTextColor hdc (Win32.rgb 255 255 0)
let y | h==10 = 0
| otherwise = ((h-10) `div` 2)
x | w==50 = 0
| otherwise = (w-50) `div` 2
Win32.textOut hdc x y "Hello, world"
return ()
-- Simple window procedure - one way to improve and generalise
-- it would be to pass it a message map (represented as a
-- finite map from WindowMessages to actions, perhaps).
wndProc :: Win32.LPPAINTSTRUCT
-> (Win32.RECT -> Win32.HDC -> IO ()) -- on paint action
-> Win32.HWND
-> Win32.WindowMessage
-> Win32.WPARAM
-> Win32.LPARAM
-> IO Win32.LRESULT
wndProc lpps onPaint hwnd wmsg wParam lParam
| wmsg == Win32.wM_DESTROY = do
Win32.sendMessage hwnd Win32.wM_QUIT 1 0
return 0
| wmsg == Win32.wM_PAINT && hwnd /= nullAddr = do
r <- Win32.getClientRect hwnd
paintWith lpps hwnd (onPaint r)
return 0
| otherwise =
Win32.defWindowProc (Just hwnd) wmsg wParam lParam
createWindow :: Int -> Int -> Win32.WindowClosure -> IO Win32.HWND
createWindow width height wndProc = do
let winClass = Win32.mkClassName "Hello"
icon <- Win32.loadIcon Nothing Win32.iDI_APPLICATION
cursor <- Win32.loadCursor Nothing Win32.iDC_ARROW
bgBrush <- Win32.createSolidBrush (Win32.rgb 0 0 255)
mainInstance <- Win32.getModuleHandle Nothing
Win32.registerClass
( Win32.cS_VREDRAW + Win32.cS_HREDRAW
, mainInstance
, Just icon
, Just cursor
, Just bgBrush
, Nothing
, winClass
)
w <- Win32.createWindow
winClass
"Hello, World example"
Win32.wS_OVERLAPPEDWINDOW
Nothing Nothing -- leave it to the shell to decide the position
-- at where to put the window initially
(Just width)
(Just height)
Nothing -- no parent, i.e, root window is the parent.
Nothing -- no menu handle
mainInstance
wndProc
Win32.showWindow w Win32.sW_SHOWNORMAL
Win32.updateWindow w
return w
messagePump :: Win32.HWND -> IO ()
messagePump hwnd = do
msg <- Win32.getMessage (Just hwnd) `catch` \ _ -> return nullAddr
if msg == nullAddr then
return ()
else do
Win32.translateMessage msg
Win32.dispatchMessage msg
messagePump hwnd
paintWith :: Win32.LPPAINTSTRUCT -> Win32.HWND -> (Win32.HDC -> IO a) -> IO a
paintWith lpps hwnd p = do
hdc <- Win32.beginPaint hwnd lpps
a <- p hdc
Win32.endPaint hwnd lpps
return a
{-# LANGUAGE ForeignFunctionInterface #-}
-- Test that the Win32 error code from getLastError is thread-local.
import System.Win32
import Control.Monad
import Control.Concurrent
main = do
setLastError 42
r <- getLastError
when (r /= 42) $ fail ("wrong: " ++ show r)
m <- newEmptyMVar
forkIO $ do setLastError 43; putMVar m ()
takeMVar m
r <- getLastError
when (r /= 42) $ fail ("wrong: " ++ show r)
foreign import stdcall unsafe "windows.h SetLastError"
setLastError :: ErrCode -> IO ()
......@@ -93,7 +93,7 @@ test('T4801',
if_wordsize(32,
compiler_stats_range_field('peak_megabytes_allocated', 30, 10)),
if_wordsize(64, # sample from (amd64/Linux):
compiler_stats_range_field('peak_megabytes_allocated', 47, 10)),
compiler_stats_range_field('peak_megabytes_allocated', 50, 20)),
# expected value: 58 (amd64/OS X):
if_platform('x86_64-apple-darwin',
compiler_stats_num_field('peak_megabytes_allocated', 56, 60)),
......@@ -128,24 +128,23 @@ test('T3064',
[# expect_broken( 3064 ),
# expected value: 9 (x86/Linux 30-03-2011):
if_wordsize(32,
compiler_stats_num_field('peak_megabytes_allocated', 7, 12)),
compiler_stats_range_field('peak_megabytes_allocated', 10, 14)),
# expected value: 18 (amd64/Linux):
if_wordsize(64,
compiler_stats_num_field('peak_megabytes_allocated', 30, 38)),
compiler_stats_num_field('peak_megabytes_allocated', 20, 28)),
# expected value: 56380288 (x86/Linux) (28/6/2011)
if_wordsize(32,
compiler_stats_range_field('bytes allocated', 39800820, 10)),
compiler_stats_range_field('bytes allocated', 124952112, 10)),
# expected value: 73259544 (amd64/Linux) (28/6/2011):
if_wordsize(64,
compiler_stats_num_field('bytes allocated', 200000000,
280000000)),
# expected value: 2247016 (x86/Linux) (28/6/2011):
if_wordsize(32,
compiler_stats_num_field('max_bytes_used', 2000000,
3000000)),
compiler_stats_range_field('max_bytes_used', 5511604, 10)),
# expected value: 4032024 (amd64/Linux, intree) (28/6/2011):
if_wordsize(64,
compiler_stats_num_field('max_bytes_used', 10000000,
compiler_stats_num_field('max_bytes_used', 8000000,
14000000)),
only_ways(['normal'])
],
......@@ -158,9 +157,10 @@ test('T4007',
['$MAKE -s --no-print-directory T4007'])
test('T5030',
[# expected value: 449368924 (x86/Linux)
[expect_broken(5030),
# expected value: 449368924 (x86/Linux)
if_wordsize(32,
compiler_stats_range_field('bytes allocated', 176193448, 10)),
compiler_stats_range_field('bytes allocated', 196457520, 10)),
# expected value: 346750856 (amd64/Linux):
if_wordsize(64,
compiler_stats_num_field('bytes allocated', 300000000,
......@@ -185,8 +185,7 @@ test('T5631',
test('parsing001',
[# expected value: ?
if_wordsize(32,
compiler_stats_num_field('bytes allocated', 280000000,
320000000)),
compiler_stats_range_field('bytes allocated', 274000576, 10)),
# expected value: 587079016 (amd64/Linux):
if_wordsize(64,
compiler_stats_num_field('bytes allocated', 540000000,
......@@ -212,8 +211,7 @@ test('T5321Fun',
[ only_ways(['normal']), # no optimisation for this one
# sample from x86/Linux
if_wordsize(32,
compiler_stats_range_field('bytes allocated', 341591280, 10)),
# expected value: 669165280 (amd64/Linux):
compiler_stats_range_field('bytes allocated', 296657384, 10)),
if_wordsize(64,
compiler_stats_range_field('bytes allocated', 585521080, 10))
],
......@@ -223,8 +221,7 @@ test('T5321FD',
[ only_ways(['normal']), # no optimisation for this one
# sample from x86/Linux
if_wordsize(32,
compiler_stats_range_field('bytes allocated', 257175456, 10)),
# expected value: 500642456 (amd64/Linux):
compiler_stats_range_field('bytes allocated', 213380256, 10)),
if_wordsize(64,
compiler_stats_range_field('bytes allocated', 418306336, 10))
],
......@@ -233,9 +230,7 @@ test('T5321FD',
test('T5642',
[ only_ways(['normal']),
if_wordsize(32, # sample from x86/Linux
compiler_stats_range_field('bytes allocated', 1893427932, 10)),
# sample: 3926235424 (amd64/Linux, 15/2/2012)
compiler_stats_range_field('bytes allocated', 1682508520, 10)),
if_wordsize(64,
compiler_stats_range_field('bytes allocated', 3361296144, 10))
],
......
......@@ -12,7 +12,7 @@ plugins01:
#
# Suggestions to make this better gratefully recieved.
(cd simple-plugin; make package)
@$(RM) plugins01.hi plugins01.o
$(RM) plugins01.hi plugins01.o
"$(TEST_HC)" $(HC_OPTS) --make -v0 plugins01.hs -package-conf simple-plugin/local.package.conf -fplugin Simple.Plugin -fplugin-opt Simple.Plugin:Irrelevant_Option -package simple-plugin
./plugins01
......
......@@ -9,9 +9,15 @@ T5881:
'$(TEST_HC)' $(TEST_HC_OPTS) -c T5881a.hs
'$(TEST_HC)' $(TEST_HC_OPTS) -c T5881.hs
# T6025 is like T5881; needs separat compile