Added quick preliminary support for the PERMITALIASES pragma

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

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

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],

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