From: sof Date: Tue, 5 May 1998 10:31:18 +0000 (+0000) Subject: [project @ 1998-05-05 10:31:14 by sof] X-Git-Tag: Approx_2487_patches~725 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=e35015434bcde3d5de46b2f25360e8bae00f158d;p=ghc-hetmet.git [project @ 1998-05-05 10:31:14 by sof] constructErrorAndFailWithInfo: new function for including files/paths that caused IO op to fail --- diff --git a/ghc/lib/std/Directory.lhs b/ghc/lib/std/Directory.lhs index edd0e7b..e3bb80c 100644 --- a/ghc/lib/std/Directory.lhs +++ b/ghc/lib/std/Directory.lhs @@ -133,7 +133,7 @@ The path refers to an existing non-directory object. createDirectory path = do rc <- _ccall_ createDirectory path if rc == 0 then return () else - constructErrorAndFail "createDirectory" + constructErrorAndFailWithInfo "createDirectory" path \end{code} @removeDirectory dir@ removes an existing directory {\em dir}. The @@ -176,7 +176,7 @@ removeDirectory path = do if rc == 0 then return () else - constructErrorAndFail "removeDirectory" + constructErrorAndFailWithInfo "removeDirectory" path \end{code} @removeFile file@ removes the directory entry for an existing file @@ -213,7 +213,7 @@ removeFile path = do if rc == 0 then return () else - constructErrorAndFail "removeFile" + constructErrorAndFailWithInfo "removeFile" path \end{code} @renameDirectory old@ {\em new} changes the name of an existing @@ -260,7 +260,7 @@ renameDirectory opath npath = do if rc == 0 then return () else - constructErrorAndFail "renameDirectory" + constructErrorAndFailWithInfo "renameDirectory" opath \end{code} @renameFile old@ {\em new} changes the name of an existing file system @@ -305,7 +305,7 @@ renameFile opath npath = do if rc == 0 then return () else - constructErrorAndFail "renameFile" + constructErrorAndFailWithInfo "renameFile" opath \end{code} @getDirectoryContents dir@ returns a list of {\em all} entries @@ -338,7 +338,7 @@ The path refers to an existing non-directory object. getDirectoryContents path = do dir <- _ccall_ openDir__ path if dir == ``NULL'' - then constructErrorAndFail "getDirectoryContents" + then constructErrorAndFailWithInfo "getDirectoryContents" path else loop dir where loop :: Addr -> IO [String] @@ -346,6 +346,8 @@ getDirectoryContents path = do dirent_ptr <- _ccall_ readDir__ dir if (dirent_ptr::Addr) == ``NULL'' then do + -- readDir__ implicitly performs closedir() when the + -- end is reached. return [] else do str <- _casm_ `` %r=(char*)((struct dirent*)%0)->d_name; '' dirent_ptr @@ -423,7 +425,7 @@ setCurrentDirectory path = do rc <- _ccall_ setCurrentDirectory path if rc == 0 then return () - else constructErrorAndFail "setCurrentDirectory" + else constructErrorAndFailWithInfo "setCurrentDirectory" path \end{code} diff --git a/ghc/lib/std/PrelHandle.lhs b/ghc/lib/std/PrelHandle.lhs index bf3416d..c80b941 100644 --- a/ghc/lib/std/PrelHandle.lhs +++ b/ghc/lib/std/PrelHandle.lhs @@ -206,15 +206,7 @@ openFileEx f m = do newHandle (htype ptr Nothing False) #endif else do - ioError@(IOError hn iot msg) <- constructError "openFile" - let - improved_error -- a HACK, I guess - = case iot of - AlreadyExists -> IOError hn AlreadyExists (msg ++ ": " ++ f) - NoSuchThing -> IOError hn NoSuchThing (msg ++ ": " ++ f) - PermissionDenied -> IOError hn PermissionDenied (msg ++ ": " ++ f) - _ -> ioError - fail improved_error + constructErrorAndFailWithInfo "openFile" f where imo = case m of BinaryMode imo -> imo diff --git a/ghc/lib/std/PrelIOBase.lhs b/ghc/lib/std/PrelIOBase.lhs index bcf6d7d..f8c8cf8 100644 --- a/ghc/lib/std/PrelIOBase.lhs +++ b/ghc/lib/std/PrelIOBase.lhs @@ -20,7 +20,7 @@ import PrelMaybe import PrelAddr import PrelPack ( unpackCString ) import PrelBase -import PrelArr ( ByteArray(..), MutableVar(..) ) +import PrelArr ( ByteArray(..), MutableVar ) import PrelGHC \end{code} @@ -216,17 +216,17 @@ the exact strings to be used for particular errors. For errors not explicitly mentioned in the standard, any descriptive string may be used. -\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 = constructError call_site >>= \ io_error -> fail io_error +constructErrorAndFailWithInfo :: String -> String -> IO a +constructErrorAndFailWithInfo call_site reason + = constructErrorMsg call_site (Just reason) >>= \ io_error -> + fail io_error + \end{code} This doesn't seem to be documented/spelled out anywhere, @@ -243,7 +243,10 @@ information. \begin{code} constructError :: String -> IO IOError -constructError call_site = +constructError call_site = constructErrorMsg call_site Nothing + +constructErrorMsg :: String -> Maybe String -> IO IOError +constructErrorMsg call_site reason = _casm_ ``%r = ghc_errtype;'' >>= \ (I# errtype#) -> _casm_ ``%r = ghc_errstr;'' >>= \ str -> let @@ -271,9 +274,12 @@ constructError call_site = msg = call_site ++ ':' : ' ' : unpackCString str ++ - case iot of + (case iot of OtherError -> "(error code: " ++ show (I# errtype#) ++ ")" - _ -> "" + _ -> "") ++ + (case reason of + Nothing -> "" + Just m -> ' ':m) in return (IOError Nothing iot msg) \end{code} diff --git a/ghc/lib/std/System.lhs b/ghc/lib/std/System.lhs index ad0b66c..096a860 100644 --- a/ghc/lib/std/System.lhs +++ b/ghc/lib/std/System.lhs @@ -12,7 +12,7 @@ module System ( import Prelude import PrelAddr -import PrelIOBase ( IOError(..), IOErrorType(..), constructErrorAndFail ) +import PrelIOBase ( IOError(..), IOErrorType(..), constructErrorAndFailWithInfo ) import PrelArr ( indexAddrOffAddr ) import PrelPack ( unpackCString ) @@ -103,7 +103,7 @@ system cmd = do status <- _ccall_ systemCmd cmd case status of 0 -> return ExitSuccess - -1 -> constructErrorAndFail "system" + -1 -> constructErrorAndFailWithInfo "system" cmd n -> return (ExitFailure n) \end{code}