-----------------------------------------------------------------------------
--- $Id: DriverState.hs,v 1.1 2000/10/11 11:54:58 simonmar Exp $
+-- $Id: DriverState.hs,v 1.2 2000/10/11 14:08:52 simonmar Exp $
--
-- Settings for the driver
--
-----------------------------------------------------------------------------
-- Global compilation flags
+-- location of compiler-related files
+GLOBAL_VAR(topDir, clibdir, String)
+GLOBAL_VAR(inplace, False, Bool)
+
-- Cpp-related flags
hs_source_cpp_opts = global
[ "-D__HASKELL1__="++cHaskell1Version
-----------------------------------------------------------------------------
-- Packages
-GLOBAL_VAR(package_config, (findFile "package.conf" (cGHC_DRIVER_DIR++"/package.conf.inplace")), String)
+GLOBAL_VAR(path_package_config, error "path_package_config", String)
-- package list is maintained in dependency order
packages = global ["std", "rts", "gmp"] :: IORef [String]
-----------------------------------------------------------------------------
-- Programs for particular phases
-GLOBAL_VAR(pgm_L, findFile "unlit" cGHC_UNLIT, String)
-GLOBAL_VAR(pgm_P, cRAWCPP, String)
-GLOBAL_VAR(pgm_C, findFile "hsc" cGHC_HSC, String)
-GLOBAL_VAR(pgm_c, cGCC, String)
-GLOBAL_VAR(pgm_m, findFile "ghc-asm" cGHC_MANGLER, String)
-GLOBAL_VAR(pgm_s, findFile "ghc-split" cGHC_SPLIT, String)
-GLOBAL_VAR(pgm_a, cGCC, String)
-GLOBAL_VAR(pgm_l, cGCC, String)
+GLOBAL_VAR(pgm_L, error "pgm_L", String)
+GLOBAL_VAR(pgm_P, cRAWCPP, String)
+GLOBAL_VAR(pgm_C, error "pgm_L", String)
+GLOBAL_VAR(pgm_c, cGCC, String)
+GLOBAL_VAR(pgm_m, error "pgm_m", String)
+GLOBAL_VAR(pgm_s, error "pgm_s", String)
+GLOBAL_VAR(pgm_a, cGCC, String)
+GLOBAL_VAR(pgm_l, cGCC, String)
GLOBAL_VAR(opt_dep, [], [String])
GLOBAL_VAR(anti_opt_C, [], [String])
-----------------------------------------------------------------------------
--- $Id: DriverUtil.hs,v 1.1 2000/10/11 11:54:58 simonmar Exp $
+-- $Id: DriverUtil.hs,v 1.2 2000/10/11 14:08:52 simonmar Exp $
--
-- Utils for the driver
--
import IOExts
import Exception
import Dynamic
+import RegexString
import IO
import System
short_usage = "Usage: For basic information, try the `--help' option."
+GLOBAL_VAR(path_usage, "", String)
+
long_usage = do
- let usage_file = "ghc-usage.txt"
- usage_path = findFile usage_file (cGHC_DRIVER_DIR ++ '/':usage_file)
+ usage_path <- readIORef path_usage
usage <- readFile usage_path
dump usage
exitWith ExitSuccess
typeOf _ = mkAppTy barfKindTc []
-----------------------------------------------------------------------------
--- Finding files in the installation
-
-GLOBAL_VAR(topDir, clibdir, String)
-
- -- grab the last -B option on the command line, and
- -- set topDir to its value.
-setTopDir :: [String] -> IO [String]
-setTopDir args = do
- let (minusbs, others) = partition (prefixMatch "-B") args
- (case minusbs of
- [] -> writeIORef topDir clibdir
- some -> writeIORef topDir (drop 2 (last some)))
- return others
-
-findFile name alt_path = unsafePerformIO (do
- top_dir <- readIORef topDir
- let installed_file = top_dir ++ '/':name
- let inplace_file = top_dir ++ '/':cCURRENT_DIR ++ '/':alt_path
- b <- doesFileExist inplace_file
- if b then return inplace_file
- else return installed_file
- )
+-- Reading OPTIONS pragmas
+
+getOptionsFromSource
+ :: String -- input file
+ -> IO [String] -- options, if any
+getOptionsFromSource file
+ = do h <- openFile file ReadMode
+ catchJust ioErrors (look h)
+ (\e -> if isEOFError e then return [] else ioError e)
+ where
+ look h = do
+ l <- hGetLine h
+ case () of
+ () | null l -> look h
+ | prefixMatch "#" l -> look h
+ | prefixMatch "{-# LINE" l -> look h -- -}
+ | Just (opts:_) <- matchRegex optionRegex l
+ -> return (words opts)
+ | otherwise -> return []
+
+optionRegex = mkRegex "\\{-#[ \t]+OPTIONS[ \t]+(.*)#-\\}" -- -}
-----------------------------------------------------------------------------
-- Utils
| p == r = my_prefix_match pat rest
| otherwise = Nothing
-prefixMatch :: Eq a => [a] -> [a] -> Bool
-prefixMatch [] _str = True
-prefixMatch _pat [] = False
-prefixMatch (p:ps) (s:ss) | p == s = prefixMatch ps ss
- | otherwise = False
-
-postfixMatch :: String -> String -> Bool
-postfixMatch pat str = prefixMatch (reverse pat) (reverse str)
-
later = flip finally
handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
{-# OPTIONS -W -fno-warn-incomplete-patterns #-}
-----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.2 2000/10/11 11:54:58 simonmar Exp $
+-- $Id: Main.hs,v 1.3 2000/10/11 14:08:52 simonmar Exp $
--
-- GHC Driver program
--
where
add_dir hisuf dir str = dir ++ "%." ++ hisuf ++ split_marker : str
-
-getOptionsFromSource
- :: String -- input file
- -> IO [String] -- options, if any
-getOptionsFromSource file
- = do h <- openFile file ReadMode
- catchJust ioErrors (look h)
- (\e -> if isEOFError e then return [] else ioError e)
- where
- look h = do
- l <- hGetLine h
- case () of
- () | null l -> look h
- | prefixMatch "#" l -> look h
- | prefixMatch "{-# LINE" l -> look h -- -}
- | Just (opts:_) <- matchRegex optionRegex l
- -> return (words opts)
- | otherwise -> return []
-
-optionRegex = mkRegex "\\{-#[ \t]+OPTIONS[ \t]+(.*)#-\\}" -- -}
-
-----------------------------------------------------------------------------
-- Main loop
-get_source_files :: [String] -> ([String],[String])
-get_source_files = partition (('-' /=) . head)
-
main =
-- all error messages are propagated as exceptions
my_catchDyn (\dyn -> case dyn of
-- grab any -B options from the command line first
argv' <- setTopDir argv
+ top_dir <- readIORef topDir
+
+ let installed s = top_dir ++ s
+ inplace s = top_dir ++ '/':cCURRENT_DIR ++ '/':s
+
+ installed_pkgconfig = installed ("package.conf")
+ inplace_pkgconfig = inplace (cGHC_DRIVER_DIR ++ "/package.conf.inplace")
+
+ -- discover whether we're running in a build tree or in an installation,
+ -- by looking for the package configuration file.
+ am_installed <- doesFileExist installed_pkgconfig
+
+ if am_installed
+ then writeIORef path_pkgconfig installed_pkgconfig
+ else do am_inplace <- doesFileExist inplace_pkgconfig
+ if am_inplace
+ then writeIORef path_pkgconfig inplace_pkgconfig
+ else throw (OtherError "can't find package.conf")
+
+ -- set the location of our various files
+ if am_installed
+ then do writeIORef path_usage (installed "ghc-usage.txt")
+ writeIORef pgm_L (installed "unlit")
+ writeIORef pgm_C (installed "hsc")
+ writeIORef pgm_m (installed "ghc-asm")
+ writeIORef pgm_s (installed "ghc-split")
+
+ else do writeIORef path_usage (inplace (cGHC_DRIVER_DIR ++ '/':usage_file))
+ writeIORef pgm_L (inplace cGHC_UNLIT)
+ writeIORef pgm_C (inplace cGHC_HSC)
+ writeIORef pgm_m (inplace cGHC_MANGLER)
+ writeIORef pgm_s (inplace cGHC_SPLIT)
-- read the package configuration
- conf_file <- readIORef package_config
+ conf_file <- readIORef path_pkgconfig
contents <- readFile conf_file
writeIORef package_details (read contents)
when verb (do hPutStr stderr "Glasgow Haskell Compiler, Version "
hPutStr stderr version_str
hPutStr stderr ", for Haskell 98, compiled by GHC version "
- hPutStr stderr booter_version
- hPutStr stderr "\n")
+ hPutStrLn stderr booter_version)
when verb (hPutStrLn stderr ("Using package config file: " ++ conf_file))
-- mkdependHS is special
when (todo == DoMkDependHS) beginMkDependHS
+ -- make is special
+ when (todo == DoMake) beginMake
+
-- for each source file, find which phases to run
pipelines <- mapM (genPipeline todo stop_flag) srcs
let src_pipelines = zip srcs pipelines
when (todo == DoLink) (do_link o_files)
+ -- grab the last -B option on the command line, and
+ -- set topDir to its value.
+setTopDir :: [String] -> IO [String]
+setTopDir args = do
+ let (minusbs, others) = partition (prefixMatch "-B") args
+ (case minusbs of
+ [] -> writeIORef topDir clibdir
+ some -> writeIORef topDir (drop 2 (last some)))
+ return others
-----------------------------------------------------------------------------
-- Which phase to stop at
-data ToDo = DoMkDependHS | DoMkDLL | StopBefore Phase | DoLink
+data ToDo = DoMkDependHS | DoMkDLL | StopBefore Phase | DoLink | DoInteractive
deriving (Eq)
GLOBAL_VAR(v_todo, error "todo", ToDo)
todoFlag :: String -> Maybe ToDo
-todoFlag "-M" = Just $ DoMkDependHS
-todoFlag "-E" = Just $ StopBefore Hsc
-todoFlag "-C" = Just $ StopBefore HCc
-todoFlag "-S" = Just $ StopBefore As
-todoFlag "-c" = Just $ StopBefore Ln
-todoFlag _ = Nothing
+todoFlag "-M" = Just $ DoMkDependHS
+todoFlag "-E" = Just $ StopBefore Hsc
+todoFlag "-C" = Just $ StopBefore HCc
+todoFlag "-S" = Just $ StopBefore As
+todoFlag "-c" = Just $ StopBefore Ln
+todoFlag "--make" = Just $ DoMake
+todoFlag "--interactive" = Just $ DoInteractive
+todoFlag _ = Nothing
getToDo :: [String]
-> IO ( [String] -- rest of command line
- , ToDo -- phase to stop at
- , String -- "stop at" flag
+ , ToDo
+ , String -- "ToDo" flag
)
getToDo flags
= case my_partition todoFlag flags of
([] , rest) -> return (rest, DoLink, "") -- default is to do linking
([(flag,one)], rest) -> return (rest, one, flag)
(_ , _ ) ->
- throwDyn (OtherError "only one of the flags -M, -E, -C, -S, -c is allowed")
+ throwDyn (OtherError
+ "only one of the flags -M, -E, -C, -S, -c, --make is allowed")
-----------------------------------------------------------------------------
-- genPipeline
projects / ghc-hetmet.git / commitdiff