├── .gitignore ├── Child.hs ├── CodeSnippet.hs ├── GCCXML.hs ├── LICENSE ├── README ├── Repl.hs ├── Setup.lhs ├── TODO ├── c-repl ├── c-repl.cabal └── child.c /.gitignore: -------------------------------------------------------------------------------- 1 | /dist 2 | -------------------------------------------------------------------------------- /Child.hs: -------------------------------------------------------------------------------- 1 | -- c-repl: a C read-eval-print loop. 2 | -- Copyright (C) 2008 Evan Martin 3 | 4 | -- This module is responsible for managing the child process that actually 5 | -- executes the code snippets. 6 | 7 | module Child ( 8 | Child(..), 9 | 10 | -- Start/stop a child subprocess. 11 | start, 12 | stop, 13 | 14 | -- Instruct a child subprocess to run some code. 15 | run 16 | ) where 17 | 18 | import Prelude hiding (catch) 19 | import Control.Concurrent 20 | import Control.Exception 21 | import Control.Monad.Error 22 | import Data.Maybe 23 | import System.Directory 24 | import System.Exit 25 | import System.Process 26 | import System.IO 27 | import System.Posix.IO (createPipe, fdToHandle) 28 | 29 | import qualified Paths_c_repl 30 | 31 | -- TODO: rewrite this to not use runProcess, as we want the real pid of 32 | -- the child process (for attaching to it with gdb), and System.Process 33 | -- only exposes ProcessHandles and no pids. 34 | 35 | data Child = Child { 36 | childPHandle :: ProcessHandle, 37 | childPid :: Int, -- The actual process ID of this process. 38 | childCommand :: Handle, 39 | childResponse :: Handle 40 | } 41 | 42 | -- Compute the location of the child helper. 43 | findChildBinary :: IO (Maybe FilePath) 44 | findChildBinary = do 45 | let path = "dist/build/c-repl-child" 46 | ok1 <- isReadable path 47 | if ok1 48 | then return (Just path) 49 | else do 50 | libexecdir <- Paths_c_repl.getLibexecDir 51 | let path = libexecdir ++ "/c-repl-child" 52 | ok2 <- isReadable path 53 | if ok2 54 | then return (Just path) 55 | else return Nothing 56 | where 57 | isReadable path = 58 | do 59 | perms <- getPermissions path 60 | return $ readable perms 61 | `catch` \e -> return False 62 | 63 | -- Create a new Child, starting the helper process. 64 | start :: IO (Either String Child) 65 | start = do 66 | (commandR, commandW) <- createPipe 67 | (responseR, responseW) <- createPipe 68 | childPath <- findChildBinary 69 | case childPath of 70 | Nothing -> return $ throwError "couldn't find helper binary" 71 | Just childPath -> do 72 | phandle <- runProcess childPath 73 | [show commandR, show responseW] 74 | Nothing{-working dir-} Nothing{-env-} 75 | Nothing Nothing Nothing {-stdin,out,err-} 76 | [commandH, responseH] <- mapM fdToHandle [commandW, responseR] 77 | mapM_ (\h -> hSetBuffering h LineBuffering) [commandH, responseH] 78 | pidstr <- hGetLine responseH 79 | return $ Right $ Child phandle (read pidstr) commandH responseH 80 | 81 | -- Kill off a Child. 82 | stop :: Child -> IO () 83 | stop child = terminateProcess (childPHandle child) 84 | 85 | -- Command a Child to run modules up to a given id. 86 | run :: Child -> Int -> IO (Either String ()) 87 | run child entry = runErrorT (sendCommand >> awaitResponse) where 88 | command = show entry 89 | sendCommand = liftIO $ hPutStrLn (childCommand child) command 90 | awaitResponse :: ErrorT String IO () 91 | awaitResponse = do 92 | -- Set up a thread that fills in a MVar if the child responds. 93 | respMVar <- liftIO $ do 94 | respMVar <- newEmptyMVar 95 | forkIO $ do 96 | resp <- hGetLine (childResponse child) 97 | putMVar respMVar resp 98 | return respMVar 99 | -- Wait up to 5s for a response. 100 | resp <- checkResponse respMVar 5000 101 | -- Check that the response is as we expect. 102 | if resp == command 103 | then return () 104 | else throwError "got bad response from child" 105 | 106 | checkResponse :: MVar String -> Int -> ErrorT String IO String 107 | checkResponse respMVar ms = do 108 | resp <- liftIO $ tryTakeMVar respMVar 109 | case resp of 110 | Just resp -> return resp 111 | Nothing -> do -- still working? 112 | -- The subprocess hasn't responded yet. Check if it died. 113 | -- (Sometimes getProcessExitCode throws an interrupted exception; 114 | -- we interpret that as a crash as well.) 115 | dead <- liftIO $ isDead child 116 | if dead 117 | then throwError "(child exited)" 118 | else if ms <= 0 119 | then do 120 | -- We've waited too long. (XXX prompt the user here) 121 | liftIO $ terminateProcess (childPHandle child) 122 | throwError "(child hung?)" 123 | else do 124 | -- Wait a bit longer for a response. 125 | liftIO $ threadDelay 100 126 | checkResponse respMVar (ms-100) 127 | 128 | isDead :: Child -> IO Bool 129 | isDead child = catchJust ioErrors getExited (\e -> return True) where 130 | getExited = do 131 | exit <- getProcessExitCode (childPHandle child) 132 | return $ isJust exit 133 | -------------------------------------------------------------------------------- /CodeSnippet.hs: -------------------------------------------------------------------------------- 1 | -- c-repl: a C read-eval-print loop. 2 | -- Copyright (C) 2008 Evan Martin 3 | 4 | -- This module parses REPL inputs. We need to parse a 5 | -- declaration like "int x = foo()" because we compile that into a 6 | -- global declaration of x along with a call to an initializer. 7 | -- The code is pretty hacky but it passes the (inline) test suite. 8 | 9 | module CodeSnippet ( 10 | -- Parsed snippet of code, to the level of parsing we care about. 11 | CodeSnippet(..), 12 | -- Parse an input into a CodeSnippet. 13 | parse, 14 | -- Expose the test runner so we can use it via ghci. 15 | runTests 16 | ) where 17 | 18 | import Control.Monad.Error 19 | import Data.Char 20 | import Data.List 21 | import Test.HUnit 22 | import Text.ParserCombinators.Parsec hiding (parse) 23 | import qualified Text.ParserCombinators.Parsec as Parsec 24 | 25 | data CodeSnippet = Code String 26 | | VarDecl String String -- Decl, initialization code. 27 | | FunDecl String String -- Type + name, body. 28 | deriving (Eq,Show) 29 | 30 | type TokenStream = [(SourcePos, Token)] 31 | tokPos = fst 32 | data Token = Ident String | Punct String deriving (Eq, Show) 33 | 34 | substr :: Maybe SourcePos -> Maybe SourcePos -> String -> String 35 | substr start end str = strip $ take sublen $ drop startOfs $ str 36 | where 37 | startOfs = maybe 0 spOfs start 38 | endOfs = maybe (length str) spOfs end 39 | sublen = endOfs - startOfs 40 | spOfs sp = sourceColumn sp - 1 41 | strip [] = [] 42 | strip [' '] = [] 43 | strip (x:xs) = x : strip xs 44 | stripSemi [] = [] 45 | stripSemi [';'] = [] 46 | stripSemi (x:xs) = x : stripSemi xs 47 | 48 | parse :: String -> Either String CodeSnippet 49 | parse input = do 50 | -- Properly parsing C is famously impossible without processing typedefs in 51 | -- all headers. But we can get pretty close with some heuristics. 52 | -- This code is hideous, but it sorta comes with the territory. 53 | case Parsec.parse p_tokenize "code" input of 54 | Left err -> Left (show err) 55 | Right tokenstream -> do 56 | let (idents, rest) = span (isTypeLeader . snd) tokenstream 57 | if length idents < 2 58 | then return $ Code (stripSemi input) 59 | else let (typ, var) = (init idents, last idents) 60 | in parseDecl typ var rest 61 | where 62 | parseDecl typ var ((npos, Punct "("):rest) = 63 | case dropWhile (\(_,tok) -> tok /= Punct ")") rest of 64 | (rparen:(next,_):rest) -> 65 | return $ FunDecl (substr Nothing (Just next) input) 66 | (substr (Just next) Nothing input) 67 | _ -> Left $ "couldn't find rparen" 68 | parseDecl typ var rest = 69 | let nextpos = case rest of 70 | ((pos, tok):rest) | tok /= Punct ";" -> Just pos 71 | _ -> Nothing 72 | code = case nextpos of 73 | Just n -> substr (Just (tokPos var)) Nothing input 74 | Nothing -> "" 75 | in return $ VarDecl (stripSemi $ substr Nothing nextpos input) 76 | (stripSemi code) 77 | isTypeLeader (Ident _) = True 78 | isTypeLeader (Punct "*") = True 79 | isTypeLeader _ = False 80 | 81 | p_tokenize :: Parser TokenStream 82 | p_tokenize = many (annotate p_ident <|> annotate p_token) where 83 | p_ident = liftM Ident $ withSpaces $ many1 (letter <|> digit <|> char '_') 84 | p_token = do l <- withSpaces $ oneOf "()*[]={};"; return $ Punct [l] 85 | withSpaces p = do r <- p; skipMany space; return r 86 | annotate p = do 87 | pos <- getPosition 88 | p' <- p 89 | return (pos, p') 90 | 91 | assertParse :: CodeSnippet -> String -> Assertion 92 | assertParse expected input = do 93 | case parse input of 94 | Left error -> assertFailure $ show input ++ " failed to parse: " ++ error 95 | Right snip -> assertEqual input expected snip 96 | 97 | testParse exp input = test $ assertParse exp input 98 | 99 | runTests = 100 | runTestTT $ test $ TestList [ 101 | testParse (VarDecl "int x" "x = 3") "int x = 3;" 102 | , testParse (VarDecl "int x" "x = 3") "int x = 3" 103 | , testParse (VarDecl "int xx" "xx = 3") "int xx = 3;" 104 | , testParse (Code "x = 3") "x = 3" 105 | , testParse (Code "*((char*)x) = 0") "*((char*)x) = 0;" 106 | , testParse (VarDecl "int x" "") "int x" 107 | , testParse (VarDecl "const char* x" "") "const char* x;" 108 | , testParse (Code "x+y = 4") "x+y = 4;" 109 | , testParse (Code "for (;;) x") "for (;;) x;" 110 | , testParse (FunDecl "void f()" "{}") "void f() {}" 111 | ] 112 | 113 | main = runTests 114 | -------------------------------------------------------------------------------- /GCCXML.hs: -------------------------------------------------------------------------------- 1 | -- c-repl: a C read-eval-print loop. 2 | -- Copyright (C) 2008 Evan Martin 3 | 4 | -- This module parses GCCXML output, giving you a parse tree of C code. 5 | 6 | module GCCXML ( 7 | Symbol(..), 8 | 9 | -- The main parser/driver, @symbols code@ returns either an error or a list of 10 | -- resolved Symbols. 11 | symbols, 12 | 13 | -- Print a user-friendly version of a Symbol. 14 | showSymbol 15 | ) where 16 | 17 | import Prelude hiding (catch) 18 | import Control.Monad.Error 19 | import Control.Exception 20 | import qualified Data.ByteString as BS 21 | import Data.Maybe (mapMaybe) 22 | import Data.List (intercalate) 23 | import qualified Data.Map as M 24 | import System.Exit 25 | import System.IO 26 | import System.Process 27 | import qualified Text.XML.Expat.Tree as Expat 28 | 29 | type XML = BS.ByteString 30 | type XMLNode = Expat.Node String String 31 | 32 | -- @runGCCXML code@ runs a gccxml process on |code|, returning the XML output 33 | -- or an error string on error. 34 | runGCCXML :: String -> IO (Either String XML) 35 | runGCCXML code = run `catch` (\e -> do print e; undefined) where 36 | run = do 37 | let cmd = "gccxml - -fxml=/dev/stdout" 38 | (inp,out,err,pid) <- runInteractiveCommand cmd 39 | hPutStr inp code 40 | hClose inp 41 | output <- BS.hGetContents out 42 | error <- hGetContents err 43 | exit <- BS.length output `seq` waitForProcess pid 44 | return $ case exit of 45 | ExitSuccess -> return output 46 | ExitFailure code -> throwError error 47 | 48 | -- Symbol resolution: gccxml outputs a DAG as a flat list of nodes with ids 49 | -- and pointers to other nodes. While parsing, we build a Map of symbol 50 | -- id -> unresolved symbol info, and then once parsing is complete we resolve 51 | -- all references into the real DAG. 52 | 53 | -- The identity of a symbol as output by gccxml, such as "_341". 54 | type SymbolId = String 55 | -- A map from symbol id to unresolved symbol. 56 | type SymbolMap = M.Map SymbolId UnrSym 57 | -- An unresolved symbol is either a UnrSym, awaiting a complete SymbolMap, 58 | -- or it's a ResSym, a base case child node like "int". 59 | data UnrSym = UnrSym (SymbolMap -> Either String UnrSym) 60 | | ResSym Symbol 61 | 62 | -- Description of a C-level type. 63 | data CType = Array CType 64 | | Const CType 65 | | Enum String 66 | | Fundamental String 67 | | CFunction [CType] 68 | | Pointer CType 69 | | Struct String 70 | | Typedef String 71 | | Union String 72 | deriving Show 73 | 74 | showCType (Array t) = showCType t ++ "[]" 75 | showCType (Const t) = showCType t ++ " const" 76 | showCType (Enum t) = t 77 | showCType (Fundamental t) = t 78 | showCType (CFunction t) = "[function]" 79 | showCType (Pointer t) = showCType t ++ "*" 80 | showCType (Struct t) = t 81 | showCType (Typedef t) = t 82 | showCType (Union t) = t 83 | 84 | -- The symbols we parse out of gccxml: currently just functions and types. 85 | data Symbol = Function String [String] 86 | | Type CType 87 | deriving Show 88 | 89 | showSymbol :: GCCXML.Symbol -> String 90 | showSymbol (Function name args) = name ++ "(" ++ intercalate ", " args ++ ")" 91 | showSymbol (Type typ) = showCType typ 92 | 93 | -- Given a symbol map and an unresolved symbol, resolve it to a plain symbol 94 | -- or throw an error. 95 | resolve :: SymbolMap -> UnrSym -> Either String Symbol 96 | resolve map (UnrSym f) = f map >>= resolve map 97 | resolve map (ResSym s) = return s 98 | 99 | -- Given a symbol map and an unresolved symbol, resolve it to a type or throw 100 | -- an error. 101 | resolveType :: SymbolMap -> UnrSym -> Either String CType 102 | resolveType map unr = do 103 | sym <- resolve map unr 104 | case sym of 105 | Type ct -> return ct 106 | x -> throwError (show x) 107 | 108 | -- Convert a plain symbol id to an UnrSym: the unresolved symbol the id 109 | -- references. 110 | symref :: SymbolId -> UnrSym 111 | symref id = UnrSym (\symbolmap -> 112 | case M.lookup id symbolmap :: Maybe UnrSym of 113 | Nothing -> Left $ "lookup failed: " ++ id 114 | Just ok -> Right ok) 115 | 116 | symbols :: String -> IO (Either String [Symbol]) 117 | symbols code = runErrorT $ do 118 | xml <- ErrorT $ runGCCXML code 119 | ErrorT $ return $ parseSymbols xml 120 | where 121 | parseSymbols :: XML -> Either String [Symbol] 122 | parseSymbols xml = do 123 | tree <- case Expat.parseTree' Nothing xml of 124 | Left err -> throwError (show err) 125 | Right (Expat.Element root attrs tree) -> return tree 126 | let nodes = mapMaybe parseNode tree 127 | let symbolmap = M.fromList nodes 128 | mapM (resolve symbolmap . snd) nodes 129 | parseNode :: XMLNode -> Maybe (SymbolId, UnrSym) 130 | parseNode (Expat.Element typ attrs kids) = do 131 | sym <- parseSymbol typ attrs kids 132 | id <- lookup "id" attrs 133 | return (id, sym) 134 | parseNode _ = Nothing 135 | 136 | parseSymbolType0Arg :: [(String,String)] -> (String -> CType) -> Maybe UnrSym 137 | parseSymbolType0Arg attrs constructor = do 138 | name <- lookup "name" attrs 139 | return $ ResSym $ Type $ constructor (prettify name) 140 | 141 | parseSymbolType1Arg :: [(String,String)] -> (CType -> CType) -> Maybe UnrSym 142 | parseSymbolType1Arg attrs constructor = do 143 | innertypeid <- lookup "type" attrs 144 | return $ UnrSym $ \symbolmap -> do 145 | innertype <- resolveType symbolmap (symref innertypeid) 146 | return $ ResSym $ Type $ constructor innertype 147 | 148 | parseSymbol :: String -> [(String,String)] -> [XMLNode] -> Maybe UnrSym 149 | parseSymbol "Function" attrs kids = do 150 | name <- lookup "name" attrs 151 | when (isInternal name) Nothing 152 | let args = mapMaybe parseFunctionArg kids 153 | return $ UnrSym $ \symbolmap -> do 154 | args' <- forM args $ \(unr, name) -> do 155 | ctype <- resolveType symbolmap unr 156 | return $ showCType ctype ++ " " ++ name 157 | return $ ResSym $ Function name args' 158 | parseSymbol "Union" attrs kids = do 159 | name <- msum [lookup "name" attrs, lookup "demangled" attrs, Just "anon"] 160 | return $ ResSym $ Type $ Union (prettify name) 161 | parseSymbol "Struct" attrs kids = do 162 | name <- msum [lookup "name" attrs, lookup "demangled" attrs, Just "anon"] 163 | return $ ResSym $ Type $ Struct (prettify name) 164 | parseSymbol "FunctionType" attrs kids = do 165 | return $ ResSym $ Type $ CFunction [] 166 | parseSymbol "Enumeration" attrs _ = parseSymbolType0Arg attrs Enum 167 | parseSymbol "FundamentalType" attrs _ = parseSymbolType0Arg attrs Fundamental 168 | parseSymbol "Typedef" attrs _ = parseSymbolType0Arg attrs Typedef 169 | parseSymbol "ArrayType" attrs _ = parseSymbolType1Arg attrs Array 170 | parseSymbol "CvQualifiedType" attrs _ = parseSymbolType1Arg attrs Const 171 | parseSymbol "PointerType" attrs _ = parseSymbolType1Arg attrs Pointer 172 | parseSymbol _ _ _ = Nothing 173 | 174 | parseFunctionArg :: XMLNode -> Maybe (UnrSym, String) 175 | parseFunctionArg (Expat.Element "Argument" attrs _) = do 176 | name <- lookup "name" attrs 177 | typeid <- lookup "type" attrs 178 | return (symref typeid, prettify name) 179 | parseFunctionArg _ = Nothing 180 | 181 | isInternal :: String -> Bool 182 | isInternal ('_':_) = True 183 | isInternal _ = False 184 | 185 | prettify ('_':'_':name) = name 186 | prettify name = name 187 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2007 Evan Martin 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are 6 | met: 7 | * Redistributions of source code must retain the above copyright notice, 8 | this list of conditions and the following disclaimer. 9 | * Redistributions in binary form must reproduce the above copyright 10 | notice, this list of conditions and the following disclaimer in the 11 | documentation and/or other materials provided with the distribution. 12 | * Neither the name of the author nor the names of contributors may be 13 | used to endorse or promote products derived from this software without 14 | specific prior written permission. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS 17 | IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED 18 | TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A 19 | PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER 20 | OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 21 | EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 22 | PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 23 | PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 24 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 25 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 26 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | c-repl: a C read-eval-print loop. 2 | Copyright (C) 2008 Evan Martin 3 | 4 | Many programming languages come with a REPL (read-eval-print loop), 5 | which allows you to type in code line by line and see what it does. This 6 | is quite useful for prototyping, experimentation, and debugging code. 7 | 8 | Other programming languages, and especially C, use a "compile-run" 9 | model, and don't provide a REPL. Let's fix that. 10 | 11 | == Dependencies 12 | - GHC 6.8 13 | - gcc 14 | - gccxml and hexpat 15 | (http://hackage.haskell.org/cgi-bin/hackage-scripts/package/hexpat) 16 | - gdb and hgdbmi 17 | (http://hackage.haskell.org/cgi-bin/hackage-scripts/package/hgdbmi) 18 | - readline 19 | 20 | Debian/Ubuntu users on recent releases can do something like: 21 | sudo apt-get install ghc6 gccxml libghc6-parsec-dev libghc6-mtl-dev \ 22 | libghc6-hunit-dev 23 | hexpat, hgdbmi, and readline can be fetched and installed from Hackage 24 | via the above URLs or via cabal-get, and they depend on 25 | sudo apt-get install gdb libexpat1-dev c2hs libreadline-dev 26 | 27 | If you get an error from c2hs like this: 28 | /usr/include/bits/pthreadtypes.h:99: (column 6) [FATAL] 29 | >>> Syntax error! 30 | The symbol `;' does not fit here. 31 | then you unfortunately need a newer c2hs; the one in Ubuntu Hardy is 32 | at least recent enough. 33 | 34 | == Building 35 | Almost list a normal cabal-managed app: 36 | cabal configure 37 | cabal install 38 | but with one major exception, you must also run this at the end. 39 | cabal copy 40 | 41 | Why is this extra step necessary? Read Setup.lhs and tell me what I've 42 | done wrong; I've probably spent as much time trying to figure out Cabal 43 | as I have writing the actual app. I'd love to apply a patch from someone 44 | smarter than me. 45 | 46 | == Usage 47 | Type normal lines of C code and hit enter. Trailing semicolons are 48 | optional. All variable and function declarations are implicitly global, 49 | but can be initialized as if they were locals. 50 | > int x = 3 51 | > printf("at %p, %d\n", &x, x) 52 | at 0xb7f4a550, 3 53 | > FILE* f = fopen("README", "r") 54 | 55 | Bring in more headers by writing #include statements. Library functions 56 | that are in scope should be tab-completable at the prompt. 57 | > #include 58 | > op 59 | open open_memstream openat64 60 | open64 openat 61 | > open 62 | 63 | == How it works 64 | The approach is surprisingly simple: for each line of code you enter, we 65 | compile a shared object in the background. If the compilation succeeds, 66 | the object is loaded into a child process via dlopen(). Parsing of C 67 | #includes uses gccxml. (Unfortunately, I can't figure out how to use 68 | gccxml to parse the user's input, and due to the complexity of parsing C 69 | the input parser is currently hacky and heuristic.) 70 | 71 | == Debugging 72 | c-repl currently can take one flag, "-v", which causes it to output the 73 | internal code that it's generating. Please include this output with bug 74 | reports. 75 | 76 | == Credit 77 | The original idea is due to Satoru Takabayashi (http://0xcc.net), who 78 | was responsible for a prototype implementation and advice on the 79 | original version. 80 | 81 | 82 | vim: set tw=72 : 83 | -------------------------------------------------------------------------------- /Repl.hs: -------------------------------------------------------------------------------- 1 | -- c-repl: a C read-eval-print loop. 2 | -- Copyright (C) 2008 Evan Martin 3 | 4 | -- The main function and REPL handling. 5 | 6 | import Prelude hiding (log) 7 | import Control.Exception 8 | import Control.Monad 9 | import Control.Monad.Error 10 | import Data.List (find, isPrefixOf, intercalate, stripPrefix) 11 | import Data.Maybe (catMaybes, mapMaybe) 12 | import qualified System.Console.Readline as Readline 13 | import System.Environment 14 | import System.Exit 15 | import System.IO 16 | import System.Posix.Types (ProcessID) 17 | import System.Process 18 | import System.FilePath 19 | import System.Directory 20 | 21 | import qualified Child 22 | import qualified CodeSnippet 23 | import CodeSnippet (CodeSnippet) 24 | import qualified GCCXML 25 | import qualified GDBMI 26 | 27 | log :: Show a => String -> a -> IO () 28 | log desc obj = putStrLn (desc ++ " " ++ show obj) 29 | 30 | data InterpEnv = InterpEnv { 31 | envVerbose :: Bool, -- Verbose flag. 32 | envChild :: Child.Child, -- Child process that executes code. 33 | envHeaders :: [String], -- Headers to #include, like "". 34 | envLibraries :: [String], -- Libraries to link in, like "foo" in -l"foo". 35 | envSyms :: [(String, GCCXML.Symbol)], -- Imported header symbols. 36 | envDecls :: [String], -- Declared variables. 37 | envEntry :: Int -- Current .so number we're on. 38 | } 39 | instance Show InterpEnv where 40 | show env = "headers: " ++ show (envHeaders env) 41 | ++ " decls: " ++ show (envDecls env) 42 | ++ " entry: " ++ show (envEntry env) 43 | 44 | creplDir = ".c-repl" 45 | cleanupDir :: IO () 46 | cleanupDir = do 47 | exists <- doesDirectoryExist creplDir 48 | when exists $ do 49 | files <- getDirectoryContents creplDir 50 | sequence_ [removeFile (creplDir x) | x <- files, x /= "." && x /= ".."] 51 | removeDirectory creplDir 52 | 53 | setupDir = do 54 | cleanupDir 55 | createDirectory creplDir 56 | 57 | includesAsSource :: [String] -> String 58 | includesAsSource = concatMap (\h -> "#include " ++ h ++ "\n") 59 | 60 | makeSnippet :: InterpEnv -> String -> Int -> Either String (InterpEnv, String) 61 | makeSnippet env code entry = do 62 | snippet <- CodeSnippet.parse code 63 | let source = snippetToSource env snippet entry 64 | let decl = snippetToDecl snippet 65 | return (env {envDecls=envDecls env ++ catMaybes [decl]}, 66 | source) 67 | 68 | snippetToDecl :: CodeSnippet -> Maybe String 69 | snippetToDecl (CodeSnippet.Code _) = Nothing 70 | snippetToDecl (CodeSnippet.VarDecl decl _) = return decl 71 | snippetToDecl (CodeSnippet.FunDecl decl _) = return decl 72 | 73 | snippetToSource :: InterpEnv -> CodeSnippet -> Int -> String 74 | snippetToSource env snippet entry = 75 | intercalate "\n" [incl, decls, line, global snippet, 76 | func, line, local snippet, "}\n"] 77 | where 78 | incl = includesAsSource (envHeaders env) 79 | decls = concatMap (++ ";\n") (envDecls env) 80 | line = "#line 1" -- So gcc error messages have user-understandable lineno. 81 | global (CodeSnippet.Code _) = "" 82 | global (CodeSnippet.VarDecl decl _) = decl ++ ";" 83 | global (CodeSnippet.FunDecl decl code) = decl ++ code ++ ";" 84 | func = "void dl" ++ show entry ++ "() {" 85 | local (CodeSnippet.Code str) = str ++ ";" 86 | local (CodeSnippet.VarDecl _ str) = str ++ ";" 87 | local (CodeSnippet.FunDecl _ _ ) = "" 88 | 89 | generateSharedObject :: InterpEnv -> String -> IO (Either String ()) 90 | generateSharedObject env snippet = do 91 | let libs = concatMap (\lib -> "-l" ++ lib ++ " ") (envLibraries env) 92 | let soname = creplDir "dl" ++ show (envEntry env) ++ ".so" 93 | let cmd = "gcc -Wall " ++ libs ++ "-xc -g -shared -fPIC -o " ++ soname ++ " -" 94 | (inp,out,err,pid) <- runInteractiveCommand cmd 95 | error <- hGetContents err 96 | hPutStr inp snippet 97 | hClose inp 98 | exit <- waitForProcess pid 99 | when (not (null error)) $ putStr error 100 | case exit of 101 | ExitSuccess -> return (return ()) 102 | ExitFailure code -> return (throwError "compile failed.") 103 | 104 | -- c-repl meta-level parse of a line. 105 | data Command = IncludeHeader String 106 | | Code String 107 | | TypeQuery String 108 | | InfoQuery String 109 | | LoadLibrary String 110 | | HelpQuery 111 | 112 | metacommands :: [(String, String, String -> Command)] 113 | metacommands = [ 114 | ("t", "print the type of a symbol", TypeQuery), 115 | ("p", "print the value of a variable", InfoQuery), 116 | ("i", "#include a header", IncludeHeader), 117 | ("l", "load a library", LoadLibrary) 118 | ] 119 | 120 | parseLine :: String -> Either String Command 121 | parseLine line | inc `isPrefixOf` line = 122 | let Just h = stripPrefix inc line in return $ IncludeHeader h 123 | where inc = "#include " 124 | parseLine ('.':line) = 125 | let (cmd, rest) = breakApart (==' ') line in 126 | case find (\(key,_,_) -> key `isPrefixOf` cmd) allcommands of 127 | Just (_, _, command) -> return (command rest) 128 | Nothing -> throwError "unknown command" 129 | where 130 | allcommands = ("h", "", const HelpQuery) : metacommands 131 | breakApart pred l = 132 | let (a,b) = break pred l in 133 | case b of [] -> (a, b); _ -> (a, tail b) 134 | parseLine line = return $ Code line 135 | 136 | runLine :: InterpEnv -> String -> IO (Either String InterpEnv) 137 | runLine env line = runErrorT $ do 138 | cmd <- ErrorT $ return $ parseLine line 139 | case cmd of 140 | IncludeHeader header -> do 141 | let env' = env {envHeaders=envHeaders env ++ [header]} 142 | updateCompletionSymbols env' 143 | Code code -> do 144 | let entry = envEntry env 145 | (env', code) <- ErrorT $ return (makeSnippet env line entry) 146 | runCode env' code 147 | TypeQuery var -> do 148 | liftIO $ case lookup var (envSyms env) of 149 | Nothing -> putStrLn "unknown" 150 | Just sym -> putStrLn $ GCCXML.showSymbol sym 151 | return env 152 | LoadLibrary lib -> do 153 | return $ env {envLibraries=envLibraries env ++ [lib]} 154 | InfoQuery var -> do 155 | let pid = fromIntegral (Child.childPid (envChild env)) 156 | let cmd = GDBMI.MICommand ("var-create v * " ++ var) 157 | GDBMI.MIOutput log out <- ErrorT $ runGDB pid cmd 158 | case out of 159 | Nothing -> throwError $ "GDB unexpected output " ++ show log 160 | Just (GDBMI.MIError e) -> throwError $ "GDB error: " ++ show e 161 | Just (GDBMI.MIDone args) -> do 162 | vals <- return $ mapM (`lookup` args) ["type", "value"] 163 | case vals of 164 | Just [GDBMI.MIString typ, GDBMI.MIString val] -> 165 | liftIO $ putStrLn $ typ ++ ": " ++ val 166 | _ -> throwError $ "bad output args: " ++ show args 167 | return env 168 | HelpQuery -> do 169 | liftIO $ do 170 | putStrLn "you can enter:" 171 | putStrLn "- snippets of code: e.g. int x = 3 or printf(\"hi\\n\")" 172 | putStrLn "- includes: e.g. #include " 173 | putStrLn "- or a metacommand of the form '.command args'" 174 | putStrLn "metacommands are:" 175 | forM_ metacommands $ \(key, desc, _) -> 176 | putStrLn $ "- " ++ key ++ ": " ++ desc 177 | return env 178 | where 179 | runCode :: InterpEnv -> String -> ErrorT String IO InterpEnv 180 | runCode env code = do 181 | let entry = envEntry env 182 | liftIO $ when (envVerbose env) $ putStrLn code 183 | ErrorT $ generateSharedObject env code 184 | runok <- liftIO $ Child.run (envChild env) entry 185 | case runok of 186 | Left err -> do 187 | -- Run failed. Reboot the child. 188 | liftIO $ putStrLn err 189 | child <- ErrorT Child.start 190 | return $ env {envChild=child, envEntry=1} 191 | Right ok -> return $ env {envEntry = envEntry env + 1} 192 | 193 | runGDB :: ProcessID -> GDBMI.GDBCommand -> IO (Either String GDBMI.MIOutput) 194 | runGDB pid cmd = bracket before after todo where 195 | before = GDBMI.attach Nothing pid 196 | after :: Either String (GDBMI.GDB, GDBMI.MIOutput) -> IO () 197 | after (Right (gdb, log)) = GDBMI.detach gdb 198 | after _ = return () 199 | todo (Right (gdb, log)) = GDBMI.runCommand cmd gdb 200 | todo (Left err) = return $ throwError err 201 | 202 | updateCompletionSymbols :: InterpEnv -> ErrorT String IO InterpEnv 203 | updateCompletionSymbols env = do 204 | let code = includesAsSource (envHeaders env) 205 | symbols <- ErrorT $ GCCXML.symbols code 206 | let newsyms = mapMaybe (\sym -> do name <- symbolName sym; return (name, sym)) 207 | symbols 208 | let names = map fst newsyms 209 | when (envVerbose env) $ liftIO $ print names 210 | liftIO $ Readline.setCompletionEntryFunction (Just (complete names)) 211 | return $ env {envSyms=envSyms env ++ newsyms} 212 | where 213 | complete names input = return $ filter (input `isPrefixOf`) names 214 | symbolName (GCCXML.Function name args) = return name 215 | symbolName (GCCXML.Type _) = Nothing 216 | 217 | main = do 218 | args <- getArgs 219 | let verbose = case args of 220 | "-v":_ -> True 221 | _ -> False 222 | putStrLn "c-repl: a C read-eval-print loop." 223 | putStrLn "enter '.h' at the prompt for help." 224 | -- Turn off the space after tab-completion. 225 | Readline.setCompletionAppendCharacter (Just '\0') 226 | bracket_ setupDir cleanupDir $ do 227 | env <- runErrorT $ do 228 | child <- ErrorT Child.start 229 | let env = InterpEnv { 230 | envVerbose=verbose, envChild=child, 231 | envHeaders=["", ""], envLibraries=["m"], 232 | envSyms=[], envDecls=[], 233 | envEntry=1} 234 | updateCompletionSymbols env 235 | case env of 236 | Left error -> putStrLn $ "error: " ++ error 237 | Right env -> 238 | loop env `finally` (Child.stop (envChild env)) 239 | where 240 | loop env = do 241 | line <- Readline.readline "> " 242 | case line of 243 | Nothing -> putStrLn "" >> return () -- EOF; time to die. 244 | Just line -> do 245 | Readline.addHistory line 246 | env' <- runLine env line 247 | case env' of 248 | Left err -> do putStrLn err; loop env 249 | Right env' -> loop env' 250 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env runhaskell 2 | 3 | This setup file ought to be pretty simple, but we have one extra dependency: 4 | our "child" executable, a helper program that's written in C. So we have to 5 | patch in a compile and install step for the child program. 6 | 7 | This seems conceptually simple, but the "simple" distribution system used by 8 | Cabal et al is a huge confusing undocmented mess. :( 9 | 10 | > import Control.Applicative 11 | > import Distribution.Simple 12 | > import Distribution.PackageDescription 13 | > import Distribution.Simple.LocalBuildInfo 14 | > import Distribution.Simple.Setup 15 | > import Distribution.Simple.Program 16 | > import Distribution.Simple.Utils 17 | > import Distribution.Verbosity 18 | > import System.FilePath (()) 19 | > import System.Posix.Files 20 | 21 | > creplChildName :: String 22 | > creplChildName = "c-repl-child" 23 | 24 | > creplChildPath :: LocalBuildInfo -> FilePath 25 | > creplChildPath buildinfo = buildDir buildinfo creplChildName 26 | 27 | > creplChildBuild :: Args -> BuildFlags -> PackageDescription 28 | > -> LocalBuildInfo -> IO () 29 | > creplChildBuild args flags desc buildinfo = do 30 | > rawSystemProgramConf (fromFlag $ buildVerbosity flags) gccProgram (withPrograms buildinfo) 31 | > ["child.c", "-o", creplChildPath buildinfo, "-ldl"] 32 | 33 | > creplChildCopy :: Args -> CopyFlags -> PackageDescription 34 | > -> LocalBuildInfo -> IO () 35 | > creplChildCopy args flags desc buildinfo = do 36 | > let dirs = absoluteInstallDirs desc buildinfo (fromFlag $ copyDest flags) 37 | > let libexec = libexecdir dirs 38 | > let target = libexec creplChildName 39 | > putStrLn $ "copying child to " ++ target 40 | > let verbosity = fromFlag $ copyVerbosity flags 41 | > -- You might reasonably ask, "what is this mystery True argument here?" 42 | > -- I have no idea; it's not documented. 43 | > -- I am surely doing something wrong here but I've given up. 44 | > createDirectoryIfMissingVerbose verbosity True libexec 45 | > copyFileVerbose verbosity (creplChildPath buildinfo) target 46 | > -- copyFile appears to lose the +x bit on the binary. 47 | > mode <- fileMode <$> getFileStatus target 48 | > let desiredMode = unionFileModes ownerExecuteMode mode 49 | > setFileMode target desiredMode 50 | 51 | > buildHooks = simpleUserHooks { 52 | > hookedPrograms = [gccProgram], 53 | > postBuild = creplChildBuild, 54 | > postCopy = creplChildCopy 55 | > } 56 | 57 | > main = defaultMainWithHooks buildHooks 58 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | - .l command for bringing a library 2 | - ? command for help (and manpages?) 3 | - gdb support for printing variable contents 4 | - record command history to ~/.c-repl ? 5 | -------------------------------------------------------------------------------- /c-repl: -------------------------------------------------------------------------------- 1 | dist/build/c-repl/c-repl -------------------------------------------------------------------------------- /c-repl.cabal: -------------------------------------------------------------------------------- 1 | Cabal-Version: >= 1.2 2 | Name: c-repl 3 | Version: 0.1 4 | Synopsis: C read-eval-print loop 5 | Category: Development 6 | License: BSD3 7 | License-File: LICENSE 8 | Author: Evan Martin 9 | Maintainer: martine@danga.com 10 | Copyright: (c) 2009 Evan Martin 11 | Homepage: http://neugierig.org/software/c-repl/ 12 | Extra-Source-Files: child.c, README 13 | Build-Type: Custom 14 | 15 | Executable c-repl 16 | Main-Is: Repl.hs 17 | Other-Modules: Child, CodeSnippet, GCCXML 18 | Build-Depends: 19 | base, bytestring, containers, directory, filepath, HUnit, mtl, parsec, 20 | process, readline, unix, hexpat == 0.9, hgdbmi == 0.1 21 | Build-Tools: c2hs >= 0.15 22 | 23 | -------------------------------------------------------------------------------- /child.c: -------------------------------------------------------------------------------- 1 | /* c-repl -- a C read-eval-print loop. 2 | * Copyright (C) 2006 Evan Martin 3 | */ 4 | 5 | /* The child process is what actually runs the code. 6 | * It reads in a number from stdin, 7 | * then loads dl#.so and executes dl#(). 8 | */ 9 | 10 | #include 11 | #include 12 | #include 13 | #include 14 | #include 15 | #include 16 | 17 | static int debug = 0; 18 | 19 | /* Load dl.so and run dl(). */ 20 | static void load_and_run(int id) { 21 | char buf[1024]; 22 | 23 | sprintf(buf, "./.c-repl/dl%d.so", id); 24 | if (debug) 25 | fprintf(stderr, "CHILD> loading %s\n", buf); 26 | void *so = dlopen(buf, RTLD_LAZY | RTLD_GLOBAL); 27 | if (!so) { 28 | fprintf(stderr, "CHILD> error loading library: %s\n", dlerror()); 29 | assert(so); 30 | } 31 | 32 | sprintf(buf, "dl%d", id); 33 | void (*f)() = dlsym(so, buf); 34 | if (!f) { 35 | fprintf(stderr, "CHILD> error loading function: %s\n", dlerror()); 36 | assert(f); 37 | } 38 | 39 | //printf("child executing '%s':\n", buf); 40 | // XXX fork here to do the segfault -> undo magic? 41 | f(); 42 | } 43 | 44 | int main(int argc, char **argv) { 45 | if (argc < 3) { 46 | fprintf(stderr, "bad arguments\n"); 47 | return 1; 48 | } 49 | const int command_fd = atoi(argv[1]); 50 | const int response_fd = atoi(argv[2]); 51 | 52 | FILE* command_pipe = fdopen(command_fd, "rb"); 53 | if (!command_pipe) { 54 | perror("fdopen(command_fd)"); 55 | return 1; 56 | } 57 | setlinebuf(command_pipe); 58 | FILE* response_pipe = fdopen(response_fd, "wb"); 59 | if (!response_pipe) { 60 | perror("fdopen(response_fd)"); 61 | return 1; 62 | } 63 | setlinebuf(response_pipe); 64 | 65 | if (fprintf(response_pipe, "%d\n", getpid()) < 0) { 66 | perror("CHILD> fputs"); 67 | return 1; 68 | } 69 | 70 | char buf[1024]; 71 | int highest_id = 0; 72 | while (fgets(buf, sizeof(buf), command_pipe)) { 73 | const int id = atoi(buf); 74 | if (id > 0) 75 | for ( ; highest_id < id; highest_id++) 76 | load_and_run(highest_id+1); 77 | 78 | /* If we get here, we succeeded. 79 | * Let the parent know. */ 80 | if (fputs(buf, response_pipe) < 0) { 81 | perror("CHILD> fputs"); 82 | break; 83 | } 84 | fflush(response_pipe); 85 | } 86 | if (debug) 87 | fprintf(stderr, "CHILD> exiting\n"); 88 | 89 | fclose(command_pipe); 90 | fclose(response_pipe); 91 | 92 | return 0; 93 | }; 94 | 95 | /* vim: set ts=2 sw=2 et cino=(0 : */ 96 | --------------------------------------------------------------------------------