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

Minor fixes to tests

ghc/tests/ccall/should_fail/cc001.hs

--- !!! cc002 -- ccall with ambiguous argument
+-- !!! cc001 -- ccall with ambiguous argument
 module Test where
 
 f :: IO ()

ghc/tests/ccall/should_fail/cc001.stderr

- 
+
 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

- 
+
 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

- 
+
 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

@@ -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

@@ -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

- 
+
 drvfail007.hs:2:
     No instance for `Eq (Int -> Int)'
     When deriving classes for `Foo'
 
-
 Compilation had errors
+

ghc/tests/programs/jeff-bug/AQ.hs

+-- 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

+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

+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

+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 
+case a constant.  The Cell class hopes to capture this notion, while
+allowing you freedom to define richer Cell-like structures.