Reworked the pragma generation again for occam PROCs

One change, based on Adam's suggestion, was to rename the pragma to TOCKEXTERNAL.

Another, also based on Adam's suggestion, was to generate both the munged name and the original name, which allows (along with a previous patch) different files to declare the same PROC, and will remove the need for the occam_ prefix in the backend.

I also stopped using specific states in the lexer, in favour of just using the normal lexing function (which has had its type generalised slightly).

frontends/LexOccam.x

@@ -199,7 +199,7 @@ mkState code _ s = (Nothing, code)
 
 -- | Run the lexer, returning a list of tokens.
 -- (This is based on the `alexScanTokens` function that Alex provides.)
-runLexer :: String -> String -> PassM [Token]
+runLexer :: Die m => String -> String -> m [Token]
 runLexer filename str = go (alexStartPos, '\n', str) 0
   where
     go inp@(pos@(AlexPn _ line col), _, str) code =

frontends/OccamPasses.hs

@@ -69,12 +69,11 @@ writeIncFile = occamOnlyPass "Write .inc file" [] []
   where
     emitProcsAsExternal :: A.AST -> PassM (Seq.Seq String)
     emitProcsAsExternal (A.Spec _ (A.Specification _ n (A.Proc _ _ fs _)) scope)
-      = do thisProc <- sequence (
+      = do origN <- lookupName n >>* A.ndOrigName
-             [return "#PRAGMA OCCAMEXTERNAL \"PROC "
+           thisProc <- sequence (
-             ,showCode n
+             [return $ "#PRAGMA TOCKEXTERNAL \"PROC " ++ A.nameName n ++ "("
-             ,return "("
              ] ++ intersperse (return ",") (map showCode fs) ++
-             [return ")\""
+             [return $ ") = " ++ origN ++ "\""
              ]) >>* concat
            modify $ \cs -> cs { csOriginalTopLevelProcs =
              A.nameName n : csOriginalTopLevelProcs cs }

frontends/ParseOccam.hs

@@ -19,7 +19,7 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 -- | Parse occam code into an AST.
 module ParseOccam (parseOccamProgram) where
 
-import Control.Monad (liftM, when)
+import Control.Monad (join, liftM)
 import Control.Monad.State (MonadState, modify, get, put)
 import Data.List
 import qualified Data.Map as Map
@@ -1371,24 +1371,18 @@ structuredTypeField
 pragma :: OccParser ()
 pragma = do Pragma rawP <- genToken isPragma
             m <- getPosition >>* sourcePosToMeta
-            pragToks <- case runPragmaLexer "<unknown(pragma)>" rawP of
+            let prag :: Maybe (Int, String)
-              Left _ -> do warnP m WarnUnknownPreprocessorDirective $
+                prag = join $ find isJust
-                             "Unknown PRAGMA: " ++ rawP
+                 [ (matchRegex (mkRegex pt) rawP >>= listToMaybe) >>* (,) i
-                           return []
+                 | (i, pt) <- zip [0..]
-              Right toks -> return toks
+                        [ "^SHARED +(.*)"
-            cs <- getCompState
+                        , "^PERMITALIASES +(.*)"
-            prod <- return $
+                        , "^EXTERNAL +\"(.*)\""
-                      -- Maybe monad:
+                        , "^TOCKEXTERNAL +\"(.*)\""
-               case findIndex isJust
-                 [ do Token _ (Pragma firstTok) <- listToMaybe pragToks
-                      matchRegex (mkRegex pt) firstTok
-                 | pt <- [ "^SHARED.*"
-                        , "^PERMITALIASES.*"
-                        , "^EXTERNAL.*"
-                        , "^OCCAMEXTERNAL.*"
                         ]
-                 ] of
+                 ]
-              Just 0 -> do
+            mprod <- return $ flip fmap prag $ \(pragType, _) -> case pragType of
+              0 -> do
                 vars <- sepBy1 identifier sComma
                 mapM_ (\var ->
                   do st <- get
@@ -1398,7 +1392,7 @@ pragma = do Pragma rawP <- genToken isPragma
                      modify $ \st -> st {csNameAttr = Map.insertWith Set.union
                        n (Set.singleton NameShared) (csNameAttr st)})
                   vars
-              Just 1 -> do
+              1 -> do
                 vars <- sepBy1 identifier sComma
                 mapM_ (\var ->
                   do st <- get
@@ -1408,41 +1402,40 @@ pragma = do Pragma rawP <- genToken isPragma
                      modify $ \st -> st {csNameAttr = Map.insertWith Set.union
                        n (Set.singleton NameAliasesPermitted) (csNameAttr st)})
                   vars
-              Just pragmaType | pragmaType == 2 || pragmaType == 3 -> do
+              pragmaType | pragmaType == 2 || pragmaType == 3 -> do
                 m <- md
                 sPROC
                 n <- newProcName
                 fs <- formalList >>* map fst
-                when (pragmaType == 2) $ do sEq
+                sEq
-                                            integer
+                origN <- if pragmaType == 2
-                                            return ()
+                           then integer >> return (A.nameName n)
+                           else identifier
+                
                 let on = A.nameName n
                     sp = A.Proc m (A.PlainSpec, A.PlainRec) fs (A.Skip m)
-                    nd = A.NameDef m on on sp A.Original A.NamePredefined A.Unplaced
+                    nd = A.NameDef m on origN sp A.Original A.NamePredefined A.Unplaced
                     ext = if pragmaType == 2 then ExternalOldStyle else ExternalOccam
                 modify $ \st -> st
                   { csNames = Map.insert on nd (csNames st)
-                  , csLocalNames = (on, (n, ProcName)) : csLocalNames st
+                  , csLocalNames = (origN, (n, ProcName)) : csLocalNames st
                   , csExternals = (on, (ext, fs)) : csExternals st
                   }
+            case (prag, mprod) of
+              (Just (_, pragStr), Just prod) -> do
+                toks <- runLexer "<unknown(pragma)>" pragStr
+                cs <- getCompState
+                case runParser (prod >> getState) cs "" toks of
+                  Left err -> warnP m WarnUnknownPreprocessorDirective $
+                                "Unknown PRAGMA (parse failed): " ++ show err
+                  Right st -> setState st
               _ -> warnP m WarnUnknownPreprocessorDirective $
-                "Unknown PRAGMA type: " ++ show (listToMaybe pragToks)
+                     "Unknown PRAGMA type: " ++ show rawP
-            let otherToks = safeTail pragToks
-            case otherToks of
-              Nothing -> warnP m WarnUnknownPreprocessorDirective $
-                           "Unknown PRAGMA (no tokens): " ++ rawP
-              Just toks -> case runParser (prod >> getState) cs "" toks of
-                             Left err -> warnP m WarnUnknownPreprocessorDirective $
-                                         "Unknown PRAGMA (parse failed): " ++ show err
-                             Right st -> setState st
             eol
   where
     isPragma (Token _ p@(Pragma {})) = Just p
     isPragma _ = Nothing
 
-    safeTail [] = Nothing
-    safeTail (_:xs) = Just xs
-
 --}}}
 --{{{ processes
 process :: OccParser A.Process