diff --git a/alpha.cabal b/alpha.cabal --- a/alpha.cabal +++ b/alpha.cabal @@ -1,5 +1,5 @@ name: alpha -version: 1.0.1 +version: 1.0.2 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 diff --git a/src/Alpha.hs b/src/Alpha.hs --- a/src/Alpha.hs +++ b/src/Alpha.hs @@ -5,6 +5,7 @@ import Data.List import Data.Maybe import Data.Ord +import Data.Version import qualified Data.Bimap as BM import qualified Data.ByteString as B import qualified Data.Map as M @@ -15,11 +16,13 @@ import My.Control.Monad.State hiding ((<.>)) import My.Prelude import Options +import Paths_alpha (version) import PCode import Serialize import Specialize import Syntax import Syntax.Parse +import System.IO import System.Directory import System.Environment as SE import System.FilePath @@ -39,9 +42,8 @@ formatEntry Elf64 = entryAddress formatEntry (Raw n) = n -version = "1.0" printHelp = putStrLn helpMsg -printVersion = putStrLn $ "Alpha version "++version +printVersion = putStrLn $ "Alpha version "++showVersion version newtype Str = Str String instance Show Str where show (Str s) = s @@ -52,10 +54,16 @@ where entry = formatEntry $ outputFmt opts languageFile language = languageDir optslanguage<.>"l" - findSource language = findM doesFileExist (concat [[base<.>"a",base] | dir <- sourceDirs opts - , let base = dirlanguage]) + findSource language = findM doesFileExist [file | dir <- sourceDirs opts + , let base = dirlanguage + , file <- [base<.>"a",base]] - interactive = void $ compileFile "/dev/stdin" + interactive = withDefaultContext entry $ do + putStrLn $ "Alpha, version "++showVersion version++". Type alpha/help() for help on Alpha invocation. ^D to exit." + str <- getContents + let sTree = concat $ parseAlpha "/dev/stdin" str + mapM_ (\e -> compileExpr e >> putStr "> " >> hFlush stdout) (Group []:sTree) + putStrLn "\rGoodbye !" compileProgram (language,root) = withDefaultContext entry $ do importLanguage compileLanguage (const $ return ()) language l <- viewing language_ get @@ -80,17 +88,16 @@ B.writeFile langFile (Ser.encode lang) return lang return (not skip,l) - - compileFile src = withDefaultContext entry $ (>> gets language) $ do - str <- readFile src - let sTree = concat $ parseAlpha src str - init <- mapM compileExpr sTree - languageState $ modify $ \e -> exportLanguage $ e { initializeL = init } - where compileExpr expr = do - symExpr <- languageState $ envCast expr - trExpr <- doTransform symExpr - (code,imports) <- languageState $ compile [] Nothing trExpr - mapM_ (importLanguage compileLanguage (mapM_ execCode . initializeL)) imports - execCode code - return code + where compileFile src = withDefaultContext entry $ (>> gets language) $ do + str <- readFile src + let sTree = concat $ parseAlpha src str + init <- mapM compileExpr sTree + languageState $ modify $ \e -> exportLanguage $ e { initializeL = init } + compileExpr expr = do + symExpr <- languageState $ envCast expr + trExpr <- doTransform symExpr + (code,imports) <- languageState $ compile [] Nothing trExpr + mapM_ (importLanguage compileLanguage (mapM_ execCode . initializeL)) imports + execCode code + return code diff --git a/src/Context.hs b/src/Context.hs --- a/src/Context.hs +++ b/src/Context.hs @@ -6,31 +6,32 @@ ,doTransform ,getAddressComp ,execCode) where -import Bindings.Posix.Unistd import Bindings.Posix.Sys.Mman -import Context.Language as Lang +import Bindings.Posix.Unistd import Context.Language +import Context.Language as Lang import Context.Types -import qualified Data.ByteString as B -import Data.ByteString.Unsafe import Data.ByteString.Internal +import Data.ByteString.Unsafe import Data.Functor.Identity import Data.IORef import Data.Maybe -import qualified Data.Map as M import Elf(entryAddress) +import Foreign hiding (unsafePerformIO,unsafeForeignPtrToPtr,void) import Foreign.C import Foreign.ForeignPtr.Unsafe -import Foreign hiding (unsafePerformIO,unsafeForeignPtrToPtr,void) import ID import My.Control.Monad import My.Control.Monad.State +import My.Prelude +import Options import PCode import Specialize import Specialize.Architecture import Syntax import System.IO.Unsafe (unsafePerformIO) -import My.Prelude +import qualified Data.ByteString as B +import qualified Data.Map as M foreign import ccall "mprotect" mprotect :: Ptr () -> CSize -> CInt -> IO CInt @@ -43,7 +44,7 @@ funPtrToInteger f = fromIntegral $ ptrToIntPtr $ castFunPtrToPtr f compAddrRef = unsafePerformIO $ newIORef (undefined :: ID -> IO Int) -contextRef = unsafePerformIO $ newIORef (undefined :: Context) +contextRef = unsafePerformIO $ newIORef (error "Undefined context" :: Context) instance MonadState Context IO where get = readIORef contextRef put = writeIORef contextRef @@ -87,6 +88,9 @@ 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" @@ -94,6 +98,8 @@ 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), @@ -122,6 +128,7 @@ ("alpha/allocate" , Right $ exportAlpha callStub1 allocate_ptr), ("alpha/free" , Right $ exportAlpha callStub1 free_ptr), + ("alpha/help" , Right $ exportAlpha callStub1 printHelp_ptr), ("alpha/print-OK" , Right $ exportAlpha callStub0 printOK_ptr), ("alpha/print-num" , Right $ exportAlpha callStub1 printNum_ptr) ] diff --git a/src/Specialize.hs b/src/Specialize.hs --- a/src/Specialize.hs +++ b/src/Specialize.hs @@ -27,7 +27,6 @@ import System.IO.Unsafe import My.Prelude -import Debug.Trace worldID = ID (-1) @@ -53,10 +52,10 @@ where getsi f = gets $ \a i -> f (a!i) puti i e = modify $ (//[(i,e)]) - nextFuture i f = snd4 $ runInstr i undefined f (const Nothing) + nextFuture i f = snd4 $ runInstr i (error "undefined past") f (const Nothing) gens = array bounds $ zip (flatten codeTree) [0..] gens' = array bounds $ zip [0..] (flatten codeTree) - getPast g i | g == maximum (filter (<=(gens!i)) $ map (gens!) $ prevs i) = Nothing + getPast g i | (case filter (<=(gens!i)) [gens!j | j <- prevs i] of [] -> False ; l -> g==maximum l) = Nothing | otherwise = Just $ fst $ instrs!i instrs = array bounds $ flatten $ descend desc past codeTree where desc i p = ((i,(p,c)),p')