suzanne.soy/tock-mirror
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

A whole lot of changes, described in #101 that help with records and separate compilation

Browse Source 
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:
Neil Brown 2009-04-18 21:35:26 +00:00
parent 56e9609148
commit 40e0399e4c
7 changed files with 216 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
backends/GenerateC.hs
View File

@ -180,17 +180,22 @@ cgenTopLevel headerName s
tell ["#include <tock_support_cif.h>\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]

32
backends/GenerateCBased.hs
View File

@ -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)

31
backends/GenerateCPPCSP.hs
View File

@ -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 ()

2
backends/GenerateCTest.hs
View File

@ -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"])

54
frontends/OccamCheckTypes.hs
View File

@ -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

75
frontends/OccamPasses.hs
View File

@ -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"

38
frontends/ParseOccam.hs
View File

@ -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.