Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
9df21476
Commit
9df21476
authored
Jan 10, 2000
by
sewardj
Browse files
[project @ 2000-01-10 16:23:32 by sewardj]
parent
98689fa6
Changes
4
Hide whitespace changes
Inline
Side-by-side
ghc/interpreter/lib/Prelude.hs
View file @
9df21476
...
...
@@ -1548,11 +1548,11 @@ readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
primCompAux
::
Ord
a
=>
a
->
a
->
Ordering
->
Ordering
primCompAux
x
y
o
=
case
compare
x
y
of
EQ
->
o
;
LT
->
LT
;
GT
->
GT
primPmInt
::
Num
a
=>
Int
->
a
->
Bool
primPmInt
n
x
=
fromInt
n
==
x
hugs
primPmInt
::
Num
a
=>
Int
->
a
->
Bool
hugs
primPmInt
n
x
=
fromInt
n
==
x
primPmInteger
::
Num
a
=>
Integer
->
a
->
Bool
primPmInteger
n
x
=
fromInteger
n
==
x
hugs
primPmInteger
::
Num
a
=>
Integer
->
a
->
Bool
hugs
primPmInteger
n
x
=
fromInteger
n
==
x
primPmDouble
::
Fractional
a
=>
Double
->
a
->
Bool
primPmDouble
n
x
=
fromDouble
n
==
x
...
...
@@ -1562,28 +1562,28 @@ primPmFail :: a
primPmFail
=
error
"Pattern Match Failure"
-- used in desugaring Foreign functions
primMkIO
::
(
RealWorld
->
(
a
,
RealWorld
))
->
IO
a
primMkIO
=
ST
hugs
primMkIO
::
(
RealWorld
->
(
a
,
RealWorld
))
->
IO
a
hugs
primMkIO
=
ST
primCreateAdjThunk
::
(
a
->
b
)
->
String
->
Char
->
IO
Addr
primCreateAdjThunk
fun
typestr
callconv
hugs
primCreateAdjThunk
::
(
a
->
b
)
->
String
->
Char
->
IO
Addr
hugs
primCreateAdjThunk
fun
typestr
callconv
=
do
sp
<-
makeStablePtr
fun
p
<-
copy_String_to_cstring
typestr
-- is never freed
a
<-
primCreateAdjThunkARCH
sp
p
callconv
return
a
-- The following primitives are only needed if (n+k) patterns are enabled:
primPmSub
::
Integral
a
=>
Int
->
a
->
a
primPmSub
n
x
=
x
-
fromInt
n
hugs
primPmSub
::
Integral
a
=>
Int
->
a
->
a
hugs
primPmSub
n
x
=
x
-
fromInt
n
primPmFromInteger
::
Integral
a
=>
Integer
->
a
primPmFromInteger
=
fromIntegral
hugs
primPmFromInteger
::
Integral
a
=>
Integer
->
a
hugs
primPmFromInteger
=
fromIntegral
primPmSubtract
::
Integral
a
=>
a
->
a
->
a
primPmSubtract
x
y
=
x
-
y
hugs
primPmSubtract
::
Integral
a
=>
a
->
a
->
a
hugs
primPmSubtract
x
y
=
x
-
y
primPmLe
::
Integral
a
=>
a
->
a
->
Bool
primPmLe
x
y
=
x
<=
y
hugs
primPmLe
::
Integral
a
=>
a
->
a
->
Bool
hugs
primPmLe
x
y
=
x
<=
y
-- Unpack strings generated by the Hugs code generator.
-- Strings can contain \0 provided they're coded right.
...
...
@@ -1842,8 +1842,8 @@ prelCleanupAfterRunAction :: IORef (Maybe (IO ()))
prelCleanupAfterRunAction
=
primRunST
(
newIORef
Nothing
)
-- used when Hugs invokes top level function
primRunIO_
hugs_
toplevel
::
IO
a
->
()
primRunIO_
hugs_
toplevel
m
hugs
primRunIO_toplevel
::
IO
a
->
()
hugs
primRunIO_toplevel
m
=
protect
5
(
fst
(
unST
composite_action
realWorld
))
where
composite_action
...
...
ghc/interpreter/link.c
View file @
9df21476
...
...
@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: link.c,v $
* $Revision: 1.2
7
$
* $Date: 2000/01/
07 17:49:29
$
* $Revision: 1.2
8
$
* $Date: 2000/01/
10 16:23:32
$
* ------------------------------------------------------------------------*/
#include
"prelude.h"
...
...
@@ -213,9 +213,13 @@ static Name predefinePrim ( String s );
static
Tycon
linkTycon
(
String
s
)
{
Tycon
tc
=
findTycon
(
findText
(
s
));
if
(
nonNull
(
tc
))
{
return
tc
;
if
(
nonNull
(
tc
))
return
tc
;
if
(
combined
)
{
tc
=
findTyconInAnyModule
(
findText
(
s
));
if
(
nonNull
(
tc
))
return
tc
;
}
fprintf
(
stderr
,
"frambozenvla! unknown tycon %s
\n
"
,
s
);
return
NIL
;
ERRMSG
(
0
)
"Prelude does not define standard type
\"
%s
\"
"
,
s
EEND
;
}
...
...
@@ -223,9 +227,13 @@ static Tycon linkTycon( String s )
static
Class
linkClass
(
String
s
)
{
Class
cc
=
findClass
(
findText
(
s
));
if
(
nonNull
(
cc
))
{
return
cc
;
}
if
(
nonNull
(
cc
))
return
cc
;
if
(
combined
)
{
cc
=
findClassInAnyModule
(
findText
(
s
));
if
(
nonNull
(
cc
))
return
cc
;
}
fprintf
(
stderr
,
"frambozenvla! unknown class %s
\n
"
,
s
);
return
NIL
;
ERRMSG
(
0
)
"Prelude does not define standard class
\"
%s
\"
"
,
s
EEND
;
}
...
...
@@ -233,9 +241,13 @@ static Class linkClass( String s )
static
Name
linkName
(
String
s
)
{
Name
n
=
findName
(
findText
(
s
));
if
(
nonNull
(
n
))
{
return
n
;
}
if
(
nonNull
(
n
))
return
n
;
if
(
combined
)
{
n
=
findNameInAnyModule
(
findText
(
s
));
if
(
nonNull
(
n
))
return
n
;
}
fprintf
(
stderr
,
"frambozenvla! unknown name %s
\n
"
,
s
);
return
NIL
;
ERRMSG
(
0
)
"Prelude does not define standard name
\"
%s
\"
"
,
s
EEND
;
}
...
...
@@ -427,7 +439,7 @@ Void linkPreludeNames(void) { /* Hook to names defined in Prelude */
setCurrModule
(
modulePrelude
);
/* primops */
nameMkIO
=
linkName
(
"primMkIO"
);
nameMkIO
=
linkName
(
"
hugs
primMkIO"
);
for
(
i
=
0
;
asmPrimOps
[
i
].
name
;
++
i
)
{
Text
t
=
findText
(
asmPrimOps
[
i
].
name
);
Name
n
=
findName
(
t
);
...
...
@@ -447,25 +459,25 @@ Void linkPreludeNames(void) { /* Hook to names defined in Prelude */
/* static(tidyInfix) */
nameNegate
=
linkName
(
"negate"
);
/* user interface */
nameRunIO
=
linkName
(
"primRunIO_
hugs_
toplevel"
);
nameRunIO
=
linkName
(
"
hugs
primRunIO_toplevel"
);
namePrint
=
linkName
(
"print"
);
/* desugar */
nameOtherwise
=
linkName
(
"otherwise"
);
nameUndefined
=
linkName
(
"undefined"
);
/* pmc */
# if NPLUSK
namePmSub
=
linkName
(
"primPmSub"
);
namePmSub
=
linkName
(
"
hugs
primPmSub"
);
# endif
/* translator */
nameEqChar
=
linkName
(
"primEqChar"
);
nameCreateAdjThunk
=
linkName
(
"primCreateAdjThunk"
);
namePmInt
=
linkName
(
"primPmInt"
);
namePmInteger
=
linkName
(
"primPmInteger"
);
nameCreateAdjThunk
=
linkName
(
"
hugs
primCreateAdjThunk"
);
namePmInt
=
linkName
(
"
hugs
primPmInt"
);
namePmInteger
=
linkName
(
"
hugs
primPmInteger"
);
namePmDouble
=
linkName
(
"primPmDouble"
);
namePmFromInteger
=
linkName
(
"primPmFromInteger"
);
namePmSubtract
=
linkName
(
"primPmSubtract"
);
namePmLe
=
linkName
(
"primPmLe"
);
namePmFromInteger
=
linkName
(
"
hugs
primPmFromInteger"
);
namePmSubtract
=
linkName
(
"
hugs
primPmSubtract"
);
namePmLe
=
linkName
(
"
hugs
primPmLe"
);
implementCfun
(
nameCons
,
NIL
);
implementCfun
(
nameNil
,
NIL
);
...
...
@@ -492,6 +504,12 @@ Int what; {
case
POSTPREL
:
#if 1
fprintf
(
stderr
,
"linkControl(POSTPREL)
\n
"
);
#if 1
setCurrModule
(
modulePrelude
);
linkPreludeTC
();
linkPreludeCM
();
linkPreludeNames
();
#endif
#endif
break
;
...
...
ghc/interpreter/storage.c
View file @
9df21476
...
...
@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: storage.c,v $
* $Revision: 1.3
3
$
* $Date: 2000/01/
07 17:49:29
$
* $Revision: 1.3
4
$
* $Date: 2000/01/
10 16:23:33
$
* ------------------------------------------------------------------------*/
#include
"prelude.h"
...
...
@@ -1209,6 +1209,29 @@ Tycon findQualTyconWithoutConsultingExportList ( QualId q )
return
NIL
;
}
Tycon
findTyconInAnyModule
(
Text
t
)
{
Tycon
tc
;
for
(
tc
=
TYCMIN
;
tc
<
tyconHw
;
tc
++
)
if
(
tycon
(
tc
).
text
==
t
)
return
tc
;
return
NIL
;
}
Class
findClassInAnyModule
(
Text
t
)
{
Class
cc
;
for
(
cc
=
CLASSMIN
;
cc
<
classHw
;
cc
++
)
if
(
cclass
(
cc
).
text
==
t
)
return
cc
;
return
NIL
;
}
Name
findNameInAnyModule
(
Text
t
)
{
Name
nm
;
for
(
nm
=
NAMEMIN
;
nm
<
nameHw
;
nm
++
)
if
(
name
(
nm
).
text
==
t
)
return
nm
;
return
NIL
;
}
/* Same deal, except for Names. */
Name
findQualNameWithoutConsultingExportList
(
QualId
q
)
...
...
ghc/lib/hugs/Prelude.hs
View file @
9df21476
...
...
@@ -1548,11 +1548,11 @@ readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
primCompAux
::
Ord
a
=>
a
->
a
->
Ordering
->
Ordering
primCompAux
x
y
o
=
case
compare
x
y
of
EQ
->
o
;
LT
->
LT
;
GT
->
GT
primPmInt
::
Num
a
=>
Int
->
a
->
Bool
primPmInt
n
x
=
fromInt
n
==
x
hugs
primPmInt
::
Num
a
=>
Int
->
a
->
Bool
hugs
primPmInt
n
x
=
fromInt
n
==
x
primPmInteger
::
Num
a
=>
Integer
->
a
->
Bool
primPmInteger
n
x
=
fromInteger
n
==
x
hugs
primPmInteger
::
Num
a
=>
Integer
->
a
->
Bool
hugs
primPmInteger
n
x
=
fromInteger
n
==
x
primPmDouble
::
Fractional
a
=>
Double
->
a
->
Bool
primPmDouble
n
x
=
fromDouble
n
==
x
...
...
@@ -1562,28 +1562,28 @@ primPmFail :: a
primPmFail
=
error
"Pattern Match Failure"
-- used in desugaring Foreign functions
primMkIO
::
(
RealWorld
->
(
a
,
RealWorld
))
->
IO
a
primMkIO
=
ST
hugs
primMkIO
::
(
RealWorld
->
(
a
,
RealWorld
))
->
IO
a
hugs
primMkIO
=
ST
primCreateAdjThunk
::
(
a
->
b
)
->
String
->
Char
->
IO
Addr
primCreateAdjThunk
fun
typestr
callconv
hugs
primCreateAdjThunk
::
(
a
->
b
)
->
String
->
Char
->
IO
Addr
hugs
primCreateAdjThunk
fun
typestr
callconv
=
do
sp
<-
makeStablePtr
fun
p
<-
copy_String_to_cstring
typestr
-- is never freed
a
<-
primCreateAdjThunkARCH
sp
p
callconv
return
a
-- The following primitives are only needed if (n+k) patterns are enabled:
primPmSub
::
Integral
a
=>
Int
->
a
->
a
primPmSub
n
x
=
x
-
fromInt
n
hugs
primPmSub
::
Integral
a
=>
Int
->
a
->
a
hugs
primPmSub
n
x
=
x
-
fromInt
n
primPmFromInteger
::
Integral
a
=>
Integer
->
a
primPmFromInteger
=
fromIntegral
hugs
primPmFromInteger
::
Integral
a
=>
Integer
->
a
hugs
primPmFromInteger
=
fromIntegral
primPmSubtract
::
Integral
a
=>
a
->
a
->
a
primPmSubtract
x
y
=
x
-
y
hugs
primPmSubtract
::
Integral
a
=>
a
->
a
->
a
hugs
primPmSubtract
x
y
=
x
-
y
primPmLe
::
Integral
a
=>
a
->
a
->
Bool
primPmLe
x
y
=
x
<=
y
hugs
primPmLe
::
Integral
a
=>
a
->
a
->
Bool
hugs
primPmLe
x
y
=
x
<=
y
-- Unpack strings generated by the Hugs code generator.
-- Strings can contain \0 provided they're coded right.
...
...
@@ -1842,8 +1842,8 @@ prelCleanupAfterRunAction :: IORef (Maybe (IO ()))
prelCleanupAfterRunAction
=
primRunST
(
newIORef
Nothing
)
-- used when Hugs invokes top level function
primRunIO_
hugs_
toplevel
::
IO
a
->
()
primRunIO_
hugs_
toplevel
m
hugs
primRunIO_toplevel
::
IO
a
->
()
hugs
primRunIO_toplevel
m
=
protect
5
(
fst
(
unST
composite_action
realWorld
))
where
composite_action
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment