X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FDriverUtil.hs;h=dab7eb68c28c4863359b0a0c68cca5793a75017c;hb=153b9cb9b11e05c4edb1b6bc0a7b972660e41f70;hp=484c024f07fb2434ef3f1792c49ac4544fc72b6c;hpb=b89ad0e9ba8633987a0163aa94fed82f7cd56c67;p=ghc-hetmet.git diff --git a/ghc/compiler/main/DriverUtil.hs b/ghc/compiler/main/DriverUtil.hs index 484c024..dab7eb6 100644 --- a/ghc/compiler/main/DriverUtil.hs +++ b/ghc/compiler/main/DriverUtil.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverUtil.hs,v 1.45 2004/10/03 16:28:06 panne Exp $ +-- $Id: DriverUtil.hs,v 1.50 2005/01/28 12:55:37 simonmar Exp $ -- -- Utils for the driver -- @@ -19,12 +19,12 @@ module DriverUtil ( replaceFilenameDirectory, remove_spaces, escapeSpaces, ) where -#include "../includes/ghcconfig.h" #include "HsVersions.h" import Util import Panic import Config ( cLeadingUnderscore ) +import Ctype import EXCEPTION ( Exception(..), finally, throwDyn, catchDyn, throw ) import qualified EXCEPTION as Exception @@ -45,29 +45,45 @@ getOptionsFromSource -> IO [String] -- options, if any getOptionsFromSource file = do h <- openFile file ReadMode - catchJust ioErrors (look h `finally` hClose h) - (\e -> if isEOFError e then return [] else ioError e) + look h `finally` hClose h where - look h = do - l' <- hGetLine h - let l = remove_spaces l' - case () of - () | null l -> look h - | prefixMatch "#" l -> look h - | prefixMatch "{-# LINE" l -> look h -- -} - | Just opts <- matchOptions l - -> do rest <- look h + r <- tryJust ioErrors (hGetLine h) + case r of + Left e | isEOFError e -> return [] + | otherwise -> ioError e + Right l' -> do + let l = remove_spaces l' + case () of + () | null l -> look h + | prefixMatch "#" l -> look h + | prefixMatch "{-# LINE" l -> look h -- -} + | Just opts <- matchOptions l + -> do rest <- look h return (words opts ++ rest) - | otherwise -> return [] + | otherwise -> return [] +-- detect {-# OPTIONS_GHC ... #-}. For the time being, we accept OPTIONS +-- instead of OPTIONS_GHC, but that is deprecated. matchOptions s - | Just s1 <- maybePrefixMatch "{-#" s, -- -} - Just s2 <- maybePrefixMatch "OPTIONS" (remove_spaces s1), - Just s3 <- maybePrefixMatch "}-#" (reverse s2) - = Just (reverse s3) + | Just s1 <- maybePrefixMatch "{-#" s -- -} + = matchOptions1 (remove_spaces s1) | otherwise = Nothing + where + matchOptions1 s + | Just s2 <- maybePrefixMatch "OPTIONS" s + = case () of + _ | Just s3 <- maybePrefixMatch "_GHC" s2, not (is_ident (head s3)) + -> matchOptions2 s3 + | not (is_ident (head s2)) + -> matchOptions2 s2 + | otherwise + -> Just [] -- OPTIONS_anything is ignored, not treated as start of source + | otherwise = Nothing + matchOptions2 s + | Just s3 <- maybePrefixMatch "}-#" (reverse s) = Just (reverse s3) + | otherwise = Nothing ----------------------------------------------------------------------------- -- A version of getDirectoryContents that is non-fatal if the