fortran-src 0.8.0 → 0.9.0

raw patch · 86 files changed

+12235/−12504 lines, 86 filesdep +eitherPVP ok

version bump matches the API change (PVP)

Dependencies added: either

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−0
• app/Main.hs +469/−0
• fortran-src.cabal +102/−39
• src/Language/Fortran/AST.hs +22/−12
• src/Language/Fortran/AST/AList.hs +0/−6
• src/Language/Fortran/AST/Boz.hs +15/−19
• src/Language/Fortran/AST/RealLit.hs +1/−2
• src/Language/Fortran/Analysis.hs +5/−8
• src/Language/Fortran/Analysis/BBlocks.hs +7/−8
• src/Language/Fortran/Analysis/DataFlow.hs +4/−9
• src/Language/Fortran/Analysis/ModGraph.hs +13/−36
• src/Language/Fortran/Analysis/Renaming.hs +2/−2
• src/Language/Fortran/Analysis/SemanticTypes.hs +0/−3
• src/Language/Fortran/Analysis/Types.hs +2/−4
• src/Language/Fortran/Intrinsics.hs +1/−4
• src/Language/Fortran/LValue.hs +0/−6
• src/Language/Fortran/Lexer/FixedForm.x +0/−1153
• src/Language/Fortran/Lexer/FixedForm/Utils.hs +0/−19
• src/Language/Fortran/Lexer/FreeForm.x +0/−1395
• src/Language/Fortran/Parser.hs +338/−0
• src/Language/Fortran/Parser/Any.hs +0/−86
• src/Language/Fortran/Parser/Fixed/Fortran66.y +465/−0
• src/Language/Fortran/Parser/Fixed/Fortran77.y +977/−0
• src/Language/Fortran/Parser/Fixed/Lexer.x +1126/−0
• src/Language/Fortran/Parser/Fixed/Utils.hs +42/−0
• src/Language/Fortran/Parser/Fortran2003.y +0/−1477
• src/Language/Fortran/Parser/Fortran66.y +0/−512
• src/Language/Fortran/Parser/Fortran77.y +0/−1152
• src/Language/Fortran/Parser/Fortran90.y +0/−1214
• src/Language/Fortran/Parser/Fortran95.y +0/−1290
• src/Language/Fortran/Parser/Free/Fortran2003.y +1417/−0
• src/Language/Fortran/Parser/Free/Fortran90.y +1161/−0
• src/Language/Fortran/Parser/Free/Fortran95.y +1231/−0
• src/Language/Fortran/Parser/Free/Lexer.x +1377/−0
• src/Language/Fortran/Parser/Free/Utils.hs +23/−0
• src/Language/Fortran/Parser/LexerUtils.hs +18/−0
• src/Language/Fortran/Parser/Monad.hs +224/−0
• src/Language/Fortran/Parser/Utils.hs +0/−47
• src/Language/Fortran/ParserMonad.hs +0/−276
• src/Language/Fortran/PrettyPrint.hs +5/−3
• src/Language/Fortran/Transformation/Disambiguation/Function.hs +2/−3
• src/Language/Fortran/Transformation/Disambiguation/Intrinsic.hs +1/−2
• src/Language/Fortran/Transformation/Grouping.hs +5/−1
• src/Language/Fortran/Transformation/Monad.hs +42/−0
• src/Language/Fortran/Transformation/TransformMonad.hs +0/−40
• src/Language/Fortran/Transformer.hs +0/−70
• src/Language/Fortran/Util/FirstParameter.hs +0/−2
• src/Language/Fortran/Util/ModFile.hs +62/−23
• src/Language/Fortran/Util/Position.hs +0/−5
• src/Language/Fortran/Util/SecondParameter.hs +0/−2
• src/Language/Fortran/Version.hs +0/−8
• src/Main.hs +0/−482
• test/Language/Fortran/Analysis/BBlocksSpec.hs +5/−4
• test/Language/Fortran/Analysis/DataFlowSpec.hs +7/−10
• test/Language/Fortran/Analysis/RenamingSpec.hs +15/−16
• test/Language/Fortran/Analysis/TypesSpec.hs +7/−9
• test/Language/Fortran/AnalysisSpec.hs +5/−7
• test/Language/Fortran/Lexer/FixedFormSpec.hs +0/−312
• test/Language/Fortran/Lexer/FreeFormSpec.hs +0/−377
• test/Language/Fortran/Parser/Fixed/Fortran66Spec.hs +189/−0
• test/Language/Fortran/Parser/Fixed/Fortran77/IncludeSpec.hs +52/−0
• test/Language/Fortran/Parser/Fixed/Fortran77/ParserSpec.hs +412/−0
• test/Language/Fortran/Parser/Fixed/LexerSpec.hs +324/−0
• test/Language/Fortran/Parser/Fortran2003Spec.hs +0/−180
• test/Language/Fortran/Parser/Fortran2008Spec.hs +0/−8
• test/Language/Fortran/Parser/Fortran66Spec.hs +0/−190
• test/Language/Fortran/Parser/Fortran77/IncludeSpec.hs +0/−55
• test/Language/Fortran/Parser/Fortran77/ParserSpec.hs +0/−424
• test/Language/Fortran/Parser/Fortran90Spec.hs +0/−590
• test/Language/Fortran/Parser/Fortran95Spec.hs +0/−660
• test/Language/Fortran/Parser/Free/Common.hs +87/−0
• test/Language/Fortran/Parser/Free/Fortran2003Spec.hs +176/−0
• test/Language/Fortran/Parser/Free/Fortran2008Spec.hs +8/−0
• test/Language/Fortran/Parser/Free/Fortran90Spec.hs +586/−0
• test/Language/Fortran/Parser/Free/Fortran95Spec.hs +655/−0
• test/Language/Fortran/Parser/Free/LexerSpec.hs +383/−0
• test/Language/Fortran/Parser/FreeFormCommon.hs +0/−68
• test/Language/Fortran/Parser/MonadSpec.hs +91/−0
• test/Language/Fortran/Parser/UtilsSpec.hs +0/−29
• test/Language/Fortran/ParserMonadSpec.hs +0/−92
• test/Language/Fortran/PrettyPrintSpec.hs +1/−2
• test/Language/Fortran/Transformation/Disambiguation/FunctionSpec.hs +21/−14
• test/Language/Fortran/Transformation/GroupingSpec.hs +28/−21
• test/Language/Fortran/Util/FirstParameterSpec.hs +0/−4
• test/Language/Fortran/Util/SecondParameterSpec.hs +0/−4
• test/TestUtil.hs +13/−8

@@ -1,3 +1,14 @@+### 0.9.0 (Feb 14, 2022)+  * Restructure parsing-related modules for code deduplication and better user+    experience.+    * Now all user-facing parsers and the combinators to create them are in a+      single module at `Language.Fortran.Parser`.+    * The Happy parsers have fewer dependencies, so should no longer require a+      recompile due to apparently unrelated changes.+  * Remove some deprecated shims (from the restructured modules).+  * Merge fortran-src-extras `Language.Fortran.Extras.ModFiles.Extras` module+    into `Language.Fortran.Util.ModFile`.+ ### 0.8.0 (Jan 04, 2022)   * Merge declarator constructors. Now you differentiate between array and     scalar declarators by looking at the relevant field. See

@@ -0,0 +1,469 @@+{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Main ( main ) where++import Prelude hiding (readFile, mod)+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as LB++import Text.PrettyPrint (render)++import System.Console.GetOpt+import System.IO+import System.Environment+import System.Directory+import System.FilePath+import Text.PrettyPrint.GenericPretty (pp, pretty, Out)+import Text.Read (readMaybe)+import Data.List (sortBy, intercalate, isSuffixOf)+import Data.Ord (comparing)+import Data.Char (toLower)+import Data.Maybe (listToMaybe, fromMaybe, maybeToList)+import Data.Data+import Data.Generics.Uniplate.Data+import Data.Graph.Inductive hiding (trc, mf, version)+import Data.Either.Combinators ( fromRight' )++import qualified Data.IntMap as IM+import qualified Data.Map as M+import Control.Monad+import Text.Printf++import Language.Fortran.Parser+import Language.Fortran.Version+import Language.Fortran.Util.ModFile+import Language.Fortran.Util.Position+import Language.Fortran.Util.Files+import Language.Fortran.PrettyPrint+import Language.Fortran.Analysis+import Language.Fortran.AST+import Language.Fortran.Analysis.Types+import Language.Fortran.Analysis.ModGraph+import Language.Fortran.Analysis.BBlocks+import Language.Fortran.Analysis.DataFlow+import Language.Fortran.Analysis.Renaming+import qualified Language.Fortran.Parser as Parser+import qualified Language.Fortran.Parser.Fixed.Lexer as Fixed+import qualified Language.Fortran.Parser.Free.Lexer  as Free++programName :: String+programName = "fortran-src"++main :: IO ()+main = do+  args <- getArgs+  (opts, parsedArgs) <- compileArgs args+  case (parsedArgs, action opts) of+    (paths, ShowMakeGraph) -> do+      paths' <- expandDirs paths+      mg <- genModGraph (fortranVersion opts) (includeDirs opts) paths'+      putStrLn $ modGraphToDOT mg+    -- make: construct a build-dep graph and follow it+    (paths, Make) -> do+      let mvers = fortranVersion opts+      paths' <- expandDirs paths+      -- Build the graph of module dependencies+      mg0 <- genModGraph mvers (includeDirs opts) paths'+      -- Start the list of mods with those from the command line+      mods0 <- decodeModFiles' $ includeDirs opts+      -- Loop through the dependency graph until it is empty+      let loop mg mods+            | nxt <- takeNextMods mg+            , not (null nxt) = do+                let fnPaths = [ fn | (_, Just (MOFile fn)) <- nxt ]+                newMods <- fmap concat . forM fnPaths $ \ fnPath -> do+                  tsStatus <- checkTimestamps fnPath+                  case tsStatus of+                    NoSuchFile -> do+                      putStr $ "Does not exist: " ++ fnPath+                      pure [emptyModFile]+                    ModFileExists modPath -> do+                      putStrLn $ "Loading mod file " ++ modPath ++ "."+                      decodeOneModFile modPath+                    CompileFile -> do+                      putStr $ "Summarising " ++ fnPath ++ "..."+                      mod <- compileFileToMod mvers mods fnPath Nothing+                      putStrLn "done"+                      pure [mod]++                let ns  = map fst nxt+                let mg' = delModNodes ns mg+                loop mg' $ newMods ++ mods+          loop _ mods = pure mods++      allMods <- loop mg0 mods0+      case outputFile opts of+        Nothing -> pure ()+        Just f  -> LB.writeFile f $ encodeModFile allMods++    (paths, Compile) -> do+      mods <- decodeModFiles' $ includeDirs opts+      mapM_ (\ p -> compileFileToMod (fortranVersion opts) mods p (outputFile opts)) paths+    (path:_, actionOpt) -> do+      contents <- flexReadFile path+      mods <- decodeModFiles' $ includeDirs opts+      let version   = fromMaybe (deduceFortranVersion path) (fortranVersion opts)+          parsedPF  = fromRight' $ (Parser.byVerWithMods mods version) path contents+          outfmt    = outputFormat opts+          mmap      = combinedModuleMap mods+          tenv      = combinedTypeEnv mods+          pvm       = combinedParamVarMap mods++      let runTypes = analyseAndCheckTypesWithEnv tenv . analyseRenamesWithModuleMap mmap . initAnalysis+      let runRenamer = stripAnalysis . rename . analyseRenamesWithModuleMap mmap . initAnalysis+      let runBBlocks pf = showBBlocks pf' ++ "\n\n" ++ showDataFlow pf'+            where pf' = analyseParameterVars pvm . analyseBBlocks . analyseRenamesWithModuleMap mmap . initAnalysis $ pf+      let runSuperGraph pf | outfmt == DOT = superBBGrToDOT sgr+                           | otherwise     = superGraphDataFlow pf' sgr+            where pf' = analyseParameterVars pvm . analyseBBlocks . analyseRenamesWithModuleMap mmap . initAnalysis $ pf+                  bbm = genBBlockMap pf'+                  sgr = genSuperBBGr bbm+      let findBlockPU pf astBlockId = listToMaybe+            [ pu | pu <- universeBi pf :: [ProgramUnit (Analysis A0)]+                 , bbgr <- maybeToList (bBlocks (getAnnotation pu))+                 , b <- concatMap snd $ labNodes (bbgrGr bbgr)+                 , insLabel (getAnnotation b) == Just astBlockId ]+      case actionOpt of+        Lex | version `elem` [ Fortran66, Fortran77, Fortran77Extended, Fortran77Legacy ] ->+          print $ Parser.collectTokens Fixed.lexer' $ initParseStateFixed "<unknown>" version contents+        Lex | version `elem` [Fortran90, Fortran2003, Fortran2008] ->+          print $ Parser.collectTokens Free.lexer'  $ initParseStateFree "<unknown>" version contents+        Lex        -> ioError $ userError $ usageInfo programName options+        Parse      -> pp parsedPF+        Typecheck  -> let (pf, _, errs) = runTypes parsedPF in+                        printTypeErrors errs >> printTypes (extractTypeEnv pf)+        Rename     -> pp $ runRenamer parsedPF+        BBlocks    -> putStrLn $ runBBlocks parsedPF+        SuperGraph -> putStrLn $ runSuperGraph parsedPF+        Reprint    ->+          let prettyContents = render . flip (pprint version) (Just 0) $ parsedPF+           in putStrLn $+                if   useContinuationReformatter opts+                then reformatMixedFormInsertContinuations prettyContents+                else prettyContents+        DumpModFile -> do+          let path' = if modFileSuffix `isSuffixOf` path then path else path <.> modFileSuffix+          contents' <- LB.readFile path'+          case decodeModFile contents' of+            Left msg  -> putStrLn $ "Error: " ++ msg+            Right mfs -> forM_ mfs $ \ mf ->+              putStrLn $ "Filename: " ++ moduleFilename mf +++                       "\n\nStringMap:\n" ++ showStringMap (combinedStringMap [mf]) +++                       "\n\nModuleMap:\n" ++ showModuleMap (combinedModuleMap [mf]) +++                       "\n\nDeclMap:\n" ++ showGenericMap (combinedDeclMap [mf]) +++                       "\n\nTypeEnv:\n" ++ showTypes (combinedTypeEnv [mf]) +++                       "\n\nParamVarMap:\n" ++ showGenericMap (combinedParamVarMap [mf]) +++                       "\n\nOther Data Labels: " ++ show (getLabelsModFileData mf)+        ShowFlows isFrom isSuper astBlockId -> do+          let pf = analyseParameterVars pvm .+                   analyseBBlocks .+                   analyseRenamesWithModuleMap mmap .+                   initAnalysis $ parsedPF+          let bbm = genBBlockMap pf+          case (isSuper, findBlockPU pf astBlockId) of+            (False, Nothing) -> fail "Couldn't find given AST block ID number."+            (False, Just pu)+              | Just bbgr <- M.lookup (puName pu) bbm ->+                  putStrLn $ showFlowsDOT pf bbgr astBlockId isFrom+              | otherwise -> do+                  print $ M.keys bbm+                  fail $ "Internal error: Program Unit " ++ show (puName pu) ++ " is lacking a basic block graph."+            (True, _) -> do+              let sgr = genSuperBBGr bbm+              putStrLn $ showFlowsDOT pf (superBBGrGraph sgr) astBlockId isFrom+        ShowBlocks mlinenum -> do+          let pf = analyseBBlocks .+                   analyseRenamesWithModuleMap mmap .+                   initAnalysis $ parsedPF+          let f :: ([ASTBlockNode], Int) -> ([ASTBlockNode], Int) -> ([ASTBlockNode], Int)+              f (nodes1, len1) (nodes2, len2)+                | len1 < len2 = (nodes1, len1)+                | len2 < len1 = (nodes2, len2)+                | otherwise   = (nodes1 ++ nodes2, len1)+          let lineMap :: IM.IntMap ([ASTBlockNode], Int)  -- ([list of IDs], line-distance of span)+              lineMap = IM.fromListWith f [+                (l, ([i], lineDistance ss))+                | b <- universeBi pf :: [Block (Analysis A0)]+                , i <- maybeToList . insLabel $ getAnnotation b+                , let ss = getSpan b+                , l <- spannedLines ss+                ]+          case mlinenum of+            Just l -> putStrLn . unwords . map show $ fromMaybe [] (fst <$> IM.lookup l lineMap)+            Nothing -> do+              let lineBs = B.lines contents+              let maxLen = maximum (0:map B.length lineBs)+              forM_ (zip lineBs [1..]) $ \ (line, l) -> do+                let nodeIDs = fromMaybe [] (fst <$> IM.lookup l lineMap)+                let nodeStr = B.intercalate "," (map (B.pack . ('B':) . show) nodeIDs)+                let suffix | null nodeIDs = ""+                           | otherwise    = B.replicate (maxLen - B.length line + 1) ' ' <> "!" <> nodeStr+                B.putStrLn $ line <> suffix+        _ -> fail $ usageInfo programName options+    _ -> fail $ usageInfo programName options+++-- | Expand all paths that are directories into a list of Fortran+-- files from a recursive directory listing.+expandDirs :: [FilePath] -> IO [FilePath]+expandDirs = fmap concat . mapM each+  where+    each path = do+      isDir <- doesDirectoryExist path+      if isDir+        then listFortranFiles path+        else pure [path]++-- | Get a list of Fortran files under the given directory.+listFortranFiles :: FilePath -> IO [FilePath]+listFortranFiles dir = filter isFortran <$> listDirectoryRecursively dir+  where+    -- | True if the file has a valid fortran extension.+    isFortran :: FilePath -> Bool+    isFortran x = map toLower (takeExtension x) `elem` exts+      where exts = [".f", ".f90", ".f77", ".f03"]++listDirectoryRecursively :: FilePath -> IO [FilePath]+listDirectoryRecursively dir = listDirectoryRec dir ""+  where+    listDirectoryRec :: FilePath -> FilePath -> IO [FilePath]+    listDirectoryRec d f = do+      let fullPath = d </> f+      isDir <- doesDirectoryExist fullPath+      if isDir+      then do+        conts <- listDirectory fullPath+        concat <$> mapM (listDirectoryRec fullPath) conts+      else pure [fullPath]++compileFileToMod :: Maybe FortranVersion -> ModFiles -> FilePath -> Maybe FilePath -> IO ModFile+compileFileToMod mvers mods path moutfile = do+  contents <- flexReadFile path+  let version = fromMaybe (deduceFortranVersion path) mvers+      mmap = combinedModuleMap mods+      tenv = combinedTypeEnv mods+      runCompile = genModFile . fst . analyseTypesWithEnv tenv . analyseRenamesWithModuleMap mmap . initAnalysis+      parsedPF  = fromRight' $ (Parser.byVerWithMods mods version) path contents+      mod = runCompile parsedPF+      fspath = path -<.> modFileSuffix `fromMaybe` moutfile+  LB.writeFile fspath $ encodeModFile [mod]+  return mod++decodeOneModFile :: FilePath -> IO ModFiles+decodeOneModFile path = do+  contents <- LB.readFile path+  case decodeModFile contents of+    Left msg -> do+      hPutStrLn stderr $ path ++ ": Error: " ++ msg+      return []+    Right modFiles -> do+      hPutStrLn stderr $ path ++ ": successfully parsed summary file."+      return modFiles++-- TODO almost replicated at Analysis.DataFlow.showDataFlow+superGraphDataFlow :: forall a. (Out a, Data a) => ProgramFile (Analysis a) -> SuperBBGr (Analysis a) -> String+superGraphDataFlow pf sgr = showBBGr (bbgrMap (nmap (map (fmap insLabel))) gr') ++ "\n\n" ++ replicate 50 '-' ++ "\n\n" +++                            show entries ++ "\n\n" ++ replicate 50 '-' ++ "\n\n" +++                            dfStr gr'+  where+    gr' = superBBGrGraph sgr+    entries = superBBGrEntries sgr+    dfStr gr = (\ (l, x) -> '\n':l ++ ": " ++ x) =<< [+                 ("callMap",      show cm)+               , ("entries",      show (bbgrEntries gr))+               , ("exits",        show (bbgrExits gr))+               , ("postOrder",    show (postOrder gr))+               , ("revPostOrder", show (revPostOrder gr))+               , ("revPreOrder",  show (revPreOrder gr))+               , ("dominators",   show (dominators gr))+               , ("iDominators",  show (iDominators gr))+               , ("defMap",       show dm)+               , ("lva",          show (IM.toList $ lva gr))+               , ("rd",           show (IM.toList rDefs))+               , ("backEdges",    show bedges)+               , ("topsort",      show (topsort $ bbgrGr gr))+               , ("scc ",         show (scc $ bbgrGr gr))+               , ("loopNodes",    show (loopNodes bedges $ bbgrGr gr))+               , ("duMap",        show (genDUMap bm dm gr rDefs))+               , ("udMap",        show (genUDMap bm dm gr rDefs))+               , ("flowsTo",      show (edges flTo))+               , ("varFlowsTo",   show (genVarFlowsToMap dm flTo))+               , ("ivMap",        show (genInductionVarMap bedges gr))+               , ("blockMap",     unlines [ "AST-block " ++ show i ++ ":\n" ++ pretty b | (i, b) <- IM.toList bm ])+               , ("derivedInd",   unlines [ "Expression " ++ show i ++ " (IE: " ++ show ie ++ "):\n" ++ pretty e+                                          | e <- universeBi bm :: [Expression (Analysis a)]+                                          , i <- maybeToList (insLabel (getAnnotation e))+                                          , let ie = IM.lookup i diMap ])+               , ("constExpMap",  show (genConstExpMap pf))+               ] where+                   bedges = genBackEdgeMap (dominators gr) $ bbgrGr gr+                   flTo   = genFlowsToGraph bm dm gr rDefs+                   rDefs  = rd gr+                   diMap  = genDerivedInductionMap bedges gr+    lva = liveVariableAnalysis+    bm = genBlockMap pf+    dm = genDefMap bm+    rd = reachingDefinitions dm+    cm = genCallMap pf++showGenericMap :: (Show a, Show b) => M.Map a b -> String+showGenericMap = unlines . map (\ (k, v) -> show k ++ " : " ++ show v) . M.toList+showStringMap :: StringMap -> String+showStringMap = showGenericMap+showModuleMap :: ModuleMap -> String+showModuleMap = concatMap (\ (n, m) -> show n ++ ":\n" ++ (unlines . map ("  "++) . lines . showGenericMap $ m)) . M.toList+showTypes :: TypeEnv -> String+showTypes tenv =+    flip concatMap (M.toList tenv) $+      \ (name, IDType { idVType = vt, idCType = ct }) ->+        printf "%s\t\t%s %s\n" name (drop 1 $ maybe "  -" show vt) (drop 2 $ maybe "   " show ct)+printTypes :: TypeEnv -> IO ()+printTypes = putStrLn . showTypes+showTypeErrors :: [TypeError] -> String+showTypeErrors errs = unlines [ show ss ++ ": " ++ msg | (msg, ss) <- sortBy (comparing snd) errs ]+printTypeErrors :: [TypeError] -> IO ()+printTypeErrors = putStrLn . showTypeErrors++data Action+  = Lex | Parse | Typecheck | Rename | BBlocks | SuperGraph | Reprint | DumpModFile | Compile+  | ShowFlows Bool Bool Int | ShowBlocks (Maybe Int) | ShowMakeGraph | Make+  deriving Eq++instance Read Action where+  readsPrec _ value =+    let options' = [ ("lex", Lex) , ("parse", Parse) ] in+      tryTypes options'+      where+        tryTypes [] = []+        tryTypes ((attempt,result):xs) =+          if map toLower value == attempt then [(result, "")] else tryTypes xs++data OutputFormat = Default | DOT deriving Eq++data Options = Options+  { fortranVersion  :: Maybe FortranVersion+  , action          :: Action+  , outputFormat    :: OutputFormat+  , outputFile      :: Maybe FilePath+  , includeDirs     :: [String]+  , useContinuationReformatter :: Bool+  }++initOptions :: Options+initOptions = Options Nothing Parse Default Nothing [] False++options :: [OptDescr (Options -> Options)]+options =+  [ Option ['v','F']+      ["fortranVersion"]+      (ReqArg (\v opts -> opts { fortranVersion = selectFortranVersion v }) "VERSION")+      "Fortran version to use, format: Fortran[66/77/77Legacy/77Extended/90]"+  , Option ['a']+      ["action"]+      (ReqArg (\a opts -> opts { action = read a }) "ACTION")+      "lex or parse action"+  , Option ['t']+      ["typecheck"]+      (NoArg $ \ opts -> opts { action = Typecheck })+      "parse and run typechecker"+  , Option ['R']+      ["rename"]+      (NoArg $ \ opts -> opts { action = Rename })+      "parse and rename variables"+  , Option ['B']+      ["bblocks"]+      (NoArg $ \ opts -> opts { action = BBlocks })+      "analyse basic blocks"+  , Option ['S']+      ["supergraph"]+      (NoArg $ \ opts -> opts { action = SuperGraph })+      "analyse super graph of basic blocks"+  , Option ['r']+      ["reprint"]+      (NoArg $ \ opts -> opts { action = Reprint })+      "Parse and output using pretty printer"+  , Option []+      ["split-long"]+      (NoArg $ \ opts -> opts { useContinuationReformatter = True })+      "when using pretty printer, split long lines via continuations"+  , Option []+      ["dot"]+      (NoArg $ \ opts -> opts { outputFormat = DOT })+      "output graphs in GraphViz DOT format"+  , Option []+      ["dump-mod-file"]+      (NoArg $ \ opts -> opts { action = DumpModFile })+      "dump the information contained within mod files"+  , Option ['I']+      ["include-dir"]+      (ReqArg (\ d opts -> opts { includeDirs = d:includeDirs opts }) "DIR")+      "directory to search for precompiled 'mod files'"+  , Option ['c']+      ["summarise", "compile-mod"]+      (NoArg $ \ opts -> opts { action = Compile })+      "build an .fsmod file from the input"+  , Option ['o']+      ["output-file"]+      (ReqArg (\ f opts -> opts { outputFile = Just f }) "FILE")+      "name of output file (e.g. name of generated fsmod file)"+  , Option []+      ["make-mods", "make"]+      (NoArg $ \ opts -> opts { action = Make })+      "determine dependency order of modules and automatically build .fsmod files"+  , Option []+      ["show-make-graph"]+      (NoArg $ \ opts -> opts { action = ShowMakeGraph })+      "dump a graph showing the build structure of modules"+  , Option []+      ["show-block-numbers"]+      (OptArg (\a opts -> opts { action = ShowBlocks (a >>= readMaybe) }+              ) "LINE-NUM")+      "Show the corresponding AST-block identifier number next to every line of code."+  , Option []+      ["show-flows-to"]+      (ReqArg (\a opts -> case a of s:num | toLower s == 's' -> opts { action = ShowFlows False True (read num) }+                                    b:num | toLower b == 'b' -> opts { action = ShowFlows False False (read num) }+                                    num                      -> opts { action = ShowFlows False False (read num) }+              ) "AST-BLOCK-ID")+      "dump a graph showing flows-to information from the given AST-block ID; prefix with 's' for supergraph"+  , Option []+      ["show-flows-from"]+      (ReqArg (\a opts -> case a of s:num | toLower s == 's' -> opts { action = ShowFlows True True (read num) }+                                    b:num | toLower b == 'b' -> opts { action = ShowFlows True False (read num) }+                                    num                      -> opts { action = ShowFlows True False (read num) }+              ) "AST-BLOCK-ID")+      "dump a graph showing flows-from information from the given AST-block ID; prefix with 's' for supergraph"+  ]++compileArgs :: [ String ] -> IO (Options, [ String ])+compileArgs args =+  case getOpt Permute options args of+    (o, n, []) -> return (foldl (flip id) initOptions o, n)+    (_, _, errors) -> ioError $ userError $ concat errors ++ usageInfo header options+  where+    header = "Usage: " ++ programName ++ " [OPTION...] <file...>"++instance {-# OVERLAPPING #-} Show [ Fixed.Token ] where+  show = unlines . lines'+    where+      lines' [] = []+      lines' xs =+        let (x, xs') = break isNewline xs+        in case xs' of+             (nl@(Fixed.TNewline _):xs'') -> ('\t' : (intercalate ", " . map show $ x ++ [nl])) : lines' xs''+             xs'' -> [ show xs'' ]+      isNewline (Fixed.TNewline _) = True+      isNewline _ = False++instance {-# OVERLAPPING #-} Show [ Free.Token ] where+  show = unlines . lines'+    where+      lines' [] = []+      lines' xs =+        let (x, xs') = break isNewline xs+        in case xs' of+             (nl@(Free.TNewline _):xs'') -> ('\t' : (intercalate ", " . map show $ x ++ [nl])) : lines' xs''+             xs'' -> [ show xs'' ]+      isNewline (Free.TNewline _) = True+      isNewline _ = False

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           fortran-src-version:        0.8.0+version:        0.9.0 synopsis:       Parsers and analyses for Fortran standards 66, 77, 90, 95 and 2003 (partial). description:    Provides lexing, parsing, and basic analyses of Fortran code covering standards: FORTRAN 66, FORTRAN 77, Fortran 90, Fortran 95, Fortran 2003 (partial) and some legacy extensions. Includes data flow and basic block analysis, a renamer, and type analysis. For example usage, see the @<https://hackage.haskell.org/package/camfort CamFort>@ project, which uses fortran-src as its front end. category:       Language@@ -62,46 +62,67 @@  library   exposed-modules:-      Language.Fortran.Analysis.SemanticTypes       Language.Fortran.Analysis-      Language.Fortran.Analysis.Renaming-      Language.Fortran.Analysis.ModGraph-      Language.Fortran.Analysis.Types       Language.Fortran.Analysis.BBlocks       Language.Fortran.Analysis.DataFlow+      Language.Fortran.Analysis.ModGraph+      Language.Fortran.Analysis.Renaming+      Language.Fortran.Analysis.SemanticTypes+      Language.Fortran.Analysis.Types       Language.Fortran.AST       Language.Fortran.AST.AList-      Language.Fortran.AST.RealLit       Language.Fortran.AST.Boz-      Language.Fortran.Version-      Language.Fortran.LValue+      Language.Fortran.AST.RealLit       Language.Fortran.Intrinsics-      Language.Fortran.Lexer.FixedForm-      Language.Fortran.Lexer.FixedForm.Utils-      Language.Fortran.Lexer.FreeForm-      Language.Fortran.ParserMonad-      Language.Fortran.Parser.Any-      Language.Fortran.Parser.Fortran66-      Language.Fortran.Parser.Fortran77-      Language.Fortran.Parser.Fortran90-      Language.Fortran.Parser.Fortran95-      Language.Fortran.Parser.Fortran2003-      Language.Fortran.Parser.Utils+      Language.Fortran.LValue+      Language.Fortran.Parser+      Language.Fortran.Parser.Fixed.Fortran66+      Language.Fortran.Parser.Fixed.Fortran77+      Language.Fortran.Parser.Fixed.Lexer+      Language.Fortran.Parser.Fixed.Utils+      Language.Fortran.Parser.Free.Fortran2003+      Language.Fortran.Parser.Free.Fortran90+      Language.Fortran.Parser.Free.Fortran95+      Language.Fortran.Parser.Free.Lexer+      Language.Fortran.Parser.Free.Utils+      Language.Fortran.Parser.LexerUtils+      Language.Fortran.Parser.Monad       Language.Fortran.PrettyPrint+      Language.Fortran.Rewriter+      Language.Fortran.Rewriter.Internal       Language.Fortran.Transformation.Disambiguation.Function       Language.Fortran.Transformation.Disambiguation.Intrinsic       Language.Fortran.Transformation.Grouping-      Language.Fortran.Transformation.TransformMonad-      Language.Fortran.Transformer-      Language.Fortran.Util.Position+      Language.Fortran.Transformation.Monad+      Language.Fortran.Util.Files       Language.Fortran.Util.FirstParameter-      Language.Fortran.Util.SecondParameter       Language.Fortran.Util.ModFile-      Language.Fortran.Util.Files-      Language.Fortran.Rewriter-      Language.Fortran.Rewriter.Internal+      Language.Fortran.Util.Position+      Language.Fortran.Util.SecondParameter+      Language.Fortran.Version+  other-modules:+      Paths_fortran_src   hs-source-dirs:       src+  default-extensions:+      EmptyCase+      FlexibleContexts+      FlexibleInstances+      InstanceSigs+      MultiParamTypeClasses+      PolyKinds+      LambdaCase+      DerivingStrategies+      StandaloneDeriving+      DeriveAnyClass+      DeriveGeneric+      DeriveDataTypeable+      DeriveFunctor+      DeriveFoldable+      DeriveTraversable+      DeriveLift+      BangPatterns+      TupleSections   ghc-options: -Wall -fno-warn-tabs   build-tools:       alex >=3.1@@ -115,6 +136,7 @@     , containers >=0.5 && <0.7     , deepseq ==1.4.*     , directory >=1.2 && <2+    , either >=5.0.1.1 && <5.1     , fgl ==5.*     , filepath ==1.4.*     , mtl >=2.2 && <3@@ -125,9 +147,30 @@   default-language: Haskell2010  executable fortran-src-  main-is: src/Main.hs+  main-is: Main.hs   other-modules:       Paths_fortran_src+  hs-source-dirs:+      app+  default-extensions:+      EmptyCase+      FlexibleContexts+      FlexibleInstances+      InstanceSigs+      MultiParamTypeClasses+      PolyKinds+      LambdaCase+      DerivingStrategies+      StandaloneDeriving+      DeriveAnyClass+      DeriveGeneric+      DeriveDataTypeable+      DeriveFunctor+      DeriveFoldable+      DeriveTraversable+      DeriveLift+      BangPatterns+      TupleSections   ghc-options: -Wall -fno-warn-tabs   build-depends:       GenericPretty >=1.2.2 && <2@@ -138,6 +181,7 @@     , containers >=0.5 && <0.7     , deepseq ==1.4.*     , directory >=1.2 && <2+    , either >=5.0.1.1 && <5.1     , fgl ==5.*     , filepath ==1.4.*     , fortran-src@@ -160,18 +204,17 @@       Language.Fortran.AnalysisSpec       Language.Fortran.AST.BozSpec       Language.Fortran.AST.RealLitSpec-      Language.Fortran.Lexer.FixedFormSpec-      Language.Fortran.Lexer.FreeFormSpec-      Language.Fortran.Parser.Fortran2003Spec-      Language.Fortran.Parser.Fortran2008Spec-      Language.Fortran.Parser.Fortran66Spec-      Language.Fortran.Parser.Fortran77.IncludeSpec-      Language.Fortran.Parser.Fortran77.ParserSpec-      Language.Fortran.Parser.Fortran90Spec-      Language.Fortran.Parser.Fortran95Spec-      Language.Fortran.Parser.FreeFormCommon-      Language.Fortran.Parser.UtilsSpec-      Language.Fortran.ParserMonadSpec+      Language.Fortran.Parser.Fixed.Fortran66Spec+      Language.Fortran.Parser.Fixed.Fortran77.IncludeSpec+      Language.Fortran.Parser.Fixed.Fortran77.ParserSpec+      Language.Fortran.Parser.Fixed.LexerSpec+      Language.Fortran.Parser.Free.Common+      Language.Fortran.Parser.Free.Fortran2003Spec+      Language.Fortran.Parser.Free.Fortran2008Spec+      Language.Fortran.Parser.Free.Fortran90Spec+      Language.Fortran.Parser.Free.Fortran95Spec+      Language.Fortran.Parser.Free.LexerSpec+      Language.Fortran.Parser.MonadSpec       Language.Fortran.PrettyPrintSpec       Language.Fortran.Rewriter.InternalSpec       Language.Fortran.RewriterSpec@@ -183,6 +226,25 @@       Paths_fortran_src   hs-source-dirs:       test+  default-extensions:+      EmptyCase+      FlexibleContexts+      FlexibleInstances+      InstanceSigs+      MultiParamTypeClasses+      PolyKinds+      LambdaCase+      DerivingStrategies+      StandaloneDeriving+      DeriveAnyClass+      DeriveGeneric+      DeriveDataTypeable+      DeriveFunctor+      DeriveFoldable+      DeriveTraversable+      DeriveLift+      BangPatterns+      TupleSections   ghc-options: -Wall   build-tool-depends:       hspec-discover:hspec-discover@@ -196,6 +258,7 @@     , containers >=0.5 && <0.7     , deepseq ==1.4.*     , directory >=1.2 && <2+    , either >=5.0.1.1 && <5.1     , fgl ==5.*     , filepath ==1.4.*     , fortran-src

@@ -1,10 +1,4 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleContexts #-}  -- | --@@ -73,6 +67,9 @@   , ModuleNature(..)   , Use(..)   , Argument(..)+  , ArgumentExpression(..)+  , argExprNormalize+  , argExtractExpr   , Intent(..)   , ControlPair(..)   , AllocOpt(..)@@ -115,19 +112,17 @@    ) where -import Prelude hiding (init)+import Prelude hiding ( init )  import Language.Fortran.AST.AList import Language.Fortran.AST.RealLit-import Language.Fortran.AST.Boz (Boz)+import Language.Fortran.AST.Boz ( Boz ) import Language.Fortran.Util.Position import Language.Fortran.Util.FirstParameter import Language.Fortran.Util.SecondParameter-import Language.Fortran.Version (FortranVersion(..))+import Language.Fortran.Version  import Data.Data-import Data.Generics.Uniplate.Data ()-import Data.Typeable () import Data.Binary import Control.DeepSeq import Text.PrettyPrint.GenericPretty@@ -490,9 +485,22 @@   | UseID a SrcSpan (Expression a)   deriving (Eq, Show, Data, Typeable, Generic, Functor) -data Argument a = Argument a SrcSpan (Maybe String) (Expression a)+-- TODO potentially should throw Maybe String into ArgumentExpression too?+data Argument a = Argument a SrcSpan (Maybe String) (ArgumentExpression a)   deriving (Eq, Show, Data, Typeable, Generic, Functor) +data ArgumentExpression a+  = ArgExpr              (Expression a)+  | ArgExprVar a SrcSpan Name+  deriving (Eq, Show, Data, Typeable, Generic, Functor)++argExprNormalize :: ArgumentExpression a -> Expression a+argExprNormalize = \case ArgExpr         e -> e+                         ArgExprVar a ss v -> ExpValue a ss (ValVariable v)++argExtractExpr :: Argument a -> Expression a+argExtractExpr (Argument _ _ _ ae) = argExprNormalize ae+ data Attribute a =     AttrAllocatable a SrcSpan   | AttrAsynchronous a SrcSpan@@ -918,6 +926,7 @@ instance Out Only instance Out ModuleNature instance Out a => Out (Argument a)+instance Out a => Out (ArgumentExpression a) instance Out a => Out (Use a) instance Out a => Out (Attribute a) instance Out Intent@@ -1016,6 +1025,7 @@ instance NFData a => NFData (Selector a) instance NFData a => NFData (ForallHeader a) instance NFData a => NFData (Argument a)+instance NFData a => NFData (ArgumentExpression a) instance NFData a => NFData (Use a) instance NFData a => NFData (Attribute a) instance NFData a => NFData (CommonGroup a)

@@ -1,9 +1,3 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveFunctor #-}- module Language.Fortran.AST.AList where  import Language.Fortran.Util.FirstParameter

@@ -15,9 +15,6 @@ 'Bits' instance. -} -{-# LANGUAGE DerivingStrategies, DeriveDataTypeable, DeriveGeneric, DeriveAnyClass #-}-{-# LANGUAGE LambdaCase #-}- module Language.Fortran.AST.Boz where  import           GHC.Generics@@ -28,7 +25,6 @@ import qualified Data.List as List import qualified Data.Char as Char import qualified Numeric   as Num-import           Data.Maybe ( isJust, fromJust )  -- | A Fortran BOZ literal constant. --@@ -44,9 +40,9 @@     deriving anyclass (NFData, Out)  data BozPrefix-  = BozPrefixB-  | BozPrefixO-  | BozPrefixZ -- also @x@+  = BozPrefixB  -- ^ binary (bitstring)+  | BozPrefixO  -- ^ octal+  | BozPrefixZ  -- ^ hex (also with prefix @x@)     deriving stock    (Eq, Show, Generic, Data, Typeable, Ord)     deriving anyclass (NFData, Out) @@ -78,24 +74,24 @@ --   @x@ for hexadecimal. prettyBoz :: Boz -> String prettyBoz b = prettyBozPrefix (bozPrefix b) : '\'' : bozString b <> "'"-  where prettyBozPrefix = \case-          BozPrefixB -> 'b'-          BozPrefixO -> 'o'-          BozPrefixZ -> 'z'+  where prettyBozPrefix = \case BozPrefixB -> 'b'+                                BozPrefixO -> 'o'+                                BozPrefixZ -> 'z'  -- | Resolve a BOZ constant as a natural (positive integer). -- -- Is actually polymorphic over the output type, but you probably want to -- resolve to 'Integer' or 'Natural' usually.+--+-- We assume the 'Boz' is well-formed, thus don't bother with digit predicates. bozAsNatural :: (Num a, Eq a) => Boz -> a bozAsNatural (Boz pfx str) = runReadS $ parser str   where     runReadS = fst . head-    parser = case pfx of-               BozPrefixB -> -- TODO on GHC 9.2, 'Num.readBin'-                 Num.readInt 2 (isJust . binCharFunc) (fromJust . binCharFunc)-               BozPrefixO -> Num.readOct-               BozPrefixZ -> Num.readHex-    binCharFunc = \case '0' -> Just 0-                        '1' -> Just 1-                        _   -> Nothing+    parser = case pfx of BozPrefixB -> Num.readInt 2 (const True) binDigitVal+                         -- (on GHC >=9.2, 'Num.readBin')+                         BozPrefixO -> Num.readOct+                         BozPrefixZ -> Num.readHex+    binDigitVal = \case '0' -> 0+                        '1' -> 1+                        _   -> error "Language.Fortran.AST.BOZ.bozAsNatural: invalid BOZ string"

@@ -12,8 +12,7 @@     Haskell literals do not support this.) -} -{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, DeriveAnyClass #-}-{-# LANGUAGE RecordWildCards, LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}  module Language.Fortran.AST.RealLit where 

@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, StandaloneDeriving, DeriveGeneric, TupleSections #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-orphans #-}  -- |@@ -240,7 +240,7 @@     lhsOfStmt :: Statement a -> [Expression a]     lhsOfStmt (StExpressionAssign _ _ e e') = e : onExprs e'     lhsOfStmt (StCall _ _ _ (Just aexps)) = filter isLExpr argExps ++ concatMap onExprs argExps-       where argExps = map extractExp . aStrip $ aexps+       where argExps = map argExtractExpr . aStrip $ aexps     lhsOfStmt s =  onExprs s      onExprs :: (Data a, Data (c a)) => c a -> [Expression a]@@ -249,8 +249,7 @@     lhsOfExp (ExpFunctionCall _ _ _ (Just aexps)) = fstLvl aexps     lhsOfExp _ = [] -    fstLvl = filter isLExpr . map extractExp . aStrip-    extractExp (Argument _ _ _ exp) = exp+    fstLvl = filter isLExpr . map argExtractExpr . aStrip  -- | Return list of expressions that are not "left-hand-side" of -- assignment statements.@@ -298,7 +297,7 @@     lhsOfStmt (StDeclaration _ _ _ _ decls) = concat [ lhsOfDecls decl | decl <- universeBi decls ]     lhsOfStmt (StCall _ _ f@(ExpValue _ _ (ValIntrinsic _)) _)       | Just defs <- intrinsicDefs f = defs-    lhsOfStmt (StCall _ _ _ (Just aexps)) = concatMap (match'' . extractExp) (aStrip aexps)+    lhsOfStmt (StCall _ _ _ (Just aexps)) = concatMap (match'' . argExtractExpr) (aStrip aexps)     lhsOfStmt s = onExprs s      lhsOfDecls (Declarator _ _ e _ _ (Just e')) = match' e : onExprs e'@@ -308,10 +307,8 @@     onExprs = concatMap lhsOfExp . universeBi      lhsOfExp :: Expression (Analysis a) -> [Name]-    lhsOfExp (ExpFunctionCall _ _ _ (Just aexps)) = concatMap (match . extractExp) (aStrip aexps)+    lhsOfExp (ExpFunctionCall _ _ _ (Just aexps)) = concatMap (match . argExtractExpr) (aStrip aexps)     lhsOfExp _ = []--    extractExp (Argument _ _ _ exp) = exp      -- Match and give the varname for LHS of statement     match' v@(ExpValue _ _ ValVariable{}) = varName v

@@ -1,6 +1,6 @@ -- | Analyse a program file and create basic blocks. -{-# LANGUAGE TupleSections, FlexibleContexts, PatternGuards, ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables #-} module Language.Fortran.Analysis.BBlocks   ( analyseBBlocks, genBBlockMap, showBBGr, showAnalysedBBGr, showBBlocks, bbgrToDOT, BBlockMap, ASTBlockNode, ASTExprNode   , genSuperBBGr, SuperBBGr(..), showSuperBBGr, superBBGrToDOT, findLabeledBBlock, showBlock )@@ -428,7 +428,7 @@   createEdges [ (prevN, callN, ()), (callN, nextN, ()) ] perBlock (BlStatement a s l (StCall a' s' cn@ExpValue{} (Just aargs))) = do   let a0 = head . initAnalysis $ [prevAnnotation a]-  let exps = map extractExp . aStrip $ aargs+  let exps = map argExtractExpr . aStrip $ aargs   (prevN, formalN) <- closeBBlock    -- create bblock that assigns formal parameters (n[1], n[2], ...)@@ -448,7 +448,8 @@   -- formalN' may differ from formalN when additional bblocks were   -- generated by processFunctionCalls. -  let dummyArgs = map (Argument a0 s' Nothing) (zipWith formal exps [(1::Integer)..])+  let dummyArgs = map (\e -> Argument a0 s' Nothing (ArgExpr e))+                      (zipWith formal exps [(1::Integer)..])    -- create "dummy call" bblock with dummy parameters in the StCall AST-node.   addToBBlock . analyseAllLhsVars1 $ BlStatement a s Nothing (StCall a' s' cn (Just $ fromList a0 dummyArgs))@@ -575,7 +576,7 @@   let a0 = head . initAnalysis $ [prevAnnotation a]   (prevN, formalN) <- closeBBlock -  let exps = map extractExp (fromMaybe [] (aStrip <$> aargs))+  let exps = map argExtractExpr (fromMaybe [] (aStrip <$> aargs))    -- create bblock that assigns formal parameters (fn[1], fn[2], ...)   let name i   = varName fn ++ "[" ++ show i ++ "]"@@ -587,7 +588,8 @@   (_, dummyCallN) <- closeBBlock    let retV = genVar a0 s $ name (0::Integer)-  let dummyArgs = map (Argument a0 s' Nothing) (retV:zipWith formal exps [(1::Integer)..])+  let dummyArgs = map (\e -> Argument a0 s' Nothing (ArgExpr e))+                      (retV:zipWith formal exps [(1::Integer)..])    -- create "dummy call" bblock with dummy arguments in the StCall AST-node.   addToBBlock . analyseAllLhsVars1 $ BlStatement a s Nothing (StCall a' s' fn (Just $ fromList a0 dummyArgs))@@ -610,9 +612,6 @@               , (dummyCallN, returnedN, ()), (returnedN, nextN, ()) ]   return temp processFunctionCall e = return e--extractExp :: Argument a -> Expression a-extractExp (Argument _ _ _ exp) = exp  -------------------------------------------------- -- Supergraph: all program units in one basic-block graph

@@ -1,6 +1,6 @@ -- | Dataflow analysis to be applied once basic block analysis is complete. -{-# LANGUAGE FlexibleContexts, PatternGuards, ScopedTypeVariables, TupleSections, DeriveGeneric, DeriveDataTypeable, BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-} module Language.Fortran.Analysis.DataFlow   ( dominators, iDominators, DomMap, IDomMap   , postOrder, revPostOrder, preOrder, revPreOrder, OrderF@@ -30,7 +30,6 @@ import Control.DeepSeq import Control.Arrow ((&&&)) import Text.PrettyPrint.GenericPretty (Out)-import Language.Fortran.Parser.Utils import Language.Fortran.Analysis import Language.Fortran.Analysis.BBlocks (showBlock, ASTBlockNode, ASTExprNode) import Language.Fortran.AST@@ -406,9 +405,7 @@     labelOf = insLabel . getAnnotation     doExpr :: Expression (Analysis a) -> Maybe Constant     doExpr e = case e of-      ExpValue _ _ (ValInteger str _)-        | Just i <- readInteger str -> Just . ConstInt $ fromIntegral i-      ExpValue _ _ (ValInteger str _) -> Just $ ConstUninterpInt str+      ExpValue _ _ (ValInteger intStr _) -> Just . ConstInt $ read intStr       ExpValue _ _ (ValReal r _)    -> Just $ ConstUninterpReal (prettyHsRealLit r) -- TODO       ExpValue _ _ (ValVariable _)  -> getV e       -- Recursively seek information about sub-expressions, relying on laziness.@@ -603,8 +600,7 @@ derivedInductionExpr :: Data a => IEFlow -> Expression (Analysis a) -> InductionExpr derivedInductionExpr flow e = case e of   v@(ExpValue _ _ (ValVariable _))   -> fromMaybe IETop $ M.lookup (varName v) (ieFlowVars flow)-  ExpValue _ _ (ValInteger str _)-    | Just i <- readInteger str      -> IELinear "" 0 (fromIntegral i)+  ExpValue _ _ (ValInteger intStr _) -> IELinear "" 0 $ read intStr   ExpBinary _ _ Addition e1 e2       -> derive e1 `addInductionExprs` derive e2   ExpBinary _ _ Subtraction e1 e2    -> derive e1 `addInductionExprs` negInductionExpr (derive e2)   ExpBinary _ _ Multiplication e1 e2 -> derive e1 `mulInductionExprs` derive e2@@ -621,8 +617,7 @@                 | otherwise = derivedInductionExprM e'   ie <- case e of         v@(ExpValue _ _ (ValVariable _))   -> pure . fromMaybe IETop $ M.lookup (varName v) (ieFlowVars flow)-        ExpValue _ _ (ValInteger str _)-          | Just i <- readInteger str      -> pure $ IELinear "" 0 (fromIntegral i)+        ExpValue _ _ (ValInteger intStr _) -> pure $ IELinear "" 0 $ read intStr         ExpBinary _ _ Addition e1 e2       -> addInductionExprs <$> derive e1 <*> derive e2         ExpBinary _ _ Subtraction e1 e2    -> addInductionExprs <$> derive e1 <*> (negInductionExpr <$> derive e2)         ExpBinary _ _ Multiplication e1 e2 -> mulInductionExprs <$> derive e1 <*> derive e2

@@ -1,10 +1,16 @@-{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, PatternGuards, TupleSections #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | Generate a module use-graph. module Language.Fortran.Analysis.ModGraph   (genModGraph, ModGraph(..), ModOrigin(..), modGraphToDOT, takeNextMods, delModNodes) where +import Language.Fortran.AST hiding (setName)+import qualified Language.Fortran.Parser as Parser+import Language.Fortran.Version+import Language.Fortran.Util.ModFile+import Language.Fortran.Util.Files+ import Prelude hiding (mod) import Control.Monad import Control.Monad.State.Strict@@ -12,16 +18,8 @@ import Data.Generics.Uniplate.Data import Data.Graph.Inductive hiding (version) import Data.Maybe-import Language.Fortran.AST hiding (setName)-import Language.Fortran.Version (FortranVersion(..), deduceFortranVersion)-import Language.Fortran.Parser.Any (parserWithModFilesVersions)-import Language.Fortran.ParserMonad (fromRight)-import Language.Fortran.Util.ModFile-import Language.Fortran.Util.Files-import qualified Data.ByteString.Lazy.Char8 as LB+import Data.Either.Combinators ( fromRight' ) import qualified Data.Map as M-import System.IO-import System.FilePath  -------------------------------------------------- @@ -85,16 +83,16 @@   let iter :: FilePath -> ModGrapher ()       iter path = do         contents <- liftIO $ flexReadFile path-        let version = fromMaybe (deduceFortranVersion path) mversion-        let parserF0 = parserWithModFilesVersions version-        let parserF m b s = fromRight (parserF0 m b s)         fileMods <- liftIO $ decodeModFiles includeDirs-        let mods = map snd fileMods+        let version = fromMaybe (deduceFortranVersion path) mversion+            mods = map snd fileMods+            parserF0 = Parser.byVerWithMods mods version+            parserF fn bs = fromRight' $ parserF0 fn bs         forM_ fileMods $ \ (fileName, mod) -> do           forM_ [ name | Named name <- M.keys (combinedModuleMap [mod]) ] $ \ name -> do             _ <- maybeAddModName name . Just $ MOFSMod fileName             pure ()-        let pf = parserF mods contents path+        let pf = parserF path contents         mapM_ (perModule path) (childrenBi pf :: [ProgramUnit ()])         pure ()   execStateT (mapM_ iter paths) modGraph0@@ -123,24 +121,3 @@ delModNodes ns mg@ModGraph { mgGraph = gr } = mg'   where     mg' = mg { mgGraph = delNodes ns gr }------------------------------------------------------decodeModFiles :: [FilePath] -> IO [(FilePath, ModFile)]-decodeModFiles = foldM (\ modFiles d -> do-      -- Figure out the camfort mod files and parse them.-      modFileNames <- filter isModFile `fmap` getDirContents d-      addedModFiles <- fmap concat . forM modFileNames $ \ modFileName -> do-        contents <- LB.readFile (d </> modFileName)-        case decodeModFile contents of-          Left msg -> do-            hPutStrLn stderr $ modFileName ++ ": Error: " ++ msg-            return [(modFileName, emptyModFile)]-          Right mods -> do-            hPutStrLn stderr $ modFileName ++ ": successfully parsed precompiled file."-            return $ map (modFileName,) mods-      return $ addedModFiles ++ modFiles-    ) [] -- can't use emptyModFiles--isModFile :: FilePath -> Bool-isModFile = (== modFileSuffix) . takeExtension

@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables, PatternGuards, TupleSections #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | -- Analyse variables/function names and produce unique names that can@@ -14,7 +14,7 @@ import Language.Fortran.AST hiding (fromList) import Language.Fortran.Intrinsics import Language.Fortran.Analysis-import Language.Fortran.ParserMonad (FortranVersion(..))+import Language.Fortran.Version  import Prelude hiding (lookup) import Data.Maybe (mapMaybe, fromMaybe)

@@ -1,7 +1,4 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}  module Language.Fortran.Analysis.SemanticTypes where

@@ -1,6 +1,4 @@ {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE LambdaCase          #-}-{-# LANGUAGE FlexibleContexts    #-}  module Language.Fortran.Analysis.Types   ( analyseTypes@@ -428,8 +426,8 @@             ITLogical   -> wrapBaseType TypeLogical             ITCharacter -> wrapBaseType TypeCharacter             ITParam i-              | length params >= i, Argument _ _ _ e <- params !! (i-1)-                -> return $ idVType =<< getIDType e+              | length params >= i, Argument _ _ _ ae <- params !! (i-1)+                -> return $ idVType =<< getIDType (argExprNormalize ae)               | otherwise -> typeError ("Invalid parameter list to intrinsic '" ++ n ++ "'") ss >> return Nothing       case mst of         Nothing -> return emptyType

@@ -1,6 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}- module Language.Fortran.Intrinsics   ( getVersionIntrinsics, getIntrinsicReturnType, getIntrinsicNames, getIntrinsicDefsUses, isIntrinsic   , IntrinsicType(..), IntrinsicsTable, allIntrinsics )@@ -10,7 +7,7 @@ import Data.Data import Data.List import GHC.Generics (Generic)-import Language.Fortran.ParserMonad (FortranVersion(..))+import Language.Fortran.Version   data IntrinsicType = ITReal | ITInteger | ITComplex | ITDouble | ITLogical | ITCharacter | ITParam Int

@@ -1,9 +1,3 @@-{-# LANGUAGE DeriveDataTypeable    #-}-{-# LANGUAGE DeriveFunctor         #-}-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}- module Language.Fortran.LValue where  import           Prelude                               hiding (exp)

@@ -1,1153 +0,0 @@--- -*- Mode: Haskell -*--{-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-}--module Language.Fortran.Lexer.FixedForm-  ( lexer, initParseState, collectFixedTokens, collectFixedTokensSafe-  , Token(..), LexAction, AlexInput(..), lexemeMatch, lexN-  ) where--import Data.Word (Word8)-import Data.Char (toLower, ord, isDigit)-import Data.List (isPrefixOf)-import Data.Maybe (fromJust, isNothing, isJust)-import Data.Data-import qualified Data.Bits-import qualified Data.ByteString.Char8 as B--import Control.Monad.State--import GHC.Generics--import Language.Fortran.ParserMonad---import Language.Fortran.Version (required when ParserMonad stops exporting it)-import Language.Fortran.Util.FirstParameter-import Language.Fortran.Util.Position-import Language.Fortran.Parser.Utils (readInteger)-import Language.Fortran.AST.Boz--}--$digit      = 0-9-$bit        = 0-1-$octalDigit = 0-7-$hexDigit   = [a-f $digit]--$hash = [\#]--@binary = b\'$bit+\' | \'$bit+\'b-@octal  = o\'$octalDigit+\' | \'$octalDigit+\'o-@hex    = [xz]\'$hexDigit+\' | \'$hexDigit+\'[xz]--$letter = a-z-$alphanumeric = [$letter $digit]-$alphanumericExtended = [$letter $digit \_]-$special = [\ \=\+\-\*\/\(\)\,\.\$]---- This should really be 6 characters but there are many standard non-compliant--- programs out there.-@idExtended = $letter $alphanumericExtended{0,9} $alphanumericExtended{0,9} $alphanumericExtended{0,9} $alphanumericExtended?-@id = $letter $alphanumeric{0,5}-@label = $digit{1,5}--@idLegacy = [$letter \_] [$alphanumericExtended \$]*--@datatype = "integer" | "real" | "doubleprecision" | "complex" | "logical"-          -- legacy extensions-          | "byte"---- Numbers-@integerConst = $digit+-@posIntegerConst = [1-9] $digit*-@bozLiteralConst = (@binary|@octal|@hex)---- For reals-@exponent = [ed] [\+\-]? @integerConst---- For format items-@repeat = @posIntegerConst?-@width = @posIntegerConst--tokens :---  <0> [c!\*d] / { commentP }                  { lexComment }-  "!" / { bangCommentP &&& legacy77P }        { lexComment }-  <0> @label / { withinLabelColsP }           { addSpanAndMatch TLabel }-  <0> . / { \_ ai _ _ -> atColP 6 ai }        { toSC keyword }-  <0> " "                                     ;--  <0> $hash                                   { lexHash }--  <0,st,keyword,iif,assn,doo> \n              { resetPar >> toSC 0 >> addSpan TNewline }-  <0,st,keyword,iif,assn,doo> \r              ;--  <st,keyword,iif,assn,doo> ";"               { resetPar >> toSC keyword >> addSpan TNewline }--  <st> "("                                    { addSpan TLeftPar }-  <keyword> "(" / { legacy77P }               { addSpan TLeftPar }-  <iif> "("                                   { incPar >> addSpan TLeftPar }-  <st> ")"                                    { addSpan TRightPar }-  <keyword> ")" / { legacy77P }               { typeSCChange >> addSpan TRightPar }-  <iif> ")"                                   { maybeToKeyword >> addSpan TRightPar }-  <st,iif> "(/" / { formatExtendedP }         { addSpan TLeftArrayPar }-  <st,iif> "/)" / { formatExtendedP }         { addSpan TRightArrayPar }-  <st,iif,doo,keyword> ","                    { addSpan TComma }-  <st,iif,keyword> "."                        { addSpan TDot }-  <st,iif,keyword> "%"                        { addSpan TPercent }-  <keyword> "." / { legacy77P }               { addSpan TDot }-  <st,iif> ":" / { fortran77P }               { addSpan TColon }--  <keyword> @id / { idP }                     { toSC st >> addSpanAndMatch TId }-  <keyword> @idExtended / { extendedIdP }     { toSC st >> addSpanAndMatch TId }-  <keyword> @idLegacy / { legacyIdP }         { toSC st >> addSpanAndMatch TId }--  <keyword> "include" / { extended77P }       { toSC st >> addSpan TInclude }--  -- Tokens related to procedures and subprograms-  <keyword> "program"                         { toSC st >> addSpan TProgram }-  <keyword> "function" / { functionP }        { toSC st >> addSpan TFunction  }-  <keyword> "subroutine"                      { toSC st >> addSpan TSubroutine  }-  <keyword> "blockdata"                       { toSC st >> addSpan TBlockData  }-  <keyword> "structure"    / { legacy77P }    { toSC st >> addSpan TStructure  }-  <keyword> "union"        / { legacy77P }    { toSC st >> addSpan TUnion  }-  <keyword> "map"          / { legacy77P }    { toSC st >> addSpan TMap  }-  <keyword> "endstructure" / { legacy77P }    { toSC st >> addSpan TEndStructure  }-  <keyword> "endunion"     / { legacy77P }    { toSC st >> addSpan TEndUnion  }-  <keyword> "endmap"       / { legacy77P }    { toSC st >> addSpan TEndMap  }-  <keyword> "record"       / { legacy77P }    { toSC st >> addSpan TRecord  }-  <keyword> "end"                             { toSC st >> addSpan TEnd  }-  <keyword> "endprogram"    / { legacy77P }   { toSC st >> addSpan TEndProgram  }-  <keyword> "endfunction"   / { legacy77P }   { toSC st >> addSpan TEndFunction  }-  <keyword> "endsubroutine" / { legacy77P }   { toSC st >> addSpan TEndSubroutine  }--  -- Tokens related to assignment statements-  <keyword> "assign"                          { toSC assn >> addSpan TAssign  }-  <assn> @integerConst                        { addSpanAndMatch TInt }-  <assn> "to"                                 { addSpan TTo  }-  <assn> @id / { notToP }             { addSpanAndMatch TId }-  <assn> @idExtended / { notToP &&& extended77P } { addSpanAndMatch TId }-  <assn> @idLegacy / { notToP &&& legacy77P } { addSpanAndMatch TId }-  <st,iif> "="                                { addSpan TOpAssign  }--  -- Tokens related to control statements-  <keyword> "goto"                            { toSC st >> addSpan TGoto  }-  <keyword> "if" / { ifP }                    { toSC iif >> addSpan TIf  }-  <st,keyword> "then" / { fortran77P }        { toSC keyword >> addSpan TThen  }-  <keyword> "else" / {fortran77P }            { addSpan TElse  }-  <keyword> "elseif" / {fortran77P }          { toSC st >> addSpan TElsif  }-  <keyword> "endif" / {fortran77P }           { addSpan TEndif  }-  <keyword> "call"                            { toSC st >> addSpan TCall  }-  <keyword> "return"                          { toSC st >> addSpan TReturn  }-  <keyword> "save" / { fortran77P }           { toSC st >> addSpan TSave  }-  <keyword> "continue"                        { toSC st >> addSpan TContinue  }-  <keyword> "stop"                            { toSC st >> addSpan TStop  }-  <keyword> "exit" / { extended77P }          { toSC st >> addSpan TExit  }-  <keyword> "cycle" / { legacy77P }           { toSC st >> addSpan TCycle  }-  <keyword> "case" / { legacy77P }            { toSC st >> addSpan TCase  }-  <keyword> "casedefault" / { legacy77P }     { toSC st >> addSpan TCaseDefault  }-  <keyword> "selectcase" / { legacy77P }      { toSC st >> addSpan TSelectCase  }-  <keyword> "endselect" / { legacy77P }       { toSC st >> addSpan TEndSelect  }-  <keyword> "pause"                           { toSC st >> addSpan TPause  }-  <keyword> "dowhile" / { extended77P }       { toSC st >> addSpan TDoWhile }-  <keyword> "enddo" / { extended77P }         { toSC st >> addSpan TEndDo  }-  <keyword> "do"                              { toSC doo >> addSpan TDo }-  <doo> @integerConst                         { addSpanAndMatch TInt }-  <doo> "while" / { extended77P }             { toSC st >> addSpan TWhile }-  <doo> @id                                   { toSC st >> addSpanAndMatch TId }-  <doo> @idExtended / { extended77P }         { toSC st >> addSpanAndMatch TId }-  <doo> @idLegacy / { legacy77P }             { toSC st >> addSpanAndMatch TId }--  -- Tokens related to I/O statements-  <keyword> "read"                            { toSC st >> addSpan TRead  }-  <keyword> "write"                           { toSC st >> addSpan TWrite  }-  <keyword> "rewind"                          { toSC st >> addSpan TRewind  }-  <keyword> "backspace"                       { toSC st >> addSpan TBackspace  }-  <keyword> "endfile"                         { toSC st >> addSpan TEndfile  }-  <keyword> "inquire" / { fortran77P }        { toSC st >> addSpan TInquire  }-  <keyword> "open" / { fortran77P }           { toSC st >> addSpan TOpen  }-  <keyword> "close" / { fortran77P }          { toSC st >> addSpan TClose  }-  <keyword> "print" / { fortran77P }          { toSC st >> addSpan TPrint  }-  <keyword> "type" / { legacy77P }            { toSC st >> addSpan TTypePrint  }--  -- Tokens related to non-executable statements--  -- Tokens related to speification statements-  <keyword> "dimension"                       { toSC st >> addSpan TDimension  }-  <keyword> "common"                          { toSC st >> addSpan TCommon  }-  <keyword> "equivalence"                     { toSC st >> addSpan TEquivalence  }-  <keyword> "external"                        { toSC st >> addSpan TExternal  }-  <keyword> "intrinsic" / { fortran77P }      { toSC st >> addSpan TIntrinsic  }-  <keyword> @datatype                         { typeSCChange >> addSpanAndMatch TType }-  <st> @datatype / { implicitStP }            { addSpanAndMatch TType }--  <keyword> "doublecomplex" / { extended77P } { typeSCChange >> addSpanAndMatch TType }-  <st> "doublecomplex" / { implicitTypeExtendedP }  { addSpanAndMatch TType }-  <keyword> "character" / { fortran77P }      { typeSCChange >> addSpanAndMatch TType }-  <st> "character" / { implicitType77P }      { addSpanAndMatch TType }-  <keyword> "implicit" / { fortran77P }       { toSC st >> addSpan TImplicit  }-  <st> "none" / { implicitType77P }           { addSpan TNone  }-  <keyword> "parameter" / { fortran77P }      { toSC st >> addSpan TParameter  }-  <keyword> "entry" / { fortran77P }          { toSC st >> addSpan TEntry  }-  <keyword> "pointer" / { legacy77P }         { toSC st >> addSpan TPointer  }--  -- Tokens related to data initalization statement-  <keyword> "data"                            { toSC st >> addSpan TData  }-  <keyword> "automatic" / { legacy77P }       { toSC st >> addSpan TAutomatic  }-  <keyword> "static" / { legacy77P }          { toSC st >> addSpan TStatic }--  -- Tokens related to format statement-  <keyword> "format"                          { toSC fmt >> enterFormat >> addSpan TFormat  }-  <fmt> "(".*")"                              { toSC st >> exitFormat >> addSpanAndMatch TBlob }--  -- Tokens needed to parse integers, reals, double precision and complex-  -- constants-  <st,iif> @exponent / { exponentP }          { addSpanAndMatch TExponent }-  <st,iif> @integerConst                      { addSpanAndMatch TInt }-    -- can be part (end) of function type declaration-  <keyword> @integerConst                     { typeSCChange >> addSpanAndMatch TInt }-  <st,iif,keyword> @bozLiteralConst / { legacy77P } { addSpanAndMatch $ \ss s -> TBozLiteral ss (parseBoz s) }--  -- String-  <st,iif> \' / { fortran77P }                { strAutomaton '\'' 0 }-  <st,iif> \" / { legacy77P }                 { strAutomaton '"'  0 }--  -- Logicals-  <st,iif> ".true."                           { addSpan (\s -> TBool s True)  }-  <st,iif> ".false."                          { addSpan (\s -> TBool s False) }--  -- Arithmetic operators-  <st,iif> "+"                                { addSpan TOpPlus  }-  <st,iif> "-"                                { addSpan TOpMinus  }-  <st,iif> "**"                               { addSpan TOpExp  }-  <st,iif> "*"                                { addSpan TStar  }-    -- can be part of function type declaration-  <keyword> "*" / { legacy77P }               { addSpan TStar  }-  <st,iif> "/"                                { addSpan TSlash  }-  <st,iif> "&" / { legacy77P }                { addSpan TAmpersand  }--  -- Logical operators-  <st,iif> ".or."                             { addSpan TOpOr  }-  <st,iif> ".and."                            { addSpan TOpAnd  }-  <st,iif> ".not."                            { addSpan TOpNot  }-  <st,iif> ".xor." / { legacy77P }            { addSpan TOpXOr  }-  <st,iif> ".eqv." / { fortran77P }           { addSpan TOpEquivalent  }-  <st,iif> ".neqv." / { fortran77P }          { addSpan TOpNotEquivalent  }--  -- Relational operators-  <st,iif> "<" / { extended77P }              { addSpan TOpLT  }-  <st,iif> "<=" / { extended77P }             { addSpan TOpLE  }-  <st,iif> "==" / { extended77P }             { addSpan TOpEQ  }-  <st,iif> "/=" / { extended77P }             { addSpan TOpNE  }-  <st,iif> ">" / { extended77P }              { addSpan TOpGT  }-  <st,iif> ">=" / { extended77P }             { addSpan TOpGE  }-  <st,iif> ".lt."                             { addSpan TOpLT  }-  <st,iif> ".le."                             { addSpan TOpLE  }-  <st,iif> ".eq."                             { addSpan TOpEQ  }-  <st,iif> ".ne."                             { addSpan TOpNE  }-  <st,iif> ".gt."                             { addSpan TOpGT  }-  <st,iif> ".ge."                             { addSpan TOpGE  }--  -- ID-  <st,iif> @id                                { addSpanAndMatch TId }-  <st,iif> @idExtended / { extended77P }      { addSpanAndMatch TId }-  <st,iif> @idLegacy / { legacy77P }          { addSpanAndMatch TId }--  -- Strings-  <st> @posIntegerConst "h" / { fortran66P }  { lexHollerith }-  <st,iif> @posIntegerConst "h" / { hollerithP &&& legacy77P } { lexHollerith }--{------------------------------------------------------------------------------------- Predicated lexer helpers-----------------------------------------------------------------------------------(&&&) :: (FortranVersion -> AlexInput -> Int -> AlexInput -> Bool)-      -> (FortranVersion -> AlexInput -> Int -> AlexInput -> Bool)-      -> (FortranVersion -> AlexInput -> Int -> AlexInput -> Bool)-f &&& g = \ fv ai1 i ai2 -> f fv ai1 i ai2 && g fv ai1 i ai2--formatExtendedP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool-formatExtendedP fv _ _ ai = fv `elem` [Fortran77Extended, Fortran77Legacy] &&-  case xs of-    [ TFormat _, _ ] -> False-    [ TLabel _ _, TFormat _ ] -> False-    _ -> True-  where-    xs = take 2 . reverse . aiPreviousTokensInLine $ ai--implicitType77P :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool-implicitType77P fv b c d = fortran77P fv b c d && implicitStP fv b c d--implicitTypeExtendedP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool-implicitTypeExtendedP fv b c d = extended77P fv b c d && implicitStP fv b c d--implicitStP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool-implicitStP _ _ _ ai = checkPreviousTokensInLine f ai-  where-    f (TImplicit _) = True-    f _ = False--extendedIdP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool-extendedIdP fv a b ai = fv `elem` [Fortran77Extended, Fortran77Legacy] && idP fv a b ai--legacyIdP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool-legacyIdP fv a b ai = fv == Fortran77Legacy && idP fv a b ai--idP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool-idP fv ao i ai = not (doP fv ai) && not (ifP fv ao i ai)-             && (equalFollowsP fv ai || rParFollowsP fv ai)--doP :: FortranVersion -> AlexInput -> Bool-doP fv ai = isPrefixOf "do" (reverse . lexemeMatch . aiLexeme $ ai) &&-    case unParse (lexer $ f (0::Integer)) ps of-      ParseOk True _ -> True-      _ -> False-  where-    ps = ParseState-      { psAlexInput = ai { aiStartCode = st}-      , psVersion = fv-      , psFilename = "<unknown>"-      , psParanthesesCount = ParanthesesCount 0 False-      , psContext = [ ConStart ] }-    f 0 t =-      case t of-        TNewline{} -> return False-        TEOF{} -> return False-        TLeftPar{} -> lexer $ f 1-        TComma{} -> return True-        _ -> lexer $ f 0-    f !n t =-      case t of-        TLeftPar{} -> lexer $ f (n+1)-        TRightPar{} -> lexer $ f (n-1)-        _ -> lexer $ f n--ifP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool-ifP fv _ _ ai = "if" == (reverse . lexemeMatch . aiLexeme $ ai) &&-    case unParse (lexer $ f) ps of-      ParseOk True _ -> True-      _ -> False-  where-    ps = ParseState-      { psAlexInput = ai { aiStartCode = st}-      , psVersion = fv-      , psFilename = "<unknown>"-      , psParanthesesCount = ParanthesesCount 0 False-      , psContext = [ ConStart ] }-    f t =-      case t of-        -- IF is always followed by (-        TLeftPar{} -> return True-        _ -> return False--functionP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool-functionP fv _ _ ai = "function" == (reverse . lexemeMatch . aiLexeme $ ai) &&-    case unParse (lexer $ f) ps of-      ParseOk True _ -> True-      _ -> False-  where-    ps = ParseState-      { psAlexInput = ai { aiStartCode = st}-      , psVersion = fv-      , psFilename = "<unknown>"-      , psParanthesesCount = ParanthesesCount 0 False-      , psContext = [ ConStart ] }-    f t =-      case t of-        -- a function keyword should be followed by the name and a left paren-        TId{} -> lexer f-        TLeftPar{} -> return True-        _ -> return False--hollerithP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool-hollerithP _ _ _ ai = isDigit (lookBack 2 ai)--notToP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool-notToP _ _ _ ai = not $ "to" `isPrefixOf` (reverse . lexemeMatch . aiLexeme $ ai)--equalFollowsP :: FortranVersion -> AlexInput -> Bool-equalFollowsP fv ai =-    case unParse (lexer $ f False (0::Integer)) ps of-      ParseOk True _ -> True-      _ -> False-  where-    ps = ParseState-      { psAlexInput = ai { aiStartCode = st}-      , psVersion = fv-      , psFilename = "<unknown>"-      , psParanthesesCount = ParanthesesCount 0 False-      , psContext = [ ConStart ] }-    f False 0 t =-      case t of-        TNewline{} -> return False-        TEOF{} -> return False-        TOpAssign{} -> return True-        TLeftPar{} -> lexer $ f True 1-        TDot{} -> lexer $ f False 0-        TId{} -> lexer $ f False 0-        _ -> return False-    f False _ _ = return False-    f True 0 t =-      case t of-        TOpAssign{} -> return True-        TDot{} -> lexer $ f True 0-        TId{} -> lexer $ f True 0-        TLeftPar{} -> lexer $ f True 1-        _ -> return False-    f True n t =-      case t of-        TNewline{} -> return False-        TEOF{} -> return False-        TLeftPar{} -> lexer $ f True (n + 1)-        TRightPar{} -> lexer $ f True (n - 1)-        _ -> lexer $ f True n--rParFollowsP :: FortranVersion -> AlexInput -> Bool-rParFollowsP fv ai =-    case unParse (lexer $ f) ps of-      ParseOk True _ -> True-      _ -> False-  where-    ps = ParseState-      { psAlexInput = ai { aiStartCode = st}-      , psVersion = fv-      , psFilename = "<unknown>"-      , psParanthesesCount = ParanthesesCount 0 False-      , psContext = [ ConStart ] }-    f t =-      case t of-        TRightPar{} -> return True-        _ -> return False--commentP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool-commentP _ aiOld _ aiNew = atColP 1 aiOld && _endsWithLine-  where-    _endsWithLine = (posColumn . aiPosition) aiNew /= 1--bangCommentP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool-bangCommentP _ _ _ aiNew = _endsWithLine-  where-    _endsWithLine = (posColumn . aiPosition) aiNew /= 1--withinLabelColsP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool-withinLabelColsP _ aiOld _ aiNew = getCol aiOld >= 1 && getCol aiNew <= 6-  where-    getCol = posColumn . aiPosition--atColP :: Int -> AlexInput -> Bool-atColP n ai = (posColumn . aiPosition) ai == n---- This predicate allows to distinguish identifiers and real exponent tokens--- by looking at previous token. Since exponent can only follow a "." or an--- integer token. Anything other previous token will prevent matching the input--- as an exponent token.-exponentP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool-exponentP _ _ _ ai =-  case aiPreviousTokensInLine ai of-    -- real*8 d8 is not an exponent-    TInt{} : TStar{} : TType{} : _ -> False-    TInt{} : _ -> True-    TDot{} : _ -> True-    _ -> False--fortran66P :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool-fortran66P fv _ _ _ = fv == Fortran66--fortran77P :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool-fortran77P fv _ _ _ = fv == Fortran77 || fv == Fortran77Extended || fv == Fortran77Legacy--extended77P :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool-extended77P fv _ _ _ = fv == Fortran77Extended || fv == Fortran77Legacy--legacy77P :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool-legacy77P fv _ _ _ = fv == Fortran77Legacy-------------------------------------------------------------------------------------- Lexer helpers-----------------------------------------------------------------------------------addSpan :: (SrcSpan -> Token) -> LexAction (Maybe Token)-addSpan cons = do-  s <- getLexemeSpan-  return $ Just $ cons s--addSpanAndMatch :: (SrcSpan -> String -> Token) -> LexAction (Maybe Token)-addSpanAndMatch cons = do-  s <- getLexemeSpan-  m <- getMatch-  return $ Just $ cons s m--getLexeme :: LexAction Lexeme-getLexeme = do-  ai <- getAlex-  return $ aiLexeme ai--putLexeme :: Lexeme -> LexAction ()-putLexeme lexeme = do-  ai <- getAlex-  putAlex $ ai { aiLexeme = lexeme }--resetLexeme :: LexAction ()-resetLexeme = putLexeme initLexeme--getMatch :: LexAction String-getMatch = do-  lexeme <- getLexeme-  return $ (reverse . lexemeMatch) lexeme--putMatch :: String -> LexAction ()-putMatch newMatch = do-  lexeme <- getLexeme-  putLexeme $ lexeme { lexemeMatch = reverse newMatch }--incWhiteSensitiveCharCount :: LexAction ()-incWhiteSensitiveCharCount = do-  ai <- getAlex-  let wsc = aiWhiteSensitiveCharCount ai-  putAlex $ ai { aiWhiteSensitiveCharCount = wsc + 1 }--resetWhiteSensitiveCharCount :: LexAction ()-resetWhiteSensitiveCharCount = do-  ai <- getAlex-  putAlex $ ai { aiWhiteSensitiveCharCount = 0 }--setCaseSensitive :: LexAction ()-setCaseSensitive = do-  ai <- getAlex-  putAlex $ ai { aiCaseSensitive = True }--setCaseInsensitive :: LexAction ()-setCaseInsensitive = do-  ai <- getAlex-  putAlex $ ai { aiCaseSensitive = False }--enterFormat :: LexAction ()-enterFormat = do-  ai <- getAlex-  putAlex $ ai { aiInFormat = True }--exitFormat :: LexAction ()-exitFormat = do-  ai <- getAlex-  putAlex $ ai { aiInFormat = False }--instance Spanned Lexeme where-  getSpan lexeme =-    let ms = lexemeStart lexeme-        me = lexemeEnd lexeme in-      SrcSpan (fromJust ms) (fromJust me)-  setSpan _ = error "Lexeme span cannot be set."--updatePreviousToken :: Maybe Token -> LexAction ()-updatePreviousToken maybeToken = do-  ai <- getAlex-  putAlex $ ai { aiPreviousToken = maybeToken }--addToPreviousTokensInLine :: Token -> LexAction ()-addToPreviousTokensInLine token = do-  ai <- getAlex-  putAlex $-    case token of-      TNewline _ -> updatePrevTokens ai [ ]-      t -> updatePrevTokens ai $ t : aiPreviousTokensInLine ai-  where-    updatePrevTokens ai tokens = ai { aiPreviousTokensInLine = tokens }--checkPreviousTokensInLine :: (Token -> Bool) -> AlexInput -> Bool-checkPreviousTokensInLine prop ai = any prop $ aiPreviousTokensInLine ai--getLexemeSpan :: LexAction SrcSpan-getLexemeSpan = do-  lexeme <- getLexeme-  return $ getSpan lexeme---- Handle pragmas that begin with #-lexHash :: LexAction (Maybe Token)-lexHash = do-  lexLineWithWhitespace $ \ m -> do-    ai <- getAlex-    case words (drop 1 m) of-      -- 'line' pragma - rewrite the current line and filename-      "line":lineStr:_-        | Just line <- readInteger lineStr -> do-          let revdropWNQ = reverse . drop 1 . dropWhile (flip notElem "'\"")-          let file       = revdropWNQ . revdropWNQ $ m-          let lineOffs   = fromIntegral line - posLine (aiPosition ai) - 1-          let newP       = (aiPosition ai) { posPragmaOffset = Just (lineOffs, file)-                                           , posColumn = 1 }-          putAlex $ ai { aiPosition = newP }-      _ -> return ()-    return Nothing---- Lex comments with whitespace included-lexComment :: LexAction (Maybe Token)-lexComment =-  lexLineWithWhitespace $ \ m -> do-    s <- getLexemeSpan-    return . Just . TComment s $ tail m---- Get a line without losing the whitespace, then call continuation with it.-lexLineWithWhitespace :: (String -> LexAction (Maybe Token)) -> LexAction (Maybe Token)-lexLineWithWhitespace k = do-  alex <- getAlex-  let modifiedAlex = alex { aiWhiteSensitiveCharCount = 1 }-  case alexGetByte modifiedAlex of-    Just (w, newAlex)-      | fromIntegral w /= ord '\n' -> putAlex newAlex >> lexLineWithWhitespace k-    _                              -> getMatch >>= k-------------------------------------------------------{--     Chars-      +-+-      | |-      | |-      | v-      +-+  Nothing  +-+-+---> |0|---------->+3|-  +-> +++           +-+-  |    |-' |    | '-  |    v-  |   +++  Nothing  +-+-  +---|1|----------->2|-      +++           +++-       |             ^-       +-------------+-            Chars--}-strAutomaton :: Char -> Int -> LexAction (Maybe Token)-strAutomaton c 0 = do-  setCaseSensitive-  incWhiteSensitiveCharCount-  alex <- getAlex-  case alexGetByte alex of-    Just (_, newAlex) -> do-      putAlex newAlex-      m <- getMatch-      if last m == c-      then strAutomaton c 1-      else strAutomaton c 0-    Nothing -> strAutomaton c 3-strAutomaton c 1 = do-  incWhiteSensitiveCharCount-  alex <- getAlex-  case alexGetByte alex of-    Just (_, newAlex) -> do-      let m = lexemeMatch . aiLexeme $ newAlex-      if head m == c-      then do-        putAlex newAlex-        putMatch $ reverse . tail $ m-        strAutomaton c 0-      else strAutomaton c 2-    Nothing -> strAutomaton c 2-strAutomaton _ 2 = do-  s <- getLexemeSpan-  m <- getMatch-  resetWhiteSensitiveCharCount-  setCaseInsensitive-  return $ Just $ TString s $ (init . tail) m-strAutomaton _ _ = fail "Unmatched string."--lexHollerith :: LexAction (Maybe Token)-lexHollerith = do-  match' <- getMatch-  let len = read $ init match' -- Get n of "nH" from string-  putMatch ""-  ai <- getAlex-  putAlex $ ai { aiWhiteSensitiveCharCount = len }-  lexed <- lexN len-  s <- getLexemeSpan-  return $ do-    hollerith <- lexed-    return $ THollerith s hollerith--lexN :: Int -> LexAction (Maybe String)-lexN n = do-  alex <- getAlex-  match' <- getMatch-  let len = length match'-  if n == len-  then return $ Just match'-  else-    case alexGetByte alex of-      Just (w, _) | fromIntegral w == ord '\n' -> do-        return . Just $! pad match'-      Just (_, newAlex) -> do-        putAlex newAlex-        lexN n-      Nothing -> return Nothing- where-  pad s = s ++ replicate (n - length s) ' '--maybeToKeyword :: LexAction (Maybe Token)-maybeToKeyword = do-  decPar-  pcActual' <- pcActual . psParanthesesCount <$> get-  if pcActual' == 0-  then toSC keyword-  else return Nothing--typeSCChange :: LexAction (Maybe Token)-typeSCChange = do-  ps <- get-  let hypotheticalPs = ps { psAlexInput = (psAlexInput ps) { aiStartCode = keyword } }-  let isFunction = case unParse (lexer f) hypotheticalPs of { ParseOk True _ -> True; _ -> False }-  if isFunction-  then return Nothing-  else toSC st-  where-    f TFunction{} = return True-      -- can be part of function type declaration-    f TLeftPar{} = lexer f-    f TRightPar{} = lexer f-    f TStar{} = lexer f-    f TInt{} = lexer f-    f _ = return False--toSC :: Int -> LexAction (Maybe Token)-toSC startCode = do-  ai <- getAlex-  if startCode == 0-  then putAlex $ ai { aiStartCode = startCode, aiWhiteSensitiveCharCount = 6 }-  else putAlex $ ai { aiStartCode = startCode }-  return Nothing------------------------------------------------------------------------------------- Tokens-----------------------------------------------------------------------------------data Token = TLeftPar             SrcSpan-           | TRightPar            SrcSpan-           | TLeftArrayPar        SrcSpan-           | TRightArrayPar       SrcSpan-           | TComma               SrcSpan-           | TDot                 SrcSpan-           | TPercent             SrcSpan-           | TColon               SrcSpan-           | TInclude             SrcSpan-           | TProgram             SrcSpan-           | TFunction            SrcSpan-           | TSubroutine          SrcSpan-           | TBlockData           SrcSpan-           | TStructure           SrcSpan-           | TRecord              SrcSpan-           | TUnion               SrcSpan-           | TMap                 SrcSpan-           | TEndProgram          SrcSpan-           | TEndFunction         SrcSpan-           | TEndSubroutine       SrcSpan-           | TEndStructure        SrcSpan-           | TEndUnion            SrcSpan-           | TEndMap              SrcSpan-           | TEnd                 SrcSpan-           | TAssign              SrcSpan-           | TOpAssign            SrcSpan-           | TTo                  SrcSpan-           | TGoto                SrcSpan-           | TIf                  SrcSpan-           | TThen                SrcSpan-           | TElse                SrcSpan-           | TElsif               SrcSpan-           | TEndif               SrcSpan-           | TCall                SrcSpan-           | TReturn              SrcSpan-           | TSave                SrcSpan-           | TContinue            SrcSpan-           | TStop                SrcSpan-           | TCycle               SrcSpan-           | TExit                SrcSpan-           | TCase                SrcSpan-           | TCaseDefault         SrcSpan-           | TSelectCase          SrcSpan-           | TEndSelect           SrcSpan-           | TPause               SrcSpan-           | TDo                  SrcSpan-           | TDoWhile             SrcSpan-           | TWhile               SrcSpan-           | TEndDo               SrcSpan-           | TRead                SrcSpan-           | TWrite               SrcSpan-           | TRewind              SrcSpan-           | TBackspace           SrcSpan-           | TEndfile             SrcSpan-           | TInquire             SrcSpan-           | TOpen                SrcSpan-           | TClose               SrcSpan-           | TPrint               SrcSpan-           | TTypePrint           SrcSpan-           | TDimension           SrcSpan-           | TCommon              SrcSpan-           | TEquivalence         SrcSpan-           | TPointer             SrcSpan-           | TExternal            SrcSpan-           | TIntrinsic           SrcSpan-           | TType                SrcSpan String-           | TEntry               SrcSpan-           | TImplicit            SrcSpan-           | TNone                SrcSpan-           | TParameter           SrcSpan-           | TData                SrcSpan-           | TStatic              SrcSpan-           | TAutomatic           SrcSpan-           | TFormat              SrcSpan-           | TBlob                SrcSpan String-           | TInt                 SrcSpan String-           | TBozLiteral          SrcSpan Boz-           | TExponent            SrcSpan String-           | TBool                SrcSpan Bool-           | TOpPlus              SrcSpan-           | TOpMinus             SrcSpan-           | TOpExp               SrcSpan-           | TStar                SrcSpan-           | TSlash               SrcSpan-           | TAmpersand           SrcSpan-           | TOpOr                SrcSpan-           | TOpAnd               SrcSpan-           | TOpXOr               SrcSpan-           | TOpNot               SrcSpan-           | TOpEquivalent        SrcSpan-           | TOpNotEquivalent     SrcSpan-           | TOpLT                SrcSpan-           | TOpLE                SrcSpan-           | TOpEQ                SrcSpan-           | TOpNE                SrcSpan-           | TOpGT                SrcSpan-           | TOpGE                SrcSpan-           | TId                  SrcSpan String-           | TComment             SrcSpan String-           | TString              SrcSpan String-           | THollerith           SrcSpan String-           | TLabel               SrcSpan String-           | TNewline             SrcSpan-           | TEOF                 SrcSpan-           deriving (Show, Eq, Ord, Data, Typeable, Generic)--instance FirstParameter Token SrcSpan-instance FirstParameter Token SrcSpan => Spanned Token where-  getSpan a = getFirstParameter a-  setSpan e a = setFirstParameter e a--instance Tok Token where-  eofToken (TEOF _) = True-  eofToken _ = False------------------------------------------------------------------------------------- AlexInput & related definitions-----------------------------------------------------------------------------------data Lexeme = Lexeme-  { lexemeMatch :: String-  , lexemeStart :: Maybe Position-  , lexemeEnd   :: Maybe Position-  } deriving (Show)--initLexeme :: Lexeme-initLexeme = Lexeme-  { lexemeMatch = ""-  , lexemeStart = Nothing-  , lexemeEnd   = Nothing }--data AlexInput = AlexInput-  { aiSourceBytes               :: B.ByteString-  , aiEndOffset                 :: Int-  , aiPosition                  :: Position-  , aiBytes                     :: [Word8]-  , aiPreviousChar              :: Char-  , aiLexeme                    :: Lexeme-  , aiWhiteSensitiveCharCount   :: Int-  , aiStartCode                 :: Int-  , aiPreviousToken             :: Maybe Token-  , aiPreviousTokensInLine      :: [ Token ]-  , aiCaseSensitive             :: Bool-  , aiInFormat                  :: Bool-  , aiFortranVersion            :: FortranVersion-  } deriving (Show)--instance Loc AlexInput where-  getPos = aiPosition--instance LastToken AlexInput Token where-  getLastToken = aiPreviousToken--type LexAction a = Parse AlexInput Token a--vanillaAlexInput :: AlexInput-vanillaAlexInput = AlexInput-  { aiSourceBytes = B.empty-  , aiEndOffset = 0-  , aiPosition = initPosition-  , aiBytes = []-  , aiPreviousChar = '\n'-  , aiLexeme = initLexeme-  , aiWhiteSensitiveCharCount = 6-  , aiStartCode = 0-  , aiPreviousToken = Nothing-  , aiPreviousTokensInLine = [ ]-  , aiCaseSensitive = False-  , aiInFormat = False-  , aiFortranVersion = Fortran77-  }--updateLexeme :: Maybe Char -> Position -> AlexInput -> AlexInput-updateLexeme maybeChar p ai =-  let lexeme = aiLexeme ai-      match = lexemeMatch lexeme-      newMatch =-        case maybeChar of-          Just c -> c : match-          Nothing -> match-      start = lexemeStart lexeme-                 -- skipping should not start a new lexeme-      newStart = if isNothing start && isJust maybeChar then Just p else start-      newEnd = Just p in-    ai { aiLexeme = Lexeme newMatch newStart newEnd }------------------------------------------------------------------------------------- Definitions needed for alexScanUser-----------------------------------------------------------------------------------data Move = Continuation | Char | Newline | NewlineComment | Comment--alexGetByte :: AlexInput -> Maybe (Word8, AlexInput)-alexGetByte ai-  -- The process of reading individual bytes of the character-  | _bytes /= [] = Just (head _bytes, ai { aiBytes = tail _bytes })-  -- When all characters are already read-  | posAbsoluteOffset _position == aiEndOffset ai = Nothing-  -- Skip the continuation line altogether-  | isContinuation ai && _isWhiteInsensitive = skip Continuation ai-  -- Skip the newline before a comment-  | aiFortranVersion ai == Fortran77Legacy && _isWhiteInsensitive-  && isNewlineCommentsFollowedByContinuation ai = skip NewlineComment ai-  -- If we are not parsing a Hollerith skip whitespace-  | _curChar `elem` [ ' ', '\t' ] && _isWhiteInsensitive = skip Char ai-  -- Ignore inline comments-  | aiFortranVersion ai == Fortran77Legacy &&-    _isWhiteInsensitive && not _inFormat && _curChar == '!' = skip Comment ai-  -- Ignore comments after column 72 in fortran77-  | aiFortranVersion ai == Fortran77Legacy && posColumn _position > 72 && _curChar /= '\n'-  = skip Comment ai-  -- Read genuine character and advance. Also covers white sensitivity.-  | otherwise =-      let (_b:_bs) = utf8Encode _curChar in-        Just(_b, updateLexeme (Just _curChar) _position-          ai {-            aiPosition =-              case _curChar of-                '\n'  -> advance Newline ai-                _     -> advance Char ai,-            aiBytes = _bs,-            aiPreviousChar = _curChar,-            aiWhiteSensitiveCharCount =-              if _isWhiteInsensitive-              then 0-              else aiWhiteSensitiveCharCount ai - 1-          })-  where-    _curChar = (if aiCaseSensitive ai then id else toLower) $ currentChar ai-    _bytes = aiBytes ai-    _position = aiPosition ai-    _isWhiteInsensitive = aiWhiteSensitiveCharCount ai == 0-    _inFormat = aiInFormat ai--alexInputPrevChar :: AlexInput -> Char-alexInputPrevChar ai = aiPreviousChar ai--takeNChars :: Integer -> AlexInput -> String-takeNChars n ai =-  B.unpack . B.take (fromIntegral n) . B.drop (fromIntegral _dropN) $ aiSourceBytes ai-  where-    _dropN = posAbsoluteOffset . aiPosition $ ai--currentChar :: AlexInput -> Char-currentChar ai = B.index (aiSourceBytes ai) (fromIntegral . posAbsoluteOffset . aiPosition $ ai)--lookBack :: Int -> AlexInput -> Char-lookBack n ai = B.index (aiSourceBytes ai) (fromIntegral . subtract n . posAbsoluteOffset . aiPosition $ ai)--isContinuation :: AlexInput -> Bool-isContinuation ai =-  take 6 _next7 == "\n     " && not (last _next7 `elem` [' ', '0', '\n', '\r'])-  where-    _next7 = takeNChars 7 ai--isNewlineComment :: AlexInput -> Bool-isNewlineComment ai =-  _next1 == "\n" && isCommentLine ai p-  where-    _next1 = takeNChars 1 ai-    p = (aiPosition ai) { posAbsoluteOffset = posAbsoluteOffset (aiPosition ai) + 1 }--isNewlineCommentsFollowedByContinuation :: AlexInput -> Bool-isNewlineCommentsFollowedByContinuation ai-  | isNewlineComment ai-  = isNewlineCommentsFollowedByContinuation (ai { aiPosition = advance NewlineComment ai })-  | isContinuation ai = True-  | otherwise = False--skip :: Move -> AlexInput -> Maybe (Word8, AlexInput)-skip move ai =-  let _newPosition = advance move ai in-    alexGetByte $ updateLexeme Nothing _newPosition $ ai { aiPosition = _newPosition }--advance :: Move -> AlexInput -> Position-advance move ai =-  case move of-    Char ->-      position { posAbsoluteOffset = _absl + 1, posColumn = _col + 1 }-    Continuation ->-      position { posAbsoluteOffset = _absl + 7, posColumn = 7, posLine = _line + 1 }-    Newline ->-      position { posAbsoluteOffset = _absl + 1, posColumn = 1, posLine = _line + 1 }-    NewlineComment ->-      skipComment ai-        position { posAbsoluteOffset = _absl + 1, posColumn = 1, posLine = _line + 1 }-    Comment ->-      skipComment ai position-  where-    position = aiPosition ai-    _col = posColumn position-    _line = posLine position-    _absl = posAbsoluteOffset position--skipComment :: AlexInput -> Position -> Position-skipComment ai p =-  p { posAbsoluteOffset = posAbsoluteOffset p + length line-    , posColumn = posColumn p + length line-    }-  where-  line = takeLine p ai--skipCommentLines :: AlexInput -> Position -> Position-skipCommentLines ai p = go p p-  where-  go p' p''-    -- eof is not a comment line-    | not (null line)-    , isCommentLine ai p''-    = go p'' p''{ posAbsoluteOffset = posAbsoluteOffset p'' + length line + 1 -- skip the newline-            , posColumn = 1, posLine = posLine p'' + 1-            }-    | isContinuation ai'-    = advance Continuation ai'-    | otherwise-      -- after skipping comment lines, place cursor right at the last newline-    = p2-    where-    line = takeLine p'' ai-    line' = takeLine p' ai-    p2 = p' { posAbsoluteOffset = posAbsoluteOffset p' + length line'-            , posColumn = length line' + 1-            }-    ai' = ai { aiPosition = p2 }--isCommentLine :: AlexInput -> Position -> Bool-isCommentLine ai p-      -- eof is not a comment line-    | posAbsoluteOffset p == aiEndOffset ai-    = False-    | map toLower (take 1 line) `elem` ["c", "d", "!", "*"]-      || all (`elem` " \t") line-      || head (dropWhile (`elem` " \t") line) == '!'-    = True-    | otherwise-    = False-    where-    line = takeLine p ai--takeLine :: Position -> AlexInput -> String-takeLine p ai =-  B.unpack . B.takeWhile (/='\n') . B.drop (fromIntegral _dropN) $ aiSourceBytes ai-  where-    _dropN = posAbsoluteOffset p--utf8Encode :: Char -> [Word8]-utf8Encode = map fromIntegral . _go . ord-  where-    _go oc-      | oc <= 0x7f   = [oc]-      | oc <= 0x7ff  = [ 0xc0 + (oc `Data.Bits.shiftR` 6)-                       , 0x80 + oc Data.Bits..&. 0x3f-                       ]-      | oc <= 0xffff = [ 0xe0 + (oc `Data.Bits.shiftR` 12)-                       , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)-                       , 0x80 + oc Data.Bits..&. 0x3f-                       ]-      | otherwise    = [ 0xf0 + (oc `Data.Bits.shiftR` 18)-                       , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f)-                       , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)-                       , 0x80 + oc Data.Bits..&. 0x3f-                       ]------------------------------------------------------------------------------------- Lexer definition-----------------------------------------------------------------------------------lexer :: (Token -> LexAction a) -> LexAction a-lexer cont = cont =<< lexer'--lexer' :: LexAction Token-lexer' = do-  resetLexeme-  alexInput <- getAlex-  let startCode = aiStartCode alexInput-  version <- getVersion-  case alexScanUser version alexInput startCode of-    AlexEOF -> return $ TEOF $ SrcSpan (getPos alexInput) (getPos alexInput)-    AlexError _ -> do-      parseState <- get-      fail $ psFilename parseState ++ ": lexing failed. "-    AlexSkip newAlex _ -> putAlex newAlex >> lexer'-    AlexToken newAlex _ action -> do-      putAlex newAlex-      maybeToken <- action-      case maybeToken of-        Just token -> do-          updatePreviousToken maybeToken-          addToPreviousTokensInLine token-          return token-        Nothing -> lexer'--alexScanUser :: FortranVersion -> AlexInput -> Int -> AlexReturn (LexAction (Maybe Token))------------------------------------------------------------------------------------- Functions to help testing & output-----------------------------------------------------------------------------------initParseState :: B.ByteString -> FortranVersion -> String -> ParseState AlexInput-initParseState srcBytes fortranVersion filename =-  _vanillaParseState { psAlexInput = _vanillaAlexInput }-  where-    _vanillaParseState = ParseState-      { psAlexInput = undefined-      , psVersion = fortranVersion-      , psFilename = filename-      , psParanthesesCount = ParanthesesCount 0 False-      , psContext = [ ConStart ] }-    _vanillaAlexInput = vanillaAlexInput-      { aiSourceBytes = srcBytes-      , aiEndOffset   = fromIntegral $ B.length srcBytes-      , aiFortranVersion = fortranVersion-      , aiPosition = initPosition {filePath = filename} }--collectFixedTokens :: FortranVersion -> B.ByteString -> [Token]-collectFixedTokens version srcInput =-    collectTokens lexer' $ initParseState srcInput version "<unknown>"--collectFixedTokensSafe :: FortranVersion -> B.ByteString -> Maybe [Token]-collectFixedTokensSafe version srcInput =-    collectTokensSafe lexer' $ initParseState srcInput version "<unknown>"--}

@@ -1,19 +0,0 @@-module Language.Fortran.Lexer.FixedForm.Utils where--import           Language.Fortran.Lexer.FixedForm-import           Language.Fortran.AST-import           Language.Fortran.AST.RealLit-import           Language.Fortran.Util.Position--makeReal :: Maybe Token -> Maybe Token -> Maybe Token -> Maybe (SrcSpan, String) -> Expression A0-makeReal i1 dot i2 expr =-  let span1   = getSpan (i1, dot, i2)-      span2   = case expr of-                  Just e -> getTransSpan span1 (fst e)-                  Nothing -> span1-      i1Str   = case i1 of { Just (TInt _ s) -> s ; _ -> "" }-      dotStr  = case dot of { Just (TDot _) -> "." ; _ -> "" }-      i2Str   = case i2 of { Just (TInt _ s) -> s ; _ -> "" }-      exprStr  = case expr of { Just (_, s) -> s ; _ -> "" }-      litStr  = i1Str ++ dotStr ++ i2Str ++ exprStr-   in ExpValue () span2 $ ValReal (parseRealLit litStr) Nothing

@@ -1,1395 +0,0 @@--- -*- Mode: Haskell -*--{-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE DeriveGeneric #-}--module Language.Fortran.Lexer.FreeForm where--import Prelude hiding (span)-import Data.Data-import Data.Maybe (fromMaybe)-import Data.List (foldl')-import Data.Char (toLower)-import Data.Word (Word8)-import qualified Data.ByteString.Char8 as B--import Control.Monad (join)-import Control.Monad.State (get)--import GHC.Generics--import Language.Fortran.ParserMonad---import Language.Fortran.Version (required when ParserMonad stops exporting it)-import Language.Fortran.Util.Position-import Language.Fortran.Util.FirstParameter-import Language.Fortran.Parser.Utils (readInteger)-import Language.Fortran.AST.RealLit (RealLit, parseRealLit)-import Language.Fortran.AST.Boz--}--$digit      = 0-9-$bit        = 0-1-$octalDigit = 0-7-$hexDigit   = [a-f $digit]--$letter = a-z-$alphanumeric = [$letter $digit \_]--$hash = [\#]--@label = $digit{1,5}-@name = $letter $alphanumeric*--@binary = b\'$bit+\'-@octal  = o\'$octalDigit+\'-@hex    = z\'$hexDigit+\'--@digitString = $digit+-@kindParam = (@digitString|@name)-@bozLiteralConst = (@binary|@octal|@hex)---- Real literals-$expLetter = [ed]-@exponent = [\-\+]? @digitString-@significand = @digitString? \. @digitString-@realLiteral = @significand ($expLetter @exponent)?-             | @digitString $expLetter @exponent-             -- The following complements @altRealLiteral . The reason it is-             -- included in the general case is to reduce the number of-             -- semantic predicates to be made while lexing.-             | @digitString \. $expLetter @exponent-@altRealLiteral = @digitString \.--@characterLiteralBeg = (@kindParam \_)? (\'|\")------------------------------------------------------------------------------------- Start codes | Explanation------------------------------------------------------------------------------------ 0           | For statement starters--- scI         | For statements that can come after logical IF--- scC         | To be used in lexCharacter, it only appears to force Happy to---             | resolve it.--- scT         | For types--- scN         | For everything else----------------------------------------------------------------------------------tokens :---<0> "/*"                                          { skipCComment }-<0,scN> "!".*$                                    { adjustComment $ addSpanAndMatch TComment }--<0> $hash.*$                                      { lexHash }--<0,scN,scT> (\n\r|\r\n|\n)                        { resetPar >> toSC 0 >> addSpan TNewline }-<0,scN,scI,scT> [\t\ ]+                           ;--<scN> "("                                         { leftPar }-<scN> ")" / { ifConditionEndP }                   { decPar >> toSC scI >> addSpan TRightPar }-<scN> ")"                                         { decPar >> addSpan TRightPar }-<scN> "(/" / { notDefinedOperP }                  { addSpan TLeftInitPar }-<scN> "/)" / { notDefinedOperP }                  { addSpan TRightInitPar }-<scN> "[" / { notDefinedOperP }                   { addSpan TLeftInitPar }-<scN> "]" / { notDefinedOperP }                   { addSpan TRightInitPar }-<scN> ","                                         { comma }-<scN> ";"                                         { resetPar >> toSC 0 >> addSpan TSemiColon }-<scN> ":"                                         { addSpan TColon }-<scN> "::"                                        { addSpan TDoubleColon }-<scN> "="                                         { addSpan TOpAssign}-<scN> "=>"                                        { addSpan TArrow }-<scN> "%"                                         { addSpan TPercent }--<0,scI> @name / { partOfExpOrPointerAssignmentP } { addSpanAndMatch TId }-<0> @name / { constructNameP }                    { addSpanAndMatch TId }---- Program units-<0> "program"                                     { addSpan TProgram }-<0> "end"\ *"program"                             { addSpan TEndProgram }-<0> "function"                                    { addSpan TFunction }-<scN> "function" / { typeSpecP }                  { addSpan TFunction }-<0> "end"\ *"function"                            { addSpan TEndFunction }-<scN> "result" / { resultP }                      { addSpan TResult }-<0> "pure"                                        { toSC 0 >> addSpan TPure }-<0> "elemental"                                   { toSC 0 >> addSpan TElemental }-<0> "recursive"                                   { toSC 0 >> addSpan TRecursive }-<scN> "pure" / { typeSpecP }                      { toSC 0 >> addSpan TPure }-<scN> "elemental" / { typeSpecP }                 { toSC 0 >> addSpan TElemental }-<scN> "recursive" / { typeSpecP }                 { toSC 0 >> addSpan TRecursive }-<0> "subroutine"                                  { addSpan TSubroutine }-<0> "end"\ *"subroutine"                          { addSpan TEndSubroutine }-<0> "block"\ *"data"                              { addSpan TBlockData }-<0> "end"\ *"block"\ *"data"                      { addSpan TEndBlockData }-<0> "module"                                      { addSpan TModule }-<0> "end"\ *"module"                              { addSpan TEndModule }-<0> "contains"                                    { addSpan TContains }-<0> "use"                                         { addSpan TUse }-<scN> "only" / { useStP }                         { addSpan TOnly }-<0> "import"                                      { addSpan TImport }-<0> "abstract"                                    { addSpan TAbstract }-<0> "interface"                                   { addSpan TInterface }-<scN> "interface" / { genericSpecP }              { addSpan TInterface }-<0> "end"\ *"interface"                           { addSpan TEndInterface }-<0> "procedure"                                   { addSpan TProcedure }-<0> "module"\ \ *"procedure"                      { addSpan TModuleProcedure }-<scN> "assignment"\ *"("\ *"="\ *")" / { genericSpecP } { addSpan TAssignment }-<scN> "operator" / { genericSpecP }               { addSpan TOperator }-<0,scI> "call"                                    { addSpan TCall }-<0,scI> "return"                                  { addSpan TReturn }-<0> "entry"                                       { addSpan TEntry }-<0> "include"                                     { addSpan TInclude }---- Type def related-<0,scT> "type"                                    { addSpan TType }-<scN> "type" / { allocateP }                      { addSpan TType }-<0> "end"\ *"type"                                { addSpan TEndType }-<scN> "class" / { followsProcedureP }             { addSpan TClass }-<0> "sequence"                                    { addSpan TSequence }-<0> "enum"                                        { addSpan TEnum }-<0> "end"\ *"enum"                                { addSpan TEndEnum }-<0> "enumerator"                                  { addSpan TEnumerator }---- Intrinsic types-<0,scT> "integer"                                 { addSpan TInteger }-<scN> "integer" / { allocateP }                   { addSpan TInteger }-<0,scT> "real"                                    { addSpan TReal }-<scN> "real" / { allocateP }                      { addSpan TReal }-<0,scT> "double"\ *"precision"                    { addSpan TDoublePrecision }-<scN> "double"\ *"precision" / { allocateP }      { addSpan TDoublePrecision }-<0,scT> "logical"                                 { addSpan TLogical }-<scN> "logical" / { allocateP }                   { addSpan TLogical }-<0,scT> "character"                               { addSpan TCharacter }-<scN> "character" / { allocateP }                 { addSpan TCharacter }-<0,scT> "complex"                                 { addSpan TComplex }-<scN> "complex" / { allocateP }                   { addSpan TComplex }--<scN> "kind" / { selectorP }                      { addSpan TKind }-<scN> "len" / { selectorP }                       { addSpan TLen }---- Attributes-<0> "public"                                      { addSpan TPublic }-<scN> "public" / { attributeP }                   { addSpan TPublic }-<0> "private"                                     { addSpan TPrivate }-<scN> "private" / { attributeP }                  { addSpan TPrivate }-<0> "protected"                                   { addSpan TProtected }-<scN> "protected" / { attributeP }                { addSpan TProtected }-<0> "parameter"                                   { addSpan TParameter }-<scN> "parameter" / { attributeP }                { addSpan TParameter }-<0> "allocatable"                                 { addSpan TAllocatable }-<scN> "allocatable" / { attributeP }              { addSpan TAllocatable }-<0> "asynchronous"                                { addSpan TAsynchronous }-<scN> "asynchronous" / { attributeP }             { addSpan TAsynchronous }-<0> "dimension"                                   { addSpan TDimension }-<scN> "dimension" / { attributeP }                { addSpan TDimension }-<0> "external"                                    { addSpan TExternal }-<scN> "external" / { attributeP }                 { addSpan TExternal }-<0> "intent"                                      { addSpan TIntent }-<scN> "intent" / { attributeP }                   { addSpan TIntent }-<0> "intrinsic"                                   { addSpan TIntrinsic }-<scN> "intrinsic" / { attributeP }                { addSpan TIntrinsic }-<0> "non_intrinsic"                               { addSpan TNonIntrinsic }-<scN> "non_intrinsic" / { attributeP }            { addSpan TNonIntrinsic }-<0> "optional"                                    { addSpan TOptional }-<scN> "optional" / { attributeP }                 { addSpan TOptional }-<0> "pointer"                                     { addSpan TPointer }-<scN> "pointer" / { attributeP }                  { addSpan TPointer }-<0> "save"                                        { addSpan TSave }-<scN> "save" / { attributeP }                     { addSpan TSave }-<0> "target"                                      { addSpan TTarget }-<scN> "target" / { attributeP }                   { addSpan TTarget }-<0> "save"                                        { addSpan TSave }-<scN> "save" / { attributeP }                     { addSpan TSave }-<0> "value"                                       { addSpan TValue }-<scN> "value" / { attributeP }                    { addSpan TValue }-<0> "volatile"                                    { addSpan TVolatile }-<scN> "volatile" / { attributeP }                 { addSpan TVolatile }---- Attribute values-<scN> "in"\ *"out" / { followsIntentP }           { addSpan TInOut }-<scN> "in" / { followsIntentP }                   { addSpan TIn }-<scN> "out" / { followsIntentP }                  { addSpan TOut }---- language-binding-spec-<scN> "bind" / { bindP }                          { addSpan TBind }-<scN> "name" / { followsCP }                      { addSpan TName }-<scN> "c" / { followsBindP }                      { addSpan TC }---- Control flow-<0> "do"                                          { addSpan TDo }-<scN> "do" / { followsColonP }                    { addSpan TDo }-<0> "end"\ *"do"                                  { addSpan TEndDo }-<scN> "while" / { followsDoWithOptLabelP }        { addSpan TWhile }-<0> "if"                                          { addSpan TIf }-<scN> "if" / { followsColonP }                    { addSpan TIf }-<scI> "then"                                      { addSpan TThen }-<0> "else"                                        { addSpan TElse }-<0> "else"\ *"if"                                 { addSpan TElsif }-<0> "end"\ *"if"                                  { addSpan TEndIf }-<0> "select"\ *"case"                             { addSpan TSelectCase }-<scN> "select"\ *"case" / { followsColonP }       { addSpan TSelectCase }-<0> "case"                                        { addSpan TCase }-<0> "end"\ *"select"                              { addSpan TEndSelect }-<scN> "default" / { caseStP }                     { addSpan TDefault }-<0,scI> "cycle"                                   { addSpan TCycle }-<0,scI> "exit"                                    { addSpan TExit }-<0,scI> "go"\ *"to"                               { addSpan TGoto }-<0,scI> "assign"                                  { addSpan TAssign }-<scN> "to" / { assignStP }                        { addSpan TTo }-<0,scI> "continue"                                { addSpan TContinue }-<0,scI> "stop"                                    { addSpan TStop }-<0,scI> "pause"                                   { addSpan TPause }-<0> "forall"                                      { addSpan TForall }-<0> "end"\ *"forall"                              { addSpan TEndForall }-<0> "associate"                                   { addSpan TAssociate }-<scN> "associate" / { followsColonP }             { addSpan TAssociate }-<0> "end"\ *"associate"                           { addSpan TEndAssociate }----- Where construct-<0,scI> "where"                                   { addSpan TWhere }-<scN> "where" / { labelledWhereP }                { addSpan TWhere }-<0> "elsewhere"                                   { addSpan TElsewhere }-<0> "else"\ *"where"                              { addSpan TElsewhere }-<0> "end"\ *"where"                               { addSpan TEndWhere }---- Beginning keyword-<0> "data"                                        { addSpan TData }-<0,scI> "allocate"                                { addSpan TAllocate }-<scN> "stat" / { allocateP }                      { addSpan TStat }-<scN> "errmsg" / { allocateP }                    { addSpan TErrMsg }-<scN> "source" / { allocateP }                    { addSpan TSource }-<0,scI> "deallocate"                              { addSpan TDeallocate }-<0,scI> "nullify"                                 { addSpan TNullify }-<0> "namelist"                                    { addSpan TNamelist }-<0> "implicit"                                    { toSC scT >> addSpan TImplicit }-<0> "equivalence"                                 { addSpan TEquivalence }-<0> "common"                                      { addSpan TCommon }-<0> "end"                                         { addSpan TEnd }--<scT> "none"                                      { addSpan TNone }---- I/O-<0,scI> "open"                                    { addSpan TOpen }-<0,scI> "close"                                   { addSpan TClose }-<0,scI> "read"                                    { addSpan TRead }-<0,scI> "write"                                   { addSpan TWrite }-<0,scI> "print"                                   { addSpan TPrint }-<0,scI> "backspace"                               { addSpan TBackspace }-<0,scI> "rewind"                                  { addSpan TRewind }-<0,scI> "inquire"                                 { addSpan TInquire }-<0,scI> "end"\ *"file"                            { addSpan TEndfile }-<0> "flush"                                       { addSpan TFlush }-<scN> "unit" / { followsFlushP }                  { addSpan TUnit }-<scN> "iostat" / { followsFlushP }                { addSpan TIOStat }-<scN> "iomsg" / { followsFlushP }                 { addSpan TIOMsg }-<scN> "err" / { followsFlushP }                   { addSpan TErr }---- Format-<0> "format"                                      { addSpan TFormat }-<scN> "(".*")" / { formatP }                      { addSpanAndMatch TBlob }---- Literals-<scN> "_"                                         { addSpan TUnderscore }-<0> @label                                        { toSC 0 >> addSpanAndMatch TIntegerLiteral }-<scN,scI> @digitString                            { addSpanAndMatch TIntegerLiteral }-<scN> @bozLiteralConst                            { addSpanAndMatch $ \ss s -> TBozLiteral ss (parseBoz s) }--<scN> @realLiteral                                { addSpanAndMatch $ \ss s -> TRealLiteral ss (parseRealLit s) }-<scN> @altRealLiteral / { notPrecedingDotP }      { addSpanAndMatch $ \ss s -> TRealLiteral ss (parseRealLit s) }--<scN,scC> @characterLiteralBeg                    { lexCharacter }--<scN> ".true."  { addSpan (\s -> TLogicalLiteral s True)  }-<scN> ".false." { addSpan (\s -> TLogicalLiteral s False) }---- Operators-<scN> ("."$letter+"."|"**"|\*|\/|\+|\-) / { opP } { addSpanAndMatch TOpCustom }-<scN> "**"                                        { addSpan TOpExp }-<scN> "+"                                         { addSpan TOpPlus }-<scN> "-"                                         { addSpan TOpMinus }-<scN> "*"                                         { addSpan TStar }-<scN> "/"                                         { slashOrDivision }-<scN> ".or."                                      { addSpan TOpOr }-<scN> ".and."                                     { addSpan TOpAnd }-<scN> ".not."                                     { addSpan TOpNot }-<scN> ".eqv."                                     { addSpan TOpEquivalent }-<scN> ".neqv."                                    { addSpan TOpNotEquivalent }-<scN> (".eq."|"==")                               { addSpan TOpEQ }-<scN> (".ne."|"/=")                               { addSpan TOpNE }-<scN> (".lt."|"<")                                { addSpan TOpLT }-<scN> (".le."|"<=")                               { addSpan TOpLE }-<scN> (".gt."|">")                                { addSpan TOpGT }-<scN> (".ge."|">=")                               { addSpan TOpGE }-<scN> "." $letter+ "."                            { addSpanAndMatch TOpCustom }--<scN> @name                                       { addSpanAndMatch TId }--{------------------------------------------------------------------------------------- Predicated lexer helpers-----------------------------------------------------------------------------------formatP :: User -> AlexInput -> Int -> AlexInput -> Bool-formatP _ _ _ ai-  | Just TFormat{} <- aiPreviousToken ai = True-  | otherwise = False--followsDoWithOptLabelP :: User -> AlexInput -> Int -> AlexInput -> Bool-followsDoWithOptLabelP _ _ _ ai-  -- DO ...-  | Just TDo {} <- aiPreviousToken ai        = True--  -- DO 10 ...-  | TDo{}:TIntegerLiteral{}:[] <- prevTokens = True--  | otherwise = False-  where-    prevTokens = reverse . aiPreviousTokensInLine $ ai--followsColonP :: User -> AlexInput -> Int -> AlexInput -> Bool-followsColonP _ _ _ ai-  | Just TColon{} <- aiPreviousToken ai = True-  | otherwise = False--labelledWhereP :: User -> AlexInput -> Int -> AlexInput -> Bool-labelledWhereP _ _ _ ai-  | TId{}:TColon{}:[] <- prevTokens = True-  | otherwise                       = False-  where-    prevTokens = reverse . aiPreviousTokensInLine $ ai--selectorP :: User -> AlexInput -> Int -> AlexInput -> Bool-selectorP user _ _ ai =-    followsType && nextTokenIsOpAssign && precedesDoubleColon ai-  where-    nextTokenIsOpAssign = nextTokenConstr user ai == (Just . fillConstr $ TOpAssign)-    followsType =-      case searchBeforePar (aiPreviousTokensInLine ai) of-        Just x -> isTypeSpec x-        Nothing -> False-    searchBeforePar [] = Nothing-    searchBeforePar (x:xs)-      | TLeftPar{} <- x = if null xs then Nothing else (Just $ head xs)-      | otherwise = searchBeforePar xs--ifConditionEndP :: User -> AlexInput -> Int -> AlexInput -> Bool-ifConditionEndP (User _ pc) _ _ ai-    | (TIf{}:_) <- prevTokens = pc == ParanthesesCount 1 False-    | (TIntegerLiteral{}:TIf{}:_) <- prevTokens = pc == ParanthesesCount 1 False-    | (TId{}:TColon{}:TIf{}:_) <- prevTokens = pc == ParanthesesCount 1 False-    | (TElsif{}:_) <- prevTokens = pc == ParanthesesCount 1 False-    | otherwise = False-  where-    prevTokens = reverse . aiPreviousTokensInLine $ ai--opP :: User -> AlexInput -> Int ->AlexInput -> Bool-opP _ _ _ ai-  | (TLeftPar{}:TOperator{}:_) <- aiPreviousTokensInLine ai = True-  | otherwise = False--partOfExpOrPointerAssignmentP :: User -> AlexInput -> Int -> AlexInput -> Bool-partOfExpOrPointerAssignmentP (User fv pc) _ _ ai =-    case unParse (lexer $ f False (0::Integer)) ps of-      ParseOk True _ -> True-      _ -> False-  where-    ps = ParseState-      { psAlexInput = ai { aiStartCode = StartCode scN Return }-      , psVersion = fv-      , psFilename = "<unknown>"-      , psParanthesesCount = pc-      , psContext = [ ConStart ] }-    f leftParSeen parCount token-      | not leftParSeen =-        case token of-          TNewline{} -> return False-          TSemiColon{} -> return False-          TEOF{} -> return False-          TPercent{} -> return True-          TArrow{} -> return True-          TOpAssign{} -> return True-          TLeftPar{} -> lexer $ f True 1-          TLeftPar2{} -> lexer $ f True 1-          _ -> return False-      | parCount == 0 =-        case token of-          TOpAssign{} -> return True-          TArrow{} -> return True-          TPercent{} -> return True-          TLeftPar{} -> lexer $ f True 1-          TLeftPar2{} -> lexer $ f True 1-          _ -> return False-      | parCount > 0 =-        case token of-          TNewline{} -> return False-          TSemiColon{} -> return False-          TEOF{} -> return False-          TLeftPar{} -> lexer $ f True (parCount + 1)-          TLeftPar2{} -> lexer $ f True (parCount + 1)-          TRightPar{} -> lexer $ f True (parCount - 1)-          _ -> lexer $ f True parCount-      | otherwise =-        error "Error while executing part of expression assignment predicate."--precedesDoubleColon :: AlexInput -> Bool-precedesDoubleColon ai = not . flip seenConstr ai . fillConstr $ TDoubleColon--parenLevel :: [Token] -> Int-parenLevel = foldl' f 0-  where-    f n tok | fillConstr TLeftPar == toConstr tok  = n + 1-            | fillConstr TRightPar == toConstr tok = n - 1-            | otherwise                            = n--allocateP :: User -> AlexInput -> Int -> AlexInput -> Bool-allocateP _ _ _ ai-  | alloc:lpar:rest <- prevTokens-  , toConstr alloc `elem` [fillConstr TAllocate, fillConstr TDeallocate]-  , fillConstr TLeftPar  == toConstr lpar-  = null rest || (followsComma && parenLevel prevTokens == 1)-  | otherwise = False-  where-    prevTokens = reverse . aiPreviousTokensInLine $ ai-    followsComma-      | Just TComma{} <- aiPreviousToken ai = True-      | otherwise = False--attributeP :: User -> AlexInput -> Int -> AlexInput -> Bool-attributeP _ _ _ ai = followsComma && precedesDoubleColon ai && lineStartOK-  where-    followsComma-      | Just TComma{} <- aiPreviousToken ai = True-      | otherwise = False--    lineStartOK-      -- matches e.g.: TYPE (FOO), ATTR-      | typ:lpar:_:rpar:com:_ <- prevTokens-      , toConstr typ `elem` [fillConstr TType, fillConstr TClass]-      , toConstr lpar == fillConstr TLeftPar-      , toConstr rpar == fillConstr TRightPar-      = fillConstr TComma == toConstr com--      -- matches e.g.: TYPE FOO, ATTR-      | typ:com:_ <- prevTokens-      , toConstr typ == fillConstr TType-      = fillConstr TComma == toConstr com--      -- matches e.g.: INTEGER (KIND=...), ATTR-      -- or: PROCEDURE (...), ATTR-      | tok:lpar:rest <- prevTokens-      , isTypeSpec tok || fillConstr TProcedure == toConstr tok-      , fillConstr TLeftPar == toConstr lpar-      , (_, _:com:_) <- break ((fillConstr TRightPar ==) . toConstr) rest-      = fillConstr TComma == toConstr com--      -- matches e.g.: INTEGER*NUM, ATTR-      | tok:star:num:com:_ <- prevTokens-      , isTypeSpec tok-      , fillConstr TStar == toConstr star-      , TIntegerLiteral{} <- num-      = fillConstr TComma == toConstr com--      -- matches e.g.: INTEGER, ATTR-      -- or: USE, ATTR-      | tok:com:_ <- prevTokens-      , isTypeSpec tok || fillConstr TUse == toConstr tok-      = fillConstr TComma == toConstr com--      | otherwise = False--    prevTokens = reverse . aiPreviousTokensInLine $ ai--bindP :: User -> AlexInput -> Int -> AlexInput -> Bool-bindP _ _ _ ai = (followsRightPar && isFunSub) || (followsComma && isProcEnum)-  where-    followsComma-      | Just TComma{} <- aiPreviousToken ai = True-      | otherwise = False-    followsRightPar-      | Just TRightPar{} <- aiPreviousToken ai = True-      | otherwise = False-    isFunSub = flip any prevTokens $ \ token ->-      fillConstr TFunction == toConstr token ||-      fillConstr TSubroutine == toConstr token-    isProcEnum = flip any prevTokens $ \ token ->-      fillConstr TProcedure == toConstr token ||-      fillConstr TEnum == toConstr token-    prevTokens = reverse . aiPreviousTokensInLine $ ai--constructNameP :: User -> AlexInput -> Int -> AlexInput -> Bool-constructNameP user _ _ ai =-  case nextTokenConstr user ai of-    Just constr -> constr == fillConstr TColon-    _ -> False--genericSpecP :: User -> AlexInput -> Int -> AlexInput -> Bool-genericSpecP _ _ _ ai = Just True == do-  constr <- prevTokenConstr ai-  if constr `elem` fmap fillConstr [ TAbstract, TInterface, TPublic, TPrivate, TProtected ]-  then return True-  else if constr `elem` fmap fillConstr [ TComma, TDoubleColon, TColon ]-  then return $ seenConstr (fillConstr TPublic) ai ||-                seenConstr (fillConstr TPrivate) ai ||-                seenConstr (fillConstr TProtected) ai ||-                seenConstr (fillConstr TOnly) ai-  else Nothing--notDefinedOperP :: User -> AlexInput -> Int -> AlexInput -> Bool-notDefinedOperP _ _ _ ai-  | prevToken:_ <- prevTokens-  , fillConstr TOperator == toConstr prevToken  = False-  | prevToken:prevToken':_ <- prevTokens-  , fillConstr TLeftPar  == toConstr prevToken-  , fillConstr TOperator == toConstr prevToken' = False-  | otherwise                                   = True-  where-    prevTokens = aiPreviousTokensInLine ai--typeSpecP :: User -> AlexInput -> Int -> AlexInput -> Bool-typeSpecP _ _ _ ai-  | (prevToken:_) <- prevTokens-  , isTypeSpec prevToken = True-  | otherwise = isTypeSpecImmediatelyBefore $ reverse prevTokens-  where-    isTypeSpecImmediatelyBefore tokens@(_:xs)-      | isTypeSpec tokens = True-      | otherwise = isTypeSpecImmediatelyBefore xs-    isTypeSpecImmediatelyBefore [] = False-    prevTokens = aiPreviousTokensInLine ai--resultP :: User -> AlexInput -> Int -> AlexInput -> Bool-resultP _ _ _ ai =-    (flip seenConstr ai . fillConstr $ TFunction) &&-    prevTokenConstr ai == (Just $ fillConstr TRightPar)--notPrecedingDotP :: User -> AlexInput -> Int -> AlexInput -> Bool-notPrecedingDotP user _ _ ai = not $-  nextTokenConstr user ai == (Just $ toConstr (TId undefined undefined))--followsIntentP :: User -> AlexInput -> Int -> AlexInput -> Bool-followsIntentP _ _ _ ai =-  (map toConstr . take 2 . aiPreviousTokensInLine) ai ==-  map fillConstr [ TLeftPar, TIntent ]--followsProcedureP :: User -> AlexInput -> Int -> AlexInput -> Bool-followsProcedureP _ _ _ ai =-  (map toConstr . take 2 . aiPreviousTokensInLine) ai ==-  map fillConstr [ TLeftPar, TProcedure ]--followsBindP :: User -> AlexInput -> Int -> AlexInput -> Bool-followsBindP _ _ _ ai =-  (map toConstr . take 2 . aiPreviousTokensInLine) ai ==-  map fillConstr [ TLeftPar, TBind ]--followsCP :: User -> AlexInput -> Int -> AlexInput -> Bool-followsCP _ _ _ ai =-  (map toConstr . take 2 . aiPreviousTokensInLine) ai ==-  map fillConstr [ TComma, TC ]--followsFlushP :: User -> AlexInput -> Int -> AlexInput -> Bool-followsFlushP _ _ _ ai = not (null toks) && fillConstr TFlush == toConstr (last toks)-  where toks = aiPreviousTokensInLine ai--useStP :: User -> AlexInput -> Int -> AlexInput -> Bool-useStP _ _ _ ai = seenConstr (toConstr $ TUse undefined) ai--caseStP :: User -> AlexInput -> Int -> AlexInput -> Bool-caseStP _ _ _ ai = prevTokenConstr ai == (Just $ fillConstr TCase)--assignStP :: User -> AlexInput -> Int -> AlexInput -> Bool-assignStP _ _ _ ai = seenConstr (fillConstr TAssign) ai--prevTokenConstr :: AlexInput -> Maybe Constr-prevTokenConstr ai = toConstr <$> aiPreviousToken ai--nextTokenConstr :: User -> AlexInput -> Maybe Constr-nextTokenConstr (User fv pc) ai =-    case unParse lexer' parseState of-      ParseOk token _ -> Just $ toConstr token-      _ -> Nothing-  where-    parseState = ParseState-      { psAlexInput = ai-      , psParanthesesCount = pc-      , psVersion = fv-      , psFilename = "<unknown>"-      , psContext = [ ConStart ] }--seenConstr :: Constr -> AlexInput -> Bool-seenConstr candidateConstr ai =-  candidateConstr `elem` (toConstr <$> aiPreviousTokensInLine ai)--fillConstr = toConstr . ($ undefined)------------------------------------------------------------------------------------- Lexer helpers-----------------------------------------------------------------------------------adjustComment :: LexAction (Maybe Token) -> LexAction (Maybe Token)-adjustComment action = do-  mTok <- action-  case mTok of-    Just (TComment s (_:xs)) -> return $ Just $ TComment s xs-    _ -> error "Either not a comment token or matched empty."--leftPar :: LexAction (Maybe Token)-leftPar = do-    incPar-    context <- topContext-    if context == ConImplicit-      then do-        parseState <- get-        case unParse f parseState of-          ParseOk tokenCons _ -> do-            span <- getLexemeSpan-            return $ Just $ tokenCons span-          ParseFailed _ -> fail "Left parantheses is not matched."-      else addSpan TLeftPar-  where-    f :: LexAction (SrcSpan -> Token)-    f = do-      (ParanthesesCount pc _) <- getParanthesesCount-      mPrevToken <- aiPreviousToken <$> getAlex-      case mPrevToken of-        Just TRightPar{} | pc == 0 -> do-          _ <- getLexemeSpan-          curToken <- lexer'-          case curToken of-            TComma{} -> return TLeftPar2-            TNewline{} -> return TLeftPar2-            TSemiColon{} -> return TLeftPar2-            TEOF{} -> return TLeftPar2-            _ -> return TLeftPar-        _ -> lexer' >> f--comma :: LexAction (Maybe Token)-comma = do-  context <- topContext-  case context of-    ConImplicit -> do-      mToken <- aiPreviousToken <$> getAlex-      case mToken of-        Just TRightPar{} -> toSC scT >> addSpan TComma-        _ -> addSpan TComma-    ConNamelist -> secondCommaIfSlashFollows-    ConCommon -> secondCommaIfSlashFollows-    _ -> addSpan TComma-  where-    secondCommaIfSlashFollows = do-      parseState <- get-      case unParse lexer' parseState of-        ParseOk TOpDivision{} _ -> addSpan TComma2-        ParseFailed _ -> fail "Expecting variable name or slash."-        _ -> addSpan TComma--slashOrDivision :: LexAction (Maybe Token)-slashOrDivision = do-  context <- topContext-  case context of-    ConData -> addSpan TSlash-    _ -> addSpan TOpDivision--addSpan :: (SrcSpan -> Token) -> LexAction (Maybe Token)-addSpan cons = do-  s <- getLexemeSpan-  return $ Just $ cons s--addSpanAndMatch :: (SrcSpan -> String -> Token) -> LexAction (Maybe Token)-addSpanAndMatch cons = do-  s <- getLexemeSpan-  m <- getMatch-  return $ Just $ cons s m--getLexeme :: LexAction Lexeme-getLexeme = do-  ai <- getAlex-  return $ aiLexeme ai--putLexeme :: Lexeme -> LexAction ()-putLexeme lexeme = do-  ai <- getAlex-  putAlex $ ai { aiLexeme = lexeme }--resetLexeme :: LexAction ()-resetLexeme = putLexeme initLexeme--getMatch :: LexAction String-getMatch = do-  lexeme <- getLexeme-  return $ (reverse . lexemeMatch) lexeme--putMatch :: String -> LexAction ()-putMatch newMatch = do-  lexeme <- getLexeme-  putLexeme $ lexeme { lexemeMatch = reverse newMatch }--instance Spanned Lexeme where-  getSpan lexeme = SrcSpan (lexemeStart lexeme) (lexemeEnd lexeme)-  setSpan _ = error "Lexeme span cannot be set."--updatePreviousToken :: Maybe Token -> LexAction ()-updatePreviousToken maybeToken = do-  ai <- getAlex-  putAlex $ ai { aiPreviousToken = maybeToken }--addToPreviousTokensInLine :: Token -> LexAction ()-addToPreviousTokensInLine token = do-  ai <- getAlex-  putAlex $-    case token of-      TNewline _ -> updatePrevTokens ai [ ]-      TSemiColon _ -> updatePrevTokens ai [ ]-      t -> updatePrevTokens ai $ t : aiPreviousTokensInLine ai-  where-    updatePrevTokens ai tokens = ai { aiPreviousTokensInLine = tokens }--checkPreviousTokensInLine :: (Token -> Bool) -> AlexInput -> Bool-checkPreviousTokensInLine prop ai = any prop $ aiPreviousTokensInLine ai--getLexemeSpan :: LexAction SrcSpan-getLexemeSpan = do-  lexeme <- getLexeme-  return $ getSpan lexeme---- Automata for character literal parsing is given below. Wherever it says '--- you can replace ", whichever is used depends on what the first matched--- character is and they are dual in their nature.------      else---       +-+---       | v---       +-+  Nothing  +-+--- +---> |0|---------->|3|---   +-> +-+           +-+---   |    |--- ' |    | '---   |    v---   |   +-+  Nothing  +-+---   +---|1|---------->|2|---       +-+           +-+---        |             ^---        +-------------+---             else------ For more information please refer to Fortran 90 standard's section related--- to character constants.-lexCharacter :: LexAction (Maybe Token)-lexCharacter = do-    alex <- getAlex-    putAlex $ alex { aiStartCode = StartCode scC Stable }-    match <- getMatch-    let boundaryMarker = last match-    _lexChar (0::Integer) boundaryMarker-  where-    _lexChar 0 bm = do-      alex <- getAlex-      case alexGetByte alex of-        Just (_, newAlex) -> do-          putAlex newAlex-          m <- getMatch-          if last m == bm-          then _lexChar 1 bm-          else _lexChar 0 bm-        Nothing -> fail "Unmatched character literal."-    _lexChar 1 bm = do-      alex <- getAlex-      case alexGetByte alex of-        Just (_, newAlex) -> do-          let m = lexemeMatch . aiLexeme $ newAlex-          if head m == bm-          then do-            putAlex newAlex-            putMatch . reverse . tail $ m-            _lexChar 0 bm-          else _lexChar 2 bm-        Nothing -> _lexChar 2 bm-    _lexChar 2 _ = do-      alex <- getAlex-      putAlex $ alex { aiStartCode = StartCode scN Return }-      match <- getMatch-      putMatch . init . tail $ match-      addSpanAndMatch TString-    _lexChar _ _ = do fail "unhandled lexCharacter"--toSC :: Int -> LexAction ()-toSC startCode = do-  alex <- getAlex-  putAlex $ alex { aiStartCode = StartCode startCode Return }--stabiliseStartCode :: LexAction ()-stabiliseStartCode = do-  alex <- getAlex-  let sc = aiStartCode alex-  putAlex $ alex { aiStartCode = sc { scStatus = Stable } }--normaliseStartCode :: LexAction ()-normaliseStartCode = do-  alex <- getAlex-  let startCode = aiStartCode alex-  case scStatus startCode of-    Return -> putAlex $ alex { aiStartCode = StartCode scN Stable }-    Stable -> return ()------------------------------------------------------------------------------------- AlexInput & related definitions-----------------------------------------------------------------------------------invalidPosition :: Position-invalidPosition = Position 0 0 0 "" Nothing--{-# INLINE isValidPosition #-}-isValidPosition :: Position -> Bool-isValidPosition pos = posLine pos > 0--data Lexeme = Lexeme-  { lexemeMatch :: !String-  , lexemeStart :: {-# UNPACK #-} !Position-  , lexemeEnd   :: {-# UNPACK #-} !Position-  , lexemeIsCmt :: !Bool-  } deriving (Show)--initLexeme :: Lexeme-initLexeme = Lexeme-  { lexemeMatch = ""-  , lexemeStart = invalidPosition-  , lexemeEnd   = invalidPosition-  , lexemeIsCmt = False }--data StartCodeStatus = Return | Stable deriving (Show)--data StartCode = StartCode-  { scActual :: {-# UNPACK #-} !Int-  , scStatus :: !StartCodeStatus }-  deriving (Show)--data AlexInput = AlexInput-  { aiSourceBytes               :: !B.ByteString-  , aiPosition                  :: {-# UNPACK #-} !Position-  , aiEndOffset                 :: {-# UNPACK #-} !Int-  , aiPreviousChar              :: {-# UNPACK #-} !Char-  , aiLexeme                    :: {-# UNPACK #-} !Lexeme-  , aiStartCode                 :: {-# UNPACK #-} !StartCode-  , aiPreviousToken             :: !(Maybe Token)-  , aiPreviousTokensInLine      :: !([ Token ])-  } deriving (Show)--instance Loc AlexInput where-  getPos = aiPosition--instance LastToken AlexInput Token where-  getLastToken = aiPreviousToken--type LexAction a = Parse AlexInput Token a--vanillaAlexInput :: AlexInput-vanillaAlexInput = AlexInput-  { aiSourceBytes          = B.empty-  , aiPosition             = initPosition-  , aiEndOffset            = 0-  , aiPreviousChar         = '\n'-  , aiLexeme               = initLexeme-  , aiStartCode            = StartCode 0 Return-  , aiPreviousToken        = Nothing-  , aiPreviousTokensInLine = [ ] }--updateLexeme :: Char -> Position -> AlexInput -> AlexInput-updateLexeme !char !p !ai = ai { aiLexeme = Lexeme (char:match) start' p isCmt' }-  where-    Lexeme match start _ isCmt = aiLexeme ai-    start'                     = if isValidPosition start then start else p-    isCmt'                     = isCmt || (null match && char == '!')---- Fortran version and parantheses count to be used by alexScanUser-data User = User FortranVersion ParanthesesCount------------------------------------------------------------------------------------- Definitions needed for alexScanUser-----------------------------------------------------------------------------------data Move = Continuation | Char | Newline--alexGetByte :: AlexInput -> Maybe (Word8, AlexInput)-alexGetByte !ai-  -- When all characters are already read-  | posAbsoluteOffset _position == aiEndOffset ai = Nothing-  -- Skip the continuation line altogether-  | isContinuation ai = alexGetByte . skipContinuation $ ai-  -- Read genuine character and advance. Also covers white sensitivity.-  | otherwise =-      Just ( fromIntegral . fromEnum $ _curChar-           , updateLexeme _curChar _position-               ai-               { aiPosition =-                   case _curChar of-                     '\n'  -> advance Newline _position-                     _     -> advance Char _position-               , aiPreviousChar = _curChar })-  where-    _curChar = currentChar ai-    _position = aiPosition ai--alexInputPrevChar :: AlexInput -> Char-alexInputPrevChar ai = aiPreviousChar ai--currentChar :: AlexInput -> Char-currentChar !ai-  -- case sensitivity matters only in character literals-  | sCode == scC              = _currentChar-  | 'A' <= _currentChar &&-     _currentChar <= 'Z'      = {-# SCC toLower_currentChar #-} toLower _currentChar-  | otherwise                 = _currentChar-  where-    sCode        = scActual (aiStartCode ai)-    -- _currentChar = w2c (BU.unsafeIndex srcBytes i)-    _currentChar = B.index srcBytes absOff-    srcBytes     = aiSourceBytes ai-    absOff       = posAbsoluteOffset pos-    pos          = aiPosition ai--advanceWithoutContinuation :: AlexInput -> Maybe AlexInput-advanceWithoutContinuation !ai-  -- When all characters are already read-  | posAbsoluteOffset _position == aiEndOffset ai =-    Nothing-  -- Read genuine character and advance. Also covers white sensitivity.-  | otherwise =-    Just $! ai { aiPosition =-                  case _curChar of-                    '\n'  -> advance Newline _position-                    _     -> advance Char _position-               , aiPreviousChar = _curChar }-  where-    _curChar = currentChar ai-    _position = aiPosition ai--isContinuation :: AlexInput -> Bool-isContinuation !ai =-    -- No continuation while lexing a character literal.-    (scActual . aiStartCode) ai /= scC-    -- No continuation while lexing a comment.-    && (null match || not (lexemeIsCmt lexeme))-    && _isContinuation ai (0::Integer)-  where-    match  = lexemeMatch lexeme-    lexeme = aiLexeme $ ai-    _isContinuation !ai' 0 =-      if currentChar ai' == '&'-      then _advance ai'-      else False-    _isContinuation !ai' 1 =-      case currentChar ai' of-        ' ' -> _advance ai'-        '\t' -> _advance ai'-        '\r' -> _advance ai'-        '!' -> True-        '\n' -> True-        _ -> False-    _isContinuation _ _ = False-    _advance :: AlexInput -> Bool-    _advance !ai' =-      case advanceWithoutContinuation ai' of-        Just ai'' -> _isContinuation ai'' (1::Integer)-        Nothing -> False---- Here's the skip continuation automaton:------              white     white,\n---               +-+        +-+---               | v        | v        +---+---     +-+   &   +-+   \n   +-+   &    |---|--- +-->|0|------>|1|------->|3|------->||4||---     +-+       +-+        +-+----+   |---|---                |          ^     |   +---+---                |!         |     |---                v          |     |else---            +->+-+         |     v---        else|  |2|---------+   +---+---            +--+-+             |---|---                               ||5||---                               |---|---                               +---+------ For more information refer to Fortran 90 standard.--- This version is more permissive than the specification--- as it allows empty lines to be used between continuations.-skipContinuation :: AlexInput -> AlexInput-skipContinuation ai' = _skipCont ai' (0::Integer)-  where-    _skipCont ai 0 =-      if currentChar ai == '&'-      then _advance ai 1-      else error "This case is excluded by isContinuation."-    _skipCont ai 1 =-      let _curChar = currentChar ai in-        if _curChar `elem` [' ', '\t', '\r']-        then _advance ai 1-        else if _curChar == '!'-        then _advance ai 2-        else if _curChar == '\n'-        then _advance ai 3-        else-          error $-            join [ "Did not expect non-blank/non-comment character after "-                 , "continuation symbol (&)." ]-    _skipCont ai 2 =-      if currentChar ai == '\n'-      then _advance ai 3-      else _advance ai 2-    _skipCont ai 3 =-      let _curChar = currentChar ai in-        if _curChar `elem` [' ', '\t', '\r', '\n']-        then _advance ai 3-        else if _curChar == '!'-        then _advance ai 2-        else if _curChar == '&'-        -- This state accepts as if there were no spaces between the broken-        -- line and whatever comes after second &. This is implicitly state (4)-        then fromMaybe (error "File has ended prematurely during a continuation.")-                       (advanceWithoutContinuation ai)-        -- This state accepts but the broken line delimits the previous token.-        -- This is implicitly state (5). To achieve this, it returns the-        -- previous ai, which either has whitespace or newline, so it will-        -- nicely delimit.-        else ai-    _skipCont _ _ = error "unhandled _skipCont in skipContinuation"-    _advance ai state =-      case advanceWithoutContinuation ai of-        Just ai'' -> _skipCont ai'' state-        Nothing -> error "File has ended prematurely during a continuation."---- skip a C comment (read until first "*/")-skipCComment :: LexAction (Maybe Token)-skipCComment = do-  let loop (Just ai) 0 | currentChar ai == '*' = loop (advanceWithoutContinuation ai) 1-                       | otherwise             = loop (advanceWithoutContinuation ai) 0-      loop (Just ai) 1 | currentChar ai == '/' = ai `fromMaybe` advanceWithoutContinuation ai-                       | otherwise             = loop (advanceWithoutContinuation ai) 0-      loop _ _                                 = error "File has ended prematurely during a C comment."-  ai <- getAlex-  putAlex $ loop (Just ai) (0 :: Int)-  return Nothing--advance :: Move -> Position -> Position-advance move position =-  case move of-    Newline ->-      position-        { posAbsoluteOffset = _absl + 1 , posColumn = 1 , posLine = _line + 1 }-    Char ->-      position { posAbsoluteOffset = _absl + 1 , posColumn = _col + 1 }--- for now just return the original position-    _ -> position { posAbsoluteOffset = _absl, posColumn = _col }-  where-    _col = posColumn position-    _line = posLine position-    _absl = posAbsoluteOffset position---- Handle pragmas that begin with #-lexHash :: LexAction (Maybe Token)-lexHash = do-  ai <- getAlex-  m <- getMatch-  case words (drop 1 m) of-    -- 'line' pragma - rewrite the current line and filename-    "line":lineStr:_-      | Just line <- readInteger lineStr -> do-        let revdropWNQ = reverse . drop 1 . dropWhile (flip notElem "'\"")-        let file       = revdropWNQ . revdropWNQ $ m-        let lineOffs   = fromIntegral line - posLine (aiPosition ai) - 1-        let newP       = (aiPosition ai) { posPragmaOffset = Just (lineOffs, file)-                                         , posColumn = 1 }-        putAlex $ ai { aiPosition = newP }-    _ -> return ()-  return Nothing------------------------------------------------------------------------------------- Lexer definition-----------------------------------------------------------------------------------lexer :: (Token -> LexAction a) -> LexAction a-lexer cont = cont =<< lexer'--lexer' :: LexAction Token-lexer' = do-  resetLexeme-  alex <- getAlex-  let startCode = scActual . aiStartCode $ alex-  normaliseStartCode-  newAlex' <- getAlex-  version <- getVersion-  paranthesesCount <- getParanthesesCount-  let user = User version paranthesesCount-  case alexScanUser user newAlex' startCode of-    AlexEOF -> return $ TEOF $ SrcSpan (getPos alex) (getPos alex)-    AlexError _ -> do-      parseState <- get-      fail $ psFilename parseState ++ ": lexing failed. "-#ifdef DEBUG-        ++ '\n' : show newAlex ++ "\n"-#endif-    AlexSkip newAlex _ -> do-      putAlex $ newAlex { aiStartCode = StartCode startCode Return }-      lexer'-    AlexToken newAlex _ action -> do-      putAlex newAlex-      maybeToken <- action-      case maybeToken of-        Just token -> do-          updatePreviousToken maybeToken-          addToPreviousTokensInLine token-          return token-        Nothing -> lexer'--alexScanUser :: User -> AlexInput -> Int -> AlexReturn (LexAction (Maybe Token))------------------------------------------------------------------------------------- Tokens-----------------------------------------------------------------------------------data Token =-    TId                 SrcSpan String-  | TComment            SrcSpan String-  | TString             SrcSpan String-  | TIntegerLiteral     SrcSpan String-  | TRealLiteral        SrcSpan RealLit-  | TBozLiteral         SrcSpan Boz-  | TComma              SrcSpan-  | TComma2             SrcSpan-  | TSemiColon          SrcSpan-  | TColon              SrcSpan-  | TDoubleColon        SrcSpan-  | TOpAssign           SrcSpan-  | TArrow              SrcSpan-  | TPercent            SrcSpan-  | TLeftPar            SrcSpan-  | TLeftPar2           SrcSpan-  | TRightPar           SrcSpan-  | TLeftInitPar        SrcSpan-  | TRightInitPar       SrcSpan-  -- Mainly operators-  | TOpCustom           SrcSpan String-  | TOpExp              SrcSpan-  | TOpPlus             SrcSpan-  | TOpMinus            SrcSpan-  | TStar               SrcSpan-  | TOpDivision         SrcSpan-  | TSlash              SrcSpan-  | TOpOr               SrcSpan-  | TOpAnd              SrcSpan-  | TOpNot              SrcSpan-  | TOpEquivalent       SrcSpan-  | TOpNotEquivalent    SrcSpan-  | TOpLT               SrcSpan-  | TOpLE               SrcSpan-  | TOpEQ               SrcSpan-  | TOpNE               SrcSpan-  | TOpGT               SrcSpan-  | TOpGE               SrcSpan-  | TLogicalLiteral     SrcSpan Bool-  | TUnderscore         SrcSpan-  -- Keywords-  -- Program unit related-  | TProgram            SrcSpan-  | TEndProgram         SrcSpan-  | TFunction           SrcSpan-  | TEndFunction        SrcSpan-  | TResult             SrcSpan-  | TPure               SrcSpan-  | TElemental          SrcSpan-  | TRecursive          SrcSpan-  | TSubroutine         SrcSpan-  | TEndSubroutine      SrcSpan-  | TBlockData          SrcSpan-  | TEndBlockData       SrcSpan-  | TModule             SrcSpan-  | TEndModule          SrcSpan-  | TContains           SrcSpan-  | TUse                SrcSpan-  | TOnly               SrcSpan-  | TImport             SrcSpan-  | TAbstract           SrcSpan-  | TInterface          SrcSpan-  | TEndInterface       SrcSpan-  | TProcedure          SrcSpan-  | TModuleProcedure    SrcSpan-  | TAssignment         SrcSpan-  | TOperator           SrcSpan-  | TCall               SrcSpan-  | TReturn             SrcSpan-  | TEntry              SrcSpan-  | TInclude            SrcSpan-  -- language-binding-spec-  | TBind               SrcSpan-  | TC                  SrcSpan-  | TName               SrcSpan-  -- Attributes-  | TAllocatable        SrcSpan-  | TAsynchronous       SrcSpan-  | TDimension          SrcSpan-  | TExternal           SrcSpan-  | TIntent             SrcSpan-  | TIntrinsic          SrcSpan-  | TNonIntrinsic       SrcSpan-  | TOptional           SrcSpan-  | TParameter          SrcSpan-  | TPointer            SrcSpan-  | TPrivate            SrcSpan-  | TPublic             SrcSpan-  | TProtected          SrcSpan-  | TSave               SrcSpan-  | TTarget             SrcSpan-  | TValue              SrcSpan-  | TVolatile           SrcSpan-  -- Attribute values-  | TIn                 SrcSpan-  | TOut                SrcSpan-  | TInOut              SrcSpan-  -- Beginning keyword-  | TData               SrcSpan-  | TNamelist           SrcSpan-  | TImplicit           SrcSpan-  | TEquivalence        SrcSpan-  | TCommon             SrcSpan-  | TFormat             SrcSpan-  | TBlob               SrcSpan String-  | TAllocate           SrcSpan-  | TStat               SrcSpan-  | TErrMsg             SrcSpan-  | TSource             SrcSpan-  | TDeallocate         SrcSpan-  | TNullify            SrcSpan-  -- Misc-  | TNone               SrcSpan-  -- Control flow-  | TGoto               SrcSpan-  | TAssign             SrcSpan-  | TTo                 SrcSpan-  | TContinue           SrcSpan-  | TStop               SrcSpan-  | TPause              SrcSpan-  | TDo                 SrcSpan-  | TEndDo              SrcSpan-  | TWhile              SrcSpan-  | TIf                 SrcSpan-  | TThen               SrcSpan-  | TElse               SrcSpan-  | TElsif              SrcSpan-  | TEndIf              SrcSpan-  | TCase               SrcSpan-  | TSelectCase         SrcSpan-  | TEndSelect          SrcSpan-  | TDefault            SrcSpan-  | TCycle              SrcSpan-  | TExit               SrcSpan-  | TForall             SrcSpan-  | TEndForall          SrcSpan-  | TAssociate          SrcSpan-  | TEndAssociate       SrcSpan-  -- Where construct-  | TWhere              SrcSpan-  | TElsewhere          SrcSpan-  | TEndWhere           SrcSpan-  -- Type related-  | TType               SrcSpan-  | TEndType            SrcSpan-  | TSequence           SrcSpan-  | TClass              SrcSpan-  | TEnum               SrcSpan-  | TEnumerator         SrcSpan-  | TEndEnum            SrcSpan-  -- Selector-  | TKind               SrcSpan-  | TLen                SrcSpan-  -- Intrinsic types-  | TInteger            SrcSpan-  | TReal               SrcSpan-  | TDoublePrecision    SrcSpan-  | TLogical            SrcSpan-  | TCharacter          SrcSpan-  | TComplex            SrcSpan-  -- I/O-  | TOpen               SrcSpan-  | TClose              SrcSpan-  | TRead               SrcSpan-  | TWrite              SrcSpan-  | TPrint              SrcSpan-  | TBackspace          SrcSpan-  | TRewind             SrcSpan-  | TInquire            SrcSpan-  | TEndfile            SrcSpan-  -- Etc.-  | TEnd                SrcSpan-  | TNewline            SrcSpan-  | TEOF                SrcSpan-  | TFlush              SrcSpan-  | TUnit               SrcSpan-  | TIOStat             SrcSpan-  | TIOMsg              SrcSpan-  | TErr                SrcSpan-  deriving (Eq, Show, Data, Typeable, Generic)--instance FirstParameter Token SrcSpan-instance FirstParameter Token SrcSpan => Spanned Token where-  getSpan = getFirstParameter-  setSpan = setFirstParameter--instance Tok Token where-  eofToken TEOF{} = True-  eofToken _ = False--class SpecifiesType a where-  isTypeSpec :: a -> Bool--instance SpecifiesType Token where-  isTypeSpec TInteger{} = True-  isTypeSpec TReal{} = True-  isTypeSpec TDoublePrecision{} = True-  isTypeSpec TLogical{} = True-  isTypeSpec TCharacter{} = True-  isTypeSpec TComplex{} = True-  isTypeSpec _ = False--instance SpecifiesType [ Token ] where-  isTypeSpec tokens-    | [ TType{}, TLeftPar{}, _, TRightPar{} ] <- tokens = True-    -- This is an approximation but should hold for almost all legal programs.-    | (typeToken:TLeftPar{}:rest) <- tokens =-      isTypeSpec typeToken &&-      case last rest of-        TRightPar{} -> True-        _ -> False-    | (TCharacter{}:TStar{}:rest) <- tokens =-      case rest of-        [ TIntegerLiteral{} ] -> True-        (TLeftPar{}:rest') | TRightPar{} <- last rest' -> True-        _ -> False-    | otherwise = False------------------------------------------------------------------------------------- Functions to help testing & output-----------------------------------------------------------------------------------initParseState :: B.ByteString -> FortranVersion -> String -> ParseState AlexInput-initParseState srcBytes fortranVersion filename =-  _vanillaParseState { psAlexInput = _vanillaAlexInput }-  where-    _vanillaParseState = ParseState-      { psAlexInput = undefined-      , psVersion = fortranVersion-      , psFilename = filename-      , psParanthesesCount = ParanthesesCount 0 False-      , psContext = [ ConStart ] }-    _vanillaAlexInput = vanillaAlexInput-      { aiSourceBytes = srcBytes-      , aiEndOffset   = B.length srcBytes-      , aiPosition    = initPosition {filePath = filename} }--collectFreeTokens :: FortranVersion -> B.ByteString -> [Token]-collectFreeTokens version srcInput =-    collectTokens lexer' $ initParseState srcInput version "<unknown>"--}

@@ -0,0 +1,338 @@+{-| Common interface to various Fortran parsers.++Each parser exports various Happy-generated functions. All export a top-level+'ProgramFile' parser. Most also export intermediate parsers e.g. for+'Statement's and 'Expression's. Fixed form and free form parsers use different+lexing schemes. And, due to headaches with Fortran's syntax, we usually want to+enforce some post-parse transformations.++This module provides a common wrapper over all that functionality. Internal+combinators are exposed to assist in manually configuring parsers.+-}++{-# LANGUAGE ScopedTypeVariables #-}++module Language.Fortran.Parser+  (+  -- * Main parsers (ProgramFile, with transformation)+    byVer, byVerWithMods+  , f66, f77, f77e, f77l, f90, f95, f2003++  -- * Main parsers without post-parse transformation+  , f66NoTransform, f77NoTransform, f77eNoTransform, f77lNoTransform+    , f90NoTransform, f95NoTransform, f2003NoTransform++  -- * Other parsers+  , f90Expr++  -- * Various combinators+  , transformAs, defaultTransformation+  , Parser, StateInit, ParserMaker, makeParser, makeParserFixed, makeParserFree+  , initParseStateFixed, initParseStateFree+  , initParseStateFixedExpr, initParseStateFreeExpr+  , parseUnsafe+  , collectTokensSafe, collectTokens++  -- * F77 with inlined includes+  -- $f77includes+  , f77lIncludes+  ) where++import Language.Fortran.AST+import Language.Fortran.Parser.Monad++import qualified Language.Fortran.Parser.Fixed.Fortran66  as F66+import qualified Language.Fortran.Parser.Fixed.Fortran77  as F77+import qualified Language.Fortran.Parser.Free.Fortran90   as F90+import qualified Language.Fortran.Parser.Free.Fortran95   as F95+import qualified Language.Fortran.Parser.Free.Fortran2003 as F2003+import qualified Language.Fortran.Parser.Fixed.Lexer as Fixed+import qualified Language.Fortran.Parser.Free.Lexer  as Free+import Language.Fortran.Version+import Language.Fortran.Util.Position+import Language.Fortran.Util.ModFile+import Language.Fortran.Transformation.Monad+import qualified Language.Fortran.Transformation.Grouping                 as Trans+import qualified Language.Fortran.Transformation.Disambiguation.Function  as Trans+import qualified Language.Fortran.Transformation.Disambiguation.Intrinsic as Trans++import qualified Data.ByteString.Char8 as B+import Data.Data++import Control.Monad.State+import qualified Data.Map as Map+import           Data.Map ( Map )+import Data.Generics.Uniplate.Operations ( descendBiM )+import Control.Exception ( throwIO )+import System.FilePath ( (</>) )+import System.Directory ( doesFileExist )++-- | Our common Fortran parser type takes a filename and input, and returns+--   either a normalized error (tokens are printed) or an untransformed+--   'ProgramFile'.+type Parser a = String -> B.ByteString -> Either ParseErrorSimple a++--------------------------------------------------------------------------------++byVer :: FortranVersion -> Parser (ProgramFile A0)+byVer = \case+  Fortran66         -> f66+  Fortran77         -> f77+  Fortran77Extended -> f77e+  Fortran77Legacy   -> f77l+  Fortran90         -> f90+  Fortran95         -> f95+  Fortran2003       -> f2003+  v                 -> error $  "Language.Fortran.Parser.byVer: "+                             <> "no parser available for requested version: "+                             <> show v++byVerWithMods :: ModFiles -> FortranVersion -> Parser (ProgramFile A0)+byVerWithMods mods = \case+  Fortran66         -> f66Mods mods+  Fortran77         -> f77Mods mods+  Fortran77Extended -> f77eMods mods+  Fortran77Legacy   -> f77lMods mods+  Fortran90         -> f90Mods mods+  Fortran95         -> f95Mods mods+  Fortran2003       -> f2003Mods mods+  v                 -> error $ "Language.Fortran.Parser.byVerWithMods: no parser available for requested version: " <> show v++f66, f77, f77e, f77l, f90, f95, f2003 :: Parser (ProgramFile A0)+f66   = f66Mods   []+f77   = f77Mods   []+f77e  = f77eMods  []+f77l  = f77lMods  []+f90   = f90Mods   []+f95   = f95Mods   []+f2003 = f2003Mods []++f66Mods, f77Mods, f77eMods, f77lMods, f90Mods, f95Mods, f2003Mods+    :: ModFiles -> Parser (ProgramFile A0)+f66Mods   = transformAs Fortran66         f66NoTransform+f77Mods   = transformAs Fortran77         f77NoTransform+f77eMods  = transformAs Fortran77Extended f77eNoTransform+f77lMods  = transformAs Fortran77Legacy   f77lNoTransform+f90Mods   = transformAs Fortran90         f90NoTransform+f95Mods   = transformAs Fortran95         f95NoTransform+f2003Mods = transformAs Fortran2003       f2003NoTransform++f66NoTransform, f77NoTransform, f77eNoTransform, f77lNoTransform,+  f90NoTransform, f95NoTransform, f2003NoTransform+    :: Parser (ProgramFile A0)+f66NoTransform   = makeParserFixed F66.programParser   Fortran66+f77NoTransform   = makeParserFixed F77.programParser   Fortran77+f77eNoTransform  = makeParserFixed F77.programParser   Fortran77Extended+f77lNoTransform  = makeParserFixed F77.programParser   Fortran77Legacy+f90NoTransform   = makeParserFree  F90.programParser   Fortran90+f95NoTransform   = makeParserFree  F95.programParser   Fortran95+f2003NoTransform = makeParserFree  F2003.programParser Fortran2003++f90Expr :: Parser (Expression A0)+f90Expr = makeParser initParseStateFreeExpr F90.expressionParser Fortran90++--------------------------------------------------------------------------------++transformAs+    :: Data a+    => FortranVersion -> Parser (ProgramFile a) -> ModFiles+    -> Parser (ProgramFile a)+transformAs fv p mods fn bs = do+    pf <- p fn bs+    let pf' = pfSetFilename fn pf+    return $ transform pf'+  where transform = runTransform (combinedTypeEnv mods)+                                 (combinedModuleMap mods)+                                 (defaultTransformation fv)++-- | The default post-parse AST transformation for each Fortran version.+--+-- Formed by composing transformations end-to-end.+--+-- Note that some transformations are noncommutative e.g. labeled DO grouping+-- must be done before block DO grouping.+defaultTransformation :: Data a => FortranVersion -> Transform a ()+defaultTransformation = \case+  Fortran66         -> sequence_ [ Trans.groupLabeledDo+                                 , Trans.disambiguateIntrinsic+                                 , Trans.disambiguateFunction ]+  Fortran77         -> defaultTransformation Fortran66+  Fortran77Legacy   -> sequence_ [ Trans.groupLabeledDo+                                 , Trans.groupDo+                                 , Trans.disambiguateIntrinsic+                                 , Trans.disambiguateFunction ]+  _ -> defaultTransformation Fortran77Legacy++--------------------------------------------------------------------------------++type StateInit s = String -> FortranVersion -> B.ByteString -> ParseState s+type ParserMaker ai tok a = Parse ai tok a -> FortranVersion -> Parser a++makeParser+    :: (Loc ai, LastToken ai tok, Show tok)+    => StateInit ai -> ParserMaker ai tok a+makeParser fInitState p fv fn = fromParseResult . runParse p . fInitState fn fv++makeParserFixed :: ParserMaker Fixed.AlexInput Fixed.Token a+makeParserFixed = makeParser initParseStateFixed++makeParserFree :: ParserMaker Free.AlexInput Free.Token a+makeParserFree = makeParser initParseStateFree++initParseStateFixed :: StateInit Fixed.AlexInput+initParseStateFixed fn fv bs = initParseState fn fv ai+  where ai = Fixed.vanillaAlexInput fn fv bs++initParseStateFree :: StateInit Free.AlexInput+initParseStateFree fn fv bs = initParseState fn fv ai+  where ai = Free.vanillaAlexInput fn bs++-- | Initialize free-form parser state with the lexer configured for standalone+--   expression parsing.+--+-- The free-form lexer needs a non-default start code for lexing standaloe+-- expressions.+initParseStateFreeExpr :: StateInit Free.AlexInput+initParseStateFreeExpr fn fv bs = st+  { psAlexInput = ai { Free.aiStartCode = Free.StartCode Free.scN Free.Return } }+  where+    ai = Free.vanillaAlexInput fn bs+    st = initParseStateFree fn fv bs++-- checked in generated file: 1=assn, 4=iif, 6=st+-- 6, 1, 4 seem best in order. Looks like 6 is correct.+-- TODO guesswork, relies on internal behaviour :/+initParseStateFixedExpr :: StateInit Fixed.AlexInput+initParseStateFixedExpr fn fv bs = st+  { psAlexInput = ai { Fixed.aiStartCode = 6+                     , Fixed.aiWhiteSensitiveCharCount = 0 } }+  where+    ai = Fixed.vanillaAlexInput fn fv bs+    st = initParseStateFixed fn fv bs++-- | Convenience wrapper to easily use a parser unsafely.+--+-- This throws a catchable runtime IO exception, which is used in the tests.+parseUnsafe :: Parser a -> B.ByteString -> a+parseUnsafe p bs =+    case p "<unknown>" bs of+      Left err -> throwIOError $  "Language.Fortran.Parser.parseUnsafe: "+                               <> "parse error: " <> show err+      Right a -> a++-- | Helper for preparing initial parser state for the different lexers.+initParseState :: FilePath -> FortranVersion -> ai -> ParseState ai+initParseState fn fv ai = ParseState+  { psAlexInput = ai+  , psVersion = fv+  , psFilename = fn+  , psParanthesesCount = ParanthesesCount 0 False+  , psContext = [ ConStart ] }++--------------------------------------------------------------------------------++{- $f77includes+The Fortran 77 parser can parse and inline includes at parse time. Parse errors+are thrown as IO exceptions.++Can be cleaned up and generalized to use for other parsers.+-}++f77lIncludes+    :: [FilePath] -> ModFiles -> String -> B.ByteString+    -> IO (ProgramFile A0)+f77lIncludes incs mods fn bs = do+    -- includes files have to end with 2 newlines (unknown why, parser related)+    case f77lNoTransform fn (B.snoc bs '\n') of+      Left e -> liftIO $ throwIO e+      Right pf -> do+        let pf' = pfSetFilename fn pf+        pf'' <- evalStateT (descendBiM (f77lIncludesInline incs []) pf') Map.empty+        let pf''' = runTransform (combinedTypeEnv mods)+                                 (combinedModuleMap mods)+                                 (defaultTransformation Fortran77Legacy)+                                 pf''+        return pf'''++f77lIncludesInner :: Parser [Block A0]+f77lIncludesInner = makeParserFixed F77.includesParser Fortran77Legacy++f77lIncludesInline+    :: [FilePath] -> [FilePath] -> Statement A0+    -> StateT (Map String [Block A0]) IO (Statement A0)+f77lIncludesInline dirs seen st = case st of+  StInclude a s e@(ExpValue _ _ (ValString path)) Nothing -> do+    if notElem path seen then do+      incMap <- get+      case Map.lookup path incMap of+        Just blocks' -> pure $ StInclude a s e (Just blocks')+        Nothing -> do+          (fullPath, inc) <- liftIO $ readInDirs dirs path+          case f77lIncludesInner fullPath inc of+            Right blocks -> do+              blocks' <- descendBiM (f77lIncludesInline dirs (path:seen)) blocks+              modify (Map.insert path blocks')+              return $ StInclude a s e (Just blocks')+            Left err -> liftIO $ throwIO err+    else return st+  _ -> return st++readInDirs :: [String] -> String -> IO (String, B.ByteString)+readInDirs [] f = fail $ "cannot find file: " ++ f+readInDirs (d:ds) f = do+  let path = d</>f+  b <- doesFileExist path+  if b then+    (path,) <$> B.readFile path+  else+    readInDirs ds f++--------------------------------------------------------------------------------++-------------------------------------------------------------------------------+-- Generic token collection and functions (inherited from ParserMonad)+-------------------------------------------------------------------------------++collectTokens+    :: forall a b+    .  (Loc b, Tok a, LastToken b a, Show a)+    => Parse b a a -> ParseState b -> [a]+collectTokens lexer initState =+    evalParse (_collectTokens initState) undefined+  where+    _collectTokens :: ParseState b -> Parse b a [a]+    _collectTokens st = do+      let (_token, _st) = runParseUnsafe lexer st+      if eofToken _token+      then return [_token]+      else do+        _tokens <- _collectTokens _st+        return $ _token:_tokens++collectTokensSafe+    :: forall a b+    .  (Loc b, Tok a, LastToken b a, Show a)+    => Parse b a a -> ParseState b -> Maybe [a]+collectTokensSafe lexer initState =+    evalParse (_collectTokens initState) undefined+  where+    _collectTokens :: ParseState b -> Parse b a (Maybe [a])+    _collectTokens st =+      case unParse lexer st of+        ParseOk _token _st ->+          if eofToken _token+          then return $ Just [_token]+          else do+            _mTokens <- _collectTokens _st+            case _mTokens of+              Just _tokens -> return $ Just $ _token:_tokens+              _ -> return Nothing+        _ -> return Nothing++fromParseResult :: (Show c) => ParseResult b c a -> Either ParseErrorSimple a+fromParseResult (ParseOk a _)     = Right a+fromParseResult (ParseFailed err) =+    Left ParseErrorSimple+      { errorPos = errPos err+      , errorFilename = errFilename err+      , errorMsg = errMsg err ++ "\n" ++ tokenMsg (errLastToken err)  }

@@ -1,86 +0,0 @@-{-# LANGUAGE LambdaCase #-}---- | = Note on these parsers------ Seperate parsers are provided for different Fortran versions. A few parsers--- are provided for each version, offering built-in defaults or allowing you to--- configure them yourself. They can be identified by their suffix:------   * @parser@: all defaults (without mod files, default transformations)---   * @parserWithModFiles@: select mod files, default transformations---   * @parserWithTransforms@: without mod files, select transformations---   * @parserWithModFilesWithTransforms@: select mod files, select transformations-----module Language.Fortran.Parser.Any where--import Language.Fortran.AST-import Language.Fortran.Util.ModFile-import Language.Fortran.Version (FortranVersion(..), deduceFortranVersion)-import Language.Fortran.ParserMonad (ParseErrorSimple(..), fromParseResult)--import Language.Fortran.Parser.Fortran66 ( fortran66Parser, fortran66ParserWithModFiles )-import Language.Fortran.Parser.Fortran77 ( fortran77Parser, fortran77ParserWithModFiles-                                         , extended77Parser, extended77ParserWithModFiles-                                         , legacy77Parser, legacy77ParserWithModFiles )-import Language.Fortran.Parser.Fortran90 ( fortran90Parser, fortran90ParserWithModFiles )-import Language.Fortran.Parser.Fortran95 ( fortran95Parser, fortran95ParserWithModFiles )-import Language.Fortran.Parser.Fortran2003 ( fortran2003Parser, fortran2003ParserWithModFiles )--import qualified Data.ByteString.Char8 as B--type Parser = B.ByteString -> String -> Either ParseErrorSimple (ProgramFile A0)-parserVersions :: FortranVersion -> Parser-parserVersions = \case-  Fortran66         -> fromParseResult `after` fortran66Parser-  Fortran77         -> fromParseResult `after` fortran77Parser-  Fortran77Extended -> fromParseResult `after` extended77Parser-  Fortran77Legacy   -> fromParseResult `after` legacy77Parser-  Fortran90         -> fromParseResult `after` fortran90Parser-  Fortran95         -> fromParseResult `after` fortran95Parser-  Fortran2003       -> fromParseResult `after` fortran2003Parser-  _                 -> error "no parser available for requested Fortran version"-  where-    after :: (b -> c) -> (t -> a -> b) -> t -> a -> c-    after g f x = g . f x--type ParserWithModFiles = ModFiles -> B.ByteString -> String -> Either ParseErrorSimple (ProgramFile A0)-parserWithModFilesVersions :: FortranVersion -> ParserWithModFiles-parserWithModFilesVersions = \case-  Fortran66         -> helper fortran66ParserWithModFiles-  Fortran77         -> helper fortran77ParserWithModFiles-  Fortran77Extended -> helper extended77ParserWithModFiles-  Fortran77Legacy   -> helper legacy77ParserWithModFiles-  Fortran90         -> helper fortran90ParserWithModFiles-  Fortran95         -> helper fortran95ParserWithModFiles-  Fortran2003       -> helper fortran2003ParserWithModFiles-  _                 -> error "no parser available for requested Fortran version"-  where-    helper parser m s = fromParseResult . parser m s---- | Deduce the type of parser from the filename and parse the--- contents of the file.-fortranParser :: Parser-fortranParser contents filename =-   let parserF = parserVersions (deduceFortranVersion filename)-    in parserF contents filename---- | Deduce the type of parser from the filename and parse the--- contents of the file, within the context of given "mod files".-fortranParserWithModFiles :: ParserWithModFiles-fortranParserWithModFiles mods contents filename =-   let parserF = parserWithModFilesVersions (deduceFortranVersion filename)-    in parserF mods contents filename---- | Given a FortranVersion, parse the contents of the file.-fortranParserWithVersion :: FortranVersion -> Parser-fortranParserWithVersion v contents filename =-   let parserF = parserVersions v-    in parserF contents filename---- | Given a FortranVersion, parse the contents of the file, within--- the context of given "mod files".-fortranParserWithModFilesAndVersion :: FortranVersion -> ParserWithModFiles-fortranParserWithModFilesAndVersion v mods contents filename =-   let parserF = parserWithModFilesVersions v-    in parserF mods contents filename

@@ -0,0 +1,465 @@+-- -*- Mode: Haskell -*-+-- vim: ft=haskell+{+module Language.Fortran.Parser.Fixed.Fortran66+  ( programParser+  , blockParser+  , statementParser+  , expressionParser+  ) where++import Language.Fortran.Version+import Language.Fortran.Util.Position+import Language.Fortran.Parser.Monad+import Language.Fortran.Parser.Fixed.Lexer+import Language.Fortran.Parser.Fixed.Utils+import Language.Fortran.AST+import Language.Fortran.AST.RealLit++import Prelude hiding ( EQ, LT, GT ) -- Same constructors exist in the AST++}++%name programParser    PROGRAM+%name blockParser      BLOCK+%name statementParser  STATEMENT+%name expressionParser EXPRESSION+%monad { LexAction }+%lexer { lexer } { TEOF _ }+%tokentype { Token }+%error { parseError }++%token+  '('                   { TLeftPar _ }+  ')'                   { TRightPar _ }+  ','                   { TComma _ }+  '.'                   { TDot _ }+  function              { TFunction _ }+  subroutine            { TSubroutine _ }+  blockData             { TBlockData _ }+  end                   { TEnd _ }+  '='                   { TOpAssign _ }+  assign                { TAssign _ }+  to                    { TTo _ }+  goto                  { TGoto _ }+  if                    { TIf _ }+  call                  { TCall _ }+  return                { TReturn _ }+  continue              { TContinue _ }+  stop                  { TStop _ }+  pause                 { TPause _ }+  do                    { TDo _ }+  read                  { TRead _ }+  write                 { TWrite _ }+  rewind                { TRewind _ }+  backspace             { TBackspace _ }+  endfile               { TEndfile _ }+  common                { TCommon _ }+  equivalence           { TEquivalence _ }+  external              { TExternal _ }+  dimension             { TDimension _ }+  integer               { TType _ "integer" }+  real                  { TType _ "real" }+  doublePrecision       { TType _ "doubleprecision" }+  logical               { TType _ "logical" }+  complex               { TType _ "complex" }+  data                  { TData _ }+  format                { TFormat _ }+  blob                  { TBlob _ _ }+  int                   { TInt _ _ }+  exponent              { TExponent _ _ }+  bool                  { TBool _ _ }+  '+'                   { TOpPlus _ }+  '-'                   { TOpMinus _ }+  '**'                  { TOpExp _ }+  '*'                   { TStar _ }+  '/'                   { TSlash _ }+  or                    { TOpOr _ }+  and                   { TOpAnd _ }+  not                   { TOpNot _ }+  '<'                   { TOpLT _ }+  '<='                  { TOpLE _ }+  '>'                   { TOpGT _ }+  '>='                  { TOpGE _ }+  '=='                  { TOpEQ _ }+  '!='                  { TOpNE _ }+  id                    { TId _ _ }+  comment               { TComment _ _ }+  hollerith             { THollerith _ _ }+  label                 { TLabel _ _ }+  newline               { TNewline _ }++%left or+%left and+%right not++%nonassoc '>' '<' '>=' '<=' '==' '!='+%nonassoc RELATIONAL++%left '+' '-'+%left '*' '/'+%right NEGATION+%right '**'++%%++-- This rule is to ignore leading whitespace+PROGRAM :: { ProgramFile A0 }+: NEWLINE PROGRAM_INNER { $2 }+| PROGRAM_INNER { $1 }++PROGRAM_INNER :: { ProgramFile A0 }+: PROGRAM_UNITS BLOCKS { ProgramFile (MetaInfo { miVersion = Fortran66, miFilename = "" })  (reverse $1 ++ convCmts (reverse $2)) }+| {- empty -}   { ProgramFile (MetaInfo { miVersion = Fortran66, miFilename = "" }) [] }++PROGRAM_UNITS :: { [ ProgramUnit A0 ] }+: PROGRAM_UNITS MAIN_PROGRAM_UNIT { $2 : $1 }+| PROGRAM_UNITS BLOCKS OTHER_PROGRAM_UNIT { convCmts (reverse $2) ++ ($3 : $1) }+| MAIN_PROGRAM_UNIT { [ $1 ] }+| BLOCKS OTHER_PROGRAM_UNIT { convCmts (reverse $1) ++ [ $2 ] }++MAIN_PROGRAM_UNIT :: { ProgramUnit A0 }+: BLOCKS end MAYBE_NEWLINE+  { let blocks = reverse $1+    in PUMain () (getTransSpan $1 $2) Nothing blocks Nothing }++OTHER_PROGRAM_UNIT :: { ProgramUnit A0 }+: TYPE_SPEC function NAME MAYBE_ARGUMENTS NEWLINE BLOCKS end MAYBE_NEWLINE+  { PUFunction () (getTransSpan $1 $7) (Just $1) emptyPrefixSuffix $3 $4 Nothing (reverse $6) Nothing }+| function NAME MAYBE_ARGUMENTS NEWLINE BLOCKS end MAYBE_NEWLINE+  { PUFunction () (getTransSpan $1 $6) Nothing emptyPrefixSuffix $2 $3 Nothing (reverse $5) Nothing  }+| subroutine NAME MAYBE_ARGUMENTS NEWLINE BLOCKS end MAYBE_NEWLINE+  { PUSubroutine () (getTransSpan $1 $6) emptyPrefixSuffix $2 $3 (reverse $5) Nothing }+| blockData NEWLINE BLOCKS end MAYBE_NEWLINE { PUBlockData () (getTransSpan $1 $4) Nothing (reverse $3) }++MAYBE_ARGUMENTS :: { Maybe (AList Expression A0) }+: '(' MAYBE_VARIABLES ')' { $2 }+| {- Nothing -} { Nothing }++NAME :: { Name } : id { let (TId _ name) = $1 in name }++BLOCKS :: { [ Block A0 ] }+: BLOCKS BLOCK { $2 : $1 }+| {- EMPTY -}  { [ ] }++BLOCK :: { Block A0 }+: LABEL_IN_6COLUMN STATEMENT NEWLINE { BlStatement () (getTransSpan $1 $2) (Just $1) $2 }+| STATEMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 }+| comment NEWLINE { let (TComment s c) = $1 in BlComment () s (Comment c) }++MAYBE_NEWLINE :: { Maybe Token }+: NEWLINE     { Just $1 }+| {- EMPTY -} { Nothing }++NEWLINE :: { Token }+: NEWLINE newline { $1 }+| newline { $1 }++STATEMENT :: { Statement A0 }+: LOGICAL_IF_STATEMENT { $1 }+| DO_STATEMENT { $1 }+| OTHER_EXECUTABLE_STATEMENT { $1 }+| NONEXECUTABLE_STATEMENT { $1 }++LOGICAL_IF_STATEMENT :: { Statement A0 }+: if '(' EXPRESSION ')' OTHER_EXECUTABLE_STATEMENT+  { StIfLogical () (getTransSpan $1 $5) $3 $5 }++DO_STATEMENT :: { Statement A0 }+: do LABEL_IN_STATEMENT DO_SPECIFICATION+  { StDo () (getTransSpan $1 $3) Nothing (Just $2) (Just $3) }++DO_SPECIFICATION :: { DoSpecification A0 }+: EXPRESSION_ASSIGNMENT_STATEMENT ',' INT_OR_VAR ',' INT_OR_VAR+  { DoSpecification () (getTransSpan $1 $5) $1 $3 (Just $5) }+| EXPRESSION_ASSIGNMENT_STATEMENT ',' INT_OR_VAR+  { DoSpecification () (getTransSpan $1 $3) $1 $3 Nothing }++INT_OR_VAR :: { Expression A0 }+: INTEGER_LITERAL { $1 }+| VARIABLE { $1 }++OTHER_EXECUTABLE_STATEMENT :: { Statement A0 }+: EXPRESSION_ASSIGNMENT_STATEMENT { $1 }+| assign LABEL_IN_STATEMENT to VARIABLE { StLabelAssign () (getTransSpan $1 $4) $2 $4 }+| goto LABEL_IN_STATEMENT { StGotoUnconditional () (getTransSpan $1 $2) $2 }+| goto VARIABLE LABELS_IN_STATEMENT { StGotoAssigned () (getTransSpan $1 $3) $2 (Just $3) }+| goto LABELS_IN_STATEMENT VARIABLE { StGotoComputed () (getTransSpan $1 $3) $2 $3 }+| if '(' EXPRESSION ')' LABEL_IN_STATEMENT ',' LABEL_IN_STATEMENT ',' LABEL_IN_STATEMENT { StIfArithmetic () (getTransSpan $1 $9) $3 $5 $7 $9 }+| call VARIABLE ARGUMENTS+  { StCall () (getTransSpan $1 $3) $2 (Just $3) }+| call VARIABLE { StCall () (getTransSpan $1 $2) $2 Nothing }+| return { StReturn () (getSpan $1) Nothing }+| continue { StContinue () $ getSpan $1 }+| stop INTEGER_LITERAL { StStop () (getTransSpan $1 $2) $ Just $2 }+| stop { StStop () (getSpan $1) Nothing }+| pause INTEGER_LITERAL { StPause () (getTransSpan $1 $2) $ Just $2 }+| pause { StPause () (getSpan $1) Nothing }+| rewind UNIT { StRewind2 () (getTransSpan $1 $2) $2 }+| backspace UNIT { StBackspace2 () (getTransSpan $1 $2) $2 }+| endfile UNIT { StEndfile2 () (getTransSpan $1 $2) $2 }+| write READ_WRITE_ARGUMENTS { let (cilist, iolist) = $2 in StWrite () (getTransSpan $1 $2) cilist iolist }+| read READ_WRITE_ARGUMENTS { let (cilist, iolist) = $2 in StRead () (getTransSpan $1 $2) cilist iolist }++EXPRESSION_ASSIGNMENT_STATEMENT :: { Statement A0 }+: ELEMENT '=' EXPRESSION { StExpressionAssign () (getTransSpan $1 $3) $1 $3 }++NONEXECUTABLE_STATEMENT :: { Statement A0 }+: external FUNCTION_NAMES { StExternal () (getTransSpan $1 $2) (aReverse $2) }+| dimension ARRAY_DECLARATORS { StDimension () (getTransSpan $1 $2) (aReverse $2) }+| common COMMON_GROUPS { StCommon () (getTransSpan $1 $2) (aReverse $2) }+| equivalence EQUIVALENCE_GROUPS { StEquivalence () (getTransSpan $1 $2) (aReverse $2) }+| data DATA_GROUPS { StData () (getTransSpan $1 $2) (aReverse $2) }+-- Following is a fake node to make arbitrary FORMAT statements parsable.+-- Must be fixed in the future. TODO+| format blob+  { let TBlob s blob = $2 in StFormatBogus () (getTransSpan $1 s) blob }+| TYPE_SPEC DECLARATORS { StDeclaration () (getTransSpan $1 $2) $1 Nothing (aReverse $2) }++READ_WRITE_ARGUMENTS :: { (AList ControlPair A0, Maybe (AList Expression A0)) }+: '(' UNIT ')' IO_ELEMENTS { (AList () (getSpan $2) [ ControlPair () (getSpan $2) Nothing $2 ], Just (aReverse $4)) }+| '(' UNIT ',' FORM ')' IO_ELEMENTS { (AList () (getTransSpan $2 $4) [ ControlPair () (getSpan $2) Nothing $2, ControlPair () (getSpan $4) Nothing $4 ], Just (aReverse $6)) }+| '(' UNIT ')' { (AList () (getSpan $2) [ ControlPair () (getSpan $2) Nothing $2 ], Nothing) }+| '(' UNIT ',' FORM ')' { (AList () (getTransSpan $2 $4) [ ControlPair () (getSpan $2) Nothing $2, ControlPair () (getSpan $4) Nothing $4 ], Nothing) }++-- Not my terminology a VAR or an INT (probably positive) is defined as UNIT.+UNIT :: { Expression A0 }+: INTEGER_LITERAL { $1 }+| VARIABLE { $1 }++FORM :: { Expression A0 }+: VARIABLE { $1 }+| LABEL_IN_STATEMENT { $1 }++IO_ELEMENTS :: { AList Expression A0 }+: IO_ELEMENTS ',' IO_ELEMENT { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1}+| IO_ELEMENT { AList () (getSpan $1) [ $1 ] }++IO_ELEMENT :: { Expression A0 }+: VARIABLE { $1 }+-- There should also be a caluse for variable names but not way to+-- differentiate it at this stage from VARIABLE. Hence, it is omitted to prevent+-- reduce/reduce conflict.+| SUBSCRIPT { $1 }+| '(' IO_ELEMENTS ',' DO_SPECIFICATION ')' { ExpImpliedDo () (getTransSpan $1 $5) $2 $4 }++ELEMENT :: { Expression A0 }+: VARIABLE { $1 }+| SUBSCRIPT { $1 }++DATA_GROUPS :: { AList DataGroup A0 }+: DATA_GROUPS ',' NAME_LIST  '/' DATA_ITEMS '/' { setSpan (getTransSpan $1 $6) $ (DataGroup () (getTransSpan $3 $6) (aReverse $3) (aReverse $5)) `aCons` $1 }+| NAME_LIST  '/' DATA_ITEMS '/' { AList () (getTransSpan $1 $4) [ DataGroup () (getTransSpan $1 $4) (aReverse $1) (aReverse $3) ] }++DATA_ITEMS :: { AList Expression A0 }+: DATA_ITEMS ',' DATA_ITEM { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1}+| DATA_ITEM { AList () (getSpan $1) [ $1 ] }++DATA_ITEM :: { Expression A0 }+: INTEGER_LITERAL '*' DATA_ITEM_LEVEL1 { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 }+| DATA_ITEM_LEVEL1 { $1 }++DATA_ITEM_LEVEL1 :: { Expression A0 }+: SIGNED_NUMERIC_LITERAL  { $1 }+| COMPLEX_LITERAL         { $1 }+| LOGICAL_LITERAL         { $1 }+| HOLLERITH               { $1 }++EQUIVALENCE_GROUPS :: { AList (AList Expression) A0 }+: EQUIVALENCE_GROUPS ','  '(' NAME_LIST ')' { setSpan (getTransSpan $1 $5) $ (setSpan (getTransSpan $3 $5) $ aReverse $4) `aCons` $1 }+| '(' NAME_LIST ')' { let s = (getTransSpan $1 $3) in AList () s [ setSpan s $ aReverse $2 ] }++COMMON_GROUPS :: { AList CommonGroup A0 }+: COMMON_GROUPS COMMON_GROUP { setSpan (getTransSpan $1 $2) $ $2 `aCons` $1 }+| INIT_COMMON_GROUP { AList () (getSpan $1) [ $1 ] }++COMMON_GROUP :: { CommonGroup A0 }+: COMMON_NAME DECLARATORS+  { CommonGroup () (getTransSpan $1 $2) (Just $1) $ aReverse $2 }+| '/' '/' DECLARATORS { CommonGroup () (getTransSpan $1 $3) Nothing $ aReverse $3 }++INIT_COMMON_GROUP :: { CommonGroup A0 }+: COMMON_NAME DECLARATORS+  { CommonGroup () (getTransSpan $1 $2) (Just $1) $ aReverse $2 }+| '/' '/' DECLARATORS { CommonGroup () (getTransSpan $1 $3) Nothing $ aReverse $3 }+| DECLARATORS { CommonGroup () (getSpan $1) Nothing $ aReverse $1 }++COMMON_NAME :: { Expression A0 }+: '/' VARIABLE '/' { setSpan (getTransSpan $1 $3) $2 }++NAME_LIST :: { AList Expression A0 }+: NAME_LIST ',' NAME_LIST_ELEMENT { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }+| NAME_LIST_ELEMENT { AList () (getSpan $1) [ $1 ] }++NAME_LIST_ELEMENT :: { Expression A0 }+: VARIABLE { $1 }+| SUBSCRIPT { $1 }++-- Note that declarator lists in the F66 parser don't have initializers.+DECLARATORS :: { AList Declarator A0 }+: DECLARATORS ',' DECLARATOR { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }+| DECLARATOR { AList () (getSpan $1) [ $1 ] }++DECLARATOR :: { Declarator A0 }+: ARRAY_DECLARATOR    { $1 }+| VARIABLE_DECLARATOR { $1 }++ARRAY_DECLARATORS :: { AList Declarator A0 }+: ARRAY_DECLARATORS ',' ARRAY_DECLARATOR+  { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }+| ARRAY_DECLARATOR+  { AList () (getSpan $1) [ $1 ] }++ARRAY_DECLARATOR :: { Declarator A0 }+: VARIABLE '(' DIMENSION_DECLARATORS ')'+  { Declarator () (getTransSpan $1 $4) $1 (ArrayDecl (aReverse $3)) Nothing Nothing }++DIMENSION_DECLARATORS :: { AList DimensionDeclarator A0 }+: DIMENSION_DECLARATORS ',' DIMENSION_DECLARATOR+  { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }+| DIMENSION_DECLARATOR+  { AList () (getSpan $1) [ $1 ] }++DIMENSION_DECLARATOR :: { DimensionDeclarator A0 }+: EXPRESSION { DimensionDeclarator () (getSpan $1) Nothing (Just $1) }++VARIABLE_DECLARATOR :: { Declarator A0 }+: VARIABLE { Declarator () (getSpan $1) $1 ScalarDecl Nothing Nothing }++-- Here the procedure should be either a function or subroutine name, but+-- since they are syntactically identical at this stage subroutine names+-- are also emitted as function names.+FUNCTION_NAMES :: { AList Expression A0 }+: FUNCTION_NAMES ',' VARIABLE { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }+| VARIABLE { AList () (getSpan $1) [ $1 ] }++ARGUMENTS :: { AList Argument A0 }+:  ARGUMENTS_LEVEL1 ')' { setSpan (getTransSpan $1 $2) $ aReverse $1 }++ARGUMENTS_LEVEL1 :: { AList Argument A0 }+: ARGUMENTS_LEVEL1 ',' CALLABLE_EXPRESSION { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }+| '(' CALLABLE_EXPRESSION { AList () (getTransSpan $1 $2) [ $2 ] }+| '(' { AList () (getSpan $1) [ ] }++-- Expression all by itself subsumes all other callable expressions.+CALLABLE_EXPRESSION :: { Argument A0 }+: HOLLERITH   { Argument () (getSpan $1) Nothing (ArgExpr $1) }+| '(' VARIABLE ')'+  { let ExpValue _ _ (ValVariable v) = $2+     in Argument () (getTransSpan $1 $3) Nothing (ArgExprVar () (getSpan $2) v) }+| EXPRESSION  { Argument () (getSpan $1) Nothing (ArgExpr $1) }++EXPRESSION :: { Expression A0 }+: EXPRESSION '+' EXPRESSION { ExpBinary () (getTransSpan $1 $3) Addition $1 $3 }+| EXPRESSION '-' EXPRESSION { ExpBinary () (getTransSpan $1 $3) Subtraction $1 $3 }+| EXPRESSION '*' EXPRESSION { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 }+| EXPRESSION '/' EXPRESSION { ExpBinary () (getTransSpan $1 $3) Division $1 $3 }+| EXPRESSION '**' EXPRESSION { ExpBinary () (getTransSpan $1 $3) Exponentiation $1 $3 }+| ARITHMETIC_SIGN EXPRESSION %prec NEGATION { ExpUnary () (getTransSpan (fst $1) $2) (snd $1) $2 }+| EXPRESSION or EXPRESSION { ExpBinary () (getTransSpan $1 $3) Or $1 $3 }+| EXPRESSION and EXPRESSION { ExpBinary () (getTransSpan $1 $3) And $1 $3 }+| not EXPRESSION { ExpUnary () (getTransSpan $1 $2) Not $2 }+| EXPRESSION RELATIONAL_OPERATOR EXPRESSION %prec RELATIONAL { ExpBinary () (getTransSpan $1 $3) $2 $1 $3 }+| '(' EXPRESSION ')' { setSpan (getTransSpan $1 $3) $2 }+| INTEGER_LITERAL               { $1 }+| REAL_LITERAL                  { $1 }+| COMPLEX_LITERAL               { $1 }+| LOGICAL_LITERAL               { $1 }+| SUBSCRIPT                     { $1 }+-- There should be FUNCTION_CALL here but as far as the parser is concerned it is same as SUBSCRIPT,+-- hence putting it here would cause a reduce/reduce conflict.+| VARIABLE                      { $1 }++RELATIONAL_OPERATOR :: { BinaryOp }+: '=='  { EQ }+| '!='  { NE }+| '>'   { GT }+| '>='  { GTE }+| '<'   { LT }+| '<='  { LTE }++SUBSCRIPT :: { Expression A0 }+: VARIABLE '(' ')'+  { ExpFunctionCall () (getTransSpan $1 $3) $1 Nothing }+| VARIABLE '(' INDICIES ')'+  { ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3) }++INDICIES :: { [ Index A0 ] }+: INDICIES ',' EXPRESSION { IxSingle () (getSpan $3) Nothing $3 : $1 }+| EXPRESSION { [ IxSingle () (getSpan $1) Nothing $1 ] }++ARITHMETIC_SIGN :: { (SrcSpan, UnaryOp) }+: '-' { (getSpan $1, Minus) }+| '+' { (getSpan $1, Plus) }++MAYBE_VARIABLES :: { Maybe (AList Expression A0) }+: VARIABLES { Just $ fromReverseList $1 } | {- EMPTY -} { Nothing }++VARIABLES :: { [ Expression A0 ] }+: VARIABLES ',' VARIABLE { $3 : $1 } | VARIABLE { [ $1 ] }++-- This may also be used to parse a function name, or an array name. Since when+-- are valid options in a production there is no way of differentiating them at+-- this stage.+-- This at least reduces reduce/reduce conflicts.+VARIABLE :: { Expression A0 }+: id { ExpValue () (getSpan $1) $ let (TId _ s) = $1 in ValVariable s }++SIGNED_INTEGER_LITERAL :: { Expression A0 }+: ARITHMETIC_SIGN INTEGER_LITERAL { ExpUnary () (getTransSpan (fst $1) $2) (snd $1) $2 }+| INTEGER_LITERAL { $1 }++INTEGER_LITERAL :: { Expression A0 }+: int { ExpValue () (getSpan $1) $ let (TInt _ i) = $1 in ValInteger i Nothing }++SIGNED_REAL_LITERAL :: { Expression A0 }+: ARITHMETIC_SIGN REAL_LITERAL { ExpUnary () (getTransSpan (fst $1) $2) (snd $1) $2 }+| REAL_LITERAL { $1 }++REAL_LITERAL :: { Expression A0 }+: int EXPONENT { makeRealLit (Just $1) Nothing Nothing (Just $2) }+| int '.' MAYBE_EXPONENT { makeRealLit (Just $1) (Just $2) Nothing $3 }+| '.' int MAYBE_EXPONENT { makeRealLit Nothing (Just $1) (Just $2) $3 }+| int '.' int MAYBE_EXPONENT { makeRealLit (Just $1) (Just $2) (Just $3) $4 }++MAYBE_EXPONENT :: { Maybe (SrcSpan, String) }+: EXPONENT { Just $1 }+| {-EMPTY-} { Nothing }++EXPONENT :: { (SrcSpan, String) }+: exponent { let (TExponent s exp) = $1 in (s, exp) }++SIGNED_NUMERIC_LITERAL :: { Expression A0 }+: SIGNED_INTEGER_LITERAL { $1 }+| SIGNED_REAL_LITERAL    { $1 }++COMPLEX_LITERAL :: { Expression A0 }+:  '(' SIGNED_NUMERIC_LITERAL ',' SIGNED_NUMERIC_LITERAL ')' { ExpValue () (getTransSpan $1 $5) (ValComplex $2 $4)}++LOGICAL_LITERAL :: { Expression A0 }+: bool { let TBool s b = $1 in ExpValue () s $ ValLogical b Nothing }++HOLLERITH :: { Expression A0 }+: hollerith { ExpValue () (getSpan $1) $ let (THollerith _ h) = $1 in ValHollerith h }++LABELS_IN_STATEMENT :: { AList Expression A0 }+: LABELS_IN_STATEMENT_LEVEL1 ')' { setSpan (getTransSpan $1 $2) $ aReverse $1 }++LABELS_IN_STATEMENT_LEVEL1 :: { AList Expression A0 }+: LABELS_IN_STATEMENT_LEVEL1 ',' LABEL_IN_STATEMENT { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }+| '(' LABEL_IN_STATEMENT { AList () (getTransSpan $1 $2) [ $2 ] }++-- Labels that occur in the first 6 columns+LABEL_IN_6COLUMN :: { Expression A0 }+: label { ExpValue () (getSpan $1) (let (TLabel _ l) = $1 in ValInteger l Nothing) }++-- Labels that occur in statements+LABEL_IN_STATEMENT :: { Expression A0 }+: int { ExpValue () (getSpan $1) (let (TInt _ l) = $1 in ValInteger l Nothing) }++TYPE_SPEC :: { TypeSpec A0 }+: integer           { TypeSpec () (getSpan $1) TypeInteger Nothing }+| real              { TypeSpec () (getSpan $1) TypeReal Nothing }+| doublePrecision   { TypeSpec () (getSpan $1) TypeDoublePrecision Nothing }+| logical           { TypeSpec () (getSpan $1) TypeLogical Nothing }+| complex           { TypeSpec () (getSpan $1) TypeComplex Nothing }

@@ -0,0 +1,977 @@+-- -*- Mode: Haskell -*-+-- vim: ft=haskell+{+module Language.Fortran.Parser.Fixed.Fortran77+  ( programParser+  , blockParser+  , statementParser+  , expressionParser+  , includesParser+  ) where++import Language.Fortran.Version+import Language.Fortran.Util.Position+import Language.Fortran.Parser.Monad+import Language.Fortran.Parser.Fixed.Lexer+import Language.Fortran.Parser.Fixed.Utils+import Language.Fortran.AST+import Language.Fortran.AST.RealLit++import Prelude hiding ( EQ, LT, GT ) -- Same constructors exist in the AST+import Data.Maybe ( isNothing, fromJust )++}++%name programParser    PROGRAM+%name blockParser      BLOCK+%name statementParser  STATEMENT+%name expressionParser EXPRESSION+%name includesParser   INCLUDES+%monad { LexAction }+%lexer { lexer } { TEOF _ }+%tokentype { Token }+%error { parseError }++%token+  '('                   { TLeftPar _ }+  ')'                   { TRightPar _ }+  '(/'                  { TLeftArrayPar _ }+  '/)'                  { TRightArrayPar _ }+  ','                   { TComma _ }+  '.'                   { TDot _ }+  '%'                   { TPercent _ }+  ':'                   { TColon _ }+  include               { TInclude _ }+  program               { TProgram _ }+  function              { TFunction _ }+  subroutine            { TSubroutine _ }+  endprogram            { TEndProgram _ }+  endfunction           { TEndFunction _ }+  endsubroutine         { TEndSubroutine _ }+  blockData             { TBlockData _ }+  structure             { TStructure _ }+  union                 { TUnion _ }+  map                   { TMap _ }+  endstructure          { TEndStructure _ }+  endunion              { TEndUnion _ }+  endmap                { TEndMap _ }+  record                { TRecord _ }+  end                   { TEnd _ }+  '='                   { TOpAssign _ }+  assign                { TAssign _ }+  to                    { TTo _ }+  goto                  { TGoto _ }+  if                    { TIf _ }+  then                  { TThen _ }+  else                  { TElse _ }+  elsif                 { TElsif _ }+  endif                 { TEndif _ }+  call                  { TCall _ }+  return                { TReturn _ }+  save                  { TSave _ }+  continue              { TContinue _ }+  stop                  { TStop _ }+  exit                  { TExit _ }+  cycle                 { TCycle _ }+  case                  { TCase _ }+  selectcase            { TSelectCase _ }+  endselect             { TEndSelect _ }+  casedefault           { TCaseDefault _ }+  pause                 { TPause _ }+  do                    { TDo _ }+  doWhile               { TDoWhile _ }+  while                 { TWhile _ }+  enddo                 { TEndDo _ }+  read                  { TRead _ }+  write                 { TWrite _ }+  print                 { TPrint _ }+  typeprint             { TTypePrint _ }+  open                  { TOpen _ }+  close                 { TClose _ }+  inquire               { TInquire _ }+  rewind                { TRewind _ }+  backspace             { TBackspace _ }+  endfile               { TEndfile _ }+  common                { TCommon _ }+  equivalence           { TEquivalence _ }+  external              { TExternal _ }+  dimension             { TDimension _ }+  byte                  { TType _ "byte" }+  character             { TType _ "character" }+  integer               { TType _ "integer" }+  real                  { TType _ "real" }+  doublePrecision       { TType _ "doubleprecision" }+  logical               { TType _ "logical" }+  complex               { TType _ "complex" }+  doubleComplex         { TType _ "doublecomplex" }+  intrinsic             { TIntrinsic _ }+  implicit              { TImplicit _ }+  parameter             { TParameter _ }+  pointer               { TPointer _ }+  entry                 { TEntry _ }+  none                  { TNone _ }+  data                  { TData _ }+  automatic             { TAutomatic _ }+  static                { TStatic _ }+  format                { TFormat _ }+  blob                  { TBlob _ _ }+  int                   { TInt _ _ }+  boz                   { TBozLiteral _ _ }+  exponent              { TExponent _ _ }+  bool                  { TBool _ _ }+  '+'                   { TOpPlus _ }+  '-'                   { TOpMinus _ }+  '**'                  { TOpExp _ }+  '*'                   { TStar _ }+  '/'                   { TSlash _ }+  '&'                   { TAmpersand _ }+  eqv                   { TOpEquivalent _ }+  neqv                  { TOpNotEquivalent _ }+  or                    { TOpOr _ }+  and                   { TOpAnd _ }+  xor                   { TOpXOr _ }+  not                   { TOpNot _ }+  '<'                   { TOpLT _ }+  '<='                  { TOpLE _ }+  '>'                   { TOpGT _ }+  '>='                  { TOpGE _ }+  '=='                  { TOpEQ _ }+  '!='                  { TOpNE _ }+  id                    { TId _ _ }+  comment               { TComment _ _ }+  hollerith             { THollerith _ _ }+  string                { TString _ _ }+  label                 { TLabel _ _ }+  newline               { TNewline _ }++%left eqv neqv xor+%left or+%left and+%right not++%nonassoc '>' '<' '>=' '<=' '==' '!='+%nonassoc RELATIONAL++%left CONCAT++%left '+' '-'+%left '*' '/'+%right NEGATION+%right '**'++%%++maybe(p)+: p           { Just $1 }+| {- empty -} { Nothing }++rev_list1(p)+: p              { [$1] }+| rev_list1(p) p { $2 : $1 }++rev_list(p)+: rev_list1(p) { $1 }+| {- empty -}  { [] }++list1(p)+: rev_list1(p) { reverse $1 }++list(p)+: rev_list(p) { reverse $1 }++-- This rule is to ignore leading whitespace+PROGRAM :: { ProgramFile A0 }+: NEWLINE PROGRAM_INNER { $2 }+| PROGRAM_INNER { $1 }++PROGRAM_INNER :: { ProgramFile A0 }+: PROGRAM_UNITS { ProgramFile (MetaInfo { miVersion = Fortran77, miFilename = "" }) (reverse $1) }+| {- empty -}   { ProgramFile (MetaInfo { miVersion = Fortran77, miFilename = "" }) [] }++PROGRAM_UNITS :: { [ ProgramUnit A0 ] }+: PROGRAM_UNITS maybe(LABEL_IN_6COLUMN) PROGRAM_UNIT maybe(NEWLINE) { $3 : $1 }+| maybe(LABEL_IN_6COLUMN) PROGRAM_UNIT maybe(NEWLINE) { [ $2 ] }++PROGRAM_UNIT :: { ProgramUnit A0 }+: program NAME NEWLINE BLOCKS ENDPROG+  { PUMain () (getTransSpan $1 $5) (Just $2) (reverse $4) Nothing }+| TYPE_SPEC function NAME MAYBE_ARGUMENTS NEWLINE BLOCKS ENDFUN+  { PUFunction () (getTransSpan $1 $7) (Just $1) emptyPrefixSuffix $3 $4 Nothing (reverse $6) Nothing }+| function NAME MAYBE_ARGUMENTS NEWLINE BLOCKS ENDFUN+  { PUFunction () (getTransSpan $1 $6) Nothing emptyPrefixSuffix $2 $3 Nothing (reverse $5) Nothing }+| subroutine NAME MAYBE_ARGUMENTS NEWLINE BLOCKS ENDSUB+  { PUSubroutine () (getTransSpan $1 $6) emptyPrefixSuffix $2 $3 (reverse $5) Nothing }+| blockData NEWLINE BLOCKS END { PUBlockData () (getTransSpan $1 $4) Nothing (reverse $3) }+| blockData NAME NEWLINE BLOCKS END { PUBlockData () (getTransSpan $1 $5) (Just $2) (reverse $4) }+| comment { let (TComment s c) = $1 in PUComment () s (Comment c) }++END :: { Token }+: end                  { $1 }+| LABEL_IN_6COLUMN end { $2 }++ENDPROG :: { Token }+: END                         { $1 }+| endprogram MAYBE_ID       { $1 }+| LABEL_IN_6COLUMN endprogram MAYBE_ID { $2 }++ENDFUN :: { Token }+: END                          { $1 }+| endfunction MAYBE_ID       { $1 }+| LABEL_IN_6COLUMN endfunction MAYBE_ID { $2 }++ENDSUB :: { Token }+: END                            { $1 }+| endsubroutine MAYBE_ID       { $1 }+| LABEL_IN_6COLUMN endsubroutine MAYBE_ID { $2 }++MAYBE_ARGUMENTS :: { Maybe (AList Expression A0) }+: '(' MAYBE_VARIABLES ')' { $2 }+| {- Nothing -} { Nothing }++MAYBE_ID :: { Maybe Name }+: id { let (TId _ name) = $1 in Just name }+| {- empty -} { Nothing }++NAME :: { Name } : id { let (TId _ name) = $1 in name }++INCLUDES :: { [ Block A0 ] }+: maybe(NEWLINE) list(BLOCK) { $2 }++BLOCKS :: { [ Block A0 ] }+: BLOCKS BLOCK { $2 : $1 }+| {- EMPTY -} { [ ] }++BLOCK :: { Block A0 }+: IF_BLOCK NEWLINE { $1 }+| LABEL_IN_6COLUMN STATEMENT NEWLINE { BlStatement () (getTransSpan $1 $2) (Just $1) $2 }+| STATEMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 }+| COMMENT_BLOCK { $1 }++IF_BLOCK :: { Block A0 }+: if '(' EXPRESSION ')' then NEWLINE BLOCKS ELSE_BLOCKS {+    let (endSpan, endLabel, conds, blocks) = $8+    in BlIf () (getTransSpan $1 endSpan) Nothing Nothing ((Just $3):conds) ((reverse $7):blocks) endLabel+  }+| LABEL_IN_6COLUMN if '(' EXPRESSION ')' then NEWLINE BLOCKS ELSE_BLOCKS {+    let (endSpan, endLabel, conds, blocks) = $9+    in BlIf () (getTransSpan $1 endSpan) (Just $1) Nothing ((Just $4):conds) ((reverse $8):blocks) endLabel+  }++ELSE_BLOCKS :: { (SrcSpan, Maybe (Expression A0), [Maybe (Expression A0)], [[Block A0]]) }+: maybe(LABEL_IN_6COLUMN) elsif '(' EXPRESSION ')' then NEWLINE BLOCKS ELSE_BLOCKS+  { let (endSpan, endLabel, conds, blocks) = $9+    in (endSpan, endLabel, Just $4 : conds, reverse $8 : blocks) }+| maybe(LABEL_IN_6COLUMN) else NEWLINE BLOCKS maybe(LABEL_IN_6COLUMN) endif+  { (getSpan $6, $5, [Nothing], [reverse $4]) }+| maybe(LABEL_IN_6COLUMN) endif { (getSpan $2, $1, [], []) }++COMMENT_BLOCK :: { Block A0 }+: comment NEWLINE { let (TComment s c) = $1 in BlComment () s (Comment c) }++NEWLINE :: { Token }+: NEWLINE newline { $1 }+| newline { $1 }++STATEMENT :: { Statement A0 }+: LOGICAL_IF_STATEMENT { $1 }+| DO_STATEMENT { $1 }+| EXECUTABLE_STATEMENT { $1 }+| NONEXECUTABLE_STATEMENT { $1 }++LOGICAL_IF_STATEMENT :: { Statement A0 }+: if '(' EXPRESSION ')' EXECUTABLE_STATEMENT { StIfLogical () (getTransSpan $1 $5) $3 $5 }++DO_STATEMENT :: { Statement A0 }+: do LABEL_IN_STATEMENT DO_SPECIFICATION { StDo () (getTransSpan $1 $3) Nothing (Just $2) (Just $3) }+| do LABEL_IN_STATEMENT ',' DO_SPECIFICATION { StDo () (getTransSpan $1 $4) Nothing (Just $2) (Just $4) }+| do DO_SPECIFICATION { StDo () (getTransSpan $1 $2) Nothing Nothing (Just $2) }+| do { StDo () (getSpan $1) Nothing Nothing Nothing }++DO_SPECIFICATION :: { DoSpecification A0 }+: EXPRESSION_ASSIGNMENT_STATEMENT ',' EXPRESSION ',' EXPRESSION { DoSpecification () (getTransSpan $1 $5) $1 $3 (Just $5) }+| EXPRESSION_ASSIGNMENT_STATEMENT ',' EXPRESSION                { DoSpecification () (getTransSpan $1 $3) $1 $3 Nothing }++EXECUTABLE_STATEMENT :: { Statement A0 }+: EXPRESSION_ASSIGNMENT_STATEMENT { $1 }+| assign LABEL_IN_STATEMENT to VARIABLE { StLabelAssign () (getTransSpan $1 $4) $2 $4 }+| GOTO_STATEMENT { $1 }+| if '(' EXPRESSION ')' LABEL_IN_STATEMENT ',' LABEL_IN_STATEMENT ',' LABEL_IN_STATEMENT { StIfArithmetic () (getTransSpan $1 $9) $3 $5 $7 $9 }+| doWhile '(' EXPRESSION ')'+  { StDoWhile () (getTransSpan $1 $4) Nothing Nothing $3 }+| do LABEL_IN_STATEMENT while '(' EXPRESSION ')'+  { StDoWhile () (getTransSpan $1 $6) Nothing (Just $2) $5 }+| do LABEL_IN_STATEMENT ',' while '(' EXPRESSION ')'+  { StDoWhile () (getTransSpan $1 $7) Nothing (Just $2) $6 }+| enddo { StEnddo () (getSpan $1) Nothing }+| call VARIABLE ARGUMENTS+  { StCall () (getTransSpan $1 $3) $2 $ Just $3 }+| call VARIABLE { StCall () (getTransSpan $1 $2) $2 Nothing }+| return { StReturn () (getSpan $1) Nothing }+| return EXPRESSION { StReturn () (getTransSpan $1 $2) $ Just $2 }+| save SAVE_ARGS { StSave () (getSpan ($1, $2)) $2 }+| continue { StContinue () $ getSpan $1 }+| stop INTEGER_OR_STRING { StStop () (getTransSpan $1 $2) $ Just $2 }+| stop { StStop () (getSpan $1) Nothing }+| exit { StExit () (getSpan $1) Nothing }+| cycle { StCycle () (getSpan $1) Nothing }+| pause INTEGER_OR_STRING { StPause () (getTransSpan $1 $2) $ Just $2 }+| pause { StPause () (getSpan $1) Nothing }+| selectcase '(' EXPRESSION ')'+  { StSelectCase () (getTransSpan $1 $4) Nothing $3 }+| casedefault { StCase () (getSpan $1) Nothing Nothing }+| casedefault id+  { let TId s id = $2 in StCase () (getTransSpan $1 s) (Just id) Nothing }+| case '(' INDICIES ')'+  { StCase () (getTransSpan $1 $4) Nothing (Just $ fromReverseList $3) }+| case '(' INDICIES ')' id+  { let TId s id = $5+    in StCase () (getTransSpan $1 s) (Just id) (Just $ fromReverseList $3) }+| endselect { StEndcase () (getSpan $1) Nothing }+| endselect id+  { let TId s id = $2 in StEndcase () (getTransSpan $1 s) (Just id) }+-- IO Statements+| read CILIST IN_IOLIST { StRead () (getTransSpan $1 $3) $2 (Just $ aReverse $3) }+| read CILIST { StRead () (getTransSpan $1 $2) $2 Nothing }+| read FORMAT_ID ',' IN_IOLIST { StRead2 () (getTransSpan $1 $4) $2 (Just $ aReverse $4) }+| read FORMAT_ID { StRead2 () (getTransSpan $1 $2) $2 Nothing }+| write CILIST OUT_IOLIST { StWrite () (getTransSpan $1 $3) $2 (Just $ aReverse $3) }+| write CILIST { StWrite () (getTransSpan $1 $2) $2 Nothing }+| print FORMAT_ID ',' OUT_IOLIST { StPrint () (getTransSpan $1 $4) $2 (Just $ aReverse $4) }+| print FORMAT_ID { StPrint () (getTransSpan $1 $2) $2 Nothing }+| typeprint FORMAT_ID ',' OUT_IOLIST { StTypePrint () (getTransSpan $1 $4) $2 (Just $ aReverse $4) }+| typeprint FORMAT_ID { StTypePrint () (getTransSpan $1 $2) $2 Nothing }+| open CILIST { StOpen () (getTransSpan $1 $2) $2 }+| close CILIST { StClose () (getTransSpan $1 $2) $2 }+| inquire CILIST { StInquire () (getTransSpan $1 $2) $2 }+| rewind CILIST { StRewind () (getTransSpan $1 $2) $2 }+| rewind UNIT { StRewind2 () (getTransSpan $1 $2) $2 }+| endfile CILIST { StEndfile () (getTransSpan $1 $2) $2 }+| endfile UNIT { StEndfile2 () (getTransSpan $1 $2) $2 }+| backspace CILIST { StBackspace () (getTransSpan $1 $2) $2 }+| backspace UNIT { StBackspace2 () (getTransSpan $1 $2) $2 }++FORMAT_ID :: { Expression A0 }+: FORMAT_ID '/' '/' FORMAT_ID %prec CONCAT { ExpBinary () (getTransSpan $1 $4) Concatenation $1 $4 }+| INTEGER_LITERAL               { $1 }+-- There should be FUNCTION_CALL here but as far as the parser is concerned it is same as SUBSCRIPT,+-- hence putting it here would cause a reduce/reduce conflict.+| SUBSCRIPT                     { $1 }+| '*' { ExpValue () (getSpan $1) ValStar }++UNIT :: { Expression A0 }+: INTEGER_LITERAL { $1 }+| SUBSCRIPT { $1 }+| '*' { ExpValue () (getSpan $1) ValStar }++-- A crude approximation that makes parsing easy. Individual key value pairs+-- should be checket later on.+CILIST :: { AList ControlPair A0 }+: '(' UNIT ',' FORMAT_ID ',' CILIST_PAIRS ')' {+  let { cp1 = ControlPair () (getSpan $2) Nothing $2;+        cp2 = ControlPair () (getSpan $4) Nothing $4 }+  in setSpan (getTransSpan $1 $7) $ cp1 `aCons` cp2 `aCons` aReverse $6+  }+| '(' UNIT ',' FORMAT_ID ')' {+  let { cp1 = ControlPair () (getSpan $2) Nothing $2;+        cp2 = ControlPair () (getSpan $4) Nothing $4 }+        in AList () (getTransSpan $1 $5) [ cp1,  cp2 ]+        }+| '(' UNIT ',' CILIST_PAIRS ')' {+  let cp1 = ControlPair () (getSpan $2) Nothing $2+        in setSpan (getTransSpan $1 $5) $ cp1 `aCons` aReverse $4+        }+| '(' UNIT ')' {+  let cp1 = ControlPair () (getSpan $2) Nothing $2+  in AList () (getTransSpan $1 $3) [ cp1 ]+  }+| '(' CILIST_PAIRS ')' { setSpan (getTransSpan $1 $3) $ aReverse $2 }++CILIST_PAIRS :: { AList ControlPair A0 }+: CILIST_PAIRS ',' CILIST_PAIR { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }+| CILIST_PAIR { AList () (getSpan $1) [ $1 ] }++CILIST_PAIR :: { ControlPair A0 }+: id '=' CILIST_ELEMENT { let (TId s id) = $1 in ControlPair () (getTransSpan s $3) (Just id) $3 }++CILIST_ELEMENT :: { Expression A0 }+: CI_EXPRESSION { $1 }+| '*' { ExpValue () (getSpan $1) ValStar }++CI_EXPRESSION :: { Expression A0 }+: CI_EXPRESSION '+' CI_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Addition $1 $3 }+| CI_EXPRESSION '-' CI_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Subtraction $1 $3 }+| CI_EXPRESSION '*' CI_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 }+| CI_EXPRESSION '/' CI_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Division $1 $3 }+| CI_EXPRESSION '**' CI_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Exponentiation $1 $3 }+| CI_EXPRESSION '/' '/' CI_EXPRESSION %prec CONCAT { ExpBinary () (getTransSpan $1 $4) Concatenation $1 $4 }+| ARITHMETIC_SIGN CI_EXPRESSION %prec NEGATION { ExpUnary () (getTransSpan (fst $1) $2) (snd $1) $2 }+| CI_EXPRESSION or CI_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Or $1 $3 }+| CI_EXPRESSION and CI_EXPRESSION { ExpBinary () (getTransSpan $1 $3) And $1 $3 }+| CI_EXPRESSION xor CI_EXPRESSION { ExpBinary () (getTransSpan $1 $3) XOr $1 $3 }+| not CI_EXPRESSION { ExpUnary () (getTransSpan $1 $2) Not $2 }+| CI_EXPRESSION eqv CI_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Equivalent $1 $3 }+| CI_EXPRESSION neqv CI_EXPRESSION { ExpBinary () (getTransSpan $1 $3) NotEquivalent $1 $3 }+| CI_EXPRESSION RELATIONAL_OPERATOR CI_EXPRESSION %prec RELATIONAL { ExpBinary () (getTransSpan $1 $3) $2 $1 $3 }+| '(' CI_EXPRESSION ')' { setSpan (getTransSpan $1 $3) $2 }+| INTEGER_LITERAL               { $1 }+| LOGICAL_LITERAL               { $1 }+-- There should be FUNCTION_CALL here but as far as the parser is concerned it is same as SUBSCRIPT,+-- hence putting it here would cause a reduce/reduce conflict.+| SUBSCRIPT                     { $1 }++-- Input IOList used in read like statements is much more restrictive as it+-- doesn't make sense to read into an integer.+-- While the output list can be an arbitrary expression. Hence, the grammar+-- rule separation.++IN_IOLIST :: { AList Expression A0 }+: IN_IOLIST ',' IN_IO_ELEMENT { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1}+| IN_IO_ELEMENT { AList () (getSpan $1) [ $1 ] }++IN_IO_ELEMENT :: { Expression A0 }+: SUBSCRIPT { $1 }+| '(' IN_IOLIST ',' DO_SPECIFICATION ')' { ExpImpliedDo () (getTransSpan $1 $5) (aReverse $2) $4 }++OUT_IOLIST :: { AList Expression A0 }+: OUT_IOLIST ',' EXPRESSION { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1}+| EXPRESSION { AList () (getSpan $1) [ $1 ] }++SAVE_ARGS :: { Maybe (AList Expression A0) }+: SAVE_ARGS_LEVEL1 { Just $ fromReverseList $1 }+| {-EMPTY-} { Nothing }++SAVE_ARGS_LEVEL1 :: { [ Expression A0 ] }+: SAVE_ARGS_LEVEL1 ',' SAVE_ARG { $3 : $1 }+| SAVE_ARG { [ $1 ] }++SAVE_ARG :: { Expression A0 }+: COMMON_NAME { $1 } | VARIABLE { $1 }++INTEGER_OR_STRING :: { Expression A0 } : STRING { $1 } | INTEGER_LITERAL { $1 }++GOTO_STATEMENT :: { Statement A0 }+: goto LABEL_IN_STATEMENT { StGotoUnconditional () (getTransSpan $1 $2) $2 }+| goto VARIABLE { StGotoAssigned () (getTransSpan $1 $2) $2 Nothing }+| goto VARIABLE LABELS_IN_STATEMENT { StGotoAssigned () (getTransSpan $1 $3) $2 (Just $3) }+| goto VARIABLE ',' LABELS_IN_STATEMENT { StGotoAssigned () (getTransSpan $1 $4) $2 (Just $4) }+| goto LABELS_IN_STATEMENT EXPRESSION { StGotoComputed () (getTransSpan $1 $3) $2 $3 }+| goto LABELS_IN_STATEMENT ',' EXPRESSION { StGotoComputed () (getTransSpan $1 $4) $2 $4 }++EXPRESSION_ASSIGNMENT_STATEMENT :: { Statement A0 }+: ELEMENT '=' EXPRESSION { StExpressionAssign () (getTransSpan $1 $3) $1 $3 }++NONEXECUTABLE_STATEMENT :: { Statement A0 }+: external FUNCTION_NAMES { StExternal () (getTransSpan $1 $2) (aReverse $2) }+| intrinsic FUNCTION_NAMES { StIntrinsic () (getTransSpan $1 $2) (aReverse $2) }+| dimension INITIALIZED_ARRAY_DECLARATORS { StDimension () (getTransSpan $1 $2) (aReverse $2) }+| common COMMON_GROUPS { StCommon () (getTransSpan $1 $2) (aReverse $2) }+| equivalence EQUIVALENCE_GROUPS { StEquivalence () (getTransSpan $1 $2) (aReverse $2) }+| pointer POINTER_LIST { StPointer () (getTransSpan $1 $2) (fromReverseList $2) }+| data DATA_GROUPS { StData () (getTransSpan $1 $2) (fromReverseList $2) }+| automatic INITIALIZED_DECLARATORS { StAutomatic () (getTransSpan $1 $2) (aReverse $2) }+| static INITIALIZED_DECLARATORS { StStatic () (getTransSpan $1 $2) (aReverse $2) }+-- Following is a fake node to make arbitrary FORMAT statements parsable.+-- Must be fixed in the future. TODO+| format blob+  { let TBlob s blob = $2 in StFormatBogus () (getTransSpan $1 s) blob }+| DECLARATION_STATEMENT { $1 }+| implicit none { StImplicit () (getTransSpan $1 $2) Nothing }+| implicit IMP_LISTS { StImplicit () (getTransSpan $1 $2) $ Just $ aReverse $2 }+| parameter '(' PARAMETER_ASSIGNMENTS ')'+  { StParameter () (getTransSpan $1 $4) $ fromReverseList $3 }+| entry VARIABLE { StEntry () (getTransSpan $1 $2) $2 Nothing Nothing }+| entry VARIABLE ENTRY_ARGS { StEntry () (getTransSpan $1 $3) $2 (Just $3) Nothing }+| include STRING { StInclude () (getTransSpan $1 $2) $2 Nothing }+| structure MAYBE_NAME NEWLINE STRUCTURE_DECLARATIONS endstructure+  { StStructure () (getTransSpan $1 $5) $2 (fromReverseList $4) }++MAYBE_NAME :: { Maybe Name }+: '/' NAME '/' { Just $2 }+| {- empty -}  { Nothing }++STRUCTURE_DECLARATIONS :: { [StructureItem A0] }+: STRUCTURE_DECLARATIONS STRUCTURE_DECLARATION_STATEMENT+  { if isNothing $2 then $1 else fromJust $2 : $1 }+| STRUCTURE_DECLARATION_STATEMENT { if isNothing $1 then [] else [fromJust $1] }++STRUCTURE_DECLARATION_STATEMENT :: { Maybe (StructureItem A0) }+: DECLARATION_STATEMENT NEWLINE+  { let StDeclaration () s t attrs decls = $1+    in Just $ StructFields () s t attrs decls }+| union NEWLINE UNION_MAPS endunion NEWLINE+  { Just $ StructUnion () (getTransSpan $1 $5) (fromReverseList $3) }+| structure MAYBE_NAME NAME NEWLINE STRUCTURE_DECLARATIONS endstructure NEWLINE+  { Just $ StructStructure () (getTransSpan $1 $7) $2 $3 (fromReverseList $5) }+| comment NEWLINE { Nothing }++UNION_MAPS :: { [ UnionMap A0 ] }+: UNION_MAPS UNION_MAP { if isNothing $2 then $1 else fromJust $2 : $1 }+| UNION_MAP { if isNothing $1 then [] else [fromJust $1] }++UNION_MAP :: { Maybe (UnionMap A0) }+: map NEWLINE STRUCTURE_DECLARATIONS endmap NEWLINE+  { Just $ UnionMap () (getTransSpan $1 $5) (fromReverseList $3) }+| comment NEWLINE { Nothing }++ENTRY_ARGS :: { AList Expression A0 }+: ENTRY_ARGS_LEVEL1 ')' { setSpan (getTransSpan $1 $2) $ aReverse $1 }++ENTRY_ARGS_LEVEL1 :: { AList Expression A0 }+: ENTRY_ARGS_LEVEL1 ',' ENTRY_ARG { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }+| '(' ENTRY_ARG { AList () (getTransSpan $1 $2) [ $2 ] }+| '(' { AList () (getSpan $1) [ ] }++ENTRY_ARG :: { Expression A0 }+: VARIABLE { $1 }+| '*' { ExpValue () (getSpan $1) ValStar }++PARAMETER_ASSIGNMENTS :: { [ Declarator A0 ] }+: PARAMETER_ASSIGNMENTS ',' PARAMETER_ASSIGNMENT { $3 : $1 }+| PARAMETER_ASSIGNMENT { [ $1 ] }++PARAMETER_ASSIGNMENT :: { Declarator A0 }+: VARIABLE '=' CONSTANT_EXPRESSION+  { Declarator () (getTransSpan $1 $3) $1 ScalarDecl Nothing (Just $3) }++DECLARATION_STATEMENT :: { Statement A0 }+: TYPE_SPEC maybe(',') INITIALIZED_DECLARATORS+  { StDeclaration () (getTransSpan $1 $3) $1 Nothing (aReverse $3) }++IMP_LISTS :: { AList ImpList A0 }+: IMP_LISTS ',' IMP_LIST { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }+| IMP_LIST { AList () (getSpan $1) [ $1 ] }++IMP_LIST :: { ImpList A0 }+: IMP_TYPE_SPEC '(' IMP_ELEMENTS ')'+  { ImpList () (getTransSpan $1 $4) $1 $ aReverse $3 }++IMP_ELEMENTS :: { AList ImpElement A0 }+: IMP_ELEMENTS ',' IMP_ELEMENT { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }+| IMP_ELEMENT { AList () (getSpan $1) [ $1 ] }++IMP_ELEMENT :: { ImpElement A0 }+: id {% do+      let (TId s id) = $1+      if length id /= 1+      then fail "Implicit argument must be a character."+      else return $ ImpCharacter () s id+     }+| id '-' id {% do+             let (TId _ id1) = $1+             let (TId _ id2) = $3+             if length id1 /= 1 || length id2 /= 1+             then fail "Implicit argument must be a character."+             else return $ ImpRange () (getTransSpan $1 $3) id1 id2+             }++ELEMENT :: { Expression A0 }+: SUBSCRIPT { $1 }++DATA_GROUPS :: { [DataGroup A0] }+: DATA_GROUPS ',' DATA_GROUP { $3 : $1 }+| DATA_GROUPS DATA_GROUP     { $2 : $1 }+| DATA_GROUP                 { [$1] }++DATA_GROUP :: { DataGroup A0 }+: DATA_NAMES  '/' DATA_ITEMS '/' { DataGroup () (getTransSpan $1 $4) (aReverse $1) (aReverse $3) }++DATA_NAMES :: { AList Expression A0 }+: NAME_LIST  { $1 }+| IMPLIED_DO { fromList () [ $1 ] }++DATA_ITEMS :: { AList Expression A0 }+: DATA_ITEMS ',' DATA_ITEM { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1}+| DATA_ITEM { AList () (getSpan $1) [ $1 ] }++DATA_ITEM :: { Expression A0 }+: INTEGER_CONSTANT '*' DATA_ITEM_LEVEL1 { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 }+| DATA_ITEM_LEVEL1 { $1 }++DATA_ITEM_LEVEL1 :: { Expression A0 }+: SIGNED_NUMERIC_LITERAL  { $1 }+-- | COMPLEX_LITERAL         { $1 }+| VARIABLE                { $1 }+| '(' SIGNED_NUMERIC_LITERAL ',' SIGNED_NUMERIC_LITERAL ')' { ExpValue () (getTransSpan $1 $5) (ValComplex $2 $4)}+| LOGICAL_LITERAL         { $1 }+| STRING                  { $1 }+| HOLLERITH               { $1 }++EQUIVALENCE_GROUPS :: { AList (AList Expression) A0 }+: EQUIVALENCE_GROUPS ','  '(' NAME_LIST ')' { setSpan (getTransSpan $1 $5) $ (setSpan (getTransSpan $3 $5) $ aReverse $4) `aCons` $1 }+| '(' NAME_LIST ')' { let s = (getTransSpan $1 $3) in AList () s [ setSpan s $ aReverse $2 ] }++POINTER_LIST :: { [ Declarator A0 ] }+: POINTER_LIST ',' POINTER { $3 : $1 }+| POINTER                  { [ $1 ] }++POINTER :: { Declarator A0 }+: '(' VARIABLE ',' VARIABLE ')'+  { Declarator () (getTransSpan $1 $5) $2 ScalarDecl Nothing (Just $4) }++COMMON_GROUPS :: { AList CommonGroup A0 }+: COMMON_GROUPS COMMON_GROUP { setSpan (getTransSpan $1 $2) $ $2 `aCons` $1 }+| INIT_COMMON_GROUP { AList () (getSpan $1) [ $1 ] }++COMMON_GROUP :: { CommonGroup A0 }+: COMMON_NAME UNINITIALIZED_DECLARATORS { CommonGroup () (getTransSpan $1 $2) (Just $1) $ aReverse $2 }+| '/' '/' UNINITIALIZED_DECLARATORS { CommonGroup () (getTransSpan $1 $3) Nothing $ aReverse $3 }++INIT_COMMON_GROUP :: { CommonGroup A0 }+: COMMON_NAME UNINITIALIZED_DECLARATORS { CommonGroup () (getTransSpan $1 $2) (Just $1) $ aReverse $2 }+| '/' '/' UNINITIALIZED_DECLARATORS { CommonGroup () (getTransSpan $1 $3) Nothing $ aReverse $3 }+| UNINITIALIZED_DECLARATORS { CommonGroup () (getSpan $1) Nothing $ aReverse $1 }++COMMON_NAME :: { Expression A0 }+: '/' VARIABLE '/' { setSpan (getTransSpan $1 $3) $2 }++NAME_LIST :: { AList Expression A0 }+: NAME_LIST ',' ELEMENT+  { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }+| ELEMENT { AList () (getSpan $1) [ $1 ] }++UNINITIALIZED_DECLARATORS :: { AList Declarator A0 }+: UNINITIALIZED_DECLARATORS ',' UNINITIALIZED_DECLARATOR { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }+| UNINITIALIZED_DECLARATOR { AList () (getSpan $1) [ $1 ] }++UNINITIALIZED_DECLARATOR :: { Declarator A0 }+: UNINITIALIZED_ARRAY_DECLARATOR { $1 }+| UNINITIALIZED_VARIABLE_DECLARATOR { $1 }++UNINITIALIZED_ARRAY_DECLARATOR :: { Declarator A0 }+: VARIABLE '(' DIMENSION_DECLARATORS ')'+  { Declarator () (getTransSpan $1 $4) $1 (ArrayDecl (aReverse $3)) Nothing   Nothing }+| VARIABLE '*' SIMPLE_EXPRESSION '(' DIMENSION_DECLARATORS ')'+  { Declarator () (getTransSpan $1 $6) $1 (ArrayDecl (aReverse $5)) (Just $3) Nothing }+| VARIABLE '(' DIMENSION_DECLARATORS ')' '*' SIMPLE_EXPRESSION+  { Declarator () (getTransSpan $1 $6) $1 (ArrayDecl (aReverse $3)) (Just $6) Nothing }++UNINITIALIZED_VARIABLE_DECLARATOR :: { Declarator A0 }+: VARIABLE+  { Declarator () (getSpan $1)         $1 ScalarDecl Nothing   Nothing }+| VARIABLE '*' SIMPLE_EXPRESSION+  { Declarator () (getTransSpan $1 $3) $1 ScalarDecl (Just $3) Nothing }++INITIALIZED_DECLARATORS :: { AList Declarator A0 }+: INITIALIZED_DECLARATORS ',' INITIALIZED_DECLARATOR { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }+| INITIALIZED_DECLARATOR { AList () (getSpan $1) [ $1 ] }++INITIALIZED_DECLARATOR :: { Declarator A0 }+: INITIALIZED_ARRAY_DECLARATOR { $1 }+| INITIALIZED_VARIABLE_DECLARATOR { $1 }++INITIALIZED_ARRAY_DECLARATORS :: { AList Declarator A0 }+: INITIALIZED_ARRAY_DECLARATORS ',' INITIALIZED_ARRAY_DECLARATOR+  { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }+| INITIALIZED_ARRAY_DECLARATOR { AList () (getSpan $1) [ $1 ] }++INITIALIZED_ARRAY_DECLARATOR :: { Declarator A0 }+: UNINITIALIZED_ARRAY_DECLARATOR { $1 }+| VARIABLE '(' DIMENSION_DECLARATORS ')' '/' SIMPLE_EXPRESSION_LIST '/'+  { Declarator () (getTransSpan $1 $7) $1 (ArrayDecl (aReverse $3))  Nothing+    (Just (ExpInitialisation () (getSpan $6) (fromReverseList $6))) }+| VARIABLE '*' SIMPLE_EXPRESSION '(' DIMENSION_DECLARATORS ')' '/' SIMPLE_EXPRESSION_LIST '/'+  { Declarator () (getTransSpan $1 $9) $1 (ArrayDecl (aReverse $5)) (Just $3)+    (Just (ExpInitialisation () (getSpan $8) (fromReverseList $8))) }+| VARIABLE '(' DIMENSION_DECLARATORS ')' '*' SIMPLE_EXPRESSION '/' SIMPLE_EXPRESSION_LIST '/'+  { Declarator () (getTransSpan $1 $9) $1 (ArrayDecl (aReverse $3)) (Just $6)+    (Just (ExpInitialisation () (getSpan $8) (fromReverseList $8))) }++INITIALIZED_VARIABLE_DECLARATOR :: { Declarator A0 }+: UNINITIALIZED_VARIABLE_DECLARATOR { $1 }+| VARIABLE '/' SIMPLE_EXPRESSION '/'+  { Declarator () (getTransSpan $1 $4) $1 ScalarDecl Nothing   (Just $3) }+| VARIABLE '*' SIMPLE_EXPRESSION '/' SIMPLE_EXPRESSION '/'+  { Declarator () (getTransSpan $1 $6) $1 ScalarDecl (Just $3) (Just $5) }++SIMPLE_EXPRESSION_LIST :: { [Expression A0] }+: SIMPLE_EXPRESSION_LIST ',' SIMPLE_EXPRESSION  { $3 : $1 }+| SIMPLE_EXPRESSION { [ $1 ] }++SIMPLE_EXPRESSION :: { Expression A0 }+: INTEGER_CONSTANT '*' CONSTANT  { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 }+| CONSTANT { $1 }+| '(' '*' ')' { ExpValue () (getSpan $2) ValStar }+| '(' EXPRESSION ')' { $2 }++CONSTANT :: { Expression A0 }+: VARIABLE { $1 }+| SIGNED_NUMERIC_LITERAL { $1 }+| LOGICAL_LITERAL { $1 }+| STRING { $1 }+| HOLLERITH { $1 }++INTEGER_CONSTANT :: { Expression A0 }+: VARIABLE { $1 }+| SIGNED_NUMERIC_LITERAL { $1 }++DIMENSION_DECLARATORS :: { AList DimensionDeclarator A0 }+: DIMENSION_DECLARATORS ',' DIMENSION_DECLARATOR+  { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }+| DIMENSION_DECLARATOR { AList () (getSpan $1) [ $1 ] }++DIMENSION_DECLARATOR :: { DimensionDeclarator A0 }+: EXPRESSION ':' EXPRESSION { DimensionDeclarator () (getTransSpan $1 $3) (Just $1) (Just $3) }+| EXPRESSION { DimensionDeclarator () (getSpan $1) Nothing (Just $1) }+| EXPRESSION ':' '*' { DimensionDeclarator () (getTransSpan $1 $3) (Just $1) (Just $ ExpValue () (getSpan $3) ValStar) }+| '*' { DimensionDeclarator () (getSpan $1) Nothing (Just $ ExpValue () (getSpan $1) ValStar) }++-- Here the procedure should be either a function or subroutine name, but+-- since they are syntactically identical at this stage subroutine names+-- are also emitted as function names.+FUNCTION_NAMES :: { AList Expression A0 }+: FUNCTION_NAMES ',' VARIABLE { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }+| VARIABLE { AList () (getSpan $1) [ $1 ] }++ARGUMENTS :: { AList Argument A0 }+: ARGUMENTS_LEVEL1 ')' { setSpan (getTransSpan $1 $2) $ aReverse $1 }++ARGUMENTS_LEVEL1 :: { AList Argument A0 }+: ARGUMENTS_LEVEL1 ',' CALLABLE_EXPRESSION { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }+| '(' CALLABLE_EXPRESSION { AList () (getTransSpan $1 $2) [ $2 ] }+| '(' { AList () (getSpan $1) [ ] }++-- Expression all by itself subsumes all other callable expressions.+CALLABLE_EXPRESSION :: { Argument A0 }+-- Explicitly parse special intrinsics for argument passing types+: '%' id '(' EXPRESSION ')'+  { let { args = AList () (getSpan $4) $ [Argument () (getSpan $4) Nothing (ArgExpr $4)];+          TId _ name = $2;+          intr = ExpFunctionCall () (getTransSpan $1 $5)+                   (ExpValue () (getTransSpan $1 $2) (ValIntrinsic ('%':name)))+                   (Just args) }+    in Argument () (getTransSpan $1 $5) Nothing (ArgExpr intr) }+| id '=' EXPRESSION+  { let TId span keyword = $1+    in Argument () (getTransSpan span $3) (Just keyword) (ArgExpr $3) }+| '(' VARIABLE ')'+  { let ExpValue _ _ (ValVariable v) = $2+     in Argument () (getTransSpan $1 $3) Nothing (ArgExprVar () (getSpan $2) v) }+| EXPRESSION  { Argument () (getSpan $1) Nothing (ArgExpr $1) }++EXPRESSION :: { Expression A0 }+: EXPRESSION '+' EXPRESSION { ExpBinary () (getTransSpan $1 $3) Addition $1 $3 }+| EXPRESSION '-' EXPRESSION { ExpBinary () (getTransSpan $1 $3) Subtraction $1 $3 }+| EXPRESSION '*' EXPRESSION { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 }+| EXPRESSION '/' EXPRESSION { ExpBinary () (getTransSpan $1 $3) Division $1 $3 }+| EXPRESSION '**' EXPRESSION { ExpBinary () (getTransSpan $1 $3) Exponentiation $1 $3 }+| EXPRESSION '/' '/' EXPRESSION %prec CONCAT { ExpBinary () (getTransSpan $1 $4) Concatenation $1 $4 }+| ARITHMETIC_SIGN EXPRESSION %prec NEGATION { ExpUnary () (getTransSpan (fst $1) $2) (snd $1) $2 }+| EXPRESSION or EXPRESSION { ExpBinary () (getTransSpan $1 $3) Or $1 $3 }+| EXPRESSION xor EXPRESSION { ExpBinary () (getTransSpan $1 $3) XOr $1 $3 }+| EXPRESSION and EXPRESSION { ExpBinary () (getTransSpan $1 $3) And $1 $3 }+| not EXPRESSION { ExpUnary () (getTransSpan $1 $2) Not $2 }+| EXPRESSION eqv EXPRESSION { ExpBinary () (getTransSpan $1 $3) Equivalent $1 $3 }+| EXPRESSION neqv EXPRESSION { ExpBinary () (getTransSpan $1 $3) NotEquivalent $1 $3 }+| EXPRESSION RELATIONAL_OPERATOR EXPRESSION %prec RELATIONAL { ExpBinary () (getTransSpan $1 $3) $2 $1 $3 }+| '(' EXPRESSION ')' { setSpan (getTransSpan $1 $3) $2 }+| NUMERIC_LITERAL                   { $1 }+| '(' EXPRESSION ',' EXPRESSION ')' { ExpValue () (getTransSpan $1 $5) (ValComplex $2 $4) }+| LOGICAL_LITERAL                   { $1 }+| HOLLERITH                         { $1 }+-- There should be FUNCTION_CALL here but as far as the parser is concerned it is same as SUBSCRIPT,+-- hence putting it here would cause a reduce/reduce conflict.+| SUBSCRIPT                         { $1 }+| IMPLIED_DO                        { $1 }+| '(/' EXPRESSION_LIST '/)' {+    let { exps = reverse $2;+          expList = AList () (getSpan exps) exps }+    in ExpInitialisation () (getTransSpan $1 $3) expList+          }+| '*' INTEGER_LITERAL { ExpReturnSpec () (getTransSpan $1 $2) $2 }+| '&' INTEGER_LITERAL { ExpReturnSpec () (getTransSpan $1 $2) $2 }++IMPLIED_DO :: { Expression A0 }+: '(' EXPRESSION ',' DO_SPECIFICATION ')' {+    let expList = AList () (getSpan $2) [ $2 ]+          in ExpImpliedDo () (getTransSpan $1 $5) expList $4+         }+| '(' EXPRESSION ',' EXPRESSION ',' DO_SPECIFICATION ')' {+    let expList = AList () (getTransSpan $2 $4) [ $2, $4 ]+          in ExpImpliedDo () (getTransSpan $1 $5) expList $6+         }+| '(' EXPRESSION ',' EXPRESSION ',' EXPRESSION_LIST ',' DO_SPECIFICATION ')' {+    let { exps =  reverse $6;+          expList = AList () (getTransSpan $2 exps) ($2 : $4 : reverse $6) }+    in ExpImpliedDo () (getTransSpan $1 $9) expList $8+         }++EXPRESSION_LIST :: { [ Expression A0 ] }+: EXPRESSION_LIST ',' EXPRESSION { $3 : $1 }+| EXPRESSION { [ $1 ] }++STRING :: { Expression A0 } : string { let (TString s cs) = $1 in ExpValue () s (ValString cs) }++CONSTANT_EXPRESSION :: { Expression A0 }+: CONSTANT_EXPRESSION '+' CONSTANT_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Addition $1 $3 }+| CONSTANT_EXPRESSION '-' CONSTANT_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Subtraction $1 $3 }+| CONSTANT_EXPRESSION '*' CONSTANT_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 }+| CONSTANT_EXPRESSION '/' CONSTANT_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Division $1 $3 }+| CONSTANT_EXPRESSION '**' CONSTANT_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Exponentiation $1 $3 }+| CONSTANT_EXPRESSION '/' '/' CONSTANT_EXPRESSION %prec CONCAT { ExpBinary () (getTransSpan $1 $4) Concatenation $1 $4 }+| ARITHMETIC_SIGN CONSTANT_EXPRESSION %prec NEGATION { ExpUnary () (getTransSpan (fst $1) $2) (snd $1) $2 }+| CONSTANT_EXPRESSION or CONSTANT_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Or $1 $3 }+| CONSTANT_EXPRESSION xor CONSTANT_EXPRESSION { ExpBinary () (getTransSpan $1 $3) XOr $1 $3 }+| CONSTANT_EXPRESSION and CONSTANT_EXPRESSION { ExpBinary () (getTransSpan $1 $3) And $1 $3 }+| not CONSTANT_EXPRESSION { ExpUnary () (getTransSpan $1 $2) Not $2 }+| CONSTANT_EXPRESSION RELATIONAL_OPERATOR CONSTANT_EXPRESSION %prec RELATIONAL { ExpBinary () (getTransSpan $1 $3) $2 $1 $3 }+| '(' CONSTANT_EXPRESSION ')' { setSpan (getTransSpan $1 $3) $2 }+| NUMERIC_LITERAL               { $1 }+| '(' CONSTANT_EXPRESSION ',' CONSTANT_EXPRESSION ')' { ExpValue () (getTransSpan $1 $5) (ValComplex $2 $4)}+| LOGICAL_LITERAL               { $1 }+| SUBSCRIPT                    { $1 }+| HOLLERITH                    { $1 }+| '(/' EXPRESSION_LIST '/)' {+    let { exps = reverse $2;+          expList = AList () (getSpan exps) exps }+    in ExpInitialisation () (getTransSpan $1 $3) expList+          }++ARITHMETIC_CONSTANT_EXPRESSION :: { Expression A0 }+: ARITHMETIC_CONSTANT_EXPRESSION '+' ARITHMETIC_CONSTANT_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Addition $1 $3 }+| ARITHMETIC_CONSTANT_EXPRESSION '-' ARITHMETIC_CONSTANT_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Subtraction $1 $3 }+| ARITHMETIC_CONSTANT_EXPRESSION '*' ARITHMETIC_CONSTANT_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 }+| ARITHMETIC_CONSTANT_EXPRESSION '/' ARITHMETIC_CONSTANT_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Division $1 $3 }+| ARITHMETIC_CONSTANT_EXPRESSION '**' ARITHMETIC_CONSTANT_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Exponentiation $1 $3 }+| ARITHMETIC_SIGN ARITHMETIC_CONSTANT_EXPRESSION %prec NEGATION { ExpUnary () (getTransSpan (fst $1) $2) (snd $1) $2 }+| '(' ARITHMETIC_CONSTANT_EXPRESSION ')' { setSpan (getTransSpan $1 $3) $2 }+| NUMERIC_LITERAL               { $1 }+| '(' ARITHMETIC_CONSTANT_EXPRESSION ',' ARITHMETIC_CONSTANT_EXPRESSION ')' { ExpValue () (getTransSpan $1 $5) (ValComplex $2 $4)}+| VARIABLE                     { $1 }+| SUBSCRIPT                    { $1 }++RELATIONAL_OPERATOR :: { BinaryOp }+: '=='  { EQ }+| '!='  { NE }+| '>'   { GT }+| '>='  { GTE }+| '<'   { LT }+| '<='  { LTE }++SUBSCRIPT :: { Expression A0 }+: SUBSCRIPT '.' VARIABLE+  { ExpDataRef () (getTransSpan $1 $3) $1 $3 }+| SUBSCRIPT '%' VARIABLE+  { ExpDataRef () (getTransSpan $1 $3) $1 $3 }+| SUBSCRIPT '(' ')'+  { ExpFunctionCall () (getTransSpan $1 $3) $1 Nothing }+| SUBSCRIPT '(' INDICIES ')'+  { ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3) }+| VARIABLE { $1 }+| STRING { $1 }++INDICIES :: { [ Index A0 ] }+: INDICIES ',' INDEX { $3 : $1 }+| INDEX { [ $1 ] }++INDEX :: { Index A0 }+: RANGE { $1 }+| EXPRESSION { IxSingle () (getSpan $1) Nothing $1 }++RANGE :: { Index A0 }+: ':' { IxRange () (getSpan $1) Nothing Nothing Nothing }+| ':' EXPRESSION { IxRange () (getTransSpan $1 $2) Nothing (Just $2) Nothing }+| EXPRESSION ':' { IxRange () (getTransSpan $1 $2) (Just $1) Nothing Nothing }+| EXPRESSION ':' EXPRESSION+  { IxRange () (getTransSpan $1 $3) (Just $1) (Just $3) Nothing }++ARITHMETIC_SIGN :: { (SrcSpan, UnaryOp) }+: '-' { (getSpan $1, Minus) }+| '+' { (getSpan $1, Plus) }++MAYBE_VARIABLES :: { Maybe (AList Expression A0) }+: VARIABLES { Just $ fromReverseList $1 } | {- EMPTY -} { Nothing }++VARIABLES :: { [ Expression A0 ] }+: VARIABLES ',' VARIABLE_OR_STAR { $3 : $1 }+| VARIABLE_OR_STAR { [ $1 ] }++VARIABLE_OR_STAR :: { Expression A0 }+: VARIABLE { $1 }+| '*' { ExpValue () (getSpan $1) ValStar }+| '&' { ExpValue () (getSpan $1) ValStar }++-- This may also be used to parse a function name, or an array name. Since when+-- are valid options in a production there is no way of differentiating them at+-- this stage.+-- This at least reduces reduce/reduce conflicts.+VARIABLE :: { Expression A0 }+: id { ExpValue () (getSpan $1) $ let (TId _ s) = $1 in ValVariable s }++INTEGER_LITERAL :: { Expression A0 }+: int { ExpValue () (getSpan $1) $ let (TInt _ i) = $1 in ValInteger i Nothing}+| boz { let TBozLiteral s b = $1 in ExpValue () s $ ValBoz b }++REAL_LITERAL :: { Expression A0 }+: int EXPONENT { makeRealLit (Just $1) Nothing Nothing (Just $2) }+| int '.' MAYBE_EXPONENT { makeRealLit (Just $1) (Just $2) Nothing $3 }+| '.' int MAYBE_EXPONENT { makeRealLit Nothing (Just $1) (Just $2) $3 }+| int '.' int MAYBE_EXPONENT { makeRealLit (Just $1) (Just $2) (Just $3) $4 }++MAYBE_EXPONENT :: { Maybe (SrcSpan, String) }+: EXPONENT { Just $1 }+| {-EMPTY-} { Nothing }++EXPONENT :: { (SrcSpan, String) }+: exponent { let (TExponent s exp) = $1 in (s, exp) }++SIGNED_NUMERIC_LITERAL :: { Expression A0 }+: ARITHMETIC_SIGN NUMERIC_LITERAL { ExpUnary () (getTransSpan (fst $1) $2) Minus $2 }+| NUMERIC_LITERAL { $1 }++NUMERIC_LITERAL :: { Expression A0 }+: INTEGER_LITERAL { $1 }+| REAL_LITERAL { $1 }++LOGICAL_LITERAL :: { Expression A0 }+: bool { let TBool s b = $1 in ExpValue () s $ ValLogical b Nothing }++HOLLERITH :: { Expression A0 } : hollerith { ExpValue () (getSpan $1) $ let (THollerith _ h) = $1 in ValHollerith h }++LABELS_IN_STATEMENT :: { AList Expression A0 }+: LABELS_IN_STATEMENT_LEVEL1 ')' { setSpan (getTransSpan $1 $2) $ aReverse $1 }++LABELS_IN_STATEMENT_LEVEL1 :: { AList Expression A0 }+: LABELS_IN_STATEMENT_LEVEL1 ',' LABEL_IN_STATEMENT { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }+| '(' LABEL_IN_STATEMENT { AList () (getTransSpan $1 $2) [ $2 ] }++-- Labels that occur in the first 6 columns+LABEL_IN_6COLUMN :: { Expression A0 } : label { ExpValue () (getSpan $1) (let (TLabel _ l) = $1 in ValInteger l Nothing) }++-- Labels that occur in statements+LABEL_IN_STATEMENT :: { Expression A0 } : int { ExpValue () (getSpan $1) (let (TInt _ l) = $1 in ValInteger l Nothing) }++TYPE_SPEC :: { TypeSpec A0 }+: integer   KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeInteger $2 }+| real      KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeReal $2  }+| doublePrecision         { TypeSpec () (getSpan $1)       TypeDoublePrecision Nothing}+| logical   KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeLogical $2 }+| complex   KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeComplex $2 }+| doubleComplex           { TypeSpec () (getSpan $1)       TypeDoubleComplex Nothing}+| character CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeCharacter $2 }+| byte      KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeByte $2 }+| record    '/' NAME '/'  { TypeSpec () (getSpan ($1, $4)) (TypeCustom $3) Nothing }++KIND_SELECTOR :: { Maybe (Selector A0) }+: KIND_SELECTOR1 { Just $1 }+| {- EMPTY -}    { Nothing }++KIND_SELECTOR1 :: { Selector A0 }+: '*' ARITHMETIC_CONSTANT_EXPRESSION+  { Selector () (getTransSpan $1 $2) Nothing (Just $2) }+| '*' '(' STAR ')' { Selector () (getTransSpan $1 $4) Nothing (Just $3) }++CHAR_SELECTOR :: { Maybe (Selector A0) }+: CHAR_SELECTOR1 { Just $1 }+| {- EMPTY -}    { Nothing }++CHAR_SELECTOR1 :: { Selector A0 }+: '*' ARITHMETIC_CONSTANT_EXPRESSION+  { Selector () (getTransSpan $1 $2) (Just $2) Nothing }+| '*' '(' STAR ')'+  { Selector () (getTransSpan $1 $4) (Just $3) Nothing }++IMP_TYPE_SPEC :: { TypeSpec A0 }+: TYPE_SPEC  { $1 }++STAR :: { Expression A0 }+STAR : '*' { ExpValue () (getSpan $1) ValStar }

@@ -0,0 +1,1126 @@+-- -*- Mode: Haskell -*-+-- vim: ft=haskell+{+{-# LANGUAGE UndecidableInstances #-}++module Language.Fortran.Parser.Fixed.Lexer+  (+  -- * Main interface+    lexer, Token(..), vanillaAlexInput, AlexInput(..), LexAction++  -- * Exposed internals for testing+  , lexN+  , lexemeMatch+  , lexer'+  ) where++import Data.Word (Word8)+import Data.Char (toLower, ord, isDigit)+import Data.List (isPrefixOf)+import Data.Maybe (fromJust, isNothing, isJust)+import Data.Data+import qualified Data.Bits+import qualified Data.ByteString.Char8 as B++import Control.Monad.State++import GHC.Generics++import Language.Fortran.Parser.Monad+import Language.Fortran.Version+import Language.Fortran.Util.FirstParameter+import Language.Fortran.Util.Position+import Language.Fortran.Parser.LexerUtils ( readIntOrBoz )+import Language.Fortran.AST.Boz++}++$digit      = 0-9+$bit        = 0-1+$octalDigit = 0-7+$hexDigit   = [a-f $digit]++$hash = [\#]++@binary = b\'$bit+\' | \'$bit+\'b+@octal  = o\'$octalDigit+\' | \'$octalDigit+\'o+@hex    = [xz]\'$hexDigit+\' | \'$hexDigit+\'[xz]++$letter = a-z+$alphanumeric = [$letter $digit]+$alphanumericExtended = [$letter $digit \_]+$special = [\ \=\+\-\*\/\(\)\,\.\$]++-- This should really be 6 characters but there are many standard non-compliant+-- programs out there.+@idExtended = $letter $alphanumericExtended{0,9} $alphanumericExtended{0,9} $alphanumericExtended{0,9} $alphanumericExtended?+@id = $letter $alphanumeric{0,5}+@label = $digit{1,5}++@idLegacy = [$letter \_] [$alphanumericExtended \$]*++@datatype = "integer" | "real" | "doubleprecision" | "complex" | "logical"+          -- legacy extensions+          | "byte"++-- Numbers+@integerConst = $digit++@posIntegerConst = [1-9] $digit*+@bozLiteralConst = (@binary|@octal|@hex)++-- For reals+@exponent = [ed] [\+\-]? @integerConst++-- For format items+@repeat = @posIntegerConst?+@width = @posIntegerConst++tokens :-++  <0> [c!\*d] / { commentP }                  { lexComment }+  "!" / { bangCommentP &&& legacy77P }        { lexComment }+  <0> @label / { withinLabelColsP }           { addSpanAndMatch TLabel }+  <0> . / { \_ ai _ _ -> atColP 6 ai }        { toSC keyword }+  <0> " "                                     ;++  <0> $hash                                   { lexHash }++  <0,st,keyword,iif,assn,doo> \n              { resetPar >> toSC 0 >> addSpan TNewline }+  <0,st,keyword,iif,assn,doo> \r              ;++  <st,keyword,iif,assn,doo> ";"               { resetPar >> toSC keyword >> addSpan TNewline }++  <st> "("                                    { addSpan TLeftPar }+  <keyword> "(" / { legacy77P }               { addSpan TLeftPar }+  <iif> "("                                   { incPar >> addSpan TLeftPar }+  <st> ")"                                    { addSpan TRightPar }+  <keyword> ")" / { legacy77P }               { typeSCChange >> addSpan TRightPar }+  <iif> ")"                                   { maybeToKeyword >> addSpan TRightPar }+  <st,iif> "(/" / { formatExtendedP }         { addSpan TLeftArrayPar }+  <st,iif> "/)" / { formatExtendedP }         { addSpan TRightArrayPar }+  <st,iif,doo,keyword> ","                    { addSpan TComma }+  <st,iif,keyword> "."                        { addSpan TDot }+  <st,iif,keyword> "%"                        { addSpan TPercent }+  <keyword> "." / { legacy77P }               { addSpan TDot }+  <st,iif> ":" / { fortran77P }               { addSpan TColon }++  <keyword> @id / { idP }                     { toSC st >> addSpanAndMatch TId }+  <keyword> @idExtended / { extendedIdP }     { toSC st >> addSpanAndMatch TId }+  <keyword> @idLegacy / { legacyIdP }         { toSC st >> addSpanAndMatch TId }++  <keyword> "include" / { extended77P }       { toSC st >> addSpan TInclude }++  -- Tokens related to procedures and subprograms+  <keyword> "program"                         { toSC st >> addSpan TProgram }+  <keyword> "function" / { functionP }        { toSC st >> addSpan TFunction  }+  <keyword> "subroutine"                      { toSC st >> addSpan TSubroutine  }+  <keyword> "blockdata"                       { toSC st >> addSpan TBlockData  }+  <keyword> "structure"    / { legacy77P }    { toSC st >> addSpan TStructure  }+  <keyword> "union"        / { legacy77P }    { toSC st >> addSpan TUnion  }+  <keyword> "map"          / { legacy77P }    { toSC st >> addSpan TMap  }+  <keyword> "endstructure" / { legacy77P }    { toSC st >> addSpan TEndStructure  }+  <keyword> "endunion"     / { legacy77P }    { toSC st >> addSpan TEndUnion  }+  <keyword> "endmap"       / { legacy77P }    { toSC st >> addSpan TEndMap  }+  <keyword> "record"       / { legacy77P }    { toSC st >> addSpan TRecord  }+  <keyword> "end"                             { toSC st >> addSpan TEnd  }+  <keyword> "endprogram"    / { legacy77P }   { toSC st >> addSpan TEndProgram  }+  <keyword> "endfunction"   / { legacy77P }   { toSC st >> addSpan TEndFunction  }+  <keyword> "endsubroutine" / { legacy77P }   { toSC st >> addSpan TEndSubroutine  }++  -- Tokens related to assignment statements+  <keyword> "assign"                          { toSC assn >> addSpan TAssign  }+  <assn> @integerConst                        { addSpanAndMatch TInt }+  <assn> "to"                                 { addSpan TTo  }+  <assn> @id / { notToP }             { addSpanAndMatch TId }+  <assn> @idExtended / { notToP &&& extended77P } { addSpanAndMatch TId }+  <assn> @idLegacy / { notToP &&& legacy77P } { addSpanAndMatch TId }+  <st,iif> "="                                { addSpan TOpAssign  }++  -- Tokens related to control statements+  <keyword> "goto"                            { toSC st >> addSpan TGoto  }+  <keyword> "if" / { ifP }                    { toSC iif >> addSpan TIf  }+  <st,keyword> "then" / { fortran77P }        { toSC keyword >> addSpan TThen  }+  <keyword> "else" / {fortran77P }            { addSpan TElse  }+  <keyword> "elseif" / {fortran77P }          { toSC st >> addSpan TElsif  }+  <keyword> "endif" / {fortran77P }           { addSpan TEndif  }+  <keyword> "call"                            { toSC st >> addSpan TCall  }+  <keyword> "return"                          { toSC st >> addSpan TReturn  }+  <keyword> "save" / { fortran77P }           { toSC st >> addSpan TSave  }+  <keyword> "continue"                        { toSC st >> addSpan TContinue  }+  <keyword> "stop"                            { toSC st >> addSpan TStop  }+  <keyword> "exit" / { extended77P }          { toSC st >> addSpan TExit  }+  <keyword> "cycle" / { legacy77P }           { toSC st >> addSpan TCycle  }+  <keyword> "case" / { legacy77P }            { toSC st >> addSpan TCase  }+  <keyword> "casedefault" / { legacy77P }     { toSC st >> addSpan TCaseDefault  }+  <keyword> "selectcase" / { legacy77P }      { toSC st >> addSpan TSelectCase  }+  <keyword> "endselect" / { legacy77P }       { toSC st >> addSpan TEndSelect  }+  <keyword> "pause"                           { toSC st >> addSpan TPause  }+  <keyword> "dowhile" / { extended77P }       { toSC st >> addSpan TDoWhile }+  <keyword> "enddo" / { extended77P }         { toSC st >> addSpan TEndDo  }+  <keyword> "do"                              { toSC doo >> addSpan TDo }+  <doo> @integerConst                         { addSpanAndMatch TInt }+  <doo> "while" / { extended77P }             { toSC st >> addSpan TWhile }+  <doo> @id                                   { toSC st >> addSpanAndMatch TId }+  <doo> @idExtended / { extended77P }         { toSC st >> addSpanAndMatch TId }+  <doo> @idLegacy / { legacy77P }             { toSC st >> addSpanAndMatch TId }++  -- Tokens related to I/O statements+  <keyword> "read"                            { toSC st >> addSpan TRead  }+  <keyword> "write"                           { toSC st >> addSpan TWrite  }+  <keyword> "rewind"                          { toSC st >> addSpan TRewind  }+  <keyword> "backspace"                       { toSC st >> addSpan TBackspace  }+  <keyword> "endfile"                         { toSC st >> addSpan TEndfile  }+  <keyword> "inquire" / { fortran77P }        { toSC st >> addSpan TInquire  }+  <keyword> "open" / { fortran77P }           { toSC st >> addSpan TOpen  }+  <keyword> "close" / { fortran77P }          { toSC st >> addSpan TClose  }+  <keyword> "print" / { fortran77P }          { toSC st >> addSpan TPrint  }+  <keyword> "type" / { legacy77P }            { toSC st >> addSpan TTypePrint  }++  -- Tokens related to non-executable statements++  -- Tokens related to speification statements+  <keyword> "dimension"                       { toSC st >> addSpan TDimension  }+  <keyword> "common"                          { toSC st >> addSpan TCommon  }+  <keyword> "equivalence"                     { toSC st >> addSpan TEquivalence  }+  <keyword> "external"                        { toSC st >> addSpan TExternal  }+  <keyword> "intrinsic" / { fortran77P }      { toSC st >> addSpan TIntrinsic  }+  <keyword> @datatype                         { typeSCChange >> addSpanAndMatch TType }+  <st> @datatype / { implicitStP }            { addSpanAndMatch TType }++  <keyword> "doublecomplex" / { extended77P } { typeSCChange >> addSpanAndMatch TType }+  <st> "doublecomplex" / { implicitTypeExtendedP }  { addSpanAndMatch TType }+  <keyword> "character" / { fortran77P }      { typeSCChange >> addSpanAndMatch TType }+  <st> "character" / { implicitType77P }      { addSpanAndMatch TType }+  <keyword> "implicit" / { fortran77P }       { toSC st >> addSpan TImplicit  }+  <st> "none" / { implicitType77P }           { addSpan TNone  }+  <keyword> "parameter" / { fortran77P }      { toSC st >> addSpan TParameter  }+  <keyword> "entry" / { fortran77P }          { toSC st >> addSpan TEntry  }+  <keyword> "pointer" / { legacy77P }         { toSC st >> addSpan TPointer  }++  -- Tokens related to data initalization statement+  <keyword> "data"                            { toSC st >> addSpan TData  }+  <keyword> "automatic" / { legacy77P }       { toSC st >> addSpan TAutomatic  }+  <keyword> "static" / { legacy77P }          { toSC st >> addSpan TStatic }++  -- Tokens related to format statement+  <keyword> "format"                          { toSC fmt >> enterFormat >> addSpan TFormat  }+  <fmt> "(".*")"                              { toSC st >> exitFormat >> addSpanAndMatch TBlob }++  -- Tokens needed to parse integers, reals, double precision and complex+  -- constants+  <st,iif> @exponent / { exponentP }          { addSpanAndMatch TExponent }+  <st,iif> @integerConst                      { addSpanAndMatch TInt }+    -- can be part (end) of function type declaration+  <keyword> @integerConst                     { typeSCChange >> addSpanAndMatch TInt }+  <st,iif,keyword> @bozLiteralConst / { legacy77P } { addSpanAndMatch $ \ss s -> TBozLiteral ss (parseBoz s) }++  -- String+  <st,iif> \' / { fortran77P }                { strAutomaton '\'' 0 }+  <st,iif> \" / { legacy77P }                 { strAutomaton '"'  0 }++  -- Logicals+  <st,iif> ".true."                           { addSpan (\s -> TBool s True)  }+  <st,iif> ".false."                          { addSpan (\s -> TBool s False) }++  -- Arithmetic operators+  <st,iif> "+"                                { addSpan TOpPlus  }+  <st,iif> "-"                                { addSpan TOpMinus  }+  <st,iif> "**"                               { addSpan TOpExp  }+  <st,iif> "*"                                { addSpan TStar  }+    -- can be part of function type declaration+  <keyword> "*" / { legacy77P }               { addSpan TStar  }+  <st,iif> "/"                                { addSpan TSlash  }+  <st,iif> "&" / { legacy77P }                { addSpan TAmpersand  }++  -- Logical operators+  <st,iif> ".or."                             { addSpan TOpOr  }+  <st,iif> ".and."                            { addSpan TOpAnd  }+  <st,iif> ".not."                            { addSpan TOpNot  }+  <st,iif> ".xor." / { legacy77P }            { addSpan TOpXOr  }+  <st,iif> ".eqv." / { fortran77P }           { addSpan TOpEquivalent  }+  <st,iif> ".neqv." / { fortran77P }          { addSpan TOpNotEquivalent  }++  -- Relational operators+  <st,iif> "<" / { extended77P }              { addSpan TOpLT  }+  <st,iif> "<=" / { extended77P }             { addSpan TOpLE  }+  <st,iif> "==" / { extended77P }             { addSpan TOpEQ  }+  <st,iif> "/=" / { extended77P }             { addSpan TOpNE  }+  <st,iif> ">" / { extended77P }              { addSpan TOpGT  }+  <st,iif> ">=" / { extended77P }             { addSpan TOpGE  }+  <st,iif> ".lt."                             { addSpan TOpLT  }+  <st,iif> ".le."                             { addSpan TOpLE  }+  <st,iif> ".eq."                             { addSpan TOpEQ  }+  <st,iif> ".ne."                             { addSpan TOpNE  }+  <st,iif> ".gt."                             { addSpan TOpGT  }+  <st,iif> ".ge."                             { addSpan TOpGE  }++  -- ID+  <st,iif> @id                                { addSpanAndMatch TId }+  <st,iif> @idExtended / { extended77P }      { addSpanAndMatch TId }+  <st,iif> @idLegacy / { legacy77P }          { addSpanAndMatch TId }++  -- Strings+  <st> @posIntegerConst "h" / { fortran66P }  { lexHollerith }+  <st,iif> @posIntegerConst "h" / { hollerithP &&& legacy77P } { lexHollerith }++{++--------------------------------------------------------------------------------+-- Predicated lexer helpers+--------------------------------------------------------------------------------++(&&&) :: (FortranVersion -> AlexInput -> Int -> AlexInput -> Bool)+      -> (FortranVersion -> AlexInput -> Int -> AlexInput -> Bool)+      -> (FortranVersion -> AlexInput -> Int -> AlexInput -> Bool)+f &&& g = \ fv ai1 i ai2 -> f fv ai1 i ai2 && g fv ai1 i ai2++formatExtendedP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool+formatExtendedP fv _ _ ai = fv `elem` [Fortran77Extended, Fortran77Legacy] &&+  case xs of+    [ TFormat _, _ ] -> False+    [ TLabel _ _, TFormat _ ] -> False+    _ -> True+  where+    xs = take 2 . reverse . aiPreviousTokensInLine $ ai++implicitType77P :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool+implicitType77P fv b c d = fortran77P fv b c d && implicitStP fv b c d++implicitTypeExtendedP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool+implicitTypeExtendedP fv b c d = extended77P fv b c d && implicitStP fv b c d++implicitStP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool+implicitStP _ _ _ ai = checkPreviousTokensInLine f ai+  where+    f (TImplicit _) = True+    f _ = False++extendedIdP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool+extendedIdP fv a b ai = fv `elem` [Fortran77Extended, Fortran77Legacy] && idP fv a b ai++legacyIdP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool+legacyIdP fv a b ai = fv == Fortran77Legacy && idP fv a b ai++idP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool+idP fv ao i ai = not (doP fv ai) && not (ifP fv ao i ai)+             && (equalFollowsP fv ai || rParFollowsP fv ai)++doP :: FortranVersion -> AlexInput -> Bool+doP fv ai = isPrefixOf "do" (reverse . lexemeMatch . aiLexeme $ ai) &&+    case unParse (lexer $ f (0::Integer)) ps of+      ParseOk True _ -> True+      _ -> False+  where+    ps = ParseState+      { psAlexInput = ai { aiStartCode = st}+      , psVersion = fv+      , psFilename = "<unknown>"+      , psParanthesesCount = ParanthesesCount 0 False+      , psContext = [ ConStart ] }+    f 0 t =+      case t of+        TNewline{} -> return False+        TEOF{} -> return False+        TLeftPar{} -> lexer $ f 1+        TComma{} -> return True+        _ -> lexer $ f 0+    f !n t =+      case t of+        TLeftPar{} -> lexer $ f (n+1)+        TRightPar{} -> lexer $ f (n-1)+        _ -> lexer $ f n++ifP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool+ifP fv _ _ ai = "if" == (reverse . lexemeMatch . aiLexeme $ ai) &&+    case unParse (lexer $ f) ps of+      ParseOk True _ -> True+      _ -> False+  where+    ps = ParseState+      { psAlexInput = ai { aiStartCode = st}+      , psVersion = fv+      , psFilename = "<unknown>"+      , psParanthesesCount = ParanthesesCount 0 False+      , psContext = [ ConStart ] }+    f t =+      case t of+        -- IF is always followed by (+        TLeftPar{} -> return True+        _ -> return False++functionP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool+functionP fv _ _ ai = "function" == (reverse . lexemeMatch . aiLexeme $ ai) &&+    case unParse (lexer $ f) ps of+      ParseOk True _ -> True+      _ -> False+  where+    ps = ParseState+      { psAlexInput = ai { aiStartCode = st}+      , psVersion = fv+      , psFilename = "<unknown>"+      , psParanthesesCount = ParanthesesCount 0 False+      , psContext = [ ConStart ] }+    f t =+      case t of+        -- a function keyword should be followed by the name and a left paren+        TId{} -> lexer f+        TLeftPar{} -> return True+        _ -> return False++hollerithP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool+hollerithP _ _ _ ai = isDigit (lookBack 2 ai)++notToP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool+notToP _ _ _ ai = not $ "to" `isPrefixOf` (reverse . lexemeMatch . aiLexeme $ ai)++equalFollowsP :: FortranVersion -> AlexInput -> Bool+equalFollowsP fv ai =+    case unParse (lexer $ f False (0::Integer)) ps of+      ParseOk True _ -> True+      _ -> False+  where+    ps = ParseState+      { psAlexInput = ai { aiStartCode = st}+      , psVersion = fv+      , psFilename = "<unknown>"+      , psParanthesesCount = ParanthesesCount 0 False+      , psContext = [ ConStart ] }+    f False 0 t =+      case t of+        TNewline{} -> return False+        TEOF{} -> return False+        TOpAssign{} -> return True+        TLeftPar{} -> lexer $ f True 1+        TDot{} -> lexer $ f False 0+        TId{} -> lexer $ f False 0+        _ -> return False+    f False _ _ = return False+    f True 0 t =+      case t of+        TOpAssign{} -> return True+        TDot{} -> lexer $ f True 0+        TId{} -> lexer $ f True 0+        TLeftPar{} -> lexer $ f True 1+        _ -> return False+    f True n t =+      case t of+        TNewline{} -> return False+        TEOF{} -> return False+        TLeftPar{} -> lexer $ f True (n + 1)+        TRightPar{} -> lexer $ f True (n - 1)+        _ -> lexer $ f True n++rParFollowsP :: FortranVersion -> AlexInput -> Bool+rParFollowsP fv ai =+    case unParse (lexer $ f) ps of+      ParseOk True _ -> True+      _ -> False+  where+    ps = ParseState+      { psAlexInput = ai { aiStartCode = st}+      , psVersion = fv+      , psFilename = "<unknown>"+      , psParanthesesCount = ParanthesesCount 0 False+      , psContext = [ ConStart ] }+    f t =+      case t of+        TRightPar{} -> return True+        _ -> return False++commentP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool+commentP _ aiOld _ aiNew = atColP 1 aiOld && _endsWithLine+  where+    _endsWithLine = (posColumn . aiPosition) aiNew /= 1++bangCommentP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool+bangCommentP _ _ _ aiNew = _endsWithLine+  where+    _endsWithLine = (posColumn . aiPosition) aiNew /= 1++withinLabelColsP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool+withinLabelColsP _ aiOld _ aiNew = getCol aiOld >= 1 && getCol aiNew <= 6+  where+    getCol = posColumn . aiPosition++atColP :: Int -> AlexInput -> Bool+atColP n ai = (posColumn . aiPosition) ai == n++-- This predicate allows to distinguish identifiers and real exponent tokens+-- by looking at previous token. Since exponent can only follow a "." or an+-- integer token. Anything other previous token will prevent matching the input+-- as an exponent token.+exponentP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool+exponentP _ _ _ ai =+  case aiPreviousTokensInLine ai of+    -- real*8 d8 is not an exponent+    TInt{} : TStar{} : TType{} : _ -> False+    TInt{} : _ -> True+    TDot{} : _ -> True+    _ -> False++fortran66P :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool+fortran66P fv _ _ _ = fv == Fortran66++fortran77P :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool+fortran77P fv _ _ _ = fv == Fortran77 || fv == Fortran77Extended || fv == Fortran77Legacy++extended77P :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool+extended77P fv _ _ _ = fv == Fortran77Extended || fv == Fortran77Legacy++legacy77P :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool+legacy77P fv _ _ _ = fv == Fortran77Legacy+++--------------------------------------------------------------------------------+-- Lexer helpers+--------------------------------------------------------------------------------++addSpan :: (SrcSpan -> Token) -> LexAction (Maybe Token)+addSpan cons = do+  s <- getLexemeSpan+  return $ Just $ cons s++addSpanAndMatch :: (SrcSpan -> String -> Token) -> LexAction (Maybe Token)+addSpanAndMatch cons = do+  s <- getLexemeSpan+  m <- getMatch+  return $ Just $ cons s m++getLexeme :: LexAction Lexeme+getLexeme = do+  ai <- getAlex+  return $ aiLexeme ai++putLexeme :: Lexeme -> LexAction ()+putLexeme lexeme = do+  ai <- getAlex+  putAlex $ ai { aiLexeme = lexeme }++resetLexeme :: LexAction ()+resetLexeme = putLexeme initLexeme++getMatch :: LexAction String+getMatch = do+  lexeme <- getLexeme+  return $ (reverse . lexemeMatch) lexeme++putMatch :: String -> LexAction ()+putMatch newMatch = do+  lexeme <- getLexeme+  putLexeme $ lexeme { lexemeMatch = reverse newMatch }++incWhiteSensitiveCharCount :: LexAction ()+incWhiteSensitiveCharCount = do+  ai <- getAlex+  let wsc = aiWhiteSensitiveCharCount ai+  putAlex $ ai { aiWhiteSensitiveCharCount = wsc + 1 }++resetWhiteSensitiveCharCount :: LexAction ()+resetWhiteSensitiveCharCount = do+  ai <- getAlex+  putAlex $ ai { aiWhiteSensitiveCharCount = 0 }++setCaseSensitive :: LexAction ()+setCaseSensitive = do+  ai <- getAlex+  putAlex $ ai { aiCaseSensitive = True }++setCaseInsensitive :: LexAction ()+setCaseInsensitive = do+  ai <- getAlex+  putAlex $ ai { aiCaseSensitive = False }++enterFormat :: LexAction ()+enterFormat = do+  ai <- getAlex+  putAlex $ ai { aiInFormat = True }++exitFormat :: LexAction ()+exitFormat = do+  ai <- getAlex+  putAlex $ ai { aiInFormat = False }++instance Spanned Lexeme where+  getSpan lexeme =+    let ms = lexemeStart lexeme+        me = lexemeEnd lexeme in+      SrcSpan (fromJust ms) (fromJust me)+  setSpan _ = error "Lexeme span cannot be set."++updatePreviousToken :: Maybe Token -> LexAction ()+updatePreviousToken maybeToken = do+  ai <- getAlex+  putAlex $ ai { aiPreviousToken = maybeToken }++addToPreviousTokensInLine :: Token -> LexAction ()+addToPreviousTokensInLine token = do+  ai <- getAlex+  putAlex $+    case token of+      TNewline _ -> updatePrevTokens ai [ ]+      t -> updatePrevTokens ai $ t : aiPreviousTokensInLine ai+  where+    updatePrevTokens ai tokens = ai { aiPreviousTokensInLine = tokens }++checkPreviousTokensInLine :: (Token -> Bool) -> AlexInput -> Bool+checkPreviousTokensInLine prop ai = any prop $ aiPreviousTokensInLine ai++getLexemeSpan :: LexAction SrcSpan+getLexemeSpan = do+  lexeme <- getLexeme+  return $ getSpan lexeme++-- Handle pragmas that begin with #+lexHash :: LexAction (Maybe Token)+lexHash = do+  lexLineWithWhitespace $ \ m -> do+    ai <- getAlex+    case words (drop 1 m) of+      -- 'line' pragma - rewrite the current line and filename+      "line":lineStr:_+        | line <- readIntOrBoz lineStr -> do+          let revdropWNQ = reverse . drop 1 . dropWhile (flip notElem "'\"")+          let file       = revdropWNQ . revdropWNQ $ m+          let lineOffs   = fromIntegral line - posLine (aiPosition ai) - 1+          let newP       = (aiPosition ai) { posPragmaOffset = Just (lineOffs, file)+                                           , posColumn = 1 }+          putAlex $ ai { aiPosition = newP }+      _ -> return ()+    return Nothing++-- Lex comments with whitespace included+lexComment :: LexAction (Maybe Token)+lexComment =+  lexLineWithWhitespace $ \ m -> do+    s <- getLexemeSpan+    return . Just . TComment s $ tail m++-- Get a line without losing the whitespace, then call continuation with it.+lexLineWithWhitespace :: (String -> LexAction (Maybe Token)) -> LexAction (Maybe Token)+lexLineWithWhitespace k = do+  alex <- getAlex+  let modifiedAlex = alex { aiWhiteSensitiveCharCount = 1 }+  case alexGetByte modifiedAlex of+    Just (w, newAlex)+      | fromIntegral w /= ord '\n' -> putAlex newAlex >> lexLineWithWhitespace k+    _                              -> getMatch >>= k+++--------------------------------------------------++{-+     Chars+      +-++      | |+      | |+      | v+      +-+  Nothing  +-+++---> |0|---------->+3|+  +-> +++           +-++  |    |+' |    | '+  |    v+  |   +++  Nothing  +-++  +---|1|----------->2|+      +++           ++++       |             ^+       +-------------++            Chars+-}+strAutomaton :: Char -> Int -> LexAction (Maybe Token)+strAutomaton c 0 = do+  setCaseSensitive+  incWhiteSensitiveCharCount+  alex <- getAlex+  case alexGetByte alex of+    Just (_, newAlex) -> do+      putAlex newAlex+      m <- getMatch+      if last m == c+      then strAutomaton c 1+      else strAutomaton c 0+    Nothing -> strAutomaton c 3+strAutomaton c 1 = do+  incWhiteSensitiveCharCount+  alex <- getAlex+  case alexGetByte alex of+    Just (_, newAlex) -> do+      let m = lexemeMatch . aiLexeme $ newAlex+      if head m == c+      then do+        putAlex newAlex+        putMatch $ reverse . tail $ m+        strAutomaton c 0+      else strAutomaton c 2+    Nothing -> strAutomaton c 2+strAutomaton _ 2 = do+  s <- getLexemeSpan+  m <- getMatch+  resetWhiteSensitiveCharCount+  setCaseInsensitive+  return $ Just $ TString s $ (init . tail) m+strAutomaton _ _ = fail "Unmatched string."++lexHollerith :: LexAction (Maybe Token)+lexHollerith = do+  match' <- getMatch+  let len = read $ init match' -- Get n of "nH" from string+  putMatch ""+  ai <- getAlex+  putAlex $ ai { aiWhiteSensitiveCharCount = len }+  lexed <- lexN len+  s <- getLexemeSpan+  return $ do+    hollerith <- lexed+    return $ THollerith s hollerith++lexN :: Int -> LexAction (Maybe String)+lexN n = do+  alex <- getAlex+  match' <- getMatch+  let len = length match'+  if n == len+  then return $ Just match'+  else+    case alexGetByte alex of+      Just (w, _) | fromIntegral w == ord '\n' -> do+        return . Just $! pad match'+      Just (_, newAlex) -> do+        putAlex newAlex+        lexN n+      Nothing -> return Nothing+ where+  pad s = s ++ replicate (n - length s) ' '++maybeToKeyword :: LexAction (Maybe Token)+maybeToKeyword = do+  decPar+  pcActual' <- pcActual . psParanthesesCount <$> get+  if pcActual' == 0+  then toSC keyword+  else return Nothing++typeSCChange :: LexAction (Maybe Token)+typeSCChange = do+  ps <- get+  let hypotheticalPs = ps { psAlexInput = (psAlexInput ps) { aiStartCode = keyword } }+  let isFunction = case unParse (lexer f) hypotheticalPs of { ParseOk True _ -> True; _ -> False }+  if isFunction+  then return Nothing+  else toSC st+  where+    f TFunction{} = return True+      -- can be part of function type declaration+    f TLeftPar{} = lexer f+    f TRightPar{} = lexer f+    f TStar{} = lexer f+    f TInt{} = lexer f+    f _ = return False++toSC :: Int -> LexAction (Maybe Token)+toSC startCode = do+  ai <- getAlex+  if startCode == 0+  then putAlex $ ai { aiStartCode = startCode, aiWhiteSensitiveCharCount = 6 }+  else putAlex $ ai { aiStartCode = startCode }+  return Nothing++--------------------------------------------------------------------------------+-- Tokens+--------------------------------------------------------------------------------++data Token = TLeftPar             SrcSpan+           | TRightPar            SrcSpan+           | TLeftArrayPar        SrcSpan+           | TRightArrayPar       SrcSpan+           | TComma               SrcSpan+           | TDot                 SrcSpan+           | TPercent             SrcSpan+           | TColon               SrcSpan+           | TInclude             SrcSpan+           | TProgram             SrcSpan+           | TFunction            SrcSpan+           | TSubroutine          SrcSpan+           | TBlockData           SrcSpan+           | TStructure           SrcSpan+           | TRecord              SrcSpan+           | TUnion               SrcSpan+           | TMap                 SrcSpan+           | TEndProgram          SrcSpan+           | TEndFunction         SrcSpan+           | TEndSubroutine       SrcSpan+           | TEndStructure        SrcSpan+           | TEndUnion            SrcSpan+           | TEndMap              SrcSpan+           | TEnd                 SrcSpan+           | TAssign              SrcSpan+           | TOpAssign            SrcSpan+           | TTo                  SrcSpan+           | TGoto                SrcSpan+           | TIf                  SrcSpan+           | TThen                SrcSpan+           | TElse                SrcSpan+           | TElsif               SrcSpan+           | TEndif               SrcSpan+           | TCall                SrcSpan+           | TReturn              SrcSpan+           | TSave                SrcSpan+           | TContinue            SrcSpan+           | TStop                SrcSpan+           | TCycle               SrcSpan+           | TExit                SrcSpan+           | TCase                SrcSpan+           | TCaseDefault         SrcSpan+           | TSelectCase          SrcSpan+           | TEndSelect           SrcSpan+           | TPause               SrcSpan+           | TDo                  SrcSpan+           | TDoWhile             SrcSpan+           | TWhile               SrcSpan+           | TEndDo               SrcSpan+           | TRead                SrcSpan+           | TWrite               SrcSpan+           | TRewind              SrcSpan+           | TBackspace           SrcSpan+           | TEndfile             SrcSpan+           | TInquire             SrcSpan+           | TOpen                SrcSpan+           | TClose               SrcSpan+           | TPrint               SrcSpan+           | TTypePrint           SrcSpan+           | TDimension           SrcSpan+           | TCommon              SrcSpan+           | TEquivalence         SrcSpan+           | TPointer             SrcSpan+           | TExternal            SrcSpan+           | TIntrinsic           SrcSpan+           | TType                SrcSpan String+           | TEntry               SrcSpan+           | TImplicit            SrcSpan+           | TNone                SrcSpan+           | TParameter           SrcSpan+           | TData                SrcSpan+           | TStatic              SrcSpan+           | TAutomatic           SrcSpan+           | TFormat              SrcSpan+           | TBlob                SrcSpan String+           | TInt                 SrcSpan String+           | TBozLiteral          SrcSpan Boz+           | TExponent            SrcSpan String+           | TBool                SrcSpan Bool+           | TOpPlus              SrcSpan+           | TOpMinus             SrcSpan+           | TOpExp               SrcSpan+           | TStar                SrcSpan+           | TSlash               SrcSpan+           | TAmpersand           SrcSpan+           | TOpOr                SrcSpan+           | TOpAnd               SrcSpan+           | TOpXOr               SrcSpan+           | TOpNot               SrcSpan+           | TOpEquivalent        SrcSpan+           | TOpNotEquivalent     SrcSpan+           | TOpLT                SrcSpan+           | TOpLE                SrcSpan+           | TOpEQ                SrcSpan+           | TOpNE                SrcSpan+           | TOpGT                SrcSpan+           | TOpGE                SrcSpan+           | TId                  SrcSpan String+           | TComment             SrcSpan String+           | TString              SrcSpan String+           | THollerith           SrcSpan String+           | TLabel               SrcSpan String+           | TNewline             SrcSpan+           | TEOF                 SrcSpan+           deriving (Show, Eq, Ord, Data, Typeable, Generic)++instance FirstParameter Token SrcSpan+instance FirstParameter Token SrcSpan => Spanned Token where+  getSpan a = getFirstParameter a+  setSpan e a = setFirstParameter e a++instance Tok Token where+  eofToken (TEOF _) = True+  eofToken _ = False++--------------------------------------------------------------------------------+-- AlexInput & related definitions+--------------------------------------------------------------------------------++data Lexeme = Lexeme+  { lexemeMatch :: String+  , lexemeStart :: Maybe Position+  , lexemeEnd   :: Maybe Position+  } deriving (Show)++initLexeme :: Lexeme+initLexeme = Lexeme+  { lexemeMatch = ""+  , lexemeStart = Nothing+  , lexemeEnd   = Nothing }++data AlexInput = AlexInput+  { aiSourceBytes               :: B.ByteString+  , aiEndOffset                 :: Int+  , aiPosition                  :: Position+  , aiBytes                     :: [Word8]+  , aiPreviousChar              :: Char+  , aiLexeme                    :: Lexeme+  , aiWhiteSensitiveCharCount   :: Int+  , aiStartCode                 :: Int+  , aiPreviousToken             :: Maybe Token+  , aiPreviousTokensInLine      :: [ Token ]+  , aiCaseSensitive             :: Bool+  , aiInFormat                  :: Bool+  , aiFortranVersion            :: FortranVersion+  } deriving (Show)++instance Loc AlexInput where+  getPos = aiPosition++instance LastToken AlexInput Token where+  getLastToken = aiPreviousToken++type LexAction a = Parse AlexInput Token a++vanillaAlexInput :: String -> FortranVersion -> B.ByteString -> AlexInput+vanillaAlexInput fn fv bs = AlexInput+  { aiSourceBytes = bs+  , aiEndOffset = B.length bs+  , aiPosition = initPosition { filePath = fn }+  , aiBytes = []+  , aiPreviousChar = '\n'+  , aiLexeme = initLexeme+  , aiWhiteSensitiveCharCount = 6+  , aiStartCode = 0+  , aiPreviousToken = Nothing+  , aiPreviousTokensInLine = [ ]+  , aiCaseSensitive = False+  , aiInFormat = False+  , aiFortranVersion = fv+  }++updateLexeme :: Maybe Char -> Position -> AlexInput -> AlexInput+updateLexeme maybeChar p ai =+  let lexeme = aiLexeme ai+      match = lexemeMatch lexeme+      newMatch =+        case maybeChar of+          Just c -> c : match+          Nothing -> match+      start = lexemeStart lexeme+                 -- skipping should not start a new lexeme+      newStart = if isNothing start && isJust maybeChar then Just p else start+      newEnd = Just p in+    ai { aiLexeme = Lexeme newMatch newStart newEnd }++--------------------------------------------------------------------------------+-- Definitions needed for alexScanUser+--------------------------------------------------------------------------------++data Move = Continuation | Char | Newline | NewlineComment | Comment++alexGetByte :: AlexInput -> Maybe (Word8, AlexInput)+alexGetByte ai+  -- The process of reading individual bytes of the character+  | _bytes /= [] = Just (head _bytes, ai { aiBytes = tail _bytes })+  -- When all characters are already read+  | posAbsoluteOffset _position == aiEndOffset ai = Nothing+  -- Skip the continuation line altogether+  | isContinuation ai && _isWhiteInsensitive = skip Continuation ai+  -- Skip the newline before a comment+  | aiFortranVersion ai == Fortran77Legacy && _isWhiteInsensitive+  && isNewlineCommentsFollowedByContinuation ai = skip NewlineComment ai+  -- If we are not parsing a Hollerith skip whitespace+  | _curChar `elem` [ ' ', '\t' ] && _isWhiteInsensitive = skip Char ai+  -- Ignore inline comments+  | aiFortranVersion ai == Fortran77Legacy &&+    _isWhiteInsensitive && not _inFormat && _curChar == '!' = skip Comment ai+  -- Ignore comments after column 72 in fortran77+  | aiFortranVersion ai == Fortran77Legacy && posColumn _position > 72 && _curChar /= '\n'+  = skip Comment ai+  -- Read genuine character and advance. Also covers white sensitivity.+  | otherwise =+      let (_b:_bs) = utf8Encode _curChar in+        Just(_b, updateLexeme (Just _curChar) _position+          ai {+            aiPosition =+              case _curChar of+                '\n'  -> advance Newline ai+                _     -> advance Char ai,+            aiBytes = _bs,+            aiPreviousChar = _curChar,+            aiWhiteSensitiveCharCount =+              if _isWhiteInsensitive+              then 0+              else aiWhiteSensitiveCharCount ai - 1+          })+  where+    _curChar = (if aiCaseSensitive ai then id else toLower) $ currentChar ai+    _bytes = aiBytes ai+    _position = aiPosition ai+    _isWhiteInsensitive = aiWhiteSensitiveCharCount ai == 0+    _inFormat = aiInFormat ai++alexInputPrevChar :: AlexInput -> Char+alexInputPrevChar ai = aiPreviousChar ai++takeNChars :: Integer -> AlexInput -> String+takeNChars n ai =+  B.unpack . B.take (fromIntegral n) . B.drop (fromIntegral _dropN) $ aiSourceBytes ai+  where+    _dropN = posAbsoluteOffset . aiPosition $ ai++currentChar :: AlexInput -> Char+currentChar ai = B.index (aiSourceBytes ai) (fromIntegral . posAbsoluteOffset . aiPosition $ ai)++lookBack :: Int -> AlexInput -> Char+lookBack n ai = B.index (aiSourceBytes ai) (fromIntegral . subtract n . posAbsoluteOffset . aiPosition $ ai)++isContinuation :: AlexInput -> Bool+isContinuation ai =+  take 6 _next7 == "\n     " && not (last _next7 `elem` [' ', '0', '\n', '\r'])+  where+    _next7 = takeNChars 7 ai++isNewlineComment :: AlexInput -> Bool+isNewlineComment ai =+  _next1 == "\n" && isCommentLine ai p+  where+    _next1 = takeNChars 1 ai+    p = (aiPosition ai) { posAbsoluteOffset = posAbsoluteOffset (aiPosition ai) + 1 }++isNewlineCommentsFollowedByContinuation :: AlexInput -> Bool+isNewlineCommentsFollowedByContinuation ai+  | isNewlineComment ai+  = isNewlineCommentsFollowedByContinuation (ai { aiPosition = advance NewlineComment ai })+  | isContinuation ai = True+  | otherwise = False++skip :: Move -> AlexInput -> Maybe (Word8, AlexInput)+skip move ai =+  let _newPosition = advance move ai in+    alexGetByte $ updateLexeme Nothing _newPosition $ ai { aiPosition = _newPosition }++advance :: Move -> AlexInput -> Position+advance move ai =+  case move of+    Char ->+      position { posAbsoluteOffset = _absl + 1, posColumn = _col + 1 }+    Continuation ->+      position { posAbsoluteOffset = _absl + 7, posColumn = 7, posLine = _line + 1 }+    Newline ->+      position { posAbsoluteOffset = _absl + 1, posColumn = 1, posLine = _line + 1 }+    NewlineComment ->+      skipComment ai+        position { posAbsoluteOffset = _absl + 1, posColumn = 1, posLine = _line + 1 }+    Comment ->+      skipComment ai position+  where+    position = aiPosition ai+    _col = posColumn position+    _line = posLine position+    _absl = posAbsoluteOffset position++skipComment :: AlexInput -> Position -> Position+skipComment ai p =+  p { posAbsoluteOffset = posAbsoluteOffset p + length line+    , posColumn = posColumn p + length line+    }+  where+  line = takeLine p ai++skipCommentLines :: AlexInput -> Position -> Position+skipCommentLines ai p = go p p+  where+  go p' p''+    -- eof is not a comment line+    | not (null line)+    , isCommentLine ai p''+    = go p'' p''{ posAbsoluteOffset = posAbsoluteOffset p'' + length line + 1 -- skip the newline+            , posColumn = 1, posLine = posLine p'' + 1+            }+    | isContinuation ai'+    = advance Continuation ai'+    | otherwise+      -- after skipping comment lines, place cursor right at the last newline+    = p2+    where+    line = takeLine p'' ai+    line' = takeLine p' ai+    p2 = p' { posAbsoluteOffset = posAbsoluteOffset p' + length line'+            , posColumn = length line' + 1+            }+    ai' = ai { aiPosition = p2 }++isCommentLine :: AlexInput -> Position -> Bool+isCommentLine ai p+      -- eof is not a comment line+    | posAbsoluteOffset p == aiEndOffset ai+    = False+    | map toLower (take 1 line) `elem` ["c", "d", "!", "*"]+      || all (`elem` " \t") line+      || head (dropWhile (`elem` " \t") line) == '!'+    = True+    | otherwise+    = False+    where+    line = takeLine p ai++takeLine :: Position -> AlexInput -> String+takeLine p ai =+  B.unpack . B.takeWhile (/='\n') . B.drop (fromIntegral _dropN) $ aiSourceBytes ai+  where+    _dropN = posAbsoluteOffset p++utf8Encode :: Char -> [Word8]+utf8Encode = map fromIntegral . _go . ord+  where+    _go oc+      | oc <= 0x7f   = [oc]+      | oc <= 0x7ff  = [ 0xc0 + (oc `Data.Bits.shiftR` 6)+                       , 0x80 + oc Data.Bits..&. 0x3f+                       ]+      | oc <= 0xffff = [ 0xe0 + (oc `Data.Bits.shiftR` 12)+                       , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)+                       , 0x80 + oc Data.Bits..&. 0x3f+                       ]+      | otherwise    = [ 0xf0 + (oc `Data.Bits.shiftR` 18)+                       , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f)+                       , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)+                       , 0x80 + oc Data.Bits..&. 0x3f+                       ]++--------------------------------------------------------------------------------+-- Lexer definition+--------------------------------------------------------------------------------++lexer :: (Token -> LexAction a) -> LexAction a+lexer cont = cont =<< lexer'++lexer' :: LexAction Token+lexer' = do+  resetLexeme+  alexInput <- getAlex+  let startCode = aiStartCode alexInput+  version <- getVersion+  case alexScanUser version alexInput startCode of+    AlexEOF -> return $ TEOF $ SrcSpan (getPos alexInput) (getPos alexInput)+    AlexError _ -> do+      parseState <- get+      fail $ psFilename parseState ++ ": lexing failed. "+    AlexSkip newAlex _ -> putAlex newAlex >> lexer'+    AlexToken newAlex _ action -> do+      putAlex newAlex+      maybeToken <- action+      case maybeToken of+        Just token -> do+          updatePreviousToken maybeToken+          addToPreviousTokensInLine token+          return token+        Nothing -> lexer'++alexScanUser :: FortranVersion -> AlexInput -> Int -> AlexReturn (LexAction (Maybe Token))++}