A whole lot of changes, described in #101 that help with records and separate compilation
The scheme may be strange, but a lot of KRoC compiles with it (and I think the cgtests will compile again now too)
This commit is contained in:
parent
56e9609148
commit
40e0399e4c
|
@ -180,17 +180,22 @@ cgenTopLevel headerName s
|
||||||
tell ["#include <tock_support_cif.h>\n"]
|
tell ["#include <tock_support_cif.h>\n"]
|
||||||
cs <- getCompState
|
cs <- getCompState
|
||||||
|
|
||||||
let isTopLevelSpec (A.Specification _ n _)
|
let isHeaderSpec (A.Specification _ n _)
|
||||||
= A.nameName n `elem` (csOriginalTopLevelProcs cs)
|
= A.nameName n `elem` (csOriginalTopLevelProcs cs)
|
||||||
|
isBodySpec (A.Specification _ n sp)
|
||||||
|
= A.nameName n `notElem` (csOriginalTopLevelProcs cs)
|
||||||
|
|
||||||
tellToHeader $ sequence_ $ map (call genForwardDeclaration)
|
tellToHeader (nameString $ A.Name emptyMeta $ dropPath headerName)
|
||||||
(reverse $ listifyDepth isTopLevelSpec s)
|
$ sequence_ $ map (call genForwardDeclaration True)
|
||||||
|
(reverse $ listifyDepth isHeaderSpec s)
|
||||||
|
|
||||||
|
-- The header now contains record types and such, so we need to include
|
||||||
|
-- that before forward-declaring other PROCs:
|
||||||
|
tell ["#include \"", dropPath headerName, "\"\n"]
|
||||||
-- Things like lifted wrapper_procs we still need to forward-declare,
|
-- Things like lifted wrapper_procs we still need to forward-declare,
|
||||||
-- but we do it in the C file, not in the header:
|
-- but we do it in the C file, not in the header:
|
||||||
sequence_ $ map (call genForwardDeclaration)
|
sequence_ $ map (call genForwardDeclaration False)
|
||||||
(reverse $ listifyDepth (not . isTopLevelSpec) s)
|
(reverse $ listifyDepth (isBodySpec) s)
|
||||||
|
|
||||||
tell ["#include \"", dropPath headerName, "\"\n"]
|
|
||||||
|
|
||||||
sequence_ [let usedFile' = if ".tock.inc" `isSuffixOf` usedFile
|
sequence_ [let usedFile' = if ".tock.inc" `isSuffixOf` usedFile
|
||||||
then take (length usedFile - length ".tock.inc") usedFile
|
then take (length usedFile - length ".tock.inc") usedFile
|
||||||
|
@ -1398,7 +1403,8 @@ cintroduceSpec lvl (A.Specification _ n (A.Is _ _ _ (A.ActualClaim v)))
|
||||||
else "MT_CB_SERVER"
|
else "MT_CB_SERVER"
|
||||||
,")"]
|
,")"]
|
||||||
cintroduceSpec _ (A.Specification _ _ (A.DataType _ _)) = return ()
|
cintroduceSpec _ (A.Specification _ _ (A.DataType _ _)) = return ()
|
||||||
cintroduceSpec _ (A.Specification _ _ (A.RecordType _ _ _)) = return ()
|
cintroduceSpec _ (A.Specification _ n (A.RecordType _ ra nts))
|
||||||
|
= call genRecordTypeSpec True n ra nts
|
||||||
cintroduceSpec _ (A.Specification _ _ (A.ChanBundleType {})) = return ()
|
cintroduceSpec _ (A.Specification _ _ (A.ChanBundleType {})) = return ()
|
||||||
cintroduceSpec _ (A.Specification _ n (A.Protocol _ _)) = return ()
|
cintroduceSpec _ (A.Specification _ n (A.Protocol _ _)) = return ()
|
||||||
cintroduceSpec _ (A.Specification _ n (A.ProtocolCase _ ts))
|
cintroduceSpec _ (A.Specification _ n (A.ProtocolCase _ ts))
|
||||||
|
@ -1446,19 +1452,17 @@ cintroduceSpec _ (A.Specification _ n (A.Forking _))
|
||||||
--cintroduceSpec (A.Specification _ n (A.RetypesExpr _ am t e))
|
--cintroduceSpec (A.Specification _ n (A.RetypesExpr _ am t e))
|
||||||
cintroduceSpec _ n = call genMissing $ "introduceSpec " ++ show n
|
cintroduceSpec _ n = call genMissing $ "introduceSpec " ++ show n
|
||||||
|
|
||||||
cgenRecordTypeSpec :: A.Name -> A.RecordAttr -> [(A.Name, A.Type)] -> CGen ()
|
cgenRecordTypeSpec :: Bool -> A.Name -> A.RecordAttr -> [(A.Name, A.Type)] -> CGen ()
|
||||||
cgenRecordTypeSpec n attr fs
|
cgenRecordTypeSpec extraStuff n attr fs
|
||||||
|
| not extraStuff
|
||||||
= do tell ["typedef struct{"]
|
= do tell ["typedef struct{"]
|
||||||
sequence_ [call genDeclaration NotTopLevel t n True | (n, t) <- fs]
|
sequence_ [call genDeclaration NotTopLevel t n True | (n, t) <- fs]
|
||||||
tell ["}"]
|
tell ["}"]
|
||||||
when (A.packedRecord attr || A.mobileRecord attr) $ tell [" occam_struct_packed "]
|
when (A.packedRecord attr || A.mobileRecord attr) $ tell [" occam_struct_packed "]
|
||||||
genName n
|
genName n
|
||||||
tell [";"]
|
tell [";"]
|
||||||
tell ["typedef "]
|
| otherwise
|
||||||
genName n
|
= if null [t | (_, A.Mobile t) <- fs]
|
||||||
origN <- lookupName n >>* A.ndOrigName
|
|
||||||
tell [" ", nameString $ A.Name emptyMeta origN, ";"]
|
|
||||||
if null [t | (_, A.Mobile t) <- fs]
|
|
||||||
then do genStatic TopLevel n
|
then do genStatic TopLevel n
|
||||||
tell ["const word "]
|
tell ["const word "]
|
||||||
genName n
|
genName n
|
||||||
|
@ -1493,12 +1497,12 @@ cgenRecordTypeSpec n attr fs
|
||||||
] ++ mt t
|
] ++ mt t
|
||||||
mt t = [mobileElemType False t]
|
mt t = [mobileElemType False t]
|
||||||
|
|
||||||
cgenForwardDeclaration :: A.Specification -> CGen ()
|
cgenForwardDeclaration :: Bool -> A.Specification -> CGen ()
|
||||||
cgenForwardDeclaration (A.Specification _ n st@(A.Proc _ _ _ _))
|
cgenForwardDeclaration _ (A.Specification _ n st@(A.Proc _ _ _ _))
|
||||||
= genProcSpec TopLevel n st True
|
= genProcSpec TopLevel n st True
|
||||||
cgenForwardDeclaration (A.Specification _ n (A.RecordType _ b fs))
|
cgenForwardDeclaration True (A.Specification _ n (A.RecordType _ b fs))
|
||||||
= call genRecordTypeSpec n b fs
|
= call genRecordTypeSpec False n b fs
|
||||||
cgenForwardDeclaration _ = return ()
|
cgenForwardDeclaration _ _ = return ()
|
||||||
|
|
||||||
cremoveSpec :: A.Specification -> CGen ()
|
cremoveSpec :: A.Specification -> CGen ()
|
||||||
cremoveSpec (A.Specification m n (A.Declaration _ t))
|
cremoveSpec (A.Specification m n (A.Declaration _ t))
|
||||||
|
@ -1625,6 +1629,7 @@ genProcSpec lvl n (A.Proc _ (sm, rm) fs (Just p)) forwardDecl
|
||||||
tell [" (Workspace wptr"]
|
tell [" (Workspace wptr"]
|
||||||
sequence_ [do tell [", "]
|
sequence_ [do tell [", "]
|
||||||
case origT of
|
case origT of
|
||||||
|
{-
|
||||||
A.Record rn | forwardDecl
|
A.Record rn | forwardDecl
|
||||||
-> do origN <- lookupName rn >>* A.ndOrigName
|
-> do origN <- lookupName rn >>* A.ndOrigName
|
||||||
ct <- call getCType (A.nameMeta rn)
|
ct <- call getCType (A.nameMeta rn)
|
||||||
|
@ -1632,7 +1637,7 @@ genProcSpec lvl n (A.Proc _ (sm, rm) fs (Just p)) forwardDecl
|
||||||
tell [show $ replacePlainType (nameString rn)
|
tell [show $ replacePlainType (nameString rn)
|
||||||
(nameString $ A.Name emptyMeta origN) ct
|
(nameString $ A.Name emptyMeta origN) ct
|
||||||
]
|
]
|
||||||
_ -> t
|
-} _ -> t
|
||||||
tell [" "]
|
tell [" "]
|
||||||
n
|
n
|
||||||
| (A.Formal am origT _, (t, n)) <- zip fs rfs]
|
| (A.Formal am origT _, (t, n)) <- zip fs rfs]
|
||||||
|
|
|
@ -23,6 +23,8 @@ import Control.Monad.Reader
|
||||||
import Control.Monad.State
|
import Control.Monad.State
|
||||||
import Control.Monad.Writer hiding (tell)
|
import Control.Monad.Writer hiding (tell)
|
||||||
import Data.Generics (Data)
|
import Data.Generics (Data)
|
||||||
|
import Data.HashTable (hashString)
|
||||||
|
import Data.Int (Int32)
|
||||||
import Data.List
|
import Data.List
|
||||||
import System.IO
|
import System.IO
|
||||||
|
|
||||||
|
@ -71,14 +73,31 @@ instance CSMR CGen where
|
||||||
getCompState = lift getCompState
|
getCompState = lift getCompState
|
||||||
|
|
||||||
-- Do not nest calls to this function!
|
-- Do not nest calls to this function!
|
||||||
tellToHeader :: CGen a -> CGen a
|
-- The function also puts in the #ifndef/#define/#endif stuff that prevents multiple
|
||||||
tellToHeader act
|
-- inclusion.
|
||||||
|
tellToHeader :: String -> CGen a -> CGen a
|
||||||
|
tellToHeader stem act
|
||||||
= do st <- get
|
= do st <- get
|
||||||
put $ st { cgenBody = cgenHeader st }
|
put $ st { cgenBody = Left [] }
|
||||||
x <- act
|
x <- act
|
||||||
st' <- get
|
st' <- get
|
||||||
put $ st' { cgenBody = cgenBody st, cgenHeader = cgenBody st' }
|
let Left mainBit = cgenBody st'
|
||||||
|
nonce = "_" ++ stem ++ "_" ++ show (makePosInteger $ hashString $ concat mainBit)
|
||||||
|
contents =
|
||||||
|
"#ifndef " ++ nonce ++ "\n" ++
|
||||||
|
"#define " ++ nonce ++ "\n" ++
|
||||||
|
concat mainBit ++ "\n" ++
|
||||||
|
"#endif\n"
|
||||||
|
case cgenHeader st of
|
||||||
|
Right h -> do liftIO $ hPutStr h contents
|
||||||
|
put $ st' { cgenBody = cgenBody st }
|
||||||
|
Left ls -> do put $ st' { cgenBody = cgenBody st
|
||||||
|
, cgenHeader = Left $ ls ++ [contents]
|
||||||
|
}
|
||||||
return x
|
return x
|
||||||
|
where
|
||||||
|
makePosInteger :: Int32 -> Integer
|
||||||
|
makePosInteger n = toInteger n + (toInteger (maxBound :: Int32))
|
||||||
|
|
||||||
tell :: [String] -> CGen ()
|
tell :: [String] -> CGen ()
|
||||||
tell x = do st <- get
|
tell x = do st <- get
|
||||||
|
@ -138,7 +157,8 @@ data GenOps = GenOps {
|
||||||
genDirectedVariable :: Meta -> A.Type -> CGen () -> A.Direction -> CGen (),
|
genDirectedVariable :: Meta -> A.Type -> CGen () -> A.Direction -> CGen (),
|
||||||
genExpression :: A.Expression -> CGen (),
|
genExpression :: A.Expression -> CGen (),
|
||||||
genFlatArraySize :: [A.Dimension] -> CGen (),
|
genFlatArraySize :: [A.Dimension] -> CGen (),
|
||||||
genForwardDeclaration :: A.Specification -> CGen(),
|
-- Bool is true if this is for the header:
|
||||||
|
genForwardDeclaration :: Bool -> A.Specification -> CGen(),
|
||||||
-- | Only used for built-in operators at the moment:
|
-- | Only used for built-in operators at the moment:
|
||||||
genFunctionCall :: Meta -> A.Name -> [A.Expression] -> CGen (),
|
genFunctionCall :: Meta -> A.Name -> [A.Expression] -> CGen (),
|
||||||
-- | Gets the current time into the given variable
|
-- | Gets the current time into the given variable
|
||||||
|
@ -169,7 +189,7 @@ data GenOps = GenOps {
|
||||||
genPoison :: Meta -> A.Variable -> CGen (),
|
genPoison :: Meta -> A.Variable -> CGen (),
|
||||||
genProcCall :: A.Name -> [A.Actual] -> CGen (),
|
genProcCall :: A.Name -> [A.Actual] -> CGen (),
|
||||||
genProcess :: A.Process -> CGen (),
|
genProcess :: A.Process -> CGen (),
|
||||||
genRecordTypeSpec :: A.Name -> A.RecordAttr -> [(A.Name, A.Type)] -> CGen (),
|
genRecordTypeSpec :: Bool -> A.Name -> A.RecordAttr -> [(A.Name, A.Type)] -> CGen (),
|
||||||
genReplicatorStart :: A.Name -> A.Replicator -> CGen (),
|
genReplicatorStart :: A.Name -> A.Replicator -> CGen (),
|
||||||
genReplicatorEnd :: A.Replicator -> CGen (),
|
genReplicatorEnd :: A.Replicator -> CGen (),
|
||||||
-- | Generates the three bits of a for loop (e.g. @int i = 0; i < 10; i++@ for the given replicator)
|
-- | Generates the three bits of a for loop (e.g. @int i = 0; i < 10; i++@ for the given replicator)
|
||||||
|
|
|
@ -141,16 +141,22 @@ cppgenTopLevel headerName s
|
||||||
|
|
||||||
cs <- getCompState
|
cs <- getCompState
|
||||||
|
|
||||||
let isTopLevelSpec (A.Specification _ n _)
|
let isHeaderSpec (A.Specification _ n _)
|
||||||
= A.nameName n `elem` (csOriginalTopLevelProcs cs)
|
= A.nameName n `elem` (csOriginalTopLevelProcs cs)
|
||||||
|
isBodySpec (A.Specification _ n sp)
|
||||||
|
= case sp of
|
||||||
|
A.RecordType {} -> True
|
||||||
|
_ -> A.nameName n `elem` (csOriginalTopLevelProcs cs)
|
||||||
|
|
||||||
tellToHeader $ sequence_ $ map (call genForwardDeclaration)
|
|
||||||
(reverse $ listifyDepth isTopLevelSpec s)
|
tellToHeader (nameString $ A.Name emptyMeta $ dropPath headerName)
|
||||||
|
$ sequence_ $ map (call genForwardDeclaration True)
|
||||||
|
(reverse $ listifyDepth isHeaderSpec s)
|
||||||
-- Things like lifted wrapper_procs we still need to forward-declare,
|
-- Things like lifted wrapper_procs we still need to forward-declare,
|
||||||
-- but we do it in the C file, not in the header:
|
-- but we do it in the C file, not in the header:
|
||||||
sequence_ $ map (call genForwardDeclaration)
|
sequence_ $ map (call genForwardDeclaration False)
|
||||||
(reverse $ listifyDepth (\sp@(A.Specification _ n _)
|
(reverse $ listifyDepth (\sp@(A.Specification _ n _)
|
||||||
-> not (isTopLevelSpec sp)
|
-> isBodySpec sp
|
||||||
&& A.nameName n `notElem` map fst (csExternals cs)) s)
|
&& A.nameName n `notElem` map fst (csExternals cs)) s)
|
||||||
|
|
||||||
tell ["#include \"", dropPath headerName, "\"\n"]
|
tell ["#include \"", dropPath headerName, "\"\n"]
|
||||||
|
@ -540,8 +546,8 @@ cppgenFormals nameFunc list = seqComma (map (cppgenFormal nameFunc) list)
|
||||||
cppgenFormal :: (A.Name -> A.Name) -> A.Formal -> CGen ()
|
cppgenFormal :: (A.Name -> A.Name) -> A.Formal -> CGen ()
|
||||||
cppgenFormal nameFunc (A.Formal am t n) = call genDecl NotTopLevel am t (nameFunc n)
|
cppgenFormal nameFunc (A.Formal am t n) = call genDecl NotTopLevel am t (nameFunc n)
|
||||||
|
|
||||||
cppgenForwardDeclaration :: A.Specification -> CGen()
|
cppgenForwardDeclaration :: Bool -> A.Specification -> CGen()
|
||||||
cppgenForwardDeclaration (A.Specification _ n (A.Proc _ (sm, _) fs _))
|
cppgenForwardDeclaration _ (A.Specification _ n (A.Proc _ (sm, _) fs _))
|
||||||
= do --Generate the "process" as a C++ function:
|
= do --Generate the "process" as a C++ function:
|
||||||
genStatic TopLevel n
|
genStatic TopLevel n
|
||||||
call genSpecMode sm
|
call genSpecMode sm
|
||||||
|
@ -591,9 +597,9 @@ cppgenForwardDeclaration (A.Specification _ n (A.Proc _ (sm, _) fs _))
|
||||||
genConstructorList :: [A.Formal] -> CGen ()
|
genConstructorList :: [A.Formal] -> CGen ()
|
||||||
genConstructorList fs = mapM_ genConsItem fs
|
genConstructorList fs = mapM_ genConsItem fs
|
||||||
|
|
||||||
cppgenForwardDeclaration (A.Specification _ n (A.RecordType _ b fs))
|
cppgenForwardDeclaration header (A.Specification _ n (A.RecordType _ b fs))
|
||||||
= call genRecordTypeSpec n b fs
|
= call genRecordTypeSpec (not header) n b fs
|
||||||
cppgenForwardDeclaration _ = return ()
|
cppgenForwardDeclaration _ _ = return ()
|
||||||
|
|
||||||
cppintroduceSpec :: Level -> A.Specification -> CGen ()
|
cppintroduceSpec :: Level -> A.Specification -> CGen ()
|
||||||
--I generate process wrappers for all functions by default:
|
--I generate process wrappers for all functions by default:
|
||||||
|
@ -923,8 +929,8 @@ cppgenFunctionCall m n es
|
||||||
tell [")"]
|
tell [")"]
|
||||||
|
|
||||||
-- Changed because we don't need the mobile descriptor stuff:
|
-- Changed because we don't need the mobile descriptor stuff:
|
||||||
cppgenRecordTypeSpec :: A.Name -> A.RecordAttr -> [(A.Name, A.Type)] -> CGen ()
|
cppgenRecordTypeSpec :: Bool -> A.Name -> A.RecordAttr -> [(A.Name, A.Type)] -> CGen ()
|
||||||
cppgenRecordTypeSpec n attr fs
|
cppgenRecordTypeSpec True n attr fs
|
||||||
= do tell ["typedef struct{"]
|
= do tell ["typedef struct{"]
|
||||||
sequence_ [call genDeclaration NotTopLevel t n True | (n, t) <- fs]
|
sequence_ [call genDeclaration NotTopLevel t n True | (n, t) <- fs]
|
||||||
tell ["}"]
|
tell ["}"]
|
||||||
|
@ -935,3 +941,4 @@ cppgenRecordTypeSpec n attr fs
|
||||||
genName n
|
genName n
|
||||||
origN <- lookupName n >>* A.ndOrigName
|
origN <- lookupName n >>* A.ndOrigName
|
||||||
tell [" ", nameString $ A.Name emptyMeta origN, ";"]
|
tell [" ", nameString $ A.Name emptyMeta origN, ";"]
|
||||||
|
cppgenRecordTypeSpec False _ _ _ = return ()
|
||||||
|
|
|
@ -607,7 +607,7 @@ testRecord = TestList
|
||||||
|
|
||||||
testAllS :: Int -> (String,String) -> (String,String) -> A.Name -> A.RecordAttr -> [(A.Name, A.Type)] -> State CompState () -> (GenOps -> GenOps) -> Test
|
testAllS :: Int -> (String,String) -> (String,String) -> A.Name -> A.RecordAttr -> [(A.Name, A.Type)] -> State CompState () -> (GenOps -> GenOps) -> Test
|
||||||
testAllS n (eCI,eCR) (eCPPI,eCPPR) rn rb rts st overFunc
|
testAllS n (eCI,eCR) (eCPPI,eCPPR) rn rb rts st overFunc
|
||||||
= testBothS ("testRecord " ++ show n) eCI eCPPI (local overFunc (tcall genRecordTypeSpec rn rb rts)) st
|
= testBothS ("testRecord " ++ show n) eCI eCPPI (local overFunc (tcall genRecordTypeSpec False rn rb rts)) st
|
||||||
testAllSame n e s0 s1 s2 = testAll n e e s0 s1 s2
|
testAllSame n e s0 s1 s2 = testAll n e e s0 s1 s2
|
||||||
over ops = ops {genDeclaration = override3 (tell . (\x -> ["#ATION_",show x]))
|
over ops = ops {genDeclaration = override3 (tell . (\x -> ["#ATION_",show x]))
|
||||||
,declareInit = (override3 (Just $ tell ["#INIT"])), declareFree = override3 (Just $ tell ["#FREE"])
|
,declareInit = (override3 (Just $ tell ["#INIT"])), declareFree = override3 (Just $ tell ["#FREE"])
|
||||||
|
|
|
@ -435,6 +435,60 @@ sameType ta@(A.UserDataType {}) tb
|
||||||
sameType ta tb@(A.UserDataType {})
|
sameType ta tb@(A.UserDataType {})
|
||||||
= do tb' <- resolveUserType emptyMeta tb
|
= do tb' <- resolveUserType emptyMeta tb
|
||||||
sameType ta tb'
|
sameType ta tb'
|
||||||
|
|
||||||
|
-- For records, because of the way separate compilation works, the same record
|
||||||
|
-- might end up with two different names. So we consider records to be the same
|
||||||
|
-- type, iff:
|
||||||
|
-- a. They have the same original name, AND
|
||||||
|
-- b. Their attributes are the same, AND
|
||||||
|
-- c. There are the same number of fields, AND
|
||||||
|
-- d. The fields have matching names, AND
|
||||||
|
-- e. The fields have matching types.
|
||||||
|
sameType (A.Record na) (A.Record nb)
|
||||||
|
= do nad <- lookupName na
|
||||||
|
nbd <- lookupName nb
|
||||||
|
let matchOn :: Eq a => (A.NameDef -> a) -> Bool
|
||||||
|
matchOn f = f nad == f nbd
|
||||||
|
|
||||||
|
allButTypesSame = and $
|
||||||
|
[matchOn A.ndOrigName
|
||||||
|
,matchOn $ (\(A.RecordType _ ra _) -> ra) . A.ndSpecType
|
||||||
|
,matchOn $ (\(A.RecordType _ _ fs) -> length fs) . A.ndSpecType
|
||||||
|
,matchOn $ (\(A.RecordType _ _ fs) -> map fst fs) . A.ndSpecType
|
||||||
|
]
|
||||||
|
|
||||||
|
getTypes = (\(A.RecordType _ _ fs) -> map snd fs) . A.ndSpecType
|
||||||
|
|
||||||
|
if allButTypesSame
|
||||||
|
then liftM and $ mapM (uncurry sameType) (zip (getTypes nad) (getTypes nbd))
|
||||||
|
else return False
|
||||||
|
-- For protocols (due to separate compilation) we check that the original names
|
||||||
|
-- were the same, and that all the types match, similar to records
|
||||||
|
sameType (A.UserProtocol na) (A.UserProtocol nb)
|
||||||
|
= do nad <- lookupName na
|
||||||
|
nbd <- lookupName nb
|
||||||
|
if A.ndOrigName nad == A.ndOrigName nbd
|
||||||
|
then case (A.ndSpecType nad, A.ndSpecType nbd) of
|
||||||
|
(A.Protocol _ ats, A.Protocol _ bts)
|
||||||
|
| length ats == length bts
|
||||||
|
-> liftM and $ mapM (uncurry sameType) (zip ats bts)
|
||||||
|
(A.ProtocolCase _ ants, A.ProtocolCase _ bnts)
|
||||||
|
| length ants == length bnts && map fst ants == map fst bnts
|
||||||
|
-> liftM and $ mapM (liftM and . sequence . uncurry (zipWith sameType)) (zip (map snd ants) (map snd bnts))
|
||||||
|
_ -> return False
|
||||||
|
else return False
|
||||||
|
-- Finally, for channel bundle types, we proceed as with the others:
|
||||||
|
sameType (A.ChanDataType dirA shA na) (A.ChanDataType dirB shB nb)
|
||||||
|
| dirA == dirB && shA == shB
|
||||||
|
= do nad <- lookupName na
|
||||||
|
nbd <- lookupName nb
|
||||||
|
if A.ndOrigName nad == A.ndOrigName nbd
|
||||||
|
then case (A.ndSpecType nad, A.ndSpecType nbd) of
|
||||||
|
(A.ChanBundleType _ arm ants, A.ChanBundleType _ brm bnts)
|
||||||
|
| arm == brm && length ants == length bnts && map fst ants == map fst bnts
|
||||||
|
-> liftM and $ mapM (uncurry sameType) (zip (map snd ants) (map snd bnts))
|
||||||
|
_ -> return False
|
||||||
|
else return False
|
||||||
sameType a b = return $ a == b
|
sameType a b = return $ a == b
|
||||||
|
|
||||||
-- | Check that the second dimension can be used in a context where the first
|
-- | Check that the second dimension can be used in a context where the first
|
||||||
|
|
|
@ -64,36 +64,69 @@ writeIncFile = occamOnlyPass "Write .inc file" [] []
|
||||||
do out <- getCompOpts >>* csOutputIncFile
|
do out <- getCompOpts >>* csOutputIncFile
|
||||||
case out of
|
case out of
|
||||||
Just fn -> do f <- liftIO $ openFile fn WriteMode
|
Just fn -> do f <- liftIO $ openFile fn WriteMode
|
||||||
contents <- emitProcsAsExternal t >>* (unlines . F.toList)
|
(origLines, ns) <- runStateT (emitProcsAsExternal t) []
|
||||||
liftIO $ hPutStr f contents
|
allLines <- mapM mask ns >>* (F.toList origLines ++)
|
||||||
|
liftIO $ hPutStr f $ unlines allLines
|
||||||
liftIO $ hClose f
|
liftIO $ hClose f
|
||||||
Nothing -> return ()
|
Nothing -> return ()
|
||||||
return t
|
return t
|
||||||
))
|
))
|
||||||
where
|
where
|
||||||
emitProcsAsExternal :: A.AST -> PassM (Seq.Seq String)
|
emitProcsAsExternal :: A.AST -> StateT [A.Name] PassM (Seq.Seq String)
|
||||||
emitProcsAsExternal (A.Spec _ (A.Specification _ n (A.Proc _ (A.PlainSpec,_) fs (Just _))) scope)
|
emitProcsAsExternal (A.Spec _ (A.Specification _ n (A.Proc _ (A.PlainSpec,_) fs (Just _))) scope)
|
||||||
= do origN <- lookupName n >>* A.ndOrigName
|
= do origN <- lookupName n >>* A.ndOrigName
|
||||||
thisProc <- sequence (
|
thisProc <- sequence (
|
||||||
[return $ "#PRAGMA TOCKEXTERNAL \"PROC " ++ origN ++ "("
|
[return $ "#PRAGMA TOCKEXTERNAL \"PROC " ++ origN ++ "("
|
||||||
] ++ intersperse (return ",") (map showCode fs) ++
|
] ++ intersperse (return ",") (map showFormal fs) ++
|
||||||
[return $ ") = " ++ nameString n ++ "\""
|
[return $ ") = " ++ nameString n ++ "\""
|
||||||
]) >>* concat
|
]) >>* concat
|
||||||
modify $ \cs -> cs { csOriginalTopLevelProcs =
|
recTopLevelName n
|
||||||
A.nameName n : csOriginalTopLevelProcs cs }
|
|
||||||
emitProcsAsExternal scope >>* (thisProc Seq.<|)
|
emitProcsAsExternal scope >>* (thisProc Seq.<|)
|
||||||
emitProcsAsExternal (A.Spec _ (A.Specification _ n (A.Function _ (A.PlainSpec,_) ts fs (Just _))) scope)
|
emitProcsAsExternal (A.Spec _ (A.Specification _ n (A.Function m (A.PlainSpec,_) ts fs (Just _))) scope)
|
||||||
= do origN <- lookupName n >>* A.ndOrigName
|
= do origN <- lookupName n >>* A.ndOrigName
|
||||||
thisProc <- sequence (
|
thisProc <- sequence (
|
||||||
[return $ "#PRAGMA TOCKEXTERNAL \""
|
[return $ "#PRAGMA TOCKEXTERNAL \""
|
||||||
] ++ intersperse (return ",") (map showCode ts) ++
|
] ++ intersperse (return ",") (map (showType m) ts) ++
|
||||||
[return $ " FUNCTION " ++ showFuncName origN ++ "("
|
[return $ " FUNCTION " ++ showFuncName origN ++ "("
|
||||||
] ++ intersperse (return ",") (map showCode fs) ++
|
] ++ intersperse (return ",") (map showFormal fs) ++
|
||||||
[return $ ") = " ++ nameString n ++ "\""
|
[return $ ") = " ++ nameString n ++ "\""
|
||||||
]) >>* concat
|
]) >>* concat
|
||||||
modify $ \cs -> cs { csOriginalTopLevelProcs =
|
recTopLevelName n
|
||||||
A.nameName n : csOriginalTopLevelProcs cs }
|
|
||||||
emitProcsAsExternal scope >>* (thisProc Seq.<|)
|
emitProcsAsExternal scope >>* (thisProc Seq.<|)
|
||||||
|
emitProcsAsExternal (A.Spec _ (A.Specification _ n
|
||||||
|
(A.RecordType m ra nts)) scope)
|
||||||
|
= do ts' <- mapM (underlyingType m) ts
|
||||||
|
thisDef <- showCode $ A.Specification m n $ A.RecordType m ra (zip ns ts')
|
||||||
|
recordType n
|
||||||
|
recTopLevelName n
|
||||||
|
emitProcsAsExternal scope >>* (thisDef Seq.<|)
|
||||||
|
where
|
||||||
|
(ns, ts) = unzip nts
|
||||||
|
emitProcsAsExternal (A.Spec _ (A.Specification _ n
|
||||||
|
(A.ChanBundleType m rm nts)) scope)
|
||||||
|
= do ts' <- mapM (underlyingType m) ts
|
||||||
|
thisDef <- showCode $ A.Specification m n $ A.ChanBundleType m rm (zip ns ts')
|
||||||
|
recordType n
|
||||||
|
recTopLevelName n
|
||||||
|
emitProcsAsExternal scope >>* (thisDef Seq.<|)
|
||||||
|
where
|
||||||
|
(ns, ts) = unzip nts
|
||||||
|
emitProcsAsExternal (A.Spec _ (A.Specification _ n
|
||||||
|
(A.Protocol m ts)) scope)
|
||||||
|
= do ts' <- mapM (underlyingType m) ts
|
||||||
|
thisDef <- showCode $ A.Specification m n $ A.Protocol m ts'
|
||||||
|
recordType n
|
||||||
|
recTopLevelName n
|
||||||
|
emitProcsAsExternal scope >>* (thisDef Seq.<|)
|
||||||
|
emitProcsAsExternal (A.Spec _ (A.Specification _ n
|
||||||
|
(A.ProtocolCase m nts)) scope)
|
||||||
|
= do ts' <- mapM (mapM $ underlyingType m) ts
|
||||||
|
thisDef <- showCode $ A.Specification m n $ A.ProtocolCase m (zip ns ts')
|
||||||
|
recordType n
|
||||||
|
recTopLevelName n
|
||||||
|
emitProcsAsExternal scope >>* (thisDef Seq.<|)
|
||||||
|
where
|
||||||
|
(ns, ts) = unzip nts
|
||||||
emitProcsAsExternal (A.Spec _ (A.Specification _ n _) scope)
|
emitProcsAsExternal (A.Spec _ (A.Specification _ n _) scope)
|
||||||
= emitProcsAsExternal scope
|
= emitProcsAsExternal scope
|
||||||
emitProcsAsExternal (A.ProcThen _ _ scope) = emitProcsAsExternal scope
|
emitProcsAsExternal (A.ProcThen _ _ scope) = emitProcsAsExternal scope
|
||||||
|
@ -101,12 +134,32 @@ writeIncFile = occamOnlyPass "Write .inc file" [] []
|
||||||
emitProcsAsExternal (A.Several _ ss)
|
emitProcsAsExternal (A.Several _ ss)
|
||||||
= foldl (liftM2 (Seq.><)) (return Seq.empty) (map emitProcsAsExternal ss)
|
= foldl (liftM2 (Seq.><)) (return Seq.empty) (map emitProcsAsExternal ss)
|
||||||
|
|
||||||
|
-- FIXME: for all the types, we should also output the types that they depend
|
||||||
|
-- on
|
||||||
|
|
||||||
showFuncName :: String -> String
|
showFuncName :: String -> String
|
||||||
showFuncName s | isOperator s = "\"" ++ doubleStars s ++ "\""
|
showFuncName s | isOperator s = "\"" ++ doubleStars s ++ "\""
|
||||||
| otherwise = s
|
| otherwise = s
|
||||||
where
|
where
|
||||||
doubleStars cs = concat [if c == '*' then "**" else [c] | c <- cs]
|
doubleStars cs = concat [if c == '*' then "**" else [c] | c <- cs]
|
||||||
|
|
||||||
|
recordType :: A.Name -> StateT [A.Name] PassM ()
|
||||||
|
recordType n = modify (n:)
|
||||||
|
|
||||||
|
recTopLevelName :: A.Name -> StateT [A.Name] PassM ()
|
||||||
|
recTopLevelName n = modifyCompState $ \cs -> cs { csOriginalTopLevelProcs =
|
||||||
|
A.nameName n : csOriginalTopLevelProcs cs }
|
||||||
|
|
||||||
|
mask :: A.Name -> PassM String
|
||||||
|
mask n = lookupName n >>* A.ndOrigName >>* ("#PRAGMA TOCKUNSCOPE " ++)
|
||||||
|
|
||||||
|
showType :: Meta -> A.Type -> StateT [A.Name] PassM String
|
||||||
|
showType m = showCode <.< underlyingType m
|
||||||
|
|
||||||
|
showFormal :: A.Formal -> StateT [A.Name] PassM String
|
||||||
|
showFormal (A.Formal am t n) = do t' <- underlyingType (findMeta n) t
|
||||||
|
showCode $ A.Formal am t' n
|
||||||
|
|
||||||
-- | Fixed the types of array constructors according to the replicator count
|
-- | Fixed the types of array constructors according to the replicator count
|
||||||
fixConstructorTypes :: PassOn A.Expression
|
fixConstructorTypes :: PassOn A.Expression
|
||||||
fixConstructorTypes = occamOnlyPass "Fix the types of array constructors"
|
fixConstructorTypes = occamOnlyPass "Fix the types of array constructors"
|
||||||
|
|
|
@ -43,7 +43,7 @@ import Types
|
||||||
import Utils
|
import Utils
|
||||||
|
|
||||||
data OccParserState = OccParserState
|
data OccParserState = OccParserState
|
||||||
{ csLocalNames :: [(String, (A.Name, NameType))]
|
{ csLocalNames :: [(String, (A.Name, NameType, Bool))]
|
||||||
, compState :: CompState
|
, compState :: CompState
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -58,8 +58,9 @@ instance CSM (GenParser tok OccParserState) where
|
||||||
setState $ st { compState = cs }
|
setState $ st { compState = cs }
|
||||||
|
|
||||||
addLocalName :: (String, (A.Name, NameType)) -> OccParser ()
|
addLocalName :: (String, (A.Name, NameType)) -> OccParser ()
|
||||||
addLocalName n = do st <- getState
|
addLocalName (s, (n, nt))
|
||||||
setState $ st { csLocalNames = n : csLocalNames st }
|
= do st <- getState
|
||||||
|
setState $ st { csLocalNames = (s, (n, nt, True)) : csLocalNames st }
|
||||||
|
|
||||||
-- The other part of the state is actually the built-up list of warnings:
|
-- The other part of the state is actually the built-up list of warnings:
|
||||||
instance Warn (GenParser tok OccParserState) where
|
instance Warn (GenParser tok OccParserState) where
|
||||||
|
@ -403,10 +404,10 @@ findName :: A.Name -> NameType -> OccParser A.Name
|
||||||
findName thisN thisNT
|
findName thisN thisNT
|
||||||
= do st <- getState
|
= do st <- getState
|
||||||
(origN, origNT) <-
|
(origN, origNT) <-
|
||||||
case lookup (A.nameName thisN) (csLocalNames st) of
|
case lookup (A.nameName thisN) [(s, (n, nt)) | (s, (n, nt, True)) <- csLocalNames st] of
|
||||||
Nothing -> dieP (A.nameMeta thisN) $ "name " ++ A.nameName thisN ++ " not defined"
|
|
||||||
++ "; possibilities were: " ++ show (map fst (csLocalNames st))
|
|
||||||
Just def -> return def
|
Just def -> return def
|
||||||
|
_ -> dieP (A.nameMeta thisN) $ "name " ++ A.nameName thisN ++ " not defined"
|
||||||
|
++ "; possibilities were: " ++ show (map fst (csLocalNames st))
|
||||||
if thisNT /= origNT
|
if thisNT /= origNT
|
||||||
then dieP (A.nameMeta thisN) $ "expected " ++ show thisNT ++ " (" ++ A.nameName origN ++ " is " ++ show origNT ++ ")"
|
then dieP (A.nameMeta thisN) $ "expected " ++ show thisNT ++ " (" ++ A.nameName origN ++ " is " ++ show origNT ++ ")"
|
||||||
else return $ thisN { A.nameName = A.nameName origN }
|
else return $ thisN { A.nameName = A.nameName origN }
|
||||||
|
@ -434,7 +435,7 @@ scopeOut :: A.Name -> OccParser ()
|
||||||
scopeOut n@(A.Name m _)
|
scopeOut n@(A.Name m _)
|
||||||
= do st <- getState
|
= do st <- getState
|
||||||
case csLocalNames st of
|
case csLocalNames st of
|
||||||
((_, (old, _)):rest)
|
((_, (old, _, _)):rest)
|
||||||
| old == n -> setState $ st { csLocalNames = rest }
|
| old == n -> setState $ st { csLocalNames = rest }
|
||||||
| otherwise -> dieInternal (Just m, "scoping out not in order; "
|
| otherwise -> dieInternal (Just m, "scoping out not in order; "
|
||||||
++ " tried to scope out: " ++ A.nameName n ++ " but found: " ++ A.nameName old)
|
++ " tried to scope out: " ++ A.nameName n ++ " but found: " ++ A.nameName old)
|
||||||
|
@ -1481,12 +1482,13 @@ pragma = do m <- getPosition >>* sourcePosToMeta
|
||||||
-- The Right return expects the given string to be lexed then parsed, whereas
|
-- The Right return expects the given string to be lexed then parsed, whereas
|
||||||
-- the Left return is just some code to run as normal, that won't consume
|
-- the Left return is just some code to run as normal, that won't consume
|
||||||
-- any input.
|
-- any input.
|
||||||
pragmas :: (Die m, CSM m) => [ (String, Meta -> [String] -> Either (m (Maybe NameSpec))
|
pragmas :: [ (String, Meta -> [String] -> Either (OccParser (Maybe NameSpec))
|
||||||
(String, OccParser (Maybe NameSpec)) ) ]
|
(String, OccParser (Maybe NameSpec)) ) ]
|
||||||
pragmas = [ ("^SHARED +(.*)", parseContents handleShared)
|
pragmas = [ ("^SHARED +(.*)", parseContents handleShared)
|
||||||
, ("^PERMITALIASES +(.*)", parseContents handlePermitAliases)
|
, ("^PERMITALIASES +(.*)", parseContents handlePermitAliases)
|
||||||
, ("^EXTERNAL +\"(.*)\"", parseContents $ handleExternal True)
|
, ("^EXTERNAL +\"(.*)\"", parseContents $ handleExternal True)
|
||||||
, ("^TOCKEXTERNAL +\"(.*)\"", parseContents $ handleExternal False)
|
, ("^TOCKEXTERNAL +\"(.*)\"", parseContents $ handleExternal False)
|
||||||
|
, ("^TOCKUNSCOPE +(.*)", simple handleUnscope)
|
||||||
, ("^TOCKSIZES +\"(.*)\"", simple handleSizes)
|
, ("^TOCKSIZES +\"(.*)\"", simple handleSizes)
|
||||||
, ("^TOCKINCLUDE +\"(.*)\"", simple handleInclude)
|
, ("^TOCKINCLUDE +\"(.*)\"", simple handleInclude)
|
||||||
, ("^TOCKNATIVELINK +\"(.*)\"", simple handleNativeLink)
|
, ("^TOCKNATIVELINK +\"(.*)\"", simple handleNativeLink)
|
||||||
|
@ -1506,7 +1508,7 @@ pragma = do m <- getPosition >>* sourcePosToMeta
|
||||||
do st <- getState
|
do st <- getState
|
||||||
A.Name _ n <- case lookup var (csLocalNames st) of
|
A.Name _ n <- case lookup var (csLocalNames st) of
|
||||||
Nothing -> dieP m $ "name " ++ var ++ " not defined"
|
Nothing -> dieP m $ "name " ++ var ++ " not defined"
|
||||||
Just def -> return $ fst def
|
Just (n, _, _) -> return n
|
||||||
modifyCompState $ \st -> st {csNameAttr = Map.insertWith Set.union
|
modifyCompState $ \st -> st {csNameAttr = Map.insertWith Set.union
|
||||||
n (Set.singleton NameShared) (csNameAttr st)})
|
n (Set.singleton NameShared) (csNameAttr st)})
|
||||||
vars
|
vars
|
||||||
|
@ -1518,7 +1520,7 @@ pragma = do m <- getPosition >>* sourcePosToMeta
|
||||||
do st <- getState
|
do st <- getState
|
||||||
A.Name _ n <- case lookup var (csLocalNames st) of
|
A.Name _ n <- case lookup var (csLocalNames st) of
|
||||||
Nothing -> dieP m $ "name " ++ var ++ " not defined"
|
Nothing -> dieP m $ "name " ++ var ++ " not defined"
|
||||||
Just def -> return $ fst def
|
Just (n, _, _) -> return n
|
||||||
modifyCompState $ \st -> st {csNameAttr = Map.insertWith Set.union
|
modifyCompState $ \st -> st {csNameAttr = Map.insertWith Set.union
|
||||||
n (Set.singleton NameAliasesPermitted) (csNameAttr st)})
|
n (Set.singleton NameAliasesPermitted) (csNameAttr st)})
|
||||||
vars
|
vars
|
||||||
|
@ -1568,6 +1570,17 @@ pragma = do m <- getPosition >>* sourcePosToMeta
|
||||||
}
|
}
|
||||||
return $ Just (A.Specification m origN sp, nt, (Just n, A.NameExternal))
|
return $ Just (A.Specification m origN sp, nt, (Just n, A.NameExternal))
|
||||||
|
|
||||||
|
handleUnscope _ [unscope]
|
||||||
|
= do st <- getState
|
||||||
|
setState $ st { csLocalNames = unscopeLatest $ csLocalNames st }
|
||||||
|
return Nothing
|
||||||
|
where
|
||||||
|
unscopeLatest (l@(s, (n, nt, _)): ls)
|
||||||
|
| s == unscope
|
||||||
|
= (s, (n, nt, False)) : ls
|
||||||
|
| otherwise
|
||||||
|
= l : unscopeLatest ls
|
||||||
|
|
||||||
isPragma (Token _ p@(Pragma {})) = Just p
|
isPragma (Token _ p@(Pragma {})) = Just p
|
||||||
isPragma _ = Nothing
|
isPragma _ = Nothing
|
||||||
|
|
||||||
|
@ -1637,7 +1650,7 @@ claimSpec
|
||||||
getOrigName :: A.Name -> OccParser String
|
getOrigName :: A.Name -> OccParser String
|
||||||
getOrigName n
|
getOrigName n
|
||||||
= do st <- getState
|
= do st <- getState
|
||||||
case lookup n [(munged, orig) | (orig, (munged, _)) <- csLocalNames st] of
|
case lookup n [(munged, orig) | (orig, (munged, _, True)) <- csLocalNames st] of
|
||||||
Just orig -> return orig
|
Just orig -> return orig
|
||||||
Nothing -> dieP (A.nameMeta n) $ "Could not find name: " ++ (A.nameName n)
|
Nothing -> dieP (A.nameMeta n) $ "Could not find name: " ++ (A.nameName n)
|
||||||
|
|
||||||
|
@ -2035,7 +2048,8 @@ topLevelItem
|
||||||
-- when we get back to the file we included this one from, or
|
-- when we get back to the file we included this one from, or
|
||||||
-- pull the TLP name from them at the end.
|
-- pull the TLP name from them at the end.
|
||||||
locals <- getState >>* csLocalNames
|
locals <- getState >>* csLocalNames
|
||||||
modifyCompState $ (\ps -> ps { csMainLocals = locals })
|
modifyCompState $ (\ps -> ps { csMainLocals =
|
||||||
|
[(s, (n, nt)) | (s, (n, nt, True)) <- locals] })
|
||||||
return $ A.Several m []
|
return $ A.Several m []
|
||||||
|
|
||||||
-- | A source file is a series of nested specifications.
|
-- | A source file is a series of nested specifications.
|
||||||
|
|
Loading…
Reference in New Issue
Block a user