diff --git a/checks/ArrayUsageCheck.hs b/checks/ArrayUsageCheck.hs index 4e962e8..03ee0d4 100644 --- a/checks/ArrayUsageCheck.hs +++ b/checks/ArrayUsageCheck.hs @@ -158,7 +158,7 @@ checkArrayUsage (m,p) checkIndexes m ((arrName, arrDir), indexes) = do sharedNames <- getCompState >>* csNameAttr let declNames = [x | Just x <- fmap (getDecl . snd) $ flattenParItems p] - when (Map.lookup arrName sharedNames /= Just NameShared && arrName `notElem` declNames) $ + when (fmap (Set.member NameShared) (Map.lookup arrName sharedNames) /= Just True && arrName `notElem` declNames) $ do userArrName <- getRealName (A.Name undefined arrName) arrType <- astTypeOf (A.Name undefined arrName) arrLength <- case arrType of diff --git a/checks/Check.hs b/checks/Check.hs index 5429319..20227a1 100644 --- a/checks/Check.hs +++ b/checks/Check.hs @@ -342,7 +342,7 @@ checkPlainVarUsage (m, p) = check p -- A quick way to do this is to do a fold-union across all the maps, turning -- the values into lists that can then be scanned for any problems. check (ParItems ps) - = do sharedNames <- getCompState >>* csNameAttr >>* Map.filter (== NameShared) + = do sharedNames <- getCompState >>* csNameAttr >>* Map.filter (Set.member NameShared) >>* Map.keysSet >>* (Set.map $ UsageCheckUtils.Var . A.Variable emptyMeta . A.Name emptyMeta) let decl = concatMap getDecl ps filt <- filterPlain diff --git a/data/CompState.hs b/data/CompState.hs index 78bbf37..03bac5f 100644 --- a/data/CompState.hs +++ b/data/CompState.hs @@ -85,7 +85,7 @@ instance Ord UnifyIndex where -- | An entry in the map corresponding to a UnifyIndex type UnifyValue = TypeExp A.Type -data NameAttr = NameShared deriving (Typeable, Data, Eq, Show, Ord) +data NameAttr = NameShared | NameAliasesPermitted deriving (Typeable, Data, Eq, Show, Ord) -- | State necessary for compilation. data CompState = CompState { @@ -116,7 +116,7 @@ data CompState = CompState { csNames :: Map String A.NameDef, csUnscopedNames :: Map String String, csNameCounter :: Int, - csNameAttr :: Map String NameAttr, + csNameAttr :: Map String (Set.Set NameAttr), -- Set by passes csTypeContext :: [Maybe A.Type], diff --git a/frontends/ParseOccam.hs b/frontends/ParseOccam.hs index e66f461..ced326b 100644 --- a/frontends/ParseOccam.hs +++ b/frontends/ParseOccam.hs @@ -24,6 +24,7 @@ import Control.Monad.State (MonadState, modify, get, put) import Data.List import qualified Data.Map as Map import Data.Maybe +import qualified Data.Set as Set import Text.ParserCombinators.Parsec import Text.Regex @@ -1284,27 +1285,41 @@ structuredTypeField pragma :: OccParser () pragma = do Pragma p <- genToken isPragma m <- getPosition >>* sourcePosToMeta - case matchRegex (mkRegex "^SHARED +(.*)") p of - Just [varsRaw] -> - let varsRawNoComment = if "--" `isInfixOf` varsRaw - then chopTrailingSpaces $ chopComment [] varsRaw - else chopTrailingSpaces varsRaw - in + case map (flip matchRegex p . mkRegex) + ["^SHARED +(.*)", "^PERMITALIASES +(.*)"] of + [Just [varsRaw], _] -> mapM_ (\var -> do st <- get A.Name _ n <- case lookup var (csLocalNames st) of Nothing -> dieP m $ "name " ++ var ++ " not defined" Just def -> return $ fst def - modify $ \st -> st {csNameAttr = Map.insert n NameShared (csNameAttr st)}) - (splitRegex (mkRegex ",") varsRawNoComment) - Nothing -> warnP m WarnUnknownPreprocessorDirective $ + modify $ \st -> st {csNameAttr = Map.insertWith Set.union + n (Set.singleton NameShared) (csNameAttr st)}) + (processVarList varsRaw) + [Nothing, Just [varsRaw]] -> + mapM_ (\var -> + do st <- get + A.Name _ n <- case lookup var (csLocalNames st) of + Nothing -> dieP m $ "name " ++ var ++ " not defined" + Just def -> return $ fst def + modify $ \st -> st {csNameAttr = Map.insertWith Set.union + n (Set.singleton NameAliasesPermitted) (csNameAttr st)}) + (processVarList varsRaw) + _ -> warnP m WarnUnknownPreprocessorDirective $ "Unknown PRAGMA: " ++ p eol where + processVarList raw = map chopBoth $ + splitRegex (mkRegex ",") $ if "--" `isInfixOf` raw + then chopComment [] raw + else raw + chopComment prev ('-':'-':_) = prev chopComment prev (x:xs) = chopComment (prev++[x]) xs chopComment prev [] = prev + chopBoth = chopLeadingSpaces . chopTrailingSpaces + chopLeadingSpaces = dropWhile (`elem` " \t") chopTrailingSpaces = reverse . dropWhile (`elem` " \t") . reverse isPragma (Token _ p@(Pragma {})) = Just p