[project @ 1997-03-14 05:27:40 by sof]
authorsof <unknown>
Fri, 14 Mar 1997 05:27:50 +0000 (05:27 +0000)
committersof <unknown>
Fri, 14 Mar 1997 05:27:50 +0000 (05:27 +0000)
OGI changes through 130397

ghc/lib/ghc/ArrBase.lhs
ghc/lib/ghc/ConcBase.lhs
ghc/lib/ghc/GHC.hi-boot
ghc/lib/ghc/GHCerr.lhs
ghc/lib/ghc/IOBase.lhs
ghc/lib/ghc/IOHandle.lhs
ghc/lib/ghc/Main.hi-boot
ghc/lib/ghc/PrelBase.lhs
ghc/lib/ghc/PrelNum.lhs
ghc/lib/ghc/PrelRead.lhs
ghc/lib/ghc/STBase.lhs

index c46aef5..0440cf0 100644 (file)
@@ -1,13 +1,15 @@
 %
 % (c) The AQUA Project, Glasgow University, 1994-1996
 %
 %
 % (c) The AQUA Project, Glasgow University, 1994-1996
 %
-
 \section[ArrBase]{Module @ArrBase@}
 
 \section[ArrBase]{Module @ArrBase@}
 
+Array implementation, @ArrBase@ exports the basic array
+types and operations.
+
 \begin{code}
 {-# OPTIONS -fno-implicit-prelude #-}
 
 \begin{code}
 {-# OPTIONS -fno-implicit-prelude #-}
 
-module  ArrBase where
+module ArrBase where
 
 import {-# SOURCE #-}  IOBase  ( error )
 import Ix
 
 import {-# SOURCE #-}  IOBase  ( error )
 import Ix
@@ -52,6 +54,9 @@ data Ix ix => Array ix elt            = Array            (ix,ix) (Array# elt)
 data Ix ix => ByteArray ix             = ByteArray        (ix,ix) ByteArray#
 data Ix ix => MutableArray     s ix elt = MutableArray     (ix,ix) (MutableArray# s elt)
 data Ix ix => MutableByteArray s ix     = MutableByteArray (ix,ix) (MutableByteArray# s)
 data Ix ix => ByteArray ix             = ByteArray        (ix,ix) ByteArray#
 data Ix ix => MutableArray     s ix elt = MutableArray     (ix,ix) (MutableArray# s elt)
 data Ix ix => MutableByteArray s ix     = MutableByteArray (ix,ix) (MutableByteArray# s)
+
+-- A one-element mutable array:
+type MutableVar s a = MutableArray s Int a
 \end{code}
 
 
 \end{code}
 
 
@@ -93,10 +98,10 @@ arrEleBottom = error "(Array.!): undefined array element"
 
 fill_it_in :: Ix ix => MutableArray s ix elt -> [(ix, elt)] -> ST s ()
 fill_it_in arr lst
 
 fill_it_in :: Ix ix => MutableArray s ix elt -> [(ix, elt)] -> ST s ()
 fill_it_in arr lst
-  = foldr fill_one_in (returnStrictlyST ()) lst
+  = foldr fill_one_in (returnST ()) lst
   where  -- **** STRICT **** (but that's OK...)
     fill_one_in (i, v) rst
   where  -- **** STRICT **** (but that's OK...)
     fill_one_in (i, v) rst
-      = writeArray arr i v `seqStrictlyST` rst
+      = writeArray arr i v `seqST` rst
 
 -----------------------------------------------------------------------
 -- these also go better with magic: (//), accum, accumArray
 
 -----------------------------------------------------------------------
 -- these also go better with magic: (//), accum, accumArray
@@ -104,9 +109,9 @@ fill_it_in arr lst
 old_array // ivs
   = runST (
        -- copy the old array:
 old_array // ivs
   = runST (
        -- copy the old array:
-       thawArray old_array                 `thenStrictlyST` \ arr ->   
+       thawArray old_array                 `thenST` \ arr ->   
        -- now write the new elements into the new array:
        -- now write the new elements into the new array:
-       fill_it_in arr ivs                  `seqStrictlyST`
+       fill_it_in arr ivs                  `seqST`
        freezeArray arr
     )
   where
        freezeArray arr
     )
   where
@@ -116,17 +121,17 @@ zap_with_f :: Ix ix => (elt -> elt2 -> elt) -> MutableArray s ix elt -> [(ix,elt
 -- zap_with_f: reads an elem out first, then uses "f" on that and the new value
 
 zap_with_f f arr lst
 -- zap_with_f: reads an elem out first, then uses "f" on that and the new value
 
 zap_with_f f arr lst
-  = foldr zap_one (returnStrictlyST ()) lst
+  = foldr zap_one (returnST ()) lst
   where
     zap_one (i, new_v) rst
   where
     zap_one (i, new_v) rst
-      = readArray  arr i                `thenStrictlyST`  \ old_v ->
-       writeArray arr i (f old_v new_v) `seqStrictlyST`
+      = readArray  arr i                `thenST`  \ old_v ->
+       writeArray arr i (f old_v new_v) `seqST`
        rst
 
 accum f old_array ivs
   = runST (
        -- copy the old array:
        rst
 
 accum f old_array ivs
   = runST (
        -- copy the old array:
-       thawArray old_array                 `thenStrictlyST` \ arr ->   
+       thawArray old_array                 `thenST` \ arr ->   
 
        -- now zap the elements in question with "f":
        zap_with_f f arr ivs            >>
 
        -- now zap the elements in question with "f":
        zap_with_f f arr ivs            >>
@@ -448,7 +453,7 @@ freezeArray (MutableArray ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#) ->
        copy cur# end# from# to# s#
          | cur# ==# end#
            = StateAndMutableArray# s# to#
        copy cur# end# from# to# s#
          | cur# ==# end#
            = StateAndMutableArray# s# to#
-         | True
+         | otherwise
            = case readArray#  from# cur#     s#  of { StateAndPtr# s1# ele ->
              case writeArray# to#   cur# ele s1# of { s2# ->
              copy (cur# +# 1#) end# from# to# s2#
            = case readArray#  from# cur#     s#  of { StateAndPtr# s1# ele ->
              case writeArray# to#   cur# ele s1# of { s2# ->
              copy (cur# +# 1#) end# from# to# s2#
@@ -481,7 +486,7 @@ freezeCharArray (MutableByteArray ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#)
        copy cur# end# from# to# s#
          | cur# ==# end#
            = StateAndMutableByteArray# s# to#
        copy cur# end# from# to# s#
          | cur# ==# end#
            = StateAndMutableByteArray# s# to#
-         | True
+         | otherwise
            = case (readCharArray#  from# cur#     s#)  of { StateAndChar# s1# ele ->
              case (writeCharArray# to#   cur# ele s1#) of { s2# ->
              copy (cur# +# 1#) end# from# to# s2#
            = case (readCharArray#  from# cur#     s#)  of { StateAndChar# s1# ele ->
              case (writeCharArray# to#   cur# ele s1#) of { s2# ->
              copy (cur# +# 1#) end# from# to# s2#
@@ -514,7 +519,7 @@ freezeIntArray (MutableByteArray ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#) -
        copy cur# end# from# to# s#
          | cur# ==# end#
            = StateAndMutableByteArray# s# to#
        copy cur# end# from# to# s#
          | cur# ==# end#
            = StateAndMutableByteArray# s# to#
-         | True
+         | otherwise
            = case (readIntArray#  from# cur#     s#)  of { StateAndInt# s1# ele ->
              case (writeIntArray# to#   cur# ele s1#) of { s2# ->
              copy (cur# +# 1#) end# from# to# s2#
            = case (readIntArray#  from# cur#     s#)  of { StateAndInt# s1# ele ->
              case (writeIntArray# to#   cur# ele s1#) of { s2# ->
              copy (cur# +# 1#) end# from# to# s2#
@@ -547,7 +552,7 @@ freezeAddrArray (MutableByteArray ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#)
        copy cur# end# from# to# s#
          | cur# ==# end#
            = StateAndMutableByteArray# s# to#
        copy cur# end# from# to# s#
          | cur# ==# end#
            = StateAndMutableByteArray# s# to#
-         | True
+         | otherwise
            = case (readAddrArray#  from# cur#     s#)  of { StateAndAddr# s1# ele ->
              case (writeAddrArray# to#   cur# ele s1#) of { s2# ->
              copy (cur# +# 1#) end# from# to# s2#
            = case (readAddrArray#  from# cur#     s#)  of { StateAndAddr# s1# ele ->
              case (writeAddrArray# to#   cur# ele s1#) of { s2# ->
              copy (cur# +# 1#) end# from# to# s2#
@@ -580,7 +585,7 @@ freezeFloatArray (MutableByteArray ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#)
        copy cur# end# from# to# s#
          | cur# ==# end#
            = StateAndMutableByteArray# s# to#
        copy cur# end# from# to# s#
          | cur# ==# end#
            = StateAndMutableByteArray# s# to#
-         | True
+         | otherwise
            = case (readFloatArray#  from# cur#     s#)  of { StateAndFloat# s1# ele ->
              case (writeFloatArray# to#   cur# ele s1#) of { s2# ->
              copy (cur# +# 1#) end# from# to# s2#
            = case (readFloatArray#  from# cur#     s#)  of { StateAndFloat# s1# ele ->
              case (writeFloatArray# to#   cur# ele s1#) of { s2# ->
              copy (cur# +# 1#) end# from# to# s2#
@@ -613,7 +618,7 @@ freezeDoubleArray (MutableByteArray ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#
        copy cur# end# from# to# s#
          | cur# ==# end#
            = StateAndMutableByteArray# s# to#
        copy cur# end# from# to# s#
          | cur# ==# end#
            = StateAndMutableByteArray# s# to#
-         | True
+         | otherwise
            = case (readDoubleArray#  from# cur#     s#)  of { StateAndDouble# s1# ele ->
              case (writeDoubleArray# to#   cur# ele s1#) of { s2# ->
              copy (cur# +# 1#) end# from# to# s2#
            = case (readDoubleArray#  from# cur#     s#)  of { StateAndDouble# s1# ele ->
              case (writeDoubleArray# to#   cur# ele s1#) of { s2# ->
              copy (cur# +# 1#) end# from# to# s2#
@@ -670,7 +675,7 @@ thawArray (Array ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#) ->
        copy cur# end# from# to# s#
          | cur# ==# end#
            = StateAndMutableArray# s# to#
        copy cur# end# from# to# s#
          | cur# ==# end#
            = StateAndMutableArray# s# to#
-         | True
+         | otherwise
            = case indexArray#  from# cur#       of { Lift ele ->
              case writeArray# to#   cur# ele s# of { s1# ->
              copy (cur# +# 1#) end# from# to# s1#
            = case indexArray#  from# cur#       of { Lift ele ->
              case writeArray# to#   cur# ele s# of { s1# ->
              copy (cur# +# 1#) end# from# to# s1#
index 3a53271..8dd4097 100644 (file)
@@ -7,6 +7,7 @@
 Basic concurrency stuff
 
 \begin{code}
 Basic concurrency stuff
 
 \begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
 module ConcBase(
                -- Forking and suchlike
        ST,     forkST,
 module ConcBase(
                -- Forking and suchlike
        ST,     forkST,
@@ -19,14 +20,14 @@ module ConcBase(
        MVar, newMVar, newEmptyMVar, takeMVar, putMVar, readMVar, swapMVar
     ) where
 
        MVar, newMVar, newEmptyMVar, takeMVar, putMVar, readMVar, swapMVar
     ) where
 
-import Prelude
+import PrelBase
 import STBase  ( PrimIO(..), ST(..), State(..), StateAndPtr#(..) )
 import STBase  ( PrimIO(..), ST(..), State(..), StateAndPtr#(..) )
-import IOBase  ( IO(..) )
+import IOBase  ( IO(..), MVar(..) )
 import GHCerr  ( parError )
 import PrelBase        ( Int(..) )
 import GHC     ( fork#, delay#, waitRead#, waitWrite#,
                  SynchVar#, newSynchVar#, takeMVar#, putMVar#,
 import GHCerr  ( parError )
 import PrelBase        ( Int(..) )
 import GHC     ( fork#, delay#, waitRead#, waitWrite#,
                  SynchVar#, newSynchVar#, takeMVar#, putMVar#,
-                 State#, RealWorld
+                 State#, RealWorld, par#
                )
 
 infixr 0 `par`, `fork`
                )
 
 infixr 0 `par`, `fork`
@@ -90,7 +91,7 @@ are allowed, but there must be at least one read between any two
 writes.
 
 \begin{code}
 writes.
 
 \begin{code}
-data MVar a = MVar (SynchVar# RealWorld a)
+--Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a)
 
 newEmptyMVar  :: IO (MVar a)
 
 
 newEmptyMVar  :: IO (MVar a)
 
index 040802b..884bba0 100644 (file)
@@ -11,7 +11,7 @@ GHC
   ->
 
   Void
   ->
 
   Void
-  void
+-- void CAF is defined in PrelBase
 
 -- I/O primitives
   RealWorld
 
 -- I/O primitives
   RealWorld
@@ -20,7 +20,13 @@ GHC
 
   fork#
   delay# 
 
   fork#
   delay# 
-  
+  seq#
+  par#
+  parGlobal#
+  parLocal#
+  parAt#
+  parAtForNow#
+
   SynchVar#
   newSynchVar#
   takeMVar#
   SynchVar#
   newSynchVar#
   takeMVar#
@@ -162,6 +168,7 @@ GHC
   MutableByteArray#
   
   sameMutableArray#
   MutableByteArray#
   
   sameMutableArray#
+  sameMutableByteArray#
   
   newArray#
   newCharArray#
   
   newArray#
   newCharArray#
@@ -177,12 +184,12 @@ GHC
   indexDoubleArray#
   indexAddrArray#
   
   indexDoubleArray#
   indexAddrArray#
   
-  indexOffAddr#
-  indexCharOffAddr#
-  indexIntOffAddr#
-  indexFloatOffAddr#
-  indexDoubleOffAddr#
-  indexAddrOffAddr#
+--  indexOffAddr#
+indexCharOffAddr#
+indexIntOffAddr#
+indexFloatOffAddr#
+indexDoubleOffAddr#
+indexAddrOffAddr#
   
   writeArray#
   writeCharArray#
   
   writeArray#
   writeCharArray#
index c0d508d..8841461 100644 (file)
@@ -12,9 +12,12 @@ We cannot define these functions in a module where they might be used
 with what the typechecker figures out.
 
 \begin{code}
 with what the typechecker figures out.
 
 \begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
 module GHCerr where
 
 module GHCerr where
 
-import Prelude
+--import Prelude
+import PrelBase
+import PrelList ( span )
 import IOBase
 
 ---------------------------------------------------------------
 import IOBase
 
 ---------------------------------------------------------------
@@ -27,13 +30,20 @@ augment = error "GHCbase.augment"
 --{-# GENERATE_SPECS build a #-}
 --build                :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a]
 --build g      = g (:) []
 --{-# GENERATE_SPECS build a #-}
 --build                :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a]
 --build g      = g (:) []
+\end{code}
 
 
 
 
----------------------------------------------------------------
--- Used for compiler-generated error message;
--- encoding saves bytes of string junk.
+Used for compiler-generated error message;
+encoding saves bytes of string junk.
 
 
+\begin{code}
 absentErr, parError :: a
 absentErr, parError :: a
+
+absentErr = error "Oops! The program has entered an `absent' argument!\n"
+parError  = error "Oops! Entered GHCerr.parError (a GHC bug -- please report it!)\n"
+\end{code}
+
+\begin{code}
 irrefutPatError
  , noDefaultMethodError
  , noExplicitMethodError
 irrefutPatError
  , noDefaultMethodError
  , noExplicitMethodError
@@ -42,31 +52,43 @@ irrefutPatError
  , recConError
  , recUpdError :: String -> a
 
  , recConError
  , recUpdError :: String -> a
 
-absentErr = error "Oops! The program has entered an `absent' argument!\n"
-parError  = error "Oops! Entered GHCerr.parError (a GHC bug -- please report it!)\n"
-
 noDefaultMethodError     s = error ("noDefaultMethodError:"++s)
 noExplicitMethodError    s = error ("No default method for class operation "++s)
 noDefaultMethodError     s = error ("noDefaultMethodError:"++s)
 noExplicitMethodError    s = error ("No default method for class operation "++s)
+irrefutPatError                 s = error (untangle s "Irrefutable pattern failed for pattern")
+nonExhaustiveGuardsError s = error (untangle s "Non-exhaustive guards in")
+patError                s = error (untangle s "Non-exhaustive patterns in")
+recConError             s = error (untangle s "Missing field in record construction:")
+recUpdError             s = error (untangle s "Record to doesn't contain field(s) to be updated")
+\end{code}
+
 
 
-irrefutPatError s          = patError__ (untangle s "irrefutable pattern")
-nonExhaustiveGuardsError s  = patError__ (untangle s "non-exhaustive guards")
-patError s                 = patError__ (untangle s "pattern-matching")
+(untangle coded message) expects "coded" to be of the form 
 
 
-patError__ = error__ (\ x -> _ccall_ PatErrorHdrHook x)
+       "location|details"
 
 
-recConError s = error (untangle s "record constructor")
-recUpdError s = error (untangle s "record update")
+It prints
 
 
-untangle coded in_str
-  =  "In "     ++ in_str
-  ++ (if null msg then "" else (": " ++ msg))
-  ++ "; at "   ++ file
-  ++ ", line " ++ line
+       location message details
+
+\begin{code}
+untangle coded message
+  =  location
+  ++ ": " 
+  ++ message
+  ++ details
   ++ "\n"
   where
   ++ "\n"
   where
-    (file,line,msg)
-      = case (span not_bar coded) of { (f, (_:rest)) ->
-       case (span not_bar rest)  of { (l, (_:m)) ->
-       (f,l,m) }}
+    (location, details)
+      = case (span not_bar coded) of { (location, rest) ->
+       case rest of
+         ('|':details) -> (location, ' ' : details)
+         _             -> (location, "")
+       }
     not_bar c = c /= '|'
 \end{code}
     not_bar c = c /= '|'
 \end{code}
+
+-- This local variant of "error" calls PatErrorHdrHook instead of ErrorHdrHook,
+-- but the former does exactly the same as the latter, so I nuked it.
+--             SLPJ Jan 97
+-- patError__ = error__ (\ x -> _ccall_ PatErrorHdrHook x)
+
index 8214bd3..4a952f7 100644 (file)
@@ -19,7 +19,9 @@ import PrelTup
 import Foreign
 import PackedString    ( unpackCString )
 import PrelBase
 import Foreign
 import PackedString    ( unpackCString )
 import PrelBase
+import PrelRead
 import GHC
 import GHC
+import ArrBase ( ByteArray(..), MutableVar(..) )
 
 infixr 1 `thenIO_Prim`
 \end{code}
 
 infixr 1 `thenIO_Prim`
 \end{code}
@@ -37,12 +39,9 @@ instance  Functor IO where
    map f x = x >>= (return . f)
 
 instance  Monad IO  where
    map f x = x >>= (return . f)
 
 instance  Monad IO  where
-{-     No inlining for now... until we can inline some of the
-       imports, like $, these functions are pretty big. 
     {-# INLINE return #-}
     {-# INLINE (>>)   #-}
     {-# INLINE (>>=)  #-}
     {-# INLINE return #-}
     {-# INLINE (>>)   #-}
     {-# INLINE (>>=)  #-}
--}
     m >> k      =  m >>= \ _ -> k
     return x   = IO $ ST $ \ s@(S# _) -> (Right x, s)
 
     m >> k      =  m >>= \ _ -> k
     return x   = IO $ ST $ \ s@(S# _) -> (Right x, s)
 
@@ -69,7 +68,7 @@ fail            :: IOError -> IO a
 fail err       =  IO $ ST $ \ s -> (Left err, s)
 
 userError       :: String  -> IOError
 fail err       =  IO $ ST $ \ s -> (Left err, s)
 
 userError       :: String  -> IOError
-userError str  =  UserError str
+userError str  =  IOError Nothing UserError str
 
 catch           :: IO a    -> (IOError -> IO a) -> IO a 
 catch (IO (ST m)) k  = IO $ ST $ \ s ->
 
 catch           :: IO a    -> (IOError -> IO a) -> IO a 
 catch (IO (ST m)) k  = IO $ ST $ \ s ->
@@ -222,107 +221,84 @@ fputs stream (c : cs)
 %*                                                     *
 %*********************************************************
 
 %*                                                     *
 %*********************************************************
 
+A value @IOError@ encode errors occurred in the @IO@ monad.
+An @IOError@ records a more specific error type, a descriptive
+string and maybe the handle that was used when the error was
+flagged.
+
 \begin{code}
 \begin{code}
-data IOError
-  = AlreadyExists              String
-  | HardwareFault              String
-  | IllegalOperation           String
-  | InappropriateType          String
-  | Interrupted                        String
-  | InvalidArgument            String
-  | NoSuchThing                        String
-  | OtherError                 String
-  | PermissionDenied           String
-  | ProtocolError              String
-  | ResourceBusy               String
-  | ResourceExhausted          String
-  | ResourceVanished           String
-  | SystemError                        String
-  | TimeExpired                        String
-  | UnsatisfiedConstraints     String
-  | UnsupportedOperation       String
-  | UserError                  String
-  | EOF
+data IOError 
+ = IOError 
+     (Maybe Handle)  -- the handle used by the action flagging the
+                    -- the error.
+     IOErrorType     -- what it was.
+     String          -- error type specific information.
 
 instance Eq IOError where
 
 instance Eq IOError where
-    -- I don't know what the (pointless) idea is here,
-    -- presumably just compare them by their tags (WDP)
-    a == b = tag a == tag b
-      where
-       tag (AlreadyExists _)           = (1::Int)
-       tag (HardwareFault _)           = 2
-       tag (IllegalOperation _)        = 3
-       tag (InappropriateType _)       = 4
-       tag (Interrupted _)             = 5
-       tag (InvalidArgument _)         = 6
-       tag (NoSuchThing _)             = 7
-       tag (OtherError _)              = 8
-       tag (PermissionDenied _)        = 9
-       tag (ProtocolError _)           = 10
-       tag (ResourceBusy _)            = 11
-       tag (ResourceExhausted _)       = 12
-       tag (ResourceVanished _)        = 13
-       tag (SystemError _)             = 14
-       tag (TimeExpired _)             = 15
-       tag (UnsatisfiedConstraints _)  = 16
-       tag (UnsupportedOperation _)    = 17
-       tag (UserError _)               = 18
-       tag EOF                         = 19
+  (IOError h1 e1 str1) == (IOError h2 e2 str2) = 
+    e1==e2 && str1==str2 && h1==h2
+
+data IOErrorType
+  = AlreadyExists        | HardwareFault
+  | IllegalOperation     | InappropriateType
+  | Interrupted          | InvalidArgument
+  | NoSuchThing          | OtherError
+  | PermissionDenied     | ProtocolError
+  | ResourceBusy         | ResourceExhausted
+  | ResourceVanished     | SystemError
+  | TimeExpired          | UnsatisfiedConstraints
+  | UnsupportedOperation | UserError
+  | EOF
+  deriving (Eq, Show)
+
 \end{code}
 
 \end{code}
 
-Predicates on IOError; almost no effort made on these so far...
+Predicates on IOError; little effort made on these so far...
 
 \begin{code}
 
 
 \begin{code}
 
-isAlreadyExistsError (AlreadyExists _) = True
-isAlreadyExistsError _                = False
+isAlreadyExistsError (IOError _ AlreadyExists _) = True
+isAlreadyExistsError _                          = False
+
+isAlreadyInUseError (IOError _ ResourceBusy _) = True
+isAlreadyInUseError _                         = False
 
 
-isAlreadyInUseError (ResourceBusy _) = True
-isAlreadyInUseError _               = False
+isFullError (IOError _ ResourceExhausted _) = True
+isFullError _                              = False
 
 
-isFullError (ResourceExhausted _) = True
-isFullError _                    = False
+isEOFError (IOError _ EOF _) = True
+isEOFError _                 = True
 
 
-isEOFError EOF = True
-isEOFError _   = True
+isIllegalOperation (IOError _ IllegalOperation _) = True
+isIllegalOperation _                             = False
 
 
-isIllegalOperation (IllegalOperation _) = True
-isIllegalOperation _                   = False
+isPermissionError (IOError _ PermissionDenied _) = True
+isPermissionError _                             = False
 
 
-isPermissionError (PermissionDenied _) = True
-isPermissionError _                    = False
+isDoesNotExistError (IOError _ NoSuchThing _) = True
+isDoesNotExistError _                         = False
 
 
-isUserError (UserError s) = Just s
-isUserError _            = Nothing
+isUserError (IOError _ UserError s) = Just s
+isUserError _                      = Nothing
 \end{code}
 
 Showing @IOError@s
 
 \begin{code}
 instance Show IOError where
 \end{code}
 
 Showing @IOError@s
 
 \begin{code}
 instance Show IOError where
-    showsPrec p (AlreadyExists s)      = show2 "AlreadyExists: "       s
-    showsPrec p (HardwareFault s)      = show2 "HardwareFault: "       s
-    showsPrec p (IllegalOperation s)   = show2 "IllegalOperation: "    s
-    showsPrec p (InappropriateType s)  = show2 "InappropriateType: "   s
-    showsPrec p (Interrupted s)                = show2 "Interrupted: "         s
-    showsPrec p (InvalidArgument s)    = show2 "InvalidArgument: "     s
-    showsPrec p (NoSuchThing s)                = show2 "NoSuchThing: "         s
-    showsPrec p (OtherError s)         = show2 "OtherError: "          s
-    showsPrec p (PermissionDenied s)   = show2 "PermissionDenied: "    s
-    showsPrec p (ProtocolError s)      = show2 "ProtocolError: "       s
-    showsPrec p (ResourceBusy s)       = show2 "ResourceBusy: "        s
-    showsPrec p (ResourceExhausted s)  = show2 "ResourceExhausted: "   s
-    showsPrec p (ResourceVanished s)   = show2 "ResourceVanished: "    s
-    showsPrec p (SystemError s)                = show2 "SystemError: "         s
-    showsPrec p (TimeExpired s)                = show2 "TimeExpired: "         s
-    showsPrec p (UnsatisfiedConstraints s) = show2 "UnsatisfiedConstraints: " s
-    showsPrec p (UnsupportedOperation s)= show2 "UnsupportedOperation: " s
-    showsPrec p (UserError s)          = showString s
-    showsPrec p EOF                    = showString "EOF"
-
-show2 x y = showString x . showString y
+    showsPrec p (IOError _ UserError s) rs =
+      showString s rs
+    showsPrec p (IOError _ EOF _) rs =
+      showsPrec p EOF rs
+    showsPrec p (IOError _ iot s) rs =
+      showsPrec p 
+                iot 
+                (case s of { 
+                 "" -> rs; 
+                 _ -> showString ": " $ 
+                      showString s rs})
 
 
-{-
+\end{code}
 
 The @String@ part of an @IOError@ is platform-dependent.  However, to
 provide a uniform mechanism for distinguishing among errors within
 
 The @String@ part of an @IOError@ is platform-dependent.  However, to
 provide a uniform mechanism for distinguishing among errors within
@@ -331,42 +307,155 @@ the exact strings to be used for particular errors.  For errors not
 explicitly mentioned in the standard, any descriptive string may be
 used.
 
 explicitly mentioned in the standard, any descriptive string may be
 used.
 
-  SOF 4/96 - added argument to indicate function that flagged error
--}
-constructErrorAndFail :: String -> IO a
-constructError       :: String -> PrimIO IOError
+\begin{change}
+SOF & 4/96 & added argument to indicate function that flagged error
+\end{change}
+% Hmm..does these envs work?!...SOF
 
 
+\begin{code}
+constructErrorAndFail :: String -> IO a
 constructErrorAndFail call_site
   = stToIO (constructError call_site) >>= \ io_error ->
     fail io_error
 
 constructErrorAndFail call_site
   = stToIO (constructError call_site) >>= \ io_error ->
     fail io_error
 
-constructError call_site
-  = _casm_ ``%r = ghc_errtype;''    >>= \ (I# errtype#) ->
-    _casm_ ``%r = ghc_errstr;''            >>= \ str ->
-    let
-       msg = call_site ++ ':' : ' ' : unpackCString str
-    in
-    return (case errtype# of
-       ERR_ALREADYEXISTS#              -> AlreadyExists msg
-       ERR_HARDWAREFAULT#              -> HardwareFault msg
-       ERR_ILLEGALOPERATION#           -> IllegalOperation msg
-       ERR_INAPPROPRIATETYPE#          -> InappropriateType msg
-       ERR_INTERRUPTED#                -> Interrupted msg
-       ERR_INVALIDARGUMENT#            -> InvalidArgument msg
-       ERR_NOSUCHTHING#                -> NoSuchThing msg
-       ERR_OTHERERROR#                 -> OtherError msg
-       ERR_PERMISSIONDENIED#           -> PermissionDenied msg
-       ERR_PROTOCOLERROR#              -> ProtocolError msg
-       ERR_RESOURCEBUSY#               -> ResourceBusy msg
-       ERR_RESOURCEEXHAUSTED#          -> ResourceExhausted msg
-       ERR_RESOURCEVANISHED#           -> ResourceVanished msg
-       ERR_SYSTEMERROR#                -> SystemError msg
-       ERR_TIMEEXPIRED#                -> TimeExpired msg
-       ERR_UNSATISFIEDCONSTRAINTS#     -> UnsatisfiedConstraints msg
-       ERR_UNSUPPORTEDOPERATION#       -> UnsupportedOperation msg
-       ERR_EOF#                        -> EOF
-       _                               -> OtherError "bad error construct"
-    )
 \end{code}
 
 \end{code}
 
+This doesn't seem to be documented/spelled out anywhere,
+so here goes: (SOF)
+
+The implementation of the IO prelude uses various C stubs
+to do the actual interaction with the OS. The bandwidth
+\tr{C<->Haskell} is somewhat limited, so the general strategy
+for flaggging any errors (apart from possibly using the
+return code of the external call), is to set the @ghc_errtype@
+to a value that is one of the \tr{#define}s in @includes/error.h@.
+@ghc_errstr@ holds a character string providing error-specific
+information.
+
+\begin{code}
+constructError       :: String -> PrimIO IOError
+constructError call_site =
+ _casm_ ``%r = ghc_errtype;''    >>= \ (I# errtype#) ->
+ _casm_ ``%r = ghc_errstr;''       >>= \ str ->
+ let
+  iot =
+   case errtype# of
+     ERR_ALREADYEXISTS#                 -> AlreadyExists
+     ERR_HARDWAREFAULT#                 -> HardwareFault
+     ERR_ILLEGALOPERATION#      -> IllegalOperation
+     ERR_INAPPROPRIATETYPE#     -> InappropriateType
+     ERR_INTERRUPTED#           -> Interrupted
+     ERR_INVALIDARGUMENT#       -> InvalidArgument
+     ERR_NOSUCHTHING#           -> NoSuchThing
+     ERR_OTHERERROR#            -> OtherError
+     ERR_PERMISSIONDENIED#      -> PermissionDenied
+     ERR_PROTOCOLERROR#                 -> ProtocolError
+     ERR_RESOURCEBUSY#          -> ResourceBusy
+     ERR_RESOURCEEXHAUSTED#     -> ResourceExhausted
+     ERR_RESOURCEVANISHED#      -> ResourceVanished
+     ERR_SYSTEMERROR#           -> SystemError
+     ERR_TIMEEXPIRED#           -> TimeExpired
+     ERR_UNSATISFIEDCONSTRAINTS# -> UnsatisfiedConstraints
+     ERR_UNSUPPORTEDOPERATION#   -> UnsupportedOperation
+     ERR_EOF#                   -> EOF
+     _                          -> OtherError
+
+  msg = 
+   case iot of
+     EOF -> ""
+     OtherError -> "bad error construct"
+     _   -> call_site ++ ':' : ' ' : unpackCString str
+ in
+ return (IOError Nothing iot msg)
+\end{code}
 
 
+%*********************************************************
+%*                                                     *
+\subsection{Types @Handle@, @Handle__@}
+%*                                                     *
+%*********************************************************
+
+The type for @Handle@ is defined rather than in @IOHandle@
+module, as the @IOError@ type uses it..all operations over
+a handles reside in @IOHandle@.
+
+\begin{code}
+
+{-
+ Sigh, the MVar ops in ConcBase depend on IO, the IO
+ representation here depend on MVars for handles (when
+ compiling a concurrent way). Break the cycle by having
+ the definition of MVars go here:
+
+-}
+data MVar a = MVar (SynchVar# RealWorld a)
+
+#if defined(__CONCURRENT_HASKELL__)
+type Handle = MVar Handle__
+#else
+type Handle = MutableVar RealWorld Handle__
+#endif
+
+data Handle__
+  = ErrorHandle                IOError
+  | ClosedHandle
+  | SemiClosedHandle   ForeignObj (Addr, Int)
+  | ReadHandle         ForeignObj (Maybe BufferMode) Bool
+  | WriteHandle                ForeignObj (Maybe BufferMode) Bool
+  | AppendHandle       ForeignObj (Maybe BufferMode) Bool
+  | ReadWriteHandle    ForeignObj (Maybe BufferMode) Bool
+
+-- Standard Instances as defined by the Report..
+
+instance Eq Handle {-partain:????-}
+instance Show Handle where {showsPrec p h = showString "<<Handle>>"}
+
+\end{code}
+
+%*********************************************************
+%*                                                     *
+\subsection[BufferMode]{Buffering modes}
+%*                                                     *
+%*********************************************************
+
+Three kinds of buffering are supported: line-buffering, 
+block-buffering or no-buffering.  These modes have the following
+effects. For output, items are written out from the internal
+buffer according to the buffer mode:
+
+\begin{itemize}
+\item[line-buffering]  the entire output buffer is written
+out whenever a newline is output, the output buffer overflows, 
+a flush is issued, or the handle is closed.
+
+\item[block-buffering] the entire output buffer is written out whenever 
+it overflows, a flush is issued, or the handle
+is closed.
+
+\item[no-buffering] output is written immediately, and never stored
+in the output buffer.
+\end{itemize}
+
+The output buffer is emptied as soon as it has been written out.
+
+Similarly, input occurs according to the buffer mode for handle {\em hdl}.
+\begin{itemize}
+\item[line-buffering] when the input buffer for {\em hdl} is not empty,
+the next item is obtained from the buffer;
+otherwise, when the input buffer is empty,
+characters up to and including the next newline
+character are read into the buffer.  No characters
+are available until the newline character is
+available.
+\item[block-buffering] when the input buffer for {\em hdl} becomes empty,
+the next block of data is read into this buffer.
+\item[no-buffering] the next input item is read and returned.
+\end{itemize}
+For most implementations, physical files will normally be block-buffered 
+and terminals will normally be line-buffered.
+
+\begin{code}
+data BufferMode  
+ = NoBuffering | LineBuffering | BlockBuffering (Maybe Int)
+   deriving (Eq, Ord, Read, Show)
+\end{code}
index 3e88c46..50e1300 100644 (file)
@@ -10,7 +10,7 @@ which are supported for them.
 \begin{code}
 #include "error.h"
 
 \begin{code}
 #include "error.h"
 
-{-# OPTIONS -fno-implicit-prelude #-}
+{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
 
 module IOHandle where
 
 
 module IOHandle where
 
@@ -23,7 +23,11 @@ import IOBase
 import PrelTup
 import PrelBase
 import GHC
 import PrelTup
 import PrelBase
 import GHC
-
+import Foreign  ( makeForeignObj )
+import PrelList (span)
+#if defined(__CONCURRENT_HASKELL__)
+import ConcBase
+#endif
 \end{code}
 
 
 \end{code}
 
 
@@ -33,43 +37,28 @@ import GHC
 %*                                                     *
 %*********************************************************
 
 %*                                                     *
 %*********************************************************
 
+The @Handle@ and @Handle__@ types are defined in @IOBase@.
+
 \begin{code}
 type FilePath = String
 
 \begin{code}
 type FilePath = String
 
-#if defined(__CONCURRENT_HASKELL__)
-type Handle = MVar Handle__
+{-# INLINE newHandle   #-}
+{-# INLINE readHandle  #-}
+{-# INLINE writeHandle #-}
+newHandle   :: Handle__ -> IO Handle
+readHandle  :: Handle   -> IO Handle__
+writeHandle :: Handle -> Handle__ -> IO ()
 
 
+#if defined(__CONCURRENT_HASKELL__)
 newHandle   = newMVar
 readHandle  = takeMVar
 writeHandle = putMVar
 newHandle   = newMVar
 readHandle  = takeMVar
 writeHandle = putMVar
-
-#else
-type Handle = MutableVar RealWorld Handle__
-
+#else 
 newHandle v     = stToIO (newVar   v)
 readHandle h    = stToIO (readVar  h)
 writeHandle h v = stToIO (writeVar h v)
 newHandle v     = stToIO (newVar   v)
 readHandle h    = stToIO (readVar  h)
 writeHandle h v = stToIO (writeVar h v)
+#endif
 
 
-#endif {- __CONCURRENT_HASKELL__ -}
-
-data Handle__
-  = ErrorHandle                IOError
-  | ClosedHandle
-  | SemiClosedHandle   Addr (Addr, Int)
-  | ReadHandle         Addr (Maybe BufferMode) Bool
-  | WriteHandle                Addr (Maybe BufferMode) Bool
-  | AppendHandle       Addr (Maybe BufferMode) Bool
-  | ReadWriteHandle    Addr (Maybe BufferMode) Bool
-
-instance Eq Handle{-partain:????-}
-
-{-# INLINE newHandle   #-}
-{-# INLINE readHandle  #-}
-{-# INLINE writeHandle #-}
-
-newHandle   :: Handle__ -> IO Handle
-readHandle  :: Handle   -> IO Handle__
-writeHandle :: Handle -> Handle__ -> IO ()
 \end{code}
 
 %*********************************************************
 \end{code}
 
 %*********************************************************
@@ -79,7 +68,7 @@ writeHandle :: Handle -> Handle__ -> IO ()
 %*********************************************************
 
 \begin{code}
 %*********************************************************
 
 \begin{code}
-filePtr :: Handle__ -> Addr
+filePtr :: Handle__ -> ForeignObj
 filePtr (SemiClosedHandle fp _)  = fp
 filePtr (ReadHandle fp _ _)     = fp
 filePtr (WriteHandle fp _ _)    = fp
 filePtr (SemiClosedHandle fp _)  = fp
 filePtr (ReadHandle fp _ _)     = fp
 filePtr (WriteHandle fp _ _)    = fp
@@ -127,7 +116,8 @@ stdin = unsafePerformPrimIO (
     _ccall_ getLock (``stdin''::Addr) 0                >>= \ rc ->
     (case rc of
        0 -> new_handle ClosedHandle
     _ccall_ getLock (``stdin''::Addr) 0                >>= \ rc ->
     (case rc of
        0 -> new_handle ClosedHandle
-       1 -> new_handle (ReadHandle ``stdin'' Nothing False)
+       1 -> makeForeignObj (``stdin''::Addr) (``&freeStdChannel''::Addr) >>= \ fp ->
+           new_handle (ReadHandle fp Nothing False)
        _ -> constructError "stdin"             >>= \ ioError -> 
             new_handle (ErrorHandle ioError)
     )                                          >>= \ handle ->
        _ -> constructError "stdin"             >>= \ ioError -> 
             new_handle (ErrorHandle ioError)
     )                                          >>= \ handle ->
@@ -140,7 +130,8 @@ stdout = unsafePerformPrimIO (
     _ccall_ getLock (``stdout''::Addr) 1       >>= \ rc ->
     (case rc of
        0 -> new_handle ClosedHandle
     _ccall_ getLock (``stdout''::Addr) 1       >>= \ rc ->
     (case rc of
        0 -> new_handle ClosedHandle
-       1 -> new_handle (WriteHandle ``stdout'' Nothing False)
+       1 -> makeForeignObj (``stdout''::Addr) (``&freeStdChannel''::Addr) >>= \ fp ->
+           new_handle (WriteHandle fp Nothing False)
        _ -> constructError "stdout"            >>= \ ioError -> 
             new_handle (ErrorHandle ioError)
     )                                          >>= \ handle ->
        _ -> constructError "stdout"            >>= \ ioError -> 
             new_handle (ErrorHandle ioError)
     )                                          >>= \ handle ->
@@ -153,7 +144,8 @@ stderr = unsafePerformPrimIO (
     _ccall_ getLock (``stderr''::Addr) 1       >>= \ rc ->
     (case rc of
        0 -> new_handle ClosedHandle
     _ccall_ getLock (``stderr''::Addr) 1       >>= \ rc ->
     (case rc of
        0 -> new_handle ClosedHandle
-       1 -> new_handle (WriteHandle ``stderr'' (Just NoBuffering) False)       
+       1 -> makeForeignObj (``stderr''::Addr) (``&freeStdChannel''::Addr) >>= \ fp ->
+            new_handle (WriteHandle fp (Just NoBuffering) False)       
        _ -> constructError "stderr"            >>= \ ioError -> 
             new_handle (ErrorHandle ioError)
     )                                          >>= \ handle ->
        _ -> constructError "stderr"            >>= \ ioError -> 
             new_handle (ErrorHandle ioError)
     )                                          >>= \ handle ->
@@ -176,18 +168,19 @@ data IOMode      =  ReadMode | WriteMode | AppendMode | ReadWriteMode
 openFile :: FilePath -> IOMode -> IO Handle
 
 openFile f m = 
 openFile :: FilePath -> IOMode -> IO Handle
 
 openFile f m = 
-    stToIO (_ccall_ openFile f m')                 >>= \ ptr ->
+    stToIO (_ccall_ openFile f m')                          >>= \ ptr ->
     if ptr /= ``NULL'' then
     if ptr /= ``NULL'' then
-        newHandle (htype ptr Nothing False)
+        stToIO (makeForeignObj ptr ((``&freeFile'')::Addr))  >>= \ fp ->
+        newHandle (htype fp Nothing False)
     else
     else
-       stToIO (constructError "openFile")          >>= \ ioError -> 
+       stToIO (constructError "openFile")          >>= \ ioError@(IOError hn iot msg) -> 
        let
            improved_error -- a HACK, I guess
        let
            improved_error -- a HACK, I guess
-             = case ioError of
-                 AlreadyExists    msg -> AlreadyExists    (msg ++ ": " ++ f)
-                 NoSuchThing      msg -> NoSuchThing      (msg ++ ": " ++ f)
-                 PermissionDenied msg -> PermissionDenied (msg ++ ": " ++ f)
-                 _                    -> ioError
+             = case iot of
+                 AlreadyExists    -> IOError hn AlreadyExists    (msg ++ ": " ++ f)
+                 NoSuchThing      -> IOError hn NoSuchThing      (msg ++ ": " ++ f)
+                 PermissionDenied -> IOError hn PermissionDenied (msg ++ ": " ++ f)
+                 _                -> ioError
        in
         fail improved_error
   where
        in
         fail improved_error
   where
@@ -238,20 +231,28 @@ hClose handle =
       ErrorHandle ioError ->
          fail ioError
       ClosedHandle -> 
       ErrorHandle ioError ->
          fail ioError
       ClosedHandle -> 
-         fail (IllegalOperation "handle is closed")
+         ioe_closedHandle handle
       SemiClosedHandle fp (buf,_) ->
           (if buf /= ``NULL'' then
              _ccall_ free buf
            else                            
               returnPrimIO ())                     `thenIO_Prim` \ () ->
       SemiClosedHandle fp (buf,_) ->
           (if buf /= ``NULL'' then
              _ccall_ free buf
            else                            
               returnPrimIO ())                     `thenIO_Prim` \ () ->
-          if fp /= ``NULL'' then
-              _ccall_ closeFile fp                 `thenIO_Prim` \ rc ->
-              if rc == 0 then 
+             _casm_ `` %r = (char *)%0; '' fp      `thenIO_Prim` \ fp_a ->
+              if fp_a /= (``NULL''::Addr) then -- Under what condition can this be NULL?
+                _ccall_ closeFile fp               `thenIO_Prim` \ rc ->
+                 {- We explicitly close a file object so that we can be told
+                    if there were any errors. Note that after @hClose@
+                    has been performed, the ForeignObj embedded in the Handle
+                     is still lying around in the heap, so care is taken
+                     to avoid closing the file object when the ForeignObj
+                    is finalised. (see freeFile()) -}
+                if rc == 0 then 
                  return ()
                  return ()
-              else
+                else
                  constructErrorAndFail "hClose"
                  constructErrorAndFail "hClose"
-          else                     
-              return ()
+
+              else                         
+                  return ()
       other -> 
           _ccall_ closeFile (filePtr other)        `thenIO_Prim` \ rc ->
           if rc == 0 then 
       other -> 
           _ccall_ closeFile (filePtr other)        `thenIO_Prim` \ rc ->
           if rc == 0 then 
@@ -285,10 +286,10 @@ hFileSize handle =
          fail ioError
       ClosedHandle -> 
          writeHandle handle htype                          >>
          fail ioError
       ClosedHandle -> 
          writeHandle handle htype                          >>
-          fail (IllegalOperation "handle is closed")
+         ioe_closedHandle handle
       SemiClosedHandle _ _ -> 
          writeHandle handle htype                          >>
       SemiClosedHandle _ _ -> 
          writeHandle handle htype                          >>
-          fail (IllegalOperation "handle is closed")
+         ioe_closedHandle handle
       other ->
           -- HACK!  We build a unique MP_INT of the right shape to hold
           -- a single unsigned word, and we let the C routine change the data bits
       other ->
           -- HACK!  We build a unique MP_INT of the right shape to hold
           -- a single unsigned word, and we let the C routine change the data bits
@@ -322,16 +323,16 @@ hIsEOF handle =
          fail ioError
       ClosedHandle -> 
          writeHandle handle htype                  >>
          fail ioError
       ClosedHandle -> 
          writeHandle handle htype                  >>
-          fail (IllegalOperation "handle is closed")
+         ioe_closedHandle handle
       SemiClosedHandle _ _ -> 
          writeHandle handle htype                  >>
       SemiClosedHandle _ _ -> 
          writeHandle handle htype                  >>
-          fail (IllegalOperation "handle is closed")
+         ioe_closedHandle handle
       WriteHandle _ _ _ -> 
          writeHandle handle htype                  >>
       WriteHandle _ _ _ -> 
          writeHandle handle htype                  >>
-          fail (IllegalOperation "handle is not open for reading")
+          fail (IOError (Just handle) IllegalOperation "handle is not open for reading")
       AppendHandle _ _ _ -> 
          writeHandle handle htype                  >>
       AppendHandle _ _ _ -> 
          writeHandle handle htype                  >>
-          fail (IllegalOperation "handle is not open for reading")
+          fail (IOError (Just handle) IllegalOperation "handle is not open for reading")
       other -> 
           _ccall_ fileEOF (filePtr other)          `thenIO_Prim` \ rc ->
          writeHandle handle (markHandle htype)     >>
       other -> 
           _ccall_ fileEOF (filePtr other)          `thenIO_Prim` \ rc ->
          writeHandle handle (markHandle htype)     >>
@@ -351,62 +352,26 @@ isEOF = hIsEOF stdin
 %*********************************************************
 
 Three kinds of buffering are supported: line-buffering, 
 %*********************************************************
 
 Three kinds of buffering are supported: line-buffering, 
-block-buffering or no-buffering.  These modes have the following effects.
-For output, items are written out from the internal buffer 
-according to the buffer mode:
-\begin{itemize}
-\item[line-buffering]  the entire output buffer is written
-out whenever a newline is output, the output buffer overflows, 
-a flush is issued, or the handle is closed.
-
-\item[block-buffering] the entire output buffer is written out whenever 
-it overflows, a flush is issued, or the handle
-is closed.
-
-\item[no-buffering] output is written immediately, and never stored
-in the output buffer.
-\end{itemize}
-
-The output buffer is emptied as soon as it has been written out.
-
-Similarly, input occurs according to the buffer mode for handle {\em hdl}.
-\begin{itemize}
-\item[line-buffering] when the input buffer for {\em hdl} is not empty,
-the next item is obtained from the buffer;
-otherwise, when the input buffer is empty,
-characters up to and including the next newline
-character are read into the buffer.  No characters
-are available until the newline character is
-available.
-\item[block-buffering] when the input buffer for {\em hdl} becomes empty,
-the next block of data is read into this buffer.
-\item[no-buffering] the next input item is read and returned.
-\end{itemize}
-For most implementations, physical files will normally be block-buffered 
-and terminals will normally be line-buffered.
-
-\begin{code}
-data BufferMode  =  NoBuffering | LineBuffering | BlockBuffering (Maybe Int)
-                    deriving (Eq, Ord, Read, Show)
-\end{code}
+block-buffering or no-buffering.  See @IOBase@ for definition
+and further explanation of what the type represent.
 
 
-Computation $hSetBuffering hdl mode$ sets the mode of buffering for
+Computation @hSetBuffering hdl mode@ sets the mode of buffering for
 handle {\em hdl} on subsequent reads and writes.
 
 \begin{itemize}
 \item
 handle {\em hdl} on subsequent reads and writes.
 
 \begin{itemize}
 \item
-If {\em mode} is $LineBuffering$, line-buffering should be
+If {\em mode} is @LineBuffering@, line-buffering should be
 enabled if possible.
 \item
 enabled if possible.
 \item
-If {\em mode} is $BlockBuffering$ {\em size}, then block-buffering
+If {\em mode} is @BlockBuffering@ {\em size}, then block-buffering
 should be enabled if possible.  The size of the buffer is {\em n} items
 should be enabled if possible.  The size of the buffer is {\em n} items
-if {\em size} is $Just${\em n} and is otherwise implementation-dependent.
+if {\em size} is @Just@~{\em n} and is otherwise implementation-dependent.
 \item
 \item
-If {\em mode} is $NoBuffering$, then buffering is disabled if possible.
+If {\em mode} is @NoBuffering@, then buffering is disabled if possible.
 \end{itemize}
 
 \end{itemize}
 
-If the buffer mode is changed from $BlockBuffering$ or $LineBuffering$
-to $NoBuffering$, then any items in the output buffer are written to
+If the buffer mode is changed from @BlockBuffering@ or @LineBuffering@
+to @NoBuffering@, then any items in the output buffer are written to
 the device, and any items in the input buffer are discarded.  The
 default buffering mode when a handle is opened is
 implementation-dependent and may depend on the object which is
 the device, and any items in the input buffer are discarded.  The
 default buffering mode when a handle is opened is
 implementation-dependent and may depend on the object which is
@@ -418,12 +383,14 @@ hSetBuffering :: Handle -> BufferMode -> IO ()
 hSetBuffering handle mode =
     case mode of
       (BlockBuffering (Just n)) 
 hSetBuffering handle mode =
     case mode of
       (BlockBuffering (Just n)) 
-        | n <= 0 -> fail (InvalidArgument "illegal buffer size")
+        | n <= 0 -> fail (IOError (Just handle) InvalidArgument "illegal buffer size")
       other ->
          readHandle handle                         >>= \ htype ->
           if isMarked htype then
               writeHandle handle htype             >>
       other ->
          readHandle handle                         >>= \ htype ->
           if isMarked htype then
               writeHandle handle htype             >>
-              fail (UnsupportedOperation "can't set buffering for a dirty handle")
+              fail (IOError (Just handle) 
+                           UnsupportedOperation 
+                           "can't set buffering for a dirty handle")
           else
               case htype of
                ErrorHandle ioError ->
           else
               case htype of
                ErrorHandle ioError ->
@@ -431,10 +398,10 @@ hSetBuffering handle mode =
                    fail ioError
                 ClosedHandle ->
                    writeHandle handle htype        >>
                    fail ioError
                 ClosedHandle ->
                    writeHandle handle htype        >>
-                   fail (IllegalOperation "handle is closed")
+                   ioe_closedHandle handle
                 SemiClosedHandle _ _ ->
                    writeHandle handle htype        >>
                 SemiClosedHandle _ _ ->
                    writeHandle handle htype        >>
-                   fail (IllegalOperation "handle is closed")
+                   ioe_closedHandle handle
                 other ->
                     _ccall_ setBuffering (filePtr other) bsize
                                                    `thenIO_Prim` \ rc -> 
                 other ->
                     _ccall_ setBuffering (filePtr other) bsize
                                                    `thenIO_Prim` \ rc -> 
@@ -460,7 +427,7 @@ hSetBuffering handle mode =
               BlockBuffering Nothing -> -2
               BlockBuffering (Just n) -> n
 
               BlockBuffering Nothing -> -2
               BlockBuffering (Just n) -> n
 
-    hcon :: Handle__ -> (Addr -> (Maybe BufferMode) -> Bool -> Handle__)
+    hcon :: Handle__ -> (ForeignObj -> (Maybe BufferMode) -> Bool -> Handle__)
     hcon (ReadHandle _ _ _) = ReadHandle
     hcon (WriteHandle _ _ _) = WriteHandle
     hcon (AppendHandle _ _ _) = AppendHandle
     hcon (ReadHandle _ _ _) = ReadHandle
     hcon (WriteHandle _ _ _) = WriteHandle
     hcon (AppendHandle _ _ _) = AppendHandle
@@ -480,10 +447,10 @@ hFlush handle =
          fail ioError
       ClosedHandle ->
          writeHandle handle htype                  >>
          fail ioError
       ClosedHandle ->
          writeHandle handle htype                  >>
-         fail (IllegalOperation "handle is closed")
+          ioe_closedHandle handle
       SemiClosedHandle _ _ ->
          writeHandle handle htype                  >>
       SemiClosedHandle _ _ ->
          writeHandle handle htype                  >>
-         fail (IllegalOperation "handle is closed")
+          ioe_closedHandle handle
       other ->
          _ccall_ flushFile (filePtr other)         `thenIO_Prim` \ rc ->
          writeHandle handle (markHandle htype)   >>
       other ->
          _ccall_ flushFile (filePtr other)         `thenIO_Prim` \ rc ->
          writeHandle handle (markHandle htype)   >>
@@ -524,10 +491,10 @@ hGetPosn handle =
          fail ioError
       ClosedHandle ->
          writeHandle handle htype                  >>
          fail ioError
       ClosedHandle ->
          writeHandle handle htype                  >>
-         fail (IllegalOperation "handle is closed")
+          ioe_closedHandle handle
       SemiClosedHandle _ _ ->
          writeHandle handle htype                  >>
       SemiClosedHandle _ _ ->
          writeHandle handle htype                  >>
-         fail (IllegalOperation "handle is closed")
+          ioe_closedHandle handle
       other -> 
           _ccall_ getFilePosn (filePtr other)      `thenIO_Prim` \ posn ->
           writeHandle handle htype                 >>
       other -> 
           _ccall_ getFilePosn (filePtr other)      `thenIO_Prim` \ posn ->
           writeHandle handle htype                 >>
@@ -545,13 +512,13 @@ hSetPosn (HandlePosn handle posn) =
          fail ioError
       ClosedHandle ->
          writeHandle handle htype                  >>
          fail ioError
       ClosedHandle ->
          writeHandle handle htype                  >>
-         fail (IllegalOperation "handle is closed")
+          ioe_closedHandle handle
       SemiClosedHandle _ _ ->
          writeHandle handle htype                  >>
       SemiClosedHandle _ _ ->
          writeHandle handle htype                  >>
-         fail (IllegalOperation "handle is closed")
+          ioe_closedHandle handle
       AppendHandle _ _ _ ->
          writeHandle handle htype                  >>
       AppendHandle _ _ _ ->
          writeHandle handle htype                  >>
-         fail (IllegalOperation "handle is not seekable")
+         fail (IOError (Just handle) IllegalOperation "handle is not seekable")
       other -> 
          _ccall_ setFilePosn (filePtr other) posn `thenIO_Prim` \ rc ->
          writeHandle handle (markHandle htype)    >>
       other -> 
          _ccall_ setFilePosn (filePtr other) posn `thenIO_Prim` \ rc ->
          writeHandle handle (markHandle htype)    >>
@@ -591,13 +558,13 @@ hSeek handle mode offset@(J# _ s# d#) =
          fail ioError
       ClosedHandle ->
          writeHandle handle htype                  >>
          fail ioError
       ClosedHandle ->
          writeHandle handle htype                  >>
-         fail (IllegalOperation "handle is closed")
+          ioe_closedHandle handle
       SemiClosedHandle _ _ ->
          writeHandle handle htype                  >>
       SemiClosedHandle _ _ ->
          writeHandle handle htype                  >>
-         fail (IllegalOperation "handle is closed")
+          ioe_closedHandle handle
       AppendHandle _ _ _ ->
          writeHandle handle htype                  >>
       AppendHandle _ _ _ ->
          writeHandle handle htype                  >>
-         fail (IllegalOperation "handle is not seekable")
+         fail (IOError (Just handle) IllegalOperation "handle is not seekable")
       other -> 
          _ccall_ seekFile (filePtr other) whence (I# s#) (ByteArray (0,0) d#)
                                                    `thenIO_Prim` \ rc ->
       other -> 
          _ccall_ seekFile (filePtr other) whence (I# s#) (ByteArray (0,0) d#)
                                                    `thenIO_Prim` \ rc ->
@@ -671,10 +638,10 @@ hIsReadable handle =
           fail ioError
       ClosedHandle ->
          writeHandle handle htype                  >>
           fail ioError
       ClosedHandle ->
          writeHandle handle htype                  >>
-         fail (IllegalOperation "handle is closed")
+          ioe_closedHandle handle
       SemiClosedHandle _ _ ->
          writeHandle handle htype                  >>
       SemiClosedHandle _ _ ->
          writeHandle handle htype                  >>
-         fail (IllegalOperation "handle is closed")
+          ioe_closedHandle handle
       other ->
          writeHandle handle htype                  >>
          return (isReadable other)
       other ->
          writeHandle handle htype                  >>
          return (isReadable other)
@@ -692,10 +659,10 @@ hIsWritable handle =
           fail ioError
       ClosedHandle ->
          writeHandle handle htype          >>
           fail ioError
       ClosedHandle ->
          writeHandle handle htype          >>
-         fail (IllegalOperation "handle is closed")
+          ioe_closedHandle handle
       SemiClosedHandle _ _ ->
          writeHandle handle htype          >>
       SemiClosedHandle _ _ ->
          writeHandle handle htype          >>
-         fail (IllegalOperation "handle is closed")
+          ioe_closedHandle handle
       other ->
          writeHandle handle htype          >>
          return (isWritable other)
       other ->
          writeHandle handle htype          >>
          return (isWritable other)
@@ -735,10 +702,10 @@ hIsBlockBuffered handle =
           fail ioError
       ClosedHandle ->
          writeHandle handle htype                  >>
           fail ioError
       ClosedHandle ->
          writeHandle handle htype                  >>
-         fail (IllegalOperation "handle is closed")
+          ioe_closedHandle handle
       SemiClosedHandle _ _ ->
          writeHandle handle htype                  >>
       SemiClosedHandle _ _ ->
          writeHandle handle htype                  >>
-         fail (IllegalOperation "handle is closed")
+          ioe_closedHandle handle
       other ->
           getBufferMode other                      `thenIO_Prim` \ other ->
           case bufferMode other of
       other ->
           getBufferMode other                      `thenIO_Prim` \ other ->
           case bufferMode other of
@@ -760,10 +727,10 @@ hIsLineBuffered handle =
           fail ioError
       ClosedHandle ->
          writeHandle handle htype                  >>
           fail ioError
       ClosedHandle ->
          writeHandle handle htype                  >>
-         fail (IllegalOperation "handle is closed")
+          ioe_closedHandle handle
       SemiClosedHandle _ _ ->
          writeHandle handle htype                  >>
       SemiClosedHandle _ _ ->
          writeHandle handle htype                  >>
-         fail (IllegalOperation "handle is closed")
+          ioe_closedHandle handle
       other ->
          getBufferMode other                       `thenIO_Prim` \ other ->
           case bufferMode other of
       other ->
          getBufferMode other                       `thenIO_Prim` \ other ->
           case bufferMode other of
@@ -785,10 +752,10 @@ hIsNotBuffered handle =
           fail ioError
       ClosedHandle ->
          writeHandle handle htype                  >>
           fail ioError
       ClosedHandle ->
          writeHandle handle htype                  >>
-         fail (IllegalOperation "handle is closed")
+          ioe_closedHandle handle
       SemiClosedHandle _ _ ->
          writeHandle handle htype                  >>
       SemiClosedHandle _ _ ->
          writeHandle handle htype                  >>
-         fail (IllegalOperation "handle is closed")
+          ioe_closedHandle handle
       other ->
          getBufferMode other                       `thenIO_Prim` \ other ->
           case bufferMode other of
       other ->
          getBufferMode other                       `thenIO_Prim` \ other ->
           case bufferMode other of
@@ -802,23 +769,23 @@ hIsNotBuffered handle =
                constructErrorAndFail "hIsNotBuffered"
 
 hGetBuffering :: Handle -> IO BufferMode
                constructErrorAndFail "hIsNotBuffered"
 
 hGetBuffering :: Handle -> IO BufferMode
-hGetBuffering hndl =
-    readHandle hndl                                >>= \ htype ->
+hGetBuffering handle =
+    readHandle handle                              >>= \ htype ->
     case htype of 
       ErrorHandle ioError ->
     case htype of 
       ErrorHandle ioError ->
-         writeHandle hndl htype                    >>
+         writeHandle handle htype                  >>
           fail ioError
       ClosedHandle ->
           fail ioError
       ClosedHandle ->
-         writeHandle hndl htype                    >>
-         fail (IllegalOperation "handle is closed")
+         writeHandle handle htype                  >>
+          ioe_closedHandle handle
       SemiClosedHandle _ _ ->
       SemiClosedHandle _ _ ->
-         writeHandle hndl htype                    >>
-         fail (IllegalOperation "handle is closed")
+         writeHandle handle htype                  >>
+          ioe_closedHandle handle
       other ->
          getBufferMode other                       `thenIO_Prim` \ other ->
           case bufferMode other of
             Just v ->
       other ->
          getBufferMode other                       `thenIO_Prim` \ other ->
           case bufferMode other of
             Just v ->
-               writeHandle hndl other              >>
+               writeHandle handle other            >>
                 return v
            Nothing -> 
                constructErrorAndFail "hGetBuffering"
                 return v
            Nothing -> 
                constructErrorAndFail "hGetBuffering"
@@ -832,10 +799,10 @@ hIsSeekable handle =
           fail ioError
       ClosedHandle ->
          writeHandle handle htype                  >>
           fail ioError
       ClosedHandle ->
          writeHandle handle htype                  >>
-         fail (IllegalOperation "handle is closed")
+          ioe_closedHandle handle
       SemiClosedHandle _ _ ->
          writeHandle handle htype                  >>
       SemiClosedHandle _ _ ->
          writeHandle handle htype                  >>
-         fail (IllegalOperation "handle is closed")
+          ioe_closedHandle handle
       AppendHandle _ _ _ ->
          writeHandle handle htype                  >>
          return False
       AppendHandle _ _ _ ->
          writeHandle handle htype                  >>
          return False
@@ -859,10 +826,28 @@ These two functions are meant to get things out of @IOErrors@.  They don't!
 
 \begin{code}
 ioeGetFileName        :: IOError -> Maybe FilePath
 
 \begin{code}
 ioeGetFileName        :: IOError -> Maybe FilePath
+ioeGetErrorString     :: IOError -> String
 ioeGetHandle          :: IOError -> Maybe Handle
 
 ioeGetHandle          :: IOError -> Maybe Handle
 
+ioeGetHandle   (IOError h _ _)   = h
+ioeGetErrorString (IOError _ iot str) =
+ case iot of
+   EOF -> "end of file"
+   _   -> str
+
+ioeGetFileName (IOError _ _ str) = 
+ case span (/=':') str of
+   (fs,[]) -> Nothing
+   (fs,_)  -> Just fs
 
 
-ioeGetHandle   _ = Nothing -- a stub, essentially
-ioeGetFileName _ = Nothing -- a stub, essentially
 \end{code}
 
 \end{code}
 
+Internal function for creating an @IOError@ representing the
+access of a closed file.
+
+\begin{code}
+
+ioe_closedHandle :: Handle -> IO a
+ioe_closedHandle h = fail (IOError (Just h) IllegalOperation "handle is closed")
+
+\end{code}
index 0358a0d..5eba82e 100644 (file)
@@ -10,4 +10,4 @@ _interface_ Main 1
 _exports_
 Main main ;
 _declarations_
 _exports_
 Main main ;
 _declarations_
-1 main :: IOBase.IO PrelBase.();;
+1 main _:_ IOBase.IO PrelBase.();;
index e83a391..f4a5b1c 100644 (file)
@@ -7,7 +7,11 @@
 \begin{code}
 {-# OPTIONS -fno-implicit-prelude #-}
 
 \begin{code}
 {-# OPTIONS -fno-implicit-prelude #-}
 
-module PrelBase where
+module PrelBase(
+       module PrelBase,
+       module GHC              -- Re-export GHC, to avoid lots of people having
+                               -- to import it explicitly
+  ) where
 
 import {-# SOURCE #-}  IOBase  ( error )       
 import GHC
 
 import {-# SOURCE #-}  IOBase  ( error )       
 import GHC
@@ -148,11 +152,7 @@ class  Show a  where
     showsPrec :: Int -> a -> ShowS
     showList  :: [a] -> ShowS
 
     showsPrec :: Int -> a -> ShowS
     showList  :: [a] -> ShowS
 
-    showList [] = showString "[]"
-    showList (x:xs)
-                = showChar '[' . shows x . showl xs
-                  where showl []     = showChar ']'
-                        showl (x:xs) = showString ", " . shows x . showl xs
+    showList ls = showList__ (showsPrec 0) ls 
 \end{code}
 
 %*********************************************************
 \end{code}
 
 %*********************************************************
@@ -168,8 +168,7 @@ data [] a = [] | a : [a]  -- do explicitly: deriving (Eq, Ord)
 instance (Eq a) => Eq [a]  where
     []     == []     = True    
     (x:xs) == (y:ys) = x == y && xs == ys
 instance (Eq a) => Eq [a]  where
     []     == []     = True    
     (x:xs) == (y:ys) = x == y && xs == ys
-    []     == ys     = False                   
-    xs     == []     = False                   
+    xs     == ys     = False                   
     xs     /= ys     = if (xs == ys) then False else True
 
 instance (Ord a) => Ord [a] where
     xs     /= ys     = if (xs == ys) then False else True
 
 instance (Ord a) => Ord [a] where
@@ -195,6 +194,7 @@ instance Functor [] where
 
 instance  Monad []  where
     m >>= k             = foldr ((++) . k) [] m
 
 instance  Monad []  where
     m >>= k             = foldr ((++) . k) [] m
+    m >> k              = foldr ((++) . (\ _ -> k)) [] m
     return x            = [x]
 
 instance  MonadZero []  where
     return x            = [x]
 
 instance  MonadZero []  where
@@ -205,7 +205,7 @@ instance  MonadPlus []  where
 
 instance  (Show a) => Show [a]  where
     showsPrec p         = showList
 
 instance  (Show a) => Show [a]  where
     showsPrec p         = showList
-    showList           = showList__ (showsPrec 0)
+    showList  ls       = showList__ (showsPrec 0) ls
 \end{code}
 
 \end{code}
 \end{code}
 
 \end{code}
@@ -253,9 +253,12 @@ dropWhile p xs@(x:xs')
 The type @Void@ is built in, but it needs a @Show@ instance.
 
 \begin{code}
 The type @Void@ is built in, but it needs a @Show@ instance.
 
 \begin{code}
+void :: Void
+void = error "You tried to evaluate void"
+
 instance  Show Void  where
     showsPrec p f  =  showString "<<void>>"
 instance  Show Void  where
     showsPrec p f  =  showString "<<void>>"
-    showList      = showList__ (showsPrec 0)
+    showList ls    = showList__ (showsPrec 0) ls
 \end{code}
 
 
 \end{code}
 
 
@@ -272,8 +275,8 @@ data  Bool  =  False | True deriving (Eq, Ord, Enum, Bounded, Show {- Read -})
 
 (&&), (||)             :: Bool -> Bool -> Bool
 True  && x             =  x
 
 (&&), (||)             :: Bool -> Bool -> Bool
 True  && x             =  x
-False && _             =  False
-True  || _             =  True
+False && x             =  False
+True  || x             =  True
 False || x             =  x
 
 not                    :: Bool -> Bool
 False || x             =  x
 
 not                    :: Bool -> Bool
@@ -294,6 +297,10 @@ otherwise          =  True
 \begin{code}
 data  Maybe a  =  Nothing | Just a     deriving (Eq, Ord, Show {- Read -})
 
 \begin{code}
 data  Maybe a  =  Nothing | Just a     deriving (Eq, Ord, Show {- Read -})
 
+maybe :: b -> (a -> b) -> Maybe a -> b
+maybe n f Nothing  = n
+maybe n f (Just x) = f x
+
 instance  Functor Maybe  where
     map f Nothing       = Nothing
     map f (Just a)      = Just (f a)
 instance  Functor Maybe  where
     map f Nothing       = Nothing
     map f (Just a)      = Just (f a)
@@ -301,6 +308,10 @@ instance  Functor Maybe  where
 instance  Monad Maybe  where
     (Just x) >>= k      = k x
     Nothing  >>= k      = Nothing
 instance  Monad Maybe  where
     (Just x) >>= k      = k x
     Nothing  >>= k      = Nothing
+
+    (Just x) >>  k      = k
+    Nothing  >>  k      = Nothing
+
     return              = Just
 
 instance  MonadZero Maybe  where
     return              = Just
 
 instance  MonadZero Maybe  where
@@ -328,7 +339,6 @@ it here seems more direct.
 \begin{code}
 data  ()  =  ()  --easier to do explicitly: deriving (Eq, Ord, Enum, Show, Bounded)
                 -- (avoids weird-named functions, e.g., con2tag_()#
 \begin{code}
 data  ()  =  ()  --easier to do explicitly: deriving (Eq, Ord, Enum, Show, Bounded)
                 -- (avoids weird-named functions, e.g., con2tag_()#
-
 instance Eq () where
     () == () = True
     () /= () = False
 instance Eq () where
     () == () = True
     () /= () = False
@@ -357,6 +367,7 @@ instance Bounded () where
 
 instance  Show ()  where
     showsPrec p () = showString "()"
 
 instance  Show ()  where
     showsPrec p () = showString "()"
+    showList ls    = showList__ (showsPrec 0) ls
 \end{code}
 
 %*********************************************************
 \end{code}
 
 %*********************************************************
@@ -398,11 +409,12 @@ data Char = C# Char#      deriving (Eq, Ord)
 
 instance  Enum Char  where
     toEnum   (I# i) | i >=# 0# && i <=# 255# =  C# (chr# i)
 
 instance  Enum Char  where
     toEnum   (I# i) | i >=# 0# && i <=# 255# =  C# (chr# i)
-                   | otherwise = error "Prelude.Enum.Char.toEnum:out of range"
+                   | otherwise = error ("Prelude.Enum.Char.toEnum:out of range: " ++ show (I# i))
     fromEnum (C# c)             =  I# (ord# c)
 
     enumFrom (C# c)                       =  eftt (ord# c)  1#                   255#
     enumFromThen (C# c1) (C# c2)          =  eftt (ord# c1) (ord# c2 -# ord# c1) 255#
     fromEnum (C# c)             =  I# (ord# c)
 
     enumFrom (C# c)                       =  eftt (ord# c)  1#                   255#
     enumFromThen (C# c1) (C# c2)          =  eftt (ord# c1) (ord# c2 -# ord# c1) 255#
+    enumFromTo (C# c1) (C# c2)             =  eftt (ord# c1) 1#                   (ord# c2)
     enumFromThenTo (C# c1) (C# c2) (C# c3) =  eftt (ord# c1) (ord# c2 -# ord# c1) (ord# c3)
 
 eftt :: Int# -> Int# -> Int# -> [Char]
     enumFromThenTo (C# c1) (C# c2) (C# c3) =  eftt (ord# c1) (ord# c2 -# ord# c1) (ord# c3)
 
 eftt :: Int# -> Int# -> Int# -> [Char]
@@ -428,9 +440,10 @@ instance  Show Char  where
 
 
 \begin{code}
 
 
 \begin{code}
-isAscii, isControl, isPrint, isSpace, isUpper,
+isAscii, isLatin1, isControl, isPrint, isSpace, isUpper,
  isLower, isAlpha, isDigit, isOctDigit, isHexDigit, isAlphanum :: Char -> Bool
 isAscii c              =  fromEnum c < 128
  isLower, isAlpha, isDigit, isOctDigit, isHexDigit, isAlphanum :: Char -> Bool
 isAscii c              =  fromEnum c < 128
+isLatin1 c              =  c <= '\xff'
 isControl c            =  c < ' ' || c >= '\DEL' && c <= '\x9f'
 isPrint c              =  not (isControl c)
 
 isControl c            =  c < ' ' || c >= '\DEL' && c <= '\x9f'
 isPrint c              =  not (isControl c)
 
@@ -455,19 +468,19 @@ isUpper c         =  c >= 'A' && c <= 'Z' ||
 isLower c              =  c >= 'a' && c <= 'z' ||
                            c >= '\xDF' && c <= '\xF6' ||
                            c >= '\xF8' && c <= '\xFF'
 isLower c              =  c >= 'a' && c <= 'z' ||
                            c >= '\xDF' && c <= '\xF6' ||
                            c >= '\xF8' && c <= '\xFF'
-isAlpha c              =  isUpper c || isLower c
+isAlpha c              =  isLower c || isUpper c
 isDigit c              =  c >= '0' && c <= '9'
 isOctDigit c           =  c >= '0' && c <= '7'
 isHexDigit c           =  isDigit c || c >= 'A' && c <= 'F' ||
                                         c >= 'a' && c <= 'f'
 isAlphanum c           =  isAlpha c || isDigit c
 
 isDigit c              =  c >= '0' && c <= '9'
 isOctDigit c           =  c >= '0' && c <= '7'
 isHexDigit c           =  isDigit c || c >= 'A' && c <= 'F' ||
                                         c >= 'a' && c <= 'f'
 isAlphanum c           =  isAlpha c || isDigit c
 
--- These almost work for ISO-Latin-1 (except for =DF <-> =FF)
+-- Case-changing operations
 
 toUpper, toLower       :: Char -> Char
 
 toUpper, toLower       :: Char -> Char
-toUpper c | isLower c  =  toEnum (fromEnum c - fromEnum 'a'
-                                              + fromEnum 'A')
-         | otherwise   =  c
+toUpper c | isLower c  && c /= '\xDF' && c /= '\xFF'
+ =  toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A')
+  | otherwise  =  c
 
 toLower c | isUpper c  =  toEnum (fromEnum c - fromEnum 'A' 
                                               + fromEnum 'a')
 
 toLower c | isUpper c  =  toEnum (fromEnum c - fromEnum 'A' 
                                               + fromEnum 'a')
@@ -491,19 +504,22 @@ asciiTab = -- Using an array drags in the array module.  listArray ('\NUL', ' ')
 data Int = I# Int#
 
 instance Eq Int where
 data Int = I# Int#
 
 instance Eq Int where
-    (I# x) == (I# y) = x ==# y
+    (==) x y = x `eqInt` y
+    (/=) x y = x `neInt` y
 
 instance Ord Int where
 
 instance Ord Int where
-    (I# x) `compare` (I# y) | x <# y    = LT
-                           | x ==# y   = EQ
-                           | otherwise = GT
-
-    (I# x) <  (I# y) = x <#  y
-    (I# x) <= (I# y) = x <=# y
-    (I# x) >= (I# y) = x >=# y
-    (I# x) >  (I# y) = x >#  y
+    compare x y = compareInt x y 
 
 
+    (<)  x y = ltInt x y
+    (<=) x y = leInt x y
+    (>=) x y = geInt x y
+    (>)  x y = gtInt x y
+    max x y = case (compareInt x y) of { LT -> y ; EQ -> x ; GT -> x }
+    min x y = case (compareInt x y) of { LT -> x ; EQ -> x ; GT -> y }
 
 
+(I# x) `compareInt` (I# y) | x <# y    = LT
+                          | x ==# y   = EQ
+                          | otherwise = GT
 
 instance  Enum Int  where
     toEnum   x = x
 
 instance  Enum Int  where
     toEnum   x = x
@@ -524,6 +540,7 @@ instance  Enum Int  where
     enumFromThenTo n m p =  takeWhile (if m >= n then (<= p) else (>= p))
                                      (enumFromThen n m)
 
     enumFromThenTo n m p =  takeWhile (if m >= n then (<= p) else (>= p))
                                      (enumFromThen n m)
 
+
 instance  Bounded Int where
     minBound =  negate 2147483647   -- **********************
     maxBound =  2147483647         -- **********************
 instance  Bounded Int where
     minBound =  negate 2147483647   -- **********************
     maxBound =  2147483647         -- **********************
@@ -546,7 +563,7 @@ instance  Num Int  where
 
 instance  Show Int  where
     showsPrec p n = showSignedInt p n
 
 instance  Show Int  where
     showsPrec p n = showSignedInt p n
-    showList      = showList__ (showsPrec 0) 
+    showList ls   = showList__ (showsPrec 0)  ls
 \end{code}
 
 
 \end{code}
 
 
@@ -576,7 +593,8 @@ data Integer        = J# Int# Int# ByteArray#
 \begin{code}
 instance  Show (a -> b)  where
     showsPrec p f  =  showString "<<function>>"
 \begin{code}
 instance  Show (a -> b)  where
     showsPrec p f  =  showString "<<function>>"
-    showList      = showList__ (showsPrec 0)
+    showList ls           = showList__ (showsPrec 0) ls
+
 
 -- identity function
 id                     :: a -> a
 
 -- identity function
 id                     :: a -> a
@@ -624,6 +642,7 @@ asTypeOf            =  const
 \begin{code}
 data Addr = A# Addr#   deriving (Eq, Ord) -- Glasgow extension
 data Word = W# Word#   deriving (Eq, Ord) -- Glasgow extension
 \begin{code}
 data Addr = A# Addr#   deriving (Eq, Ord) -- Glasgow extension
 data Word = W# Word#   deriving (Eq, Ord) -- Glasgow extension
+data ForeignObj = ForeignObj ForeignObj#   -- another one
 
 data Lift a = Lift a
 {-# GENERATE_SPECS data a :: Lift a #-}
 
 data Lift a = Lift a
 {-# GENERATE_SPECS data a :: Lift a #-}
@@ -727,6 +746,9 @@ Definitions of the boxed PrimOps; these will be
 used in the case of partial applications, etc.
 
 \begin{code}
 used in the case of partial applications, etc.
 
 \begin{code}
+{-# INLINE eqInt #-}
+{-# INLINE neInt #-}
+
 plusInt        (I# x) (I# y) = I# (x +# y)
 minusInt(I# x) (I# y) = I# (x -# y)
 timesInt(I# x) (I# y) = I# (x *# y)
 plusInt        (I# x) (I# y) = I# (x +# y)
 minusInt(I# x) (I# y) = I# (x -# y)
 timesInt(I# x) (I# y) = I# (x *# y)
index 940a57b..cadad79 100644 (file)
@@ -21,6 +21,8 @@ module PrelNum where
 import {-# SOURCE #-}  IOBase  ( error )
 import PrelList
 import PrelBase
 import {-# SOURCE #-}  IOBase  ( error )
 import PrelList
 import PrelBase
+import ArrBase ( Array, array, (!) )
+import Ix      ( Ix(..) )
 import GHC
 
 infixr 8  ^, ^^, **
 import GHC
 
 infixr 8  ^, ^^, **
@@ -338,8 +340,18 @@ instance  Show Integer  where
     showsPrec   x = showSignedInteger x
     showList = showList__ (showsPrec 0) 
 
     showsPrec   x = showSignedInteger x
     showList = showList__ (showsPrec 0) 
 
+instance  Ix Integer  where
+    range (m,n)                =  [m..n]
+    index b@(m,n) i
+       | inRange b i   =  fromInteger (i - m)
+       | otherwise     =  error "Integer.index: Index out of range."
+    inRange (m,n) i    =  m <= i && i <= n
+
 integer_0, integer_1, integer_2, integer_m1 :: Integer
 integer_0, integer_1, integer_2, integer_m1 :: Integer
-integer_0 = 0; integer_1 = 1; integer_2 = 2; integer_m1 = -1
+integer_0  = int2Integer# 0#
+integer_1  = int2Integer# 1#
+integer_2  = int2Integer# 2#
+integer_m1 = int2Integer# (negateInt# 1#)
 \end{code}
 
 
 \end{code}
 
 
@@ -361,7 +373,7 @@ instance Ord Float where
     (F# x) <  (F# y) = x `ltFloat#`  y
     (F# x) <= (F# y) = x `leFloat#`  y
     (F# x) >= (F# y) = x `geFloat#`  y
     (F# x) <  (F# y) = x `ltFloat#`  y
     (F# x) <= (F# y) = x `leFloat#`  y
     (F# x) >= (F# y) = x `geFloat#`  y
-    (F# x) >  (F# y) = x `geFloat#`  y
+    (F# x) >  (F# y) = x `gtFloat#`  y
 
 instance  Num Float  where
     (+)                x y     =  plusFloat x y
 
 instance  Num Float  where
     (+)                x y     =  plusFloat x y
@@ -662,7 +674,7 @@ numericEnumFromThen n m     =  iterate (+(m-n)) n
 %*********************************************************
 
 \begin{code}
 %*********************************************************
 
 \begin{code}
-data  (Integral a)     => Ratio a = a :% a  deriving (Eq)
+data  (Integral a)     => Ratio a = !a :% !a  deriving (Eq)
 type  Rational         =  Ratio Integer
 \end{code}
 
 type  Rational         =  Ratio Integer
 \end{code}
 
@@ -671,11 +683,19 @@ type  Rational            =  Ratio Integer
 numerator, denominator :: (Integral a) => Ratio a -> a
 approxRational         :: (RealFrac a) => a -> a -> Rational
 
 numerator, denominator :: (Integral a) => Ratio a -> a
 approxRational         :: (RealFrac a) => a -> a -> Rational
 
+\end{code}
+
+\tr{reduce} is a subsidiary function used only in this module .
+It normalises a ratio by dividing both numerator and denominator by
+their greatest common divisor.
 
 
+\begin{code}
 reduce _ 0             =  error "{Ratio.%}: zero denominator"
 reduce x y             =  (x `quot` d) :% (y `quot` d)
                           where d = gcd x y
 reduce _ 0             =  error "{Ratio.%}: zero denominator"
 reduce x y             =  (x `quot` d) :% (y `quot` d)
                           where d = gcd x y
+\end{code}
 
 
+\begin{code}
 x % y                  =  reduce (x * signum y) (abs y)
 
 numerator (x:%y)       =  x
 x % y                  =  reduce (x * signum y) (abs y)
 
 numerator (x:%y)       =  x
@@ -754,23 +774,27 @@ instance  (Integral a)  => Show (Ratio a)  where
                               (shows x . showString " % " . shows y)
 \end{code}
 
                               (shows x . showString " % " . shows y)
 \end{code}
 
-{-
-[In response to a request by simonpj, Joe Fasel writes:]
+[In response to a request for documentation of how fromRational works,
+Joe Fasel writes:] A quite reasonable request!  This code was added to
+the Prelude just before the 1.2 release, when Lennart, working with an
+early version of hbi, noticed that (read . show) was not the identity
+for floating-point numbers.  (There was a one-bit error about half the
+time.)  The original version of the conversion function was in fact
+simply a floating-point divide, as you suggest above. The new version
+is, I grant you, somewhat denser.
 
 
-A quite reasonable request!  This code was added to the Prelude just
-before the 1.2 release, when Lennart, working with an early version
-of hbi, noticed that (read . show) was not the identity for
-floating-point numbers.         (There was a one-bit error about half the time.)
-The original version of the conversion function was in fact simply
-a floating-point divide, as you suggest above. The new version is,
-I grant you, somewhat denser.
+Unfortunately, Joe's code doesn't work!  Here's an example:
 
 
-How's this?
+main = putStr (shows (1.82173691287639817263897126389712638972163e-300::Double) "\n")
 
 
-Joe
--}
+This program prints
+       0.0000000000000000
+instead of
+       1.8217369128763981e-300
 
 
-\begin{code}
+Lennart's code follows, and it works...
+
+\begin{pseudocode}
 {-# GENERATE_SPECS fromRational__ a{Double#,Double} #-}
 fromRational__ :: (RealFloat a) => Rational -> a
 fromRational__ x = x'
 {-# GENERATE_SPECS fromRational__ a{Double#,Double} #-}
 fromRational__ :: (RealFloat a) => Rational -> a
 fromRational__ x = x'
@@ -796,8 +820,76 @@ fromRational__ x = x'
 
              (s,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
                                        / fromInteger (denominator x))
 
              (s,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
                                        / fromInteger (denominator x))
-\end{code}
+\end{pseudocode}
 
 
+Now, here's Lennart's code.
+
+\begin{code}
+fromRational__ :: (RealFloat a) => Rational -> a
+fromRational__ x = 
+    if x == 0 then encodeFloat 0 0             -- Handle exceptional cases
+    else if x < 0 then - fromRat' (-x)         -- first.
+    else fromRat' x
+
+-- Conversion process:
+-- Scale the rational number by the RealFloat base until
+-- it lies in the range of the mantissa (as used by decodeFloat/encodeFloat).
+-- Then round the rational to an Integer and encode it with the exponent
+-- that we got from the scaling.
+-- To speed up the scaling process we compute the log2 of the number to get
+-- a first guess of the exponent.
+
+fromRat' :: (RealFloat a) => Rational -> a
+fromRat' x = r
+  where b = floatRadix r
+        p = floatDigits r
+       (minExp0, _) = floatRange r
+       minExp = minExp0 - p            -- the real minimum exponent
+       xMin = toRational (expt b (p-1))
+       xMax = toRational (expt b p)
+       p0 = (integerLogBase b (numerator x) - integerLogBase b (denominator x) - p) `max` minExp
+       f = if p0 < 0 then 1 % expt b (-p0) else expt b p0 % 1
+       (x', p') = scaleRat (toRational b) minExp xMin xMax p0 (x / f)
+       r = encodeFloat (round x') p'
+
+-- Scale x until xMin <= x < xMax, or p (the exponent) <= minExp.
+scaleRat :: Rational -> Int -> Rational -> Rational -> Int -> Rational -> (Rational, Int)
+scaleRat b minExp xMin xMax p x =
+    if p <= minExp then
+        (x, p)
+    else if x >= xMax then
+        scaleRat b minExp xMin xMax (p+1) (x/b)
+    else if x < xMin  then
+        scaleRat b minExp xMin xMax (p-1) (x*b)
+    else
+        (x, p)
+
+-- Exponentiation with a cache for the most common numbers.
+minExpt = 0::Int
+maxExpt = 1100::Int
+expt :: Integer -> Int -> Integer
+expt base n =
+    if base == 2 && n >= minExpt && n <= maxExpt then
+        expts!n
+    else
+        base^n
+expts :: Array Int Integer
+expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]]
+
+-- Compute the (floor of the) log of i in base b.
+-- Simplest way would be just divide i by b until it's smaller then b, but that would
+-- be very slow!  We are just slightly more clever.
+integerLogBase :: Integer -> Integer -> Int
+integerLogBase b i =
+     if i < b then
+        0
+     else
+       -- Try squaring the base first to cut down the number of divisions.
+        let l = 2 * integerLogBase (b*b) i
+           doDiv :: Integer -> Int -> Int
+           doDiv i l = if i < b then l else doDiv (i `div` b) (l+1)
+       in  doDiv (i `div` (b^l)) l
+\end{code}
 
 %*********************************************************
 %*                                                     *
 
 %*********************************************************
 %*                                                     *
index 683c42b..b8693c5 100644 (file)
@@ -367,9 +367,10 @@ lex (c:s) | isSingle c = [([c],s)]
               isSym c    =  c `elem` "!@#$%&*+./<=>?\\^|:-~"
               isIdChar c =  isAlphanum c || c `elem` "_'"
 
               isSym c    =  c `elem` "!@#$%&*+./<=>?\\^|:-~"
               isIdChar c =  isAlphanum c || c `elem` "_'"
 
-              lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,
-                                                    (e,u)  <- lexExp t]
-              lexFracExp s       = [("",s)]
+              lexFracExp ('.':c:cs) | isDigit c
+                                   = [('.':ds++e,u) | (ds,t) <- lexDigits (c:cs),
+                                                       (e,u)  <- lexExp t]
+              lexFracExp s          = [("",s)]
 
               lexExp (e:s) | e `elem` "eE"
                        = [(e:c:ds,u) | (c:t)  <- [s], c `elem` "+-",
 
               lexExp (e:s) | e `elem` "eE"
                        = [(e:c:ds,u) | (c:t)  <- [s], c `elem` "+-",
index 9cff092..afc3d51 100644 (file)
@@ -54,33 +54,6 @@ returnST = return
 thenST   = (>>=)
 seqST   = (>>)
 
 thenST   = (>>=)
 seqST   = (>>)
 
--- not sure whether to 1.3-ize these or what...
-{-# INLINE returnStrictlyST #-}
-{-# INLINE thenStrictlyST #-}
-{-# INLINE seqStrictlyST #-}
-
-{-# GENERATE_SPECS returnStrictlyST a #-}
-returnStrictlyST :: a -> ST s a
-
-{-# GENERATE_SPECS thenStrictlyST a b #-}
-thenStrictlyST :: ST s a -> (a -> ST s b) -> ST s b
-
-{-# GENERATE_SPECS seqStrictlyST a b #-}
-seqStrictlyST :: ST s a -> ST s b -> ST s b
-
-returnStrictlyST a = ST $ \ s@(S# _) -> (a, s)
-
-thenStrictlyST (ST m) k = ST $ \ s ->  -- @(S# _)   Omitted SLPJ [May95] no need to evaluate the state
-    case (m s) of { (r, new_s) ->
-    case (k r) of { ST k2     ->
-    (k2 new_s) }}
-
-seqStrictlyST (ST m) (ST k) = ST $ \ s ->      -- @(S# _)   Omitted SLPJ [May95] no need to evaluate the state
-    case (m s) of { (_, new_s) ->
-    (k new_s) }
-
--- BUILT-IN: runST (see Builtin.hs)
-
 unsafeInterleaveST :: ST s a -> ST s a    -- ToDo: put in state-interface.tex
 unsafeInterleaveST (ST m) = ST $ \ s ->
     let
 unsafeInterleaveST :: ST s a -> ST s a    -- ToDo: put in state-interface.tex
 unsafeInterleaveST (ST m) = ST $ \ s ->
     let