diff --git a/backends/GenerateC.hs b/backends/GenerateC.hs index 5e98484..efc74eb 100644 --- a/backends/GenerateC.hs +++ b/backends/GenerateC.hs @@ -180,17 +180,22 @@ cgenTopLevel headerName s tell ["#include \n"] cs <- getCompState - let isTopLevelSpec (A.Specification _ n _) + let isHeaderSpec (A.Specification _ n _) = A.nameName n `elem` (csOriginalTopLevelProcs cs) + isBodySpec (A.Specification _ n sp) + = A.nameName n `notElem` (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) + + -- 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, -- but we do it in the C file, not in the header: - sequence_ $ map (call genForwardDeclaration) - (reverse $ listifyDepth (not . isTopLevelSpec) s) - - tell ["#include \"", dropPath headerName, "\"\n"] + sequence_ $ map (call genForwardDeclaration False) + (reverse $ listifyDepth (isBodySpec) s) sequence_ [let usedFile' = if ".tock.inc" `isSuffixOf` 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" ,")"] 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 _ n (A.Protocol _ _)) = return () 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 _ n = call genMissing $ "introduceSpec " ++ show n -cgenRecordTypeSpec :: A.Name -> A.RecordAttr -> [(A.Name, A.Type)] -> CGen () -cgenRecordTypeSpec n attr fs +cgenRecordTypeSpec :: Bool -> A.Name -> A.RecordAttr -> [(A.Name, A.Type)] -> CGen () +cgenRecordTypeSpec extraStuff n attr fs + | not extraStuff = do tell ["typedef struct{"] sequence_ [call genDeclaration NotTopLevel t n True | (n, t) <- fs] tell ["}"] when (A.packedRecord attr || A.mobileRecord attr) $ tell [" occam_struct_packed "] genName n tell [";"] - tell ["typedef "] - genName n - origN <- lookupName n >>* A.ndOrigName - tell [" ", nameString $ A.Name emptyMeta origN, ";"] - if null [t | (_, A.Mobile t) <- fs] + | otherwise + = if null [t | (_, A.Mobile t) <- fs] then do genStatic TopLevel n tell ["const word "] genName n @@ -1493,12 +1497,12 @@ cgenRecordTypeSpec n attr fs ] ++ mt t mt t = [mobileElemType False t] -cgenForwardDeclaration :: A.Specification -> CGen () -cgenForwardDeclaration (A.Specification _ n st@(A.Proc _ _ _ _)) +cgenForwardDeclaration :: Bool -> A.Specification -> CGen () +cgenForwardDeclaration _ (A.Specification _ n st@(A.Proc _ _ _ _)) = genProcSpec TopLevel n st True -cgenForwardDeclaration (A.Specification _ n (A.RecordType _ b fs)) - = call genRecordTypeSpec n b fs -cgenForwardDeclaration _ = return () +cgenForwardDeclaration True (A.Specification _ n (A.RecordType _ b fs)) + = call genRecordTypeSpec False n b fs +cgenForwardDeclaration _ _ = return () cremoveSpec :: A.Specification -> CGen () 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"] sequence_ [do tell [", "] case origT of +{- A.Record rn | forwardDecl -> do origN <- lookupName rn >>* A.ndOrigName 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) (nameString $ A.Name emptyMeta origN) ct ] - _ -> t +-} _ -> t tell [" "] n | (A.Formal am origT _, (t, n)) <- zip fs rfs] diff --git a/backends/GenerateCBased.hs b/backends/GenerateCBased.hs index 679a4b3..75896a7 100644 --- a/backends/GenerateCBased.hs +++ b/backends/GenerateCBased.hs @@ -23,6 +23,8 @@ import Control.Monad.Reader import Control.Monad.State import Control.Monad.Writer hiding (tell) import Data.Generics (Data) +import Data.HashTable (hashString) +import Data.Int (Int32) import Data.List import System.IO @@ -71,14 +73,31 @@ instance CSMR CGen where getCompState = lift getCompState -- Do not nest calls to this function! -tellToHeader :: CGen a -> CGen a -tellToHeader act +-- The function also puts in the #ifndef/#define/#endif stuff that prevents multiple +-- inclusion. +tellToHeader :: String -> CGen a -> CGen a +tellToHeader stem act = do st <- get - put $ st { cgenBody = cgenHeader st } + put $ st { cgenBody = Left [] } x <- act 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 + where + makePosInteger :: Int32 -> Integer + makePosInteger n = toInteger n + (toInteger (maxBound :: Int32)) tell :: [String] -> CGen () tell x = do st <- get @@ -138,7 +157,8 @@ data GenOps = GenOps { genDirectedVariable :: Meta -> A.Type -> CGen () -> A.Direction -> CGen (), genExpression :: A.Expression -> 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: genFunctionCall :: Meta -> A.Name -> [A.Expression] -> CGen (), -- | Gets the current time into the given variable @@ -169,7 +189,7 @@ data GenOps = GenOps { genPoison :: Meta -> A.Variable -> CGen (), genProcCall :: A.Name -> [A.Actual] -> 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 (), genReplicatorEnd :: A.Replicator -> CGen (), -- | Generates the three bits of a for loop (e.g. @int i = 0; i < 10; i++@ for the given replicator) diff --git a/backends/GenerateCPPCSP.hs b/backends/GenerateCPPCSP.hs index ef2086e..960c6d6 100644 --- a/backends/GenerateCPPCSP.hs +++ b/backends/GenerateCPPCSP.hs @@ -141,16 +141,22 @@ cppgenTopLevel headerName s cs <- getCompState - let isTopLevelSpec (A.Specification _ n _) + let isHeaderSpec (A.Specification _ n _) = 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, -- 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 _) - -> not (isTopLevelSpec sp) + -> isBodySpec sp && A.nameName n `notElem` map fst (csExternals cs)) s) 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 nameFunc (A.Formal am t n) = call genDecl NotTopLevel am t (nameFunc n) -cppgenForwardDeclaration :: A.Specification -> CGen() -cppgenForwardDeclaration (A.Specification _ n (A.Proc _ (sm, _) fs _)) +cppgenForwardDeclaration :: Bool -> A.Specification -> CGen() +cppgenForwardDeclaration _ (A.Specification _ n (A.Proc _ (sm, _) fs _)) = do --Generate the "process" as a C++ function: genStatic TopLevel n call genSpecMode sm @@ -591,9 +597,9 @@ cppgenForwardDeclaration (A.Specification _ n (A.Proc _ (sm, _) fs _)) genConstructorList :: [A.Formal] -> CGen () genConstructorList fs = mapM_ genConsItem fs -cppgenForwardDeclaration (A.Specification _ n (A.RecordType _ b fs)) - = call genRecordTypeSpec n b fs -cppgenForwardDeclaration _ = return () +cppgenForwardDeclaration header (A.Specification _ n (A.RecordType _ b fs)) + = call genRecordTypeSpec (not header) n b fs +cppgenForwardDeclaration _ _ = return () cppintroduceSpec :: Level -> A.Specification -> CGen () --I generate process wrappers for all functions by default: @@ -923,8 +929,8 @@ cppgenFunctionCall m n es tell [")"] -- Changed because we don't need the mobile descriptor stuff: -cppgenRecordTypeSpec :: A.Name -> A.RecordAttr -> [(A.Name, A.Type)] -> CGen () -cppgenRecordTypeSpec n attr fs +cppgenRecordTypeSpec :: Bool -> A.Name -> A.RecordAttr -> [(A.Name, A.Type)] -> CGen () +cppgenRecordTypeSpec True n attr fs = do tell ["typedef struct{"] sequence_ [call genDeclaration NotTopLevel t n True | (n, t) <- fs] tell ["}"] @@ -935,3 +941,4 @@ cppgenRecordTypeSpec n attr fs genName n origN <- lookupName n >>* A.ndOrigName tell [" ", nameString $ A.Name emptyMeta origN, ";"] +cppgenRecordTypeSpec False _ _ _ = return () diff --git a/backends/GenerateCTest.hs b/backends/GenerateCTest.hs index bfacf39..4b2a831 100644 --- a/backends/GenerateCTest.hs +++ b/backends/GenerateCTest.hs @@ -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 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 over ops = ops {genDeclaration = override3 (tell . (\x -> ["#ATION_",show x])) ,declareInit = (override3 (Just $ tell ["#INIT"])), declareFree = override3 (Just $ tell ["#FREE"]) diff --git a/frontends/OccamCheckTypes.hs b/frontends/OccamCheckTypes.hs index 42aa461..5ad0fd3 100644 --- a/frontends/OccamCheckTypes.hs +++ b/frontends/OccamCheckTypes.hs @@ -435,6 +435,60 @@ sameType ta@(A.UserDataType {}) tb sameType ta tb@(A.UserDataType {}) = do tb' <- resolveUserType emptyMeta 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 -- | Check that the second dimension can be used in a context where the first diff --git a/frontends/OccamPasses.hs b/frontends/OccamPasses.hs index 568caf9..fdc7586 100644 --- a/frontends/OccamPasses.hs +++ b/frontends/OccamPasses.hs @@ -64,36 +64,69 @@ writeIncFile = occamOnlyPass "Write .inc file" [] [] do out <- getCompOpts >>* csOutputIncFile case out of Just fn -> do f <- liftIO $ openFile fn WriteMode - contents <- emitProcsAsExternal t >>* (unlines . F.toList) - liftIO $ hPutStr f contents + (origLines, ns) <- runStateT (emitProcsAsExternal t) [] + allLines <- mapM mask ns >>* (F.toList origLines ++) + liftIO $ hPutStr f $ unlines allLines liftIO $ hClose f Nothing -> return () return t )) 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) = do origN <- lookupName n >>* A.ndOrigName thisProc <- sequence ( [return $ "#PRAGMA TOCKEXTERNAL \"PROC " ++ origN ++ "(" - ] ++ intersperse (return ",") (map showCode fs) ++ + ] ++ intersperse (return ",") (map showFormal fs) ++ [return $ ") = " ++ nameString n ++ "\"" ]) >>* concat - modify $ \cs -> cs { csOriginalTopLevelProcs = - A.nameName n : csOriginalTopLevelProcs cs } + recTopLevelName n 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 thisProc <- sequence ( [return $ "#PRAGMA TOCKEXTERNAL \"" - ] ++ intersperse (return ",") (map showCode ts) ++ + ] ++ intersperse (return ",") (map (showType m) ts) ++ [return $ " FUNCTION " ++ showFuncName origN ++ "(" - ] ++ intersperse (return ",") (map showCode fs) ++ + ] ++ intersperse (return ",") (map showFormal fs) ++ [return $ ") = " ++ nameString n ++ "\"" ]) >>* concat - modify $ \cs -> cs { csOriginalTopLevelProcs = - A.nameName n : csOriginalTopLevelProcs cs } + recTopLevelName n 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 scope emitProcsAsExternal (A.ProcThen _ _ scope) = emitProcsAsExternal scope @@ -101,12 +134,32 @@ writeIncFile = occamOnlyPass "Write .inc file" [] [] emitProcsAsExternal (A.Several _ 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 s | isOperator s = "\"" ++ doubleStars s ++ "\"" | otherwise = s where 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 fixConstructorTypes :: PassOn A.Expression fixConstructorTypes = occamOnlyPass "Fix the types of array constructors" diff --git a/frontends/ParseOccam.hs b/frontends/ParseOccam.hs index 5fc2fbd..a4dab4d 100644 --- a/frontends/ParseOccam.hs +++ b/frontends/ParseOccam.hs @@ -43,7 +43,7 @@ import Types import Utils data OccParserState = OccParserState - { csLocalNames :: [(String, (A.Name, NameType))] + { csLocalNames :: [(String, (A.Name, NameType, Bool))] , compState :: CompState } @@ -58,8 +58,9 @@ instance CSM (GenParser tok OccParserState) where setState $ st { compState = cs } addLocalName :: (String, (A.Name, NameType)) -> OccParser () -addLocalName n = do st <- getState - setState $ st { csLocalNames = n : csLocalNames st } +addLocalName (s, (n, nt)) + = 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: instance Warn (GenParser tok OccParserState) where @@ -403,10 +404,10 @@ findName :: A.Name -> NameType -> OccParser A.Name findName thisN thisNT = do st <- getState (origN, origNT) <- - case lookup (A.nameName thisN) (csLocalNames st) of - Nothing -> dieP (A.nameMeta thisN) $ "name " ++ A.nameName thisN ++ " not defined" - ++ "; possibilities were: " ++ show (map fst (csLocalNames st)) + case lookup (A.nameName thisN) [(s, (n, nt)) | (s, (n, nt, True)) <- csLocalNames st] of Just def -> return def + _ -> dieP (A.nameMeta thisN) $ "name " ++ A.nameName thisN ++ " not defined" + ++ "; possibilities were: " ++ show (map fst (csLocalNames st)) if thisNT /= origNT then dieP (A.nameMeta thisN) $ "expected " ++ show thisNT ++ " (" ++ A.nameName origN ++ " is " ++ show origNT ++ ")" else return $ thisN { A.nameName = A.nameName origN } @@ -434,7 +435,7 @@ scopeOut :: A.Name -> OccParser () scopeOut n@(A.Name m _) = do st <- getState case csLocalNames st of - ((_, (old, _)):rest) + ((_, (old, _, _)):rest) | old == n -> setState $ st { csLocalNames = rest } | otherwise -> dieInternal (Just m, "scoping out not in order; " ++ " 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 Left return is just some code to run as normal, that won't consume -- 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)) ) ] pragmas = [ ("^SHARED +(.*)", parseContents handleShared) , ("^PERMITALIASES +(.*)", parseContents handlePermitAliases) , ("^EXTERNAL +\"(.*)\"", parseContents $ handleExternal True) , ("^TOCKEXTERNAL +\"(.*)\"", parseContents $ handleExternal False) + , ("^TOCKUNSCOPE +(.*)", simple handleUnscope) , ("^TOCKSIZES +\"(.*)\"", simple handleSizes) , ("^TOCKINCLUDE +\"(.*)\"", simple handleInclude) , ("^TOCKNATIVELINK +\"(.*)\"", simple handleNativeLink) @@ -1506,7 +1508,7 @@ pragma = do m <- getPosition >>* sourcePosToMeta do st <- getState A.Name _ n <- case lookup var (csLocalNames st) of Nothing -> dieP m $ "name " ++ var ++ " not defined" - Just def -> return $ fst def + Just (n, _, _) -> return n modifyCompState $ \st -> st {csNameAttr = Map.insertWith Set.union n (Set.singleton NameShared) (csNameAttr st)}) vars @@ -1518,7 +1520,7 @@ pragma = do m <- getPosition >>* sourcePosToMeta do st <- getState A.Name _ n <- case lookup var (csLocalNames st) of Nothing -> dieP m $ "name " ++ var ++ " not defined" - Just def -> return $ fst def + Just (n, _, _) -> return n modifyCompState $ \st -> st {csNameAttr = Map.insertWith Set.union n (Set.singleton NameAliasesPermitted) (csNameAttr st)}) vars @@ -1568,6 +1570,17 @@ pragma = do m <- getPosition >>* sourcePosToMeta } 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 _ = Nothing @@ -1637,7 +1650,7 @@ claimSpec getOrigName :: A.Name -> OccParser String getOrigName n = 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 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 -- pull the TLP name from them at the end. locals <- getState >>* csLocalNames - modifyCompState $ (\ps -> ps { csMainLocals = locals }) + modifyCompState $ (\ps -> ps { csMainLocals = + [(s, (n, nt)) | (s, (n, nt, True)) <- locals] }) return $ A.Several m [] -- | A source file is a series of nested specifications.