Commit 292c077d authored by simonmar's avatar simonmar

[project @ 2000-11-16 11:39:36 by simonmar]

Current state of the interactive system; can load packages (in theory).
parent 8894fd85
# -----------------------------------------------------------------------------
# $Id: Makefile,v 1.113 2000/11/10 14:29:20 simonmar Exp $
# $Id: Makefile,v 1.114 2000/11/16 11:39:36 simonmar Exp $
TOP = ..
include $(TOP)/mk/boilerplate.mk
......@@ -175,12 +175,12 @@ SRC_HC_OPTS += \
ghc_407_at_least = $(shell expr "$(GhcMinVersion)" \>= 7)
ifeq "$(ghc_407_at_least)" "1"
ifneq "$(mingw32_TARGET_OS)" "1"
SRC_HC_OPTS += -package concurrent -package posix -package text
SRC_HC_OPTS += -package concurrent -package posix -package text -package util
else
SRC_HC_OPTS += -package concurrent -package text
SRC_HC_OPTS += -package concurrent -package text -package util
endif
else
SRC_HC_OPTS += -syslib concurrent -syslib posix -syslib misc
SRC_HC_OPTS += -syslib concurrent -syslib posix -syslib misc -syslib util
endif
SRC_CC_OPTS += -Iparser -I. -I$(TOP)/includes -O
......
......@@ -33,7 +33,6 @@ module Module
, moduleString -- :: Module -> EncodedString
, moduleUserString -- :: Module -> UserString
, moduleName -- :: Module -> ModuleName
, mkVanillaModule -- :: ModuleName -> Module
, mkPrelModule -- :: UserString -> Module
......
......@@ -18,6 +18,7 @@ import Interpreter
import CmStaticInfo ( PackageConfigInfo, GhciMode(..) )
import Module ( ModuleName, PackageName )
import Outputable ( SDoc )
import FiniteMap
import Digraph ( SCC(..), flattenSCC )
import Outputable
import Panic ( panic )
......@@ -145,7 +146,6 @@ link doLink Interactive batch_attempt_linking linkables pls1
= do putStrLn "LINKER(interactive): not yet implemented"
return (LinkOK pls1)
ppLinkableSCC :: SCC Linkable -> SDoc
ppLinkableSCC = ppr . flattenSCC
......
-----------------------------------------------------------------------------
-- $Id: InteractiveUI.hs,v 1.1 2000/11/16 10:48:22 simonmar Exp $
-- $Id: InteractiveUI.hs,v 1.2 2000/11/16 11:39:37 simonmar Exp $
--
-- GHC Interactive User Interface
--
......@@ -7,14 +7,20 @@
--
-----------------------------------------------------------------------------
module InteractiveUI where
module InteractiveUI (interactiveUI) where
import CompManager
import CmStaticInfo
import DriverUtil
import DriverState
import Linker
import Module
import Panic
import Util
import Exception
import Readline
import IOExts
import System
import Directory
......@@ -61,9 +67,14 @@ helpText = "\
interactiveUI :: CmState -> IO ()
interactiveUI st = do
hPutStr stdout ghciWelcomeMsg
hPutStrLn stdout ghciWelcomeMsg
hFlush stdout
hSetBuffering stdout NoBuffering
-- link in the available packages
pkgs <- getPackageInfo
linkPackages (reverse pkgs)
#ifndef NO_READLINE
Readline.initialize
#endif
......@@ -108,7 +119,7 @@ specialCommand str = do
" matches multiple commands (" ++
foldr1 (\a b -> a ++ ',':b) (map fst cs) ++ ")")
noArgs c = io (hPutStr stdout ("command `:" ++ c ++ "' takes no arguments"))
noArgs c = io (hPutStrLn stdout ("command `:" ++ c ++ "' takes no arguments"))
-----------------------------------------------------------------------------
-- Commands
......@@ -131,7 +142,7 @@ reloadModule :: String -> GHCi ()
reloadModule "" = do
state <- getGHCiState
case target state of
Nothing -> io (hPutStr stdout "no current target")
Nothing -> io (putStr "no current target\n")
Just path -> do (new_cmstate, mod) <- io (cmLoadModule (cmstate state) (mkModuleName path))
setGHCiState state{cmstate=new_cmstate}
reloadModule _ = noArgs ":reload"
......@@ -169,4 +180,34 @@ setGHCiState s = GHCi $ \_ -> return (s,())
io m = GHCi $ \s -> m >>= \a -> return (s,a)
myCatch (GHCi m) h = GHCi $ \s -> catch (m s) (\e -> unGHCi (h e) s)
myCatch (GHCi m) h = GHCi $ \s -> Exception.catch (m s) (\e -> unGHCi (h e) s)
-----------------------------------------------------------------------------
-- package loader
linkPackages :: [Package] -> IO ()
linkPackages pkgs = mapM_ linkPackage pkgs
linkPackage :: Package -> IO ()
-- ignore rts and gmp for now (ToDo; better?)
linkPackage pkg | name pkg `elem` ["rts", "gmp"] = return ()
linkPackage pkg = do
putStr ("Loading package " ++ name pkg ++ " ... ")
let dirs = library_dirs pkg
let objs = map (++".o") (hs_libraries pkg ++ extra_libraries pkg)
mapM (linkOneObj dirs) objs
putStr "resolving ... "
resolveObjs
putStrLn "done."
linkOneObj dirs obj = do
filename <- findFile dirs obj
loadObj filename
findFile [] obj = throwDyn (OtherError ("can't find " ++ obj))
findFile (d:ds) obj = do
let path = d ++ '/':obj
b <- doesFileExist path
if b then return path else findFile ds obj
......@@ -10,47 +10,13 @@ module Linker (
unloadObj, -- :: String -> IO ()
lookupSymbol, -- :: String -> IO (Maybe Addr)
resolveObjs, -- :: IO ()
linkPrelude -- tmp
) where
import IO
import Exception
import Addr
import PrelByteArr
import PrelPack (packString)
import Panic ( panic )
#if __GLASGOW_HASKELL__ <= 408
loadObj = bogus "loadObj"
unloadObj = bogus "unloadObj"
lookupSymbol = bogus "lookupSymbol"
resolveObjs = bogus "resolveObjs"
linkPrelude = bogus "linkPrelude"
bogus f = panic ("Linker." ++ f ++ ": this hsc was built without an interpreter.")
#else
linkPrelude = do
hPutStr stderr "Loading HSstd_cbits.o..."
loadObj "/home/simonmar/builds/i386-unknown-linux-boot/ghc/lib/std/cbits/HSstd_cbits.o"
hPutStr stderr "done.\n"
hPutStr stderr "Resolving..."
resolveObjs
hPutStr stderr "done.\n"
hPutStr stderr "Loading HSstd.o..."
loadObj "/home/simonmar/builds/i386-unknown-linux-boot/ghc/lib/std/HSstd.o"
hPutStr stderr "done.\n"
hPutStr stderr "Resolving..."
resolveObjs
hPutStr stderr "done.\n"
{-
hPutStr stderr "Unloading HSstd.o..."
unloadObj "/home/simonmar/builds/i386-unknown-linux-boot/ghc/lib/std/HSstd.o"
hPutStr stderr "done.\n"
unloadObj "/home/simonmar/builds/i386-unknown-linux-boot/ghc/lib/std/cbits/HSstd_cbits.o"
hPutStr stderr "done.\n"
-}
-- ---------------------------------------------------------------------------
-- RTS Linker Interface
-- ---------------------------------------------------------------------------
......@@ -64,19 +30,19 @@ lookupSymbol str = do
loadObj str = do
r <- c_loadObj (packString str)
if (r == 0)
then error "loadObj: failed"
then panic "loadObj: failed"
else return ()
unloadObj str = do
r <- c_unloadObj (packString str)
if (r == 0)
then error "unloadObj: failed"
then panic "unloadObj: failed"
else return ()
resolveObjs = do
r <- c_resolveObjs
if (r == 0)
then error "resolveObjs: failed"
then panic "resolveObjs: failed"
else return ()
......@@ -93,6 +59,4 @@ foreign import "unloadObj" unsafe
foreign import "resolveObjs" unsafe
c_resolveObjs :: IO Int
#endif /* __GLASGOW_HASKELL__ <= 408 */
\end{code}
-----------------------------------------------------------------------------
-- $Id: DriverState.hs,v 1.13 2000/11/14 16:28:38 simonmar Exp $
-- $Id: DriverState.hs,v 1.14 2000/11/16 11:39:37 simonmar Exp $
--
-- Settings for the driver
--
......@@ -439,56 +439,53 @@ addPackage package
getPackageImportPath :: IO [String]
getPackageImportPath = do
ps <- readIORef v_Packages
ps' <- getPackageDetails ps
return (nub (concat (map import_dirs ps')))
ps <- getPackageInfo
return (nub (concat (map import_dirs ps)))
getPackageIncludePath :: IO [String]
getPackageIncludePath = do
ps <- readIORef v_Packages
ps' <- getPackageDetails ps
return (nub (filter (not.null) (concatMap include_dirs ps')))
ps <- getPackageInfo
return (nub (filter (not.null) (concatMap include_dirs ps)))
-- includes are in reverse dependency order (i.e. rts first)
getPackageCIncludes :: IO [String]
getPackageCIncludes = do
ps <- readIORef v_Packages
ps' <- getPackageDetails ps
return (reverse (nub (filter (not.null) (concatMap c_includes ps'))))
ps <- getPackageInfo
return (reverse (nub (filter (not.null) (concatMap c_includes ps))))
getPackageLibraryPath :: IO [String]
getPackageLibraryPath = do
ps <- readIORef v_Packages
ps' <- getPackageDetails ps
return (nub (concat (map library_dirs ps')))
ps <- getPackageInfo
return (nub (concat (map library_dirs ps)))
getPackageLibraries :: IO [String]
getPackageLibraries = do
ps <- readIORef v_Packages
ps' <- getPackageDetails ps
ps <- getPackageInfo
tag <- readIORef v_Build_tag
let suffix = if null tag then "" else '_':tag
return (concat (
map (\p -> map (++suffix) (hs_libraries p) ++ extra_libraries p) ps'
map (\p -> map (++suffix) (hs_libraries p) ++ extra_libraries p) ps
))
getPackageExtraGhcOpts :: IO [String]
getPackageExtraGhcOpts = do
ps <- readIORef v_Packages
ps' <- getPackageDetails ps
return (concatMap extra_ghc_opts ps')
ps <- getPackageInfo
return (concatMap extra_ghc_opts ps)
getPackageExtraCcOpts :: IO [String]
getPackageExtraCcOpts = do
ps <- readIORef v_Packages
ps' <- getPackageDetails ps
return (concatMap extra_cc_opts ps')
ps <- getPackageInfo
return (concatMap extra_cc_opts ps)
getPackageExtraLdOpts :: IO [String]
getPackageExtraLdOpts = do
ps <- getPackageInfo
return (concatMap extra_ld_opts ps)
getPackageInfo :: IO [Package]
getPackageInfo = do
ps <- readIORef v_Packages
ps' <- getPackageDetails ps
return (concatMap extra_ld_opts ps')
getPackageDetails ps
getPackageDetails :: [String] -> IO [Package]
getPackageDetails ps = do
......
-----------------------------------------------------------------------------
-- $Id: DriverUtil.hs,v 1.6 2000/11/10 14:29:21 simonmar Exp $
-- $Id: DriverUtil.hs,v 1.7 2000/11/16 11:39:37 simonmar Exp $
--
-- Utils for the driver
--
......@@ -70,6 +70,7 @@ instance Typeable BarfKind where
-----------------------------------------------------------------------------
-- Reading OPTIONS pragmas
getOptionsFromSource
:: String -- input file
-> IO [String] -- options, if any
......
......@@ -14,7 +14,7 @@ import IO ( hPutStrLn, stderr )
import HsSyn
import StringBuffer ( hGetStringBuffer )
import Parser ( parse )
import Parser
import Lex ( PState(..), ParseResult(..) )
import SrcLoc ( mkSrcLoc )
......@@ -263,7 +263,8 @@ myParseModule dflags src_filename
PFailed err -> do { hPutStrLn stderr (showSDoc err);
return Nothing };
POk _ rdr_module@(HsModule mod_name _ _ _ _ _ _) -> do {
POk _ (PModule rdr_module@(HsModule mod_name _ _ _ _ _ _)) -> do {
dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
......
{-# OPTIONS -W -fno-warn-incomplete-patterns #-}
-----------------------------------------------------------------------------
-- $Id: Main.hs,v 1.22 2000/11/15 10:49:54 sewardj Exp $
-- $Id: Main.hs,v 1.23 2000/11/16 11:39:37 simonmar Exp $
--
-- GHC Driver program
--
......@@ -16,6 +16,7 @@ module Main (main) where
#include "HsVersions.h"
import CompManager
import InteractiveUI
import DriverPipeline
import DriverState
import DriverFlags
......@@ -281,25 +282,12 @@ beginMake pkg_details mods
_ -> throwDyn (UsageError "only one module allowed with --make")
beginInteractive pkg_details mods
= do case mods of
[] -> return ()
[mod] -> do state <- cmInit pkg_details Interactive
cmLoadModule state (mkModuleName mod)
return ()
_ -> throwDyn (UsageError
= do state <- cmInit pkg_details Interactive
case mods of
[] -> return ()
[mod] -> do cmLoadModule state (mkModuleName mod); return ()
_ -> throwDyn (UsageError
"only one module allowed with --interactive")
interactiveUI
interactiveUI :: IO ()
interactiveUI = do
hPutStr stdout ghciWelcomeMsg
throwDyn (OtherError "GHCi not implemented yet")
ghciWelcomeMsg = "\
\ _____ __ __ ____ ------------------------------------------------\n\
\(| || || (| |) GHCi: GHC Interactive, version 5.00 \n\
\|| __ ||___|| || () For Haskell 98. \n\
\|| |) ||---|| || // http://www.haskell.org/ghc \n\
\|| || || || || // Bug reports to: glasgow-haskell-bugs@haskell.org\n\
\(|___|| || || (|__|) (| ________________________________________________\n"
interactiveUI state
......@@ -123,6 +123,7 @@ data Token
| ITccallconv
| ITinterface -- interface keywords
| ITexpr
| IT__export
| ITdepends
| IT__forall
......@@ -295,6 +296,7 @@ ghcExtensionKeywordsFM = listToUFM $
-- interface keywords
("__interface", ITinterface),
("__expr", ITexpr),
("__export", IT__export),
("__depends", ITdepends),
("__forall", IT__forall),
......
{-
-----------------------------------------------------------------------------
$Id: Parser.y,v 1.47 2000/11/07 15:21:40 simonmar Exp $
$Id: Parser.y,v 1.48 2000/11/16 11:39:37 simonmar Exp $
Haskell grammar.
......@@ -9,7 +9,7 @@ Author(s): Simon Marlow, Sven Panne 1997, 1998, 1999
-}
{
module Parser ( parse ) where
module Parser ( ParseStuff(..), parse ) where
import HsSyn
import HsTypes ( mkHsTupCon )
......@@ -113,6 +113,8 @@ Conflicts: 14 shift/reduce
'{-# DEPRECATED' { ITdeprecated_prag }
'#-}' { ITclose_prag }
'__expr' { ITexpr }
{-
'__interface' { ITinterface } -- interface keywords
'__export' { IT__export }
......@@ -201,6 +203,13 @@ Conflicts: 14 shift/reduce
%tokentype { Token }
%%
-----------------------------------------------------------------------------
-- Entry points
parse :: { ParseStuff }
: module { PModule $1 }
| '__expr' exp { PExpr $2 }
-----------------------------------------------------------------------------
-- Module Header
......@@ -1096,6 +1105,8 @@ commas :: { Int }
-----------------------------------------------------------------------------
{
data ParseStuff = PModule RdrNameHsModule | PExpr RdrNameHsExpr
happyError :: P a
happyError buf PState{ loc = loc } = PFailed (srcParseErr buf loc)
}
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