diff --git a/Main.hs b/Main.hs index abb53f8..05f0a60 100644 --- a/Main.hs +++ b/Main.hs @@ -257,10 +257,10 @@ compileFull inputFile moutputFile let cFile = outputFile ++ extension hFile = outputFile ++ ".h" iFile = outputFile ++ ".inc" + lift $ modify $ \cs -> cs { csOutputIncFile = Just iFile } lift $ withOutputFile cFile $ \hb -> withOutputFile hFile $ \hh -> - withOutputFile iFile $ \hi -> - compile ModeCompile inputFile ((hb, hh, hi), hFile) + compile ModeCompile inputFile ((hb, hh), hFile) noteFile cFile when (csRunIndent optsPS) $ exec $ "indent " ++ cFile @@ -282,7 +282,7 @@ compileFull inputFile moutputFile exec $ cCommand sFile oFile (csCompilerFlags optsPS) -- Analyse the assembly for stack sizes, and output a -- "post" C file - lift $ withOutputFile postCFile $ \h -> postCAnalyse sFile ((h,intErr,intErr),intErr) + lift $ withOutputFile postCFile $ \h -> postCAnalyse sFile ((h,intErr),intErr) -- Compile this new "post" C file into an object file exec $ cCommand postCFile postOFile (csCompilerFlags optsPS) -- Link the object files into a binary @@ -325,13 +325,12 @@ compileFull inputFile moutputFile ExitFailure n -> dieReport (Nothing, "Command \"" ++ cmd ++ "\" failed: exited with code: " ++ show n) -- | Picks out the handle from the options and passes it to the function: -useOutputOptions :: (((Handle, Handle, Handle), String) -> PassM ()) -> PassM () +useOutputOptions :: (((Handle, Handle), String) -> PassM ()) -> PassM () useOutputOptions func = do optsPS <- get withHandleFor (csOutputFile optsPS) $ \hb -> withHandleFor (csOutputHeaderFile optsPS) $ \hh -> - withHandleFor (csOutputIncFile optsPS) $ \hi -> - func ((hb, hh, hi), csOutputHeaderFile optsPS) + func ((hb, hh), csOutputHeaderFile optsPS) where withHandleFor "-" func = func stdout withHandleFor file func = @@ -376,11 +375,12 @@ showTokens html ts = evalState (mapM showToken ts >>* spaceOut) 0 then (" ", "
\n", \s -> "" ++ s ++ "") else (" ", "\n", id) + -- | Compile a file. -- This is written in the PassM monad -- as are most of the things it calls -- -- because then it's very easy to pass the state around. -compile :: CompMode -> String -> ((Handle, Handle, Handle), String) -> PassM () -compile mode fn (outHandles@(outHandle, _, _), headerName) +compile :: CompMode -> String -> ((Handle, Handle), String) -> PassM () +compile mode fn (outHandles@(outHandle, _), headerName) = do optsPS <- get debug "{{{ Parse" @@ -441,8 +441,8 @@ compile mode fn (outHandles@(outHandle, _, _), headerName) progress "Done" -- | Analyse an assembly file. -postCAnalyse :: String -> ((Handle, Handle, Handle), String) -> PassM () -postCAnalyse fn ((outHandle, _, _), _) +postCAnalyse :: String -> ((Handle, Handle), String) -> PassM () +postCAnalyse fn ((outHandle, _), _) = do asm <- liftIO $ readFile fn progress "Analysing assembly" diff --git a/backends/GenerateC.hs b/backends/GenerateC.hs index 9ed76d2..acdfa3c 100644 --- a/backends/GenerateC.hs +++ b/backends/GenerateC.hs @@ -155,7 +155,7 @@ cgenOps = GenOps { --}}} --{{{ top-level -generateC :: (Handle, Handle, Handle) -> String -> A.AST -> PassM () +generateC :: (Handle, Handle) -> String -> A.AST -> PassM () generateC = generate cgenOps cgenTopLevel :: String -> A.AST -> CGen () diff --git a/backends/GenerateCBased.hs b/backends/GenerateCBased.hs index 040e174..2d46fa8 100644 --- a/backends/GenerateCBased.hs +++ b/backends/GenerateCBased.hs @@ -58,7 +58,6 @@ type CGenOutput = Either [String] Handle data CGenOutputs = CGenOutputs { cgenBody :: CGenOutput , cgenHeader :: CGenOutput - , cgenOccamInc :: CGenOutput } --{{{ monad definition @@ -246,10 +245,10 @@ fget :: (GenOps -> a) -> CGen a fget = asks -- Handles are body, header, occam-inc -generate :: GenOps -> (Handle, Handle, Handle) -> String -> A.AST -> PassM () -generate ops (hb, hh, hi) hname ast +generate :: GenOps -> (Handle, Handle) -> String -> A.AST -> PassM () +generate ops (hb, hh) hname ast = evalStateT (runReaderT (call genTopLevel hname ast) ops) - (CGenOutputs (Right hb) (Right hh) (Right hi)) + (CGenOutputs (Right hb) (Right hh)) genComma :: CGen () genComma = tell [","] diff --git a/backends/GenerateCPPCSP.hs b/backends/GenerateCPPCSP.hs index 2089465..df08ab8 100644 --- a/backends/GenerateCPPCSP.hs +++ b/backends/GenerateCPPCSP.hs @@ -122,7 +122,7 @@ chansToAny = cppOnlyPass "Transform channels to ANY" --{{{ top-level -- | Transforms the given AST into a pass that generates C++ code. -generateCPPCSP :: (Handle, Handle, Handle) -> String -> A.AST -> PassM () +generateCPPCSP :: (Handle, Handle) -> String -> A.AST -> PassM () generateCPPCSP = generate cppgenOps cppcspPrereq :: [Property] diff --git a/data/CompState.hs b/data/CompState.hs index 329ef1d..2696b40 100644 --- a/data/CompState.hs +++ b/data/CompState.hs @@ -106,7 +106,7 @@ data CompState = CompState { csVerboseLevel :: Int, csOutputFile :: String, csOutputHeaderFile :: String, - csOutputIncFile :: String, + csOutputIncFile :: Maybe String, csKeepTemporaries :: Bool, csEnabledWarnings :: Set WarningType, csRunIndent :: Bool, @@ -156,7 +156,7 @@ emptyState = CompState { csVerboseLevel = 0, csOutputFile = "-", csOutputHeaderFile = "-", - csOutputIncFile = "-", + csOutputIncFile = Nothing, csKeepTemporaries = False, csEnabledWarnings = Set.fromList [ WarnInternal diff --git a/frontends/OccamPasses.hs b/frontends/OccamPasses.hs index feb26dd..fa173b0 100644 --- a/frontends/OccamPasses.hs +++ b/frontends/OccamPasses.hs @@ -21,6 +21,10 @@ module OccamPasses (occamPasses, foldConstants, checkConstants) where import Control.Monad.State import Data.Generics +import Data.List +import qualified Data.Sequence as Seq +import qualified Data.Foldable as F +import System.IO import qualified AST as A import CompState @@ -46,9 +50,40 @@ occamPasses = , checkConstants , resolveAmbiguities , checkTypes + , writeIncFile , pushUpDirections ] +writeIncFile :: Pass +writeIncFile = occamOnlyPass "Write .inc file" [] [] + (passOnlyOnAST "writeIncFile" (\t -> + do out <- getCompState >>* csOutputIncFile + case out of + Just fn -> do f <- liftIO $ openFile fn WriteMode + contents <- emitProcsAsExternal t >>* (unlines . F.toList) + liftIO $ hPutStr f contents + liftIO $ hClose f + Nothing -> return () + return t + )) + where + emitProcsAsExternal :: A.AST -> PassM (Seq.Seq String) + emitProcsAsExternal (A.Spec _ (A.Specification _ n (A.Proc _ _ fs _)) scope) + = do thisProc <- sequence ( + [return "#PRAGMA EXTERNAL \"PROC " + ,showCode n + ,return "(" + ] ++ intersperse (return ",") (map showCode fs) ++ + [return ") = 42\"" + ]) >>* concat + emitProcsAsExternal scope >>* (thisProc Seq.<|) + emitProcsAsExternal (A.Spec _ _ scope) = emitProcsAsExternal scope + emitProcsAsExternal (A.ProcThen _ _ scope) = emitProcsAsExternal scope + emitProcsAsExternal (A.Only {}) = return Seq.empty + emitProcsAsExternal (A.Several _ ss) + = foldl (liftM2 (Seq.><)) (return Seq.empty) (map emitProcsAsExternal ss) + + -- | Fixed the types of array constructors according to the replicator count fixConstructorTypes :: Pass fixConstructorTypes = occamOnlyPass "Fix the types of array constructors"