diff --git a/alpha.cabal b/alpha.cabal --- a/alpha.cabal +++ b/alpha.cabal @@ -1,5 +1,5 @@ name: alpha -version: 1.0.2 +version: 1.0.5 synopsis: A compiler for the Alpha language description: Alpha is a programming language that aims at being very simple and low-level, so as to be efficient, while at the same time @@ -20,10 +20,11 @@ location: git://github.com/lih/Alpha.git executable alpha - build-depends: base<=4.6.0.0, unix, containers, array, mtl, bytestring, bimap, ghc-prim, directory, filepath, cereal, parsec, transformers, bindings-posix, AvlTree, COrdering + build-depends: base<=4.6.0.0, unix, containers, array, mtl, bytestring, bimap, ghc-prim, directory, filepath, cereal, parsec, transformers, bindings-posix, AvlTree, COrdering, cpphs main-is: Alpha.hs - other-modules: Alpha Compile Compile.State Compile.Utils Context Context.Language Context.Types Elf ID My.Control.Monad My.Control.Monad.RWTL My.Control.Monad.State My.Data.Either My.Data.Graph My.Data.List My.Data.Relation My.Data.SetBy My.Data.Tree My.Prelude Options PCode PCode.Builtin PCode.Instruction PCode.Value Serialize Specialize Specialize.Architecture Specialize.Frame Specialize.Types Specialize.X86_64 Specialize.X86_64.Binary Syntax Syntax.Parse Translate + other-modules: Alpha Compile Compile.State Compile.Utils Context Context.Language Context.Types Format ID My.Control.Monad My.Control.Monad.RWTL My.Control.Monad.State My.Data.Either My.Data.Graph My.Data.List My.Data.Relation My.Data.SetBy My.Data.Tree My.Prelude Options PCode PCode.Builtin PCode.Instruction PCode.Value Serialize Specialize Specialize.Architecture Specialize.Frame Specialize.Types Specialize.X86_64 Specialize.X86_64.Binary Syntax Syntax.Parse Translate + ghc-options: -pgmP cpphs -optP --hashes -optP --cpp hs-source-dirs: src - c-sources: src/writeElf.c + c-sources: src/formats.c diff --git a/src/Alpha.hs b/src/Alpha.hs --- a/src/Alpha.hs +++ b/src/Alpha.hs @@ -10,7 +10,7 @@ import qualified Data.ByteString as B import qualified Data.Map as M import qualified Data.Serialize as Ser -import Elf (writeElf,entryAddress) +import Format import Foreign hiding (void) import My.Control.Monad import My.Control.Monad.State hiding ((<.>)) @@ -39,9 +39,6 @@ PrintVersion -> printVersion Compile -> doCompile s -formatEntry Elf64 = entryAddress -formatEntry (Raw n) = n - printHelp = putStrLn helpMsg printVersion = putStrLn $ "Alpha version "++showVersion version @@ -64,18 +61,16 @@ let sTree = concat $ parseAlpha "/dev/stdin" str mapM_ (\e -> compileExpr e >> putStr "> " >> hFlush stdout) (Group []:sTree) putStrLn "\rGoodbye !" - compileProgram (language,root) = withDefaultContext entry $ do + compileProgram (language,entryName) = withDefaultContext entry $ do importLanguage compileLanguage (const $ return ()) language - l <- viewing language_ get - rootSym <- viewState language_ $ internSym root - getAddressComp (outputArch opts) rootSym + l <- getting language_ + entrySym <- viewState language_ $ internSym entryName + _ <- getAddressComp (outputArch opts) entrySym (addrs,ptrs) <- unzip $< sortBy (comparing fst) $< M.elems $< gets compAddresses top <- gets compTop contents <- B.concat $< sequence [withForeignPtr ptr $ \p -> unsafePackCStringLen (castPtr p,size) | ptr <- ptrs | size <- zipWith (-) (tail addrs++[top]) addrs] - case outputFmt opts of - Elf64 -> writeElf root contents - Raw _ -> B.writeFile root contents + writeFormat (outputFmt opts) entryName contents compileLanguage force name = do let langFile = languageFile name source <- findSource name diff --git a/src/Compile/State.hs b/src/Compile/State.hs --- a/src/Compile/State.hs +++ b/src/Compile/State.hs @@ -1,6 +1,6 @@ {-# LANGUAGE StandaloneDeriving, NoMonomorphismRestriction, ViewPatterns #-} module Compile.State( - module Context, + module Context.Types, module My.Data.Graph, CompileState(..),BranchType(..),EdgeData(..),NodeData(..),CaseInfo(..), depGraph_,infoStack_,imports_, @@ -26,7 +26,7 @@ import My.Control.Monad import ID import My.Data.Graph hiding (deleteEdge,deleteNode,getContext,empty) -import Context +import Context.Types import Context.Language as L import qualified My.Data.Graph as G diff --git a/src/Compile/Utils.hs b/src/Compile/Utils.hs --- a/src/Compile/Utils.hs +++ b/src/Compile/Utils.hs @@ -3,6 +3,7 @@ import Control.Category ((>>>)) import Compile.State as CS +import Context.Language import Data.Array import Data.Function import Data.Maybe diff --git a/src/Context.hs b/src/Context.hs --- a/src/Context.hs +++ b/src/Context.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE ForeignFunctionInterface, NoMonomorphismRestriction, MultiParamTypeClasses #-} +{-# LANGUAGE ForeignFunctionInterface, NoMonomorphismRestriction, MultiParamTypeClasses, CPP #-} module Context(module Context.Types - ,module Context.Language + ,module Lang ,withDefaultContext ,languageState ,doTransform ,getAddressComp @@ -8,18 +8,19 @@ import Bindings.Posix.Sys.Mman import Bindings.Posix.Unistd -import Context.Language import Context.Language as Lang import Context.Types +import Control.Category ((>>>)) import Data.ByteString.Internal import Data.ByteString.Unsafe import Data.Functor.Identity import Data.IORef +import Data.List import Data.Maybe -import Elf(entryAddress) import Foreign hiding (unsafePerformIO,unsafeForeignPtrToPtr,void) import Foreign.C import Foreign.ForeignPtr.Unsafe +import Format import ID import My.Control.Monad import My.Control.Monad.State @@ -30,6 +31,7 @@ import Specialize.Architecture import Syntax import System.IO.Unsafe (unsafePerformIO) +import qualified Data.Bimap as BM import qualified Data.ByteString as B import qualified Data.Map as M @@ -40,66 +42,12 @@ foreign import ccall "dynamic" mkFunInit :: FunPtr (Ptr () -> Ptr() -> IO ()) -> Ptr() -> Ptr () -> IO () foreign import ccall "dynamic" mkFunTransform :: FunPtr (Ptr () -> Ptr() -> IO (Ptr ())) -> Ptr() -> Ptr () -> IO (Ptr ()) -withRef ref val x = readIORef ref >>= \v -> writeIORef ref val >> x >>= \x -> writeIORef ref v >> return x funPtrToInteger f = fromIntegral $ ptrToIntPtr $ castFunPtrToPtr f - -compAddrRef = unsafePerformIO $ newIORef (undefined :: ID -> IO Int) -contextRef = unsafePerformIO $ newIORef (error "Undefined context" :: Context) -instance MonadState Context IO where - get = readIORef contextRef - put = writeIORef contextRef - exportAlpha stub ptr = unsafePerformIO $ do unsafeUseAsCStringLen (stub $ funPtrToInteger ptr) $ \(src,size) -> do ptr <- mallocForeignPtrBytes size withForeignPtr ptr $ \dst -> copyBytes (castPtr dst) src size return ptr - -foreign export ccall "setTransform_" setTransform_ :: Ptr () -> IO () -foreign import ccall "&setTransform_" setTransform_ptr :: FunPtr (Ptr () -> IO ()) -setTransform_ fun = modify $ \c -> c { transform = Just fun } - -foreign export ccall "compAddr_" compAddr_ :: ID -> IO Int -foreign import ccall "&compAddr_" compAddr_ptr :: FunPtr (ID -> IO Int) -compAddr_ id = readIORef compAddrRef >>= ($id) - -foreign export ccall "symName_" symName_ :: ID -> IO (Ptr Word8) -foreign import ccall "&symName_" symName_ptr :: FunPtr (ID -> IO (Ptr Word8)) -symName_ sym = do - n <- gets (lookupSymName sym . language) - ret <- newArray0 0 (map c2w $ fromMaybe "" n) - return ret -foreign export ccall "nameSym_" nameSym_ :: Ptr Word8 -> IO ID -foreign import ccall "&nameSym_" nameSym_ptr :: FunPtr (Ptr Word8 -> IO ID) -nameSym_ p = do - l <- peekArray0 0 p - viewState language_ (internSym $ map w2c l) -foreign export ccall "createSym_" createSym_ :: IO ID -foreign import ccall "&createSym_" createSym_ptr :: FunPtr (IO ID) -createSym_ = viewState language_ createSym -foreign export ccall "numSym_" numSym_ :: Int -> IO ID -foreign import ccall "&numSym_" numSym_ptr :: FunPtr (Int -> IO ID) -numSym_ = viewState language_ . internSym . show - -foreign export ccall "allocate_" allocate_ :: Int -> IO (Ptr ()) -foreign import ccall "&allocate_" allocate_ptr :: FunPtr (Int -> IO (Ptr ())) -allocate_ = mallocBytes -foreign export ccall "free_" free_ :: Ptr() -> IO () -foreign import ccall "&free_" free_ptr :: FunPtr (Ptr() -> IO ()) -free_ = free - -foreign export ccall "printHelp_" printHelp_ :: IO () -foreign import ccall "&printHelp_" printHelp_ptr :: FunPtr (IO ()) -printHelp_ = Prelude.putStrLn helpMsg -foreign export ccall "printOK_" printOK_ :: IO () -foreign import ccall "&printOK_" printOK_ptr :: FunPtr (IO ()) -printOK_ = Prelude.putStrLn "OK" -foreign export ccall "printNum_" printNum_ :: Int -> IO () -foreign import ccall "&printNum_" printNum_ptr :: FunPtr (Int -> IO ()) -printNum_ n = print (intPtrToPtr $ fromIntegral n) - - - initialBindings = [(n,Left $ Builtin b) | (b,n) <- bNames] ++ [ ("alter" ,Left $ Axiom XAlter), ("bind" ,Left $ Axiom XBind), @@ -117,51 +65,56 @@ ("@" ,Left $ Axiom XAddr), ("#" ,Left $ Axiom XSize)] ++ [ - ("alpha/c@" , Right $ exportAlpha callStub1 compAddr_ptr), - ("alpha/create-symbol" , Right $ exportAlpha callStub0 createSym_ptr), - ("alpha/number-symbol" , Right $ exportAlpha callStub1 numSym_ptr), - ("alpha/symbol-name" , Right $ exportAlpha callStub1 symName_ptr), - ("alpha/name-symbol" , Right $ exportAlpha callStub1 nameSym_ptr), + ("alpha/c@" , Right $ exportAlpha callStub1 alpha_compAddr), + ("alpha/create-symbol" , Right $ exportAlpha callStub0 alpha_createSym), + ("alpha/number-symbol" , Right $ exportAlpha callStub1 alpha_numSym), + ("alpha/symbol-name" , Right $ exportAlpha callStub1 alpha_symName), + ("alpha/name-symbol" , Right $ exportAlpha callStub1 alpha_nameSym), - ("alpha/set-transform" , Right $ exportAlpha callStub1 setTransform_ptr), + ("alpha/set-transform" , Right $ exportAlpha callStub1 alpha_setTransform), - ("alpha/allocate" , Right $ exportAlpha callStub1 allocate_ptr), - ("alpha/free" , Right $ exportAlpha callStub1 free_ptr), + ("alpha/allocate" , Right $ exportAlpha callStub1 alpha_allocate), + ("alpha/free" , Right $ exportAlpha callStub1 alpha_free), - ("alpha/help" , Right $ exportAlpha callStub1 printHelp_ptr), - ("alpha/print-OK" , Right $ exportAlpha callStub0 printOK_ptr), - ("alpha/print-num" , Right $ exportAlpha callStub1 printNum_ptr) + ("alpha/list" , Right $ exportAlpha callStub0 alpha_printList), + ("alpha/lang" , Right $ exportAlpha callStub0 alpha_printLang), + ("alpha/help" , Right $ exportAlpha callStub0 alpha_printHelp), + ("alpha/print-OK" , Right $ exportAlpha callStub0 alpha_printOK), + ("alpha/print-num" , Right $ exportAlpha callStub1 alpha_printNum) ] -doTransform syn = gets transform >>= ($syn) . maybe return tr - where tr fun tree = do - root <- allocTree tree - new <- unsafeUseAsCString initStub $ \stub -> mkFunTransform (castPtrToFunPtr stub) fun root - readTree new - intS = sizeOf (undefined::Int) ; ptrS = sizeOf (undefined::Ptr()) - pok e p = poke (castPtr p) e >> return (p`plusPtr`sizeOf e) - pik p = peek (castPtr p) >>= \e -> return (e,p`plusPtr`sizeOf e) - allocTree (Group g) = do - p <- mallocBytes (intS+intS+(length g*ptrS)) - p' <- pok (0::Int) p - p'' <- pok (length g) p' - mapM allocTree g >>= \l -> pokeArray (castPtr p'') l - return p - allocTree (Symbol (ID s)) = do - p <- mallocBytes (intS+intS) - p' <- pok (1::Int) p - pok s p' - return p - readTree p = do - (t,p') <- pik p - case t :: Int of - 0 -> do - (s,p'') <- pik p' - l <- peekArray s p'' - liftM Group $ mapM readTree l - 1 -> do - liftM (Symbol . ID) $ peek p' - +#define str(x) #x +#define ALPHA_EXPORT(fun,t) foreign export ccall str(__alpha_##fun) __alpha_##fun :: t ; foreign import ccall str(&__alpha_##fun) alpha_##fun :: FunPtr (t) ; __alpha_##fun +ALPHA_EXPORT(setTransform,Ptr () -> IO ()) fun = modify $ \c -> c { transform = Just fun } +ALPHA_EXPORT(compAddr,ID -> IO Int) id = readIORef compAddrRef >>= ($id) + +ALPHA_EXPORT(symName,ID -> IO (Ptr Word8)) sym = do + n <- gets (lookupSymName sym . language) + ret <- newArray0 0 (map c2w $ fromMaybe "" n) + return ret +ALPHA_EXPORT(nameSym,Ptr Word8 -> IO ID) p = do + l <- peekArray0 0 p + viewState language_ (internSym $ map w2c l) +ALPHA_EXPORT(createSym,IO ID) = viewState language_ createSym +ALPHA_EXPORT(numSym,Int -> IO ID) = viewState language_ . internSym . show + +ALPHA_EXPORT(allocate,Int -> IO (Ptr())) = mallocBytes +ALPHA_EXPORT(free,Ptr() -> IO ()) = free + +ALPHA_EXPORT(printHelp,IO()) = Prelude.putStrLn helpMsg +ALPHA_EXPORT(printOK,IO()) = Prelude.putStrLn "OK" +ALPHA_EXPORT(printNum,Int -> IO()) n = print (intPtrToPtr $ fromIntegral n) +ALPHA_EXPORT(printList,IO()) = do + syms <- getting (language_ >>> syms_) + putStrLn $ intercalate " " (map fst $ BM.toList syms) +ALPHA_EXPORT(printLang,IO()) = getting language_ >>= print + +compAddrRef = unsafePerformIO $ newIORef (undefined :: ID -> IO Int) +contextRef = unsafePerformIO $ newIORef (error "Undefined context" :: Context) +instance MonadState Context IO where + get = readIORef contextRef + put = writeIORef contextRef + initialContext entry = C lang jitA M.empty (fromIntegral entry) Nothing where (lang,jitA) = execState (mapM_ st initialBindings) (Lang.empty,M.empty) where st (s,v) = do @@ -171,7 +124,6 @@ Right p -> modifying snd_ (M.insert i p) withDefaultContext = withState . initialContext - contextState sta = (runState sta $< readIORef contextRef) >>= \(a,s') -> writeIORef contextRef s' >> return a languageState = contextState . viewing language_ @@ -187,6 +139,7 @@ unsafeUseAsCString stub $ \stub -> f $ wrap (castPtrToFunPtr stub) (intPtrToPtr $ fromIntegral p) execCode c = evalCode mkProc execStub c id +withRef ref val x = readIORef ref >>= \v -> writeIORef ref val >> x >>= \x -> writeIORef ref v >> return x getAddress arch lookup register = withRef compAddrRef getAddr . getAddr where getAddr sym = lookup sym >>= \val -> case val of @@ -207,7 +160,7 @@ withForeignPtr ptr $ \p -> evalCode mkFunInit initStub init ($castPtr p) _ -> fail $ "Couldn't find definition of symbol "++fromMaybe (show sym) (lookupSymName sym lang) -getAddressJIT = getAddress hostArch lookup register +getAddressJIT = getAddress arch_host lookup register where lookup id = do val <- M.lookup id $< gets jitAddresses return $ (fromIntegral . ptrToIntPtr . unsafeForeignPtrToPtr) $< val @@ -219,3 +172,32 @@ modifying compAddresses_ (M.insert id (n,ptr)) modifying compTop_ (+size) +doTransform syn = gets transform >>= ($syn) . maybe return tr + where tr fun tree = do + root <- allocTree tree + new <- unsafeUseAsCString initStub $ \stub -> mkFunTransform (castPtrToFunPtr stub) fun root + readTree new + intS = sizeOf (undefined::Int) ; ptrS = sizeOf (undefined::Ptr()) + pok e p = poke (castPtr p) e >> return (p`plusPtr`sizeOf e) + pik p = peek (castPtr p) >>= \e -> return (e,p`plusPtr`sizeOf e) + allocTree (Group g) = do + p <- mallocBytes (intS+intS+(length g*ptrS)) + p' <- pok (0::Int) p + p'' <- pok (length g) p' + mapM allocTree g >>= \l -> pokeArray (castPtr p'') l + return p + allocTree (Symbol (ID s)) = do + p <- mallocBytes (intS+intS) + p' <- pok (1::Int) p + pok s p' + return p + readTree p = do + (t,p') <- pik p + case t :: Int of + 0 -> do + (s,p'') <- pik p' + l <- peekArray s p'' + liftM Group $ mapM readTree l + 1 -> do + liftM (Symbol . ID) $ peek p' + diff --git a/src/Context/Language.hs b/src/Context/Language.hs --- a/src/Context/Language.hs +++ b/src/Context/Language.hs @@ -94,17 +94,17 @@ exportsL = exportsL l S.\\ M.keysSet newVals } -exportLanguage e = e { - symbolsL = BM.filter exportNameP (symbolsL e), +exportLanguage l = l { + symbolsL = BM.filter exportNameP (symbolsL l), valuesL = vals', aliasesL = M.empty, equivsL = M.empty, exportsL = S.empty, - initializeL = translate trans (initializeL e) + initializeL = translate trans (initializeL l) } where set2Map s = M.fromAscList (zip (S.toAscList s) (repeat undefined)) - Language { exportsL = ex, equivsL = eqs } = e - vals' = M.map (translate trans) $ M.intersection (valuesL e) (set2Map ex) + Language { exportsL = ex, equivsL = eqs } = l + vals' = M.map (translate trans) $ M.intersection (valuesL l) (set2Map ex) trans s = fromMaybe s $ M.lookup s eqs refs = S.fromList $ concatMap references $ M.elems vals' exportNameP _ s = (S.member s ex || S.member s refs) diff --git a/src/Elf.hs b/src/Elf.hs deleted file mode 100644 --- a/src/Elf.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -module Elf (writeElf,entryAddress) where - -import Foreign -import Foreign.C -import System.Posix.IO -import System.Posix.Files -import Data.ByteString -import Data.ByteString.Unsafe - -foreign import ccall "writeElf" - c_writeElf :: CInt -> Ptr CChar -> CInt -> IO () -foreign import ccall "entryAddress" - entryAddress :: Int - -outFileMode = ownerModes + groupReadMode + groupExecuteMode + otherReadMode + otherExecuteMode - where (+) = unionFileModes - -writeElf :: String -> ByteString -> IO () -writeElf name dat = do - fd <- createFile name outFileMode - unsafeUseAsCStringLen dat (\(d,nd) -> c_writeElf (fromIntegral fd) d (fromIntegral nd)) - - diff --git a/src/Format.hs b/src/Format.hs new file mode 100644 --- /dev/null +++ b/src/Format.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE ForeignFunctionInterface, CPP #-} +module Format where + +import Foreign +import Foreign.C +import Foreign.Marshal.Alloc +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as BU +import Data.Monoid +import System.Posix.Files + +data Format = F { + formatName :: String, + formatEntry :: Int, + formatHeaderSize :: Int, + formatHeaderCons :: Int -> IO (Ptr CChar) + } + +instance Show Format where + show = formatName + +writeFormat fmt name dat = do + hp <- formatHeaderCons fmt (B.length dat) + h <- BU.unsafePackCStringLen (hp,formatHeaderSize fmt) + B.writeFile name (h <> dat) + stat <- getFileStatus name + let (+) = unionFileModes + setFileMode name (ownerExecuteMode + groupExecuteMode + otherExecuteMode + fileMode stat) + +#define importFun(fun,t) foreign import ccall #fun fun :: t +#define importFmt(fmt) importFun(fmt##_entry,Int) ; importFun(fmt##_headerSize,Int) ; importFun(fmt##_headerCons,Int -> IO (Ptr CChar)) ; fmt = F #fmt fmt##_entry fmt##_headerSize fmt##_headerCons + +raw entry = F ("raw:"++show entry) entry 0 (const $ return nullPtr) +importFmt(elf64) ; importFmt(elf32) ; importFmt(exe) +formats = [elf64,elf32,exe] + +#if x86_64_HOST_ARCH +defaultFormat = elf64 +#else +defaultFormat = raw 0 +#endif + + + diff --git a/src/My/Control/Monad/State.hs b/src/My/Control/Monad/State.hs --- a/src/My/Control/Monad/State.hs +++ b/src/My/Control/Monad/State.hs @@ -1,11 +1,9 @@ {-# LANGUAGE TupleSections, NoMonomorphismRestriction #-} -module My.Control.Monad.State( - module Control.Monad.State, - View(..), - viewState,viewing,modifying,getting,putting, - fst_,snd_,id_,f_,on_, - withState - ) where +module My.Control.Monad.State(module Control.Monad.State + ,View(..) + ,viewState,viewing,modifying,getting,putting + ,fst_,snd_,id_,f_,on_ + ,withState) where import Prelude hiding ((.),id) import Control.Monad.State hiding (withState) diff --git a/src/My/Data/List.hs b/src/My/Data/List.hs --- a/src/My/Data/List.hs +++ b/src/My/Data/List.hs @@ -1,4 +1,5 @@ -module My.Data.List(module Data.List,classesBy,nubOrd,sums,zipRest) where +{-# LANGUAGE ParallelListComp #-} +module My.Data.List(module Data.List,classesBy,nubOrd,sums,zipRest,wrap) where import Data.List @@ -11,6 +12,15 @@ sums :: Num a => [a] -> [a] sums = scanl (+) 0 + +consume f [] = [] +consume f l = let (a,t) = f l in a:consume f t + +wrap words unwords n s = consume group $ words s + where group ws = last [(unwords g,t) + | g <- inits ws + | t <- tails ws + | sz <- map (subtract 1) $ sums (map ((1+) . length) ws), sz <= n] zipRest l l' = (zip l l',drop (length l) l') diff --git a/src/Options.hs b/src/Options.hs --- a/src/Options.hs +++ b/src/Options.hs @@ -4,6 +4,7 @@ import System.Console.GetOpt import Data.Maybe import My.Data.List +import Format data Flag = Help | Version | SourceDir FilePath @@ -14,8 +15,6 @@ deriving Show data Action = PrintHelp | PrintVersion | Compile deriving Show -data Format = Elf64 | Raw Int - deriving Show data Settings = Settings { action :: Action, sourceDirs :: [FilePath], @@ -30,7 +29,8 @@ (a,':':b) -> a:splitArg b (a,"") -> [a] -options = + +options = map (\(Option a b c d) -> Option a b c (intercalate "\n" $ wrap words unwords 80 d)) [Option ['h','?'] ["help"] (NoArg Help) "prints usage information" ,Option ['v'] ["version"] (NoArg Version) @@ -42,24 +42,28 @@ "writes and seeks all language files in (defaults to the current directory)" ,sep ,Option ['a'] ["architecture"] (ReqArg (Architecture . str2arch) "") - $ "specializes for instead of the host architecture ( can be one of "++foldr glue "" (tails archNames)++")" + $ "specializes for instead of the host architecture ( can be one of "++glue archNames++")" ,Option ['f'] ["format"] (ReqArg (Format . str2fmt) "") - $ "writes the output programs in the specified format ( can be one of elf64 or \n" - ++"raw: where is the start address)" + $ "writes the output programs in the specified format ( can be one of "++glue fmtNames++")" ] - where str2arch s = fromMaybe (error $ "Invalid architecture name "++s) $ lookup s $ zip archNames architectures - str2fmt s = case splitArg s of - ["elf64"] -> Elf64 - ["raw",n] -> Raw (read n) - _ -> error ("Invalid format argument "++show s) + where sep = Option [] [] undefined "-----------------" archNames = map archName architectures - glue [a] _ = a - glue [a,_] t = a++" or "++t - glue (a:_) t = a++", "++t - sep = Option [] [] undefined "-----------------" + str2arch s = fromMaybe err $ lookup s [(archName a,a) | a <- architectures] + where err = error $ "Invalid architecture name "++show s + fmtNames = map formatName formats++["raw: where is the start address"] + str2fmt s = case splitArg s of + ["raw",n] -> raw (read n) + [s] -> fromMaybe err $ lookup s [(formatName f,f) | f <- formats] + _ -> err + where err = error $ "Invalid format argument "++show s + glue = foldr glue "" . tails + where glue [a] _ = a + glue [a,_] t = a++" or "++t + glue (a:_) t = a++", "++t + helpMsg = usageInfo "Usage: alpha