X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FPrelBase.lhs;h=16264ed116a5e763c196f9c3ecc9ab6773b3d380;hb=467bd515da15a58b0668c2912bbd19a81a203659;hp=b168ef4c952be6d66d66bc8a4650c6f7e42d73b6;hpb=ce6e38dc12b5feae2eb43e94d833646a9c921cda;p=ghc-hetmet.git

diff --git a/ghc/lib/std/PrelBase.lhs b/ghc/lib/std/PrelBase.lhs
index b168ef4..16264ed 100644
--- a/ghc/lib/std/PrelBase.lhs
+++ b/ghc/lib/std/PrelBase.lhs
@@ -1,5 +1,5 @@
 % -----------------------------------------------------------------------------
-% $Id: PrelBase.lhs,v 1.32 2000/06/30 13:39:35 simonmar Exp $
+% $Id: PrelBase.lhs,v 1.45 2001/04/14 22:28:22 qrczak Exp $
 %
 % (c) The University of Glasgow, 1992-2000
 %
@@ -75,19 +75,18 @@ Other Prelude modules are much easier with fewer complex dependencies.
 \begin{code}
 {-# OPTIONS -fno-implicit-prelude #-}
 
+#include "MachDeps.h"
+
 module PrelBase
 	(
 	module PrelBase,
-	module PrelGHC		-- Re-export PrelGHC, to avoid lots of people 
-				-- having to import it explicitly
+	module PrelGHC,		-- Re-export PrelGHC and PrelErr, to avoid lots
+	module PrelErr          -- of people having to import it explicitly
   ) 
 	where
 
-import {-# SOURCE #-} PrelErr ( error )
-import {-# SOURCE #-} PrelNum ( addr2Integer )
-  -- Otherwise the system import of addr2Integer looks for PrelNum.hi
-
 import PrelGHC
+import {-# SOURCE #-} PrelErr
 
 infixr 9  .
 infixr 5  ++, :
@@ -109,14 +108,14 @@ default ()		-- Double isn't available yet
 %*********************************************************
 
 \begin{code}
-{-		
+{-
 data  Bool  =  False | True
 data Ordering = LT | EQ | GT 
 data Char = C# Char#
 type  String = [Char]
 data Int = I# Int#
 data  ()  =  ()
--- data [] a = MkNil
+data [] a = MkNil
 
 not True = False
 (&&) True True = True
@@ -125,14 +124,14 @@ otherwise = True
 build = error "urk"
 foldr = error "urk"
 
-unpackCString#  :: Addr# -> [Char]
-unpackFoldrCString#  :: Addr# -> (Char  -> a -> a) -> a -> a 
+unpackCString# :: Addr# -> [Char]
+unpackFoldrCString# :: Addr# -> (Char  -> a -> a) -> a -> a 
 unpackAppendCString# :: Addr# -> [Char] -> [Char]
-unpackNBytes#      :: Addr# -> Int#   -> [Char]
-unpackNBytes# a b = error "urk"
+unpackCStringUtf8# :: Addr# -> [Char]
 unpackCString# a = error "urk"
 unpackFoldrCString# a = error "urk"
 unpackAppendCString# a = error "urk"
+unpackCStringUtf8# a = error "urk"
 -}
 \end{code}
 
@@ -145,37 +144,35 @@ unpackAppendCString# a = error "urk"
 
 \begin{code}
 class  Eq a  where
-    (==), (/=)		:: a -> a -> Bool
+    (==), (/=)		 :: a -> a -> Bool
 
---    x /= y		= not (x == y)
---    x == y		= not (x /= y)
---    x /= y		=  True
-    (/=) x y            = not  ((==) x y)
-    x == y		=  True
+    x /= y		 = not (x == y)
+    x == y		 = not (x /= y)
 
 class  (Eq a) => Ord a  where
-    compare             :: a -> a -> Ordering
-    (<), (<=), (>=), (>):: a -> a -> Bool
-    max, min		:: a -> a -> a
+    compare		 :: a -> a -> Ordering
+    (<), (<=), (>), (>=) :: a -> a -> Bool
+    max, min		 :: a -> a -> a
+
+    -- An instance of Ord should define either 'compare' or '<='.
+    -- Using 'compare' can be more efficient for complex types.
 
--- An instance of Ord should define either compare or <=
--- Using compare can be more efficient for complex types.
     compare x y
-	    | x == y    = EQ
-	    | x <= y    = LT	-- NB: must be '<=' not '<' to validate the
-				-- above claim about the minimal things that can
-				-- be defined for an instance of Ord
-	    | otherwise = GT
-
-    x <= y  = case compare x y of { GT -> False; _other -> True }
-    x <	 y  = case compare x y of { LT -> True;  _other -> False }
-    x >= y  = case compare x y of { LT -> False; _other -> True }
-    x >	 y  = case compare x y of { GT -> True;  _other -> False }
-
-	-- These two default methods use '>' rather than compare
+	| x == y    = EQ
+	| x <= y    = LT	-- NB: must be '<=' not '<' to validate the
+				-- above claim about the minimal things that
+				-- can be defined for an instance of Ord
+	| otherwise = GT
+
+    x <	 y = case compare x y of { LT -> True;  _other -> False }
+    x <= y = case compare x y of { GT -> False; _other -> True }
+    x >	 y = case compare x y of { GT -> True;  _other -> False }
+    x >= y = case compare x y of { LT -> False; _other -> True }
+
+	-- These two default methods use '<=' rather than 'compare'
 	-- because the latter is often more expensive
-    max x y = if x > y then x else y
-    min x y = if x > y then y else x
+    max x y = if x <= y then y else x
+    min x y = if x <= y then x else y
 \end{code}
 
 %*********************************************************
@@ -186,7 +183,7 @@ class  (Eq a) => Ord a  where
 
 \begin{code}
 class  Functor f  where
-    fmap         :: (a -> b) -> f a -> f b
+    fmap        :: (a -> b) -> f a -> f b
 
 class  Monad m  where
     (>>=)       :: m a -> (a -> m b) -> m b
@@ -196,7 +193,6 @@ class  Monad m  where
 
     m >> k      =  m >>= \_ -> k
     fail s      = error s
-
 \end{code}
 
 
@@ -212,31 +208,20 @@ data [] a = [] | a : [a]  -- do explicitly: deriving (Eq, Ord)
 
 
 instance (Eq a) => Eq [a]  where
-{-
     {-# SPECIALISE instance Eq [Char] #-}
--}
-    []     == []     = True	
+    []     == []     = True
     (x:xs) == (y:ys) = x == y && xs == ys
-    _xs    == _ys    = False			
-
-    xs     /= ys     = if (xs == ys) then False else True
+    _xs    == _ys    = False
 
 instance (Ord a) => Ord [a] where
-{-
     {-# SPECIALISE instance Ord [Char] #-}
--}
-    a <  b  = case compare a b of { LT -> True;  EQ -> False; GT -> False }
-    a <= b  = case compare a b of { LT -> True;  EQ -> True;  GT -> False }
-    a >= b  = case compare a b of { LT -> False; EQ -> True;  GT -> True  }
-    a >  b  = case compare a b of { LT -> False; EQ -> False; GT -> True  }
 
     compare []     []     = EQ
-    compare (_:_)  []     = GT
     compare []     (_:_)  = LT
+    compare (_:_)  []     = GT
     compare (x:xs) (y:ys) = case compare x y of
-                                 LT -> LT	
-			         GT -> GT		
-				 EQ -> compare xs ys
+                                EQ    -> compare xs ys
+                                other -> other
 
 instance Functor [] where
     fmap = map
@@ -263,7 +248,7 @@ foldr            :: (a -> b -> b) -> b -> [a] -> b
 foldr k z xs = go xs
 	     where
 	       go []     = z
-	       go (x:xs) = x `k` go xs
+	       go (y:ys) = y `k` go ys
 
 build 	:: forall a. (forall b. (a -> b -> b) -> b -> b) -> [a]
 {-# INLINE 2 build #-}
@@ -314,6 +299,7 @@ map :: (a -> b) -> [a] -> [b]
 map = mapList
 
 -- Note eta expanded
+mapFB ::  (elt -> lst -> lst) -> (a -> elt) -> a -> lst -> lst
 mapFB c f x ys = c (f x) ys
 
 mapList :: (a -> b) -> [a] -> [b]
@@ -422,7 +408,7 @@ data Ordering = LT | EQ | GT deriving (Eq, Ord)
 %*********************************************************
 
 \begin{code}
-type  String = [Char]
+type String = [Char]
 
 data Char = C# Char#
 
@@ -441,8 +427,8 @@ instance Ord Char where
   (C# c1) <  (C# c2) = c1 `ltChar#` c2
 
 chr :: Int -> Char
-chr (I# i) | i >=# 0# && i <=# 255# = C# (chr# i)
-	   | otherwise = error ("Prelude.chr: bad argument")
+chr (I# i) | i >=# 0# && i <=# 0x10FFFF# = C# (chr# i)
+           | otherwise                   = error "Prelude.chr: bad argument"
 
 unsafeChr :: Int -> Char
 unsafeChr (I# i) =  C# (chr# i)
@@ -451,6 +437,12 @@ ord :: Char -> Int
 ord (C# c) =  I# (ord# c)
 \end{code}
 
+String equality is used when desugaring pattern-matches against strings.
+
+\begin{code}
+eqString :: String -> String -> Bool
+eqString = (==)
+\end{code}
 
 %*********************************************************
 %*							*
@@ -465,25 +457,34 @@ zeroInt, oneInt, twoInt, maxInt, minInt :: Int
 zeroInt = I# 0#
 oneInt  = I# 1#
 twoInt  = I# 2#
-minInt  = I# (-2147483648#)	-- GHC <= 2.09 had this at -2147483647
-maxInt  = I# 2147483647#
+#if WORD_SIZE_IN_BYTES == 4
+minInt  = I# (-0x80000000#)
+maxInt  = I# 0x7FFFFFFF#
+#else
+minInt  = I# (-0x8000000000000000#)
+maxInt  = I# 0x7FFFFFFFFFFFFFFF#
+#endif
 
 instance Eq Int where
-    (==) x y = x `eqInt` y
-    (/=) x y = x `neInt` y
+    (==) = eqInt
+    (/=) = neInt
 
 instance Ord Int where
-    compare x y = compareInt x y 
+    compare = compareInt
 
-    (<)  x y = ltInt x y
-    (<=) x y = leInt x y
-    (>=) x y = geInt x y
-    (>)  x y = gtInt x y
+    (<)  = ltInt
+    (<=) = leInt
+    (>=) = geInt
+    (>)  = gtInt
 
 compareInt :: Int -> Int -> Ordering
-(I# x) `compareInt` (I# y) | x <# y    = LT
-			   | x ==# y   = EQ
-			   | otherwise = GT
+(I# x) `compareInt` (I# y) = compareInt# x y
+
+compareInt# :: Int# -> Int# -> Ordering
+compareInt# x# y#
+ | x# <#  y# = LT
+ | x# ==# y# = EQ
+ | otherwise = GT
 \end{code}
 
 
@@ -513,6 +514,7 @@ flip f x y		=  f y x
 
 -- right-associating infix application operator (useful in continuation-
 -- passing style)
+{-# INLINE ($) #-}
 ($)			:: (a -> b) -> a -> b
 f $ x			=  f x
 
@@ -549,10 +551,37 @@ instance CReturnable () -- Why, exactly?
 
 %*********************************************************
 %*							*
+\subsection{Generics}
+%*							*
+%*********************************************************
+
+\begin{code}
+data Unit = Unit
+data a :+: b = Inl a | Inr b
+data a :*: b = a :*: b
+\end{code}
+
+
+%*********************************************************
+%*							*
 \subsection{Numeric primops}
 %*							*
 %*********************************************************
 
+\begin{code}
+divInt#, modInt# :: Int# -> Int# -> Int#
+x# `divInt#` y#
+    | (x# ># 0#) && (y# <# 0#) = ((x# -# y#) -# 1#) `quotInt#` y#
+    | (x# <# 0#) && (y# ># 0#) = ((x# -# y#) +# 1#) `quotInt#` y#
+    | otherwise                = x# `quotInt#` y#
+x# `modInt#` y#
+    | (x# ># 0#) && (y# <# 0#) ||
+      (x# <# 0#) && (y# ># 0#)    = if r# /=# 0# then r# +# y# else 0#
+    | otherwise                   = r#
+    where
+    r# = x# `remInt#` y#
+\end{code}
+
 Definitions of the boxed PrimOps; these will be
 used in the case of partial applications, etc.
 
@@ -570,12 +599,14 @@ used in the case of partial applications, etc.
 {-# INLINE remInt #-}
 {-# INLINE negateInt #-}
 
-plusInt, minusInt, timesInt, quotInt, remInt, gcdInt :: Int -> Int -> Int
-plusInt	(I# x) (I# y) = I# (x +# y)
-minusInt(I# x) (I# y) = I# (x -# y)
-timesInt(I# x) (I# y) = I# (x *# y)
-quotInt	(I# x) (I# y) = I# (quotInt# x y)
-remInt	(I# x) (I# y) = I# (remInt#  x y)
+plusInt, minusInt, timesInt, quotInt, remInt, divInt, modInt, gcdInt :: Int -> Int -> Int
+(I# x) `plusInt`  (I# y) = I# (x +# y)
+(I# x) `minusInt` (I# y) = I# (x -# y)
+(I# x) `timesInt` (I# y) = I# (x *# y)
+(I# x) `quotInt`  (I# y) = I# (x `quotInt#` y)
+(I# x) `remInt`   (I# y) = I# (x `remInt#`  y)
+(I# x) `divInt`   (I# y) = I# (x `divInt#`  y)
+(I# x) `modInt`   (I# y) = I# (x `modInt#`  y)
 
 gcdInt (I# a) (I# b) = g a b
    where g 0# 0# = error "PrelBase.gcdInt: gcd 0 0 is undefined"
@@ -591,26 +622,25 @@ gcdInt (I# a) (I# b) = g a b
 negateInt :: Int -> Int
 negateInt (I# x) = I# (negateInt# x)
 
-divInt, modInt :: Int -> Int -> Int
-x `divInt` y 
-  | x > zeroInt && y < zeroInt = quotInt ((x `minusInt` y) `minusInt` oneInt) y
-  | x < zeroInt && y > zeroInt = quotInt ((x `minusInt` y) `plusInt`  oneInt) y
-  | otherwise	   = quotInt x y
-
-x `modInt` y 
-  | x > zeroInt && y < zeroInt || 
-    x < zeroInt && y > zeroInt  = if r/=zeroInt then r `plusInt` y else zeroInt
-  | otherwise	   		= r
-  where
-    r = remInt x y
-
 gtInt, geInt, eqInt, neInt, ltInt, leInt :: Int -> Int -> Bool
-gtInt	(I# x) (I# y) = x ># y
-geInt	(I# x) (I# y) = x >=# y
-eqInt	(I# x) (I# y) = x ==# y
-neInt	(I# x) (I# y) = x /=# y
-ltInt	(I# x) (I# y) = x <# y
-leInt	(I# x) (I# y) = x <=# y
+(I# x) `gtInt` (I# y) = x >#  y
+(I# x) `geInt` (I# y) = x >=# y
+(I# x) `eqInt` (I# y) = x ==# y
+(I# x) `neInt` (I# y) = x /=# y
+(I# x) `ltInt` (I# y) = x <#  y
+(I# x) `leInt` (I# y) = x <=# y
+
+#if WORD_SIZE_IN_BYTES == 4
+{-# RULES
+"intToInt32#"   forall x#. intToInt32#   x# = x#
+"wordToWord32#" forall x#. wordToWord32# x# = x#
+     #-}
+#endif
+
+{-# RULES
+"int2Word2Int"  forall x#. int2Word# (word2Int# x#) = x#
+"word2Int2Word" forall x#. word2Int# (int2Word# x#) = x#
+    #-}
 \end{code}
 
 
@@ -624,10 +654,10 @@ This code is needed for virtually all programs, since it's used for
 unpacking the strings of error messages.
 
 \begin{code}
-unpackCString#  :: Addr# -> [Char]
+unpackCString# :: Addr# -> [Char]
 unpackCString# a = unpackCStringList# a
 
-unpackCStringList#  :: Addr# -> [Char]
+unpackCStringList# :: Addr# -> [Char]
 unpackCStringList# addr 
   = unpack 0#
   where
@@ -647,7 +677,7 @@ unpackAppendCString# addr rest
       where
 	ch = indexCharOffAddr# addr nh
 
-unpackFoldrCString#  :: Addr# -> (Char  -> a -> a) -> a -> a 
+unpackFoldrCString# :: Addr# -> (Char  -> a -> a) -> a -> a 
 unpackFoldrCString# addr f z 
   = unpack 0#
   where
@@ -657,11 +687,32 @@ unpackFoldrCString# addr f z
       where
 	ch = indexCharOffAddr# addr nh
 
-unpackNBytes#      :: Addr# -> Int#   -> [Char]
-  -- This one is called by the compiler to unpack literal 
-  -- strings with NULs in them; rare. It's strict!
-  -- We don't try to do list deforestation for this one
+unpackCStringUtf8# :: Addr# -> [Char]
+unpackCStringUtf8# addr 
+  = unpack 0#
+  where
+    unpack nh
+      | ch `eqChar#` '\0'#   = []
+      | ch `leChar#` '\x7F'# = C# ch : unpack (nh +# 1#)
+      | ch `leChar#` '\xDF'# =
+          C# (chr# ((ord# ch                                  -# 0xC0#) `iShiftL#`  6# +#
+                    (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#))) :
+          unpack (nh +# 2#)
+      | ch `leChar#` '\xEF'# =
+          C# (chr# ((ord# ch                                  -# 0xE0#) `iShiftL#` 12# +#
+                    (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `iShiftL#`  6# +#
+                    (ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#))) :
+          unpack (nh +# 3#)
+      | otherwise            =
+          C# (chr# ((ord# ch                                  -# 0xF0#) `iShiftL#` 18# +#
+                    (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `iShiftL#` 12# +#
+                    (ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#) `iShiftL#`  6# +#
+                    (ord# (indexCharOffAddr# addr (nh +# 3#)) -# 0x80#))) :
+          unpack (nh +# 4#)
+      where
+	ch = indexCharOffAddr# addr nh
 
+unpackNBytes# :: Addr# -> Int# -> [Char]
 unpackNBytes# _addr 0#   = []
 unpackNBytes#  addr len# = unpack [] (len# -# 1#)
     where
@@ -680,5 +731,4 @@ unpackNBytes#  addr len# = unpack [] (len# -# 1#)
 -- 	unpackFoldr "foo" c (unpackFoldr "baz" c n)  =  unpackFoldr "foobaz" c n
 
   #-}
-
 \end{code}