Skip to content
GitLab
Commit fa7bd36e authored by simonpj's avatar simonpj
Browse files

[project @ 1999-04-29 11:53:12 by simonpj] 

Minor fixes to tests
parent b73bc3a0
Hide whitespace changes
Inline Side-by-side
ghc/tests/ccall/should_fail/cc001.hs
View file @ fa7bd36e
-- !!! cc002 -- ccall with ambiguous argument
-- !!! cc001 -- ccall with ambiguous argument
module Test where
f :: IO ()
......
ghc/tests/ccall/should_fail/cc001.stderr
View file @ fa7bd36e
cc001.hs:5:
Ambiguous type variable(s) `$0'
in the constraint `PrelGHC.CCallable $0'
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
Compilation had errors
ghc/tests/ccall/should_fail/cc002.stderr
View file @ fa7bd36e
cc002.hs:10:
No instance for `PrelGHC.CReturnable ForeignObj'
arising from the result of the _ccall_ to `a' at cc002.hs:10
Compilation had errors
ghc/tests/ccall/should_fail/cc004.stderr
View file @ fa7bd36e
cc004.hs:2:
Cannot generalise these overloadings (in a _ccall_):
`PrelGHC.CReturnable $ren' arising from the result of the _ccall_ to `f' at cc004.hs:18
`PrelGHC.CReturnable b' arising from the result of the _ccall_ to `f' at cc004.hs:15
cc004.hs:2:
Cannot generalise these overloadings (in a _ccall_):
`PrelGHC.CReturnable a' arising from the result of the _ccall_ to `f' at cc004.hs:11
`PrelGHC.CReturnable b' arising from the result of the _ccall_ to `f' at cc004.hs:8
Compilation had errors
ghc/tests/codeGen/should_run/cg036.hs
View file @ fa7bd36e
......@@ -4,13 +4,13 @@
--
module Main ( main, g ) where
main = putStr (shows (g 42) "\n")
main = putStr (shows (g 42 45 45) "\n")
g :: Int -> Int -> Int -> (Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int)
g :: Int -> Int -> Int -> [Int]
g x y z
= let
f a b = a + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b
g c = f c c
in
(g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y)
[g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y]
ghc/tests/deSugar/should_compile/ds020.hs
View file @ fa7bd36e
......@@ -50,3 +50,5 @@ g ~(~(~(~([])))) = []
eq2 = (2::Int) == (4::Int)
eq3 = (3::Int) == (3::Int)
eq4 = (4::Int) == (2::Int)
ghc/tests/deriving/should_fail/drvfail007.stderr
View file @ fa7bd36e
drvfail007.hs:2:
No instance for `Eq (Int -> Int)'
When deriving classes for `Foo'
Compilation had errors
ghc/tests/programs/jeff-bug/AQ.hs 0 → 100644
View file @ fa7bd36e
-- Addressable Queues --
module AQ where
import LazyST
import Utils
import Hawk
type AQ s a = (STArray s Int (Maybe a), Front s,Back s,QSize s,Int)
type Front s = STRef s Int
type Back s = STRef s Int
type QSize s = STRef s Int
type QAddr = Int
new :: Int -> ST s (AQ s a)
enQueue :: AQ s a -> a -> ST s QAddr
deQueue :: AQ s a -> ST s (a,QAddr)
reQueue :: AQ s a -> a -> ST s QAddr
getSize :: AQ s a -> ST s Int
getMax :: AQ s a -> ST s Int
deQueueWhile :: AQ s a -> (a -> Bool) -> ST s [a]
enList :: AQ s a -> [a] -> ST s [QAddr]
update :: AQ s a -> QAddr -> (a -> a) -> ST s ()
clear :: AQ s a -> ST s ()
space :: AQ s a -> ST s Int
------------------------------------------------------------------------------
assertM True _ = return ()
assertM False s = error $ s ++ "\n"
insert x y z = setQVal x y (Just z)
new n
= do { q <- newSTArray (0,n) Nothing
; f <- newSTRef (-1)
; b <- newSTRef 0
; s <- newSTRef 0
; return (q,f,b,s,n)
}
clear (q,f,b,s,n)
= do { mapM (\x -> writeSTArray q x Nothing) [0 .. n]
; writeSTRef f (-1)
; writeSTRef b 0
; writeSTRef s 0
}
enQueue q elem
= do { sz <- getSize q
; max <- getMax q
; () <- assertM (sz < max) "enQueue over max"
; f <- getFront q
; let f' = (f+1) `mod` max
; setQVal q f' (Just elem)
; setSize q (sz+1)
; setFront q f'
; return f'
}
reQueue q elem
= do { sz <- getSize q
; max <- getMax q
; assertM (sz < max) "reQueue over max"
; b <- getBack q
; let b' = (b-1) `mod` max
; setQVal q b' (Just elem)
; setSize q (sz+1)
; setBack q b'
; return b'
}
deQueue q
= do { sz <- getSize q
; max <- getMax q
; assertM (sz > 0) "deQueue under min"
; b <- getBack q
; mj <- getQVal q b
; let j = mj `catchEx` error "deQueue"
; setSize q (sz-1)
; setBack q $ (b+1) `mod` max
; return (j,b)
}
space q
= do { sz <- getSize q
; m <- getMax q
; return $ m - sz
}
deQueueWhile q f
= do { sz <- getSize q
; if (sz < 1)
then return []
else do { (elem,addr) <- deQueue q
; if (f elem)
then do { elems <- deQueueWhile q f
; return (elem:elems)
}
else do { reQueue q elem
; return []
}
}
}
enList q [] = return []
enList q (x:xs)
= do { sz <- space q
; if (sz > 0)
then do { a <- enQueue q x
; l <- enList q xs
; return $ a:l
}
else return []
}
assignAddrs q l
= do { let len = length l
; sz <- space q
; max <- getMax q
; assertM (sz >= len) "sz < len"
; f <- getFront q
; let f' = f+1
; let addrs = map (`mod` max) [f' .. f'+len]
; return $ zip l addrs
}
assignAddr q x
= do { ans <- assignAddrs q [x]
; return $ head ans
}
iterateQueue q f
= do { front <- getFront q
; back <- getBack q
; max <- getMax q
; updateWhile q front front back max f
}
where updateWhile q front n back max f
| n == back = return ()
| otherwise = do { val <- getQVal q n
; val <- case val of
Just x -> return $ Just $ f x
Nothing -> return Nothing
; setQVal q n val
; updateWhile q front ((n+1) `mod` max) back max f
}
update q n f
= do { x <- getQVal q n
; setQVal q n $ map f x
}
-------------------------------------------------------------------------
getSize (q,f,b,s,m) = readSTRef s
setSize (q,f,b,s,m) v = writeSTRef s v
getMax (q,f,b,s,m) = return m
getFront (q,f,b,s,m) = readSTRef f
setFront (q,f,b,s,m) v = writeSTRef f v
getBack (q,f,b,s,m) = readSTRef b
setBack (q,f,b,s,m) v = writeSTRef b v
getQVal (q,f,b,s,m) n = readSTArray q n
setQVal (q,f,b,s,m) n e = writeSTArray q n e
ghc/tests/programs/jeff-bug/Arithmetic.hs 0 → 100644
View file @ fa7bd36e
module Arithmetic
(
alu
,Immediate
,Sign(..)
,Comparison(..)
,AluOp(..)
,ImmediateSize(..)
) where
import Words
import Word
-- Begin Signature: Arithmetic ----------------------------------------------
{-
The Arithmetic module defines the datatype "AluOp" to represent the
various sorts of operations you might pass to an ALU like circuit.
The "Instruction" class defines its methods to use AluOp as the
least-common denomiator (no pun intended) of arithmetic-based instructions.
-}
type Immediate = Int
data Sign = Signed
| Unsigned
deriving (Eq,Show, Read)
data Comparison = LessThan
| LessEqual
| GreaterThan
| GreaterEqual
| Equal
| NotEqual
deriving (Eq,Show, Read)
data AluOp = Add Sign |
Sub Sign |
Mult Sign |
Div Sign |
And |
Not |
Or | Xor |
Sll | Srl | Sra |
S Comparison |
SetHi | -- Set high 16 bits of value.
Input1 | -- pass input1 through
Input2 | -- pass input2 through
Invalidate -- Invalidate the result of the
-- ALU operation
deriving (Eq,Show, Read)
data ImmediateSize = Imm16Bits | Imm26Bits
alu :: Word w => AluOp -> w -> w -> Maybe w
-- End Signature: Arithmetic ------------------------------------------------
-- If the ALUfunc is "Invalidate", this function returns Nothing,
-- otherwise it performs the assiciated ALU operation.
alu Invalidate _ _
= Nothing
alu aluFunc word1 word2
= Just (exec_op aluFunc word1 word2)
-- signExtend is only used inside combinational circuits.
signExtend :: Word w => ImmediateSize -> Immediate -> w
signExtend Imm16Bits = fromInt
signExtend Imm26Bits = fromInt
------------------------ Integer ALU unit ---------------------------
-- Performs integer addition and also returns whether overflow ocurred
addOverflowCheck :: Word w => w -> w -> (w,Bool)
addOverflowCheck a b
= (out,overflow)
where
out = a + b
overflow = out > maxBound || out < minBound
overflowErr :: Word w => AluOp -> w -> w -> a
overflowErr op a b
= error ("alu (" ++ show op ++ ") " ++ show a ++ " "
++ show b ++ " <-- overflow")
{-
NOTE: I'm not worrying about whether overflow
calculations are computed correctly, except
for signed addition and subtraction. In the
other cases, I'm letting the bits fall where
they may. Hopefully none of the benchmarks
cause overflows at all.
-}
-- This function performs the unsigned version of the normal signed
-- integer operation
unsignedWordOp :: Word w => (w->w->w) -> (w->w->w)
unsignedWordOp f a b = sign $ unsign a `f` unsign b
-- These functions convert between a Word and a vector of Bools.
bitValues :: Word w => [w]
bitValues = map (2 ^) [31,30..0]
buildVec :: Word w => w -> [Bool]
buildVec n
= makeVec (unsign n) bitValues
where
makeVec :: Word w => w -> [w] -> [Bool]
makeVec 0 [] = []
makeVec _ [] = [] ---- should we catch this?
makeVec n (b:bs)
= if n >= b
then True : makeVec (n-b) bs
else False : makeVec n bs
buildWord :: Word w => [Bool] -> w
buildWord bools
= sign $ makeInteger bools bitValues
where
makeInteger [] []
= 0
makeInteger n []
= error ("buildWord -- argument too large: " ++ show bools)
makeInteger (b:bs) (n:ns)
= if b
then n + makeInteger bs ns
else makeInteger bs ns
-- Performs an element-wise boolean operation on corresponding
-- pairs of bits of the argument integers
bitOp :: Word w => (Bool->Bool->Bool) -> (w->w->w)
bitOp f a b
= buildWord $ zipWith f (buildVec a) (buildVec b)
-- This function assumes the ALUfunc argument is not "Invalidate"
exec_op :: Word w => AluOp -> w -> w -> w
exec_op op@(Add Signed) a b
= if overflow
then overflowErr op a b
else out
where
(out,overflow) = addOverflowCheck a b
exec_op (Add Unsigned) a b
= unsignedWordOp (+) a b
exec_op op@(Sub Signed) a b
= if overflow
then overflowErr op a b
else out
where
(out,overflow) = addOverflowCheck a (-b)
exec_op (Sub Unsigned) a b
= unsignedWordOp (-) a b
exec_op (Mult Signed) a b
= sign $ a * b
exec_op (Mult Unsigned) a b
= unsignedWordOp (*) a b
exec_op (Div Signed) a b
= sign $ a `div` b
exec_op (Div Unsigned) a b
= unsignedWordOp div a b
exec_op And a b = bitOp (&&) a b
exec_op Or a b = bitOp (||) a b
-- eh, this is kinda temporary.
--exec_op Not a b = bitOp (\x y -> not x) a b
exec_op Not a b = if a == 0 then 1 else 0
exec_op Xor a b = bitOp xor a b
where
xor False x = x
xor True x = not x
exec_op Sll a b
= buildWord $ drop shiftAmt (buildVec a) ++ replicate shiftAmt False
where
shiftAmt = toInt $ unsign b `mod` 32
exec_op Srl a b
= buildWord $ replicate shiftAmt False ++ take (32 - shiftAmt) (buildVec a)
where
shiftAmt = toInt $ unsign b `mod` 32
exec_op Sra a b
= buildWord $ replicate shiftAmt signBit ++ take (32 - shiftAmt) (buildVec a)
where
shiftAmt = toInt $ unsign b `mod` 32
signBit = (a < 0)
exec_op (S relop) a b
= if (a `relation` b) then 1 else 0
where
relation = case relop of
LessThan -> (<)
LessEqual -> (<=)
GreaterThan -> (>)
GreaterEqual -> (>=)
Equal -> (==)
NotEqual -> (/=)
exec_op SetHi a _
= a * num_half -- a * 2^n
exec_op Input1 a b
= a
exec_op Input2 a b
= b
ghc/tests/programs/jeff-bug/BoundedSet.hs 0 → 100644
View file @ fa7bd36e
module BoundedSet
( new
, readBound
, readSize
, read
, clear
, insert
, spaceAvail
, rmSuch
, rmSuchN
, BoundedSet
, iterateSet
) where
import LazyST
import Prelude hiding (read)
import List
new :: Int -> ST s (BoundedSet s a)
readBound :: BoundedSet s a -> ST s Int
readSize :: BoundedSet s a -> ST s Int
read :: BoundedSet s a -> ST s [a]
clear :: BoundedSet s a -> ST s [a]
insert :: BoundedSet s a -> [a] -> ST s ()
spaceAvail :: BoundedSet s a -> ST s Int
rmSuch :: BoundedSet s a -> (a -> Bool) -> ST s [a]
rmSuchN :: BoundedSet s a -> Int -> (a -> Bool) -> ST s [a]
iterateSet :: BoundedSet s a -> (a -> a) -> ST s ()
-- Implementation ----------------------------------------------------
type BoundedSet s a = (STRef s [a],Int)
iterateSet s f =
do { set <- read s
; write s (map f set)
}
read (s,n) = readSTRef s
rmSuch s f
= do { set <- read s
; let (yes,no) = partition f set
; write s no
; return yes
}
rmSuchN s n f
= do { such <- rmSuch s f
; let (big,small) = splitAt n such
; insert s small
; return big
}
write :: BoundedSet s a -> [a] -> ST s ()
write (s,n) x = writeSTRef s x
readBound (s,n) = return n
new n
= do { set <- newSTRef []
; return (set,n)
}
clear s =
do { set <- read s
; write s []
; return set
}
readSize s =
do { set <- read s
; return ( length set)
}
spaceAvail s
= do { bnd <- readBound s
; sz <- readSize s
; return (bnd - sz)
}
insert s l
= do { set <- read s
; n <- readBound s
; write s $ take n (set ++ l)
}
ghc/tests/programs/jeff-bug/Cell.hs 0 → 100644
View file @ fa7bd36e
module Cell where
import Register
import Words
-- Begin Signature: Cell ----------------------------------------------
{-
Cells are intended to be used to represent the source and destination
operands in machine instructions. Consider, for example:
r1=? <- r20=15 + 8
Here the first cell (r1=?) is a register reference, and its value is
not known yet. The source cell r20=15 is a register reference with
its value calculated. 8 is the other source operand --- in this