Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Shayne Fletcher
Glasgow Haskell Compiler
Commits
fa7bd36e
Commit
fa7bd36e
authored
Apr 29, 1999
by
simonpj
Browse files
[project @ 1999-04-29 11:53:12 by simonpj]
Minor fixes to tests
parent
b73bc3a0
Changes
47
Hide whitespace changes
Inline
Side-by-side
ghc/tests/ccall/should_fail/cc001.hs
View file @
fa7bd36e
-- !!! cc00
2
-- ccall with ambiguous argument
-- !!! cc00
1
-- 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:1
8
`PrelGHC.CReturnable
b
' arising from the result of the _ccall_ to `f' at cc004.hs:1
5
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