Commit 4ba55934 authored by simonmar's avatar simonmar
Browse files

[project @ 2000-10-11 14:08:52 by simonmar]

getting there...
parent 9a219892
......@@ -160,7 +160,7 @@ import Array ( array, (//) )
import GlaExts
import Argv
import Constants -- Default values for some flags
import DriverUtil
import Util
import Maybes ( firstJust )
import Panic ( panic )
......
-----------------------------------------------------------------------------
-- $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
--
......@@ -94,6 +94,10 @@ cHaskell1Version = "5" -- i.e., Haskell 98
-----------------------------------------------------------------------------
-- 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
......@@ -412,7 +416,7 @@ addToDirList ref path
-----------------------------------------------------------------------------
-- 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]
......@@ -652,14 +656,14 @@ way_details =
-----------------------------------------------------------------------------
-- 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
--
......@@ -17,6 +17,7 @@ import Util
import IOExts
import Exception
import Dynamic
import RegexString
import IO
import System
......@@ -30,9 +31,10 @@ import Monad
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
......@@ -70,28 +72,27 @@ instance Typeable BarfKind where
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
......@@ -111,15 +112,6 @@ my_prefix_match (p:pat) (r:rest)
| 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
--
......@@ -196,33 +196,9 @@ makeHiMap
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
......@@ -259,9 +235,41 @@ main =
-- 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)
......@@ -292,14 +300,16 @@ main =
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
......@@ -328,34 +338,46 @@ main =
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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment