Commit 16d5d1c7 authored by simonpj's avatar simonpj

[project @ 2001-06-14 12:50:05 by simonpj]

----------------------
	Installation packaging
	----------------------

GHC runs various system programs like
	cp, touch
	gcc, as, ld etc

On Windows we plan to deliver these programs along with GHC,
so we have to be careful about where to find them.

This commit isolates all these dependencies in a single module

	main/SysTools.lhs

Most of the #ifdefery for mingw has moved into this module.
There's some documentation in SysTools.lhs

Along the way I did lots of other cleanups.  In particular

  * There is no more 'globbing' needed when calling runSomething
  * All file removal goes via the standard Directory.removeFile
  * TmpFiles.hs has gone; absorbed into SysTools
  * Some DynFlag stuff has moved from DriverFlags to CmdLineOpts


Still to do:

  **	I'm a bit concerned that calling removeFile one at a time
	when deleting masses of split-object files is going to be
	rather slow

  **	GHC now expects to find split,mangle,unlit in
		libdir/extra-bin
	instead of just
		libdir

	So something needs to change in the Unix installation scripts

  **    The "ineffective C preprocessor" is a perversion and should die
parent 8245241e
...@@ -12,7 +12,7 @@ you will screw up the layout where they are used in case expressions! ...@@ -12,7 +12,7 @@ you will screw up the layout where they are used in case expressions!
#ifdef __GLASGOW_HASKELL__ #ifdef __GLASGOW_HASKELL__
#define GLOBAL_VAR(name,value,ty) \ #define GLOBAL_VAR(name,value,ty) \
name = global (value) :: IORef (ty); \ name = Util.global (value) :: IORef (ty); \
{-# NOINLINE name #-} {-# NOINLINE name #-}
#endif #endif
......
# ----------------------------------------------------------------------------- # -----------------------------------------------------------------------------
# $Id: Makefile,v 1.155 2001/05/28 03:31:19 sof Exp $ # $Id: Makefile,v 1.156 2001/06/14 12:50:06 simonpj Exp $
TOP = .. TOP = ..
include $(TOP)/mk/boilerplate.mk include $(TOP)/mk/boilerplate.mk
...@@ -25,6 +25,9 @@ endif ...@@ -25,6 +25,9 @@ endif
# ----------------------------------------------------------------------------- # -----------------------------------------------------------------------------
# Create compiler configuration # Create compiler configuration
#
# The 'echo' commands simply spit the values of various make variables
# into Config.hs, whence they can be compiled and used by GHC itself
CURRENT_DIR = ghc/compiler CURRENT_DIR = ghc/compiler
CONFIG_HS = main/Config.hs CONFIG_HS = main/Config.hs
...@@ -41,41 +44,31 @@ $(CONFIG_HS) : $(FPTOOLS_TOP)/mk/config.mk Makefile ...@@ -41,41 +44,31 @@ $(CONFIG_HS) : $(FPTOOLS_TOP)/mk/config.mk Makefile
@echo "cHscIfaceFileVersion = \"$(HscIfaceFileVersion)\"" >> $(CONFIG_HS) @echo "cHscIfaceFileVersion = \"$(HscIfaceFileVersion)\"" >> $(CONFIG_HS)
@echo "cHOSTPLATFORM = \"$(HOSTPLATFORM)\"" >> $(CONFIG_HS) @echo "cHOSTPLATFORM = \"$(HOSTPLATFORM)\"" >> $(CONFIG_HS)
@echo "cTARGETPLATFORM = \"$(TARGETPLATFORM)\"" >> $(CONFIG_HS) @echo "cTARGETPLATFORM = \"$(TARGETPLATFORM)\"" >> $(CONFIG_HS)
@echo "cCURRENT_DIR = \"$(CURRENT_DIR)\"" >> $(CONFIG_HS)
@echo "cGHC_LIB_DIR = \"$(GHC_LIB_DIR)\"" >> $(CONFIG_HS)
@echo "cGHC_RUNTIME_DIR = \"$(GHC_RUNTIME_DIR)\"" >> $(CONFIG_HS)
@echo "cGHC_UTILS_DIR = \"$(GHC_UTILS_DIR)\"" >> $(CONFIG_HS)
@echo "cGHC_INCLUDE_DIR = \"$(GHC_INCLUDE_DIR)\"" >> $(CONFIG_HS)
@echo "cGHC_DRIVER_DIR = \"$(GHC_DRIVER_DIR)\"" >> $(CONFIG_HS)
@echo "cGCC = \"$(WhatGccIsCalled)\"" >> $(CONFIG_HS)
@echo "cMkDLL = \"$(BLD_DLL)\"" >> $(CONFIG_HS)
@echo "cGhcWithNativeCodeGen = \"$(GhcWithNativeCodeGen)\"" >> $(CONFIG_HS) @echo "cGhcWithNativeCodeGen = \"$(GhcWithNativeCodeGen)\"" >> $(CONFIG_HS)
@echo "cGhcUnregisterised = \"$(GhcUnregisterised)\"" >> $(CONFIG_HS) @echo "cGhcUnregisterised = \"$(GhcUnregisterised)\"" >> $(CONFIG_HS)
@echo "cLeadingUnderscore = \"$(LeadingUnderscore)\"" >> $(CONFIG_HS) @echo "cLeadingUnderscore = \"$(LeadingUnderscore)\"" >> $(CONFIG_HS)
@echo "cRAWCPP = \"$(GHC_RAWCPP)\"" >> $(CONFIG_HS)
@echo "cGCC = \"$(WhatGccIsCalled)\"" >> $(CONFIG_HS)
@echo "cMkDLL = \"$(BLD_DLL)\"" >> $(CONFIG_HS)
@echo "cGHC_DRIVER_DIR = \"$(GHC_DRIVER_DIR)\"" >> $(CONFIG_HS)
@echo "cGHC_TOUCHY = \"$(GHC_TOUCHY)\"" >> $(CONFIG_HS)
@echo "cGHC_TOUCHY_DIR = \"$(GHC_TOUCHY)\"" >> $(CONFIG_HS)
@echo "cGHC_UNLIT = \"$(GHC_UNLIT)\"" >> $(CONFIG_HS) @echo "cGHC_UNLIT = \"$(GHC_UNLIT)\"" >> $(CONFIG_HS)
@echo "cGHC_UNLIT_DIR = \"$(GHC_UNLIT_DIR)\"" >> $(CONFIG_HS)
@echo "cGHC_MANGLER = \"$(GHC_MANGLER)\"" >> $(CONFIG_HS) @echo "cGHC_MANGLER = \"$(GHC_MANGLER)\"" >> $(CONFIG_HS)
@echo "cGHC_MANGLER_DIR = \"$(GHC_MANGLER_DIR)\"" >> $(CONFIG_HS)
@echo "cGHC_SPLIT = \"$(GHC_SPLIT)\"" >> $(CONFIG_HS) @echo "cGHC_SPLIT = \"$(GHC_SPLIT)\"" >> $(CONFIG_HS)
@echo "cGHC_SPLIT_DIR = \"$(GHC_SPLIT_DIR)\"" >> $(CONFIG_HS)
@echo "cGHC_SYSMAN = \"$(GHC_SYSMAN)\"" >> $(CONFIG_HS) @echo "cGHC_SYSMAN = \"$(GHC_SYSMAN)\"" >> $(CONFIG_HS)
@echo "cGHC_SYSMAN_DIR = \"$(GHC_SYSMAN_DIR)\"" >> $(CONFIG_HS)
@echo "cGHC_CP = \"$(GHC_CP)\"" >> $(CONFIG_HS)
@echo "cGHC_PERL = \"$(GHC_PERL)\"" >> $(CONFIG_HS)
@echo "cEnableWin32DLLs = \"$(EnableWin32DLLs)\"" >> $(CONFIG_HS) @echo "cEnableWin32DLLs = \"$(EnableWin32DLLs)\"" >> $(CONFIG_HS)
ifeq "$(TARGETPLATFORM) and $(MinimalUnixDeps)" "i386-unknown-mingw32 and YES"
@echo "cCP = \"copy /y\"" >> $(CONFIG_HS)
@echo "cRM = \"del /F /Q\"" >> $(CONFIG_HS)
@echo "cTOUCH = \"$(GHC_TOUCHY)\"" >> $(CONFIG_HS)
else
@echo "cCP = \"$(CP)\"" >> $(CONFIG_HS)
@echo "cRM = \"$(RM)\"" >> $(CONFIG_HS)
@echo "cTOUCH = \"touch\"" >> $(CONFIG_HS)
endif
@echo "cCONTEXT_DIFF = \"$(CONTEXT_DIFF)\"" >> $(CONFIG_HS) @echo "cCONTEXT_DIFF = \"$(CONTEXT_DIFF)\"" >> $(CONFIG_HS)
@echo "cHaveLibGmp = \"$(HaveLibGmp)\"" >> $(CONFIG_HS) @echo "cHaveLibGmp = \"$(HaveLibGmp)\"" >> $(CONFIG_HS)
@echo "cUSER_WAY_NAMES = \"$(USER_WAY_NAMES)\"" >> $(CONFIG_HS) @echo "cUSER_WAY_NAMES = \"$(USER_WAY_NAMES)\"" >> $(CONFIG_HS)
@echo "cUSER_WAY_OPTS = \"$(USER_WAY_OPTS)\"" >> $(CONFIG_HS) @echo "cUSER_WAY_OPTS = \"$(USER_WAY_OPTS)\"" >> $(CONFIG_HS)
@echo "cDEFAULT_TMPDIR = \"$(DEFAULT_TMPDIR)\"" >> $(CONFIG_HS) @echo "cDEFAULT_TMPDIR = \"$(DEFAULT_TMPDIR)\"" >> $(CONFIG_HS)
ifeq "$(TARGETPLATFORM) and $(MinimalUnixDeps)" "i386-unknown-mingw32 and YES"
@echo "cRAWCPP = \"$(subst -mwin32,,$(RAWCPP))\"" >> $(CONFIG_HS)
else
@echo "cRAWCPP = \"$(RAWCPP)\"" >> $(CONFIG_HS)
endif
@echo done. @echo done.
CLEAN_FILES += $(CONFIG_HS) CLEAN_FILES += $(CONFIG_HS)
...@@ -250,7 +243,7 @@ main/DriverPipeline_HC_OPTS = -fno-cse ...@@ -250,7 +243,7 @@ main/DriverPipeline_HC_OPTS = -fno-cse
main/DriverState_HC_OPTS = -fno-cse main/DriverState_HC_OPTS = -fno-cse
main/DriverUtil_HC_OPTS = -fno-cse main/DriverUtil_HC_OPTS = -fno-cse
main/Finder_HC_OPTS = -fno-cse main/Finder_HC_OPTS = -fno-cse
main/TmpFiles_HC_OPTS = -fno-cse main/SysTools_HC_OPTS = -fno-cse
# ---------------------------------------------------------------------------- # ----------------------------------------------------------------------------
# C compilations # C compilations
......
...@@ -104,6 +104,8 @@ LocalId and GlobalId ...@@ -104,6 +104,8 @@ LocalId and GlobalId
A GlobalId is A GlobalId is
* always a constant (top-level) * always a constant (top-level)
* imported, or data constructor, or primop, or record selector * imported, or data constructor, or primop, or record selector
* has a Unique that is globally unique across the whole
GHC invocation (a single invocation may compile multiple modules)
A LocalId is A LocalId is
* bound within an expression (lambda, case, local let(rec)) * bound within an expression (lambda, case, local let(rec))
......
...@@ -35,9 +35,8 @@ import FiniteMap ...@@ -35,9 +35,8 @@ import FiniteMap
import Outputable import Outputable
import ErrUtils ( showPass ) import ErrUtils ( showPass )
import CmdLineOpts ( DynFlags(..) ) import CmdLineOpts ( DynFlags(..) )
import Panic ( panic, GhcException(..) ) import Panic ( panic )
import Exception
import List import List
import Monad import Monad
import IO import IO
...@@ -219,9 +218,6 @@ link' Interactive dflags batch_attempt_linking linkables pls ...@@ -219,9 +218,6 @@ link' Interactive dflags batch_attempt_linking linkables pls
linkObjs (objs ++ bcos) pls linkObjs (objs ++ bcos) pls
-- get the objects first -- get the objects first
ppLinkableSCC :: SCC Linkable -> SDoc
ppLinkableSCC = ppr . flattenSCC
filterModuleLinkables :: (ModuleName -> Bool) -> [Linkable] -> [Linkable] filterModuleLinkables :: (ModuleName -> Bool) -> [Linkable] -> [Linkable]
filterModuleLinkables p [] = [] filterModuleLinkables p [] = []
filterModuleLinkables p (li:lis) filterModuleLinkables p (li:lis)
......
...@@ -55,8 +55,8 @@ import UniqFM ...@@ -55,8 +55,8 @@ import UniqFM
import Unique ( Uniquable ) import Unique ( Uniquable )
import Digraph ( SCC(..), stronglyConnComp, flattenSCC ) import Digraph ( SCC(..), stronglyConnComp, flattenSCC )
import ErrUtils ( showPass ) import ErrUtils ( showPass )
import SysTools ( cleanTempFilesExcept )
import Util import Util
import TmpFiles
import Outputable import Outputable
import Panic import Panic
import CmdLineOpts ( DynFlags(..) ) import CmdLineOpts ( DynFlags(..) )
......
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- $Id: InteractiveUI.hs,v 1.73 2001/06/07 16:00:18 sewardj Exp $ -- $Id: InteractiveUI.hs,v 1.74 2001/06/14 12:50:06 simonpj Exp $
-- --
-- GHC Interactive User Interface -- GHC Interactive User Interface
-- --
...@@ -24,7 +24,7 @@ import Finder ( flushPackageCache ) ...@@ -24,7 +24,7 @@ import Finder ( flushPackageCache )
import Util import Util
import Name ( Name ) import Name ( Name )
import Outputable import Outputable
import CmdLineOpts ( DynFlag(..), dopt_unset ) import CmdLineOpts ( DynFlag(..), getDynFlags, saveDynFlags, restoreDynFlags, dopt_unset )
import Panic ( GhcException(..) ) import Panic ( GhcException(..) )
import Config import Config
...@@ -302,7 +302,7 @@ runStmt stmt ...@@ -302,7 +302,7 @@ runStmt stmt
= return Nothing = return Nothing
| otherwise | otherwise
= do st <- getGHCiState = do st <- getGHCiState
dflags <- io (getDynFlags) dflags <- io getDynFlags
let dflags' = dopt_unset dflags Opt_WarnUnusedBinds let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
(new_cmstate, names) <- io (cmRunStmt (cmstate st) dflags' stmt) (new_cmstate, names) <- io (cmRunStmt (cmstate st) dflags' stmt)
setGHCiState st{cmstate = new_cmstate} setGHCiState st{cmstate = new_cmstate}
...@@ -396,7 +396,7 @@ defineMacro s = do ...@@ -396,7 +396,7 @@ defineMacro s = do
-- compile the expression -- compile the expression
st <- getGHCiState st <- getGHCiState
dflags <- io (getDynFlags) dflags <- io getDynFlags
(new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr) (new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
setGHCiState st{cmstate = new_cmstate} setGHCiState st{cmstate = new_cmstate}
case maybe_hv of case maybe_hv of
...@@ -427,7 +427,7 @@ loadModule path = timeIt (loadModule' path) ...@@ -427,7 +427,7 @@ loadModule path = timeIt (loadModule' path)
loadModule' path = do loadModule' path = do
state <- getGHCiState state <- getGHCiState
dflags <- io (getDynFlags) dflags <- io getDynFlags
cmstate1 <- io (cmUnload (cmstate state) dflags) cmstate1 <- io (cmUnload (cmstate state) dflags)
setGHCiState state{ cmstate = cmstate1, target = Nothing } setGHCiState state{ cmstate = cmstate1, target = Nothing }
io (revertCAFs) -- always revert CAFs on load. io (revertCAFs) -- always revert CAFs on load.
...@@ -464,7 +464,7 @@ modulesLoadedMsg ok mods = do ...@@ -464,7 +464,7 @@ modulesLoadedMsg ok mods = do
typeOfExpr :: String -> GHCi () typeOfExpr :: String -> GHCi ()
typeOfExpr str typeOfExpr str
= do st <- getGHCiState = do st <- getGHCiState
dflags <- io (getDynFlags) dflags <- io getDynFlags
(new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str) (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
setGHCiState st{cmstate = new_cmstate} setGHCiState st{cmstate = new_cmstate}
case maybe_tystr of case maybe_tystr of
...@@ -513,11 +513,9 @@ setOptions str ...@@ -513,11 +513,9 @@ setOptions str
-- then, dynamic flags -- then, dynamic flags
io $ do io $ do
dyn_flags <- readIORef v_InitDynFlags restoreDynFlags
writeIORef v_DynFlags dyn_flags
leftovers <- processArgs dynamic_flags leftovers [] leftovers <- processArgs dynamic_flags leftovers []
dyn_flags <- readIORef v_DynFlags saveDynFlags
writeIORef v_InitDynFlags dyn_flags
if (not (null leftovers)) if (not (null leftovers))
then throwDyn (CmdLineError ("unrecognised flags: " ++ then throwDyn (CmdLineError ("unrecognised flags: " ++
...@@ -572,7 +570,7 @@ optToStr RevertCAFs = "r" ...@@ -572,7 +570,7 @@ optToStr RevertCAFs = "r"
newPackages new_pkgs = do newPackages new_pkgs = do
state <- getGHCiState state <- getGHCiState
dflags <- io (getDynFlags) dflags <- io getDynFlags
cmstate1 <- io (cmUnload (cmstate state) dflags) cmstate1 <- io (cmUnload (cmstate state) dflags)
setGHCiState state{ cmstate = cmstate1, target = Nothing } setGHCiState state{ cmstate = cmstate1, target = Nothing }
......
...@@ -14,7 +14,6 @@ module CmdLineOpts ( ...@@ -14,7 +14,6 @@ module CmdLineOpts (
HscLang(..), HscLang(..),
DynFlag(..), -- needed non-abstractly by DriverFlags DynFlag(..), -- needed non-abstractly by DriverFlags
DynFlags(..), DynFlags(..),
defaultDynFlags,
v_Static_hsc_opts, v_Static_hsc_opts,
...@@ -22,26 +21,35 @@ module CmdLineOpts ( ...@@ -22,26 +21,35 @@ module CmdLineOpts (
switchIsOn, switchIsOn,
isStaticHscFlag, isStaticHscFlag,
opt_PprStyle_NoPrags, -- Manipulating DynFlags
opt_PprStyle_RawTypes, defaultDynFlags, -- DynFlags
opt_PprUserLength, dopt, -- DynFlag -> DynFlags -> Bool
opt_PprStyle_Debug, dopt_set, dopt_unset, -- DynFlags -> DynFlag -> DynFlags
dopt_CoreToDo, -- DynFlags -> [CoreToDo]
dopt, dopt_StgToDo, -- DynFlags -> [StgToDo]
dopt_set, dopt_HscLang, -- DynFlags -> HscLang
dopt_unset, dopt_OutName, -- DynFlags -> String
-- other dynamic flags -- Manipulating the DynFlags state
dopt_CoreToDo, getDynFlags, -- IO DynFlags
dopt_StgToDo, setDynFlags, -- DynFlags -> IO ()
dopt_HscLang, updDynFlags, -- (DynFlags -> DynFlags) -> IO ()
dopt_OutName, dynFlag, -- (DynFlags -> a) -> IO a
setDynFlag, unSetDynFlag, -- DynFlag -> IO ()
saveDynFlags, -- IO ()
restoreDynFlags, -- IO DynFlags
-- sets of warning opts -- sets of warning opts
standardWarnings, standardWarnings,
minusWOpts, minusWOpts,
minusWallOpts, minusWallOpts,
-- Output style options
opt_PprStyle_NoPrags,
opt_PprStyle_RawTypes,
opt_PprUserLength,
opt_PprStyle_Debug,
-- profiling opts -- profiling opts
opt_AutoSccsOnAllToplevs, opt_AutoSccsOnAllToplevs,
opt_AutoSccsOnExportedToplevs, opt_AutoSccsOnExportedToplevs,
...@@ -108,7 +116,7 @@ module CmdLineOpts ( ...@@ -108,7 +116,7 @@ module CmdLineOpts (
import Array ( array, (//) ) import Array ( array, (//) )
import GlaExts import GlaExts
import IOExts ( IORef, readIORef ) import IOExts ( IORef, readIORef, writeIORef )
import Constants -- Default values for some flags import Constants -- Default values for some flags
import Util import Util
import FastTypes import FastTypes
...@@ -312,6 +320,14 @@ data DynFlags = DynFlags { ...@@ -312,6 +320,14 @@ data DynFlags = DynFlags {
flags :: [DynFlag] flags :: [DynFlag]
} }
data HscLang
= HscC
| HscAsm
| HscJava
| HscILX
| HscInterpreted
deriving (Eq, Show)
defaultDynFlags = DynFlags { defaultDynFlags = DynFlags {
coreToDo = [], stgToDo = [], coreToDo = [], stgToDo = [],
hscLang = HscC, hscLang = HscC,
...@@ -353,24 +369,61 @@ dopt_StgToDo = stgToDo ...@@ -353,24 +369,61 @@ dopt_StgToDo = stgToDo
dopt_OutName :: DynFlags -> String dopt_OutName :: DynFlags -> String
dopt_OutName = hscOutName dopt_OutName = hscOutName
dopt_HscLang :: DynFlags -> HscLang
dopt_HscLang = hscLang
dopt_set :: DynFlags -> DynFlag -> DynFlags dopt_set :: DynFlags -> DynFlag -> DynFlags
dopt_set dfs f = dfs{ flags = f : flags dfs } dopt_set dfs f = dfs{ flags = f : flags dfs }
dopt_unset :: DynFlags -> DynFlag -> DynFlags dopt_unset :: DynFlags -> DynFlag -> DynFlags
dopt_unset dfs f = dfs{ flags = filter (/= f) (flags dfs) } dopt_unset dfs f = dfs{ flags = filter (/= f) (flags dfs) }
\end{code}
data HscLang -----------------------------------------------------------------------------
= HscC -- Mess about with the mutable variables holding the dynamic arguments
| HscAsm
| HscJava
| HscILX
| HscInterpreted
deriving (Eq, Show)
dopt_HscLang :: DynFlags -> HscLang -- v_InitDynFlags
dopt_HscLang = hscLang -- is the "baseline" dynamic flags, initialised from
-- the defaults and command line options, and updated by the
-- ':s' command in GHCi.
--
-- v_DynFlags
-- is the dynamic flags for the current compilation. It is reset
-- to the value of v_InitDynFlags before each compilation, then
-- updated by reading any OPTIONS pragma in the current module.
\begin{code}
GLOBAL_VAR(v_InitDynFlags, defaultDynFlags, DynFlags)
GLOBAL_VAR(v_DynFlags, defaultDynFlags, DynFlags)
setDynFlags :: DynFlags -> IO ()
setDynFlags dfs = writeIORef v_DynFlags dfs
saveDynFlags :: IO ()
saveDynFlags = do dfs <- readIORef v_DynFlags
writeIORef v_InitDynFlags dfs
restoreDynFlags :: IO DynFlags
restoreDynFlags = do dfs <- readIORef v_InitDynFlags
writeIORef v_DynFlags dfs
return dfs
getDynFlags :: IO DynFlags
getDynFlags = readIORef v_DynFlags
updDynFlags :: (DynFlags -> DynFlags) -> IO ()
updDynFlags f = do dfs <- readIORef v_DynFlags
writeIORef v_DynFlags (f dfs)
dynFlag :: (DynFlags -> a) -> IO a
dynFlag f = do dflags <- readIORef v_DynFlags; return (f dflags)
setDynFlag, unSetDynFlag :: DynFlag -> IO ()
setDynFlag f = updDynFlags (\dfs -> dopt_set dfs f)
unSetDynFlag f = updDynFlags (\dfs -> dopt_unset dfs f)
\end{code} \end{code}
%************************************************************************ %************************************************************************
%* * %* *
\subsection{Warnings} \subsection{Warnings}
......
{-# OPTIONS -#include "hschooks.h" #-} {-# OPTIONS -#include "hschooks.h" #-}
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- $Id: DriverFlags.hs,v 1.57 2001/06/13 15:50:25 rrt Exp $ -- $Id: DriverFlags.hs,v 1.58 2001/06/14 12:50:06 simonpj Exp $
-- --
-- Driver flags -- Driver flags
-- --
...@@ -11,10 +11,9 @@ ...@@ -11,10 +11,9 @@
module DriverFlags ( module DriverFlags (
processArgs, OptKind(..), static_flags, dynamic_flags, processArgs, OptKind(..), static_flags, dynamic_flags,
v_InitDynFlags, v_DynFlags, getDynFlags, dynFlag, getDynFlags, dynFlag,
getOpts, getVerbFlag, addCmdlineHCInclude, getOpts, getVerbFlag, addCmdlineHCInclude,
buildStaticHscOpts, buildStaticHscOpts,
runSomething,
machdepCCOpts machdepCCOpts
) where ) where
...@@ -22,7 +21,7 @@ module DriverFlags ( ...@@ -22,7 +21,7 @@ module DriverFlags (
import DriverState import DriverState
import DriverUtil import DriverUtil
import TmpFiles ( v_TmpDir ) import SysTools ( setTmpDir, setPgm, setDryRun, showGhcUsage )
import CmdLineOpts import CmdLineOpts
import Config import Config
import Util import Util
...@@ -30,11 +29,11 @@ import Panic ...@@ -30,11 +29,11 @@ import Panic
import Exception import Exception
import IOExts import IOExts
import System ( exitWith, ExitCode(..) )
import IO import IO
import Maybe import Maybe
import Monad import Monad
import System
import Char import Char
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
...@@ -71,15 +70,15 @@ data OptKind ...@@ -71,15 +70,15 @@ data OptKind
| AnySuffixPred (String -> Bool) (String -> IO ()) | AnySuffixPred (String -> Bool) (String -> IO ())
processArgs :: [(String,OptKind)] -> [String] -> [String] processArgs :: [(String,OptKind)] -> [String] -> [String]
-> IO [String] -- returns spare args -> IO [String] -- returns spare args
processArgs _spec [] spare = return (reverse spare) processArgs _spec [] spare = return (reverse spare)
processArgs spec args@(('-':arg):args') spare = do processArgs spec args@(('-':arg):args') spare = do
case findArg spec arg of case findArg spec arg of
Just (rest,action) -> Just (rest,action) -> do args' <- processOneArg action rest args
do args' <- processOneArg action rest args processArgs spec args' spare
processArgs spec args' spare Nothing -> processArgs spec args' (('-':arg):spare)
Nothing ->
processArgs spec args' (('-':arg):spare)
processArgs spec (arg:args) spare = processArgs spec (arg:args) spare =
processArgs spec args (arg:spare) processArgs spec args (arg:spare)
...@@ -127,7 +126,8 @@ processOneArg action rest (dash_arg@('-':arg):args) = ...@@ -127,7 +126,8 @@ processOneArg action rest (dash_arg@('-':arg):args) =
findArg :: [(String,OptKind)] -> String -> Maybe (String,OptKind) findArg :: [(String,OptKind)] -> String -> Maybe (String,OptKind)
findArg spec arg findArg spec arg
= case [ (remove_spaces rest, k) = case [ (remove_spaces rest, k)
| (pat,k) <- spec, Just rest <- [my_prefix_match pat arg], | (pat,k) <- spec,
Just rest <- [my_prefix_match pat arg],
arg_ok k rest arg ] arg_ok k rest arg ]
of of
[] -> Nothing [] -> Nothing
...@@ -152,8 +152,8 @@ arg_ok (AnySuffixPred p _) rest arg = p arg ...@@ -152,8 +152,8 @@ arg_ok (AnySuffixPred p _) rest arg = p arg
static_flags = static_flags =
[ ------- help ------------------------------------------------------- [ ------- help -------------------------------------------------------
( "?" , NoArg long_usage) ( "?" , NoArg showGhcUsage)
, ( "-help" , NoArg long_usage) , ( "-help" , NoArg showGhcUsage)
------- version ---------------------------------------------------- ------- version ----------------------------------------------------
...@@ -164,7 +164,7 @@ static_flags = ...@@ -164,7 +164,7 @@ static_flags =
exitWith ExitSuccess)) exitWith ExitSuccess))
------- verbosity ---------------------------------------------------- ------- verbosity ----------------------------------------------------
, ( "n" , NoArg (writeIORef v_Dry_run True) ) , ( "n" , NoArg setDryRun )
------- recompilation checker -------------------------------------- ------- recompilation checker --------------------------------------
, ( "recomp" , NoArg (writeIORef v_Recomp True) ) , ( "recomp" , NoArg (writeIORef v_Recomp True) )
...@@ -210,7 +210,7 @@ static_flags = ...@@ -210,7 +210,7 @@ static_flags =
, ( "hisuf" , HasArg (writeIORef v_Hi_suf) ) , ( "hisuf" , HasArg (writeIORef v_Hi_suf) )
, ( "hidir" , HasArg (writeIORef v_Hi_dir . Just) ) , ( "hidir" , HasArg (writeIORef v_Hi_dir . Just) )
, ( "buildtag" , HasArg (writeIORef v_Build_tag) ) , ( "buildtag" , HasArg (writeIORef v_Build_tag) )
, ( "tmpdir" , HasArg (writeIORef v_TmpDir . (++ "/")) ) , ( "tmpdir" , HasArg setTmpDir)
, ( "ohi" , HasArg (writeIORef v_Output_hi . Just) )