diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -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
diff --git a/app/Main.hs b/app/Main.hs
new file mode 100644
--- /dev/null
+++ b/app/Main.hs
@@ -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
diff --git a/fortran-src.cabal b/fortran-src.cabal
--- a/fortran-src.cabal
+++ b/fortran-src.cabal
@@ -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
diff --git a/src/Language/Fortran/AST.hs b/src/Language/Fortran/AST.hs
--- a/src/Language/Fortran/AST.hs
+++ b/src/Language/Fortran/AST.hs
@@ -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)
diff --git a/src/Language/Fortran/AST/AList.hs b/src/Language/Fortran/AST/AList.hs
--- a/src/Language/Fortran/AST/AList.hs
+++ b/src/Language/Fortran/AST/AList.hs
@@ -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
diff --git a/src/Language/Fortran/AST/Boz.hs b/src/Language/Fortran/AST/Boz.hs
--- a/src/Language/Fortran/AST/Boz.hs
+++ b/src/Language/Fortran/AST/Boz.hs
@@ -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"
diff --git a/src/Language/Fortran/AST/RealLit.hs b/src/Language/Fortran/AST/RealLit.hs
--- a/src/Language/Fortran/AST/RealLit.hs
+++ b/src/Language/Fortran/AST/RealLit.hs
@@ -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
 
diff --git a/src/Language/Fortran/Analysis.hs b/src/Language/Fortran/Analysis.hs
--- a/src/Language/Fortran/Analysis.hs
+++ b/src/Language/Fortran/Analysis.hs
@@ -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
diff --git a/src/Language/Fortran/Analysis/BBlocks.hs b/src/Language/Fortran/Analysis/BBlocks.hs
--- a/src/Language/Fortran/Analysis/BBlocks.hs
+++ b/src/Language/Fortran/Analysis/BBlocks.hs
@@ -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
diff --git a/src/Language/Fortran/Analysis/DataFlow.hs b/src/Language/Fortran/Analysis/DataFlow.hs
--- a/src/Language/Fortran/Analysis/DataFlow.hs
+++ b/src/Language/Fortran/Analysis/DataFlow.hs
@@ -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
diff --git a/src/Language/Fortran/Analysis/ModGraph.hs b/src/Language/Fortran/Analysis/ModGraph.hs
--- a/src/Language/Fortran/Analysis/ModGraph.hs
+++ b/src/Language/Fortran/Analysis/ModGraph.hs
@@ -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
diff --git a/src/Language/Fortran/Analysis/Renaming.hs b/src/Language/Fortran/Analysis/Renaming.hs
--- a/src/Language/Fortran/Analysis/Renaming.hs
+++ b/src/Language/Fortran/Analysis/Renaming.hs
@@ -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)
diff --git a/src/Language/Fortran/Analysis/SemanticTypes.hs b/src/Language/Fortran/Analysis/SemanticTypes.hs
--- a/src/Language/Fortran/Analysis/SemanticTypes.hs
+++ b/src/Language/Fortran/Analysis/SemanticTypes.hs
@@ -1,7 +1,4 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Language.Fortran.Analysis.SemanticTypes where
diff --git a/src/Language/Fortran/Analysis/Types.hs b/src/Language/Fortran/Analysis/Types.hs
--- a/src/Language/Fortran/Analysis/Types.hs
+++ b/src/Language/Fortran/Analysis/Types.hs
@@ -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
diff --git a/src/Language/Fortran/Intrinsics.hs b/src/Language/Fortran/Intrinsics.hs
--- a/src/Language/Fortran/Intrinsics.hs
+++ b/src/Language/Fortran/Intrinsics.hs
@@ -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
diff --git a/src/Language/Fortran/LValue.hs b/src/Language/Fortran/LValue.hs
--- a/src/Language/Fortran/LValue.hs
+++ b/src/Language/Fortran/LValue.hs
@@ -1,9 +1,3 @@
-{-# LANGUAGE DeriveDataTypeable    #-}
-{-# LANGUAGE DeriveFunctor         #-}
-{-# LANGUAGE DeriveGeneric         #-}
-{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-
 module Language.Fortran.LValue where
 
 import           Prelude                               hiding (exp)
diff --git a/src/Language/Fortran/Lexer/FixedForm.x b/src/Language/Fortran/Lexer/FixedForm.x
deleted file mode 100644
--- a/src/Language/Fortran/Lexer/FixedForm.x
+++ /dev/null
@@ -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>"
-
-}
diff --git a/src/Language/Fortran/Lexer/FixedForm/Utils.hs b/src/Language/Fortran/Lexer/FixedForm/Utils.hs
deleted file mode 100644
--- a/src/Language/Fortran/Lexer/FixedForm/Utils.hs
+++ /dev/null
@@ -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
diff --git a/src/Language/Fortran/Lexer/FreeForm.x b/src/Language/Fortran/Lexer/FreeForm.x
deleted file mode 100644
--- a/src/Language/Fortran/Lexer/FreeForm.x
+++ /dev/null
@@ -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>"
-
-}
diff --git a/src/Language/Fortran/Parser.hs b/src/Language/Fortran/Parser.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Fortran/Parser.hs
@@ -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)  }
diff --git a/src/Language/Fortran/Parser/Any.hs b/src/Language/Fortran/Parser/Any.hs
deleted file mode 100644
--- a/src/Language/Fortran/Parser/Any.hs
+++ /dev/null
@@ -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
diff --git a/src/Language/Fortran/Parser/Fixed/Fortran66.y b/src/Language/Fortran/Parser/Fixed/Fortran66.y
new file mode 100644
--- /dev/null
+++ b/src/Language/Fortran/Parser/Fixed/Fortran66.y
@@ -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 }
diff --git a/src/Language/Fortran/Parser/Fixed/Fortran77.y b/src/Language/Fortran/Parser/Fixed/Fortran77.y
new file mode 100644
--- /dev/null
+++ b/src/Language/Fortran/Parser/Fixed/Fortran77.y
@@ -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 }
diff --git a/src/Language/Fortran/Parser/Fixed/Lexer.x b/src/Language/Fortran/Parser/Fixed/Lexer.x
new file mode 100644
--- /dev/null
+++ b/src/Language/Fortran/Parser/Fixed/Lexer.x
@@ -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))
+
+}
diff --git a/src/Language/Fortran/Parser/Fixed/Utils.hs b/src/Language/Fortran/Parser/Fixed/Utils.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Fortran/Parser/Fixed/Utils.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE CPP #-}
+module Language.Fortran.Parser.Fixed.Utils where
+
+import Language.Fortran.Parser.Fixed.Lexer
+import Language.Fortran.AST
+import Language.Fortran.AST.RealLit
+import Language.Fortran.Util.Position
+import Language.Fortran.Parser.Monad
+import Control.Monad.State
+
+-- | UNSAFE. Must be called with expected token types (see usage sites). Will
+--   cause a runtime exception if it doesn't form a valid REAL literal.
+makeRealLit
+    :: Maybe Token -> Maybe Token -> Maybe Token -> Maybe (SrcSpan, String)
+    -> Expression A0
+makeRealLit 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
+
+parseError :: Token -> LexAction a
+parseError _ = do
+    parseState <- get
+#ifdef DEBUG
+    tokens <- reverse <$> aiPreviousTokensInLine <$> getAlex
+#endif
+    fail $ psFilename parseState ++ ": parsing failed. "
+#ifdef DEBUG
+      ++ '\n' : show tokens
+#endif
+
+convCmts :: [Block a] -> [ProgramUnit a]
+convCmts = map convCmt
+  where convCmt (BlComment a s c) = PUComment a s c
+        convCmt _ = error "convCmt applied to something that is not a comment"
diff --git a/src/Language/Fortran/Parser/Fortran2003.y b/src/Language/Fortran/Parser/Fortran2003.y
deleted file mode 100644
--- a/src/Language/Fortran/Parser/Fortran2003.y
+++ /dev/null
@@ -1,1477 +0,0 @@
--- -*- Mode: Haskell -*-
--- vim: ft=haskell
-{
--- Incomplete work-in-progress.
-module Language.Fortran.Parser.Fortran2003 ( functionParser
-                                           , statementParser
-                                           , blockParser
-                                           , fortran2003Parser
-                                           , fortran2003ParserWithTransforms
-                                           , fortran2003ParserWithModFiles
-                                           , fortran2003ParserWithModFilesWithTransforms
-                                           ) where
-
-import Prelude hiding (EQ,LT,GT) -- Same constructors exist in the AST
-import Control.Monad.State
-import Data.Maybe (fromMaybe, isJust)
-import Data.List (nub)
-import Data.Either (either, lefts, rights, partitionEithers)
-import Control.Applicative
-import qualified Data.ByteString.Char8 as B
-
-#ifdef DEBUG
-import Data.Data (toConstr)
-#endif
-
-import Language.Fortran.Util.Position
-import Language.Fortran.Util.ModFile
-import Language.Fortran.ParserMonad
-import Language.Fortran.Lexer.FreeForm
-import Language.Fortran.AST
-import Language.Fortran.Transformer
-
-import Debug.Trace
-
-}
-
-%name programParser   PROGRAM
-%name functionParser  SUBPROGRAM_UNIT
-%name blockParser     BLOCK
-%name statementParser STATEMENT
-%monad { LexAction }
-%lexer { lexer } { TEOF _ }
-%tokentype { Token }
-%error { parseError }
-
-%token
-  id                          { TId _ _ }
-  comment                     { TComment _ _ }
-  string                      { TString _ _ }
-  int                         { TIntegerLiteral _ _ }
-  float                       { TRealLiteral _ _ }
-  boz                         { TBozLiteral _ _ }
-  '_'                         { TUnderscore _ }
-  ','                         { TComma _ }
-  ',2'                        { TComma2 _ }
-  ';'                         { TSemiColon _ }
-  ':'                         { TColon _ }
-  '::'                        { TDoubleColon _ }
-  '='                         { TOpAssign _ }
-  '=>'                        { TArrow _ }
-  '%'                         { TPercent _ }
-  '('                         { TLeftPar _ }
-  '(2'                        { TLeftPar2 _ }
-  ')'                         { TRightPar _ }
-  '(/'                        { TLeftInitPar _ }
-  '/)'                        { TRightInitPar _ }
-  opCustom                    { TOpCustom _ _ }
-  '**'                        { TOpExp _ }
-  '+'                         { TOpPlus _ }
-  '-'                         { TOpMinus _ }
-  '*'                         { TStar _ }
-  '/'                         { TOpDivision _ }
-  slash                       { TSlash _ }
-  or                          { TOpOr _ }
-  and                         { TOpAnd _ }
-  not                         { TOpNot _ }
-  eqv                         { TOpEquivalent _ }
-  neqv                        { TOpNotEquivalent _ }
-  '<'                         { TOpLT _ }
-  '<='                        { TOpLE _ }
-  '=='                        { TOpEQ _ }
-  '!='                        { TOpNE _ }
-  '>'                         { TOpGT _ }
-  '>='                        { TOpGE _ }
-  bool                        { TLogicalLiteral _ _ }
-  program                     { TProgram _ }
-  endProgram                  { TEndProgram _ }
-  function                    { TFunction _ }
-  endFunction                 { TEndFunction _ }
-  result                      { TResult _ }
-  pure                        { TPure _ }
-  elemental                   { TElemental _ }
-  recursive                   { TRecursive _ }
-  subroutine                  { TSubroutine _ }
-  endSubroutine               { TEndSubroutine _ }
-  blockData                   { TBlockData _ }
-  endBlockData                { TEndBlockData _ }
-  module                      { TModule _ }
-  endModule                   { TEndModule _ }
-  contains                    { TContains _ }
-  use                         { TUse _ }
-  only                        { TOnly _ }
-  import                      { TImport _ }
-  abstract                    { TAbstract _ }
-  interface                   { TInterface _ }
-  endInterface                { TEndInterface _ }
-  moduleProcedure             { TModuleProcedure _ }
-  procedure                   { TProcedure _ }
-  assignment                  { TAssignment _ }
-  operator                    { TOperator _ }
-  call                        { TCall _ }
-  return                      { TReturn _ }
-  entry                       { TEntry _ }
-  include                     { TInclude _ }
-  public                      { TPublic _ }
-  private                     { TPrivate _ }
-  protected                   { TProtected _ }
-  parameter                   { TParameter _ }
-  allocatable                 { TAllocatable _ }
-  asynchronous                { TAsynchronous _ }
-  dimension                   { TDimension _ }
-  external                    { TExternal _ }
-  intent                      { TIntent _ }
-  intrinsic                   { TIntrinsic _ }
-  nonintrinsic                { TNonIntrinsic _ }
-  optional                    { TOptional _ }
-  pointer                     { TPointer _ }
-  save                        { TSave _ }
-  target                      { TTarget _ }
-  value                       { TValue _ }
-  volatile                    { TVolatile _ }
-  bind                        { TBind _ }
-  'c'                         { TC _ }
-  name                        { TName _ }
-  in                          { TIn _ }
-  out                         { TOut _ }
-  inout                       { TInOut _ }
-  data                        { TData _ }
-  namelist                    { TNamelist _ }
-  implicit                    { TImplicit _ }
-  equivalence                 { TEquivalence _ }
-  common                      { TCommon _ }
-  allocate                    { TAllocate _ }
-  deallocate                  { TDeallocate _ }
-  stat                        { TStat _ }
-  errmsg                      { TErrMsg _ }
-  source                      { TSource _ }
-  nullify                     { TNullify _ }
-  none                        { TNone _ }
-  goto                        { TGoto _ }
-  to                          { TTo _ }
-  continue                    { TContinue _ }
-  stop                        { TStop _ }
-  do                          { TDo _ }
-  enddo                       { TEndDo _ }
-  while                       { TWhile _ }
-  if                          { TIf _ }
-  then                        { TThen _ }
-  else                        { TElse _ }
-  elsif                       { TElsif _ }
-  endif                       { TEndIf _ }
-  case                        { TCase _ }
-  selectcase                  { TSelectCase _ }
-  endselect                   { TEndSelect _ }
-  associate                   { TAssociate _ }
-  endassociate                { TEndAssociate _ }
-  default                     { TDefault _ }
-  cycle                       { TCycle _ }
-  exit                        { TExit _ }
-  where                       { TWhere _ }
-  elsewhere                   { TElsewhere _ }
-  endwhere                    { TEndWhere _ }
-  type                        { TType _ }
-  endType                     { TEndType _ }
-  class                       { TClass _ }
-  enum                        { TEnum _ }
-  enumerator                  { TEnumerator _ }
-  endEnum                     { TEndEnum _ }
-  sequence                    { TSequence _ }
-  kind                        { TKind _ }
-  len                         { TLen _ }
-  integer                     { TInteger _ }
-  real                        { TReal _ }
-  doublePrecision             { TDoublePrecision _ }
-  logical                     { TLogical _ }
-  character                   { TCharacter _ }
-  complex                     { TComplex _ }
-  open                        { TOpen _ }
-  close                       { TClose _ }
-  read                        { TRead _ }
-  write                       { TWrite _ }
-  print                       { TPrint _ }
-  flush                       { TFlush _ }
-  unit                        { TUnit _ }
-  iostat                      { TIOStat _ }
-  iomsg                       { TIOMsg _ }
-  err                         { TErr _ }
-  backspace                   { TBackspace _ }
-  rewind                      { TRewind _ }
-  inquire                     { TInquire _ }
-  endfile                     { TEndfile _ }
-  format                      { TFormat _ }
-  blob                        { TBlob _ _ }
-  end                         { TEnd _ }
-  newline                     { TNewline _ }
-  forall                      { TForall _ }
-  endforall                   { TEndForall _ }
--- Precedence of operators
-
--- Level 6
-%left opCustom
-
--- Level 5
-%left eqv neqv
-%left or
-%left and
-%right not
-
--- Level 4
-%nonassoc '==' '!=' '>' '<' '>=' '<='
-%nonassoc RELATIONAL
-
--- Level 3
-%left CONCAT
-
--- Level 2
-%left '+' '-'
-%left '*' '/'
-%right SIGN
-%right '**'
-
--- Level 1
-%right DEFINED_UNARY
-
--- Level 0
-%left '%'
-
-%%
-
-maybe(p)
-: p           { Just $1 }
-| {- empty -} { Nothing }
-
--- 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 = Fortran2003, miFilename = "" }) (reverse $1) }
-| {- empty -}   { ProgramFile (MetaInfo { miVersion = Fortran2003, miFilename = "" }) [] }
-
-PROGRAM_UNITS :: { [ ProgramUnit A0 ] }
-: PROGRAM_UNITS PROGRAM_UNIT MAYBE_NEWLINE { $2 : $1 }
-| PROGRAM_UNIT MAYBE_NEWLINE { [ $1 ] }
-
-PROGRAM_UNIT :: { ProgramUnit A0 }
-: program NAME NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS PROGRAM_END
-  {% do { unitNameCheck $6 $2;
-          return $ PUMain () (getTransSpan $1 $6) (Just $2) (reverse $4) $5 } }
-| module NAME NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS MODULE_END
-  {% do { unitNameCheck $6 $2;
-          return $ PUModule () (getTransSpan $1 $6) $2 (reverse $4) $5 } }
-| blockData NEWLINE BLOCKS BLOCK_DATA_END
-  { PUBlockData () (getTransSpan $1 $4) Nothing (reverse $3) }
-| blockData NAME NEWLINE BLOCKS BLOCK_DATA_END
-  {% do { unitNameCheck $5 $2;
-          return $ PUBlockData () (getTransSpan $1 $5) (Just $2) (reverse $4) } }
-| SUBPROGRAM_UNIT { $1 }
-
-MAYBE_SUBPROGRAM_UNITS :: { Maybe [ ProgramUnit A0 ] }
-: contains NEWLINE SUBPROGRAM_UNITS { Just $ reverse $3 }
-| {- Empty -} { Nothing }
-
-SUBPROGRAM_UNITS :: { [ ProgramUnit A0 ] }
-: SUBPROGRAM_UNITS SUBPROGRAM_UNIT NEWLINE { $2 : $1 }
-| {- EMPTY -} { [ ] }
-
-SUBPROGRAM_UNIT :: { ProgramUnit A0 }
-: PREFIXES function NAME MAYBE_ARGUMENTS FUNC_SUFFIX MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END
-  {% do { unitNameCheck $10 $3;
-          let (pfxs, typeSpec) = case partitionEithers $1 of
-                                   { (ps, t:_) -> (fromReverseList' ps, Just t)
-                                   ; (ps, [])  -> (fromReverseList' ps, Nothing) } in
-          let (sfx, result) = $5 in
-          let sfx' = fmap (\ s -> AList () (getSpan s) [s]) sfx in
-          let ss = if null $1 then getTransSpan $2 $10 else getTransSpan (reverse $1) $10 in
-          if validPrefixSuffix (pfxs, sfx') then
-            return $ PUFunction () ss typeSpec (pfxs, sfx') $3 $4 result (reverse $8) $9
-          else fail "Cannot specify elemental along with recursive and/or bind." } }
-| PREFIXES subroutine NAME MAYBE_ARGUMENTS SUBR_SUFFIX MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS SUBROUTINE_END
-  {% do { unitNameCheck $10 $3;
-          (pfxs, typeSpec) <- case partitionEithers $1 of
-                                { (ps, t:_) -> fail "Subroutines cannot have return types."
-                                ; (ps, [])  -> return (fromReverseList' ps, Nothing) };
-          let sfx' = fmap (\ s -> AList () (getSpan s) [s]) $5 in
-          let ss = if null $1 then getTransSpan $2 $10 else getTransSpan (reverse $1) $10 in
-          if validPrefixSuffix (pfxs, sfx') then
-            return $ PUSubroutine () ss (pfxs, sfx') $3 $4 (reverse $8) $9
-          else fail "Cannot specify elemental along with recursive and/or bind." } }
-| comment { let (TComment s c) = $1 in PUComment () s (Comment c) }
-
--- (Fortran2003) R1227, Fortran95 (...)
-PREFIXES :: { [Either (Prefix A0) (TypeSpec A0)] }
-: PREFIXES PREFIX { $2:$1 }
-| {- EMPTY -}     { [] }
-
--- (Fortran2003) R1228, Fortran95 (...)
-PREFIX :: { Either (Prefix A0) (TypeSpec A0) }
-: recursive { Left $ PfxRecursive () (getSpan $1) }
-| elemental { Left $ PfxElemental () (getSpan $1) }
-| pure      { Left $ PfxPure      () (getSpan $1) }
-| TYPE_SPEC { Right $1 }
-
-FUNC_SUFFIX :: { (Maybe (Suffix A0), Maybe (Expression A0)) }
-: SUFFIX RESULT { (Just $1, Just $2) }
-| RESULT SUFFIX { (Just $2, Just $1) }
-| SUFFIX        { (Just $1, Nothing) }
-| RESULT        { (Nothing, Just $1) }
-| {- empty -}   { (Nothing, Nothing) }
-
-SUBR_SUFFIX :: { Maybe (Suffix A0) }
-: SUFFIX        { Just $1 }
-| {- empty -}   { Nothing }
-
--- (Fortran2003) R1229
-SUFFIX :: { Suffix A0 }
--- (Fortran2003) R509
-: bind '(' 'c' ',' name '=' EXPRESSION ')' { SfxBind () (getTransSpan $1 $8) (Just $7) }
-| bind '(' 'c' ')'                         { SfxBind () (getTransSpan $1 $4) Nothing }
-
-MAYBE_ARGUMENTS :: { Maybe (AList Expression A0) }
-: '(' MAYBE_VARIABLES ')' { $2 }
-| {- Nothing -} { Nothing }
-
-RESULT :: { Expression A0 }
-: result '(' VARIABLE ')' { $3 }
-
-MAYBE_RESULT :: { Maybe (Expression A0) }
-: RESULT      { Just $1 }
-| {- empty -} { Nothing}
-
-PROGRAM_END :: { Token }
-: end { $1 } | endProgram { $1 } | endProgram id { $2 }
-MODULE_END :: { Token }
-: end { $1 } | endModule { $1 } | endModule id { $2 }
-FUNCTION_END :: { Token }
-: end { $1 } | endFunction { $1 } | endFunction id { $2 }
-SUBROUTINE_END :: { Token }
-: end { $1 } | endSubroutine { $1 } | endSubroutine id { $2 }
-BLOCK_DATA_END :: { Token }
-: end { $1 } | endBlockData { $1 } | endBlockData id { $2 }
-INTERFACE_END :: { Token }
-: end { $1 } | endInterface { $1 } | endInterface id { $2 }
-
-NAME :: { Name } : id { let (TId _ name) = $1 in name }
-
-IMPORT_NAME_LIST :: { [Expression A0] }
-: IMPORT_NAME_LIST ',' VARIABLE { $3 : $1 }
-| VARIABLE { [ $1 ] }
-
-BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] }
-
-BLOCK :: { Block A0 }
-: IF_BLOCK MAYBE_COMMENT NEWLINE { $1 }
-| CASE_BLOCK MAYBE_COMMENT NEWLINE { $1 }
-| ASSOCIATE_BLOCK MAYBE_COMMENT NEWLINE { $1 }
-| INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE
-  { BlStatement () (getTransSpan $1 $2) (Just $1) $2 }
-| STATEMENT MAYBE_COMMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 }
-| ABSTRACTP interface MAYBE_EXPRESSION MAYBE_COMMENT NEWLINE SUBPROGRAM_UNITS2 MODULE_PROCEDURES INTERFACE_END MAYBE_COMMENT NEWLINE
-  { BlInterface () (getTransSpan $2 $10) $3 $1 (reverse $6) (reverse $7) }
-| ABSTRACTP interface MAYBE_EXPRESSION MAYBE_COMMENT NEWLINE MODULE_PROCEDURES INTERFACE_END MAYBE_COMMENT NEWLINE
-  { BlInterface () (getTransSpan $2 $9) $3 $1 [ ] (reverse $6) }
-| COMMENT_BLOCK { $1 }
-
-IF_BLOCK :: { Block A0 }
-:                        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
-  { let { startSpan = getSpan $1;
-          (endSpan, conds, blocks, endLabel) = $9;
-          span = getTransSpan startSpan endSpan }
-     in BlIf () span Nothing Nothing ((Just $3):conds) ((reverse $8):blocks) endLabel }
-|                 id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
-  { let { TId startSpan startName = $1;
-          (endSpan, conds, blocks, endLabel) = $11;
-          span = getTransSpan startSpan endSpan }
-     in BlIf () span Nothing (Just startName) ((Just $5):conds) ((reverse $10):blocks) endLabel }
-| INTEGER_LITERAL        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
-  { let { startSpan = getSpan $1;
-          startLabel = Just $1;
-          (endSpan, conds, blocks, endLabel) = $10;
-          span = getTransSpan startSpan endSpan }
-     in BlIf () span startLabel Nothing ((Just $4):conds) ((reverse $9):blocks) endLabel }
-| INTEGER_LITERAL id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
-  { let { startSpan = getSpan $1;
-          startLabel = Just $1;
-          TId _ startName = $2;
-          (endSpan, conds, blocks, endLabel) = $12;
-          span = getTransSpan startSpan endSpan }
-     in BlIf () span startLabel (Just startName) ((Just $6):conds) ((reverse $11):blocks) endLabel }
-
-ELSE_BLOCKS :: { (SrcSpan, [Maybe (Expression A0)], [[Block A0]], Maybe (Expression A0)) }
-: maybe(INTEGER_LITERAL) elsif '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
-  { let (endSpan, conds, blocks, endLabel) = $10
-    in (endSpan, Just $4 : conds, reverse $9 : blocks, endLabel) }
-| maybe(INTEGER_LITERAL) else                          MAYBE_COMMENT NEWLINE BLOCKS END_IF
-  { let (endSpan, endLabel) = $6
-    in (endSpan, [Nothing], [reverse $5], endLabel) }
-| END_IF { let (endSpan, endLabel) = $1 in (endSpan, [], [], endLabel) }
-
-END_IF :: { (SrcSpan, Maybe (Expression A0)) }
-: endif { (getSpan $1, Nothing) }
-| endif id { (getSpan $2, Nothing) }
-| INTEGER_LITERAL endif { (getSpan $2, Just $1) }
-| INTEGER_LITERAL endif id { (getSpan $3, Just $1) }
-
-CASE_BLOCK :: { Block A0 }
-:                        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
-  { let { (caseRanges, blocks, endLabel, endSpan) = $7;
-          span = getTransSpan $1 endSpan }
-    in BlCase () span Nothing Nothing $3 caseRanges blocks endLabel }
-| INTEGER_LITERAL        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
-  { let { (caseRanges, blocks, endLabel, endSpan) = $8;
-          span = getTransSpan $1 endSpan }
-    in BlCase () span (Just $1) Nothing $4 caseRanges blocks endLabel }
-|                 id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
-  { let { (caseRanges, blocks, endLabel, endSpan) = $9;
-          TId s startName = $1;
-          span = getTransSpan s endSpan }
-    in BlCase () span Nothing (Just startName) $5 caseRanges blocks endLabel }
-| INTEGER_LITERAL id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
-  { let { (caseRanges, blocks, endLabel, endSpan) = $10;
-          TId s startName = $2;
-          span = getTransSpan s endSpan }
-    in BlCase () span (Just $1) (Just startName) $6 caseRanges blocks endLabel }
-
--- We store line comments as statements, but this raises an issue: we have
--- nowhere to place comments after a SELECT CASE but before a CASE. So we drop
--- them. The inner CASES_ rule does /not/ use this, because comments can always
--- be parsed as belonging to to the above CASE block.
-CASES :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }
-: COMMENT_BLOCK CASES_ { $2 }
-|               CASES_ { $1 }
-
-CASES_ :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }
-: maybe(INTEGER_LITERAL) case '(' INDICIES ')' MAYBE_COMMENT NEWLINE BLOCKS CASES_
-  { let (scrutinees, blocks, endLabel, endSpan) = $9
-    in  (Just (fromReverseList $4) : scrutinees, reverse $8 : blocks, endLabel, endSpan) }
-| maybe(INTEGER_LITERAL) case default          MAYBE_COMMENT NEWLINE BLOCKS END_SELECT
-  { let (endLabel, endSpan) = $7
-    in ([Nothing], [$6], endLabel, endSpan) }
-| END_SELECT
-  { let (endLabel, endSpan) = $1
-    in ([], [], endLabel, endSpan) }
-
-END_SELECT :: { (Maybe (Expression A0), SrcSpan) }
-: maybe(INTEGER_LITERAL) endselect maybe(id)
-  { ($1, maybe (getSpan $2) getSpan $3) }
-
-ASSOCIATE_BLOCK :: { Block A0 }
-: INTEGER_LITERAL id ':' associate '(' ABBREVIATIONS ')' MAYBE_COMMENT NEWLINE BLOCKS END_ASSOCIATE
-  { let { startSpan  = getSpan $1;
-          mLabel     = Just $1;
-          TId _ name = $2;
-          mName      = Just name;
-          abbrevs    = fromReverseList $6;
-          body       = reverse $10;
-          (endSpan, mEndLabel) = $11;
-          span       = getTransSpan startSpan endSpan }
-     in BlAssociate () span mLabel mName abbrevs body mEndLabel }
-| INTEGER_LITERAL        associate '(' ABBREVIATIONS ')' MAYBE_COMMENT NEWLINE BLOCKS END_ASSOCIATE
-  { let { startSpan  = getSpan $1;
-          mLabel     = Just $1;
-          mName      = Nothing;
-          abbrevs    = fromReverseList $4;
-          body       = reverse $8;
-          (endSpan, mEndLabel) = $9;
-          span       = getTransSpan startSpan endSpan }
-     in BlAssociate () span mLabel mName abbrevs body mEndLabel }
-|                 id ':' associate '(' ABBREVIATIONS ')' MAYBE_COMMENT NEWLINE BLOCKS END_ASSOCIATE
-  { let { startSpan  = getSpan $1;
-          TId _ name = $1;
-          mLabel     = Nothing;
-          mName      = Just name;
-          abbrevs    = fromReverseList $5;
-          body       = reverse $9;
-          (endSpan, mEndLabel) = $10;
-          span       = getTransSpan startSpan endSpan }
-     in BlAssociate () span mLabel mName abbrevs body mEndLabel }
-|                        associate '(' ABBREVIATIONS ')' MAYBE_COMMENT NEWLINE BLOCKS END_ASSOCIATE
-  { let { startSpan  = getSpan $1;
-          mLabel     = Nothing;
-          mName      = Nothing;
-          abbrevs    = fromReverseList $3;
-          body       = reverse $7;
-          (endSpan, mEndLabel) = $8;
-          span       = getTransSpan startSpan endSpan }
-     in BlAssociate () span mLabel mName abbrevs body mEndLabel }
-
--- TODO: Copied verbatim from END_IF. Should attempt to functionalise.
-END_ASSOCIATE :: { (SrcSpan, Maybe (Expression A0)) }
-: endassociate { (getSpan $1, Nothing) }
-| endassociate id { (getSpan $2, Nothing) }
-| INTEGER_LITERAL endassociate { (getSpan $2, Just $1) }
-| INTEGER_LITERAL endassociate id { (getSpan $3, Just $1) }
-
--- (var (ExpValue (ValVariable)), assoc. expr)
-ABBREVIATIONS :: { [(ATuple Expression Expression A0)] }
-: ABBREVIATIONS ',' ABBREVIATION { $3 : $1 }
-| ABBREVIATION { [ $1 ] }
-
-ABBREVIATION :: { ATuple Expression Expression A0 }
-: VARIABLE '=>' EXPRESSION { ATuple () (getTransSpan $1 $3) $1 $3 }
-
-ABSTRACTP :: { Bool }
-: abstract { True }
-| {- EMPTY -} { False }
-
-MAYBE_EXPRESSION :: { Maybe (Expression A0) }
-: EXPRESSION { Just $1 }
-| {- EMPTY -} { Nothing }
-
-MAYBE_COMMENT :: { Maybe Token }
-: comment { Just $1 }
-| {- EMPTY -} { Nothing }
-
-SUBPROGRAM_UNITS2 :: { [ ProgramUnit A0 ] }
-: SUBPROGRAM_UNITS SUBPROGRAM_UNIT NEWLINE { $2 : $1 }
-
-MODULE_PROCEDURES :: { [ Block A0 ] }
-: MODULE_PROCEDURES MODULE_PROCEDURE { $2 : $1 }
-| MODULE_PROCEDURES MODULE_PROCEDURE COMMENT_BLOCK { $3 : $2 : $1 }
-| { [ ] }
-
-MODULE_PROCEDURE :: { Block A0 }
-: moduleProcedure VARIABLES MAYBE_COMMENT NEWLINE
-  { let { al = fromReverseList $2;
-          st = StModuleProcedure () (getTransSpan $1 al) (fromReverseList $2) }
-    in BlStatement () (getTransSpan $1 $4) Nothing st }
-
-COMMENT_BLOCK :: { Block A0 }
-: 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 }
-| newline { $1 }
-| ';' { $1 }
-
-STATEMENT :: { Statement A0 }
-: NONEXECUTABLE_STATEMENT { $1 }
-| EXECUTABLE_STATEMENT { $1 }
-
-EXPRESSION_ASSIGNMENT_STATEMENT :: { Statement A0 }
-: DATA_REF '=' EXPRESSION { StExpressionAssign () (getTransSpan $1 $3) $1 $3 }
-
-NONEXECUTABLE_STATEMENT :: { Statement A0 }
-: DECLARATION_STATEMENT { $1 }
-| intent '(' INTENT_CHOICE ')' MAYBE_DCOLON EXPRESSION_LIST
-  { let expAList = fromReverseList $6
-    in StIntent () (getTransSpan $1 expAList) $3 expAList }
-| optional MAYBE_DCOLON EXPRESSION_LIST
-  { let expAList = fromReverseList $3
-    in StOptional () (getTransSpan $1 expAList) expAList }
-| public MAYBE_DCOLON EXPRESSION_LIST
-  { let expAList = fromReverseList $3
-    in StPublic () (getTransSpan $1 expAList) (Just expAList) }
-| public { StPublic () (getSpan $1) Nothing }
-| private MAYBE_DCOLON EXPRESSION_LIST
-  { let expAList = fromReverseList $3
-    in StPrivate () (getTransSpan $1 expAList) (Just expAList) }
-| private { StPrivate () (getSpan $1) Nothing }
-| protected MAYBE_DCOLON EXPRESSION_LIST
-  { let expAList = fromReverseList $3
-    in StProtected () (getTransSpan $1 expAList) (Just expAList) }
-| protected { StProtected () (getSpan $1) Nothing }
-| save MAYBE_DCOLON SAVE_ARGS
-  { let saveAList = (fromReverseList $3)
-    in StSave () (getTransSpan $1 saveAList) (Just saveAList) }
-| save { StSave () (getSpan $1) Nothing }
-| procedure '(' MAYBE_PROC_INTERFACE ')' ',' ATTRIBUTE_SPEC '::' PROC_DECLS
-  { let declAList = fromReverseList $8
-    in StProcedure () (getTransSpan $1 $8) $3 (Just $6) declAList }
-| procedure '(' MAYBE_PROC_INTERFACE ')' MAYBE_DCOLON PROC_DECLS
-  { let declAList = fromReverseList $6
-    in StProcedure () (getTransSpan $1 $6) $3 Nothing declAList }
-| dimension MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
-  { let declAList = fromReverseList $3
-    in StDimension () (getTransSpan $1 declAList) declAList }
-| allocatable MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
-  { let declAList = fromReverseList $3
-    in StAllocatable () (getTransSpan $1 declAList) declAList }
-| asynchronous MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
-  { let declAList = fromReverseList $3
-    in StAsynchronous () (getTransSpan $1 declAList) declAList }
-| pointer MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
-  { let declAList = fromReverseList $3
-    in StPointer () (getTransSpan $1 declAList) declAList }
-| target MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
-  { let declAList = fromReverseList $3
-    in StTarget () (getTransSpan $1 declAList) declAList }
-| value MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
-  { let declAList = fromReverseList $3
-    in StValue () (getTransSpan $1 declAList) declAList }
-| volatile MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
-  { let declAList = fromReverseList $3
-    in StVolatile () (getTransSpan $1 declAList) declAList }
-| data cDATA DATA_GROUPS cPOP
-  { let dataAList = fromReverseList $3
-    in StData () (getTransSpan $1 dataAList) dataAList }
-| parameter '(' PARAMETER_ASSIGNMENTS ')'
-  { let declAList = fromReverseList $3
-    in StParameter () (getTransSpan $1 $4) declAList }
-| implicit none { StImplicit () (getTransSpan $1 $2) Nothing }
-| implicit cIMPLICIT IMP_LISTS cPOP
-  { let impAList = fromReverseList $3
-    in StImplicit () (getTransSpan $1 impAList) $ Just $ impAList }
-| namelist cNAMELIST NAMELISTS cPOP
-  { let nameALists = fromReverseList $3
-    in StNamelist () (getTransSpan $1 nameALists) nameALists }
-| equivalence EQUIVALENCE_GROUPS
-  { let eqALists = fromReverseList $2
-    in StEquivalence () (getTransSpan $1 eqALists) eqALists }
-| common cCOMMON COMMON_GROUPS cPOP
-  { let commonAList = fromReverseList $3
-    in StCommon () (getTransSpan $1 commonAList) commonAList }
-| external MAYBE_DCOLON VARIABLES
-  { let alist = fromReverseList $3
-    in StExternal () (getTransSpan $1 alist) alist }
-| intrinsic MAYBE_DCOLON VARIABLES
-  { let alist = fromReverseList $3
-    in StIntrinsic () (getTransSpan $1 alist) alist }
-| use MODULE_NATURE VARIABLE { StUse () (getTransSpan $1 $3) $3 $2 Permissive Nothing }
-| use MODULE_NATURE VARIABLE ',' RENAME_LIST
-  { let alist = fromReverseList $5
-    in StUse () (getTransSpan $1 alist) $3 $2 Permissive (Just alist) }
-| use MODULE_NATURE VARIABLE ',' only ':' MAYBE_RENAME_LIST
-  { StUse () (getTransSpan $1 ($6, $7)) $3 $2 Exclusive $7 }
-| entry VARIABLE MAYBE_RESULT
-  { StEntry () (getTransSpan $1 $ maybe (getSpan $2) getSpan $3) $2 Nothing $3 }
-| entry VARIABLE '(' ')' MAYBE_RESULT
-  { StEntry () (getTransSpan $1 $ maybe (getSpan $4) getSpan $5) $2 Nothing $5 }
-| entry VARIABLE '(' VARIABLES ')' MAYBE_RESULT
-  { StEntry () (getTransSpan $1 $ maybe (getSpan $5) getSpan $6) $2 (Just $ fromReverseList $4) $6 }
-| sequence { StSequence () (getSpan $1) }
-| type ATTRIBUTE_LIST '::' id
-  { let { TId span id = $4;
-          alist = if null $2 then Nothing else (Just . fromReverseList) $2 }
-    in StType () (getTransSpan $1 span) alist id }
-| type id
-  { let TId span id = $2 in StType () (getTransSpan $1 span) Nothing id }
-| endType { StEndType () (getSpan $1) Nothing }
-| endType id
-  { let TId span id = $2 in StEndType () (getTransSpan $1 span) (Just id) }
--- R461-R464
-| enum ',' bind '(' 'c' ')' { StEnum () (getTransSpan $1 $6) }
-| enumerator MAYBE_DCOLON ENUMERATOR_LIST { StEnumerator () (getTransSpan $1 $3) (fromReverseList $3) }
-| endEnum { StEndEnum () (getSpan $1) }
-| include STRING { StInclude () (getTransSpan $1 $2) $2 Nothing }
--- R1209
-| import '::' IMPORT_NAME_LIST { StImport () (getTransSpan $1 $3) (fromReverseList $3) }
-| import IMPORT_NAME_LIST      { StImport () (getTransSpan $1 $2) (fromReverseList $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 }
-
-ENUMERATOR_LIST :: { [Declarator A0] }
-: ENUMERATOR_LIST ',' ENUMERATOR { $3:$1 }
-| ENUMERATOR { [$1] }
-
--- R463
-ENUMERATOR :: { Declarator A0 }
-: PARAMETER_ASSIGNMENT { $1 }
-| VARIABLE { Declarator () (getSpan $1) $1 ScalarDecl Nothing Nothing }
-
-MAYBE_PROC_INTERFACE :: { Maybe (ProcInterface A0) }
-: TYPE_SPEC             { Just $ ProcInterfaceType () (getSpan $1) $1 }
-| VARIABLE              { Just $ ProcInterfaceName () (getSpan $1) $1 }
-| {- EMPTY -}           { Nothing }
-
-PROC_DECLS :: { [ProcDecl A0] }
-: PROC_DECLS ',' PROC_DECL { $3 : $1 }
-| PROC_DECL                { [ $1 ]  }
-
-PROC_DECL :: { ProcDecl A0 }
-: VARIABLE '=>' EXPRESSION { ProcDecl () (getTransSpan $1 $3) $1 (Just $3) }
-| VARIABLE                 { ProcDecl () (getSpan $1) $1 Nothing }
-
-MODULE_NATURE :: { Maybe ModuleNature }
-: ',' intrinsic    '::' { Just ModIntrinsic }
-| ',' nonintrinsic '::' { Just ModNonIntrinsic }
-| '::'                  { Nothing }
-| {- empty -}           { Nothing }
-
-EXECUTABLE_STATEMENT :: { Statement A0 }
-: allocate '(' MAYBE_TYPE_SPEC DATA_REFS MAYBE_ALLOC_OPT_LIST ')'
-  { StAllocate () (getTransSpan $1 $6) $3 (fromReverseList $4) $5 }
-| nullify '(' DATA_REFS ')'
-  { StNullify () (getTransSpan $1 $4) (fromReverseList $3) }
-| deallocate '(' DATA_REFS MAYBE_ALLOC_OPT_LIST ')'
-  { StDeallocate () (getTransSpan $1 $5) (fromReverseList $3) $4 }
-| EXPRESSION_ASSIGNMENT_STATEMENT { $1 }
-| POINTER_ASSIGNMENT_STMT { $1 }
-| where '(' EXPRESSION ')' EXPRESSION_ASSIGNMENT_STATEMENT
-  { StWhere () (getTransSpan $1 $5) $3 $5 }
-| id ':' where '(' EXPRESSION ')' { let (TId s1 id) = $1 in StWhereConstruct () (getTransSpan $1 $6) (Just id) $5 }
-| where '(' EXPRESSION ')' { StWhereConstruct () (getTransSpan $1 $4) Nothing $3 }
-| elsewhere '(' EXPRESSION ')' id { let TId _ id = $5 in StElsewhere () (getTransSpan $1 $5) (Just id) (Just $3) }
-| elsewhere '(' EXPRESSION ')' { StElsewhere () (getTransSpan $1 $4) Nothing (Just $3) }
-| elsewhere id { let TId _ id = $2 in StElsewhere () (getTransSpan $1 $2) (Just id) Nothing }
-| elsewhere { StElsewhere () (getSpan $1) Nothing Nothing }
-| endwhere id { let TId _ id = $2 in StEndWhere () (getTransSpan $1 $2) (Just id) }
-| endwhere { StEndWhere () (getSpan $1) Nothing }
-| if '(' EXPRESSION ')' INTEGER_LITERAL ',' INTEGER_LITERAL ',' INTEGER_LITERAL
-  { StIfArithmetic () (getTransSpan $1 $9) $3 $5 $7 $9 }
-| do { StDo () (getSpan $1) Nothing Nothing Nothing }
-| id ':' do
-  { let TId s id = $1
-    in StDo () (getTransSpan s $3) (Just id) Nothing Nothing }
-| do INTEGER_LITERAL MAYBE_COMMA DO_SPECIFICATION
-  { StDo () (getTransSpan $1 $4) Nothing (Just $2) (Just $4) }
-| do DO_SPECIFICATION { StDo () (getTransSpan $1 $2) Nothing Nothing (Just $2) }
-| id ':' do DO_SPECIFICATION
-  { let TId s id = $1
-    in StDo () (getTransSpan s $4) (Just id) Nothing (Just $4) }
-| do INTEGER_LITERAL MAYBE_COMMA while '(' EXPRESSION ')'
-  { StDoWhile () (getTransSpan $1 $7) Nothing (Just $2) $6 }
-| do while '(' EXPRESSION ')'
-  { StDoWhile () (getTransSpan $1 $5) Nothing Nothing $4 }
-| id ':' do while '(' EXPRESSION ')'
-  { let TId s id = $1
-    in StDoWhile () (getTransSpan s $7) (Just id) Nothing $6 }
-| enddo { StEnddo () (getSpan $1) Nothing }
-| enddo id
-  { let TId s id = $2 in StEnddo () (getTransSpan $1 s) (Just id) }
-| cycle { StCycle () (getSpan $1) Nothing }
-| cycle VARIABLE { StCycle () (getTransSpan $1 $2) (Just $2) }
-| exit { StExit () (getSpan $1) Nothing }
-| exit VARIABLE { StExit () (getTransSpan $1 $2) (Just $2) }
--- GO TO label
-| goto INTEGER_LITERAL { StGotoUnconditional () (getTransSpan $1 $2) $2 }
--- GO TO label-list [,] scalar-int-expression
-| goto '(' INTEGERS ')' MAYBE_COMMA EXPRESSION
-  { StGotoComputed () (getTransSpan $1 $6) (fromReverseList $3) $6 }
-| continue { StContinue () (getSpan $1) }
-| stop { StStop () (getSpan $1) Nothing }
-| stop EXPRESSION { StStop () (getTransSpan $1 $2) (Just $2) }
-| if '(' EXPRESSION ')' EXECUTABLE_STATEMENT
-  { StIfLogical () (getTransSpan $1 $5) $3 $5 }
-| read CILIST IN_IOLIST
-  { let alist = fromReverseList $3
-    in StRead () (getTransSpan $1 alist) $2 (Just alist) }
-| read CILIST { StRead () (getTransSpan $1 $2) $2 Nothing }
-| read FORMAT_ID ',' IN_IOLIST
-  { let alist = fromReverseList $4
-    in StRead2 () (getTransSpan $1 alist) $2 (Just alist) }
-| read FORMAT_ID { StRead2 () (getTransSpan $1 $2) $2 Nothing }
-| write CILIST OUT_IOLIST
-  { let alist = fromReverseList $3
-    in StWrite () (getTransSpan $1 alist) $2 (Just alist) }
-| write CILIST { StWrite () (getTransSpan $1 $2) $2 Nothing }
-| print FORMAT_ID ',' OUT_IOLIST
-  { let alist = fromReverseList $4
-    in StPrint () (getTransSpan $1 alist) $2 (Just alist) }
-| print FORMAT_ID { StPrint () (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 }
-| flush INTEGER_LITERAL { StFlush () (getTransSpan $1 $2) (AList () (getSpan $2) [FSUnit () (getSpan $2) $2]) }
-| flush '(' FLUSH_SPEC_LIST ')' { StFlush () (getTransSpan $1 $4) (fromReverseList $3) }
-| call VARIABLE { StCall () (getTransSpan $1 $2) $2 Nothing }
-| call VARIABLE '(' ')' { StCall () (getTransSpan $1 $4) $2 Nothing }
-| call VARIABLE '(' ARGUMENTS ')'
-  { let alist = fromReverseList $4
-    in StCall () (getTransSpan $1 $5) $2 (Just alist) }
-| return { StReturn () (getSpan $1) Nothing }
-| return EXPRESSION { StReturn () (getTransSpan $1 $2) (Just $2) }
-| FORALL { $1 }
-| END_FORALL { $1 }
-
-ARGUMENTS :: { [ Argument A0 ] }
-: ARGUMENTS ',' ARGUMENT { $3 : $1 }
-| ARGUMENT { [ $1 ] }
-
-ARGUMENT :: { Argument A0 }
-: id '=' EXPRESSION
-  { let TId span keyword = $1
-    in Argument () (getTransSpan span $3) (Just keyword) $3 }
-| EXPRESSION
-  { Argument () (getSpan $1) Nothing $1 }
-
-MAYBE_RENAME_LIST :: { Maybe (AList Use A0) }
-: RENAME_LIST { Just $ fromReverseList $1 }
-| {- empty -} { Nothing }
-
-RENAME_LIST :: { [ Use A0 ] }
-: RENAME_LIST ',' RENAME { $3 : $1 }
-| RENAME { [ $1 ] }
-
-RENAME :: { Use A0  }
-: VARIABLE '=>' VARIABLE { UseRename () (getTransSpan $1 $3) $1 $3 }
-| VARIABLE { UseID () (getSpan $1) $1 }
-| operator '(' opCustom ')'
-  { let TOpCustom ss op = $3
-    in UseID () (getTransSpan $1 $4) (ExpValue () ss (ValOperator op)) }
-| assignment { UseID () (getSpan $1) (ExpValue () (getSpan $1) ValAssignment) }
-
-MAYBE_DCOLON :: { () } : '::' { () } | {- EMPTY -} { () }
-
-FORMAT_ID :: { Expression A0 }
-: FORMAT_ID '/' '/' FORMAT_ID %prec CONCAT
-  { ExpBinary () (getTransSpan $1 $4) Concatenation $1 $4 }
-| INTEGER_LITERAL { $1 }
-| STRING { $1 }
-| DATA_REF { $1 }
-| '*' { ExpValue () (getSpan $1) ValStar }
-
-UNIT :: { Expression A0 }
-: INTEGER_LITERAL { $1 }
-| DATA_REF { $1 }
-| '*' { ExpValue () (getSpan $1) ValStar }
-
-{- R928 -}
-FLUSH_SPEC_LIST :: { [ FlushSpec A0 ] }
-: FLUSH_SPEC_LIST ',' FLUSH_SPEC { $3 : $1 }
-| FLUSH_SPEC { [ $1 ] }
-
-{- R928 -}
-FLUSH_SPEC :: { FlushSpec A0 }
-: EXPRESSION { FSUnit () (getSpan $1) $1 }
-| unit '=' EXPRESSION   { FSUnit () (getTransSpan $1 $3) $3 }
-| iostat '=' EXPRESSION { FSIOStat () (getTransSpan $1 $3) $3 }
-| iomsg '=' EXPRESSION  { FSIOMsg () (getTransSpan $1 $3) $3 }
-| err '=' EXPRESSION    { FSErr () (getTransSpan $1 $3) $3 }
-
-CILIST :: { AList ControlPair A0 }
-: '(' CILIST_ELEMENT ',' FORMAT_ID ',' CILIST_PAIRS ')'
-  { let { cp1 = ControlPair () (getSpan $2) Nothing $2;
-          cp2 = ControlPair () (getSpan $4) Nothing $4;
-          tail = fromReverseList $6 }
-    in setSpan (getTransSpan $1 $7) $ cp1 `aCons` cp2 `aCons` tail }
-| '(' CILIST_ELEMENT ',' FORMAT_ID ')'
-  { let { cp1 = ControlPair () (getSpan $2) Nothing $2;
-          cp2 = ControlPair () (getSpan $4) Nothing $4 }
-    in AList () (getTransSpan $1 $5) [ cp1,  cp2 ] }
-| '(' CILIST_ELEMENT ',' CILIST_PAIRS ')'
-  { let { cp1 = ControlPair () (getSpan $2) Nothing $2;
-          tail = fromReverseList $4 }
-    in setSpan (getTransSpan $1 $5) $ cp1 `aCons` tail }
-| '(' CILIST_ELEMENT ')'
-  { let cp1 = ControlPair () (getSpan $2) Nothing $2
-    in AList () (getTransSpan $1 $3) [ cp1 ] }
-| '(' CILIST_PAIRS ')' { fromReverseList $2 }
-
-CILIST_PAIRS :: { [ ControlPair A0 ] }
-: CILIST_PAIRS ',' CILIST_PAIR { $3 : $1 }
-| CILIST_PAIR { [ $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 SIGN
-  { 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 }
-| 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 }
-| opCustom CI_EXPRESSION %prec DEFINED_UNARY
-  { let TOpCustom span str = $1
-    in ExpUnary () (getTransSpan span $2) (UnCustom str) $2 }
-| CI_EXPRESSION opCustom CI_EXPRESSION
-  { let TOpCustom _ str = $2
-    in ExpBinary () (getTransSpan $1 $3) (BinCustom str) $1 $3 }
-| '(' CI_EXPRESSION ')' { setSpan (getTransSpan $1 $3) $2 }
-| INTEGER_LITERAL { $1 }
-| LOGICAL_LITERAL { $1 }
-| STRING { $1 }
-| DATA_REF { $1 }
-
-MAYBE_ALLOC_OPT_LIST :: { Maybe (AList AllocOpt A0) }
-: ',' ALLOC_OPT_LIST { Just $ fromReverseList $2 }
-| {- empty -}        { Nothing }
-
-ALLOC_OPT_LIST :: { [ AllocOpt A0 ] }
-: ALLOC_OPT_LIST ',' ALLOC_OPT { $3 : $1 }
-| ALLOC_OPT                    { [ $1 ] }
-
-{- R624 -}
-ALLOC_OPT :: { AllocOpt A0 }
-: stat '=' EXPRESSION   { AOStat () (getTransSpan $1 $3) $3 }
-| errmsg '=' EXPRESSION { AOErrMsg () (getTransSpan $1 $3) $3 }
-| source '=' EXPRESSION { AOSource () (getTransSpan $1 $3) $3 }
-
-IN_IOLIST :: { [ Expression A0 ] }
-: IN_IOLIST ',' IN_IO_ELEMENT { $3 : $1}
-| IN_IO_ELEMENT { [ $1 ] }
-
-IN_IO_ELEMENT :: { Expression A0 }
-: DATA_REF { $1 }
-| '(' IN_IOLIST ',' DO_SPECIFICATION ')'
-  { ExpImpliedDo () (getTransSpan $1 $5) (fromReverseList $2) $4 }
-
-OUT_IOLIST :: { [ Expression A0 ] }
-: OUT_IOLIST ',' EXPRESSION { $3 : $1}
-| EXPRESSION { [ $1 ] }
-
-COMMON_GROUPS :: { [ CommonGroup A0 ] }
-: COMMON_GROUPS COMMON_GROUP { $2 : $1 }
-| COMMON_GROUPS ',2' COMMON_GROUP { $3 : $1 }
-| INIT_COMMON_GROUP { [ $1 ] }
-
-COMMON_GROUP :: { CommonGroup A0 }
-: COMMON_NAME UNINITIALIZED_DECLARATOR_LIST
-  { let alist = fromReverseList $2
-    in CommonGroup () (getTransSpan $1 alist) (Just $1) alist }
-| '/' '/' UNINITIALIZED_DECLARATOR_LIST
-  { let alist = fromReverseList $3
-    in CommonGroup () (getTransSpan $1 alist) Nothing alist }
-
-INIT_COMMON_GROUP :: { CommonGroup A0 }
-: COMMON_NAME UNINITIALIZED_DECLARATOR_LIST
-  { let alist = fromReverseList $2
-    in CommonGroup () (getTransSpan $1 alist) (Just $1) alist }
-| '/' '/' UNINITIALIZED_DECLARATOR_LIST
-  { let alist = fromReverseList $3
-    in CommonGroup () (getTransSpan $1 alist) Nothing alist }
-| UNINITIALIZED_DECLARATOR_LIST
-  { let alist = fromReverseList $1
-    in CommonGroup () (getSpan alist) Nothing alist }
-
-EQUIVALENCE_GROUPS :: { [ AList Expression A0 ] }
-: EQUIVALENCE_GROUPS ',' '(' PART_REFS ')'
-  { setSpan (getTransSpan $3 $5) (fromReverseList $4) : $1 }
-| '(' PART_REFS ')'
-  { [ setSpan (getTransSpan $1 $3) (fromReverseList $2) ] }
-
-NAMELISTS :: { [ Namelist A0 ] }
-: NAMELISTS NAMELIST { $2 : $1 }
-| NAMELISTS ',2' NAMELIST { $3 : $1 }
-| NAMELIST { [ $1 ] }
-
-NAMELIST :: { Namelist A0 }
-: '/' VARIABLE '/' VARIABLES
-  { Namelist () (getTransSpan $1 $4) $2 $ fromReverseList $4 }
-
-MAYBE_VARIABLES :: { Maybe (AList Expression A0) }
-: VARIABLES { Just $ fromReverseList $1 } | {- EMPTY -} { Nothing }
-
-VARIABLES :: { [ Expression A0 ] }
-: VARIABLES ',' VARIABLE { $3 : $1 }
-| VARIABLE { [ $1 ] }
-
-IMP_LISTS :: { [ ImpList A0 ] }
-: IMP_LISTS ',' IMP_LIST { $3 : $1 }
-| IMP_LIST { [ $1 ] }
-
-IMP_LIST :: { ImpList A0 }
-: TYPE_SPEC '(2' 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
-             }
-
-PARAMETER_ASSIGNMENTS :: { [ Declarator A0 ] }
-: PARAMETER_ASSIGNMENTS ',' PARAMETER_ASSIGNMENT { $3 : $1 }
-| PARAMETER_ASSIGNMENT { [ $1 ] }
-
-PARAMETER_ASSIGNMENT :: { Declarator A0 }
-: VARIABLE '=' EXPRESSION
-  { Declarator () (getTransSpan $1 $3) $1 ScalarDecl Nothing (Just $3) }
-
-DECLARATION_STATEMENT :: { Statement A0 }
-: TYPE_SPEC ATTRIBUTE_LIST '::' INITIALIZED_DECLARATOR_LIST
-  { let { mAttrAList = if null $2 then Nothing else Just $ fromReverseList $2;
-          declAList = fromReverseList $4 }
-    in StDeclaration () (getTransSpan $1 declAList) $1 mAttrAList declAList }
-| TYPE_SPEC INITIALIZED_DECLARATOR_LIST
-  { let { declAList = fromReverseList $2 }
-    in StDeclaration () (getTransSpan $1 declAList) $1 Nothing declAList }
-
-ATTRIBUTE_LIST :: { [ Attribute A0 ] }
-: ATTRIBUTE_LIST ',' ATTRIBUTE_SPEC { $3 : $1 }
-| {- EMPTY -} { [ ] }
-
-ATTRIBUTE_SPEC :: { Attribute A0 }
-: public { AttrPublic () (getSpan $1) }
-| private { AttrPrivate () (getSpan $1) }
-| protected { AttrProtected () (getSpan $1) }
-| allocatable { AttrAllocatable () (getSpan $1) }
-| asynchronous { AttrAsynchronous () (getSpan $1) }
-| dimension '(' DIMENSION_DECLARATORS ')'
-  { AttrDimension () (getTransSpan $1 $4) (aReverse $3) }
-| external { AttrExternal () (getSpan $1) }
-| intent '(' INTENT_CHOICE ')' { AttrIntent () (getTransSpan $1 $4) $3 }
-| intrinsic { AttrIntrinsic () (getSpan $1) }
-| optional { AttrOptional () (getSpan $1) }
-| pointer { AttrPointer () (getSpan $1) }
-| parameter { AttrParameter () (getSpan $1) }
-| save { AttrSave () (getSpan $1) }
-| target { AttrTarget () (getSpan $1) }
-| value { AttrValue () (getSpan $1) }
-| volatile { AttrVolatile () (getSpan $1) }
-| SUFFIX { AttrSuffix () (getSpan $1) $1 }
-
-INTENT_CHOICE :: { Intent } : in { In } | out { Out } | inout { InOut }
-
-DATA_GROUPS :: { [ DataGroup A0 ] }
-: DATA_GROUPS MAYBE_COMMA DATA_LIST slash EXPRESSION_LIST slash
-  { let { nameAList = fromReverseList $3;
-          dataAList = fromReverseList $5 }
-    in DataGroup () (getTransSpan nameAList $6) nameAList dataAList : $1 }
-| DATA_LIST slash EXPRESSION_LIST slash
-  { let { nameAList = fromReverseList $1;
-          dataAList = fromReverseList $3 }
-    in [ DataGroup () (getTransSpan nameAList $4) nameAList dataAList ] }
-
-MAYBE_COMMA :: { () } : ',' { () } | {- EMPTY -} { () }
-
-DATA_LIST :: { [ Expression A0 ] }
-: DATA_LIST ',' DATA_ELEMENT { $3 : $1 }
-| DATA_ELEMENT { [ $1 ] }
-
-DATA_ELEMENT :: { Expression A0 }
-: DATA_REF { $1 } | IMPLIED_DO { $1 }
-
-SAVE_ARGS :: { [ Expression A0 ] }
-: SAVE_ARGS ',' SAVE_ARG { $3 : $1 } | SAVE_ARG { [ $1 ] }
-
-SAVE_ARG :: { Expression A0 } : COMMON_NAME { $1 } | VARIABLE { $1 }
-
-COMMON_NAME :: { Expression A0 }
-: '/' VARIABLE '/' { setSpan (getTransSpan $1 $3) $2 }
-
-INITIALIZED_DECLARATOR_LIST :: { [ Declarator A0 ] }
-: INITIALIZED_DECLARATOR_LIST ',' INITIALIZED_DECLARATOR { $3 : $1 }
-| INITIALIZED_DECLARATOR { [ $1 ] }
-
-UNINITIALIZED_DECLARATOR_LIST :: { [ Declarator A0 ] }
-: UNINITIALIZED_DECLARATOR_LIST ',' DECLARATOR { $3 : $1 }
-| DECLARATOR { [ $1 ] }
-
-INITIALIZED_DECLARATOR :: { Declarator A0 }
-: DECLARATOR '=' EXPRESSION { setInitialisation $1 $3 }
-| DECLARATOR '=>' EXPRESSION { setInitialisation $1 $3 }
-| DECLARATOR { $1 }
-
-DECLARATOR :: { Declarator A0 }
-: VARIABLE
-  {     Declarator () (getSpan $1)         $1 ScalarDecl                Nothing     Nothing }
-| VARIABLE '*' EXPRESSION
-  {     Declarator () (getTransSpan $1 $3) $1 ScalarDecl                (Just $3)   Nothing }
-| VARIABLE '*' '(' '*' ')'
-  { let star = ExpValue () (getSpan $4) ValStar
-     in Declarator () (getTransSpan $1 $5) $1 ScalarDecl                (Just star) Nothing }
-| VARIABLE '(' DIMENSION_DECLARATORS ')'
-  {     Declarator () (getTransSpan $1 $4) $1 (ArrayDecl (aReverse $3)) Nothing     Nothing }
-| VARIABLE '(' DIMENSION_DECLARATORS ')' '*' EXPRESSION
-  {     Declarator () (getTransSpan $1 $6) $1 (ArrayDecl (aReverse $3)) (Just $6)   Nothing }
--- nonstandard char array syntax (wrong order for dimensions & charlen)
-| VARIABLE '*' EXPRESSION '(' DIMENSION_DECLARATORS ')'
-  {     Declarator () (getTransSpan $1 $6) $1 (ArrayDecl (aReverse $5)) (Just $3)   Nothing }
-| VARIABLE '(' DIMENSION_DECLARATORS ')' '*' '(' '*' ')'
-  { let star = ExpValue () (getSpan $7) ValStar
-     in Declarator () (getTransSpan $1 $8) $1 (ArrayDecl (aReverse $3)) (Just star) 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 ':' EXPRESSION
-  { DimensionDeclarator () (getTransSpan $1 $3) (Just $1) (Just $3) }
-| EXPRESSION { DimensionDeclarator () (getSpan $1) Nothing (Just $1) }
--- Lower bound only
-| EXPRESSION ':'
-  { DimensionDeclarator () (getTransSpan $1 $2) (Just $1) Nothing }
-| EXPRESSION ':' '*'
-  { let { span = getSpan $3;
-          star = ExpValue () span ValStar }
-    in DimensionDeclarator () (getTransSpan $1 span) (Just $1) (Just star) }
-| '*'
-  { let { span = getSpan $1;
-          star = ExpValue () span ValStar }
-    in DimensionDeclarator () span Nothing (Just star) }
-| ':'
-  { let span = getSpan $1
-    in DimensionDeclarator () span Nothing Nothing }
-
-MAYBE_TYPE_SPEC :: { Maybe (TypeSpec A0) }
-: TYPE_SPEC '::' { Just $1 }
-| {- empty -}    { 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 }
-| complex KIND_SELECTOR   { TypeSpec () (getSpan ($1, $2)) TypeComplex $2 }
-| character CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeCharacter $2 }
-| logical KIND_SELECTOR   { TypeSpec () (getSpan ($1, $2)) TypeLogical $2 }
-| type '(' id ')'
-  { let TId _ id = $3
-    in TypeSpec () (getTransSpan $1 $4) (TypeCustom id) Nothing }
--- R502
-| class '(' '*' ')'       { TypeSpec () (getSpan ($1, $4)) ClassStar Nothing }
--- FIXME: this (and TypeCustom) can accept parameterised types. See type-param-value.
--- Needs refactoring as this is used in various parts of the spec to consolidate
--- uses of ':', '*' and scalar-int-exp.
-| class '(' id ')'
-  { let TId _ id = $3
-    in TypeSpec () (getSpan ($1, $4)) (ClassCustom id) Nothing }
-
-KIND_SELECTOR :: { Maybe (Selector A0) }
-: '(' EXPRESSION ')'
-  { Just $ Selector () (getTransSpan $1 $3) Nothing (Just $2) }
-| '(' kind '=' EXPRESSION ')'
-  { Just $ Selector () (getTransSpan $1 $5) Nothing (Just $4) }
-| '*' EXPRESSION -- non-standard but commonly used extension
-  { Just $ Selector () (getTransSpan $1 $2) Nothing (Just $2) }
-| {- EMPTY -} { Nothing }
-
-CHAR_SELECTOR :: { Maybe (Selector A0) }
-: '*' EXPRESSION
-  { Just $ Selector () (getTransSpan $1 $2) (Just $2) Nothing }
--- The following rule is a bug in the spec.
--- | '*' EXPRESSION ','
---   { Just $ Selector () (getTransSpan $1 $2) (Just $2) Nothing }
-| '*' '(' '*' ')'
-  { let star = ExpValue () (getSpan $3) ValStar
-    in Just $ Selector () (getTransSpan $1 $4) (Just star) Nothing }
-| '(' LEN_EXPRESSION ')'
-  { Just $ Selector () (getTransSpan $1 $3) (Just $2) Nothing }
-| '(' len '=' LEN_EXPRESSION ')'
-  { Just $ Selector () (getTransSpan $1 $5) (Just $4) Nothing }
-| '(' kind '=' EXPRESSION ')'
-  { Just $ Selector () (getTransSpan $1 $5) Nothing (Just $4) }
-| '(' LEN_EXPRESSION ',' EXPRESSION ')'
-  { Just $ Selector () (getTransSpan $1 $5) (Just $2) (Just $4) }
-| '(' LEN_EXPRESSION ',' kind '=' EXPRESSION ')'
-  { Just $ Selector () (getTransSpan $1 $7) (Just $2) (Just $6) }
-| '(' len '=' LEN_EXPRESSION ',' kind '=' EXPRESSION ')'
-  { Just $ Selector () (getTransSpan $1 $9) (Just $4) (Just $8) }
-| '(' kind '=' EXPRESSION ',' len '=' LEN_EXPRESSION ')'
-  { Just $ Selector () (getTransSpan $1 $9) (Just $8) (Just $4) }
-| {- EMPTY -} { Nothing }
-
-{- R402 -}
-LEN_EXPRESSION :: { Expression A0 }
-: EXPRESSION { $1 }
-| '*' { ExpValue () (getSpan $1) ValStar }
-| ':' { ExpValue () (getSpan $1) ValColon }
-
-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 SIGN
-  { 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 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 }
-| opCustom EXPRESSION %prec DEFINED_UNARY
-  { let TOpCustom span str = $1
-    in ExpUnary () (getTransSpan span $2) (UnCustom str) $2 }
-| EXPRESSION opCustom EXPRESSION
-  { let TOpCustom _ str = $2
-    in ExpBinary () (getTransSpan $1 $3) (BinCustom str) $1 $3 }
-| '(' EXPRESSION ')' { setSpan (getTransSpan $1 $3) $2 }
-| NUMERIC_LITERAL                   { $1 }
-| '(' EXPRESSION ',' EXPRESSION ')'
-  { ExpValue () (getTransSpan $1 $5) (ValComplex $2 $4) }
-| LOGICAL_LITERAL                   { $1 }
-| STRING                            { $1 }
-| DATA_REF                          { $1 }
-| IMPLIED_DO                        { $1 }
-| '(/' EXPRESSION_LIST '/)'
-  { ExpInitialisation () (getTransSpan $1 $3) (fromReverseList $2) }
-| operator '(' opCustom ')'
-  { let TOpCustom _ op = $3
-    in ExpValue () (getTransSpan $1 $4) (ValOperator op) }
-| assignment { ExpValue () (getSpan $1) ValAssignment }
-| '*' INTEGER_LITERAL { ExpReturnSpec () (getTransSpan $1 $2) $2 }
-
-DATA_REFS :: { [ Expression A0 ] }
-: DATA_REFS ',' DATA_REF { $3 : $1 }
-| DATA_REF { [ $1 ] }
-
-DATA_REF :: { Expression A0 }
-: DATA_REF '%' PART_REF { ExpDataRef () (getTransSpan $1 $3) $1 $3 }
-| PART_REF { $1 }
-
-PART_REFS :: { [ Expression A0 ] }
-: PART_REFS ',' PART_REF { $3 : $1 }
-| PART_REF { [ $1 ] }
-
-PART_REF :: { Expression A0 }
-: VARIABLE { $1 }
-| VARIABLE '(' ')'
-  { ExpFunctionCall () (getTransSpan $1 $3) $1 Nothing }
-| VARIABLE '(' INDICIES ')'
-  { ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3) }
-| VARIABLE '(' INDICIES ')' '(' INDICIES ')'
-  { let innerSub = ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3)
-    in ExpSubscript () (getTransSpan $1 $7) innerSub (fromReverseList $6) }
-
-INDICIES :: { [ Index A0 ] }
-: INDICIES ',' INDEX { $3 : $1 }
-| INDEX { [ $1 ] }
-
-INDEX :: { Index A0 }
-: RANGE { $1 }
-| RANGE ':' EXPRESSION
-  { let IxRange () s lower upper _ = $1
-    in IxRange () (getTransSpan s $3) lower upper (Just $3) }
-| EXPRESSION { IxSingle () (getSpan $1) Nothing $1 }
--- Following is only as an intermediate stage before having been turned into
--- an argument by later transformation.
-| id '=' EXPRESSION
-  { let TId s id = $1 in IxSingle () (getTransSpan $1 s) (Just id) $3 }
-
-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 }
-
-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 }
-
-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 }
-
-FORALL :: { Statement A0 }
-: id ':' forall FORALL_HEADER {
-  let (TId s1 id) = $1 in
-  let (h,s2) = $4 in
-  StForall () (getTransSpan s1 s2) (Just id) h
-}
-| forall FORALL_HEADER {
-  let (h,s) = $2 in
-  StForall () (getTransSpan $1 s) Nothing h
-}
-| forall FORALL_HEADER FORALL_ASSIGNMENT_STMT {
-  let (h,_) = $2 in
-  StForallStatement () (getTransSpan $1 $3) h $3
-}
-
-FORALL_HEADER :: { (ForallHeader A0, SrcSpan) }
--- Standard simple forall header
-: '(' FORALL_TRIPLET_SPEC ')'   { (ForallHeader [$2] Nothing, getTransSpan $1 $3) }
--- forall header with scale expression
-| '(' '(' FORALL_TRIPLET_SPEC ')' ',' EXPRESSION ')'
-                              { (ForallHeader [$3] (Just $6), getTransSpan $1 $7) }
--- multi forall header
-| '(' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE ')'
-                              { (ForallHeader $2 Nothing, getTransSpan $1 $3) }
--- multi forall header with scale
-| '(' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE ',' EXPRESSION ')'
-                              { (ForallHeader $2 (Just $4), getTransSpan $1 $5) }
-
-FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE
-  :: { [(Name, Expression A0, Expression A0, Maybe (Expression A0))] }
-: '(' FORALL_TRIPLET_SPEC ')' ',' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE { $2 : $5 }
-| {- empty -}                                                          { [] }
-
-FORALL_TRIPLET_SPEC :: { (Name, Expression A0, Expression A0, Maybe (Expression A0)) }
-: NAME '=' EXPRESSION ':' EXPRESSION { ($1, $3, $5, Nothing) }
-| NAME '=' EXPRESSION ':' EXPRESSION ',' EXPRESSION { ($1, $3, $5, Just $7) }
-
-FORALL_ASSIGNMENT_STMT :: { Statement A0 }
-: EXPRESSION_ASSIGNMENT_STATEMENT { $1 }
-| POINTER_ASSIGNMENT_STMT { $1 }
-
-POINTER_ASSIGNMENT_STMT :: { Statement A0 }
-: DATA_REF '=>' EXPRESSION { StPointerAssign () (getTransSpan $1 $3) $1 $3 }
-
-END_FORALL :: { Statement A0 }
-: endforall    { StEndForall () (getSpan $1) Nothing }
-| endforall id { let (TId s id) = $2 in StEndForall () (getTransSpan $1 s) (Just id)}
-
-EXPRESSION_LIST :: { [ Expression A0 ] }
-: EXPRESSION_LIST ',' EXPRESSION { $3 : $1 }
-| EXPRESSION { [ $1 ] }
-
-ARITHMETIC_SIGN :: { (SrcSpan, UnaryOp) }
-: '-' { (getSpan $1, Minus) }
-| '+' { (getSpan $1, Plus) }
-
-RELATIONAL_OPERATOR :: { BinaryOp }
-: '=='  { EQ }
-| '!='  { NE }
-| '>'   { GT }
-| '>='  { GTE }
-| '<'   { LT }
-| '<='  { LTE }
-
-VARIABLE :: { Expression A0 }
-: id { ExpValue () (getSpan $1) $ let (TId _ s) = $1 in ValVariable s }
-
-NUMERIC_LITERAL :: { Expression A0 }
-: INTEGER_LITERAL { $1 } | REAL_LITERAL { $1 }
-
-INTEGERS :: { [ Expression A0 ] }
-: INTEGERS ',' INTEGER_LITERAL { $3 : $1 }
-| INTEGER_LITERAL { [ $1 ] }
-
-INTEGER_LITERAL :: { Expression A0 }
-: int
-  { let TIntegerLiteral s i = $1
-     in ExpValue () s $ ValInteger i Nothing   }
-| int '_' KIND_PARAM
-  { let TIntegerLiteral s i = $1
-     in ExpValue () s $ ValInteger i (Just $3) }
-| boz { let TBozLiteral s b = $1 in ExpValue () s $ ValBoz b }
-
-REAL_LITERAL :: { Expression A0 }
-: float
-  { let TRealLiteral s r = $1
-     in ExpValue () s $ ValReal r Nothing }
-| float '_' KIND_PARAM
-  { let TRealLiteral s r = $1
-     in ExpValue () s $ ValReal r (Just $3) }
-
-LOGICAL_LITERAL :: { Expression A0 }
-: bool
-  { let TLogicalLiteral s b = $1
-     in ExpValue () s (ValLogical b Nothing) }
-| bool '_' KIND_PARAM
-  { let TLogicalLiteral s b = $1
-     in ExpValue () s (ValLogical b (Just $3)) }
-
-KIND_PARAM :: { Expression A0 }
-: INTEGER_LITERAL { $1 }
-| VARIABLE        { $1 }
-
-STRING :: { Expression A0 }
-: string { let TString s c = $1 in ExpValue () s $ ValString c }
-
-cDATA :: { () } : {% pushContext ConData }
-cIMPLICIT :: { () } : {% pushContext ConImplicit }
-cNAMELIST :: { () } : {% pushContext ConNamelist }
-cCOMMON :: { () } : {% pushContext ConCommon }
-cPOP :: { () } : {% popContext }
-
-{
-
-unitNameCheck :: Token -> String -> Parse AlexInput Token ()
-unitNameCheck (TId _ name1) name2
-  | name1 == name2 = return ()
-  | otherwise = fail "Unit name does not match the corresponding END statement."
-unitNameCheck _ _ = return ()
-
-parse = runParse programParser
-defTransforms = defaultTransformations Fortran2003
-
-fortran2003Parser
-    :: B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)
-fortran2003Parser = fortran2003ParserWithTransforms defTransforms
-
-fortran2003ParserWithTransforms
-    :: [Transformation]
-    -> B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)
-fortran2003ParserWithTransforms =
-    flip fortran2003ParserWithModFilesWithTransforms emptyModFiles
-
-fortran2003ParserWithModFiles
-    :: ModFiles
-    -> B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)
-fortran2003ParserWithModFiles = fortran2003ParserWithModFilesWithTransforms defTransforms
-
-fortran2003ParserWithModFilesWithTransforms
-    :: [Transformation] -> ModFiles
-    -> B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)
-fortran2003ParserWithModFilesWithTransforms transforms mods sourceCode filename =
-    fmap (pfSetFilename filename . transformWithModFiles mods transforms) $ parse parseState
-  where
-    parseState = initParseState sourceCode Fortran2003 filename
-
-parseError :: Token -> LexAction a
-parseError token = do
-    parseState <- get
-#ifdef DEBUG
-    tokens <- reverse <$> aiPreviousTokensInLine <$> getAlex
-#endif
-    fail $ psFilename parseState ++ ": parsing failed. "
-      ++ specifics token
-#ifdef DEBUG
-      ++ '\n' : show tokens
-#endif
-  where specifics (TPause _) = "\nPAUSE statements are not supported in Fortran 2003 or later. "
-        specifics (TAssign _) = "\nASSIGN statements are not supported in Fortran 2003 or later. "
-        specifics _ = ""
-
-}
diff --git a/src/Language/Fortran/Parser/Fortran66.y b/src/Language/Fortran/Parser/Fortran66.y
deleted file mode 100644
--- a/src/Language/Fortran/Parser/Fortran66.y
+++ /dev/null
@@ -1,512 +0,0 @@
--- -*- Mode: Haskell -*-
--- vim: ft=haskell
-{
-module Language.Fortran.Parser.Fortran66 ( expressionParser
-                                         , statementParser
-                                         , fortran66Parser
-                                         , fortran66ParserWithTransforms
-                                         , fortran66ParserWithModFiles
-                                         , fortran66ParserWithModFilesWithTransforms
-                                         ) where
-
-import Prelude hiding (EQ,LT,GT) -- Same constructors exist in the AST
-
-import Control.Monad.State
-import Data.Maybe (isNothing, fromJust)
-import qualified Data.ByteString.Char8 as B
-import Language.Fortran.Util.Position
-import Language.Fortran.Util.ModFile
-import Language.Fortran.ParserMonad
-import Language.Fortran.Lexer.FixedForm
-import Language.Fortran.Lexer.FixedForm.Utils
-import Language.Fortran.Transformer
-import Language.Fortran.AST
-import Language.Fortran.AST.RealLit
-
-}
-
-%name programParser PROGRAM
-%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 $1 }
-| EXPRESSION  { Argument () (getSpan $1) Nothing $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 { makeReal (Just $1) Nothing Nothing (Just $2) }
-| int '.' MAYBE_EXPONENT { makeReal (Just $1) (Just $2) Nothing $3 }
-| '.' int MAYBE_EXPONENT { makeReal Nothing (Just $1) (Just $2) $3 }
-| int '.' int MAYBE_EXPONENT { makeReal (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 }
-
-{
-
-parse = runParse programParser
-defTransforms = defaultTransformations Fortran66
-
-fortran66Parser
-    :: B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)
-fortran66Parser = fortran66ParserWithTransforms defTransforms
-
-fortran66ParserWithTransforms
-    :: [Transformation]
-    -> B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)
-fortran66ParserWithTransforms =
-    flip fortran66ParserWithModFilesWithTransforms emptyModFiles
-
-fortran66ParserWithModFiles
-    :: ModFiles
-    -> B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)
-fortran66ParserWithModFiles =
-    fortran66ParserWithModFilesWithTransforms defTransforms
-
-fortran66ParserWithModFilesWithTransforms
-    :: [Transformation] -> ModFiles
-    -> B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)
-fortran66ParserWithModFilesWithTransforms transforms mods sourceCode filename =
-    fmap (pfSetFilename filename . transformWithModFiles mods transforms) $ parse parseState
-  where
-    parseState = initParseState sourceCode Fortran66 filename
-
-parseError :: Token -> LexAction a
-parseError _ = do
-    parseState <- get
-#ifdef DEBUG
-    tokens <- reverse <$> aiPreviousTokensInLine <$> getAlex
-#endif
-    fail $ psFilename parseState ++ ": parsing failed. "
-#ifdef DEBUG
-      ++ '\n' : show tokens
-#endif
-
-convCmts = map convCmt
-convCmt (BlComment a s c) = PUComment a s c
-convCmt _ = error "convCmt applied to something that is not a comment"
-
-}
diff --git a/src/Language/Fortran/Parser/Fortran77.y b/src/Language/Fortran/Parser/Fortran77.y
deleted file mode 100644
--- a/src/Language/Fortran/Parser/Fortran77.y
+++ /dev/null
@@ -1,1152 +0,0 @@
--- -*- Mode: Haskell -*-
--- vim: ft=haskell
-{
-{-# LANGUAGE TupleSections #-}
-module Language.Fortran.Parser.Fortran77
-  ( expressionParser
-  , statementParser
-  , blockParser
-  , fortran77Parser
-  , fortran77ParserWithTransforms
-  , fortran77ParserWithModFiles
-  , fortran77ParserWithModFilesWithTransforms
-  , extended77Parser
-  , extended77ParserWithTransforms
-  , extended77ParserWithModFiles
-  , extended77ParserWithModFilesWithTransforms
-  , legacy77Parser
-  , legacy77ParserWithTransforms
-  , legacy77ParserWithModFiles
-  , legacy77ParserWithModFilesWithTransforms
-  , legacy77ParserWithIncludes
-  , legacy77ParserWithIncludesWithTransforms
-  , includeParser
-
-  ) where
-
-import Prelude hiding (EQ,LT,GT) -- Same constructors exist in the AST
-
-import Control.Monad.State
-import Data.List
-import Data.Maybe (isNothing, fromJust)
-import qualified Data.ByteString.Char8 as B
-import qualified Data.Map as M
-import Language.Fortran.Util.Position
-import Language.Fortran.Util.ModFile
-import Language.Fortran.ParserMonad
-import Language.Fortran.Lexer.FixedForm hiding (Move(..))
-import Language.Fortran.Lexer.FixedForm.Utils
-import Language.Fortran.Transformer
-import Language.Fortran.AST
-import Language.Fortran.AST.RealLit
-
-import Data.Generics.Uniplate.Operations
-import System.Directory
-import System.FilePath
-import Control.Exception
-
-}
-
-%name programParser PROGRAM
-%name includesParser INCLUDES
-%name blockParser BLOCK
-%name statementParser STATEMENT
-%name expressionParser EXPRESSION
-%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 $4];
-          TId _ name = $2;
-          intr = ExpFunctionCall () (getTransSpan $1 $5)
-                   (ExpValue () (getTransSpan $1 $2) (ValIntrinsic ('%':name)))
-                   (Just args) }
-    in Argument () (getTransSpan $1 $5) Nothing intr }
-| id '=' EXPRESSION
-  { let TId span keyword = $1
-    in Argument () (getTransSpan span $3) (Just keyword) $3 }
-| EXPRESSION  { Argument () (getSpan $1) Nothing $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 { makeReal (Just $1) Nothing Nothing (Just $2) }
-| int '.' MAYBE_EXPONENT { makeReal (Just $1) (Just $2) Nothing $3 }
-| '.' int MAYBE_EXPONENT { makeReal Nothing (Just $1) (Just $2) $3 }
-| int '.' int MAYBE_EXPONENT { makeReal (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 }
-
-{
-
-parse = runParse programParser
-
-defTransforms77  = defaultTransformations Fortran77
-defTransforms77e = defaultTransformations Fortran77Extended
-defTransforms77l = defaultTransformations Fortran77Legacy
-
-fortran77Parser
-    :: B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)
-fortran77Parser = fortran77ParserWithTransforms defTransforms77
-
-fortran77ParserWithTransforms
-    :: [Transformation]
-    -> B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)
-fortran77ParserWithTransforms =
-    flip fortran77ParserWithModFilesWithTransforms emptyModFiles
-
-fortran77ParserWithModFiles
-    :: ModFiles
-    -> B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)
-fortran77ParserWithModFiles =
-    fortran77ParserWithModFilesWithTransforms defTransforms77
-
-fortran77ParserWithModFilesWithTransforms
-    :: [Transformation] -> ModFiles
-    -> B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)
-fortran77ParserWithModFilesWithTransforms transforms mods sourceCode filename =
-    fmap (pfSetFilename filename . transform) $ parse parseState
-  where
-    transform  = transformWithModFiles mods transforms
-    parseState = initParseState sourceCode Fortran77Extended filename
-
-extended77Parser
-    :: B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)
-extended77Parser = extended77ParserWithTransforms defTransforms77e
-
-extended77ParserWithTransforms
-    :: [Transformation]
-    -> B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)
-extended77ParserWithTransforms =
-    flip extended77ParserWithModFilesWithTransforms emptyModFiles
-
-extended77ParserWithModFiles
-    :: ModFiles
-    -> B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)
-extended77ParserWithModFiles =
-    extended77ParserWithModFilesWithTransforms defTransforms77e
-
-extended77ParserWithModFilesWithTransforms
-    :: [Transformation] -> ModFiles
-    -> B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)
-extended77ParserWithModFilesWithTransforms transforms mods sourceCode filename =
-    fmap (pfSetFilename filename . transform) $ parse parseState
-  where
-    transform = transformWithModFiles mods transforms
-    parseState = initParseState sourceCode Fortran77Extended filename
-
-legacy77Parser
-    :: B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)
-legacy77Parser = legacy77ParserWithTransforms defTransforms77l
-
-legacy77ParserWithTransforms
-    :: [Transformation]
-    -> B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)
-legacy77ParserWithTransforms = flip legacy77ParserWithModFilesWithTransforms emptyModFiles
-
-legacy77ParserWithModFiles
-    :: ModFiles
-    -> B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)
-legacy77ParserWithModFiles =
-    legacy77ParserWithModFilesWithTransforms defTransforms77l
-
-legacy77ParserWithModFilesWithTransforms
-    :: [Transformation] -> ModFiles
-    -> B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)
-legacy77ParserWithModFilesWithTransforms transforms mods sourceCode filename =
-    fmap (pfSetFilename filename . transform) $ parse parseState
-  where
-    transform = transformWithModFiles mods transforms
-    parseState = initParseState sourceCode Fortran77Legacy filename
-
-legacy77ParserWithIncludes
-    :: [String]
-    -> B.ByteString -> String -> IO (ParseResult AlexInput Token (ProgramFile A0))
-legacy77ParserWithIncludes =
-    legacy77ParserWithIncludesWithTransforms defTransforms77l
-
-legacy77ParserWithIncludesWithTransforms
-    :: [Transformation] -> [String]
-    -> B.ByteString -> String -> IO (ParseResult AlexInput Token (ProgramFile A0))
-legacy77ParserWithIncludesWithTransforms transforms incs sourceCode filename =
-    fmap (pfSetFilename filename . transform) <$> doParse
-  where
-    doParse = case parse parseState of
-      ParseFailed e -> return (ParseFailed e)
-      ParseOk p x -> do
-        p' <- evalStateT (descendBiM (inlineInclude Fortran77Legacy incs []) p) M.empty
-        return (ParseOk p' x)
-    transform = transformWithModFiles emptyModFiles transforms
-    parseState = initParseState sourceCode Fortran77Legacy filename
-
-includeParser ::
-    FortranVersion -> B.ByteString -> String -> ParseResult AlexInput Token [Block A0]
-includeParser version sourceCode filename =
-    runParse includesParser parseState
-  where
-    -- ensure the file ends with a newline..
-    parseState = initParseState (sourceCode `B.snoc` '\n') version filename
-
-inlineInclude :: FortranVersion -> [String] -> [String] -> Statement A0 ->
-  StateT (M.Map String [Block A0]) IO (Statement A0)
-inlineInclude fv dirs seen st = case st of
-  StInclude a s e@(ExpValue _ _ (ValString path)) Nothing -> do
-    if notElem path seen then do
-      incMap <- get
-      case M.lookup path incMap of
-        Just blocks' -> pure $ StInclude a s e (Just blocks')
-        Nothing -> do
-          (fullPath, inc) <- liftIO $ readInDirs dirs path
-          case includeParser fv inc fullPath of
-            ParseOk blocks _ -> do
-              blocks' <- descendBiM (inlineInclude fv dirs (path:seen)) blocks
-              modify (M.insert path blocks')
-              return $ StInclude a s e (Just blocks')
-            ParseFailed e -> liftIO $ throwIO e
-    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
-
-parseError :: Token -> LexAction a
-parseError _ = do
-    parseState <- get
-#ifdef DEBUG
-    tokens <- reverse <$> aiPreviousTokensInLine <$> getAlex
-#endif
-    fail $ psFilename parseState ++ ": parsing failed. "
-#ifdef DEBUG
-      ++ '\n' : show tokens
-#endif
-
-
-}
diff --git a/src/Language/Fortran/Parser/Fortran90.y b/src/Language/Fortran/Parser/Fortran90.y
deleted file mode 100644
--- a/src/Language/Fortran/Parser/Fortran90.y
+++ /dev/null
@@ -1,1214 +0,0 @@
--- -*- Mode: Haskell -*-
-{
-module Language.Fortran.Parser.Fortran90 ( statementParser
-                                         , functionParser
-                                         , blockParser
-                                         , fortran90Parser
-                                         , fortran90ParserWithTransforms
-                                         , fortran90ParserWithModFiles
-                                         , fortran90ParserWithModFilesWithTransforms
-                                         ) where
-
-import Prelude hiding (EQ,LT,GT) -- Same constructors exist in the AST
-import Control.Monad.State (get)
-import Data.Maybe (fromMaybe)
-import Data.Either (partitionEithers)
-import qualified Data.ByteString.Char8 as B
-
-import Control.Monad.State
-#ifdef DEBUG
-import Data.Data (toConstr)
-#endif
-
-import Language.Fortran.Util.Position
-import Language.Fortran.Util.ModFile
-import Language.Fortran.ParserMonad
-import Language.Fortran.Lexer.FreeForm
-import Language.Fortran.AST
-import Language.Fortran.Transformer
-
-import Debug.Trace
-
-}
-
-%name programParser PROGRAM
-%name functionParser SUBPROGRAM_UNIT
-%name statementParser STATEMENT
-%name blockParser BLOCK
-%monad { LexAction }
-%lexer { lexer } { TEOF _ }
-%tokentype { Token }
-%error { parseError }
-
-%token
-  id                          { TId _ _ }
-  comment                     { TComment _ _ }
-  string                      { TString _ _ }
-  int                         { TIntegerLiteral _ _ }
-  float                       { TRealLiteral _ _ }
-  boz                         { TBozLiteral _ _ }
-  '_'                         { TUnderscore _ }
-  ','                         { TComma _ }
-  ',2'                        { TComma2 _ }
-  ';'                         { TSemiColon _ }
-  ':'                         { TColon _ }
-  '::'                        { TDoubleColon _ }
-  '='                         { TOpAssign _ }
-  '=>'                        { TArrow _ }
-  '%'                         { TPercent _ }
-  '('                         { TLeftPar _ }
-  '(2'                        { TLeftPar2 _ }
-  ')'                         { TRightPar _ }
-  '(/'                        { TLeftInitPar _ }
-  '/)'                        { TRightInitPar _ }
-  opCustom                    { TOpCustom _ _ }
-  '**'                        { TOpExp _ }
-  '+'                         { TOpPlus _ }
-  '-'                         { TOpMinus _ }
-  '*'                         { TStar _ }
-  '/'                         { TOpDivision _ }
-  slash                       { TSlash _ }
-  or                          { TOpOr _ }
-  and                         { TOpAnd _ }
-  not                         { TOpNot _ }
-  eqv                         { TOpEquivalent _ }
-  neqv                        { TOpNotEquivalent _ }
-  '<'                         { TOpLT _ }
-  '<='                        { TOpLE _ }
-  '=='                        { TOpEQ _ }
-  '!='                        { TOpNE _ }
-  '>'                         { TOpGT _ }
-  '>='                        { TOpGE _ }
-  bool                        { TLogicalLiteral _ _ }
-  program                     { TProgram _ }
-  endProgram                  { TEndProgram _ }
-  function                    { TFunction _ }
-  endFunction                 { TEndFunction _ }
-  result                      { TResult _ }
-  recursive                   { TRecursive _ }
-  subroutine                  { TSubroutine _ }
-  endSubroutine               { TEndSubroutine _ }
-  blockData                   { TBlockData _ }
-  endBlockData                { TEndBlockData _ }
-  module                      { TModule _ }
-  endModule                   { TEndModule _ }
-  contains                    { TContains _ }
-  use                         { TUse _ }
-  only                        { TOnly _ }
-  interface                   { TInterface _ }
-  endInterface                { TEndInterface _ }
-  moduleProcedure             { TModuleProcedure _ }
-  assignment                  { TAssignment _ }
-  operator                    { TOperator _ }
-  call                        { TCall _ }
-  return                      { TReturn _ }
-  entry                       { TEntry _ }
-  include                     { TInclude _ }
-  public                      { TPublic _ }
-  private                     { TPrivate _ }
-  parameter                   { TParameter _ }
-  allocatable                 { TAllocatable _ }
-  dimension                   { TDimension _ }
-  external                    { TExternal _ }
-  intent                      { TIntent _ }
-  intrinsic                   { TIntrinsic _ }
-  optional                    { TOptional _ }
-  pointer                     { TPointer _ }
-  save                        { TSave _ }
-  target                      { TTarget _ }
-  in                          { TIn _ }
-  out                         { TOut _ }
-  inout                       { TInOut _ }
-  data                        { TData _ }
-  namelist                    { TNamelist _ }
-  implicit                    { TImplicit _ }
-  equivalence                 { TEquivalence _ }
-  common                      { TCommon _ }
-  allocate                    { TAllocate _ }
-  stat                        { TStat _ }
-  deallocate                  { TDeallocate _ }
-  nullify                     { TNullify _ }
-  none                        { TNone _ }
-  goto                        { TGoto _ }
-  assign                      { TAssign _ }
-  to                          { TTo _ }
-  continue                    { TContinue _ }
-  stop                        { TStop _ }
-  pause                       { TPause _ }
-  do                          { TDo _ }
-  enddo                       { TEndDo _ }
-  while                       { TWhile _ }
-  if                          { TIf _ }
-  then                        { TThen _ }
-  else                        { TElse _ }
-  elsif                       { TElsif _ }
-  endif                       { TEndIf _ }
-  case                        { TCase _ }
-  selectcase                  { TSelectCase _ }
-  endselect                   { TEndSelect _ }
-  default                     { TDefault _ }
-  cycle                       { TCycle _ }
-  exit                        { TExit _ }
-  where                       { TWhere _ }
-  elsewhere                   { TElsewhere _ }
-  endwhere                    { TEndWhere _ }
-  type                        { TType _ }
-  endType                     { TEndType _ }
-  sequence                    { TSequence _ }
-  kind                        { TKind _ }
-  len                         { TLen _ }
-  integer                     { TInteger _ }
-  real                        { TReal _ }
-  doublePrecision             { TDoublePrecision _ }
-  logical                     { TLogical _ }
-  character                   { TCharacter _ }
-  complex                     { TComplex _ }
-  open                        { TOpen _ }
-  close                       { TClose _ }
-  read                        { TRead _ }
-  write                       { TWrite _ }
-  print                       { TPrint _ }
-  backspace                   { TBackspace _ }
-  rewind                      { TRewind _ }
-  inquire                     { TInquire _ }
-  endfile                     { TEndfile _ }
-  format                      { TFormat _ }
-  blob                        { TBlob _ _ }
-  end                         { TEnd _ }
-  newline                     { TNewline _ }
-
--- Precedence of operators
-
--- Level 6
-%left opCustom
-
--- Level 5
-%left eqv neqv
-%left or
-%left and
-%right not
-
--- Level 4
-%nonassoc '==' '!=' '>' '<' '>=' '<='
-%nonassoc RELATIONAL
-
--- Level 3
-%left CONCAT
-
--- Level 2
-%left '+' '-'
-%left '*' '/'
-%right SIGN
-%right '**'
-
--- Level 1
-%right DEFINED_UNARY
-
--- Level 0
-%left '%'
-
-%%
-
-maybe(p)
-: p           { Just $1 }
-| {- empty -} { Nothing }
-
--- 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 = Fortran90, miFilename = "" }) (reverse $1) }
-| {- empty -}   { ProgramFile (MetaInfo { miVersion = Fortran90, miFilename = "" }) [] }
-
-PROGRAM_UNITS :: { [ ProgramUnit A0 ] }
-: PROGRAM_UNITS PROGRAM_UNIT MAYBE_NEWLINE { $2 : $1 }
-| PROGRAM_UNIT MAYBE_NEWLINE { [ $1 ] }
-
-PROGRAM_UNIT :: { ProgramUnit A0 }
-: program NAME NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS PROGRAM_END
-  {% do { unitNameCheck $6 $2;
-          return $ PUMain () (getTransSpan $1 $6) (Just $2) (reverse $4) $5 } }
-| module NAME NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS MODULE_END
-  {% do { unitNameCheck $6 $2;
-          return $ PUModule () (getTransSpan $1 $6) $2 (reverse $4) $5 } }
-| blockData NEWLINE BLOCKS BLOCK_DATA_END
-  { PUBlockData () (getTransSpan $1 $4) Nothing (reverse $3) }
-| blockData NAME NEWLINE BLOCKS BLOCK_DATA_END
-  {% do { unitNameCheck $5 $2;
-          return $ PUBlockData () (getTransSpan $1 $5) (Just $2) (reverse $4) } }
-| SUBPROGRAM_UNIT { $1 }
-
-MAYBE_SUBPROGRAM_UNITS :: { Maybe [ ProgramUnit A0 ] }
-: contains NEWLINE SUBPROGRAM_UNITS { Just $ reverse $3 }
-| {- Empty -} { Nothing }
-
-SUBPROGRAM_UNITS :: { [ ProgramUnit A0 ] }
-: SUBPROGRAM_UNITS SUBPROGRAM_UNIT NEWLINE { $2 : $1 }
-| {- EMPTY -} { [ ] }
-
-SUBPROGRAM_UNIT :: { ProgramUnit A0 }
-: PREFIXES function NAME MAYBE_ARGUMENTS MAYBE_RESULT MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END
-  {% do { unitNameCheck $10 $3;
-          let (pfxs, typeSpec) = case partitionEithers $1 of
-                                   { (ps, t:_) -> (fromReverseList' ps, Just t)
-                                   ; (ps, [])  -> (fromReverseList' ps, Nothing) } in
-          let sfx = emptySuffixes in
-          let ss = if null $1 then getTransSpan $2 $10 else getTransSpan (reverse $1) $10 in
-          return $ PUFunction () ss typeSpec (pfxs, sfx) $3 $4 $5 (reverse $8) $9 } }
-| PREFIXES subroutine NAME MAYBE_ARGUMENTS MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS SUBROUTINE_END
-  {% do { unitNameCheck $9 $3;
-          (pfxs, typeSpec) <- case partitionEithers $1 of
-                                { (ps, t:_) -> fail "Subroutines cannot have return types."
-                                ; (ps, [])  -> return (fromReverseList' ps, Nothing) };
-          let sfx = emptySuffixes in
-          let ss = if null $1 then getTransSpan $2 $9 else getTransSpan (reverse $1) $9 in
-          return $ PUSubroutine () ss (pfxs, sfx) $3 $4 (reverse $7) $8 } }
-| comment { let (TComment s c) = $1 in PUComment () s (Comment c) }
-
--- (Fortran2003) R1227, Fortran95/90 (...)
-PREFIXES :: { [Either (Prefix A0) (TypeSpec A0)] }
-: PREFIXES PREFIX { $2:$1 }
-| {- EMPTY -}     { [] }
-
--- (Fortran2003) R1228, Fortran95/90 (...)
-PREFIX :: { Either (Prefix A0) (TypeSpec A0) }
-: recursive { Left $ PfxRecursive () (getSpan $1) }
-| TYPE_SPEC { Right $1 }
-
-RESULT :: { Expression A0 }
-: result '(' VARIABLE ')' { $3 }
-
-MAYBE_RESULT :: { Maybe (Expression A0) }
-: RESULT      { Just $1 }
-| {- empty -} { Nothing }
-
-MAYBE_ARGUMENTS :: { Maybe (AList Expression A0) }
-: '(' MAYBE_VARIABLES ')' { $2 }
-| {- Nothing -} { Nothing }
-
-PROGRAM_END :: { Token }
-: end { $1 } | endProgram { $1 } | endProgram id { $2 }
-MODULE_END :: { Token }
-: end { $1 } | endModule { $1 } | endModule id { $2 }
-FUNCTION_END :: { Token }
-: end { $1 } | endFunction { $1 } | endFunction id { $2 }
-SUBROUTINE_END :: { Token }
-: end { $1 } | endSubroutine { $1 } | endSubroutine id { $2 }
-BLOCK_DATA_END :: { Token }
-: end { $1 } | endBlockData { $1 } | endBlockData id { $2 }
-INTERFACE_END :: { Token }
-: end { $1 } | endInterface { $1 } | endInterface id { $2 }
-
-NAME :: { Name } : id { let (TId _ name) = $1 in name }
-
-BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] }
-
-BLOCK :: { Block A0 }
-: IF_BLOCK MAYBE_COMMENT NEWLINE { $1 }
-| CASE_BLOCK MAYBE_COMMENT NEWLINE { $1 }
-| INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE
-  { BlStatement () (getTransSpan $1 $2) (Just $1) $2 }
-| STATEMENT MAYBE_COMMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 }
-| interface MAYBE_EXPRESSION MAYBE_COMMENT NEWLINE SUBPROGRAM_UNITS2 MODULE_PROCEDURES INTERFACE_END MAYBE_COMMENT NEWLINE
-  { BlInterface () (getTransSpan $1 $9) $2 False (reverse $5) (reverse $6) }
-| interface MAYBE_EXPRESSION MAYBE_COMMENT NEWLINE MODULE_PROCEDURES INTERFACE_END MAYBE_COMMENT NEWLINE
-  { BlInterface () (getTransSpan $1 $8) $2 False [ ] (reverse $5) }
-| COMMENT_BLOCK { $1 }
-
-IF_BLOCK :: { Block A0 }
-:                        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
-  { let { startSpan = getSpan $1;
-          (endSpan, conds, blocks, endLabel) = $9;
-          span = getTransSpan startSpan endSpan }
-     in BlIf () span Nothing Nothing ((Just $3):conds) ((reverse $8):blocks) endLabel }
-|                 id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
-  { let { TId startSpan startName = $1;
-          (endSpan, conds, blocks, endLabel) = $11;
-          span = getTransSpan startSpan endSpan }
-     in BlIf () span Nothing (Just startName) ((Just $5):conds) ((reverse $10):blocks) endLabel }
-| INTEGER_LITERAL        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
-  { let { startSpan = getSpan $1;
-          startLabel = Just $1;
-          (endSpan, conds, blocks, endLabel) = $10;
-          span = getTransSpan startSpan endSpan }
-     in BlIf () span startLabel Nothing ((Just $4):conds) ((reverse $9):blocks) endLabel }
-| INTEGER_LITERAL id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
-  { let { startSpan = getSpan $1;
-          startLabel = Just $1;
-          TId _ startName = $2;
-          (endSpan, conds, blocks, endLabel) = $12;
-          span = getTransSpan startSpan endSpan }
-     in BlIf () span startLabel (Just startName) ((Just $6):conds) ((reverse $11):blocks) endLabel }
-
-ELSE_BLOCKS :: { (SrcSpan, [Maybe (Expression A0)], [[Block A0]], Maybe (Expression A0)) }
-: maybe(INTEGER_LITERAL) elsif '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
-  { let (endSpan, conds, blocks, endLabel) = $10
-    in (endSpan, Just $4 : conds, reverse $9 : blocks, endLabel) }
-| maybe(INTEGER_LITERAL) else                          MAYBE_COMMENT NEWLINE BLOCKS END_IF
-  { let (endSpan, endLabel) = $6
-    in (endSpan, [Nothing], [reverse $5], endLabel) }
-| END_IF { let (endSpan, endLabel) = $1 in (endSpan, [], [], endLabel) }
-
-END_IF :: { (SrcSpan, Maybe (Expression A0)) }
-: endif { (getSpan $1, Nothing) }
-| endif id { (getSpan $2, Nothing) }
-| INTEGER_LITERAL endif { (getSpan $2, Just $1) }
-| INTEGER_LITERAL endif id { (getSpan $3, Just $1) }
-
-CASE_BLOCK :: { Block A0 }
-:                        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
-  { let { (caseRanges, blocks, endLabel, endSpan) = $7;
-          span = getTransSpan $1 endSpan }
-    in BlCase () span Nothing Nothing $3 caseRanges blocks endLabel }
-| INTEGER_LITERAL        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
-  { let { (caseRanges, blocks, endLabel, endSpan) = $8;
-          span = getTransSpan $1 endSpan }
-    in BlCase () span (Just $1) Nothing $4 caseRanges blocks endLabel }
-|                 id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
-  { let { (caseRanges, blocks, endLabel, endSpan) = $9;
-          TId s startName = $1;
-          span = getTransSpan s endSpan }
-    in BlCase () span Nothing (Just startName) $5 caseRanges blocks endLabel }
-| INTEGER_LITERAL id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
-  { let { (caseRanges, blocks, endLabel, endSpan) = $10;
-          TId s startName = $2;
-          span = getTransSpan s endSpan }
-    in BlCase () span (Just $1) (Just startName) $6 caseRanges blocks endLabel }
-
--- We store line comments as statements, but this raises an issue: we have
--- nowhere to place comments after a SELECT CASE but before a CASE. So we drop
--- them. The inner CASES_ rule does /not/ use this, because comments can always
--- be parsed as belonging to to the above CASE block.
-CASES :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }
-: COMMENT_BLOCK CASES_ { $2 }
-|               CASES_ { $1 }
-
-CASES_ :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }
-: maybe(INTEGER_LITERAL) case '(' INDICIES ')' MAYBE_COMMENT NEWLINE BLOCKS CASES_
-  { let (scrutinees, blocks, endLabel, endSpan) = $9
-    in  (Just (fromReverseList $4) : scrutinees, reverse $8 : blocks, endLabel, endSpan) }
-| maybe(INTEGER_LITERAL) case default          MAYBE_COMMENT NEWLINE BLOCKS END_SELECT
-  { let (endLabel, endSpan) = $7
-    in ([Nothing], [$6], endLabel, endSpan) }
-| END_SELECT
-  { let (endLabel, endSpan) = $1
-    in ([], [], endLabel, endSpan) }
-
-END_SELECT :: { (Maybe (Expression A0), SrcSpan) }
-: maybe(INTEGER_LITERAL) endselect maybe(id)
-  { ($1, maybe (getSpan $2) getSpan $3) }
-
-MAYBE_EXPRESSION :: { Maybe (Expression A0) }
-: EXPRESSION { Just $1 }
-| {- EMPTY -} { Nothing }
-
-MAYBE_COMMENT :: { Maybe Token }
-: comment { Just $1 }
-| {- EMPTY -} { Nothing }
-
-SUBPROGRAM_UNITS2 :: { [ ProgramUnit A0 ] }
-: SUBPROGRAM_UNITS SUBPROGRAM_UNIT NEWLINE { $2 : $1 }
-
-MODULE_PROCEDURES :: { [ Block A0 ] }
-: MODULE_PROCEDURES MODULE_PROCEDURE { $2 : $1 }
-| MODULE_PROCEDURES MODULE_PROCEDURE COMMENT_BLOCK { $3 : $2 : $1 }
-| { [ ] }
-
-MODULE_PROCEDURE :: { Block A0 }
-: moduleProcedure VARIABLES MAYBE_COMMENT NEWLINE
-  { let { al = fromReverseList $2;
-          st = StModuleProcedure () (getTransSpan $1 al) (fromReverseList $2) }
-    in BlStatement () (getTransSpan $1 $4) Nothing st }
-
-COMMENT_BLOCK :: { Block A0 }
-: 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 }
-| newline { $1 }
-| ';' { $1 }
-
-STATEMENT :: { Statement A0 }
-: NONEXECUTABLE_STATEMENT { $1 }
-| EXECUTABLE_STATEMENT { $1 }
-
-EXPRESSION_ASSIGNMENT_STATEMENT :: { Statement A0 }
-: DATA_REF '=' EXPRESSION { StExpressionAssign () (getTransSpan $1 $3) $1 $3 }
-
-NONEXECUTABLE_STATEMENT :: { Statement A0 }
-: DECLARATION_STATEMENT { $1 }
-| intent '(' INTENT_CHOICE ')' MAYBE_DCOLON EXPRESSION_LIST
-  { let expAList = fromReverseList $6
-    in StIntent () (getTransSpan $1 expAList) $3 expAList }
-| optional MAYBE_DCOLON EXPRESSION_LIST
-  { let expAList = fromReverseList $3
-    in StOptional () (getTransSpan $1 expAList) expAList }
-| public MAYBE_DCOLON EXPRESSION_LIST
-  { let expAList = fromReverseList $3
-    in StPublic () (getTransSpan $1 expAList) (Just expAList) }
-| public { StPublic () (getSpan $1) Nothing }
-| private MAYBE_DCOLON EXPRESSION_LIST
-  { let expAList = fromReverseList $3
-    in StPrivate () (getTransSpan $1 expAList) (Just expAList) }
-| private { StPrivate () (getSpan $1) Nothing }
-| save MAYBE_DCOLON SAVE_ARGS
-  { let saveAList = (fromReverseList $3)
-    in StSave () (getTransSpan $1 saveAList) (Just saveAList) }
-| save { StSave () (getSpan $1) Nothing }
-| dimension MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
-  { let declAList = fromReverseList $3
-    in StDimension () (getTransSpan $1 declAList) declAList }
-| allocatable MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
-  { let declAList = fromReverseList $3
-    in StAllocatable () (getTransSpan $1 declAList) declAList }
-| pointer MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
-  { let declAList = fromReverseList $3
-    in StPointer () (getTransSpan $1 declAList) declAList }
-| target MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
-  { let declAList = fromReverseList $3
-    in StTarget () (getTransSpan $1 declAList) declAList }
-| data cDATA DATA_GROUPS cPOP
-  { let dataAList = fromReverseList $3
-    in StData () (getTransSpan $1 dataAList) dataAList }
-| parameter '(' PARAMETER_ASSIGNMENTS ')'
-  { let declAList = fromReverseList $3
-    in StParameter () (getTransSpan $1 $4) declAList }
-| implicit none { StImplicit () (getTransSpan $1 $2) Nothing }
-| implicit cIMPLICIT IMP_LISTS cPOP
-  { let impAList = fromReverseList $3
-    in StImplicit () (getTransSpan $1 impAList) $ Just $ impAList }
-| namelist cNAMELIST NAMELISTS cPOP
-  { let nameALists = fromReverseList $3
-    in StNamelist () (getTransSpan $1 nameALists) nameALists }
-| equivalence EQUIVALENCE_GROUPS
-  { let eqALists = fromReverseList $2
-    in StEquivalence () (getTransSpan $1 eqALists) eqALists }
-| common cCOMMON COMMON_GROUPS cPOP
-  { let commonAList = fromReverseList $3
-    in StCommon () (getTransSpan $1 commonAList) commonAList }
-| external MAYBE_DCOLON VARIABLES
-  { let alist = fromReverseList $3
-    in StExternal () (getTransSpan $1 alist) alist }
-| intrinsic MAYBE_DCOLON VARIABLES
-  { let alist = fromReverseList $3
-    in StIntrinsic () (getTransSpan $1 alist) alist }
-| use VARIABLE { StUse () (getTransSpan $1 $2) $2 Nothing Permissive Nothing }
-| use VARIABLE ',' RENAME_LIST
-  { let alist = fromReverseList $4
-    in StUse () (getTransSpan $1 alist) $2 Nothing Permissive (Just alist) }
-| use VARIABLE ',' only ':' MAYBE_RENAME_LIST
-  { StUse () (getTransSpan $1 ($5, $6)) $2 Nothing Exclusive $6 }
-| entry VARIABLE MAYBE_RESULT
-  { StEntry () (getTransSpan $1 $ maybe (getSpan $2) getSpan $3) $2 Nothing $3 }
-| entry VARIABLE '(' ')' MAYBE_RESULT
-  { StEntry () (getTransSpan $1 $ maybe (getSpan $4) getSpan $5) $2 Nothing $5 }
-| entry VARIABLE '(' VARIABLES ')' MAYBE_RESULT
-  { StEntry () (getTransSpan $1 $ maybe (getSpan $5) getSpan $6) $2 (Just $ fromReverseList $4) $6 }
-| sequence { StSequence () (getSpan $1) }
-| type ATTRIBUTE_LIST '::' id
-  { let { TId span id = $4;
-          alist = if null $2 then Nothing else (Just . fromReverseList) $2 }
-    in StType () (getTransSpan $1 span) alist id }
-| type id
-  { let TId span id = $2 in StType () (getTransSpan $1 span) Nothing id }
-| endType { StEndType () (getSpan $1) Nothing }
-| endType id
-  { let TId span id = $2 in StEndType () (getTransSpan $1 span) (Just id) }
-| include STRING { StInclude () (getTransSpan $1 $2) $2 Nothing }
--- 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 }
-
-EXECUTABLE_STATEMENT :: { Statement A0 }
-: allocate '(' DATA_REFS MAYBE_ALLOC_OPT_LIST ')'
-  { StAllocate () (getTransSpan $1 $5) Nothing (fromReverseList $3) $4 }
-| nullify '(' DATA_REFS ')'
-  { StNullify () (getTransSpan $1 $4) (fromReverseList $3) }
-| deallocate '(' DATA_REFS MAYBE_ALLOC_OPT_LIST ')'
-  { StDeallocate () (getTransSpan $1 $5) (fromReverseList $3) $4 }
-| EXPRESSION_ASSIGNMENT_STATEMENT { $1 }
-| DATA_REF '=>' EXPRESSION { StPointerAssign () (getTransSpan $1 $3) $1 $3 }
-| where '(' EXPRESSION ')' EXPRESSION_ASSIGNMENT_STATEMENT
-  { StWhere () (getTransSpan $1 $5) $3 $5 }
-| where '(' EXPRESSION ')' { StWhereConstruct () (getTransSpan $1 $4) Nothing $3 }
-| elsewhere '(' EXPRESSION ')' { StElsewhere () (getTransSpan $1 $4) Nothing (Just $3) }
-| elsewhere { StElsewhere () (getSpan $1) Nothing Nothing }
-| endwhere { StEndWhere () (getSpan $1) Nothing }
-| if '(' EXPRESSION ')' INTEGER_LITERAL ',' INTEGER_LITERAL ',' INTEGER_LITERAL
-  { StIfArithmetic () (getTransSpan $1 $9) $3 $5 $7 $9 }
-| do { StDo () (getSpan $1) Nothing Nothing Nothing }
-| id ':' do
-  { let TId s id = $1
-    in StDo () (getTransSpan s $3) (Just id) Nothing Nothing }
-| do INTEGER_LITERAL MAYBE_COMMA DO_SPECIFICATION
-  { StDo () (getTransSpan $1 $4) Nothing (Just $2) (Just $4) }
-| do DO_SPECIFICATION { StDo () (getTransSpan $1 $2) Nothing Nothing (Just $2) }
-| id ':' do DO_SPECIFICATION
-  { let TId s id = $1
-    in StDo () (getTransSpan s $4) (Just id) Nothing (Just $4) }
-| do INTEGER_LITERAL MAYBE_COMMA while '(' EXPRESSION ')'
-  { StDoWhile () (getTransSpan $1 $7) Nothing (Just $2) $6 }
-| do while '(' EXPRESSION ')'
-  { StDoWhile () (getTransSpan $1 $5) Nothing Nothing $4 }
-| id ':' do while '(' EXPRESSION ')'
-  { let TId s id = $1
-    in StDoWhile () (getTransSpan s $7) (Just id) Nothing $6 }
-| enddo { StEnddo () (getSpan $1) Nothing }
-| enddo id
-  { let TId s id = $2 in StEnddo () (getTransSpan $1 s) (Just id) }
-| cycle { StCycle () (getSpan $1) Nothing }
-| cycle VARIABLE { StCycle () (getTransSpan $1 $2) (Just $2) }
-| exit { StExit () (getSpan $1) Nothing }
-| exit VARIABLE { StExit () (getTransSpan $1 $2) (Just $2) }
--- GO TO label
-| goto INTEGER_LITERAL { StGotoUnconditional () (getTransSpan $1 $2) $2 }
--- GO TO scalar-int-variable
-| goto VARIABLE { StGotoUnconditional () (getTransSpan $1 $2) $2 }
--- GO TO scalar-int-variable [,] label-list
-| goto VARIABLE MAYBE_COMMA '(' INTEGERS ')'
-  { StGotoAssigned () (getTransSpan $1 $6) $2 (Just (fromReverseList $5)) }
--- GO TO label-list [,] scalar-int-expression
-| goto '(' INTEGERS ')' MAYBE_COMMA EXPRESSION
-  { StGotoComputed () (getTransSpan $1 $6) (fromReverseList $3) $6 }
-| assign INTEGER_LITERAL to VARIABLE
-  { StLabelAssign () (getTransSpan $1 $4) $2 $4 }
-| continue { StContinue () (getSpan $1) }
-| stop { StStop () (getSpan $1) Nothing }
-| stop EXPRESSION { StStop () (getTransSpan $1 $2) (Just $2) }
-| pause { StPause () (getSpan $1) Nothing }
-| pause EXPRESSION { StPause () (getTransSpan $1 $2) (Just $2) }
-| if '(' EXPRESSION ')' EXECUTABLE_STATEMENT
-  { StIfLogical () (getTransSpan $1 $5) $3 $5 }
-| read CILIST IN_IOLIST
-  { let alist = fromReverseList $3
-    in StRead () (getTransSpan $1 alist) $2 (Just alist) }
-| read CILIST { StRead () (getTransSpan $1 $2) $2 Nothing }
-| read FORMAT_ID ',' IN_IOLIST
-  { let alist = fromReverseList $4
-    in StRead2 () (getTransSpan $1 alist) $2 (Just alist) }
-| read FORMAT_ID { StRead2 () (getTransSpan $1 $2) $2 Nothing }
-| write CILIST OUT_IOLIST
-  { let alist = fromReverseList $3
-    in StWrite () (getTransSpan $1 alist) $2 (Just alist) }
-| write CILIST { StWrite () (getTransSpan $1 $2) $2 Nothing }
-| print FORMAT_ID ',' OUT_IOLIST
-  { let alist = fromReverseList $4
-    in StPrint () (getTransSpan $1 alist) $2 (Just alist) }
-| print FORMAT_ID { StPrint () (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 }
-| call VARIABLE { StCall () (getTransSpan $1 $2) $2 Nothing }
-| call VARIABLE '(' ')' { StCall () (getTransSpan $1 $4) $2 Nothing }
-| call VARIABLE '(' ARGUMENTS ')'
-  { let alist = fromReverseList $4
-    in StCall () (getTransSpan $1 $5) $2 (Just alist) }
-| return { StReturn () (getSpan $1) Nothing }
-| return EXPRESSION { StReturn () (getTransSpan $1 $2) (Just $2) }
-
-ARGUMENTS :: { [ Argument A0 ] }
-: ARGUMENTS ',' ARGUMENT { $3 : $1 }
-| ARGUMENT { [ $1 ] }
-
-ARGUMENT :: { Argument A0 }
-: id '=' EXPRESSION
-  { let TId span keyword = $1
-    in Argument () (getTransSpan span $3) (Just keyword) $3 }
-| EXPRESSION
-  { Argument () (getSpan $1) Nothing $1 }
-
-MAYBE_RENAME_LIST :: { Maybe (AList Use A0) }
-: RENAME_LIST { Just $ fromReverseList $1 }
-| {- empty -} { Nothing }
-
-RENAME_LIST :: { [ Use A0 ] }
-: RENAME_LIST ',' RENAME { $3 : $1 }
-| RENAME { [ $1 ] }
-
-RENAME :: { Use A0  }
-: VARIABLE '=>' VARIABLE { UseRename () (getTransSpan $1 $3) $1 $3 }
-| VARIABLE { UseID () (getSpan $1) $1 }
-| operator '(' opCustom ')'
-  { let TOpCustom ss op = $3
-    in UseID () (getTransSpan $1 $4) (ExpValue () ss (ValOperator op)) }
-| assignment { UseID () (getSpan $1) (ExpValue () (getSpan $1) ValAssignment) }
-
-MAYBE_DCOLON :: { () } : '::' { () } | {- EMPTY -} { () }
-
-FORMAT_ID :: { Expression A0 }
-: FORMAT_ID '/' '/' FORMAT_ID %prec CONCAT
-  { ExpBinary () (getTransSpan $1 $4) Concatenation $1 $4 }
-| INTEGER_LITERAL { $1 }
-| STRING { $1 }
-| DATA_REF { $1 }
-| '*' { ExpValue () (getSpan $1) ValStar }
-
-UNIT :: { Expression A0 }
-: INTEGER_LITERAL { $1 }
-| DATA_REF { $1 }
-| '*' { ExpValue () (getSpan $1) ValStar }
-
-CILIST :: { AList ControlPair A0 }
-: '(' CILIST_ELEMENT ',' FORMAT_ID ',' CILIST_PAIRS ')'
-  { let { cp1 = ControlPair () (getSpan $2) Nothing $2;
-          cp2 = ControlPair () (getSpan $4) Nothing $4;
-          tail = fromReverseList $6 }
-    in setSpan (getTransSpan $1 $7) $ cp1 `aCons` cp2 `aCons` tail }
-| '(' CILIST_ELEMENT ',' FORMAT_ID ')'
-  { let { cp1 = ControlPair () (getSpan $2) Nothing $2;
-          cp2 = ControlPair () (getSpan $4) Nothing $4 }
-    in AList () (getTransSpan $1 $5) [ cp1,  cp2 ] }
-| '(' CILIST_ELEMENT ',' CILIST_PAIRS ')'
-  { let { cp1 = ControlPair () (getSpan $2) Nothing $2;
-          tail = fromReverseList $4 }
-    in setSpan (getTransSpan $1 $5) $ cp1 `aCons` tail }
-| '(' CILIST_ELEMENT ')'
-  { let cp1 = ControlPair () (getSpan $2) Nothing $2
-    in AList () (getTransSpan $1 $3) [ cp1 ] }
-| '(' CILIST_PAIRS ')' { fromReverseList $2 }
-
-CILIST_PAIRS :: { [ ControlPair A0 ] }
-: CILIST_PAIRS ',' CILIST_PAIR { $3 : $1 }
-| CILIST_PAIR { [ $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 SIGN
-  { 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 }
-| 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 }
-| opCustom CI_EXPRESSION %prec DEFINED_UNARY
-  { let TOpCustom span str = $1
-    in ExpUnary () (getTransSpan span $2) (UnCustom str) $2 }
-| CI_EXPRESSION opCustom CI_EXPRESSION
-  { let TOpCustom _ str = $2
-    in ExpBinary () (getTransSpan $1 $3) (BinCustom str) $1 $3 }
-| '(' CI_EXPRESSION ')' { setSpan (getTransSpan $1 $3) $2 }
-| INTEGER_LITERAL { $1 }
-| LOGICAL_LITERAL { $1 }
-| STRING { $1 }
-| DATA_REF { $1 }
-
-MAYBE_ALLOC_OPT_LIST :: { Maybe (AList AllocOpt A0) }
-: ',' stat '=' EXPRESSION { Just (fromReverseList [AOStat () (getTransSpan $2 $4) $4]) }
-| {- empty -}             { Nothing }
-
-IN_IOLIST :: { [ Expression A0 ] }
-: IN_IOLIST ',' IN_IO_ELEMENT { $3 : $1}
-| IN_IO_ELEMENT { [ $1 ] }
-
-IN_IO_ELEMENT :: { Expression A0 }
-: DATA_REF { $1 }
-| '(' IN_IOLIST ',' DO_SPECIFICATION ')'
-  { ExpImpliedDo () (getTransSpan $1 $5) (fromReverseList $2) $4 }
-
-OUT_IOLIST :: { [ Expression A0 ] }
-: OUT_IOLIST ',' EXPRESSION { $3 : $1}
-| EXPRESSION { [ $1 ] }
-
-COMMON_GROUPS :: { [ CommonGroup A0 ] }
-: COMMON_GROUPS COMMON_GROUP { $2 : $1 }
-| COMMON_GROUPS ',2' COMMON_GROUP { $3 : $1 }
-| INIT_COMMON_GROUP { [ $1 ] }
-
-COMMON_GROUP :: { CommonGroup A0 }
-: COMMON_NAME UNINITIALIZED_DECLARATOR_LIST
-  { let alist = fromReverseList $2
-    in CommonGroup () (getTransSpan $1 alist) (Just $1) alist }
-| '/' '/' UNINITIALIZED_DECLARATOR_LIST
-  { let alist = fromReverseList $3
-    in CommonGroup () (getTransSpan $1 alist) Nothing alist }
-
-INIT_COMMON_GROUP :: { CommonGroup A0 }
-: COMMON_NAME UNINITIALIZED_DECLARATOR_LIST
-  { let alist = fromReverseList $2
-    in CommonGroup () (getTransSpan $1 alist) (Just $1) alist }
-| '/' '/' UNINITIALIZED_DECLARATOR_LIST
-  { let alist = fromReverseList $3
-    in CommonGroup () (getTransSpan $1 alist) Nothing alist }
-| UNINITIALIZED_DECLARATOR_LIST
-  { let alist = fromReverseList $1
-    in CommonGroup () (getSpan alist) Nothing alist }
-
-EQUIVALENCE_GROUPS :: { [ AList Expression A0 ] }
-: EQUIVALENCE_GROUPS ',' '(' PART_REFS ')'
-  { setSpan (getTransSpan $3 $5) (fromReverseList $4) : $1 }
-| '(' PART_REFS ')'
-  { [ setSpan (getTransSpan $1 $3) (fromReverseList $2) ] }
-
-NAMELISTS :: { [ Namelist A0 ] }
-: NAMELISTS NAMELIST { $2 : $1 }
-| NAMELISTS ',2' NAMELIST { $3 : $1 }
-| NAMELIST { [ $1 ] }
-
-NAMELIST :: { Namelist A0 }
-: '/' VARIABLE '/' VARIABLES
-  { Namelist () (getTransSpan $1 $4) $2 $ fromReverseList $4 }
-
-MAYBE_VARIABLES :: { Maybe (AList Expression A0) }
-: VARIABLES { Just $ fromReverseList $1 } | {- EMPTY -} { Nothing }
-
-VARIABLES :: { [ Expression A0 ] }
-: VARIABLES ',' VARIABLE { $3 : $1 }
-| VARIABLE { [ $1 ] }
-
-IMP_LISTS :: { [ ImpList A0 ] }
-: IMP_LISTS ',' IMP_LIST { $3 : $1 }
-| IMP_LIST { [ $1 ] }
-
-IMP_LIST :: { ImpList A0 }
-: TYPE_SPEC '(2' 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
-             }
-
-PARAMETER_ASSIGNMENTS :: { [ Declarator A0 ] }
-: PARAMETER_ASSIGNMENTS ',' PARAMETER_ASSIGNMENT { $3 : $1 }
-| PARAMETER_ASSIGNMENT { [ $1 ] }
-
-PARAMETER_ASSIGNMENT :: { Declarator A0 }
-: VARIABLE '=' EXPRESSION
-  { Declarator () (getTransSpan $1 $3) $1 ScalarDecl Nothing (Just $3) }
-
-DECLARATION_STATEMENT :: { Statement A0 }
-: TYPE_SPEC ATTRIBUTE_LIST '::' INITIALIZED_DECLARATOR_LIST
-  { let { mAttrAList = if null $2 then Nothing else Just $ fromReverseList $2;
-          declAList = fromReverseList $4 }
-    in StDeclaration () (getTransSpan $1 declAList) $1 mAttrAList declAList }
-| TYPE_SPEC INITIALIZED_DECLARATOR_LIST
-  { let { declAList = fromReverseList $2 }
-    in StDeclaration () (getTransSpan $1 declAList) $1 Nothing declAList }
-
-ATTRIBUTE_LIST :: { [ Attribute A0 ] }
-: ATTRIBUTE_LIST ',' ATTRIBUTE_SPEC { $3 : $1 }
-| {- EMPTY -} { [ ] }
-
-ATTRIBUTE_SPEC :: { Attribute A0 }
-: public { AttrPublic () (getSpan $1) }
-| private { AttrPrivate () (getSpan $1) }
-| allocatable { AttrAllocatable () (getSpan $1) }
-| dimension '(' DIMENSION_DECLARATORS ')'
-  { AttrDimension () (getTransSpan $1 $4) (aReverse $3) }
-| external { AttrExternal () (getSpan $1) }
-| intent '(' INTENT_CHOICE ')' { AttrIntent () (getTransSpan $1 $4) $3 }
-| intrinsic { AttrIntrinsic () (getSpan $1) }
-| optional { AttrOptional () (getSpan $1) }
-| pointer { AttrPointer () (getSpan $1) }
-| parameter { AttrParameter () (getSpan $1) }
-| save { AttrSave () (getSpan $1) }
-| target { AttrTarget () (getSpan $1) }
-
-INTENT_CHOICE :: { Intent } : in { In } | out { Out } | inout { InOut }
-
-DATA_GROUPS :: { [ DataGroup A0 ] }
-: DATA_GROUPS MAYBE_COMMA DATA_LIST slash EXPRESSION_LIST slash
-  { let { nameAList = fromReverseList $3;
-          dataAList = fromReverseList $5 }
-    in DataGroup () (getTransSpan nameAList $6) nameAList dataAList : $1 }
-| DATA_LIST slash EXPRESSION_LIST slash
-  { let { nameAList = fromReverseList $1;
-          dataAList = fromReverseList $3 }
-    in [ DataGroup () (getTransSpan nameAList $4) nameAList dataAList ] }
-
-MAYBE_COMMA :: { () } : ',' { () } | {- EMPTY -} { () }
-
-DATA_LIST :: { [ Expression A0 ] }
-: DATA_LIST ',' DATA_ELEMENT { $3 : $1 }
-| DATA_ELEMENT { [ $1 ] }
-
-DATA_ELEMENT :: { Expression A0 }
-: DATA_REF { $1 } | IMPLIED_DO { $1 }
-
-SAVE_ARGS :: { [ Expression A0 ] }
-: SAVE_ARGS ',' SAVE_ARG { $3 : $1 } | SAVE_ARG { [ $1 ] }
-
-SAVE_ARG :: { Expression A0 } : COMMON_NAME { $1 } | VARIABLE { $1 }
-
-COMMON_NAME :: { Expression A0 }
-: '/' VARIABLE '/' { setSpan (getTransSpan $1 $3) $2 }
-
-INITIALIZED_DECLARATOR_LIST :: { [ Declarator A0 ] }
-: INITIALIZED_DECLARATOR_LIST ',' INITIALIZED_DECLARATOR { $3 : $1 }
-| INITIALIZED_DECLARATOR { [ $1 ] }
-
-UNINITIALIZED_DECLARATOR_LIST :: { [ Declarator A0 ] }
-: UNINITIALIZED_DECLARATOR_LIST ',' DECLARATOR { $3 : $1 }
-| DECLARATOR { [ $1 ] }
-
-INITIALIZED_DECLARATOR :: { Declarator A0 }
-: DECLARATOR '=' EXPRESSION { setInitialisation $1 $3 }
-| DECLARATOR '=>' EXPRESSION { setInitialisation $1 $3 }
-| DECLARATOR { $1 }
-
-DECLARATOR :: { Declarator A0 }
-: VARIABLE
-  {     Declarator () (getSpan $1)         $1 ScalarDecl                Nothing     Nothing }
-| VARIABLE '*' EXPRESSION
-  {     Declarator () (getTransSpan $1 $3) $1 ScalarDecl                (Just $3)   Nothing }
-| VARIABLE '*' '(' '*' ')'
-  { let star = ExpValue () (getSpan $4) ValStar
-     in Declarator () (getTransSpan $1 $5) $1 ScalarDecl                (Just star) Nothing }
-| VARIABLE '(' DIMENSION_DECLARATORS ')'
-  {     Declarator () (getTransSpan $1 $4) $1 (ArrayDecl (aReverse $3)) Nothing     Nothing }
-| VARIABLE '(' DIMENSION_DECLARATORS ')' '*' EXPRESSION
-  {     Declarator () (getTransSpan $1 $6) $1 (ArrayDecl (aReverse $3)) (Just $6)   Nothing }
--- nonstandard char array syntax (wrong order for dimensions & charlen)
-| VARIABLE '*' EXPRESSION '(' DIMENSION_DECLARATORS ')'
-  {     Declarator () (getTransSpan $1 $6) $1 (ArrayDecl (aReverse $5)) (Just $3)   Nothing }
-| VARIABLE '(' DIMENSION_DECLARATORS ')' '*' '(' '*' ')'
-  { let star = ExpValue () (getSpan $7) ValStar
-     in Declarator () (getTransSpan $1 $8) $1 (ArrayDecl (aReverse $3)) (Just star) 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 ':' EXPRESSION
-  { DimensionDeclarator () (getTransSpan $1 $3) (Just $1) (Just $3) }
-| EXPRESSION { DimensionDeclarator () (getSpan $1) Nothing (Just $1) }
--- Lower bound only
-| EXPRESSION ':'
-  { DimensionDeclarator () (getTransSpan $1 $2) (Just $1) Nothing }
-| EXPRESSION ':' '*'
-  { let { span = getSpan $3;
-          star = ExpValue () span ValStar }
-    in DimensionDeclarator () (getTransSpan $1 span) (Just $1) (Just star) }
-| '*'
-  { let { span = getSpan $1;
-          star = ExpValue () span ValStar }
-    in DimensionDeclarator () span Nothing (Just star) }
-| ':'
-  { let span = getSpan $1
-    in DimensionDeclarator () span Nothing 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 }
-| complex   KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeComplex $2 }
-| character CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeCharacter $2 }
-| logical   KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeLogical $2 }
-| type      '(' id ')'
-  { let TId _ id = $3
-    in TypeSpec () (getTransSpan $1 $4) (TypeCustom id) Nothing }
-
-KIND_SELECTOR :: { Maybe (Selector A0) }
-: '(' EXPRESSION ')'
-  { Just $ Selector () (getTransSpan $1 $3) Nothing (Just $2) }
-| '(' kind '=' EXPRESSION ')'
-  { Just $ Selector () (getTransSpan $1 $5) Nothing (Just $4) }
-| '*' EXPRESSION -- non-standard but commonly used extension
-  { Just $ Selector () (getTransSpan $1 $2) Nothing (Just $2) }
-| {- EMPTY -} { Nothing }
-
-CHAR_SELECTOR :: { Maybe (Selector A0) }
-: '*' EXPRESSION
-  { Just $ Selector () (getTransSpan $1 $2) (Just $2) Nothing }
--- The following rule is a bug in the spec.
--- | '*' EXPRESSION ','
---   { Just $ Selector () (getTransSpan $1 $2) (Just $2) Nothing }
-| '*' '(' '*' ')'
-  { let star = ExpValue () (getSpan $3) ValStar
-    in Just $ Selector () (getTransSpan $1 $4) (Just star) Nothing }
-| '(' LEN_EXPRESSION ')'
-  { Just $ Selector () (getTransSpan $1 $3) (Just $2) Nothing }
-| '(' len '=' LEN_EXPRESSION ')'
-  { Just $ Selector () (getTransSpan $1 $5) (Just $4) Nothing }
-| '(' kind '=' EXPRESSION ')'
-  { Just $ Selector () (getTransSpan $1 $5) Nothing (Just $4) }
-| '(' LEN_EXPRESSION ',' EXPRESSION ')'
-  { Just $ Selector () (getTransSpan $1 $5) (Just $2) (Just $4) }
-| '(' LEN_EXPRESSION ',' kind '=' EXPRESSION ')'
-  { Just $ Selector () (getTransSpan $1 $7) (Just $2) (Just $6) }
-| '(' len '=' LEN_EXPRESSION ',' kind '=' EXPRESSION ')'
-  { Just $ Selector () (getTransSpan $1 $9) (Just $4) (Just $8) }
-| '(' kind '=' EXPRESSION ',' len '=' LEN_EXPRESSION ')'
-  { Just $ Selector () (getTransSpan $1 $9) (Just $8) (Just $4) }
-| {- EMPTY -} { Nothing }
-
-LEN_EXPRESSION :: { Expression A0 }
-: EXPRESSION { $1 }
-| '*' { ExpValue () (getSpan $1) ValStar }
-
-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 SIGN
-  { 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 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 }
-| opCustom EXPRESSION %prec DEFINED_UNARY
-  { let TOpCustom span str = $1
-    in ExpUnary () (getTransSpan span $2) (UnCustom str) $2 }
-| EXPRESSION opCustom EXPRESSION
-  { let TOpCustom _ str = $2
-    in ExpBinary () (getTransSpan $1 $3) (BinCustom str) $1 $3 }
-| '(' EXPRESSION ')' { setSpan (getTransSpan $1 $3) $2 }
-| NUMERIC_LITERAL                   { $1 }
-| '(' EXPRESSION ',' EXPRESSION ')'
-  { ExpValue () (getTransSpan $1 $5) (ValComplex $2 $4) }
-| LOGICAL_LITERAL                   { $1 }
-| STRING                            { $1 }
-| DATA_REF                          { $1 }
-| IMPLIED_DO                        { $1 }
-| '(/' EXPRESSION_LIST '/)'
-  { ExpInitialisation () (getTransSpan $1 $3) (fromReverseList $2) }
-| operator '(' opCustom ')'
-  { let TOpCustom _ op = $3
-    in ExpValue () (getTransSpan $1 $4) (ValOperator op) }
-| assignment { ExpValue () (getSpan $1) ValAssignment }
-| '*' INTEGER_LITERAL { ExpReturnSpec () (getTransSpan $1 $2) $2 }
-
-DATA_REFS :: { [ Expression A0 ] }
-: DATA_REFS ',' DATA_REF { $3 : $1 }
-| DATA_REF { [ $1 ] }
-
-DATA_REF :: { Expression A0 }
-: DATA_REF '%' PART_REF { ExpDataRef () (getTransSpan $1 $3) $1 $3 }
-| PART_REF { $1 }
-
-PART_REFS :: { [ Expression A0 ] }
-: PART_REFS ',' PART_REF { $3 : $1 }
-| PART_REF { [ $1 ] }
-
-PART_REF :: { Expression A0 }
-: VARIABLE { $1 }
-| VARIABLE '(' ')'
-  { ExpFunctionCall () (getTransSpan $1 $3) $1 Nothing }
-| VARIABLE '(' INDICIES ')'
-  { ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3) }
-| VARIABLE '(' INDICIES ')' '(' INDICIES ')'
-  { let innerSub = ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3)
-    in ExpSubscript () (getTransSpan $1 $7) innerSub (fromReverseList $6) }
-
-INDICIES :: { [ Index A0 ] }
-: INDICIES ',' INDEX { $3 : $1 }
-| INDEX { [ $1 ] }
-
-INDEX :: { Index A0 }
-: RANGE { $1 }
-| RANGE ':' EXPRESSION
-  { let IxRange () s lower upper _ = $1
-    in IxRange () (getTransSpan s $3) lower upper (Just $3) }
-| EXPRESSION { IxSingle () (getSpan $1) Nothing $1 }
--- Following is only as an intermediate stage before having been turned into
--- an argument by later transformation.
-| id '=' EXPRESSION
-  { let TId s id = $1 in IxSingle () (getTransSpan $1 s) (Just id) $3 }
-
-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 }
-
-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 }
-
-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 ] }
-
-ARITHMETIC_SIGN :: { (SrcSpan, UnaryOp) }
-: '-' { (getSpan $1, Minus) }
-| '+' { (getSpan $1, Plus) }
-
-RELATIONAL_OPERATOR :: { BinaryOp }
-: '=='  { EQ }
-| '!='  { NE }
-| '>'   { GT }
-| '>='  { GTE }
-| '<'   { LT }
-| '<='  { LTE }
-
-VARIABLE :: { Expression A0 }
-: id { ExpValue () (getSpan $1) $ let (TId _ s) = $1 in ValVariable s }
-
-NUMERIC_LITERAL :: { Expression A0 }
-: INTEGER_LITERAL { $1 } | REAL_LITERAL { $1 }
-
-INTEGERS :: { [ Expression A0 ] }
-: INTEGERS ',' INTEGER_LITERAL { $3 : $1 }
-| INTEGER_LITERAL { [ $1 ] }
-
-INTEGER_LITERAL :: { Expression A0 }
-: int
-  { let TIntegerLiteral s i = $1
-     in ExpValue () s $ ValInteger i Nothing   }
-| int '_' KIND_PARAM
-  { let TIntegerLiteral s i = $1
-     in ExpValue () s $ ValInteger i (Just $3) }
-| boz { let TBozLiteral s b = $1 in ExpValue () s $ ValBoz b }
-
-REAL_LITERAL :: { Expression A0 }
-: float
-  { let TRealLiteral s r = $1
-     in ExpValue () s $ ValReal r Nothing }
-| float '_' KIND_PARAM
-  { let TRealLiteral s r = $1
-     in ExpValue () s $ ValReal r (Just $3) }
-
-LOGICAL_LITERAL :: { Expression A0 }
-: bool
-  { let TLogicalLiteral s b = $1
-     in ExpValue () s (ValLogical b Nothing) }
-| bool '_' KIND_PARAM
-  { let TLogicalLiteral s b = $1
-     in ExpValue () s (ValLogical b (Just $3)) }
-
-KIND_PARAM :: { Expression A0 }
-: INTEGER_LITERAL { $1 }
-| VARIABLE        { $1 }
-
-STRING :: { Expression A0 }
-: string { let TString s c = $1 in ExpValue () s $ ValString c }
-
-cDATA :: { () } : {% pushContext ConData }
-cIMPLICIT :: { () } : {% pushContext ConImplicit }
-cNAMELIST :: { () } : {% pushContext ConNamelist }
-cCOMMON :: { () } : {% pushContext ConCommon }
-cPOP :: { () } : {% popContext }
-
-{
-
-unitNameCheck :: Token -> String -> Parse AlexInput Token ()
-unitNameCheck (TId _ name1) name2
-  | name1 == name2 = return ()
-  | otherwise = fail "Unit name does not match the corresponding END statement."
-unitNameCheck _ _ = return ()
-
-parse = runParse programParser
-defTransforms = defaultTransformations Fortran90
-
-fortran90Parser ::
-    B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)
-fortran90Parser = fortran90ParserWithTransforms defTransforms
-
-fortran90ParserWithTransforms
-    :: [Transformation]
-    -> B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)
-fortran90ParserWithTransforms =
-    flip fortran90ParserWithModFilesWithTransforms emptyModFiles
-
-fortran90ParserWithModFiles
-    :: ModFiles
-    -> B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)
-fortran90ParserWithModFiles = fortran90ParserWithModFilesWithTransforms defTransforms
-
-fortran90ParserWithModFilesWithTransforms
-    :: [Transformation] -> ModFiles
-    -> B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)
-fortran90ParserWithModFilesWithTransforms transforms mods sourceCode filename =
-    fmap (pfSetFilename filename . transformWithModFiles mods transforms) $ parse parseState
-  where
-    parseState = initParseState sourceCode Fortran90 filename
-
-parseError :: Token -> LexAction a
-parseError _ = do
-    parseState <- get
-#ifdef DEBUG
-    tokens <- reverse <$> aiPreviousTokensInLine <$> getAlex
-#endif
-    fail $ psFilename parseState ++ ": parsing failed. "
-#ifdef DEBUG
-      ++ '\n' : show tokens
-#endif
-
-}
diff --git a/src/Language/Fortran/Parser/Fortran95.y b/src/Language/Fortran/Parser/Fortran95.y
deleted file mode 100644
--- a/src/Language/Fortran/Parser/Fortran95.y
+++ /dev/null
@@ -1,1290 +0,0 @@
--- -*- Mode: Haskell -*-
-{
-module Language.Fortran.Parser.Fortran95 ( functionParser
-                                         , blockParser
-                                         , statementParser
-                                         , fortran95Parser
-                                         , fortran95ParserWithTransforms
-                                         , fortran95ParserWithModFiles
-                                         , fortran95ParserWithModFilesWithTransforms
-                                         ) where
-
-
-import Prelude hiding (EQ,LT,GT) -- Same constructors exist in the AST
-import Control.Monad.State
-import Data.Maybe (fromMaybe, isJust)
-import Data.List (nub)
-import Data.Either (either, lefts, rights, partitionEithers)
-import Control.Applicative
-import qualified Data.ByteString.Char8 as B
-
-#ifdef DEBUG
-import Data.Data (toConstr)
-#endif
-
-import Language.Fortran.Util.Position
-import Language.Fortran.Util.ModFile
-import Language.Fortran.ParserMonad
-import Language.Fortran.Lexer.FreeForm
-import Language.Fortran.AST
-import Language.Fortran.Transformer
-
-import Debug.Trace
-
-}
-
-%name programParser PROGRAM
-%name blockParser BLOCK
-%name statementParser STATEMENT
-%name functionParser SUBPROGRAM_UNIT
-%monad { LexAction }
-%lexer { lexer } { TEOF _ }
-%tokentype { Token }
-%error { parseError }
-
-%token
-  id                          { TId _ _ }
-  comment                     { TComment _ _ }
-  string                      { TString _ _ }
-  int                         { TIntegerLiteral _ _ }
-  float                       { TRealLiteral _ _ }
-  boz                         { TBozLiteral _ _ }
-  '_'                         { TUnderscore _ }
-  ','                         { TComma _ }
-  ',2'                        { TComma2 _ }
-  ';'                         { TSemiColon _ }
-  ':'                         { TColon _ }
-  '::'                        { TDoubleColon _ }
-  '='                         { TOpAssign _ }
-  '=>'                        { TArrow _ }
-  '%'                         { TPercent _ }
-  '('                         { TLeftPar _ }
-  '(2'                        { TLeftPar2 _ }
-  ')'                         { TRightPar _ }
-  '(/'                        { TLeftInitPar _ }
-  '/)'                        { TRightInitPar _ }
-  opCustom                    { TOpCustom _ _ }
-  '**'                        { TOpExp _ }
-  '+'                         { TOpPlus _ }
-  '-'                         { TOpMinus _ }
-  '*'                         { TStar _ }
-  '/'                         { TOpDivision _ }
-  slash                       { TSlash _ }
-  or                          { TOpOr _ }
-  and                         { TOpAnd _ }
-  not                         { TOpNot _ }
-  eqv                         { TOpEquivalent _ }
-  neqv                        { TOpNotEquivalent _ }
-  '<'                         { TOpLT _ }
-  '<='                        { TOpLE _ }
-  '=='                        { TOpEQ _ }
-  '!='                        { TOpNE _ }
-  '>'                         { TOpGT _ }
-  '>='                        { TOpGE _ }
-  bool                        { TLogicalLiteral _ _ }
-  program                     { TProgram _ }
-  endProgram                  { TEndProgram _ }
-  function                    { TFunction _ }
-  endFunction                 { TEndFunction _ }
-  result                      { TResult _ }
-  pure                        { TPure _ }
-  elemental                   { TElemental _ }
-  recursive                   { TRecursive _ }
-  subroutine                  { TSubroutine _ }
-  endSubroutine               { TEndSubroutine _ }
-  blockData                   { TBlockData _ }
-  endBlockData                { TEndBlockData _ }
-  module                      { TModule _ }
-  endModule                   { TEndModule _ }
-  contains                    { TContains _ }
-  use                         { TUse _ }
-  only                        { TOnly _ }
-  interface                   { TInterface _ }
-  endInterface                { TEndInterface _ }
-  moduleProcedure             { TModuleProcedure _ }
-  assignment                  { TAssignment _ }
-  operator                    { TOperator _ }
-  call                        { TCall _ }
-  return                      { TReturn _ }
-  entry                       { TEntry _ }
-  include                     { TInclude _ }
-  public                      { TPublic _ }
-  private                     { TPrivate _ }
-  parameter                   { TParameter _ }
-  allocatable                 { TAllocatable _ }
-  dimension                   { TDimension _ }
-  external                    { TExternal _ }
-  intent                      { TIntent _ }
-  intrinsic                   { TIntrinsic _ }
-  optional                    { TOptional _ }
-  pointer                     { TPointer _ }
-  save                        { TSave _ }
-  target                      { TTarget _ }
-  value                       { TValue _ }
-  volatile                    { TVolatile _ }
-  in                          { TIn _ }
-  out                         { TOut _ }
-  inout                       { TInOut _ }
-  data                        { TData _ }
-  namelist                    { TNamelist _ }
-  implicit                    { TImplicit _ }
-  equivalence                 { TEquivalence _ }
-  common                      { TCommon _ }
-  allocate                    { TAllocate _ }
-  stat                        { TStat _ }
-  deallocate                  { TDeallocate _ }
-  nullify                     { TNullify _ }
-  none                        { TNone _ }
-  goto                        { TGoto _ }
-  to                          { TTo _ }
-  continue                    { TContinue _ }
-  stop                        { TStop _ }
-  do                          { TDo _ }
-  enddo                       { TEndDo _ }
-  while                       { TWhile _ }
-  if                          { TIf _ }
-  then                        { TThen _ }
-  else                        { TElse _ }
-  elsif                       { TElsif _ }
-  endif                       { TEndIf _ }
-  case                        { TCase _ }
-  selectcase                  { TSelectCase _ }
-  endselect                   { TEndSelect _ }
-  default                     { TDefault _ }
-  cycle                       { TCycle _ }
-  exit                        { TExit _ }
-  where                       { TWhere _ }
-  elsewhere                   { TElsewhere _ }
-  endwhere                    { TEndWhere _ }
-  type                        { TType _ }
-  endType                     { TEndType _ }
-  sequence                    { TSequence _ }
-  kind                        { TKind _ }
-  len                         { TLen _ }
-  integer                     { TInteger _ }
-  real                        { TReal _ }
-  doublePrecision             { TDoublePrecision _ }
-  logical                     { TLogical _ }
-  character                   { TCharacter _ }
-  complex                     { TComplex _ }
-  open                        { TOpen _ }
-  close                       { TClose _ }
-  read                        { TRead _ }
-  write                       { TWrite _ }
-  print                       { TPrint _ }
-  backspace                   { TBackspace _ }
-  rewind                      { TRewind _ }
-  inquire                     { TInquire _ }
-  endfile                     { TEndfile _ }
-  format                      { TFormat _ }
-  blob                        { TBlob _ _ }
-  end                         { TEnd _ }
-  newline                     { TNewline _ }
-  forall                      { TForall _ }
-  endforall                   { TEndForall _ }
--- Precedence of operators
-
--- Level 6
-%left opCustom
-
--- Level 5
-%left eqv neqv
-%left or
-%left and
-%right not
-
--- Level 4
-%nonassoc '==' '!=' '>' '<' '>=' '<='
-%nonassoc RELATIONAL
-
--- Level 3
-%left CONCAT
-
--- Level 2
-%left '+' '-'
-%left '*' '/'
-%right SIGN
-%right '**'
-
--- Level 1
-%right DEFINED_UNARY
-
--- Level 0
-%left '%'
-
-%%
-
-maybe(p)
-: p           { Just $1 }
-| {- empty -} { Nothing }
-
--- 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 = Fortran95, miFilename = "" }) (reverse $1) }
-| {- empty -}   { ProgramFile (MetaInfo { miVersion = Fortran95, miFilename = "" }) [] }
-
-PROGRAM_UNITS :: { [ ProgramUnit A0 ] }
-: PROGRAM_UNITS PROGRAM_UNIT MAYBE_NEWLINE { $2 : $1 }
-| PROGRAM_UNIT MAYBE_NEWLINE { [ $1 ] }
-
-PROGRAM_UNIT :: { ProgramUnit A0 }
-: program NAME NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS PROGRAM_END
-  {% do { unitNameCheck $6 $2;
-          return $ PUMain () (getTransSpan $1 $6) (Just $2) (reverse $4) $5 } }
-| module NAME NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS MODULE_END
-  {% do { unitNameCheck $6 $2;
-          return $ PUModule () (getTransSpan $1 $6) $2 (reverse $4) $5 } }
-| blockData NEWLINE BLOCKS BLOCK_DATA_END
-  { PUBlockData () (getTransSpan $1 $4) Nothing (reverse $3) }
-| blockData NAME NEWLINE BLOCKS BLOCK_DATA_END
-  {% do { unitNameCheck $5 $2;
-          return $ PUBlockData () (getTransSpan $1 $5) (Just $2) (reverse $4) } }
-| SUBPROGRAM_UNIT { $1 }
-
-MAYBE_SUBPROGRAM_UNITS :: { Maybe [ ProgramUnit A0 ] }
-: contains NEWLINE SUBPROGRAM_UNITS { Just $ reverse $3 }
-| {- Empty -} { Nothing }
-
-SUBPROGRAM_UNITS :: { [ ProgramUnit A0 ] }
-: SUBPROGRAM_UNITS SUBPROGRAM_UNIT NEWLINE { $2 : $1 }
-| {- EMPTY -} { [ ] }
-
-SUBPROGRAM_UNIT :: { ProgramUnit A0 }
-: PREFIXES function NAME MAYBE_ARGUMENTS MAYBE_RESULT MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END
-  {% do { unitNameCheck $10 $3;
-          let (pfxs, typeSpec) = case partitionEithers $1 of
-                                   { (ps, t:_) -> (fromReverseList' ps, Just t)
-                                   ; (ps, [])  -> (fromReverseList' ps, Nothing) } in
-          let sfx = emptySuffixes in
-          let ss = if null $1 then getTransSpan $2 $10 else getTransSpan (reverse $1) $10 in
-          if validPrefixSuffix (pfxs, sfx) then
-            return $ PUFunction () ss typeSpec (pfxs, sfx) $3 $4 $5 (reverse $8) $9
-          else fail "Cannot specify elemental along with recursive." } }
-| PREFIXES subroutine NAME MAYBE_ARGUMENTS MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS SUBROUTINE_END
-  {% do { unitNameCheck $9 $3;
-          (pfxs, typeSpec) <- case partitionEithers $1 of
-                                { (ps, t:_) -> fail "Subroutines cannot have return types."
-                                ; (ps, [])  -> return (fromReverseList' ps, Nothing) };
-          let sfx = emptySuffixes in
-          let ss = if null $1 then getTransSpan $2 $9 else getTransSpan (reverse $1) $9 in
-          if validPrefixSuffix (pfxs, sfx) then
-            return $ PUSubroutine () ss (pfxs, sfx) $3 $4 (reverse $7) $8
-          else fail "Cannot specify elemental along with recursive." } }
-| comment { let (TComment s c) = $1 in PUComment () s (Comment c) }
-
--- (Fortran2003) R1227, Fortran95 (...)
-PREFIXES :: { [Either (Prefix A0) (TypeSpec A0)] }
-: PREFIXES PREFIX { $2:$1 }
-| {- EMPTY -}     { [] }
-
--- (Fortran2003) R1228, Fortran95 (...)
-PREFIX :: { Either (Prefix A0) (TypeSpec A0) }
-: recursive { Left $ PfxRecursive () (getSpan $1) }
-| elemental { Left $ PfxElemental () (getSpan $1) }
-| pure      { Left $ PfxPure      () (getSpan $1) }
-| TYPE_SPEC { Right $1 }
-
-RESULT :: { Expression A0 }
-: result '(' VARIABLE ')' { $3 }
-
-MAYBE_RESULT :: { Maybe (Expression A0) }
-: RESULT      { Just $1 }
-| {- empty -} { Nothing}
-
-MAYBE_ARGUMENTS :: { Maybe (AList Expression A0) }
-: '(' MAYBE_VARIABLES ')' { $2 }
-| {- Nothing -} { Nothing }
-
-PROGRAM_END :: { Token }
-: end { $1 } | endProgram { $1 } | endProgram id { $2 }
-MODULE_END :: { Token }
-: end { $1 } | endModule { $1 } | endModule id { $2 }
-FUNCTION_END :: { Token }
-: end { $1 } | endFunction { $1 } | endFunction id { $2 }
-SUBROUTINE_END :: { Token }
-: end { $1 } | endSubroutine { $1 } | endSubroutine id { $2 }
-BLOCK_DATA_END :: { Token }
-: end { $1 } | endBlockData { $1 } | endBlockData id { $2 }
-INTERFACE_END :: { Token }
-: end { $1 } | endInterface { $1 } | endInterface id { $2 }
-
-NAME :: { Name } : id { let (TId _ name) = $1 in name }
-
-BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] }
-
-BLOCK :: { Block A0 }
-: IF_BLOCK MAYBE_COMMENT NEWLINE { $1 }
-| CASE_BLOCK MAYBE_COMMENT NEWLINE { $1 }
-| INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE
-  { BlStatement () (getTransSpan $1 $2) (Just $1) $2 }
-| STATEMENT MAYBE_COMMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 }
-| interface MAYBE_EXPRESSION MAYBE_COMMENT NEWLINE SUBPROGRAM_UNITS2 MODULE_PROCEDURES INTERFACE_END MAYBE_COMMENT NEWLINE
-  { BlInterface () (getTransSpan $1 $9) $2 False (reverse $5) (reverse $6) }
-| interface MAYBE_EXPRESSION MAYBE_COMMENT NEWLINE MODULE_PROCEDURES INTERFACE_END MAYBE_COMMENT NEWLINE
-  { BlInterface () (getTransSpan $1 $8) $2 False [ ] (reverse $5) }
-| COMMENT_BLOCK { $1 }
-
-IF_BLOCK :: { Block A0 }
-IF_BLOCK
-:                        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
-  { let { startSpan = getSpan $1;
-          (endSpan, conds, blocks, endLabel) = $9;
-          span = getTransSpan startSpan endSpan }
-     in BlIf () span Nothing Nothing ((Just $3):conds) ((reverse $8):blocks) endLabel }
-|                 id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
-  { let { TId startSpan startName = $1;
-          (endSpan, conds, blocks, endLabel) = $11;
-          span = getTransSpan startSpan endSpan }
-     in BlIf () span Nothing (Just startName) ((Just $5):conds) ((reverse $10):blocks) endLabel }
-| INTEGER_LITERAL        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
-  { let { startSpan = getSpan $1;
-          startLabel = Just $1;
-          (endSpan, conds, blocks, endLabel) = $10;
-          span = getTransSpan startSpan endSpan }
-     in BlIf () span startLabel Nothing ((Just $4):conds) ((reverse $9):blocks) endLabel }
-| INTEGER_LITERAL id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
-  { let { startSpan = getSpan $1;
-          startLabel = Just $1;
-          TId _ startName = $2;
-          (endSpan, conds, blocks, endLabel) = $12;
-          span = getTransSpan startSpan endSpan }
-     in BlIf () span startLabel (Just startName) ((Just $6):conds) ((reverse $11):blocks) endLabel }
-
-ELSE_BLOCKS :: { (SrcSpan, [Maybe (Expression A0)], [[Block A0]], Maybe (Expression A0)) }
-ELSE_BLOCKS
-: maybe(INTEGER_LITERAL) elsif '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
-  { let (endSpan, conds, blocks, endLabel) = $10
-    in (endSpan, Just $4 : conds, reverse $9 : blocks, endLabel) }
-| maybe(INTEGER_LITERAL) else                          MAYBE_COMMENT NEWLINE BLOCKS END_IF
-  { let (endSpan, endLabel) = $6
-    in (endSpan, [Nothing], [reverse $5], endLabel) }
-| END_IF { let (endSpan, endLabel) = $1 in (endSpan, [], [], endLabel) }
-
-END_IF :: { (SrcSpan, Maybe (Expression A0)) }
-END_IF
-: endif { (getSpan $1, Nothing) }
-| endif id { (getSpan $2, Nothing) }
-| INTEGER_LITERAL endif { (getSpan $2, Just $1) }
-| INTEGER_LITERAL endif id { (getSpan $3, Just $1) }
-
-CASE_BLOCK :: { Block A0 }
-CASE_BLOCK
-:                        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
-  { let { (caseRanges, blocks, endLabel, endSpan) = $7;
-          span = getTransSpan $1 endSpan }
-    in BlCase () span Nothing Nothing $3 caseRanges blocks endLabel }
-| INTEGER_LITERAL        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
-  { let { (caseRanges, blocks, endLabel, endSpan) = $8;
-          span = getTransSpan $1 endSpan }
-    in BlCase () span (Just $1) Nothing $4 caseRanges blocks endLabel }
-|                 id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
-  { let { (caseRanges, blocks, endLabel, endSpan) = $9;
-          TId s startName = $1;
-          span = getTransSpan s endSpan }
-    in BlCase () span Nothing (Just startName) $5 caseRanges blocks endLabel }
-| INTEGER_LITERAL id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
-  { let { (caseRanges, blocks, endLabel, endSpan) = $10;
-          TId s startName = $2;
-          span = getTransSpan s endSpan }
-    in BlCase () span (Just $1) (Just startName) $6 caseRanges blocks endLabel }
-
--- We store line comments as statements, but this raises an issue: we have
--- nowhere to place comments after a SELECT CASE but before a CASE. So we drop
--- them. The inner CASES_ rule does /not/ use this, because comments can always
--- be parsed as belonging to to the above CASE block.
-CASES :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }
-: COMMENT_BLOCK CASES_ { $2 }
-|               CASES_ { $1 }
-
-CASES_ :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }
-: maybe(INTEGER_LITERAL) case '(' INDICIES ')' MAYBE_COMMENT NEWLINE BLOCKS CASES_
-  { let (scrutinees, blocks, endLabel, endSpan) = $9
-    in  (Just (fromReverseList $4) : scrutinees, reverse $8 : blocks, endLabel, endSpan) }
-| maybe(INTEGER_LITERAL) case default          MAYBE_COMMENT NEWLINE BLOCKS END_SELECT
-  { let (endLabel, endSpan) = $7
-    in ([Nothing], [$6], endLabel, endSpan) }
-| END_SELECT
-  { let (endLabel, endSpan) = $1
-    in ([], [], endLabel, endSpan) }
-
-END_SELECT :: { (Maybe (Expression A0), SrcSpan) }
-: maybe(INTEGER_LITERAL) endselect maybe(id)
-  { ($1, maybe (getSpan $2) getSpan $3) }
-
-MAYBE_EXPRESSION :: { Maybe (Expression A0) }
-: EXPRESSION { Just $1 }
-| {- EMPTY -} { Nothing }
-
-MAYBE_COMMENT :: { Maybe Token }
-: comment { Just $1 }
-| {- EMPTY -} { Nothing }
-
-SUBPROGRAM_UNITS2 :: { [ ProgramUnit A0 ] }
-: SUBPROGRAM_UNITS SUBPROGRAM_UNIT NEWLINE { $2 : $1 }
-
-MODULE_PROCEDURES :: { [ Block A0 ] }
-: MODULE_PROCEDURES MODULE_PROCEDURE { $2 : $1 }
-| MODULE_PROCEDURES MODULE_PROCEDURE COMMENT_BLOCK { $3 : $2 : $1 }
-| { [ ] }
-
-MODULE_PROCEDURE :: { Block A0 }
-: moduleProcedure VARIABLES MAYBE_COMMENT NEWLINE
-  { let { al = fromReverseList $2;
-          st = StModuleProcedure () (getTransSpan $1 al) (fromReverseList $2) }
-    in BlStatement () (getTransSpan $1 $4) Nothing st }
-
-COMMENT_BLOCK :: { Block A0 }
-: 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 }
-| newline { $1 }
-| ';' { $1 }
-
-STATEMENT :: { Statement A0 }
-: NONEXECUTABLE_STATEMENT { $1 }
-| EXECUTABLE_STATEMENT { $1 }
-
-EXPRESSION_ASSIGNMENT_STATEMENT :: { Statement A0 }
-: DATA_REF '=' EXPRESSION { StExpressionAssign () (getTransSpan $1 $3) $1 $3 }
-
-NONEXECUTABLE_STATEMENT :: { Statement A0 }
-: DECLARATION_STATEMENT { $1 }
-| intent '(' INTENT_CHOICE ')' MAYBE_DCOLON EXPRESSION_LIST
-  { let expAList = fromReverseList $6
-    in StIntent () (getTransSpan $1 expAList) $3 expAList }
-| optional MAYBE_DCOLON EXPRESSION_LIST
-  { let expAList = fromReverseList $3
-    in StOptional () (getTransSpan $1 expAList) expAList }
-| public MAYBE_DCOLON EXPRESSION_LIST
-  { let expAList = fromReverseList $3
-    in StPublic () (getTransSpan $1 expAList) (Just expAList) }
-| public { StPublic () (getSpan $1) Nothing }
-| private MAYBE_DCOLON EXPRESSION_LIST
-  { let expAList = fromReverseList $3
-    in StPrivate () (getTransSpan $1 expAList) (Just expAList) }
-| private { StPrivate () (getSpan $1) Nothing }
-| save MAYBE_DCOLON SAVE_ARGS
-  { let saveAList = (fromReverseList $3)
-    in StSave () (getTransSpan $1 saveAList) (Just saveAList) }
-| save { StSave () (getSpan $1) Nothing }
-| dimension MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
-  { let declAList = fromReverseList $3
-    in StDimension () (getTransSpan $1 declAList) declAList }
-| allocatable MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
-  { let declAList = fromReverseList $3
-    in StAllocatable () (getTransSpan $1 declAList) declAList }
-| pointer MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
-  { let declAList = fromReverseList $3
-    in StPointer () (getTransSpan $1 declAList) declAList }
-| target MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
-  { let declAList = fromReverseList $3
-    in StTarget () (getTransSpan $1 declAList) declAList }
-| value MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
-  { let declAList = fromReverseList $3
-    in StValue () (getTransSpan $1 declAList) declAList }
-| volatile MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
-  { let declAList = fromReverseList $3
-    in StVolatile () (getTransSpan $1 declAList) declAList }
-| data cDATA DATA_GROUPS cPOP
-  { let dataAList = fromReverseList $3
-    in StData () (getTransSpan $1 dataAList) dataAList }
-| parameter '(' PARAMETER_ASSIGNMENTS ')'
-  { let declAList = fromReverseList $3
-    in StParameter () (getTransSpan $1 $4) declAList }
-| implicit none { StImplicit () (getTransSpan $1 $2) Nothing }
-| implicit cIMPLICIT IMP_LISTS cPOP
-  { let impAList = fromReverseList $3
-    in StImplicit () (getTransSpan $1 impAList) $ Just $ impAList }
-| namelist cNAMELIST NAMELISTS cPOP
-  { let nameALists = fromReverseList $3
-    in StNamelist () (getTransSpan $1 nameALists) nameALists }
-| equivalence EQUIVALENCE_GROUPS
-  { let eqALists = fromReverseList $2
-    in StEquivalence () (getTransSpan $1 eqALists) eqALists }
-| common cCOMMON COMMON_GROUPS cPOP
-  { let commonAList = fromReverseList $3
-    in StCommon () (getTransSpan $1 commonAList) commonAList }
-| external MAYBE_DCOLON VARIABLES
-  { let alist = fromReverseList $3
-    in StExternal () (getTransSpan $1 alist) alist }
-| intrinsic MAYBE_DCOLON VARIABLES
-  { let alist = fromReverseList $3
-    in StIntrinsic () (getTransSpan $1 alist) alist }
-| use VARIABLE { StUse () (getTransSpan $1 $2) $2 Nothing Permissive Nothing }
-| use VARIABLE ',' RENAME_LIST
-  { let alist = fromReverseList $4
-    in StUse () (getTransSpan $1 alist) $2 Nothing Permissive (Just alist) }
-| use VARIABLE ',' only ':' MAYBE_RENAME_LIST
-  { StUse () (getTransSpan $1 ($5, $6)) $2 Nothing Exclusive $6 }
-| entry VARIABLE MAYBE_RESULT
-  { StEntry () (getTransSpan $1 $ maybe (getSpan $2) getSpan $3) $2 Nothing $3 }
-| entry VARIABLE '(' ')' MAYBE_RESULT
-  { StEntry () (getTransSpan $1 $ maybe (getSpan $4) getSpan $5) $2 Nothing $5 }
-| entry VARIABLE '(' VARIABLES ')' MAYBE_RESULT
-  { StEntry () (getTransSpan $1 $ maybe (getSpan $5) getSpan $6) $2 (Just $ fromReverseList $4) $6 }
-| sequence { StSequence () (getSpan $1) }
-| type ATTRIBUTE_LIST '::' id
-  { let { TId span id = $4;
-          alist = if null $2 then Nothing else (Just . fromReverseList) $2 }
-    in StType () (getTransSpan $1 span) alist id }
-| type id
-  { let TId span id = $2 in StType () (getTransSpan $1 span) Nothing id }
-| endType { StEndType () (getSpan $1) Nothing }
-| endType id
-  { let TId span id = $2 in StEndType () (getTransSpan $1 span) (Just id) }
-| include STRING { StInclude () (getTransSpan $1 $2) $2 Nothing }
--- 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 }
-
-EXECUTABLE_STATEMENT :: { Statement A0 }
-: allocate '(' DATA_REFS MAYBE_ALLOC_OPT_LIST ')'
-  { StAllocate () (getTransSpan $1 $5) Nothing (fromReverseList $3) $4 }
-| nullify '(' DATA_REFS ')'
-  { StNullify () (getTransSpan $1 $4) (fromReverseList $3) }
-| deallocate '(' DATA_REFS MAYBE_ALLOC_OPT_LIST ')'
-  { StDeallocate () (getTransSpan $1 $5) (fromReverseList $3) $4 }
-| EXPRESSION_ASSIGNMENT_STATEMENT { $1 }
-| POINTER_ASSIGNMENT_STMT { $1 }
-| where '(' EXPRESSION ')' EXPRESSION_ASSIGNMENT_STATEMENT
-  { StWhere () (getTransSpan $1 $5) $3 $5 }
-| where '(' EXPRESSION ')' { StWhereConstruct () (getTransSpan $1 $4) Nothing $3 }
-| elsewhere '(' EXPRESSION ')' { StElsewhere () (getTransSpan $1 $4) Nothing (Just $3) }
-| elsewhere { StElsewhere () (getSpan $1) Nothing Nothing }
-| endwhere { StEndWhere () (getSpan $1) Nothing }
-| if '(' EXPRESSION ')' INTEGER_LITERAL ',' INTEGER_LITERAL ',' INTEGER_LITERAL
-  { StIfArithmetic () (getTransSpan $1 $9) $3 $5 $7 $9 }
-| do { StDo () (getSpan $1) Nothing Nothing Nothing }
-| id ':' do
-  { let TId s id = $1
-    in StDo () (getTransSpan s $3) (Just id) Nothing Nothing }
-| do INTEGER_LITERAL MAYBE_COMMA DO_SPECIFICATION
-  { StDo () (getTransSpan $1 $4) Nothing (Just $2) (Just $4) }
-| do DO_SPECIFICATION { StDo () (getTransSpan $1 $2) Nothing Nothing (Just $2) }
-| id ':' do DO_SPECIFICATION
-  { let TId s id = $1
-    in StDo () (getTransSpan s $4) (Just id) Nothing (Just $4) }
-| do INTEGER_LITERAL MAYBE_COMMA while '(' EXPRESSION ')'
-  { StDoWhile () (getTransSpan $1 $7) Nothing (Just $2) $6 }
-| do while '(' EXPRESSION ')'
-  { StDoWhile () (getTransSpan $1 $5) Nothing Nothing $4 }
-| id ':' do while '(' EXPRESSION ')'
-  { let TId s id = $1
-    in StDoWhile () (getTransSpan s $7) (Just id) Nothing $6 }
-| enddo { StEnddo () (getSpan $1) Nothing }
-| enddo id
-  { let TId s id = $2 in StEnddo () (getTransSpan $1 s) (Just id) }
-| cycle { StCycle () (getSpan $1) Nothing }
-| cycle VARIABLE { StCycle () (getTransSpan $1 $2) (Just $2) }
-| exit { StExit () (getSpan $1) Nothing }
-| exit VARIABLE { StExit () (getTransSpan $1 $2) (Just $2) }
--- GO TO label
-| goto INTEGER_LITERAL { StGotoUnconditional () (getTransSpan $1 $2) $2 }
--- GO TO label-list [,] scalar-int-expression
-| goto '(' INTEGERS ')' MAYBE_COMMA EXPRESSION
-  { StGotoComputed () (getTransSpan $1 $6) (fromReverseList $3) $6 }
-| continue { StContinue () (getSpan $1) }
-| stop { StStop () (getSpan $1) Nothing }
-| stop EXPRESSION { StStop () (getTransSpan $1 $2) (Just $2) }
-| if '(' EXPRESSION ')' EXECUTABLE_STATEMENT
-  { StIfLogical () (getTransSpan $1 $5) $3 $5 }
-| read CILIST IN_IOLIST
-  { let alist = fromReverseList $3
-    in StRead () (getTransSpan $1 alist) $2 (Just alist) }
-| read CILIST { StRead () (getTransSpan $1 $2) $2 Nothing }
-| read FORMAT_ID ',' IN_IOLIST
-  { let alist = fromReverseList $4
-    in StRead2 () (getTransSpan $1 alist) $2 (Just alist) }
-| read FORMAT_ID { StRead2 () (getTransSpan $1 $2) $2 Nothing }
-| write CILIST OUT_IOLIST
-  { let alist = fromReverseList $3
-    in StWrite () (getTransSpan $1 alist) $2 (Just alist) }
-| write CILIST { StWrite () (getTransSpan $1 $2) $2 Nothing }
-| print FORMAT_ID ',' OUT_IOLIST
-  { let alist = fromReverseList $4
-    in StPrint () (getTransSpan $1 alist) $2 (Just alist) }
-| print FORMAT_ID { StPrint () (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 }
-| call VARIABLE { StCall () (getTransSpan $1 $2) $2 Nothing }
-| call VARIABLE '(' ')' { StCall () (getTransSpan $1 $4) $2 Nothing }
-| call VARIABLE '(' ARGUMENTS ')'
-  { let alist = fromReverseList $4
-    in StCall () (getTransSpan $1 $5) $2 (Just alist) }
-| return { StReturn () (getSpan $1) Nothing }
-| return EXPRESSION { StReturn () (getTransSpan $1 $2) (Just $2) }
-| FORALL { $1 }
-| END_FORALL { $1 }
-
-ARGUMENTS :: { [ Argument A0 ] }
-: ARGUMENTS ',' ARGUMENT { $3 : $1 }
-| ARGUMENT { [ $1 ] }
-
-ARGUMENT :: { Argument A0 }
-: id '=' EXPRESSION
-  { let TId span keyword = $1
-    in Argument () (getTransSpan span $3) (Just keyword) $3 }
-| EXPRESSION
-  { Argument () (getSpan $1) Nothing $1 }
-
-MAYBE_RENAME_LIST :: { Maybe (AList Use A0) }
-: RENAME_LIST { Just $ fromReverseList $1 }
-| {- empty -} { Nothing }
-
-RENAME_LIST :: { [ Use A0 ] }
-: RENAME_LIST ',' RENAME { $3 : $1 }
-| RENAME { [ $1 ] }
-
-RENAME :: { Use A0  }
-: VARIABLE '=>' VARIABLE { UseRename () (getTransSpan $1 $3) $1 $3 }
-| VARIABLE { UseID () (getSpan $1) $1 }
-| operator '(' opCustom ')'
-  { let TOpCustom ss op = $3
-    in UseID () (getTransSpan $1 $4) (ExpValue () ss (ValOperator op)) }
-| assignment { UseID () (getSpan $1) (ExpValue () (getSpan $1) ValAssignment) }
-
-MAYBE_DCOLON :: { () } : '::' { () } | {- EMPTY -} { () }
-
-FORMAT_ID :: { Expression A0 }
-: FORMAT_ID '/' '/' FORMAT_ID %prec CONCAT
-  { ExpBinary () (getTransSpan $1 $4) Concatenation $1 $4 }
-| INTEGER_LITERAL { $1 }
-| STRING { $1 }
-| DATA_REF { $1 }
-| '*' { ExpValue () (getSpan $1) ValStar }
-
-UNIT :: { Expression A0 }
-: INTEGER_LITERAL { $1 }
-| DATA_REF { $1 }
-| '*' { ExpValue () (getSpan $1) ValStar }
-
-CILIST :: { AList ControlPair A0 }
-: '(' CILIST_ELEMENT ',' FORMAT_ID ',' CILIST_PAIRS ')'
-  { let { cp1 = ControlPair () (getSpan $2) Nothing $2;
-          cp2 = ControlPair () (getSpan $4) Nothing $4;
-          tail = fromReverseList $6 }
-    in setSpan (getTransSpan $1 $7) $ cp1 `aCons` cp2 `aCons` tail }
-| '(' CILIST_ELEMENT ',' FORMAT_ID ')'
-  { let { cp1 = ControlPair () (getSpan $2) Nothing $2;
-          cp2 = ControlPair () (getSpan $4) Nothing $4 }
-    in AList () (getTransSpan $1 $5) [ cp1,  cp2 ] }
-| '(' CILIST_ELEMENT ',' CILIST_PAIRS ')'
-  { let { cp1 = ControlPair () (getSpan $2) Nothing $2;
-          tail = fromReverseList $4 }
-    in setSpan (getTransSpan $1 $5) $ cp1 `aCons` tail }
-| '(' CILIST_ELEMENT ')'
-  { let cp1 = ControlPair () (getSpan $2) Nothing $2
-    in AList () (getTransSpan $1 $3) [ cp1 ] }
-| '(' CILIST_PAIRS ')' { fromReverseList $2 }
-
-CILIST_PAIRS :: { [ ControlPair A0 ] }
-: CILIST_PAIRS ',' CILIST_PAIR { $3 : $1 }
-| CILIST_PAIR { [ $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 SIGN
-  { 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 }
-| 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 }
-| opCustom CI_EXPRESSION %prec DEFINED_UNARY
-  { let TOpCustom span str = $1
-    in ExpUnary () (getTransSpan span $2) (UnCustom str) $2 }
-| CI_EXPRESSION opCustom CI_EXPRESSION
-  { let TOpCustom _ str = $2
-    in ExpBinary () (getTransSpan $1 $3) (BinCustom str) $1 $3 }
-| '(' CI_EXPRESSION ')' { setSpan (getTransSpan $1 $3) $2 }
-| INTEGER_LITERAL { $1 }
-| LOGICAL_LITERAL { $1 }
-| STRING { $1 }
-| DATA_REF { $1 }
-
-{- p67 ALLOCATE statement -}
-MAYBE_ALLOC_OPT_LIST :: { Maybe (AList AllocOpt A0) }
-: ',' stat '=' EXPRESSION { Just (fromReverseList [AOStat () (getTransSpan $2 $4) $4]) }
-| {- empty -}             { Nothing }
-
-IN_IOLIST :: { [ Expression A0 ] }
-: IN_IOLIST ',' IN_IO_ELEMENT { $3 : $1}
-| IN_IO_ELEMENT { [ $1 ] }
-
-IN_IO_ELEMENT :: { Expression A0 }
-: DATA_REF { $1 }
-| '(' IN_IOLIST ',' DO_SPECIFICATION ')'
-  { ExpImpliedDo () (getTransSpan $1 $5) (fromReverseList $2) $4 }
-
-OUT_IOLIST :: { [ Expression A0 ] }
-: OUT_IOLIST ',' EXPRESSION { $3 : $1}
-| EXPRESSION { [ $1 ] }
-
-COMMON_GROUPS :: { [ CommonGroup A0 ] }
-: COMMON_GROUPS COMMON_GROUP { $2 : $1 }
-| COMMON_GROUPS ',2' COMMON_GROUP { $3 : $1 }
-| INIT_COMMON_GROUP { [ $1 ] }
-
-COMMON_GROUP :: { CommonGroup A0 }
-: COMMON_NAME UNINITIALIZED_DECLARATOR_LIST
-  { let alist = fromReverseList $2
-    in CommonGroup () (getTransSpan $1 alist) (Just $1) alist }
-| '/' '/' UNINITIALIZED_DECLARATOR_LIST
-  { let alist = fromReverseList $3
-    in CommonGroup () (getTransSpan $1 alist) Nothing alist }
-
-INIT_COMMON_GROUP :: { CommonGroup A0 }
-: COMMON_NAME UNINITIALIZED_DECLARATOR_LIST
-  { let alist = fromReverseList $2
-    in CommonGroup () (getTransSpan $1 alist) (Just $1) alist }
-| '/' '/' UNINITIALIZED_DECLARATOR_LIST
-  { let alist = fromReverseList $3
-    in CommonGroup () (getTransSpan $1 alist) Nothing alist }
-| UNINITIALIZED_DECLARATOR_LIST
-  { let alist = fromReverseList $1
-    in CommonGroup () (getSpan alist) Nothing alist }
-
-EQUIVALENCE_GROUPS :: { [ AList Expression A0 ] }
-: EQUIVALENCE_GROUPS ',' '(' PART_REFS ')'
-  { setSpan (getTransSpan $3 $5) (fromReverseList $4) : $1 }
-| '(' PART_REFS ')'
-  { [ setSpan (getTransSpan $1 $3) (fromReverseList $2) ] }
-
-NAMELISTS :: { [ Namelist A0 ] }
-: NAMELISTS NAMELIST { $2 : $1 }
-| NAMELISTS ',2' NAMELIST { $3 : $1 }
-| NAMELIST { [ $1 ] }
-
-NAMELIST :: { Namelist A0 }
-: '/' VARIABLE '/' VARIABLES
-  { Namelist () (getTransSpan $1 $4) $2 $ fromReverseList $4 }
-
-MAYBE_VARIABLES :: { Maybe (AList Expression A0) }
-: VARIABLES { Just $ fromReverseList $1 } | {- EMPTY -} { Nothing }
-
-VARIABLES :: { [ Expression A0 ] }
-: VARIABLES ',' VARIABLE { $3 : $1 }
-| VARIABLE { [ $1 ] }
-
-IMP_LISTS :: { [ ImpList A0 ] }
-: IMP_LISTS ',' IMP_LIST { $3 : $1 }
-| IMP_LIST { [ $1 ] }
-
-IMP_LIST :: { ImpList A0 }
-: TYPE_SPEC '(2' 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
-             }
-
-PARAMETER_ASSIGNMENTS :: { [ Declarator A0 ] }
-: PARAMETER_ASSIGNMENTS ',' PARAMETER_ASSIGNMENT { $3 : $1 }
-| PARAMETER_ASSIGNMENT { [ $1 ] }
-
-PARAMETER_ASSIGNMENT :: { Declarator A0 }
-: VARIABLE '=' EXPRESSION
-  { Declarator () (getTransSpan $1 $3) $1 ScalarDecl Nothing (Just $3) }
-
-DECLARATION_STATEMENT :: { Statement A0 }
-: TYPE_SPEC ATTRIBUTE_LIST '::' INITIALIZED_DECLARATOR_LIST
-  { let { mAttrAList = if null $2 then Nothing else Just $ fromReverseList $2;
-          declAList = fromReverseList $4 }
-    in StDeclaration () (getTransSpan $1 declAList) $1 mAttrAList declAList }
-| TYPE_SPEC INITIALIZED_DECLARATOR_LIST
-  { let { declAList = fromReverseList $2 }
-    in StDeclaration () (getTransSpan $1 declAList) $1 Nothing declAList }
-
-ATTRIBUTE_LIST :: { [ Attribute A0 ] }
-: ATTRIBUTE_LIST ',' ATTRIBUTE_SPEC { $3 : $1 }
-| {- EMPTY -} { [ ] }
-
-ATTRIBUTE_SPEC :: { Attribute A0 }
-: public { AttrPublic () (getSpan $1) }
-| private { AttrPrivate () (getSpan $1) }
-| allocatable { AttrAllocatable () (getSpan $1) }
-| dimension '(' DIMENSION_DECLARATORS ')'
-  { AttrDimension () (getTransSpan $1 $4) (aReverse $3) }
-| external { AttrExternal () (getSpan $1) }
-| intent '(' INTENT_CHOICE ')' { AttrIntent () (getTransSpan $1 $4) $3 }
-| intrinsic { AttrIntrinsic () (getSpan $1) }
-| optional { AttrOptional () (getSpan $1) }
-| pointer { AttrPointer () (getSpan $1) }
-| parameter { AttrParameter () (getSpan $1) }
-| save { AttrSave () (getSpan $1) }
-| target { AttrTarget () (getSpan $1) }
-| value { AttrValue () (getSpan $1) }
-| volatile { AttrVolatile () (getSpan $1) }
-
-INTENT_CHOICE :: { Intent } : in { In } | out { Out } | inout { InOut }
-
-DATA_GROUPS :: { [ DataGroup A0 ] }
-: DATA_GROUPS MAYBE_COMMA DATA_LIST slash EXPRESSION_LIST slash
-  { let { nameAList = fromReverseList $3;
-          dataAList = fromReverseList $5 }
-    in DataGroup () (getTransSpan nameAList $6) nameAList dataAList : $1 }
-| DATA_LIST slash EXPRESSION_LIST slash
-  { let { nameAList = fromReverseList $1;
-          dataAList = fromReverseList $3 }
-    in [ DataGroup () (getTransSpan nameAList $4) nameAList dataAList ] }
-
-MAYBE_COMMA :: { () } : ',' { () } | {- EMPTY -} { () }
-
-DATA_LIST :: { [ Expression A0 ] }
-: DATA_LIST ',' DATA_ELEMENT { $3 : $1 }
-| DATA_ELEMENT { [ $1 ] }
-
-DATA_ELEMENT :: { Expression A0 }
-: DATA_REF { $1 } | IMPLIED_DO { $1 }
-
-SAVE_ARGS :: { [ Expression A0 ] }
-: SAVE_ARGS ',' SAVE_ARG { $3 : $1 } | SAVE_ARG { [ $1 ] }
-
-SAVE_ARG :: { Expression A0 } : COMMON_NAME { $1 } | VARIABLE { $1 }
-
-COMMON_NAME :: { Expression A0 }
-: '/' VARIABLE '/' { setSpan (getTransSpan $1 $3) $2 }
-
-INITIALIZED_DECLARATOR_LIST :: { [ Declarator A0 ] }
-: INITIALIZED_DECLARATOR_LIST ',' INITIALIZED_DECLARATOR { $3 : $1 }
-| INITIALIZED_DECLARATOR { [ $1 ] }
-
-UNINITIALIZED_DECLARATOR_LIST :: { [ Declarator A0 ] }
-: UNINITIALIZED_DECLARATOR_LIST ',' DECLARATOR { $3 : $1 }
-| DECLARATOR { [ $1 ] }
-
-INITIALIZED_DECLARATOR :: { Declarator A0 }
-: DECLARATOR '=' EXPRESSION { setInitialisation $1 $3 }
-| DECLARATOR '=>' EXPRESSION { setInitialisation $1 $3 }
-| DECLARATOR { $1 }
-
-DECLARATOR :: { Declarator A0 }
-: VARIABLE
-  {     Declarator () (getSpan $1)         $1 ScalarDecl                Nothing     Nothing }
-| VARIABLE '*' EXPRESSION
-  {     Declarator () (getTransSpan $1 $3) $1 ScalarDecl                (Just $3)   Nothing }
-| VARIABLE '*' '(' '*' ')'
-  { let star = ExpValue () (getSpan $4) ValStar
-     in Declarator () (getTransSpan $1 $5) $1 ScalarDecl                (Just star) Nothing }
-| VARIABLE '(' DIMENSION_DECLARATORS ')'
-  {     Declarator () (getTransSpan $1 $4) $1 (ArrayDecl (aReverse $3)) Nothing     Nothing }
-| VARIABLE '(' DIMENSION_DECLARATORS ')' '*' EXPRESSION
-  {     Declarator () (getTransSpan $1 $6) $1 (ArrayDecl (aReverse $3)) (Just $6)   Nothing }
--- nonstandard char array syntax (wrong order for dimensions & charlen)
-| VARIABLE '*' EXPRESSION '(' DIMENSION_DECLARATORS ')'
-  {     Declarator () (getTransSpan $1 $6) $1 (ArrayDecl (aReverse $5)) (Just $3)   Nothing }
-| VARIABLE '(' DIMENSION_DECLARATORS ')' '*' '(' '*' ')'
-  { let star = ExpValue () (getSpan $7) ValStar
-     in Declarator () (getTransSpan $1 $8) $1 (ArrayDecl (aReverse $3)) (Just star) 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 ':' EXPRESSION
-  { DimensionDeclarator () (getTransSpan $1 $3) (Just $1) (Just $3) }
-| EXPRESSION { DimensionDeclarator () (getSpan $1) Nothing (Just $1) }
--- Lower bound only
-| EXPRESSION ':'
-  { DimensionDeclarator () (getTransSpan $1 $2) (Just $1) Nothing }
-| EXPRESSION ':' '*'
-  { let { span = getSpan $3;
-          star = ExpValue () span ValStar }
-    in DimensionDeclarator () (getTransSpan $1 span) (Just $1) (Just star) }
-| '*'
-  { let { span = getSpan $1;
-          star = ExpValue () span ValStar }
-    in DimensionDeclarator () span Nothing (Just star) }
-| ':'
-  { let span = getSpan $1
-    in DimensionDeclarator () span Nothing 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 }
-| complex   KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeComplex $2 }
-| character CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeCharacter $2 }
-| logical   KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeLogical $2 }
-| type      '(' id ')'
-  { let TId _ id = $3
-    in TypeSpec () (getTransSpan $1 $4) (TypeCustom id) Nothing }
-
-KIND_SELECTOR :: { Maybe (Selector A0) }
-: '(' EXPRESSION ')'
-  { Just $ Selector () (getTransSpan $1 $3) Nothing (Just $2) }
-| '(' kind '=' EXPRESSION ')'
-  { Just $ Selector () (getTransSpan $1 $5) Nothing (Just $4) }
-| '*' EXPRESSION -- non-standard but commonly used extension
-  { Just $ Selector () (getTransSpan $1 $2) Nothing (Just $2) }
-| {- EMPTY -} { Nothing }
-
-CHAR_SELECTOR :: { Maybe (Selector A0) }
-: '*' EXPRESSION
-  { Just $ Selector () (getTransSpan $1 $2) (Just $2) Nothing }
--- The following rule is a bug in the spec.
--- | '*' EXPRESSION ','
---   { Just $ Selector () (getTransSpan $1 $2) (Just $2) Nothing }
-| '*' '(' '*' ')'
-  { let star = ExpValue () (getSpan $3) ValStar
-    in Just $ Selector () (getTransSpan $1 $4) (Just star) Nothing }
-| '(' LEN_EXPRESSION ')'
-  { Just $ Selector () (getTransSpan $1 $3) (Just $2) Nothing }
-| '(' len '=' LEN_EXPRESSION ')'
-  { Just $ Selector () (getTransSpan $1 $5) (Just $4) Nothing }
-| '(' kind '=' EXPRESSION ')'
-  { Just $ Selector () (getTransSpan $1 $5) Nothing (Just $4) }
-| '(' LEN_EXPRESSION ',' EXPRESSION ')'
-  { Just $ Selector () (getTransSpan $1 $5) (Just $2) (Just $4) }
-| '(' LEN_EXPRESSION ',' kind '=' EXPRESSION ')'
-  { Just $ Selector () (getTransSpan $1 $7) (Just $2) (Just $6) }
-| '(' len '=' LEN_EXPRESSION ',' kind '=' EXPRESSION ')'
-  { Just $ Selector () (getTransSpan $1 $9) (Just $4) (Just $8) }
-| '(' kind '=' EXPRESSION ',' len '=' LEN_EXPRESSION ')'
-  { Just $ Selector () (getTransSpan $1 $9) (Just $8) (Just $4) }
-| {- EMPTY -} { Nothing }
-
-LEN_EXPRESSION :: { Expression A0 }
-: EXPRESSION { $1 }
-| '*' { ExpValue () (getSpan $1) ValStar }
-
-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 SIGN
-  { 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 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 }
-| opCustom EXPRESSION %prec DEFINED_UNARY
-  { let TOpCustom span str = $1
-    in ExpUnary () (getTransSpan span $2) (UnCustom str) $2 }
-| EXPRESSION opCustom EXPRESSION
-  { let TOpCustom _ str = $2
-    in ExpBinary () (getTransSpan $1 $3) (BinCustom str) $1 $3 }
-| '(' EXPRESSION ')' { setSpan (getTransSpan $1 $3) $2 }
-| NUMERIC_LITERAL                   { $1 }
-| '(' EXPRESSION ',' EXPRESSION ')'
-  { ExpValue () (getTransSpan $1 $5) (ValComplex $2 $4) }
-| LOGICAL_LITERAL                   { $1 }
-| STRING                            { $1 }
-| DATA_REF                          { $1 }
-| IMPLIED_DO                        { $1 }
-| '(/' EXPRESSION_LIST '/)'
-  { ExpInitialisation () (getTransSpan $1 $3) (fromReverseList $2) }
-| operator '(' opCustom ')'
-  { let TOpCustom _ op = $3
-    in ExpValue () (getTransSpan $1 $4) (ValOperator op) }
-| assignment { ExpValue () (getSpan $1) ValAssignment }
-| '*' INTEGER_LITERAL { ExpReturnSpec () (getTransSpan $1 $2) $2 }
-
-DATA_REFS :: { [ Expression A0 ] }
-: DATA_REFS ',' DATA_REF { $3 : $1 }
-| DATA_REF { [ $1 ] }
-
-DATA_REF :: { Expression A0 }
-: DATA_REF '%' PART_REF { ExpDataRef () (getTransSpan $1 $3) $1 $3 }
-| PART_REF { $1 }
-
-PART_REFS :: { [ Expression A0 ] }
-: PART_REFS ',' PART_REF { $3 : $1 }
-| PART_REF { [ $1 ] }
-
-PART_REF :: { Expression A0 }
-: VARIABLE { $1 }
-| VARIABLE '(' ')'
-  { ExpFunctionCall () (getTransSpan $1 $3) $1 Nothing }
-| VARIABLE '(' INDICIES ')'
-  { ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3) }
-| VARIABLE '(' INDICIES ')' '(' INDICIES ')'
-  { let innerSub = ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3)
-    in ExpSubscript () (getTransSpan $1 $7) innerSub (fromReverseList $6) }
-
-INDICIES :: { [ Index A0 ] }
-: INDICIES ',' INDEX { $3 : $1 }
-| INDEX { [ $1 ] }
-
-INDEX :: { Index A0 }
-: RANGE { $1 }
-| RANGE ':' EXPRESSION
-  { let IxRange () s lower upper _ = $1
-    in IxRange () (getTransSpan s $3) lower upper (Just $3) }
-| EXPRESSION { IxSingle () (getSpan $1) Nothing $1 }
--- Following is only as an intermediate stage before having been turned into
--- an argument by later transformation.
-| id '=' EXPRESSION
-  { let TId s id = $1 in IxSingle () (getTransSpan $1 s) (Just id) $3 }
-
-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 }
-
-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 }
-
-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 }
-
-FORALL :: { Statement A0 }
-: id ':' forall FORALL_HEADER {
-  let (TId s1 id) = $1 in
-  let (h,s2) = $4 in
-  StForall () (getTransSpan s1 s2) (Just id) h
-}
-| forall FORALL_HEADER {
-  let (h,s) = $2 in
-  StForall () (getTransSpan $1 s) Nothing h
-}
-| forall FORALL_HEADER FORALL_ASSIGNMENT_STMT {
-  let (h,_) = $2 in
-  StForallStatement () (getTransSpan $1 $3) h $3
-}
-
-FORALL_HEADER
-  :: { (ForallHeader A0, SrcSpan) }
-FORALL_HEADER :
-  -- Standard simple forall header
-    '(' FORALL_TRIPLET_SPEC ')'   { (ForallHeader [$2] Nothing, getTransSpan $1 $3) }
-  -- forall header with scale expression
-  | '(' '(' FORALL_TRIPLET_SPEC ')' ',' EXPRESSION ')'
-                                  { (ForallHeader [$3] (Just $6), getTransSpan $1 $7) }
-  -- multi forall header
-  | '(' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE ')'
-                                  { (ForallHeader $2 Nothing, getTransSpan $1 $3) }
-  -- multi forall header with scale
-  | '(' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE ',' EXPRESSION ')'
-                                  { (ForallHeader $2 (Just $4), getTransSpan $1 $5) }
-
-FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE
-  :: { [(Name, Expression A0, Expression A0, Maybe (Expression A0))] }
-FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE
-: '(' FORALL_TRIPLET_SPEC ')' ',' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE { $2 : $5 }
-| {- empty -}                                                          { [] }
-
-FORALL_TRIPLET_SPEC :: { (Name, Expression A0, Expression A0, Maybe (Expression A0)) }
-FORALL_TRIPLET_SPEC
-: NAME '=' EXPRESSION ':' EXPRESSION { ($1, $3, $5, Nothing) }
-| NAME '=' EXPRESSION ':' EXPRESSION ',' EXPRESSION { ($1, $3, $5, Just $7) }
-
-FORALL_ASSIGNMENT_STMT :: { Statement A0 }
-FORALL_ASSIGNMENT_STMT :
-    EXPRESSION_ASSIGNMENT_STATEMENT { $1 }
-  | POINTER_ASSIGNMENT_STMT { $1 }
-
-POINTER_ASSIGNMENT_STMT :: { Statement A0 }
-POINTER_ASSIGNMENT_STMT :
- DATA_REF '=>' EXPRESSION { StPointerAssign () (getTransSpan $1 $3) $1 $3 }
-
-END_FORALL :: { Statement A0 }
-END_FORALL :
-   endforall    { StEndForall () (getSpan $1) Nothing }
- | endforall id { let (TId s id) = $2 in StEndForall () (getTransSpan $1 s) (Just id)}
-
-EXPRESSION_LIST :: { [ Expression A0 ] }
-: EXPRESSION_LIST ',' EXPRESSION { $3 : $1 }
-| EXPRESSION { [ $1 ] }
-
-ARITHMETIC_SIGN :: { (SrcSpan, UnaryOp) }
-: '-' { (getSpan $1, Minus) }
-| '+' { (getSpan $1, Plus) }
-
-RELATIONAL_OPERATOR :: { BinaryOp }
-: '=='  { EQ }
-| '!='  { NE }
-| '>'   { GT }
-| '>='  { GTE }
-| '<'   { LT }
-| '<='  { LTE }
-
-VARIABLE :: { Expression A0 }
-: id { ExpValue () (getSpan $1) $ let (TId _ s) = $1 in ValVariable s }
-
-NUMERIC_LITERAL :: { Expression A0 }
-: INTEGER_LITERAL { $1 } | REAL_LITERAL { $1 }
-
-INTEGERS :: { [ Expression A0 ] }
-: INTEGERS ',' INTEGER_LITERAL { $3 : $1 }
-| INTEGER_LITERAL { [ $1 ] }
-
-INTEGER_LITERAL :: { Expression A0 }
-: int
-  { let TIntegerLiteral s i = $1
-     in ExpValue () s $ ValInteger i Nothing   }
-| int '_' KIND_PARAM
-  { let TIntegerLiteral s i = $1
-     in ExpValue () s $ ValInteger i (Just $3) }
-| boz { let TBozLiteral s b = $1 in ExpValue () s $ ValBoz b }
-
-REAL_LITERAL :: { Expression A0 }
-: float
-  { let TRealLiteral s r = $1
-     in ExpValue () s $ ValReal r Nothing }
-| float '_' KIND_PARAM
-  { let TRealLiteral s r = $1
-     in ExpValue () s $ ValReal r (Just $3) }
-
-LOGICAL_LITERAL :: { Expression A0 }
-: bool
-  { let TLogicalLiteral s b = $1
-     in ExpValue () s (ValLogical b Nothing) }
-| bool '_' KIND_PARAM
-  { let TLogicalLiteral s b = $1
-     in ExpValue () s (ValLogical b (Just $3)) }
-
-KIND_PARAM :: { Expression A0 }
-: INTEGER_LITERAL { $1 }
-| VARIABLE        { $1 }
-
-STRING :: { Expression A0 }
-: string { let TString s c = $1 in ExpValue () s $ ValString c }
-
-cDATA :: { () } : {% pushContext ConData }
-cIMPLICIT :: { () } : {% pushContext ConImplicit }
-cNAMELIST :: { () } : {% pushContext ConNamelist }
-cCOMMON :: { () } : {% pushContext ConCommon }
-cPOP :: { () } : {% popContext }
-
-{
-
-unitNameCheck :: Token -> String -> Parse AlexInput Token ()
-unitNameCheck (TId _ name1) name2
-  | name1 == name2 = return ()
-  | otherwise = fail "Unit name does not match the corresponding END statement."
-unitNameCheck _ _ = return ()
-
-parse = runParse programParser
-defTransforms = defaultTransformations Fortran95
-
-fortran95Parser
-    :: B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)
-fortran95Parser = fortran95ParserWithTransforms defTransforms
-
-fortran95ParserWithTransforms
-    :: [Transformation]
-    -> B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)
-fortran95ParserWithTransforms =
-    flip fortran95ParserWithModFilesWithTransforms emptyModFiles
-
-fortran95ParserWithModFiles
-    :: ModFiles
-    -> B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)
-fortran95ParserWithModFiles = fortran95ParserWithModFilesWithTransforms defTransforms
-
-fortran95ParserWithModFilesWithTransforms
-    :: [Transformation] -> ModFiles
-    -> B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)
-fortran95ParserWithModFilesWithTransforms transforms mods sourceCode filename =
-    fmap (pfSetFilename filename . transformWithModFiles mods transforms) $ parse parseState
-  where
-    parseState = initParseState sourceCode Fortran95 filename
-
-parseError :: Token -> LexAction a
-parseError token = do
-    parseState <- get
-#ifdef DEBUG
-    tokens <- reverse <$> aiPreviousTokensInLine <$> getAlex
-#endif
-    fail $ psFilename parseState ++ ": parsing failed. "
-      ++ specifics token
-#ifdef DEBUG
-      ++ '\n' : show tokens
-#endif
-  where specifics (TPause _) = "\nPAUSE statements are not supported in Fortran 95 or later. "
-        specifics (TAssign _) = "\nASSIGN statements are not supported in Fortran 95 or later. "
-        specifics _ = ""
-
-}
diff --git a/src/Language/Fortran/Parser/Free/Fortran2003.y b/src/Language/Fortran/Parser/Free/Fortran2003.y
new file mode 100644
--- /dev/null
+++ b/src/Language/Fortran/Parser/Free/Fortran2003.y
@@ -0,0 +1,1417 @@
+-- -*- Mode: Haskell -*-
+-- vim: ft=haskell
+{
+module Language.Fortran.Parser.Free.Fortran2003
+  ( programParser
+  , functionParser
+  , blockParser
+  , statementParser
+  , expressionParser
+  ) where
+
+import Language.Fortran.Version
+import Language.Fortran.Util.Position
+import Language.Fortran.Parser.Monad
+import Language.Fortran.Parser.Free.Lexer
+import Language.Fortran.Parser.Free.Utils
+import Language.Fortran.AST
+
+import Prelude hiding ( EQ, LT, GT ) -- Same constructors exist in the AST
+import Data.Either ( partitionEithers )
+
+}
+
+%name programParser    PROGRAM
+%name functionParser   SUBPROGRAM_UNIT
+%name blockParser      BLOCK
+%name statementParser  STATEMENT
+%name expressionParser EXPRESSION
+%monad { LexAction }
+%lexer { lexer } { TEOF _ }
+%tokentype { Token }
+%error { parseError }
+
+%token
+  id                          { TId _ _ }
+  comment                     { TComment _ _ }
+  string                      { TString _ _ }
+  int                         { TIntegerLiteral _ _ }
+  float                       { TRealLiteral _ _ }
+  boz                         { TBozLiteral _ _ }
+  '_'                         { TUnderscore _ }
+  ','                         { TComma _ }
+  ',2'                        { TComma2 _ }
+  ';'                         { TSemiColon _ }
+  ':'                         { TColon _ }
+  '::'                        { TDoubleColon _ }
+  '='                         { TOpAssign _ }
+  '=>'                        { TArrow _ }
+  '%'                         { TPercent _ }
+  '('                         { TLeftPar _ }
+  '(2'                        { TLeftPar2 _ }
+  ')'                         { TRightPar _ }
+  '(/'                        { TLeftInitPar _ }
+  '/)'                        { TRightInitPar _ }
+  opCustom                    { TOpCustom _ _ }
+  '**'                        { TOpExp _ }
+  '+'                         { TOpPlus _ }
+  '-'                         { TOpMinus _ }
+  '*'                         { TStar _ }
+  '/'                         { TOpDivision _ }
+  slash                       { TSlash _ }
+  or                          { TOpOr _ }
+  and                         { TOpAnd _ }
+  not                         { TOpNot _ }
+  eqv                         { TOpEquivalent _ }
+  neqv                        { TOpNotEquivalent _ }
+  '<'                         { TOpLT _ }
+  '<='                        { TOpLE _ }
+  '=='                        { TOpEQ _ }
+  '!='                        { TOpNE _ }
+  '>'                         { TOpGT _ }
+  '>='                        { TOpGE _ }
+  bool                        { TLogicalLiteral _ _ }
+  program                     { TProgram _ }
+  endProgram                  { TEndProgram _ }
+  function                    { TFunction _ }
+  endFunction                 { TEndFunction _ }
+  result                      { TResult _ }
+  pure                        { TPure _ }
+  elemental                   { TElemental _ }
+  recursive                   { TRecursive _ }
+  subroutine                  { TSubroutine _ }
+  endSubroutine               { TEndSubroutine _ }
+  blockData                   { TBlockData _ }
+  endBlockData                { TEndBlockData _ }
+  module                      { TModule _ }
+  endModule                   { TEndModule _ }
+  contains                    { TContains _ }
+  use                         { TUse _ }
+  only                        { TOnly _ }
+  import                      { TImport _ }
+  abstract                    { TAbstract _ }
+  interface                   { TInterface _ }
+  endInterface                { TEndInterface _ }
+  moduleProcedure             { TModuleProcedure _ }
+  procedure                   { TProcedure _ }
+  assignment                  { TAssignment _ }
+  operator                    { TOperator _ }
+  call                        { TCall _ }
+  return                      { TReturn _ }
+  entry                       { TEntry _ }
+  include                     { TInclude _ }
+  public                      { TPublic _ }
+  private                     { TPrivate _ }
+  protected                   { TProtected _ }
+  parameter                   { TParameter _ }
+  allocatable                 { TAllocatable _ }
+  asynchronous                { TAsynchronous _ }
+  dimension                   { TDimension _ }
+  external                    { TExternal _ }
+  intent                      { TIntent _ }
+  intrinsic                   { TIntrinsic _ }
+  nonintrinsic                { TNonIntrinsic _ }
+  optional                    { TOptional _ }
+  pointer                     { TPointer _ }
+  save                        { TSave _ }
+  target                      { TTarget _ }
+  value                       { TValue _ }
+  volatile                    { TVolatile _ }
+  bind                        { TBind _ }
+  'c'                         { TC _ }
+  name                        { TName _ }
+  in                          { TIn _ }
+  out                         { TOut _ }
+  inout                       { TInOut _ }
+  data                        { TData _ }
+  namelist                    { TNamelist _ }
+  implicit                    { TImplicit _ }
+  equivalence                 { TEquivalence _ }
+  common                      { TCommon _ }
+  allocate                    { TAllocate _ }
+  deallocate                  { TDeallocate _ }
+  stat                        { TStat _ }
+  errmsg                      { TErrMsg _ }
+  source                      { TSource _ }
+  nullify                     { TNullify _ }
+  none                        { TNone _ }
+  goto                        { TGoto _ }
+  to                          { TTo _ }
+  continue                    { TContinue _ }
+  stop                        { TStop _ }
+  do                          { TDo _ }
+  enddo                       { TEndDo _ }
+  while                       { TWhile _ }
+  if                          { TIf _ }
+  then                        { TThen _ }
+  else                        { TElse _ }
+  elsif                       { TElsif _ }
+  endif                       { TEndIf _ }
+  case                        { TCase _ }
+  selectcase                  { TSelectCase _ }
+  endselect                   { TEndSelect _ }
+  associate                   { TAssociate _ }
+  endassociate                { TEndAssociate _ }
+  default                     { TDefault _ }
+  cycle                       { TCycle _ }
+  exit                        { TExit _ }
+  where                       { TWhere _ }
+  elsewhere                   { TElsewhere _ }
+  endwhere                    { TEndWhere _ }
+  type                        { TType _ }
+  endType                     { TEndType _ }
+  class                       { TClass _ }
+  enum                        { TEnum _ }
+  enumerator                  { TEnumerator _ }
+  endEnum                     { TEndEnum _ }
+  sequence                    { TSequence _ }
+  kind                        { TKind _ }
+  len                         { TLen _ }
+  integer                     { TInteger _ }
+  real                        { TReal _ }
+  doublePrecision             { TDoublePrecision _ }
+  logical                     { TLogical _ }
+  character                   { TCharacter _ }
+  complex                     { TComplex _ }
+  open                        { TOpen _ }
+  close                       { TClose _ }
+  read                        { TRead _ }
+  write                       { TWrite _ }
+  print                       { TPrint _ }
+  flush                       { TFlush _ }
+  unit                        { TUnit _ }
+  iostat                      { TIOStat _ }
+  iomsg                       { TIOMsg _ }
+  err                         { TErr _ }
+  backspace                   { TBackspace _ }
+  rewind                      { TRewind _ }
+  inquire                     { TInquire _ }
+  endfile                     { TEndfile _ }
+  format                      { TFormat _ }
+  blob                        { TBlob _ _ }
+  end                         { TEnd _ }
+  newline                     { TNewline _ }
+  forall                      { TForall _ }
+  endforall                   { TEndForall _ }
+-- Precedence of operators
+
+-- Level 6
+%left opCustom
+
+-- Level 5
+%left eqv neqv
+%left or
+%left and
+%right not
+
+-- Level 4
+%nonassoc '==' '!=' '>' '<' '>=' '<='
+%nonassoc RELATIONAL
+
+-- Level 3
+%left CONCAT
+
+-- Level 2
+%left '+' '-'
+%left '*' '/'
+%right SIGN
+%right '**'
+
+-- Level 1
+%right DEFINED_UNARY
+
+-- Level 0
+%left '%'
+
+%%
+
+maybe(p)
+: p           { Just $1 }
+| {- empty -} { Nothing }
+
+-- 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 = Fortran2003, miFilename = "" }) (reverse $1) }
+| {- empty -}   { ProgramFile (MetaInfo { miVersion = Fortran2003, miFilename = "" }) [] }
+
+PROGRAM_UNITS :: { [ ProgramUnit A0 ] }
+: PROGRAM_UNITS PROGRAM_UNIT MAYBE_NEWLINE { $2 : $1 }
+| PROGRAM_UNIT MAYBE_NEWLINE { [ $1 ] }
+
+PROGRAM_UNIT :: { ProgramUnit A0 }
+: program NAME NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS PROGRAM_END
+  {% do { unitNameCheck $6 $2;
+          return $ PUMain () (getTransSpan $1 $6) (Just $2) (reverse $4) $5 } }
+| module NAME NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS MODULE_END
+  {% do { unitNameCheck $6 $2;
+          return $ PUModule () (getTransSpan $1 $6) $2 (reverse $4) $5 } }
+| blockData NEWLINE BLOCKS BLOCK_DATA_END
+  { PUBlockData () (getTransSpan $1 $4) Nothing (reverse $3) }
+| blockData NAME NEWLINE BLOCKS BLOCK_DATA_END
+  {% do { unitNameCheck $5 $2;
+          return $ PUBlockData () (getTransSpan $1 $5) (Just $2) (reverse $4) } }
+| SUBPROGRAM_UNIT { $1 }
+
+MAYBE_SUBPROGRAM_UNITS :: { Maybe [ ProgramUnit A0 ] }
+: contains NEWLINE SUBPROGRAM_UNITS { Just $ reverse $3 }
+| {- Empty -} { Nothing }
+
+SUBPROGRAM_UNITS :: { [ ProgramUnit A0 ] }
+: SUBPROGRAM_UNITS SUBPROGRAM_UNIT NEWLINE { $2 : $1 }
+| {- EMPTY -} { [ ] }
+
+SUBPROGRAM_UNIT :: { ProgramUnit A0 }
+: PREFIXES function NAME MAYBE_ARGUMENTS FUNC_SUFFIX MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END
+  {% do { unitNameCheck $10 $3;
+          let (pfxs, typeSpec) = case partitionEithers $1 of
+                                   { (ps, t:_) -> (fromReverseList' ps, Just t)
+                                   ; (ps, [])  -> (fromReverseList' ps, Nothing) } in
+          let (sfx, result) = $5 in
+          let sfx' = fmap (\ s -> AList () (getSpan s) [s]) sfx in
+          let ss = if null $1 then getTransSpan $2 $10 else getTransSpan (reverse $1) $10 in
+          if validPrefixSuffix (pfxs, sfx') then
+            return $ PUFunction () ss typeSpec (pfxs, sfx') $3 $4 result (reverse $8) $9
+          else fail "Cannot specify elemental along with recursive and/or bind." } }
+| PREFIXES subroutine NAME MAYBE_ARGUMENTS SUBR_SUFFIX MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS SUBROUTINE_END
+  {% do { unitNameCheck $10 $3;
+          (pfxs, typeSpec) <- case partitionEithers $1 of
+                                { (ps, t:_) -> fail "Subroutines cannot have return types."
+                                ; (ps, [])  -> return (fromReverseList' ps, Nothing) };
+          let sfx' = fmap (\ s -> AList () (getSpan s) [s]) $5 in
+          let ss = if null $1 then getTransSpan $2 $10 else getTransSpan (reverse $1) $10 in
+          if validPrefixSuffix (pfxs, sfx') then
+            return $ PUSubroutine () ss (pfxs, sfx') $3 $4 (reverse $8) $9
+          else fail "Cannot specify elemental along with recursive and/or bind." } }
+| comment { let (TComment s c) = $1 in PUComment () s (Comment c) }
+
+-- (Fortran2003) R1227, Fortran95 (...)
+PREFIXES :: { [Either (Prefix A0) (TypeSpec A0)] }
+: PREFIXES PREFIX { $2:$1 }
+| {- EMPTY -}     { [] }
+
+-- (Fortran2003) R1228, Fortran95 (...)
+PREFIX :: { Either (Prefix A0) (TypeSpec A0) }
+: recursive { Left $ PfxRecursive () (getSpan $1) }
+| elemental { Left $ PfxElemental () (getSpan $1) }
+| pure      { Left $ PfxPure      () (getSpan $1) }
+| TYPE_SPEC { Right $1 }
+
+FUNC_SUFFIX :: { (Maybe (Suffix A0), Maybe (Expression A0)) }
+: SUFFIX RESULT { (Just $1, Just $2) }
+| RESULT SUFFIX { (Just $2, Just $1) }
+| SUFFIX        { (Just $1, Nothing) }
+| RESULT        { (Nothing, Just $1) }
+| {- empty -}   { (Nothing, Nothing) }
+
+SUBR_SUFFIX :: { Maybe (Suffix A0) }
+: SUFFIX        { Just $1 }
+| {- empty -}   { Nothing }
+
+-- (Fortran2003) R1229
+SUFFIX :: { Suffix A0 }
+-- (Fortran2003) R509
+: bind '(' 'c' ',' name '=' EXPRESSION ')' { SfxBind () (getTransSpan $1 $8) (Just $7) }
+| bind '(' 'c' ')'                         { SfxBind () (getTransSpan $1 $4) Nothing }
+
+MAYBE_ARGUMENTS :: { Maybe (AList Expression A0) }
+: '(' MAYBE_VARIABLES ')' { $2 }
+| {- Nothing -} { Nothing }
+
+RESULT :: { Expression A0 }
+: result '(' VARIABLE ')' { $3 }
+
+MAYBE_RESULT :: { Maybe (Expression A0) }
+: RESULT      { Just $1 }
+| {- empty -} { Nothing}
+
+PROGRAM_END :: { Token }
+: end { $1 } | endProgram { $1 } | endProgram id { $2 }
+MODULE_END :: { Token }
+: end { $1 } | endModule { $1 } | endModule id { $2 }
+FUNCTION_END :: { Token }
+: end { $1 } | endFunction { $1 } | endFunction id { $2 }
+SUBROUTINE_END :: { Token }
+: end { $1 } | endSubroutine { $1 } | endSubroutine id { $2 }
+BLOCK_DATA_END :: { Token }
+: end { $1 } | endBlockData { $1 } | endBlockData id { $2 }
+INTERFACE_END :: { Token }
+: end { $1 } | endInterface { $1 } | endInterface id { $2 }
+
+NAME :: { Name } : id { let (TId _ name) = $1 in name }
+
+IMPORT_NAME_LIST :: { [Expression A0] }
+: IMPORT_NAME_LIST ',' VARIABLE { $3 : $1 }
+| VARIABLE { [ $1 ] }
+
+BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] }
+
+BLOCK :: { Block A0 }
+: IF_BLOCK MAYBE_COMMENT NEWLINE { $1 }
+| CASE_BLOCK MAYBE_COMMENT NEWLINE { $1 }
+| ASSOCIATE_BLOCK MAYBE_COMMENT NEWLINE { $1 }
+| INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE
+  { BlStatement () (getTransSpan $1 $2) (Just $1) $2 }
+| STATEMENT MAYBE_COMMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 }
+| ABSTRACTP interface MAYBE_EXPRESSION MAYBE_COMMENT NEWLINE SUBPROGRAM_UNITS2 MODULE_PROCEDURES INTERFACE_END MAYBE_COMMENT NEWLINE
+  { BlInterface () (getTransSpan $2 $10) $3 $1 (reverse $6) (reverse $7) }
+| ABSTRACTP interface MAYBE_EXPRESSION MAYBE_COMMENT NEWLINE MODULE_PROCEDURES INTERFACE_END MAYBE_COMMENT NEWLINE
+  { BlInterface () (getTransSpan $2 $9) $3 $1 [ ] (reverse $6) }
+| COMMENT_BLOCK { $1 }
+
+IF_BLOCK :: { Block A0 }
+:                        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
+  { let { startSpan = getSpan $1;
+          (endSpan, conds, blocks, endLabel) = $9;
+          span = getTransSpan startSpan endSpan }
+     in BlIf () span Nothing Nothing ((Just $3):conds) ((reverse $8):blocks) endLabel }
+|                 id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
+  { let { TId startSpan startName = $1;
+          (endSpan, conds, blocks, endLabel) = $11;
+          span = getTransSpan startSpan endSpan }
+     in BlIf () span Nothing (Just startName) ((Just $5):conds) ((reverse $10):blocks) endLabel }
+| INTEGER_LITERAL        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
+  { let { startSpan = getSpan $1;
+          startLabel = Just $1;
+          (endSpan, conds, blocks, endLabel) = $10;
+          span = getTransSpan startSpan endSpan }
+     in BlIf () span startLabel Nothing ((Just $4):conds) ((reverse $9):blocks) endLabel }
+| INTEGER_LITERAL id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
+  { let { startSpan = getSpan $1;
+          startLabel = Just $1;
+          TId _ startName = $2;
+          (endSpan, conds, blocks, endLabel) = $12;
+          span = getTransSpan startSpan endSpan }
+     in BlIf () span startLabel (Just startName) ((Just $6):conds) ((reverse $11):blocks) endLabel }
+
+ELSE_BLOCKS :: { (SrcSpan, [Maybe (Expression A0)], [[Block A0]], Maybe (Expression A0)) }
+: maybe(INTEGER_LITERAL) elsif '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
+  { let (endSpan, conds, blocks, endLabel) = $10
+    in (endSpan, Just $4 : conds, reverse $9 : blocks, endLabel) }
+| maybe(INTEGER_LITERAL) else                          MAYBE_COMMENT NEWLINE BLOCKS END_IF
+  { let (endSpan, endLabel) = $6
+    in (endSpan, [Nothing], [reverse $5], endLabel) }
+| END_IF { let (endSpan, endLabel) = $1 in (endSpan, [], [], endLabel) }
+
+END_IF :: { (SrcSpan, Maybe (Expression A0)) }
+: endif { (getSpan $1, Nothing) }
+| endif id { (getSpan $2, Nothing) }
+| INTEGER_LITERAL endif { (getSpan $2, Just $1) }
+| INTEGER_LITERAL endif id { (getSpan $3, Just $1) }
+
+CASE_BLOCK :: { Block A0 }
+:                        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
+  { let { (caseRanges, blocks, endLabel, endSpan) = $7;
+          span = getTransSpan $1 endSpan }
+    in BlCase () span Nothing Nothing $3 caseRanges blocks endLabel }
+| INTEGER_LITERAL        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
+  { let { (caseRanges, blocks, endLabel, endSpan) = $8;
+          span = getTransSpan $1 endSpan }
+    in BlCase () span (Just $1) Nothing $4 caseRanges blocks endLabel }
+|                 id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
+  { let { (caseRanges, blocks, endLabel, endSpan) = $9;
+          TId s startName = $1;
+          span = getTransSpan s endSpan }
+    in BlCase () span Nothing (Just startName) $5 caseRanges blocks endLabel }
+| INTEGER_LITERAL id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
+  { let { (caseRanges, blocks, endLabel, endSpan) = $10;
+          TId s startName = $2;
+          span = getTransSpan s endSpan }
+    in BlCase () span (Just $1) (Just startName) $6 caseRanges blocks endLabel }
+
+-- We store line comments as statements, but this raises an issue: we have
+-- nowhere to place comments after a SELECT CASE but before a CASE. So we drop
+-- them. The inner CASES_ rule does /not/ use this, because comments can always
+-- be parsed as belonging to to the above CASE block.
+CASES :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }
+: COMMENT_BLOCK CASES_ { $2 }
+|               CASES_ { $1 }
+
+CASES_ :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }
+: maybe(INTEGER_LITERAL) case '(' INDICIES ')' MAYBE_COMMENT NEWLINE BLOCKS CASES_
+  { let (scrutinees, blocks, endLabel, endSpan) = $9
+    in  (Just (fromReverseList $4) : scrutinees, reverse $8 : blocks, endLabel, endSpan) }
+| maybe(INTEGER_LITERAL) case default          MAYBE_COMMENT NEWLINE BLOCKS END_SELECT
+  { let (endLabel, endSpan) = $7
+    in ([Nothing], [$6], endLabel, endSpan) }
+| END_SELECT
+  { let (endLabel, endSpan) = $1
+    in ([], [], endLabel, endSpan) }
+
+END_SELECT :: { (Maybe (Expression A0), SrcSpan) }
+: maybe(INTEGER_LITERAL) endselect maybe(id)
+  { ($1, maybe (getSpan $2) getSpan $3) }
+
+ASSOCIATE_BLOCK :: { Block A0 }
+: INTEGER_LITERAL id ':' associate '(' ABBREVIATIONS ')' MAYBE_COMMENT NEWLINE BLOCKS END_ASSOCIATE
+  { let { startSpan  = getSpan $1;
+          mLabel     = Just $1;
+          TId _ name = $2;
+          mName      = Just name;
+          abbrevs    = fromReverseList $6;
+          body       = reverse $10;
+          (endSpan, mEndLabel) = $11;
+          span       = getTransSpan startSpan endSpan }
+     in BlAssociate () span mLabel mName abbrevs body mEndLabel }
+| INTEGER_LITERAL        associate '(' ABBREVIATIONS ')' MAYBE_COMMENT NEWLINE BLOCKS END_ASSOCIATE
+  { let { startSpan  = getSpan $1;
+          mLabel     = Just $1;
+          mName      = Nothing;
+          abbrevs    = fromReverseList $4;
+          body       = reverse $8;
+          (endSpan, mEndLabel) = $9;
+          span       = getTransSpan startSpan endSpan }
+     in BlAssociate () span mLabel mName abbrevs body mEndLabel }
+|                 id ':' associate '(' ABBREVIATIONS ')' MAYBE_COMMENT NEWLINE BLOCKS END_ASSOCIATE
+  { let { startSpan  = getSpan $1;
+          TId _ name = $1;
+          mLabel     = Nothing;
+          mName      = Just name;
+          abbrevs    = fromReverseList $5;
+          body       = reverse $9;
+          (endSpan, mEndLabel) = $10;
+          span       = getTransSpan startSpan endSpan }
+     in BlAssociate () span mLabel mName abbrevs body mEndLabel }
+|                        associate '(' ABBREVIATIONS ')' MAYBE_COMMENT NEWLINE BLOCKS END_ASSOCIATE
+  { let { startSpan  = getSpan $1;
+          mLabel     = Nothing;
+          mName      = Nothing;
+          abbrevs    = fromReverseList $3;
+          body       = reverse $7;
+          (endSpan, mEndLabel) = $8;
+          span       = getTransSpan startSpan endSpan }
+     in BlAssociate () span mLabel mName abbrevs body mEndLabel }
+
+-- TODO: Copied verbatim from END_IF. Should attempt to functionalise.
+END_ASSOCIATE :: { (SrcSpan, Maybe (Expression A0)) }
+: endassociate { (getSpan $1, Nothing) }
+| endassociate id { (getSpan $2, Nothing) }
+| INTEGER_LITERAL endassociate { (getSpan $2, Just $1) }
+| INTEGER_LITERAL endassociate id { (getSpan $3, Just $1) }
+
+-- (var (ExpValue (ValVariable)), assoc. expr)
+ABBREVIATIONS :: { [(ATuple Expression Expression A0)] }
+: ABBREVIATIONS ',' ABBREVIATION { $3 : $1 }
+| ABBREVIATION { [ $1 ] }
+
+ABBREVIATION :: { ATuple Expression Expression A0 }
+: VARIABLE '=>' EXPRESSION { ATuple () (getTransSpan $1 $3) $1 $3 }
+
+ABSTRACTP :: { Bool }
+: abstract { True }
+| {- EMPTY -} { False }
+
+MAYBE_EXPRESSION :: { Maybe (Expression A0) }
+: EXPRESSION { Just $1 }
+| {- EMPTY -} { Nothing }
+
+MAYBE_COMMENT :: { Maybe Token }
+: comment { Just $1 }
+| {- EMPTY -} { Nothing }
+
+SUBPROGRAM_UNITS2 :: { [ ProgramUnit A0 ] }
+: SUBPROGRAM_UNITS SUBPROGRAM_UNIT NEWLINE { $2 : $1 }
+
+MODULE_PROCEDURES :: { [ Block A0 ] }
+: MODULE_PROCEDURES MODULE_PROCEDURE { $2 : $1 }
+| MODULE_PROCEDURES MODULE_PROCEDURE COMMENT_BLOCK { $3 : $2 : $1 }
+| { [ ] }
+
+MODULE_PROCEDURE :: { Block A0 }
+: moduleProcedure VARIABLES MAYBE_COMMENT NEWLINE
+  { let { al = fromReverseList $2;
+          st = StModuleProcedure () (getTransSpan $1 al) (fromReverseList $2) }
+    in BlStatement () (getTransSpan $1 $4) Nothing st }
+
+COMMENT_BLOCK :: { Block A0 }
+: 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 }
+| newline { $1 }
+| ';' { $1 }
+
+STATEMENT :: { Statement A0 }
+: NONEXECUTABLE_STATEMENT { $1 }
+| EXECUTABLE_STATEMENT { $1 }
+
+EXPRESSION_ASSIGNMENT_STATEMENT :: { Statement A0 }
+: DATA_REF '=' EXPRESSION { StExpressionAssign () (getTransSpan $1 $3) $1 $3 }
+
+NONEXECUTABLE_STATEMENT :: { Statement A0 }
+: DECLARATION_STATEMENT { $1 }
+| intent '(' INTENT_CHOICE ')' MAYBE_DCOLON EXPRESSION_LIST
+  { let expAList = fromReverseList $6
+    in StIntent () (getTransSpan $1 expAList) $3 expAList }
+| optional MAYBE_DCOLON EXPRESSION_LIST
+  { let expAList = fromReverseList $3
+    in StOptional () (getTransSpan $1 expAList) expAList }
+| public MAYBE_DCOLON EXPRESSION_LIST
+  { let expAList = fromReverseList $3
+    in StPublic () (getTransSpan $1 expAList) (Just expAList) }
+| public { StPublic () (getSpan $1) Nothing }
+| private MAYBE_DCOLON EXPRESSION_LIST
+  { let expAList = fromReverseList $3
+    in StPrivate () (getTransSpan $1 expAList) (Just expAList) }
+| private { StPrivate () (getSpan $1) Nothing }
+| protected MAYBE_DCOLON EXPRESSION_LIST
+  { let expAList = fromReverseList $3
+    in StProtected () (getTransSpan $1 expAList) (Just expAList) }
+| protected { StProtected () (getSpan $1) Nothing }
+| save MAYBE_DCOLON SAVE_ARGS
+  { let saveAList = (fromReverseList $3)
+    in StSave () (getTransSpan $1 saveAList) (Just saveAList) }
+| save { StSave () (getSpan $1) Nothing }
+| procedure '(' MAYBE_PROC_INTERFACE ')' ',' ATTRIBUTE_SPEC '::' PROC_DECLS
+  { let declAList = fromReverseList $8
+    in StProcedure () (getTransSpan $1 $8) $3 (Just $6) declAList }
+| procedure '(' MAYBE_PROC_INTERFACE ')' MAYBE_DCOLON PROC_DECLS
+  { let declAList = fromReverseList $6
+    in StProcedure () (getTransSpan $1 $6) $3 Nothing declAList }
+| dimension MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
+  { let declAList = fromReverseList $3
+    in StDimension () (getTransSpan $1 declAList) declAList }
+| allocatable MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
+  { let declAList = fromReverseList $3
+    in StAllocatable () (getTransSpan $1 declAList) declAList }
+| asynchronous MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
+  { let declAList = fromReverseList $3
+    in StAsynchronous () (getTransSpan $1 declAList) declAList }
+| pointer MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
+  { let declAList = fromReverseList $3
+    in StPointer () (getTransSpan $1 declAList) declAList }
+| target MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
+  { let declAList = fromReverseList $3
+    in StTarget () (getTransSpan $1 declAList) declAList }
+| value MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
+  { let declAList = fromReverseList $3
+    in StValue () (getTransSpan $1 declAList) declAList }
+| volatile MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
+  { let declAList = fromReverseList $3
+    in StVolatile () (getTransSpan $1 declAList) declAList }
+| data cDATA DATA_GROUPS cPOP
+  { let dataAList = fromReverseList $3
+    in StData () (getTransSpan $1 dataAList) dataAList }
+| parameter '(' PARAMETER_ASSIGNMENTS ')'
+  { let declAList = fromReverseList $3
+    in StParameter () (getTransSpan $1 $4) declAList }
+| implicit none { StImplicit () (getTransSpan $1 $2) Nothing }
+| implicit cIMPLICIT IMP_LISTS cPOP
+  { let impAList = fromReverseList $3
+    in StImplicit () (getTransSpan $1 impAList) $ Just $ impAList }
+| namelist cNAMELIST NAMELISTS cPOP
+  { let nameALists = fromReverseList $3
+    in StNamelist () (getTransSpan $1 nameALists) nameALists }
+| equivalence EQUIVALENCE_GROUPS
+  { let eqALists = fromReverseList $2
+    in StEquivalence () (getTransSpan $1 eqALists) eqALists }
+| common cCOMMON COMMON_GROUPS cPOP
+  { let commonAList = fromReverseList $3
+    in StCommon () (getTransSpan $1 commonAList) commonAList }
+| external MAYBE_DCOLON VARIABLES
+  { let alist = fromReverseList $3
+    in StExternal () (getTransSpan $1 alist) alist }
+| intrinsic MAYBE_DCOLON VARIABLES
+  { let alist = fromReverseList $3
+    in StIntrinsic () (getTransSpan $1 alist) alist }
+| use MODULE_NATURE VARIABLE { StUse () (getTransSpan $1 $3) $3 $2 Permissive Nothing }
+| use MODULE_NATURE VARIABLE ',' RENAME_LIST
+  { let alist = fromReverseList $5
+    in StUse () (getTransSpan $1 alist) $3 $2 Permissive (Just alist) }
+| use MODULE_NATURE VARIABLE ',' only ':' MAYBE_RENAME_LIST
+  { StUse () (getTransSpan $1 ($6, $7)) $3 $2 Exclusive $7 }
+| entry VARIABLE MAYBE_RESULT
+  { StEntry () (getTransSpan $1 $ maybe (getSpan $2) getSpan $3) $2 Nothing $3 }
+| entry VARIABLE '(' ')' MAYBE_RESULT
+  { StEntry () (getTransSpan $1 $ maybe (getSpan $4) getSpan $5) $2 Nothing $5 }
+| entry VARIABLE '(' VARIABLES ')' MAYBE_RESULT
+  { StEntry () (getTransSpan $1 $ maybe (getSpan $5) getSpan $6) $2 (Just $ fromReverseList $4) $6 }
+| sequence { StSequence () (getSpan $1) }
+| type ATTRIBUTE_LIST '::' id
+  { let { TId span id = $4;
+          alist = if null $2 then Nothing else (Just . fromReverseList) $2 }
+    in StType () (getTransSpan $1 span) alist id }
+| type id
+  { let TId span id = $2 in StType () (getTransSpan $1 span) Nothing id }
+| endType { StEndType () (getSpan $1) Nothing }
+| endType id
+  { let TId span id = $2 in StEndType () (getTransSpan $1 span) (Just id) }
+-- R461-R464
+| enum ',' bind '(' 'c' ')' { StEnum () (getTransSpan $1 $6) }
+| enumerator MAYBE_DCOLON ENUMERATOR_LIST { StEnumerator () (getTransSpan $1 $3) (fromReverseList $3) }
+| endEnum { StEndEnum () (getSpan $1) }
+| include STRING { StInclude () (getTransSpan $1 $2) $2 Nothing }
+-- R1209
+| import '::' IMPORT_NAME_LIST { StImport () (getTransSpan $1 $3) (fromReverseList $3) }
+| import IMPORT_NAME_LIST      { StImport () (getTransSpan $1 $2) (fromReverseList $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 }
+
+ENUMERATOR_LIST :: { [Declarator A0] }
+: ENUMERATOR_LIST ',' ENUMERATOR { $3:$1 }
+| ENUMERATOR { [$1] }
+
+-- R463
+ENUMERATOR :: { Declarator A0 }
+: PARAMETER_ASSIGNMENT { $1 }
+| VARIABLE { Declarator () (getSpan $1) $1 ScalarDecl Nothing Nothing }
+
+MAYBE_PROC_INTERFACE :: { Maybe (ProcInterface A0) }
+: TYPE_SPEC             { Just $ ProcInterfaceType () (getSpan $1) $1 }
+| VARIABLE              { Just $ ProcInterfaceName () (getSpan $1) $1 }
+| {- EMPTY -}           { Nothing }
+
+PROC_DECLS :: { [ProcDecl A0] }
+: PROC_DECLS ',' PROC_DECL { $3 : $1 }
+| PROC_DECL                { [ $1 ]  }
+
+PROC_DECL :: { ProcDecl A0 }
+: VARIABLE '=>' EXPRESSION { ProcDecl () (getTransSpan $1 $3) $1 (Just $3) }
+| VARIABLE                 { ProcDecl () (getSpan $1) $1 Nothing }
+
+MODULE_NATURE :: { Maybe ModuleNature }
+: ',' intrinsic    '::' { Just ModIntrinsic }
+| ',' nonintrinsic '::' { Just ModNonIntrinsic }
+| '::'                  { Nothing }
+| {- empty -}           { Nothing }
+
+EXECUTABLE_STATEMENT :: { Statement A0 }
+: allocate '(' MAYBE_TYPE_SPEC DATA_REFS MAYBE_ALLOC_OPT_LIST ')'
+  { StAllocate () (getTransSpan $1 $6) $3 (fromReverseList $4) $5 }
+| nullify '(' DATA_REFS ')'
+  { StNullify () (getTransSpan $1 $4) (fromReverseList $3) }
+| deallocate '(' DATA_REFS MAYBE_ALLOC_OPT_LIST ')'
+  { StDeallocate () (getTransSpan $1 $5) (fromReverseList $3) $4 }
+| EXPRESSION_ASSIGNMENT_STATEMENT { $1 }
+| POINTER_ASSIGNMENT_STMT { $1 }
+| where '(' EXPRESSION ')' EXPRESSION_ASSIGNMENT_STATEMENT
+  { StWhere () (getTransSpan $1 $5) $3 $5 }
+| id ':' where '(' EXPRESSION ')' { let (TId s1 id) = $1 in StWhereConstruct () (getTransSpan $1 $6) (Just id) $5 }
+| where '(' EXPRESSION ')' { StWhereConstruct () (getTransSpan $1 $4) Nothing $3 }
+| elsewhere '(' EXPRESSION ')' id { let TId _ id = $5 in StElsewhere () (getTransSpan $1 $5) (Just id) (Just $3) }
+| elsewhere '(' EXPRESSION ')' { StElsewhere () (getTransSpan $1 $4) Nothing (Just $3) }
+| elsewhere id { let TId _ id = $2 in StElsewhere () (getTransSpan $1 $2) (Just id) Nothing }
+| elsewhere { StElsewhere () (getSpan $1) Nothing Nothing }
+| endwhere id { let TId _ id = $2 in StEndWhere () (getTransSpan $1 $2) (Just id) }
+| endwhere { StEndWhere () (getSpan $1) Nothing }
+| if '(' EXPRESSION ')' INTEGER_LITERAL ',' INTEGER_LITERAL ',' INTEGER_LITERAL
+  { StIfArithmetic () (getTransSpan $1 $9) $3 $5 $7 $9 }
+| do { StDo () (getSpan $1) Nothing Nothing Nothing }
+| id ':' do
+  { let TId s id = $1
+    in StDo () (getTransSpan s $3) (Just id) Nothing Nothing }
+| do INTEGER_LITERAL MAYBE_COMMA DO_SPECIFICATION
+  { StDo () (getTransSpan $1 $4) Nothing (Just $2) (Just $4) }
+| do DO_SPECIFICATION { StDo () (getTransSpan $1 $2) Nothing Nothing (Just $2) }
+| id ':' do DO_SPECIFICATION
+  { let TId s id = $1
+    in StDo () (getTransSpan s $4) (Just id) Nothing (Just $4) }
+| do INTEGER_LITERAL MAYBE_COMMA while '(' EXPRESSION ')'
+  { StDoWhile () (getTransSpan $1 $7) Nothing (Just $2) $6 }
+| do while '(' EXPRESSION ')'
+  { StDoWhile () (getTransSpan $1 $5) Nothing Nothing $4 }
+| id ':' do while '(' EXPRESSION ')'
+  { let TId s id = $1
+    in StDoWhile () (getTransSpan s $7) (Just id) Nothing $6 }
+| enddo { StEnddo () (getSpan $1) Nothing }
+| enddo id
+  { let TId s id = $2 in StEnddo () (getTransSpan $1 s) (Just id) }
+| cycle { StCycle () (getSpan $1) Nothing }
+| cycle VARIABLE { StCycle () (getTransSpan $1 $2) (Just $2) }
+| exit { StExit () (getSpan $1) Nothing }
+| exit VARIABLE { StExit () (getTransSpan $1 $2) (Just $2) }
+-- GO TO label
+| goto INTEGER_LITERAL { StGotoUnconditional () (getTransSpan $1 $2) $2 }
+-- GO TO label-list [,] scalar-int-expression
+| goto '(' INTEGERS ')' MAYBE_COMMA EXPRESSION
+  { StGotoComputed () (getTransSpan $1 $6) (fromReverseList $3) $6 }
+| continue { StContinue () (getSpan $1) }
+| stop { StStop () (getSpan $1) Nothing }
+| stop EXPRESSION { StStop () (getTransSpan $1 $2) (Just $2) }
+| if '(' EXPRESSION ')' EXECUTABLE_STATEMENT
+  { StIfLogical () (getTransSpan $1 $5) $3 $5 }
+| read CILIST IN_IOLIST
+  { let alist = fromReverseList $3
+    in StRead () (getTransSpan $1 alist) $2 (Just alist) }
+| read CILIST { StRead () (getTransSpan $1 $2) $2 Nothing }
+| read FORMAT_ID ',' IN_IOLIST
+  { let alist = fromReverseList $4
+    in StRead2 () (getTransSpan $1 alist) $2 (Just alist) }
+| read FORMAT_ID { StRead2 () (getTransSpan $1 $2) $2 Nothing }
+| write CILIST OUT_IOLIST
+  { let alist = fromReverseList $3
+    in StWrite () (getTransSpan $1 alist) $2 (Just alist) }
+| write CILIST { StWrite () (getTransSpan $1 $2) $2 Nothing }
+| print FORMAT_ID ',' OUT_IOLIST
+  { let alist = fromReverseList $4
+    in StPrint () (getTransSpan $1 alist) $2 (Just alist) }
+| print FORMAT_ID { StPrint () (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 }
+| flush INTEGER_LITERAL { StFlush () (getTransSpan $1 $2) (AList () (getSpan $2) [FSUnit () (getSpan $2) $2]) }
+| flush '(' FLUSH_SPEC_LIST ')' { StFlush () (getTransSpan $1 $4) (fromReverseList $3) }
+| call VARIABLE { StCall () (getTransSpan $1 $2) $2 Nothing }
+| call VARIABLE '(' ')' { StCall () (getTransSpan $1 $4) $2 Nothing }
+| call VARIABLE '(' ARGUMENTS ')'
+  { let alist = fromReverseList $4
+    in StCall () (getTransSpan $1 $5) $2 (Just alist) }
+| return { StReturn () (getSpan $1) Nothing }
+| return EXPRESSION { StReturn () (getTransSpan $1 $2) (Just $2) }
+| FORALL { $1 }
+| END_FORALL { $1 }
+
+ARGUMENTS :: { [ Argument A0 ] }
+: ARGUMENTS ',' ARGUMENT { $3 : $1 }
+| ARGUMENT { [ $1 ] }
+
+ARGUMENT :: { Argument A0 }
+: 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) }
+
+MAYBE_RENAME_LIST :: { Maybe (AList Use A0) }
+: RENAME_LIST { Just $ fromReverseList $1 }
+| {- empty -} { Nothing }
+
+RENAME_LIST :: { [ Use A0 ] }
+: RENAME_LIST ',' RENAME { $3 : $1 }
+| RENAME { [ $1 ] }
+
+RENAME :: { Use A0  }
+: VARIABLE '=>' VARIABLE { UseRename () (getTransSpan $1 $3) $1 $3 }
+| VARIABLE { UseID () (getSpan $1) $1 }
+| operator '(' opCustom ')'
+  { let TOpCustom ss op = $3
+    in UseID () (getTransSpan $1 $4) (ExpValue () ss (ValOperator op)) }
+| assignment { UseID () (getSpan $1) (ExpValue () (getSpan $1) ValAssignment) }
+
+MAYBE_DCOLON :: { () } : '::' { () } | {- EMPTY -} { () }
+
+FORMAT_ID :: { Expression A0 }
+: FORMAT_ID '/' '/' FORMAT_ID %prec CONCAT
+  { ExpBinary () (getTransSpan $1 $4) Concatenation $1 $4 }
+| INTEGER_LITERAL { $1 }
+| STRING { $1 }
+| DATA_REF { $1 }
+| '*' { ExpValue () (getSpan $1) ValStar }
+
+UNIT :: { Expression A0 }
+: INTEGER_LITERAL { $1 }
+| DATA_REF { $1 }
+| '*' { ExpValue () (getSpan $1) ValStar }
+
+{- R928 -}
+FLUSH_SPEC_LIST :: { [ FlushSpec A0 ] }
+: FLUSH_SPEC_LIST ',' FLUSH_SPEC { $3 : $1 }
+| FLUSH_SPEC { [ $1 ] }
+
+{- R928 -}
+FLUSH_SPEC :: { FlushSpec A0 }
+: EXPRESSION { FSUnit () (getSpan $1) $1 }
+| unit '=' EXPRESSION   { FSUnit () (getTransSpan $1 $3) $3 }
+| iostat '=' EXPRESSION { FSIOStat () (getTransSpan $1 $3) $3 }
+| iomsg '=' EXPRESSION  { FSIOMsg () (getTransSpan $1 $3) $3 }
+| err '=' EXPRESSION    { FSErr () (getTransSpan $1 $3) $3 }
+
+CILIST :: { AList ControlPair A0 }
+: '(' CILIST_ELEMENT ',' FORMAT_ID ',' CILIST_PAIRS ')'
+  { let { cp1 = ControlPair () (getSpan $2) Nothing $2;
+          cp2 = ControlPair () (getSpan $4) Nothing $4;
+          tail = fromReverseList $6 }
+    in setSpan (getTransSpan $1 $7) $ cp1 `aCons` cp2 `aCons` tail }
+| '(' CILIST_ELEMENT ',' FORMAT_ID ')'
+  { let { cp1 = ControlPair () (getSpan $2) Nothing $2;
+          cp2 = ControlPair () (getSpan $4) Nothing $4 }
+    in AList () (getTransSpan $1 $5) [ cp1,  cp2 ] }
+| '(' CILIST_ELEMENT ',' CILIST_PAIRS ')'
+  { let { cp1 = ControlPair () (getSpan $2) Nothing $2;
+          tail = fromReverseList $4 }
+    in setSpan (getTransSpan $1 $5) $ cp1 `aCons` tail }
+| '(' CILIST_ELEMENT ')'
+  { let cp1 = ControlPair () (getSpan $2) Nothing $2
+    in AList () (getTransSpan $1 $3) [ cp1 ] }
+| '(' CILIST_PAIRS ')' { fromReverseList $2 }
+
+CILIST_PAIRS :: { [ ControlPair A0 ] }
+: CILIST_PAIRS ',' CILIST_PAIR { $3 : $1 }
+| CILIST_PAIR { [ $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 SIGN
+  { 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 }
+| 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 }
+| opCustom CI_EXPRESSION %prec DEFINED_UNARY
+  { let TOpCustom span str = $1
+    in ExpUnary () (getTransSpan span $2) (UnCustom str) $2 }
+| CI_EXPRESSION opCustom CI_EXPRESSION
+  { let TOpCustom _ str = $2
+    in ExpBinary () (getTransSpan $1 $3) (BinCustom str) $1 $3 }
+| '(' CI_EXPRESSION ')' { setSpan (getTransSpan $1 $3) $2 }
+| INTEGER_LITERAL { $1 }
+| LOGICAL_LITERAL { $1 }
+| STRING { $1 }
+| DATA_REF { $1 }
+
+MAYBE_ALLOC_OPT_LIST :: { Maybe (AList AllocOpt A0) }
+: ',' ALLOC_OPT_LIST { Just $ fromReverseList $2 }
+| {- empty -}        { Nothing }
+
+ALLOC_OPT_LIST :: { [ AllocOpt A0 ] }
+: ALLOC_OPT_LIST ',' ALLOC_OPT { $3 : $1 }
+| ALLOC_OPT                    { [ $1 ] }
+
+{- R624 -}
+ALLOC_OPT :: { AllocOpt A0 }
+: stat '=' EXPRESSION   { AOStat () (getTransSpan $1 $3) $3 }
+| errmsg '=' EXPRESSION { AOErrMsg () (getTransSpan $1 $3) $3 }
+| source '=' EXPRESSION { AOSource () (getTransSpan $1 $3) $3 }
+
+IN_IOLIST :: { [ Expression A0 ] }
+: IN_IOLIST ',' IN_IO_ELEMENT { $3 : $1}
+| IN_IO_ELEMENT { [ $1 ] }
+
+IN_IO_ELEMENT :: { Expression A0 }
+: DATA_REF { $1 }
+| '(' IN_IOLIST ',' DO_SPECIFICATION ')'
+  { ExpImpliedDo () (getTransSpan $1 $5) (fromReverseList $2) $4 }
+
+OUT_IOLIST :: { [ Expression A0 ] }
+: OUT_IOLIST ',' EXPRESSION { $3 : $1}
+| EXPRESSION { [ $1 ] }
+
+COMMON_GROUPS :: { [ CommonGroup A0 ] }
+: COMMON_GROUPS COMMON_GROUP { $2 : $1 }
+| COMMON_GROUPS ',2' COMMON_GROUP { $3 : $1 }
+| INIT_COMMON_GROUP { [ $1 ] }
+
+COMMON_GROUP :: { CommonGroup A0 }
+: COMMON_NAME UNINITIALIZED_DECLARATOR_LIST
+  { let alist = fromReverseList $2
+    in CommonGroup () (getTransSpan $1 alist) (Just $1) alist }
+| '/' '/' UNINITIALIZED_DECLARATOR_LIST
+  { let alist = fromReverseList $3
+    in CommonGroup () (getTransSpan $1 alist) Nothing alist }
+
+INIT_COMMON_GROUP :: { CommonGroup A0 }
+: COMMON_NAME UNINITIALIZED_DECLARATOR_LIST
+  { let alist = fromReverseList $2
+    in CommonGroup () (getTransSpan $1 alist) (Just $1) alist }
+| '/' '/' UNINITIALIZED_DECLARATOR_LIST
+  { let alist = fromReverseList $3
+    in CommonGroup () (getTransSpan $1 alist) Nothing alist }
+| UNINITIALIZED_DECLARATOR_LIST
+  { let alist = fromReverseList $1
+    in CommonGroup () (getSpan alist) Nothing alist }
+
+EQUIVALENCE_GROUPS :: { [ AList Expression A0 ] }
+: EQUIVALENCE_GROUPS ',' '(' PART_REFS ')'
+  { setSpan (getTransSpan $3 $5) (fromReverseList $4) : $1 }
+| '(' PART_REFS ')'
+  { [ setSpan (getTransSpan $1 $3) (fromReverseList $2) ] }
+
+NAMELISTS :: { [ Namelist A0 ] }
+: NAMELISTS NAMELIST { $2 : $1 }
+| NAMELISTS ',2' NAMELIST { $3 : $1 }
+| NAMELIST { [ $1 ] }
+
+NAMELIST :: { Namelist A0 }
+: '/' VARIABLE '/' VARIABLES
+  { Namelist () (getTransSpan $1 $4) $2 $ fromReverseList $4 }
+
+MAYBE_VARIABLES :: { Maybe (AList Expression A0) }
+: VARIABLES { Just $ fromReverseList $1 } | {- EMPTY -} { Nothing }
+
+VARIABLES :: { [ Expression A0 ] }
+: VARIABLES ',' VARIABLE { $3 : $1 }
+| VARIABLE { [ $1 ] }
+
+IMP_LISTS :: { [ ImpList A0 ] }
+: IMP_LISTS ',' IMP_LIST { $3 : $1 }
+| IMP_LIST { [ $1 ] }
+
+IMP_LIST :: { ImpList A0 }
+: TYPE_SPEC '(2' 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
+             }
+
+PARAMETER_ASSIGNMENTS :: { [ Declarator A0 ] }
+: PARAMETER_ASSIGNMENTS ',' PARAMETER_ASSIGNMENT { $3 : $1 }
+| PARAMETER_ASSIGNMENT { [ $1 ] }
+
+PARAMETER_ASSIGNMENT :: { Declarator A0 }
+: VARIABLE '=' EXPRESSION
+  { Declarator () (getTransSpan $1 $3) $1 ScalarDecl Nothing (Just $3) }
+
+DECLARATION_STATEMENT :: { Statement A0 }
+: TYPE_SPEC ATTRIBUTE_LIST '::' INITIALIZED_DECLARATOR_LIST
+  { let { mAttrAList = if null $2 then Nothing else Just $ fromReverseList $2;
+          declAList = fromReverseList $4 }
+    in StDeclaration () (getTransSpan $1 declAList) $1 mAttrAList declAList }
+| TYPE_SPEC INITIALIZED_DECLARATOR_LIST
+  { let { declAList = fromReverseList $2 }
+    in StDeclaration () (getTransSpan $1 declAList) $1 Nothing declAList }
+
+ATTRIBUTE_LIST :: { [ Attribute A0 ] }
+: ATTRIBUTE_LIST ',' ATTRIBUTE_SPEC { $3 : $1 }
+| {- EMPTY -} { [ ] }
+
+ATTRIBUTE_SPEC :: { Attribute A0 }
+: public { AttrPublic () (getSpan $1) }
+| private { AttrPrivate () (getSpan $1) }
+| protected { AttrProtected () (getSpan $1) }
+| allocatable { AttrAllocatable () (getSpan $1) }
+| asynchronous { AttrAsynchronous () (getSpan $1) }
+| dimension '(' DIMENSION_DECLARATORS ')'
+  { AttrDimension () (getTransSpan $1 $4) (aReverse $3) }
+| external { AttrExternal () (getSpan $1) }
+| intent '(' INTENT_CHOICE ')' { AttrIntent () (getTransSpan $1 $4) $3 }
+| intrinsic { AttrIntrinsic () (getSpan $1) }
+| optional { AttrOptional () (getSpan $1) }
+| pointer { AttrPointer () (getSpan $1) }
+| parameter { AttrParameter () (getSpan $1) }
+| save { AttrSave () (getSpan $1) }
+| target { AttrTarget () (getSpan $1) }
+| value { AttrValue () (getSpan $1) }
+| volatile { AttrVolatile () (getSpan $1) }
+| SUFFIX { AttrSuffix () (getSpan $1) $1 }
+
+INTENT_CHOICE :: { Intent } : in { In } | out { Out } | inout { InOut }
+
+DATA_GROUPS :: { [ DataGroup A0 ] }
+: DATA_GROUPS MAYBE_COMMA DATA_LIST slash EXPRESSION_LIST slash
+  { let { nameAList = fromReverseList $3;
+          dataAList = fromReverseList $5 }
+    in DataGroup () (getTransSpan nameAList $6) nameAList dataAList : $1 }
+| DATA_LIST slash EXPRESSION_LIST slash
+  { let { nameAList = fromReverseList $1;
+          dataAList = fromReverseList $3 }
+    in [ DataGroup () (getTransSpan nameAList $4) nameAList dataAList ] }
+
+MAYBE_COMMA :: { () } : ',' { () } | {- EMPTY -} { () }
+
+DATA_LIST :: { [ Expression A0 ] }
+: DATA_LIST ',' DATA_ELEMENT { $3 : $1 }
+| DATA_ELEMENT { [ $1 ] }
+
+DATA_ELEMENT :: { Expression A0 }
+: DATA_REF { $1 } | IMPLIED_DO { $1 }
+
+SAVE_ARGS :: { [ Expression A0 ] }
+: SAVE_ARGS ',' SAVE_ARG { $3 : $1 } | SAVE_ARG { [ $1 ] }
+
+SAVE_ARG :: { Expression A0 } : COMMON_NAME { $1 } | VARIABLE { $1 }
+
+COMMON_NAME :: { Expression A0 }
+: '/' VARIABLE '/' { setSpan (getTransSpan $1 $3) $2 }
+
+INITIALIZED_DECLARATOR_LIST :: { [ Declarator A0 ] }
+: INITIALIZED_DECLARATOR_LIST ',' INITIALIZED_DECLARATOR { $3 : $1 }
+| INITIALIZED_DECLARATOR { [ $1 ] }
+
+UNINITIALIZED_DECLARATOR_LIST :: { [ Declarator A0 ] }
+: UNINITIALIZED_DECLARATOR_LIST ',' DECLARATOR { $3 : $1 }
+| DECLARATOR { [ $1 ] }
+
+INITIALIZED_DECLARATOR :: { Declarator A0 }
+: DECLARATOR '=' EXPRESSION { setInitialisation $1 $3 }
+| DECLARATOR '=>' EXPRESSION { setInitialisation $1 $3 }
+| DECLARATOR { $1 }
+
+DECLARATOR :: { Declarator A0 }
+: VARIABLE
+  {     Declarator () (getSpan $1)         $1 ScalarDecl                Nothing     Nothing }
+| VARIABLE '*' EXPRESSION
+  {     Declarator () (getTransSpan $1 $3) $1 ScalarDecl                (Just $3)   Nothing }
+| VARIABLE '*' '(' '*' ')'
+  { let star = ExpValue () (getSpan $4) ValStar
+     in Declarator () (getTransSpan $1 $5) $1 ScalarDecl                (Just star) Nothing }
+| VARIABLE '(' DIMENSION_DECLARATORS ')'
+  {     Declarator () (getTransSpan $1 $4) $1 (ArrayDecl (aReverse $3)) Nothing     Nothing }
+| VARIABLE '(' DIMENSION_DECLARATORS ')' '*' EXPRESSION
+  {     Declarator () (getTransSpan $1 $6) $1 (ArrayDecl (aReverse $3)) (Just $6)   Nothing }
+-- nonstandard char array syntax (wrong order for dimensions & charlen)
+| VARIABLE '*' EXPRESSION '(' DIMENSION_DECLARATORS ')'
+  {     Declarator () (getTransSpan $1 $6) $1 (ArrayDecl (aReverse $5)) (Just $3)   Nothing }
+| VARIABLE '(' DIMENSION_DECLARATORS ')' '*' '(' '*' ')'
+  { let star = ExpValue () (getSpan $7) ValStar
+     in Declarator () (getTransSpan $1 $8) $1 (ArrayDecl (aReverse $3)) (Just star) 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 ':' EXPRESSION
+  { DimensionDeclarator () (getTransSpan $1 $3) (Just $1) (Just $3) }
+| EXPRESSION { DimensionDeclarator () (getSpan $1) Nothing (Just $1) }
+-- Lower bound only
+| EXPRESSION ':'
+  { DimensionDeclarator () (getTransSpan $1 $2) (Just $1) Nothing }
+| EXPRESSION ':' '*'
+  { let { span = getSpan $3;
+          star = ExpValue () span ValStar }
+    in DimensionDeclarator () (getTransSpan $1 span) (Just $1) (Just star) }
+| '*'
+  { let { span = getSpan $1;
+          star = ExpValue () span ValStar }
+    in DimensionDeclarator () span Nothing (Just star) }
+| ':'
+  { let span = getSpan $1
+    in DimensionDeclarator () span Nothing Nothing }
+
+MAYBE_TYPE_SPEC :: { Maybe (TypeSpec A0) }
+: TYPE_SPEC '::' { Just $1 }
+| {- empty -}    { 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 }
+| complex KIND_SELECTOR   { TypeSpec () (getSpan ($1, $2)) TypeComplex $2 }
+| character CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeCharacter $2 }
+| logical KIND_SELECTOR   { TypeSpec () (getSpan ($1, $2)) TypeLogical $2 }
+| type '(' id ')'
+  { let TId _ id = $3
+    in TypeSpec () (getTransSpan $1 $4) (TypeCustom id) Nothing }
+-- R502
+| class '(' '*' ')'       { TypeSpec () (getSpan ($1, $4)) ClassStar Nothing }
+-- FIXME: this (and TypeCustom) can accept parameterised types. See type-param-value.
+-- Needs refactoring as this is used in various parts of the spec to consolidate
+-- uses of ':', '*' and scalar-int-exp.
+| class '(' id ')'
+  { let TId _ id = $3
+    in TypeSpec () (getSpan ($1, $4)) (ClassCustom id) Nothing }
+
+KIND_SELECTOR :: { Maybe (Selector A0) }
+: '(' EXPRESSION ')'
+  { Just $ Selector () (getTransSpan $1 $3) Nothing (Just $2) }
+| '(' kind '=' EXPRESSION ')'
+  { Just $ Selector () (getTransSpan $1 $5) Nothing (Just $4) }
+| '*' EXPRESSION -- non-standard but commonly used extension
+  { Just $ Selector () (getTransSpan $1 $2) Nothing (Just $2) }
+| {- EMPTY -} { Nothing }
+
+CHAR_SELECTOR :: { Maybe (Selector A0) }
+: '*' EXPRESSION
+  { Just $ Selector () (getTransSpan $1 $2) (Just $2) Nothing }
+-- The following rule is a bug in the spec.
+-- | '*' EXPRESSION ','
+--   { Just $ Selector () (getTransSpan $1 $2) (Just $2) Nothing }
+| '*' '(' '*' ')'
+  { let star = ExpValue () (getSpan $3) ValStar
+    in Just $ Selector () (getTransSpan $1 $4) (Just star) Nothing }
+| '(' LEN_EXPRESSION ')'
+  { Just $ Selector () (getTransSpan $1 $3) (Just $2) Nothing }
+| '(' len '=' LEN_EXPRESSION ')'
+  { Just $ Selector () (getTransSpan $1 $5) (Just $4) Nothing }
+| '(' kind '=' EXPRESSION ')'
+  { Just $ Selector () (getTransSpan $1 $5) Nothing (Just $4) }
+| '(' LEN_EXPRESSION ',' EXPRESSION ')'
+  { Just $ Selector () (getTransSpan $1 $5) (Just $2) (Just $4) }
+| '(' LEN_EXPRESSION ',' kind '=' EXPRESSION ')'
+  { Just $ Selector () (getTransSpan $1 $7) (Just $2) (Just $6) }
+| '(' len '=' LEN_EXPRESSION ',' kind '=' EXPRESSION ')'
+  { Just $ Selector () (getTransSpan $1 $9) (Just $4) (Just $8) }
+| '(' kind '=' EXPRESSION ',' len '=' LEN_EXPRESSION ')'
+  { Just $ Selector () (getTransSpan $1 $9) (Just $8) (Just $4) }
+| {- EMPTY -} { Nothing }
+
+{- R402 -}
+LEN_EXPRESSION :: { Expression A0 }
+: EXPRESSION { $1 }
+| '*' { ExpValue () (getSpan $1) ValStar }
+| ':' { ExpValue () (getSpan $1) ValColon }
+
+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 SIGN
+  { 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 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 }
+| opCustom EXPRESSION %prec DEFINED_UNARY
+  { let TOpCustom span str = $1
+    in ExpUnary () (getTransSpan span $2) (UnCustom str) $2 }
+| EXPRESSION opCustom EXPRESSION
+  { let TOpCustom _ str = $2
+    in ExpBinary () (getTransSpan $1 $3) (BinCustom str) $1 $3 }
+| '(' EXPRESSION ')' { setSpan (getTransSpan $1 $3) $2 }
+| NUMERIC_LITERAL                   { $1 }
+| '(' EXPRESSION ',' EXPRESSION ')'
+  { ExpValue () (getTransSpan $1 $5) (ValComplex $2 $4) }
+| LOGICAL_LITERAL                   { $1 }
+| STRING                            { $1 }
+| DATA_REF                          { $1 }
+| IMPLIED_DO                        { $1 }
+| '(/' EXPRESSION_LIST '/)'
+  { ExpInitialisation () (getTransSpan $1 $3) (fromReverseList $2) }
+| operator '(' opCustom ')'
+  { let TOpCustom _ op = $3
+    in ExpValue () (getTransSpan $1 $4) (ValOperator op) }
+| assignment { ExpValue () (getSpan $1) ValAssignment }
+| '*' INTEGER_LITERAL { ExpReturnSpec () (getTransSpan $1 $2) $2 }
+
+DATA_REFS :: { [ Expression A0 ] }
+: DATA_REFS ',' DATA_REF { $3 : $1 }
+| DATA_REF { [ $1 ] }
+
+DATA_REF :: { Expression A0 }
+: DATA_REF '%' PART_REF { ExpDataRef () (getTransSpan $1 $3) $1 $3 }
+| PART_REF { $1 }
+
+PART_REFS :: { [ Expression A0 ] }
+: PART_REFS ',' PART_REF { $3 : $1 }
+| PART_REF { [ $1 ] }
+
+PART_REF :: { Expression A0 }
+: VARIABLE { $1 }
+| VARIABLE '(' ')'
+  { ExpFunctionCall () (getTransSpan $1 $3) $1 Nothing }
+| VARIABLE '(' INDICIES ')'
+  { ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3) }
+| VARIABLE '(' INDICIES ')' '(' INDICIES ')'
+  { let innerSub = ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3)
+    in ExpSubscript () (getTransSpan $1 $7) innerSub (fromReverseList $6) }
+
+INDICIES :: { [ Index A0 ] }
+: INDICIES ',' INDEX { $3 : $1 }
+| INDEX { [ $1 ] }
+
+INDEX :: { Index A0 }
+: RANGE { $1 }
+| RANGE ':' EXPRESSION
+  { let IxRange () s lower upper _ = $1
+    in IxRange () (getTransSpan s $3) lower upper (Just $3) }
+| EXPRESSION { IxSingle () (getSpan $1) Nothing $1 }
+-- Following is only as an intermediate stage before having been turned into
+-- an argument by later transformation.
+| id '=' EXPRESSION
+  { let TId s id = $1 in IxSingle () (getTransSpan $1 s) (Just id) $3 }
+
+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 }
+
+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 }
+
+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 }
+
+FORALL :: { Statement A0 }
+: id ':' forall FORALL_HEADER {
+  let (TId s1 id) = $1 in
+  let (h,s2) = $4 in
+  StForall () (getTransSpan s1 s2) (Just id) h
+}
+| forall FORALL_HEADER {
+  let (h,s) = $2 in
+  StForall () (getTransSpan $1 s) Nothing h
+}
+| forall FORALL_HEADER FORALL_ASSIGNMENT_STMT {
+  let (h,_) = $2 in
+  StForallStatement () (getTransSpan $1 $3) h $3
+}
+
+FORALL_HEADER :: { (ForallHeader A0, SrcSpan) }
+-- Standard simple forall header
+: '(' FORALL_TRIPLET_SPEC ')'   { (ForallHeader [$2] Nothing, getTransSpan $1 $3) }
+-- forall header with scale expression
+| '(' '(' FORALL_TRIPLET_SPEC ')' ',' EXPRESSION ')'
+                              { (ForallHeader [$3] (Just $6), getTransSpan $1 $7) }
+-- multi forall header
+| '(' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE ')'
+                              { (ForallHeader $2 Nothing, getTransSpan $1 $3) }
+-- multi forall header with scale
+| '(' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE ',' EXPRESSION ')'
+                              { (ForallHeader $2 (Just $4), getTransSpan $1 $5) }
+
+FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE
+  :: { [(Name, Expression A0, Expression A0, Maybe (Expression A0))] }
+: '(' FORALL_TRIPLET_SPEC ')' ',' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE { $2 : $5 }
+| {- empty -}                                                          { [] }
+
+FORALL_TRIPLET_SPEC :: { (Name, Expression A0, Expression A0, Maybe (Expression A0)) }
+: NAME '=' EXPRESSION ':' EXPRESSION { ($1, $3, $5, Nothing) }
+| NAME '=' EXPRESSION ':' EXPRESSION ',' EXPRESSION { ($1, $3, $5, Just $7) }
+
+FORALL_ASSIGNMENT_STMT :: { Statement A0 }
+: EXPRESSION_ASSIGNMENT_STATEMENT { $1 }
+| POINTER_ASSIGNMENT_STMT { $1 }
+
+POINTER_ASSIGNMENT_STMT :: { Statement A0 }
+: DATA_REF '=>' EXPRESSION { StPointerAssign () (getTransSpan $1 $3) $1 $3 }
+
+END_FORALL :: { Statement A0 }
+: endforall    { StEndForall () (getSpan $1) Nothing }
+| endforall id { let (TId s id) = $2 in StEndForall () (getTransSpan $1 s) (Just id)}
+
+EXPRESSION_LIST :: { [ Expression A0 ] }
+: EXPRESSION_LIST ',' EXPRESSION { $3 : $1 }
+| EXPRESSION { [ $1 ] }
+
+ARITHMETIC_SIGN :: { (SrcSpan, UnaryOp) }
+: '-' { (getSpan $1, Minus) }
+| '+' { (getSpan $1, Plus) }
+
+RELATIONAL_OPERATOR :: { BinaryOp }
+: '=='  { EQ }
+| '!='  { NE }
+| '>'   { GT }
+| '>='  { GTE }
+| '<'   { LT }
+| '<='  { LTE }
+
+VARIABLE :: { Expression A0 }
+: id { ExpValue () (getSpan $1) $ let (TId _ s) = $1 in ValVariable s }
+
+NUMERIC_LITERAL :: { Expression A0 }
+: INTEGER_LITERAL { $1 } | REAL_LITERAL { $1 }
+
+INTEGERS :: { [ Expression A0 ] }
+: INTEGERS ',' INTEGER_LITERAL { $3 : $1 }
+| INTEGER_LITERAL { [ $1 ] }
+
+INTEGER_LITERAL :: { Expression A0 }
+: int
+  { let TIntegerLiteral s i = $1
+     in ExpValue () s $ ValInteger i Nothing   }
+| int '_' KIND_PARAM
+  { let TIntegerLiteral s i = $1
+     in ExpValue () s $ ValInteger i (Just $3) }
+| boz { let TBozLiteral s b = $1 in ExpValue () s $ ValBoz b }
+
+REAL_LITERAL :: { Expression A0 }
+: float
+  { let TRealLiteral s r = $1
+     in ExpValue () s $ ValReal r Nothing }
+| float '_' KIND_PARAM
+  { let TRealLiteral s r = $1
+     in ExpValue () s $ ValReal r (Just $3) }
+
+LOGICAL_LITERAL :: { Expression A0 }
+: bool
+  { let TLogicalLiteral s b = $1
+     in ExpValue () s (ValLogical b Nothing) }
+| bool '_' KIND_PARAM
+  { let TLogicalLiteral s b = $1
+     in ExpValue () s (ValLogical b (Just $3)) }
+
+KIND_PARAM :: { Expression A0 }
+: INTEGER_LITERAL { $1 }
+| VARIABLE        { $1 }
+
+STRING :: { Expression A0 }
+: string { let TString s c = $1 in ExpValue () s $ ValString c }
+
+cDATA :: { () } : {% pushContext ConData }
+cIMPLICIT :: { () } : {% pushContext ConImplicit }
+cNAMELIST :: { () } : {% pushContext ConNamelist }
+cCOMMON :: { () } : {% pushContext ConCommon }
+cPOP :: { () } : {% popContext }
diff --git a/src/Language/Fortran/Parser/Free/Fortran90.y b/src/Language/Fortran/Parser/Free/Fortran90.y
new file mode 100644
--- /dev/null
+++ b/src/Language/Fortran/Parser/Free/Fortran90.y
@@ -0,0 +1,1161 @@
+-- -*- Mode: Haskell -*-
+-- vim: ft=haskell
+{
+module Language.Fortran.Parser.Free.Fortran90
+  ( programParser
+  , functionParser
+  , blockParser
+  , statementParser
+  , expressionParser
+  ) where
+
+import Language.Fortran.Version
+import Language.Fortran.Util.Position
+import Language.Fortran.Parser.Monad
+import Language.Fortran.Parser.Free.Lexer
+import Language.Fortran.Parser.Free.Utils
+import Language.Fortran.AST
+
+import Prelude hiding ( EQ, LT, GT ) -- Same constructors exist in the AST
+import Data.Either ( partitionEithers )
+
+}
+
+%name programParser    PROGRAM
+%name functionParser   SUBPROGRAM_UNIT
+%name blockParser      BLOCK
+%name statementParser  STATEMENT
+%name expressionParser EXPRESSION
+%monad { LexAction }
+%lexer { lexer } { TEOF _ }
+%tokentype { Token }
+%error { parseError }
+
+%token
+  id                          { TId _ _ }
+  comment                     { TComment _ _ }
+  string                      { TString _ _ }
+  int                         { TIntegerLiteral _ _ }
+  float                       { TRealLiteral _ _ }
+  boz                         { TBozLiteral _ _ }
+  '_'                         { TUnderscore _ }
+  ','                         { TComma _ }
+  ',2'                        { TComma2 _ }
+  ';'                         { TSemiColon _ }
+  ':'                         { TColon _ }
+  '::'                        { TDoubleColon _ }
+  '='                         { TOpAssign _ }
+  '=>'                        { TArrow _ }
+  '%'                         { TPercent _ }
+  '('                         { TLeftPar _ }
+  '(2'                        { TLeftPar2 _ }
+  ')'                         { TRightPar _ }
+  '(/'                        { TLeftInitPar _ }
+  '/)'                        { TRightInitPar _ }
+  opCustom                    { TOpCustom _ _ }
+  '**'                        { TOpExp _ }
+  '+'                         { TOpPlus _ }
+  '-'                         { TOpMinus _ }
+  '*'                         { TStar _ }
+  '/'                         { TOpDivision _ }
+  slash                       { TSlash _ }
+  or                          { TOpOr _ }
+  and                         { TOpAnd _ }
+  not                         { TOpNot _ }
+  eqv                         { TOpEquivalent _ }
+  neqv                        { TOpNotEquivalent _ }
+  '<'                         { TOpLT _ }
+  '<='                        { TOpLE _ }
+  '=='                        { TOpEQ _ }
+  '!='                        { TOpNE _ }
+  '>'                         { TOpGT _ }
+  '>='                        { TOpGE _ }
+  bool                        { TLogicalLiteral _ _ }
+  program                     { TProgram _ }
+  endProgram                  { TEndProgram _ }
+  function                    { TFunction _ }
+  endFunction                 { TEndFunction _ }
+  result                      { TResult _ }
+  recursive                   { TRecursive _ }
+  subroutine                  { TSubroutine _ }
+  endSubroutine               { TEndSubroutine _ }
+  blockData                   { TBlockData _ }
+  endBlockData                { TEndBlockData _ }
+  module                      { TModule _ }
+  endModule                   { TEndModule _ }
+  contains                    { TContains _ }
+  use                         { TUse _ }
+  only                        { TOnly _ }
+  interface                   { TInterface _ }
+  endInterface                { TEndInterface _ }
+  moduleProcedure             { TModuleProcedure _ }
+  assignment                  { TAssignment _ }
+  operator                    { TOperator _ }
+  call                        { TCall _ }
+  return                      { TReturn _ }
+  entry                       { TEntry _ }
+  include                     { TInclude _ }
+  public                      { TPublic _ }
+  private                     { TPrivate _ }
+  parameter                   { TParameter _ }
+  allocatable                 { TAllocatable _ }
+  dimension                   { TDimension _ }
+  external                    { TExternal _ }
+  intent                      { TIntent _ }
+  intrinsic                   { TIntrinsic _ }
+  optional                    { TOptional _ }
+  pointer                     { TPointer _ }
+  save                        { TSave _ }
+  target                      { TTarget _ }
+  in                          { TIn _ }
+  out                         { TOut _ }
+  inout                       { TInOut _ }
+  data                        { TData _ }
+  namelist                    { TNamelist _ }
+  implicit                    { TImplicit _ }
+  equivalence                 { TEquivalence _ }
+  common                      { TCommon _ }
+  allocate                    { TAllocate _ }
+  stat                        { TStat _ }
+  deallocate                  { TDeallocate _ }
+  nullify                     { TNullify _ }
+  none                        { TNone _ }
+  goto                        { TGoto _ }
+  assign                      { TAssign _ }
+  to                          { TTo _ }
+  continue                    { TContinue _ }
+  stop                        { TStop _ }
+  pause                       { TPause _ }
+  do                          { TDo _ }
+  enddo                       { TEndDo _ }
+  while                       { TWhile _ }
+  if                          { TIf _ }
+  then                        { TThen _ }
+  else                        { TElse _ }
+  elsif                       { TElsif _ }
+  endif                       { TEndIf _ }
+  case                        { TCase _ }
+  selectcase                  { TSelectCase _ }
+  endselect                   { TEndSelect _ }
+  default                     { TDefault _ }
+  cycle                       { TCycle _ }
+  exit                        { TExit _ }
+  where                       { TWhere _ }
+  elsewhere                   { TElsewhere _ }
+  endwhere                    { TEndWhere _ }
+  type                        { TType _ }
+  endType                     { TEndType _ }
+  sequence                    { TSequence _ }
+  kind                        { TKind _ }
+  len                         { TLen _ }
+  integer                     { TInteger _ }
+  real                        { TReal _ }
+  doublePrecision             { TDoublePrecision _ }
+  logical                     { TLogical _ }
+  character                   { TCharacter _ }
+  complex                     { TComplex _ }
+  open                        { TOpen _ }
+  close                       { TClose _ }
+  read                        { TRead _ }
+  write                       { TWrite _ }
+  print                       { TPrint _ }
+  backspace                   { TBackspace _ }
+  rewind                      { TRewind _ }
+  inquire                     { TInquire _ }
+  endfile                     { TEndfile _ }
+  format                      { TFormat _ }
+  blob                        { TBlob _ _ }
+  end                         { TEnd _ }
+  newline                     { TNewline _ }
+
+-- Precedence of operators
+
+-- Level 6
+%left opCustom
+
+-- Level 5
+%left eqv neqv
+%left or
+%left and
+%right not
+
+-- Level 4
+%nonassoc '==' '!=' '>' '<' '>=' '<='
+%nonassoc RELATIONAL
+
+-- Level 3
+%left CONCAT
+
+-- Level 2
+%left '+' '-'
+%left '*' '/'
+%right SIGN
+%right '**'
+
+-- Level 1
+%right DEFINED_UNARY
+
+-- Level 0
+%left '%'
+
+%%
+
+maybe(p)
+: p           { Just $1 }
+| {- empty -} { Nothing }
+
+-- 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 = Fortran90, miFilename = "" }) (reverse $1) }
+| {- empty -}   { ProgramFile (MetaInfo { miVersion = Fortran90, miFilename = "" }) [] }
+
+PROGRAM_UNITS :: { [ ProgramUnit A0 ] }
+: PROGRAM_UNITS PROGRAM_UNIT MAYBE_NEWLINE { $2 : $1 }
+| PROGRAM_UNIT MAYBE_NEWLINE { [ $1 ] }
+
+PROGRAM_UNIT :: { ProgramUnit A0 }
+: program NAME NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS PROGRAM_END
+  {% do { unitNameCheck $6 $2;
+          return $ PUMain () (getTransSpan $1 $6) (Just $2) (reverse $4) $5 } }
+| module NAME NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS MODULE_END
+  {% do { unitNameCheck $6 $2;
+          return $ PUModule () (getTransSpan $1 $6) $2 (reverse $4) $5 } }
+| blockData NEWLINE BLOCKS BLOCK_DATA_END
+  { PUBlockData () (getTransSpan $1 $4) Nothing (reverse $3) }
+| blockData NAME NEWLINE BLOCKS BLOCK_DATA_END
+  {% do { unitNameCheck $5 $2;
+          return $ PUBlockData () (getTransSpan $1 $5) (Just $2) (reverse $4) } }
+| SUBPROGRAM_UNIT { $1 }
+
+MAYBE_SUBPROGRAM_UNITS :: { Maybe [ ProgramUnit A0 ] }
+: contains NEWLINE SUBPROGRAM_UNITS { Just $ reverse $3 }
+| {- Empty -} { Nothing }
+
+SUBPROGRAM_UNITS :: { [ ProgramUnit A0 ] }
+: SUBPROGRAM_UNITS SUBPROGRAM_UNIT NEWLINE { $2 : $1 }
+| {- EMPTY -} { [ ] }
+
+SUBPROGRAM_UNIT :: { ProgramUnit A0 }
+: PREFIXES function NAME MAYBE_ARGUMENTS MAYBE_RESULT MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END
+  {% do { unitNameCheck $10 $3;
+          let (pfxs, typeSpec) = case partitionEithers $1 of
+                                   { (ps, t:_) -> (fromReverseList' ps, Just t)
+                                   ; (ps, [])  -> (fromReverseList' ps, Nothing) } in
+          let sfx = emptySuffixes in
+          let ss = if null $1 then getTransSpan $2 $10 else getTransSpan (reverse $1) $10 in
+          return $ PUFunction () ss typeSpec (pfxs, sfx) $3 $4 $5 (reverse $8) $9 } }
+| PREFIXES subroutine NAME MAYBE_ARGUMENTS MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS SUBROUTINE_END
+  {% do { unitNameCheck $9 $3;
+          (pfxs, typeSpec) <- case partitionEithers $1 of
+                                { (ps, t:_) -> fail "Subroutines cannot have return types."
+                                ; (ps, [])  -> return (fromReverseList' ps, Nothing) };
+          let sfx = emptySuffixes in
+          let ss = if null $1 then getTransSpan $2 $9 else getTransSpan (reverse $1) $9 in
+          return $ PUSubroutine () ss (pfxs, sfx) $3 $4 (reverse $7) $8 } }
+| comment { let (TComment s c) = $1 in PUComment () s (Comment c) }
+
+-- (Fortran2003) R1227, Fortran95/90 (...)
+PREFIXES :: { [Either (Prefix A0) (TypeSpec A0)] }
+: PREFIXES PREFIX { $2:$1 }
+| {- EMPTY -}     { [] }
+
+-- (Fortran2003) R1228, Fortran95/90 (...)
+PREFIX :: { Either (Prefix A0) (TypeSpec A0) }
+: recursive { Left $ PfxRecursive () (getSpan $1) }
+| TYPE_SPEC { Right $1 }
+
+RESULT :: { Expression A0 }
+: result '(' VARIABLE ')' { $3 }
+
+MAYBE_RESULT :: { Maybe (Expression A0) }
+: RESULT      { Just $1 }
+| {- empty -} { Nothing }
+
+MAYBE_ARGUMENTS :: { Maybe (AList Expression A0) }
+: '(' MAYBE_VARIABLES ')' { $2 }
+| {- Nothing -} { Nothing }
+
+PROGRAM_END :: { Token }
+: end { $1 } | endProgram { $1 } | endProgram id { $2 }
+MODULE_END :: { Token }
+: end { $1 } | endModule { $1 } | endModule id { $2 }
+FUNCTION_END :: { Token }
+: end { $1 } | endFunction { $1 } | endFunction id { $2 }
+SUBROUTINE_END :: { Token }
+: end { $1 } | endSubroutine { $1 } | endSubroutine id { $2 }
+BLOCK_DATA_END :: { Token }
+: end { $1 } | endBlockData { $1 } | endBlockData id { $2 }
+INTERFACE_END :: { Token }
+: end { $1 } | endInterface { $1 } | endInterface id { $2 }
+
+NAME :: { Name } : id { let (TId _ name) = $1 in name }
+
+BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] }
+
+BLOCK :: { Block A0 }
+: IF_BLOCK MAYBE_COMMENT NEWLINE { $1 }
+| CASE_BLOCK MAYBE_COMMENT NEWLINE { $1 }
+| INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE
+  { BlStatement () (getTransSpan $1 $2) (Just $1) $2 }
+| STATEMENT MAYBE_COMMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 }
+| interface MAYBE_EXPRESSION MAYBE_COMMENT NEWLINE SUBPROGRAM_UNITS2 MODULE_PROCEDURES INTERFACE_END MAYBE_COMMENT NEWLINE
+  { BlInterface () (getTransSpan $1 $9) $2 False (reverse $5) (reverse $6) }
+| interface MAYBE_EXPRESSION MAYBE_COMMENT NEWLINE MODULE_PROCEDURES INTERFACE_END MAYBE_COMMENT NEWLINE
+  { BlInterface () (getTransSpan $1 $8) $2 False [ ] (reverse $5) }
+| COMMENT_BLOCK { $1 }
+
+IF_BLOCK :: { Block A0 }
+:                        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
+  { let { startSpan = getSpan $1;
+          (endSpan, conds, blocks, endLabel) = $9;
+          span = getTransSpan startSpan endSpan }
+     in BlIf () span Nothing Nothing ((Just $3):conds) ((reverse $8):blocks) endLabel }
+|                 id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
+  { let { TId startSpan startName = $1;
+          (endSpan, conds, blocks, endLabel) = $11;
+          span = getTransSpan startSpan endSpan }
+     in BlIf () span Nothing (Just startName) ((Just $5):conds) ((reverse $10):blocks) endLabel }
+| INTEGER_LITERAL        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
+  { let { startSpan = getSpan $1;
+          startLabel = Just $1;
+          (endSpan, conds, blocks, endLabel) = $10;
+          span = getTransSpan startSpan endSpan }
+     in BlIf () span startLabel Nothing ((Just $4):conds) ((reverse $9):blocks) endLabel }
+| INTEGER_LITERAL id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
+  { let { startSpan = getSpan $1;
+          startLabel = Just $1;
+          TId _ startName = $2;
+          (endSpan, conds, blocks, endLabel) = $12;
+          span = getTransSpan startSpan endSpan }
+     in BlIf () span startLabel (Just startName) ((Just $6):conds) ((reverse $11):blocks) endLabel }
+
+ELSE_BLOCKS :: { (SrcSpan, [Maybe (Expression A0)], [[Block A0]], Maybe (Expression A0)) }
+: maybe(INTEGER_LITERAL) elsif '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
+  { let (endSpan, conds, blocks, endLabel) = $10
+    in (endSpan, Just $4 : conds, reverse $9 : blocks, endLabel) }
+| maybe(INTEGER_LITERAL) else                          MAYBE_COMMENT NEWLINE BLOCKS END_IF
+  { let (endSpan, endLabel) = $6
+    in (endSpan, [Nothing], [reverse $5], endLabel) }
+| END_IF { let (endSpan, endLabel) = $1 in (endSpan, [], [], endLabel) }
+
+END_IF :: { (SrcSpan, Maybe (Expression A0)) }
+: endif { (getSpan $1, Nothing) }
+| endif id { (getSpan $2, Nothing) }
+| INTEGER_LITERAL endif { (getSpan $2, Just $1) }
+| INTEGER_LITERAL endif id { (getSpan $3, Just $1) }
+
+CASE_BLOCK :: { Block A0 }
+:                        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
+  { let { (caseRanges, blocks, endLabel, endSpan) = $7;
+          span = getTransSpan $1 endSpan }
+    in BlCase () span Nothing Nothing $3 caseRanges blocks endLabel }
+| INTEGER_LITERAL        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
+  { let { (caseRanges, blocks, endLabel, endSpan) = $8;
+          span = getTransSpan $1 endSpan }
+    in BlCase () span (Just $1) Nothing $4 caseRanges blocks endLabel }
+|                 id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
+  { let { (caseRanges, blocks, endLabel, endSpan) = $9;
+          TId s startName = $1;
+          span = getTransSpan s endSpan }
+    in BlCase () span Nothing (Just startName) $5 caseRanges blocks endLabel }
+| INTEGER_LITERAL id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
+  { let { (caseRanges, blocks, endLabel, endSpan) = $10;
+          TId s startName = $2;
+          span = getTransSpan s endSpan }
+    in BlCase () span (Just $1) (Just startName) $6 caseRanges blocks endLabel }
+
+-- We store line comments as statements, but this raises an issue: we have
+-- nowhere to place comments after a SELECT CASE but before a CASE. So we drop
+-- them. The inner CASES_ rule does /not/ use this, because comments can always
+-- be parsed as belonging to to the above CASE block.
+CASES :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }
+: COMMENT_BLOCK CASES_ { $2 }
+|               CASES_ { $1 }
+
+CASES_ :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }
+: maybe(INTEGER_LITERAL) case '(' INDICIES ')' MAYBE_COMMENT NEWLINE BLOCKS CASES_
+  { let (scrutinees, blocks, endLabel, endSpan) = $9
+    in  (Just (fromReverseList $4) : scrutinees, reverse $8 : blocks, endLabel, endSpan) }
+| maybe(INTEGER_LITERAL) case default          MAYBE_COMMENT NEWLINE BLOCKS END_SELECT
+  { let (endLabel, endSpan) = $7
+    in ([Nothing], [$6], endLabel, endSpan) }
+| END_SELECT
+  { let (endLabel, endSpan) = $1
+    in ([], [], endLabel, endSpan) }
+
+END_SELECT :: { (Maybe (Expression A0), SrcSpan) }
+: maybe(INTEGER_LITERAL) endselect maybe(id)
+  { ($1, maybe (getSpan $2) getSpan $3) }
+
+MAYBE_EXPRESSION :: { Maybe (Expression A0) }
+: EXPRESSION { Just $1 }
+| {- EMPTY -} { Nothing }
+
+MAYBE_COMMENT :: { Maybe Token }
+: comment { Just $1 }
+| {- EMPTY -} { Nothing }
+
+SUBPROGRAM_UNITS2 :: { [ ProgramUnit A0 ] }
+: SUBPROGRAM_UNITS SUBPROGRAM_UNIT NEWLINE { $2 : $1 }
+
+MODULE_PROCEDURES :: { [ Block A0 ] }
+: MODULE_PROCEDURES MODULE_PROCEDURE { $2 : $1 }
+| MODULE_PROCEDURES MODULE_PROCEDURE COMMENT_BLOCK { $3 : $2 : $1 }
+| { [ ] }
+
+MODULE_PROCEDURE :: { Block A0 }
+: moduleProcedure VARIABLES MAYBE_COMMENT NEWLINE
+  { let { al = fromReverseList $2;
+          st = StModuleProcedure () (getTransSpan $1 al) (fromReverseList $2) }
+    in BlStatement () (getTransSpan $1 $4) Nothing st }
+
+COMMENT_BLOCK :: { Block A0 }
+: 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 }
+| newline { $1 }
+| ';' { $1 }
+
+STATEMENT :: { Statement A0 }
+: NONEXECUTABLE_STATEMENT { $1 }
+| EXECUTABLE_STATEMENT { $1 }
+
+EXPRESSION_ASSIGNMENT_STATEMENT :: { Statement A0 }
+: DATA_REF '=' EXPRESSION { StExpressionAssign () (getTransSpan $1 $3) $1 $3 }
+
+NONEXECUTABLE_STATEMENT :: { Statement A0 }
+: DECLARATION_STATEMENT { $1 }
+| intent '(' INTENT_CHOICE ')' MAYBE_DCOLON EXPRESSION_LIST
+  { let expAList = fromReverseList $6
+    in StIntent () (getTransSpan $1 expAList) $3 expAList }
+| optional MAYBE_DCOLON EXPRESSION_LIST
+  { let expAList = fromReverseList $3
+    in StOptional () (getTransSpan $1 expAList) expAList }
+| public MAYBE_DCOLON EXPRESSION_LIST
+  { let expAList = fromReverseList $3
+    in StPublic () (getTransSpan $1 expAList) (Just expAList) }
+| public { StPublic () (getSpan $1) Nothing }
+| private MAYBE_DCOLON EXPRESSION_LIST
+  { let expAList = fromReverseList $3
+    in StPrivate () (getTransSpan $1 expAList) (Just expAList) }
+| private { StPrivate () (getSpan $1) Nothing }
+| save MAYBE_DCOLON SAVE_ARGS
+  { let saveAList = (fromReverseList $3)
+    in StSave () (getTransSpan $1 saveAList) (Just saveAList) }
+| save { StSave () (getSpan $1) Nothing }
+| dimension MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
+  { let declAList = fromReverseList $3
+    in StDimension () (getTransSpan $1 declAList) declAList }
+| allocatable MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
+  { let declAList = fromReverseList $3
+    in StAllocatable () (getTransSpan $1 declAList) declAList }
+| pointer MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
+  { let declAList = fromReverseList $3
+    in StPointer () (getTransSpan $1 declAList) declAList }
+| target MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
+  { let declAList = fromReverseList $3
+    in StTarget () (getTransSpan $1 declAList) declAList }
+| data cDATA DATA_GROUPS cPOP
+  { let dataAList = fromReverseList $3
+    in StData () (getTransSpan $1 dataAList) dataAList }
+| parameter '(' PARAMETER_ASSIGNMENTS ')'
+  { let declAList = fromReverseList $3
+    in StParameter () (getTransSpan $1 $4) declAList }
+| implicit none { StImplicit () (getTransSpan $1 $2) Nothing }
+| implicit cIMPLICIT IMP_LISTS cPOP
+  { let impAList = fromReverseList $3
+    in StImplicit () (getTransSpan $1 impAList) $ Just $ impAList }
+| namelist cNAMELIST NAMELISTS cPOP
+  { let nameALists = fromReverseList $3
+    in StNamelist () (getTransSpan $1 nameALists) nameALists }
+| equivalence EQUIVALENCE_GROUPS
+  { let eqALists = fromReverseList $2
+    in StEquivalence () (getTransSpan $1 eqALists) eqALists }
+| common cCOMMON COMMON_GROUPS cPOP
+  { let commonAList = fromReverseList $3
+    in StCommon () (getTransSpan $1 commonAList) commonAList }
+| external MAYBE_DCOLON VARIABLES
+  { let alist = fromReverseList $3
+    in StExternal () (getTransSpan $1 alist) alist }
+| intrinsic MAYBE_DCOLON VARIABLES
+  { let alist = fromReverseList $3
+    in StIntrinsic () (getTransSpan $1 alist) alist }
+| use VARIABLE { StUse () (getTransSpan $1 $2) $2 Nothing Permissive Nothing }
+| use VARIABLE ',' RENAME_LIST
+  { let alist = fromReverseList $4
+    in StUse () (getTransSpan $1 alist) $2 Nothing Permissive (Just alist) }
+| use VARIABLE ',' only ':' MAYBE_RENAME_LIST
+  { StUse () (getTransSpan $1 ($5, $6)) $2 Nothing Exclusive $6 }
+| entry VARIABLE MAYBE_RESULT
+  { StEntry () (getTransSpan $1 $ maybe (getSpan $2) getSpan $3) $2 Nothing $3 }
+| entry VARIABLE '(' ')' MAYBE_RESULT
+  { StEntry () (getTransSpan $1 $ maybe (getSpan $4) getSpan $5) $2 Nothing $5 }
+| entry VARIABLE '(' VARIABLES ')' MAYBE_RESULT
+  { StEntry () (getTransSpan $1 $ maybe (getSpan $5) getSpan $6) $2 (Just $ fromReverseList $4) $6 }
+| sequence { StSequence () (getSpan $1) }
+| type ATTRIBUTE_LIST '::' id
+  { let { TId span id = $4;
+          alist = if null $2 then Nothing else (Just . fromReverseList) $2 }
+    in StType () (getTransSpan $1 span) alist id }
+| type id
+  { let TId span id = $2 in StType () (getTransSpan $1 span) Nothing id }
+| endType { StEndType () (getSpan $1) Nothing }
+| endType id
+  { let TId span id = $2 in StEndType () (getTransSpan $1 span) (Just id) }
+| include STRING { StInclude () (getTransSpan $1 $2) $2 Nothing }
+-- 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 }
+
+EXECUTABLE_STATEMENT :: { Statement A0 }
+: allocate '(' DATA_REFS MAYBE_ALLOC_OPT_LIST ')'
+  { StAllocate () (getTransSpan $1 $5) Nothing (fromReverseList $3) $4 }
+| nullify '(' DATA_REFS ')'
+  { StNullify () (getTransSpan $1 $4) (fromReverseList $3) }
+| deallocate '(' DATA_REFS MAYBE_ALLOC_OPT_LIST ')'
+  { StDeallocate () (getTransSpan $1 $5) (fromReverseList $3) $4 }
+| EXPRESSION_ASSIGNMENT_STATEMENT { $1 }
+| DATA_REF '=>' EXPRESSION { StPointerAssign () (getTransSpan $1 $3) $1 $3 }
+| where '(' EXPRESSION ')' EXPRESSION_ASSIGNMENT_STATEMENT
+  { StWhere () (getTransSpan $1 $5) $3 $5 }
+| where '(' EXPRESSION ')' { StWhereConstruct () (getTransSpan $1 $4) Nothing $3 }
+| elsewhere '(' EXPRESSION ')' { StElsewhere () (getTransSpan $1 $4) Nothing (Just $3) }
+| elsewhere { StElsewhere () (getSpan $1) Nothing Nothing }
+| endwhere { StEndWhere () (getSpan $1) Nothing }
+| if '(' EXPRESSION ')' INTEGER_LITERAL ',' INTEGER_LITERAL ',' INTEGER_LITERAL
+  { StIfArithmetic () (getTransSpan $1 $9) $3 $5 $7 $9 }
+| do { StDo () (getSpan $1) Nothing Nothing Nothing }
+| id ':' do
+  { let TId s id = $1
+    in StDo () (getTransSpan s $3) (Just id) Nothing Nothing }
+| do INTEGER_LITERAL MAYBE_COMMA DO_SPECIFICATION
+  { StDo () (getTransSpan $1 $4) Nothing (Just $2) (Just $4) }
+| do DO_SPECIFICATION { StDo () (getTransSpan $1 $2) Nothing Nothing (Just $2) }
+| id ':' do DO_SPECIFICATION
+  { let TId s id = $1
+    in StDo () (getTransSpan s $4) (Just id) Nothing (Just $4) }
+| do INTEGER_LITERAL MAYBE_COMMA while '(' EXPRESSION ')'
+  { StDoWhile () (getTransSpan $1 $7) Nothing (Just $2) $6 }
+| do while '(' EXPRESSION ')'
+  { StDoWhile () (getTransSpan $1 $5) Nothing Nothing $4 }
+| id ':' do while '(' EXPRESSION ')'
+  { let TId s id = $1
+    in StDoWhile () (getTransSpan s $7) (Just id) Nothing $6 }
+| enddo { StEnddo () (getSpan $1) Nothing }
+| enddo id
+  { let TId s id = $2 in StEnddo () (getTransSpan $1 s) (Just id) }
+| cycle { StCycle () (getSpan $1) Nothing }
+| cycle VARIABLE { StCycle () (getTransSpan $1 $2) (Just $2) }
+| exit { StExit () (getSpan $1) Nothing }
+| exit VARIABLE { StExit () (getTransSpan $1 $2) (Just $2) }
+-- GO TO label
+| goto INTEGER_LITERAL { StGotoUnconditional () (getTransSpan $1 $2) $2 }
+-- GO TO scalar-int-variable
+| goto VARIABLE { StGotoUnconditional () (getTransSpan $1 $2) $2 }
+-- GO TO scalar-int-variable [,] label-list
+| goto VARIABLE MAYBE_COMMA '(' INTEGERS ')'
+  { StGotoAssigned () (getTransSpan $1 $6) $2 (Just (fromReverseList $5)) }
+-- GO TO label-list [,] scalar-int-expression
+| goto '(' INTEGERS ')' MAYBE_COMMA EXPRESSION
+  { StGotoComputed () (getTransSpan $1 $6) (fromReverseList $3) $6 }
+| assign INTEGER_LITERAL to VARIABLE
+  { StLabelAssign () (getTransSpan $1 $4) $2 $4 }
+| continue { StContinue () (getSpan $1) }
+| stop { StStop () (getSpan $1) Nothing }
+| stop EXPRESSION { StStop () (getTransSpan $1 $2) (Just $2) }
+| pause { StPause () (getSpan $1) Nothing }
+| pause EXPRESSION { StPause () (getTransSpan $1 $2) (Just $2) }
+| if '(' EXPRESSION ')' EXECUTABLE_STATEMENT
+  { StIfLogical () (getTransSpan $1 $5) $3 $5 }
+| read CILIST IN_IOLIST
+  { let alist = fromReverseList $3
+    in StRead () (getTransSpan $1 alist) $2 (Just alist) }
+| read CILIST { StRead () (getTransSpan $1 $2) $2 Nothing }
+| read FORMAT_ID ',' IN_IOLIST
+  { let alist = fromReverseList $4
+    in StRead2 () (getTransSpan $1 alist) $2 (Just alist) }
+| read FORMAT_ID { StRead2 () (getTransSpan $1 $2) $2 Nothing }
+| write CILIST OUT_IOLIST
+  { let alist = fromReverseList $3
+    in StWrite () (getTransSpan $1 alist) $2 (Just alist) }
+| write CILIST { StWrite () (getTransSpan $1 $2) $2 Nothing }
+| print FORMAT_ID ',' OUT_IOLIST
+  { let alist = fromReverseList $4
+    in StPrint () (getTransSpan $1 alist) $2 (Just alist) }
+| print FORMAT_ID { StPrint () (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 }
+| call VARIABLE { StCall () (getTransSpan $1 $2) $2 Nothing }
+| call VARIABLE '(' ')' { StCall () (getTransSpan $1 $4) $2 Nothing }
+| call VARIABLE '(' ARGUMENTS ')'
+  { let alist = fromReverseList $4
+    in StCall () (getTransSpan $1 $5) $2 (Just alist) }
+| return { StReturn () (getSpan $1) Nothing }
+| return EXPRESSION { StReturn () (getTransSpan $1 $2) (Just $2) }
+
+ARGUMENTS :: { [ Argument A0 ] }
+: ARGUMENTS ',' ARGUMENT { $3 : $1 }
+| ARGUMENT { [ $1 ] }
+
+ARGUMENT :: { Argument A0 }
+: 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) }
+
+MAYBE_RENAME_LIST :: { Maybe (AList Use A0) }
+: RENAME_LIST { Just $ fromReverseList $1 }
+| {- empty -} { Nothing }
+
+RENAME_LIST :: { [ Use A0 ] }
+: RENAME_LIST ',' RENAME { $3 : $1 }
+| RENAME { [ $1 ] }
+
+RENAME :: { Use A0  }
+: VARIABLE '=>' VARIABLE { UseRename () (getTransSpan $1 $3) $1 $3 }
+| VARIABLE { UseID () (getSpan $1) $1 }
+| operator '(' opCustom ')'
+  { let TOpCustom ss op = $3
+    in UseID () (getTransSpan $1 $4) (ExpValue () ss (ValOperator op)) }
+| assignment { UseID () (getSpan $1) (ExpValue () (getSpan $1) ValAssignment) }
+
+MAYBE_DCOLON :: { () } : '::' { () } | {- EMPTY -} { () }
+
+FORMAT_ID :: { Expression A0 }
+: FORMAT_ID '/' '/' FORMAT_ID %prec CONCAT
+  { ExpBinary () (getTransSpan $1 $4) Concatenation $1 $4 }
+| INTEGER_LITERAL { $1 }
+| STRING { $1 }
+| DATA_REF { $1 }
+| '*' { ExpValue () (getSpan $1) ValStar }
+
+UNIT :: { Expression A0 }
+: INTEGER_LITERAL { $1 }
+| DATA_REF { $1 }
+| '*' { ExpValue () (getSpan $1) ValStar }
+
+CILIST :: { AList ControlPair A0 }
+: '(' CILIST_ELEMENT ',' FORMAT_ID ',' CILIST_PAIRS ')'
+  { let { cp1 = ControlPair () (getSpan $2) Nothing $2;
+          cp2 = ControlPair () (getSpan $4) Nothing $4;
+          tail = fromReverseList $6 }
+    in setSpan (getTransSpan $1 $7) $ cp1 `aCons` cp2 `aCons` tail }
+| '(' CILIST_ELEMENT ',' FORMAT_ID ')'
+  { let { cp1 = ControlPair () (getSpan $2) Nothing $2;
+          cp2 = ControlPair () (getSpan $4) Nothing $4 }
+    in AList () (getTransSpan $1 $5) [ cp1,  cp2 ] }
+| '(' CILIST_ELEMENT ',' CILIST_PAIRS ')'
+  { let { cp1 = ControlPair () (getSpan $2) Nothing $2;
+          tail = fromReverseList $4 }
+    in setSpan (getTransSpan $1 $5) $ cp1 `aCons` tail }
+| '(' CILIST_ELEMENT ')'
+  { let cp1 = ControlPair () (getSpan $2) Nothing $2
+    in AList () (getTransSpan $1 $3) [ cp1 ] }
+| '(' CILIST_PAIRS ')' { fromReverseList $2 }
+
+CILIST_PAIRS :: { [ ControlPair A0 ] }
+: CILIST_PAIRS ',' CILIST_PAIR { $3 : $1 }
+| CILIST_PAIR { [ $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 SIGN
+  { 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 }
+| 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 }
+| opCustom CI_EXPRESSION %prec DEFINED_UNARY
+  { let TOpCustom span str = $1
+    in ExpUnary () (getTransSpan span $2) (UnCustom str) $2 }
+| CI_EXPRESSION opCustom CI_EXPRESSION
+  { let TOpCustom _ str = $2
+    in ExpBinary () (getTransSpan $1 $3) (BinCustom str) $1 $3 }
+| '(' CI_EXPRESSION ')' { setSpan (getTransSpan $1 $3) $2 }
+| INTEGER_LITERAL { $1 }
+| LOGICAL_LITERAL { $1 }
+| STRING { $1 }
+| DATA_REF { $1 }
+
+MAYBE_ALLOC_OPT_LIST :: { Maybe (AList AllocOpt A0) }
+: ',' stat '=' EXPRESSION { Just (fromReverseList [AOStat () (getTransSpan $2 $4) $4]) }
+| {- empty -}             { Nothing }
+
+IN_IOLIST :: { [ Expression A0 ] }
+: IN_IOLIST ',' IN_IO_ELEMENT { $3 : $1}
+| IN_IO_ELEMENT { [ $1 ] }
+
+IN_IO_ELEMENT :: { Expression A0 }
+: DATA_REF { $1 }
+| '(' IN_IOLIST ',' DO_SPECIFICATION ')'
+  { ExpImpliedDo () (getTransSpan $1 $5) (fromReverseList $2) $4 }
+
+OUT_IOLIST :: { [ Expression A0 ] }
+: OUT_IOLIST ',' EXPRESSION { $3 : $1}
+| EXPRESSION { [ $1 ] }
+
+COMMON_GROUPS :: { [ CommonGroup A0 ] }
+: COMMON_GROUPS COMMON_GROUP { $2 : $1 }
+| COMMON_GROUPS ',2' COMMON_GROUP { $3 : $1 }
+| INIT_COMMON_GROUP { [ $1 ] }
+
+COMMON_GROUP :: { CommonGroup A0 }
+: COMMON_NAME UNINITIALIZED_DECLARATOR_LIST
+  { let alist = fromReverseList $2
+    in CommonGroup () (getTransSpan $1 alist) (Just $1) alist }
+| '/' '/' UNINITIALIZED_DECLARATOR_LIST
+  { let alist = fromReverseList $3
+    in CommonGroup () (getTransSpan $1 alist) Nothing alist }
+
+INIT_COMMON_GROUP :: { CommonGroup A0 }
+: COMMON_NAME UNINITIALIZED_DECLARATOR_LIST
+  { let alist = fromReverseList $2
+    in CommonGroup () (getTransSpan $1 alist) (Just $1) alist }
+| '/' '/' UNINITIALIZED_DECLARATOR_LIST
+  { let alist = fromReverseList $3
+    in CommonGroup () (getTransSpan $1 alist) Nothing alist }
+| UNINITIALIZED_DECLARATOR_LIST
+  { let alist = fromReverseList $1
+    in CommonGroup () (getSpan alist) Nothing alist }
+
+EQUIVALENCE_GROUPS :: { [ AList Expression A0 ] }
+: EQUIVALENCE_GROUPS ',' '(' PART_REFS ')'
+  { setSpan (getTransSpan $3 $5) (fromReverseList $4) : $1 }
+| '(' PART_REFS ')'
+  { [ setSpan (getTransSpan $1 $3) (fromReverseList $2) ] }
+
+NAMELISTS :: { [ Namelist A0 ] }
+: NAMELISTS NAMELIST { $2 : $1 }
+| NAMELISTS ',2' NAMELIST { $3 : $1 }
+| NAMELIST { [ $1 ] }
+
+NAMELIST :: { Namelist A0 }
+: '/' VARIABLE '/' VARIABLES
+  { Namelist () (getTransSpan $1 $4) $2 $ fromReverseList $4 }
+
+MAYBE_VARIABLES :: { Maybe (AList Expression A0) }
+: VARIABLES { Just $ fromReverseList $1 } | {- EMPTY -} { Nothing }
+
+VARIABLES :: { [ Expression A0 ] }
+: VARIABLES ',' VARIABLE { $3 : $1 }
+| VARIABLE { [ $1 ] }
+
+IMP_LISTS :: { [ ImpList A0 ] }
+: IMP_LISTS ',' IMP_LIST { $3 : $1 }
+| IMP_LIST { [ $1 ] }
+
+IMP_LIST :: { ImpList A0 }
+: TYPE_SPEC '(2' 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
+             }
+
+PARAMETER_ASSIGNMENTS :: { [ Declarator A0 ] }
+: PARAMETER_ASSIGNMENTS ',' PARAMETER_ASSIGNMENT { $3 : $1 }
+| PARAMETER_ASSIGNMENT { [ $1 ] }
+
+PARAMETER_ASSIGNMENT :: { Declarator A0 }
+: VARIABLE '=' EXPRESSION
+  { Declarator () (getTransSpan $1 $3) $1 ScalarDecl Nothing (Just $3) }
+
+DECLARATION_STATEMENT :: { Statement A0 }
+: TYPE_SPEC ATTRIBUTE_LIST '::' INITIALIZED_DECLARATOR_LIST
+  { let { mAttrAList = if null $2 then Nothing else Just $ fromReverseList $2;
+          declAList = fromReverseList $4 }
+    in StDeclaration () (getTransSpan $1 declAList) $1 mAttrAList declAList }
+| TYPE_SPEC INITIALIZED_DECLARATOR_LIST
+  { let { declAList = fromReverseList $2 }
+    in StDeclaration () (getTransSpan $1 declAList) $1 Nothing declAList }
+
+ATTRIBUTE_LIST :: { [ Attribute A0 ] }
+: ATTRIBUTE_LIST ',' ATTRIBUTE_SPEC { $3 : $1 }
+| {- EMPTY -} { [ ] }
+
+ATTRIBUTE_SPEC :: { Attribute A0 }
+: public { AttrPublic () (getSpan $1) }
+| private { AttrPrivate () (getSpan $1) }
+| allocatable { AttrAllocatable () (getSpan $1) }
+| dimension '(' DIMENSION_DECLARATORS ')'
+  { AttrDimension () (getTransSpan $1 $4) (aReverse $3) }
+| external { AttrExternal () (getSpan $1) }
+| intent '(' INTENT_CHOICE ')' { AttrIntent () (getTransSpan $1 $4) $3 }
+| intrinsic { AttrIntrinsic () (getSpan $1) }
+| optional { AttrOptional () (getSpan $1) }
+| pointer { AttrPointer () (getSpan $1) }
+| parameter { AttrParameter () (getSpan $1) }
+| save { AttrSave () (getSpan $1) }
+| target { AttrTarget () (getSpan $1) }
+
+INTENT_CHOICE :: { Intent } : in { In } | out { Out } | inout { InOut }
+
+DATA_GROUPS :: { [ DataGroup A0 ] }
+: DATA_GROUPS MAYBE_COMMA DATA_LIST slash EXPRESSION_LIST slash
+  { let { nameAList = fromReverseList $3;
+          dataAList = fromReverseList $5 }
+    in DataGroup () (getTransSpan nameAList $6) nameAList dataAList : $1 }
+| DATA_LIST slash EXPRESSION_LIST slash
+  { let { nameAList = fromReverseList $1;
+          dataAList = fromReverseList $3 }
+    in [ DataGroup () (getTransSpan nameAList $4) nameAList dataAList ] }
+
+MAYBE_COMMA :: { () } : ',' { () } | {- EMPTY -} { () }
+
+DATA_LIST :: { [ Expression A0 ] }
+: DATA_LIST ',' DATA_ELEMENT { $3 : $1 }
+| DATA_ELEMENT { [ $1 ] }
+
+DATA_ELEMENT :: { Expression A0 }
+: DATA_REF { $1 } | IMPLIED_DO { $1 }
+
+SAVE_ARGS :: { [ Expression A0 ] }
+: SAVE_ARGS ',' SAVE_ARG { $3 : $1 } | SAVE_ARG { [ $1 ] }
+
+SAVE_ARG :: { Expression A0 } : COMMON_NAME { $1 } | VARIABLE { $1 }
+
+COMMON_NAME :: { Expression A0 }
+: '/' VARIABLE '/' { setSpan (getTransSpan $1 $3) $2 }
+
+INITIALIZED_DECLARATOR_LIST :: { [ Declarator A0 ] }
+: INITIALIZED_DECLARATOR_LIST ',' INITIALIZED_DECLARATOR { $3 : $1 }
+| INITIALIZED_DECLARATOR { [ $1 ] }
+
+UNINITIALIZED_DECLARATOR_LIST :: { [ Declarator A0 ] }
+: UNINITIALIZED_DECLARATOR_LIST ',' DECLARATOR { $3 : $1 }
+| DECLARATOR { [ $1 ] }
+
+INITIALIZED_DECLARATOR :: { Declarator A0 }
+: DECLARATOR '=' EXPRESSION { setInitialisation $1 $3 }
+| DECLARATOR '=>' EXPRESSION { setInitialisation $1 $3 }
+| DECLARATOR { $1 }
+
+DECLARATOR :: { Declarator A0 }
+: VARIABLE
+  {     Declarator () (getSpan $1)         $1 ScalarDecl                Nothing     Nothing }
+| VARIABLE '*' EXPRESSION
+  {     Declarator () (getTransSpan $1 $3) $1 ScalarDecl                (Just $3)   Nothing }
+| VARIABLE '*' '(' '*' ')'
+  { let star = ExpValue () (getSpan $4) ValStar
+     in Declarator () (getTransSpan $1 $5) $1 ScalarDecl                (Just star) Nothing }
+| VARIABLE '(' DIMENSION_DECLARATORS ')'
+  {     Declarator () (getTransSpan $1 $4) $1 (ArrayDecl (aReverse $3)) Nothing     Nothing }
+| VARIABLE '(' DIMENSION_DECLARATORS ')' '*' EXPRESSION
+  {     Declarator () (getTransSpan $1 $6) $1 (ArrayDecl (aReverse $3)) (Just $6)   Nothing }
+-- nonstandard char array syntax (wrong order for dimensions & charlen)
+| VARIABLE '*' EXPRESSION '(' DIMENSION_DECLARATORS ')'
+  {     Declarator () (getTransSpan $1 $6) $1 (ArrayDecl (aReverse $5)) (Just $3)   Nothing }
+| VARIABLE '(' DIMENSION_DECLARATORS ')' '*' '(' '*' ')'
+  { let star = ExpValue () (getSpan $7) ValStar
+     in Declarator () (getTransSpan $1 $8) $1 (ArrayDecl (aReverse $3)) (Just star) 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 ':' EXPRESSION
+  { DimensionDeclarator () (getTransSpan $1 $3) (Just $1) (Just $3) }
+| EXPRESSION { DimensionDeclarator () (getSpan $1) Nothing (Just $1) }
+-- Lower bound only
+| EXPRESSION ':'
+  { DimensionDeclarator () (getTransSpan $1 $2) (Just $1) Nothing }
+| EXPRESSION ':' '*'
+  { let { span = getSpan $3;
+          star = ExpValue () span ValStar }
+    in DimensionDeclarator () (getTransSpan $1 span) (Just $1) (Just star) }
+| '*'
+  { let { span = getSpan $1;
+          star = ExpValue () span ValStar }
+    in DimensionDeclarator () span Nothing (Just star) }
+| ':'
+  { let span = getSpan $1
+    in DimensionDeclarator () span Nothing 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 }
+| complex   KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeComplex $2 }
+| character CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeCharacter $2 }
+| logical   KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeLogical $2 }
+| type      '(' id ')'
+  { let TId _ id = $3
+    in TypeSpec () (getTransSpan $1 $4) (TypeCustom id) Nothing }
+
+KIND_SELECTOR :: { Maybe (Selector A0) }
+: '(' EXPRESSION ')'
+  { Just $ Selector () (getTransSpan $1 $3) Nothing (Just $2) }
+| '(' kind '=' EXPRESSION ')'
+  { Just $ Selector () (getTransSpan $1 $5) Nothing (Just $4) }
+| '*' EXPRESSION -- non-standard but commonly used extension
+  { Just $ Selector () (getTransSpan $1 $2) Nothing (Just $2) }
+| {- EMPTY -} { Nothing }
+
+CHAR_SELECTOR :: { Maybe (Selector A0) }
+: '*' EXPRESSION
+  { Just $ Selector () (getTransSpan $1 $2) (Just $2) Nothing }
+-- The following rule is a bug in the spec.
+-- | '*' EXPRESSION ','
+--   { Just $ Selector () (getTransSpan $1 $2) (Just $2) Nothing }
+| '*' '(' '*' ')'
+  { let star = ExpValue () (getSpan $3) ValStar
+    in Just $ Selector () (getTransSpan $1 $4) (Just star) Nothing }
+| '(' LEN_EXPRESSION ')'
+  { Just $ Selector () (getTransSpan $1 $3) (Just $2) Nothing }
+| '(' len '=' LEN_EXPRESSION ')'
+  { Just $ Selector () (getTransSpan $1 $5) (Just $4) Nothing }
+| '(' kind '=' EXPRESSION ')'
+  { Just $ Selector () (getTransSpan $1 $5) Nothing (Just $4) }
+| '(' LEN_EXPRESSION ',' EXPRESSION ')'
+  { Just $ Selector () (getTransSpan $1 $5) (Just $2) (Just $4) }
+| '(' LEN_EXPRESSION ',' kind '=' EXPRESSION ')'
+  { Just $ Selector () (getTransSpan $1 $7) (Just $2) (Just $6) }
+| '(' len '=' LEN_EXPRESSION ',' kind '=' EXPRESSION ')'
+  { Just $ Selector () (getTransSpan $1 $9) (Just $4) (Just $8) }
+| '(' kind '=' EXPRESSION ',' len '=' LEN_EXPRESSION ')'
+  { Just $ Selector () (getTransSpan $1 $9) (Just $8) (Just $4) }
+| {- EMPTY -} { Nothing }
+
+LEN_EXPRESSION :: { Expression A0 }
+: EXPRESSION { $1 }
+| '*' { ExpValue () (getSpan $1) ValStar }
+
+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 SIGN
+  { 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 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 }
+| opCustom EXPRESSION %prec DEFINED_UNARY
+  { let TOpCustom span str = $1
+    in ExpUnary () (getTransSpan span $2) (UnCustom str) $2 }
+| EXPRESSION opCustom EXPRESSION
+  { let TOpCustom _ str = $2
+    in ExpBinary () (getTransSpan $1 $3) (BinCustom str) $1 $3 }
+| '(' EXPRESSION ')' { setSpan (getTransSpan $1 $3) $2 }
+| NUMERIC_LITERAL                   { $1 }
+| '(' EXPRESSION ',' EXPRESSION ')'
+  { ExpValue () (getTransSpan $1 $5) (ValComplex $2 $4) }
+| LOGICAL_LITERAL                   { $1 }
+| STRING                            { $1 }
+| DATA_REF                          { $1 }
+| IMPLIED_DO                        { $1 }
+| '(/' EXPRESSION_LIST '/)'
+  { ExpInitialisation () (getTransSpan $1 $3) (fromReverseList $2) }
+| operator '(' opCustom ')'
+  { let TOpCustom _ op = $3
+    in ExpValue () (getTransSpan $1 $4) (ValOperator op) }
+| assignment { ExpValue () (getSpan $1) ValAssignment }
+| '*' INTEGER_LITERAL { ExpReturnSpec () (getTransSpan $1 $2) $2 }
+
+DATA_REFS :: { [ Expression A0 ] }
+: DATA_REFS ',' DATA_REF { $3 : $1 }
+| DATA_REF { [ $1 ] }
+
+DATA_REF :: { Expression A0 }
+: DATA_REF '%' PART_REF { ExpDataRef () (getTransSpan $1 $3) $1 $3 }
+| PART_REF { $1 }
+
+PART_REFS :: { [ Expression A0 ] }
+: PART_REFS ',' PART_REF { $3 : $1 }
+| PART_REF { [ $1 ] }
+
+PART_REF :: { Expression A0 }
+: VARIABLE { $1 }
+| VARIABLE '(' ')'
+  { ExpFunctionCall () (getTransSpan $1 $3) $1 Nothing }
+| VARIABLE '(' INDICIES ')'
+  { ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3) }
+| VARIABLE '(' INDICIES ')' '(' INDICIES ')'
+  { let innerSub = ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3)
+    in ExpSubscript () (getTransSpan $1 $7) innerSub (fromReverseList $6) }
+
+INDICIES :: { [ Index A0 ] }
+: INDICIES ',' INDEX { $3 : $1 }
+| INDEX { [ $1 ] }
+
+INDEX :: { Index A0 }
+: RANGE { $1 }
+| RANGE ':' EXPRESSION
+  { let IxRange () s lower upper _ = $1
+    in IxRange () (getTransSpan s $3) lower upper (Just $3) }
+| EXPRESSION { IxSingle () (getSpan $1) Nothing $1 }
+-- Following is only as an intermediate stage before having been turned into
+-- an argument by later transformation.
+| id '=' EXPRESSION
+  { let TId s id = $1 in IxSingle () (getTransSpan $1 s) (Just id) $3 }
+
+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 }
+
+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 }
+
+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 ] }
+
+ARITHMETIC_SIGN :: { (SrcSpan, UnaryOp) }
+: '-' { (getSpan $1, Minus) }
+| '+' { (getSpan $1, Plus) }
+
+RELATIONAL_OPERATOR :: { BinaryOp }
+: '=='  { EQ }
+| '!='  { NE }
+| '>'   { GT }
+| '>='  { GTE }
+| '<'   { LT }
+| '<='  { LTE }
+
+VARIABLE :: { Expression A0 }
+: id { ExpValue () (getSpan $1) $ let (TId _ s) = $1 in ValVariable s }
+
+NUMERIC_LITERAL :: { Expression A0 }
+: INTEGER_LITERAL { $1 } | REAL_LITERAL { $1 }
+
+INTEGERS :: { [ Expression A0 ] }
+: INTEGERS ',' INTEGER_LITERAL { $3 : $1 }
+| INTEGER_LITERAL { [ $1 ] }
+
+INTEGER_LITERAL :: { Expression A0 }
+: int
+  { let TIntegerLiteral s i = $1
+     in ExpValue () s $ ValInteger i Nothing   }
+| int '_' KIND_PARAM
+  { let TIntegerLiteral s i = $1
+     in ExpValue () s $ ValInteger i (Just $3) }
+| boz { let TBozLiteral s b = $1 in ExpValue () s $ ValBoz b }
+
+REAL_LITERAL :: { Expression A0 }
+: float
+  { let TRealLiteral s r = $1
+     in ExpValue () s $ ValReal r Nothing }
+| float '_' KIND_PARAM
+  { let TRealLiteral s r = $1
+     in ExpValue () s $ ValReal r (Just $3) }
+
+LOGICAL_LITERAL :: { Expression A0 }
+: bool
+  { let TLogicalLiteral s b = $1
+     in ExpValue () s (ValLogical b Nothing) }
+| bool '_' KIND_PARAM
+  { let TLogicalLiteral s b = $1
+     in ExpValue () s (ValLogical b (Just $3)) }
+
+KIND_PARAM :: { Expression A0 }
+: INTEGER_LITERAL { $1 }
+| VARIABLE        { $1 }
+
+STRING :: { Expression A0 }
+: string { let TString s c = $1 in ExpValue () s $ ValString c }
+
+cDATA :: { () } : {% pushContext ConData }
+cIMPLICIT :: { () } : {% pushContext ConImplicit }
+cNAMELIST :: { () } : {% pushContext ConNamelist }
+cCOMMON :: { () } : {% pushContext ConCommon }
+cPOP :: { () } : {% popContext }
diff --git a/src/Language/Fortran/Parser/Free/Fortran95.y b/src/Language/Fortran/Parser/Free/Fortran95.y
new file mode 100644
--- /dev/null
+++ b/src/Language/Fortran/Parser/Free/Fortran95.y
@@ -0,0 +1,1231 @@
+-- -*- Mode: Haskell -*-
+-- vim: ft=haskell
+{
+module Language.Fortran.Parser.Free.Fortran95
+  ( programParser
+  , functionParser
+  , blockParser
+  , statementParser
+  , expressionParser
+  ) where
+
+import Language.Fortran.Version
+import Language.Fortran.Util.Position
+import Language.Fortran.Parser.Monad
+import Language.Fortran.Parser.Free.Lexer
+import Language.Fortran.Parser.Free.Utils
+import Language.Fortran.AST
+
+import Prelude hiding ( EQ, LT, GT ) -- Same constructors exist in the AST
+import Data.Either ( partitionEithers )
+
+}
+
+%name programParser    PROGRAM
+%name functionParser   SUBPROGRAM_UNIT
+%name blockParser      BLOCK
+%name statementParser  STATEMENT
+%name expressionParser EXPRESSION
+%monad { LexAction }
+%lexer { lexer } { TEOF _ }
+%tokentype { Token }
+%error { parseError }
+
+%token
+  id                          { TId _ _ }
+  comment                     { TComment _ _ }
+  string                      { TString _ _ }
+  int                         { TIntegerLiteral _ _ }
+  float                       { TRealLiteral _ _ }
+  boz                         { TBozLiteral _ _ }
+  '_'                         { TUnderscore _ }
+  ','                         { TComma _ }
+  ',2'                        { TComma2 _ }
+  ';'                         { TSemiColon _ }
+  ':'                         { TColon _ }
+  '::'                        { TDoubleColon _ }
+  '='                         { TOpAssign _ }
+  '=>'                        { TArrow _ }
+  '%'                         { TPercent _ }
+  '('                         { TLeftPar _ }
+  '(2'                        { TLeftPar2 _ }
+  ')'                         { TRightPar _ }
+  '(/'                        { TLeftInitPar _ }
+  '/)'                        { TRightInitPar _ }
+  opCustom                    { TOpCustom _ _ }
+  '**'                        { TOpExp _ }
+  '+'                         { TOpPlus _ }
+  '-'                         { TOpMinus _ }
+  '*'                         { TStar _ }
+  '/'                         { TOpDivision _ }
+  slash                       { TSlash _ }
+  or                          { TOpOr _ }
+  and                         { TOpAnd _ }
+  not                         { TOpNot _ }
+  eqv                         { TOpEquivalent _ }
+  neqv                        { TOpNotEquivalent _ }
+  '<'                         { TOpLT _ }
+  '<='                        { TOpLE _ }
+  '=='                        { TOpEQ _ }
+  '!='                        { TOpNE _ }
+  '>'                         { TOpGT _ }
+  '>='                        { TOpGE _ }
+  bool                        { TLogicalLiteral _ _ }
+  program                     { TProgram _ }
+  endProgram                  { TEndProgram _ }
+  function                    { TFunction _ }
+  endFunction                 { TEndFunction _ }
+  result                      { TResult _ }
+  pure                        { TPure _ }
+  elemental                   { TElemental _ }
+  recursive                   { TRecursive _ }
+  subroutine                  { TSubroutine _ }
+  endSubroutine               { TEndSubroutine _ }
+  blockData                   { TBlockData _ }
+  endBlockData                { TEndBlockData _ }
+  module                      { TModule _ }
+  endModule                   { TEndModule _ }
+  contains                    { TContains _ }
+  use                         { TUse _ }
+  only                        { TOnly _ }
+  interface                   { TInterface _ }
+  endInterface                { TEndInterface _ }
+  moduleProcedure             { TModuleProcedure _ }
+  assignment                  { TAssignment _ }
+  operator                    { TOperator _ }
+  call                        { TCall _ }
+  return                      { TReturn _ }
+  entry                       { TEntry _ }
+  include                     { TInclude _ }
+  public                      { TPublic _ }
+  private                     { TPrivate _ }
+  parameter                   { TParameter _ }
+  allocatable                 { TAllocatable _ }
+  dimension                   { TDimension _ }
+  external                    { TExternal _ }
+  intent                      { TIntent _ }
+  intrinsic                   { TIntrinsic _ }
+  optional                    { TOptional _ }
+  pointer                     { TPointer _ }
+  save                        { TSave _ }
+  target                      { TTarget _ }
+  value                       { TValue _ }
+  volatile                    { TVolatile _ }
+  in                          { TIn _ }
+  out                         { TOut _ }
+  inout                       { TInOut _ }
+  data                        { TData _ }
+  namelist                    { TNamelist _ }
+  implicit                    { TImplicit _ }
+  equivalence                 { TEquivalence _ }
+  common                      { TCommon _ }
+  allocate                    { TAllocate _ }
+  stat                        { TStat _ }
+  deallocate                  { TDeallocate _ }
+  nullify                     { TNullify _ }
+  none                        { TNone _ }
+  goto                        { TGoto _ }
+  to                          { TTo _ }
+  continue                    { TContinue _ }
+  stop                        { TStop _ }
+  do                          { TDo _ }
+  enddo                       { TEndDo _ }
+  while                       { TWhile _ }
+  if                          { TIf _ }
+  then                        { TThen _ }
+  else                        { TElse _ }
+  elsif                       { TElsif _ }
+  endif                       { TEndIf _ }
+  case                        { TCase _ }
+  selectcase                  { TSelectCase _ }
+  endselect                   { TEndSelect _ }
+  default                     { TDefault _ }
+  cycle                       { TCycle _ }
+  exit                        { TExit _ }
+  where                       { TWhere _ }
+  elsewhere                   { TElsewhere _ }
+  endwhere                    { TEndWhere _ }
+  type                        { TType _ }
+  endType                     { TEndType _ }
+  sequence                    { TSequence _ }
+  kind                        { TKind _ }
+  len                         { TLen _ }
+  integer                     { TInteger _ }
+  real                        { TReal _ }
+  doublePrecision             { TDoublePrecision _ }
+  logical                     { TLogical _ }
+  character                   { TCharacter _ }
+  complex                     { TComplex _ }
+  open                        { TOpen _ }
+  close                       { TClose _ }
+  read                        { TRead _ }
+  write                       { TWrite _ }
+  print                       { TPrint _ }
+  backspace                   { TBackspace _ }
+  rewind                      { TRewind _ }
+  inquire                     { TInquire _ }
+  endfile                     { TEndfile _ }
+  format                      { TFormat _ }
+  blob                        { TBlob _ _ }
+  end                         { TEnd _ }
+  newline                     { TNewline _ }
+  forall                      { TForall _ }
+  endforall                   { TEndForall _ }
+-- Precedence of operators
+
+-- Level 6
+%left opCustom
+
+-- Level 5
+%left eqv neqv
+%left or
+%left and
+%right not
+
+-- Level 4
+%nonassoc '==' '!=' '>' '<' '>=' '<='
+%nonassoc RELATIONAL
+
+-- Level 3
+%left CONCAT
+
+-- Level 2
+%left '+' '-'
+%left '*' '/'
+%right SIGN
+%right '**'
+
+-- Level 1
+%right DEFINED_UNARY
+
+-- Level 0
+%left '%'
+
+%%
+
+maybe(p)
+: p           { Just $1 }
+| {- empty -} { Nothing }
+
+-- 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 = Fortran95, miFilename = "" }) (reverse $1) }
+| {- empty -}   { ProgramFile (MetaInfo { miVersion = Fortran95, miFilename = "" }) [] }
+
+PROGRAM_UNITS :: { [ ProgramUnit A0 ] }
+: PROGRAM_UNITS PROGRAM_UNIT MAYBE_NEWLINE { $2 : $1 }
+| PROGRAM_UNIT MAYBE_NEWLINE { [ $1 ] }
+
+PROGRAM_UNIT :: { ProgramUnit A0 }
+: program NAME NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS PROGRAM_END
+  {% do { unitNameCheck $6 $2;
+          return $ PUMain () (getTransSpan $1 $6) (Just $2) (reverse $4) $5 } }
+| module NAME NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS MODULE_END
+  {% do { unitNameCheck $6 $2;
+          return $ PUModule () (getTransSpan $1 $6) $2 (reverse $4) $5 } }
+| blockData NEWLINE BLOCKS BLOCK_DATA_END
+  { PUBlockData () (getTransSpan $1 $4) Nothing (reverse $3) }
+| blockData NAME NEWLINE BLOCKS BLOCK_DATA_END
+  {% do { unitNameCheck $5 $2;
+          return $ PUBlockData () (getTransSpan $1 $5) (Just $2) (reverse $4) } }
+| SUBPROGRAM_UNIT { $1 }
+
+MAYBE_SUBPROGRAM_UNITS :: { Maybe [ ProgramUnit A0 ] }
+: contains NEWLINE SUBPROGRAM_UNITS { Just $ reverse $3 }
+| {- Empty -} { Nothing }
+
+SUBPROGRAM_UNITS :: { [ ProgramUnit A0 ] }
+: SUBPROGRAM_UNITS SUBPROGRAM_UNIT NEWLINE { $2 : $1 }
+| {- EMPTY -} { [ ] }
+
+SUBPROGRAM_UNIT :: { ProgramUnit A0 }
+: PREFIXES function NAME MAYBE_ARGUMENTS MAYBE_RESULT MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END
+  {% do { unitNameCheck $10 $3;
+          let (pfxs, typeSpec) = case partitionEithers $1 of
+                                   { (ps, t:_) -> (fromReverseList' ps, Just t)
+                                   ; (ps, [])  -> (fromReverseList' ps, Nothing) } in
+          let sfx = emptySuffixes in
+          let ss = if null $1 then getTransSpan $2 $10 else getTransSpan (reverse $1) $10 in
+          if validPrefixSuffix (pfxs, sfx) then
+            return $ PUFunction () ss typeSpec (pfxs, sfx) $3 $4 $5 (reverse $8) $9
+          else fail "Cannot specify elemental along with recursive." } }
+| PREFIXES subroutine NAME MAYBE_ARGUMENTS MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS SUBROUTINE_END
+  {% do { unitNameCheck $9 $3;
+          (pfxs, typeSpec) <- case partitionEithers $1 of
+                                { (ps, t:_) -> fail "Subroutines cannot have return types."
+                                ; (ps, [])  -> return (fromReverseList' ps, Nothing) };
+          let sfx = emptySuffixes in
+          let ss = if null $1 then getTransSpan $2 $9 else getTransSpan (reverse $1) $9 in
+          if validPrefixSuffix (pfxs, sfx) then
+            return $ PUSubroutine () ss (pfxs, sfx) $3 $4 (reverse $7) $8
+          else fail "Cannot specify elemental along with recursive." } }
+| comment { let (TComment s c) = $1 in PUComment () s (Comment c) }
+
+-- (Fortran2003) R1227, Fortran95 (...)
+PREFIXES :: { [Either (Prefix A0) (TypeSpec A0)] }
+: PREFIXES PREFIX { $2:$1 }
+| {- EMPTY -}     { [] }
+
+-- (Fortran2003) R1228, Fortran95 (...)
+PREFIX :: { Either (Prefix A0) (TypeSpec A0) }
+: recursive { Left $ PfxRecursive () (getSpan $1) }
+| elemental { Left $ PfxElemental () (getSpan $1) }
+| pure      { Left $ PfxPure      () (getSpan $1) }
+| TYPE_SPEC { Right $1 }
+
+RESULT :: { Expression A0 }
+: result '(' VARIABLE ')' { $3 }
+
+MAYBE_RESULT :: { Maybe (Expression A0) }
+: RESULT      { Just $1 }
+| {- empty -} { Nothing}
+
+MAYBE_ARGUMENTS :: { Maybe (AList Expression A0) }
+: '(' MAYBE_VARIABLES ')' { $2 }
+| {- Nothing -} { Nothing }
+
+PROGRAM_END :: { Token }
+: end { $1 } | endProgram { $1 } | endProgram id { $2 }
+MODULE_END :: { Token }
+: end { $1 } | endModule { $1 } | endModule id { $2 }
+FUNCTION_END :: { Token }
+: end { $1 } | endFunction { $1 } | endFunction id { $2 }
+SUBROUTINE_END :: { Token }
+: end { $1 } | endSubroutine { $1 } | endSubroutine id { $2 }
+BLOCK_DATA_END :: { Token }
+: end { $1 } | endBlockData { $1 } | endBlockData id { $2 }
+INTERFACE_END :: { Token }
+: end { $1 } | endInterface { $1 } | endInterface id { $2 }
+
+NAME :: { Name } : id { let (TId _ name) = $1 in name }
+
+BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] }
+
+BLOCK :: { Block A0 }
+: IF_BLOCK MAYBE_COMMENT NEWLINE { $1 }
+| CASE_BLOCK MAYBE_COMMENT NEWLINE { $1 }
+| INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE
+  { BlStatement () (getTransSpan $1 $2) (Just $1) $2 }
+| STATEMENT MAYBE_COMMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 }
+| interface MAYBE_EXPRESSION MAYBE_COMMENT NEWLINE SUBPROGRAM_UNITS2 MODULE_PROCEDURES INTERFACE_END MAYBE_COMMENT NEWLINE
+  { BlInterface () (getTransSpan $1 $9) $2 False (reverse $5) (reverse $6) }
+| interface MAYBE_EXPRESSION MAYBE_COMMENT NEWLINE MODULE_PROCEDURES INTERFACE_END MAYBE_COMMENT NEWLINE
+  { BlInterface () (getTransSpan $1 $8) $2 False [ ] (reverse $5) }
+| COMMENT_BLOCK { $1 }
+
+IF_BLOCK :: { Block A0 }
+IF_BLOCK
+:                        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
+  { let { startSpan = getSpan $1;
+          (endSpan, conds, blocks, endLabel) = $9;
+          span = getTransSpan startSpan endSpan }
+     in BlIf () span Nothing Nothing ((Just $3):conds) ((reverse $8):blocks) endLabel }
+|                 id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
+  { let { TId startSpan startName = $1;
+          (endSpan, conds, blocks, endLabel) = $11;
+          span = getTransSpan startSpan endSpan }
+     in BlIf () span Nothing (Just startName) ((Just $5):conds) ((reverse $10):blocks) endLabel }
+| INTEGER_LITERAL        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
+  { let { startSpan = getSpan $1;
+          startLabel = Just $1;
+          (endSpan, conds, blocks, endLabel) = $10;
+          span = getTransSpan startSpan endSpan }
+     in BlIf () span startLabel Nothing ((Just $4):conds) ((reverse $9):blocks) endLabel }
+| INTEGER_LITERAL id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
+  { let { startSpan = getSpan $1;
+          startLabel = Just $1;
+          TId _ startName = $2;
+          (endSpan, conds, blocks, endLabel) = $12;
+          span = getTransSpan startSpan endSpan }
+     in BlIf () span startLabel (Just startName) ((Just $6):conds) ((reverse $11):blocks) endLabel }
+
+ELSE_BLOCKS :: { (SrcSpan, [Maybe (Expression A0)], [[Block A0]], Maybe (Expression A0)) }
+ELSE_BLOCKS
+: maybe(INTEGER_LITERAL) elsif '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
+  { let (endSpan, conds, blocks, endLabel) = $10
+    in (endSpan, Just $4 : conds, reverse $9 : blocks, endLabel) }
+| maybe(INTEGER_LITERAL) else                          MAYBE_COMMENT NEWLINE BLOCKS END_IF
+  { let (endSpan, endLabel) = $6
+    in (endSpan, [Nothing], [reverse $5], endLabel) }
+| END_IF { let (endSpan, endLabel) = $1 in (endSpan, [], [], endLabel) }
+
+END_IF :: { (SrcSpan, Maybe (Expression A0)) }
+END_IF
+: endif { (getSpan $1, Nothing) }
+| endif id { (getSpan $2, Nothing) }
+| INTEGER_LITERAL endif { (getSpan $2, Just $1) }
+| INTEGER_LITERAL endif id { (getSpan $3, Just $1) }
+
+CASE_BLOCK :: { Block A0 }
+CASE_BLOCK
+:                        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
+  { let { (caseRanges, blocks, endLabel, endSpan) = $7;
+          span = getTransSpan $1 endSpan }
+    in BlCase () span Nothing Nothing $3 caseRanges blocks endLabel }
+| INTEGER_LITERAL        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
+  { let { (caseRanges, blocks, endLabel, endSpan) = $8;
+          span = getTransSpan $1 endSpan }
+    in BlCase () span (Just $1) Nothing $4 caseRanges blocks endLabel }
+|                 id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
+  { let { (caseRanges, blocks, endLabel, endSpan) = $9;
+          TId s startName = $1;
+          span = getTransSpan s endSpan }
+    in BlCase () span Nothing (Just startName) $5 caseRanges blocks endLabel }
+| INTEGER_LITERAL id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
+  { let { (caseRanges, blocks, endLabel, endSpan) = $10;
+          TId s startName = $2;
+          span = getTransSpan s endSpan }
+    in BlCase () span (Just $1) (Just startName) $6 caseRanges blocks endLabel }
+
+-- We store line comments as statements, but this raises an issue: we have
+-- nowhere to place comments after a SELECT CASE but before a CASE. So we drop
+-- them. The inner CASES_ rule does /not/ use this, because comments can always
+-- be parsed as belonging to to the above CASE block.
+CASES :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }
+: COMMENT_BLOCK CASES_ { $2 }
+|               CASES_ { $1 }
+
+CASES_ :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }
+: maybe(INTEGER_LITERAL) case '(' INDICIES ')' MAYBE_COMMENT NEWLINE BLOCKS CASES_
+  { let (scrutinees, blocks, endLabel, endSpan) = $9
+    in  (Just (fromReverseList $4) : scrutinees, reverse $8 : blocks, endLabel, endSpan) }
+| maybe(INTEGER_LITERAL) case default          MAYBE_COMMENT NEWLINE BLOCKS END_SELECT
+  { let (endLabel, endSpan) = $7
+    in ([Nothing], [$6], endLabel, endSpan) }
+| END_SELECT
+  { let (endLabel, endSpan) = $1
+    in ([], [], endLabel, endSpan) }
+
+END_SELECT :: { (Maybe (Expression A0), SrcSpan) }
+: maybe(INTEGER_LITERAL) endselect maybe(id)
+  { ($1, maybe (getSpan $2) getSpan $3) }
+
+MAYBE_EXPRESSION :: { Maybe (Expression A0) }
+: EXPRESSION { Just $1 }
+| {- EMPTY -} { Nothing }
+
+MAYBE_COMMENT :: { Maybe Token }
+: comment { Just $1 }
+| {- EMPTY -} { Nothing }
+
+SUBPROGRAM_UNITS2 :: { [ ProgramUnit A0 ] }
+: SUBPROGRAM_UNITS SUBPROGRAM_UNIT NEWLINE { $2 : $1 }
+
+MODULE_PROCEDURES :: { [ Block A0 ] }
+: MODULE_PROCEDURES MODULE_PROCEDURE { $2 : $1 }
+| MODULE_PROCEDURES MODULE_PROCEDURE COMMENT_BLOCK { $3 : $2 : $1 }
+| { [ ] }
+
+MODULE_PROCEDURE :: { Block A0 }
+: moduleProcedure VARIABLES MAYBE_COMMENT NEWLINE
+  { let { al = fromReverseList $2;
+          st = StModuleProcedure () (getTransSpan $1 al) (fromReverseList $2) }
+    in BlStatement () (getTransSpan $1 $4) Nothing st }
+
+COMMENT_BLOCK :: { Block A0 }
+: 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 }
+| newline { $1 }
+| ';' { $1 }
+
+STATEMENT :: { Statement A0 }
+: NONEXECUTABLE_STATEMENT { $1 }
+| EXECUTABLE_STATEMENT { $1 }
+
+EXPRESSION_ASSIGNMENT_STATEMENT :: { Statement A0 }
+: DATA_REF '=' EXPRESSION { StExpressionAssign () (getTransSpan $1 $3) $1 $3 }
+
+NONEXECUTABLE_STATEMENT :: { Statement A0 }
+: DECLARATION_STATEMENT { $1 }
+| intent '(' INTENT_CHOICE ')' MAYBE_DCOLON EXPRESSION_LIST
+  { let expAList = fromReverseList $6
+    in StIntent () (getTransSpan $1 expAList) $3 expAList }
+| optional MAYBE_DCOLON EXPRESSION_LIST
+  { let expAList = fromReverseList $3
+    in StOptional () (getTransSpan $1 expAList) expAList }
+| public MAYBE_DCOLON EXPRESSION_LIST
+  { let expAList = fromReverseList $3
+    in StPublic () (getTransSpan $1 expAList) (Just expAList) }
+| public { StPublic () (getSpan $1) Nothing }
+| private MAYBE_DCOLON EXPRESSION_LIST
+  { let expAList = fromReverseList $3
+    in StPrivate () (getTransSpan $1 expAList) (Just expAList) }
+| private { StPrivate () (getSpan $1) Nothing }
+| save MAYBE_DCOLON SAVE_ARGS
+  { let saveAList = (fromReverseList $3)
+    in StSave () (getTransSpan $1 saveAList) (Just saveAList) }
+| save { StSave () (getSpan $1) Nothing }
+| dimension MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
+  { let declAList = fromReverseList $3
+    in StDimension () (getTransSpan $1 declAList) declAList }
+| allocatable MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
+  { let declAList = fromReverseList $3
+    in StAllocatable () (getTransSpan $1 declAList) declAList }
+| pointer MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
+  { let declAList = fromReverseList $3
+    in StPointer () (getTransSpan $1 declAList) declAList }
+| target MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
+  { let declAList = fromReverseList $3
+    in StTarget () (getTransSpan $1 declAList) declAList }
+| value MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
+  { let declAList = fromReverseList $3
+    in StValue () (getTransSpan $1 declAList) declAList }
+| volatile MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
+  { let declAList = fromReverseList $3
+    in StVolatile () (getTransSpan $1 declAList) declAList }
+| data cDATA DATA_GROUPS cPOP
+  { let dataAList = fromReverseList $3
+    in StData () (getTransSpan $1 dataAList) dataAList }
+| parameter '(' PARAMETER_ASSIGNMENTS ')'
+  { let declAList = fromReverseList $3
+    in StParameter () (getTransSpan $1 $4) declAList }
+| implicit none { StImplicit () (getTransSpan $1 $2) Nothing }
+| implicit cIMPLICIT IMP_LISTS cPOP
+  { let impAList = fromReverseList $3
+    in StImplicit () (getTransSpan $1 impAList) $ Just $ impAList }
+| namelist cNAMELIST NAMELISTS cPOP
+  { let nameALists = fromReverseList $3
+    in StNamelist () (getTransSpan $1 nameALists) nameALists }
+| equivalence EQUIVALENCE_GROUPS
+  { let eqALists = fromReverseList $2
+    in StEquivalence () (getTransSpan $1 eqALists) eqALists }
+| common cCOMMON COMMON_GROUPS cPOP
+  { let commonAList = fromReverseList $3
+    in StCommon () (getTransSpan $1 commonAList) commonAList }
+| external MAYBE_DCOLON VARIABLES
+  { let alist = fromReverseList $3
+    in StExternal () (getTransSpan $1 alist) alist }
+| intrinsic MAYBE_DCOLON VARIABLES
+  { let alist = fromReverseList $3
+    in StIntrinsic () (getTransSpan $1 alist) alist }
+| use VARIABLE { StUse () (getTransSpan $1 $2) $2 Nothing Permissive Nothing }
+| use VARIABLE ',' RENAME_LIST
+  { let alist = fromReverseList $4
+    in StUse () (getTransSpan $1 alist) $2 Nothing Permissive (Just alist) }
+| use VARIABLE ',' only ':' MAYBE_RENAME_LIST
+  { StUse () (getTransSpan $1 ($5, $6)) $2 Nothing Exclusive $6 }
+| entry VARIABLE MAYBE_RESULT
+  { StEntry () (getTransSpan $1 $ maybe (getSpan $2) getSpan $3) $2 Nothing $3 }
+| entry VARIABLE '(' ')' MAYBE_RESULT
+  { StEntry () (getTransSpan $1 $ maybe (getSpan $4) getSpan $5) $2 Nothing $5 }
+| entry VARIABLE '(' VARIABLES ')' MAYBE_RESULT
+  { StEntry () (getTransSpan $1 $ maybe (getSpan $5) getSpan $6) $2 (Just $ fromReverseList $4) $6 }
+| sequence { StSequence () (getSpan $1) }
+| type ATTRIBUTE_LIST '::' id
+  { let { TId span id = $4;
+          alist = if null $2 then Nothing else (Just . fromReverseList) $2 }
+    in StType () (getTransSpan $1 span) alist id }
+| type id
+  { let TId span id = $2 in StType () (getTransSpan $1 span) Nothing id }
+| endType { StEndType () (getSpan $1) Nothing }
+| endType id
+  { let TId span id = $2 in StEndType () (getTransSpan $1 span) (Just id) }
+| include STRING { StInclude () (getTransSpan $1 $2) $2 Nothing }
+-- 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 }
+
+EXECUTABLE_STATEMENT :: { Statement A0 }
+: allocate '(' DATA_REFS MAYBE_ALLOC_OPT_LIST ')'
+  { StAllocate () (getTransSpan $1 $5) Nothing (fromReverseList $3) $4 }
+| nullify '(' DATA_REFS ')'
+  { StNullify () (getTransSpan $1 $4) (fromReverseList $3) }
+| deallocate '(' DATA_REFS MAYBE_ALLOC_OPT_LIST ')'
+  { StDeallocate () (getTransSpan $1 $5) (fromReverseList $3) $4 }
+| EXPRESSION_ASSIGNMENT_STATEMENT { $1 }
+| POINTER_ASSIGNMENT_STMT { $1 }
+| where '(' EXPRESSION ')' EXPRESSION_ASSIGNMENT_STATEMENT
+  { StWhere () (getTransSpan $1 $5) $3 $5 }
+| where '(' EXPRESSION ')' { StWhereConstruct () (getTransSpan $1 $4) Nothing $3 }
+| elsewhere '(' EXPRESSION ')' { StElsewhere () (getTransSpan $1 $4) Nothing (Just $3) }
+| elsewhere { StElsewhere () (getSpan $1) Nothing Nothing }
+| endwhere { StEndWhere () (getSpan $1) Nothing }
+| if '(' EXPRESSION ')' INTEGER_LITERAL ',' INTEGER_LITERAL ',' INTEGER_LITERAL
+  { StIfArithmetic () (getTransSpan $1 $9) $3 $5 $7 $9 }
+| do { StDo () (getSpan $1) Nothing Nothing Nothing }
+| id ':' do
+  { let TId s id = $1
+    in StDo () (getTransSpan s $3) (Just id) Nothing Nothing }
+| do INTEGER_LITERAL MAYBE_COMMA DO_SPECIFICATION
+  { StDo () (getTransSpan $1 $4) Nothing (Just $2) (Just $4) }
+| do DO_SPECIFICATION { StDo () (getTransSpan $1 $2) Nothing Nothing (Just $2) }
+| id ':' do DO_SPECIFICATION
+  { let TId s id = $1
+    in StDo () (getTransSpan s $4) (Just id) Nothing (Just $4) }
+| do INTEGER_LITERAL MAYBE_COMMA while '(' EXPRESSION ')'
+  { StDoWhile () (getTransSpan $1 $7) Nothing (Just $2) $6 }
+| do while '(' EXPRESSION ')'
+  { StDoWhile () (getTransSpan $1 $5) Nothing Nothing $4 }
+| id ':' do while '(' EXPRESSION ')'
+  { let TId s id = $1
+    in StDoWhile () (getTransSpan s $7) (Just id) Nothing $6 }
+| enddo { StEnddo () (getSpan $1) Nothing }
+| enddo id
+  { let TId s id = $2 in StEnddo () (getTransSpan $1 s) (Just id) }
+| cycle { StCycle () (getSpan $1) Nothing }
+| cycle VARIABLE { StCycle () (getTransSpan $1 $2) (Just $2) }
+| exit { StExit () (getSpan $1) Nothing }
+| exit VARIABLE { StExit () (getTransSpan $1 $2) (Just $2) }
+-- GO TO label
+| goto INTEGER_LITERAL { StGotoUnconditional () (getTransSpan $1 $2) $2 }
+-- GO TO label-list [,] scalar-int-expression
+| goto '(' INTEGERS ')' MAYBE_COMMA EXPRESSION
+  { StGotoComputed () (getTransSpan $1 $6) (fromReverseList $3) $6 }
+| continue { StContinue () (getSpan $1) }
+| stop { StStop () (getSpan $1) Nothing }
+| stop EXPRESSION { StStop () (getTransSpan $1 $2) (Just $2) }
+| if '(' EXPRESSION ')' EXECUTABLE_STATEMENT
+  { StIfLogical () (getTransSpan $1 $5) $3 $5 }
+| read CILIST IN_IOLIST
+  { let alist = fromReverseList $3
+    in StRead () (getTransSpan $1 alist) $2 (Just alist) }
+| read CILIST { StRead () (getTransSpan $1 $2) $2 Nothing }
+| read FORMAT_ID ',' IN_IOLIST
+  { let alist = fromReverseList $4
+    in StRead2 () (getTransSpan $1 alist) $2 (Just alist) }
+| read FORMAT_ID { StRead2 () (getTransSpan $1 $2) $2 Nothing }
+| write CILIST OUT_IOLIST
+  { let alist = fromReverseList $3
+    in StWrite () (getTransSpan $1 alist) $2 (Just alist) }
+| write CILIST { StWrite () (getTransSpan $1 $2) $2 Nothing }
+| print FORMAT_ID ',' OUT_IOLIST
+  { let alist = fromReverseList $4
+    in StPrint () (getTransSpan $1 alist) $2 (Just alist) }
+| print FORMAT_ID { StPrint () (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 }
+| call VARIABLE { StCall () (getTransSpan $1 $2) $2 Nothing }
+| call VARIABLE '(' ')' { StCall () (getTransSpan $1 $4) $2 Nothing }
+| call VARIABLE '(' ARGUMENTS ')'
+  { let alist = fromReverseList $4
+    in StCall () (getTransSpan $1 $5) $2 (Just alist) }
+| return { StReturn () (getSpan $1) Nothing }
+| return EXPRESSION { StReturn () (getTransSpan $1 $2) (Just $2) }
+| FORALL { $1 }
+| END_FORALL { $1 }
+
+ARGUMENTS :: { [ Argument A0 ] }
+: ARGUMENTS ',' ARGUMENT { $3 : $1 }
+| ARGUMENT { [ $1 ] }
+
+ARGUMENT :: { Argument A0 }
+: 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) }
+
+MAYBE_RENAME_LIST :: { Maybe (AList Use A0) }
+: RENAME_LIST { Just $ fromReverseList $1 }
+| {- empty -} { Nothing }
+
+RENAME_LIST :: { [ Use A0 ] }
+: RENAME_LIST ',' RENAME { $3 : $1 }
+| RENAME { [ $1 ] }
+
+RENAME :: { Use A0  }
+: VARIABLE '=>' VARIABLE { UseRename () (getTransSpan $1 $3) $1 $3 }
+| VARIABLE { UseID () (getSpan $1) $1 }
+| operator '(' opCustom ')'
+  { let TOpCustom ss op = $3
+    in UseID () (getTransSpan $1 $4) (ExpValue () ss (ValOperator op)) }
+| assignment { UseID () (getSpan $1) (ExpValue () (getSpan $1) ValAssignment) }
+
+MAYBE_DCOLON :: { () } : '::' { () } | {- EMPTY -} { () }
+
+FORMAT_ID :: { Expression A0 }
+: FORMAT_ID '/' '/' FORMAT_ID %prec CONCAT
+  { ExpBinary () (getTransSpan $1 $4) Concatenation $1 $4 }
+| INTEGER_LITERAL { $1 }
+| STRING { $1 }
+| DATA_REF { $1 }
+| '*' { ExpValue () (getSpan $1) ValStar }
+
+UNIT :: { Expression A0 }
+: INTEGER_LITERAL { $1 }
+| DATA_REF { $1 }
+| '*' { ExpValue () (getSpan $1) ValStar }
+
+CILIST :: { AList ControlPair A0 }
+: '(' CILIST_ELEMENT ',' FORMAT_ID ',' CILIST_PAIRS ')'
+  { let { cp1 = ControlPair () (getSpan $2) Nothing $2;
+          cp2 = ControlPair () (getSpan $4) Nothing $4;
+          tail = fromReverseList $6 }
+    in setSpan (getTransSpan $1 $7) $ cp1 `aCons` cp2 `aCons` tail }
+| '(' CILIST_ELEMENT ',' FORMAT_ID ')'
+  { let { cp1 = ControlPair () (getSpan $2) Nothing $2;
+          cp2 = ControlPair () (getSpan $4) Nothing $4 }
+    in AList () (getTransSpan $1 $5) [ cp1,  cp2 ] }
+| '(' CILIST_ELEMENT ',' CILIST_PAIRS ')'
+  { let { cp1 = ControlPair () (getSpan $2) Nothing $2;
+          tail = fromReverseList $4 }
+    in setSpan (getTransSpan $1 $5) $ cp1 `aCons` tail }
+| '(' CILIST_ELEMENT ')'
+  { let cp1 = ControlPair () (getSpan $2) Nothing $2
+    in AList () (getTransSpan $1 $3) [ cp1 ] }
+| '(' CILIST_PAIRS ')' { fromReverseList $2 }
+
+CILIST_PAIRS :: { [ ControlPair A0 ] }
+: CILIST_PAIRS ',' CILIST_PAIR { $3 : $1 }
+| CILIST_PAIR { [ $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 SIGN
+  { 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 }
+| 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 }
+| opCustom CI_EXPRESSION %prec DEFINED_UNARY
+  { let TOpCustom span str = $1
+    in ExpUnary () (getTransSpan span $2) (UnCustom str) $2 }
+| CI_EXPRESSION opCustom CI_EXPRESSION
+  { let TOpCustom _ str = $2
+    in ExpBinary () (getTransSpan $1 $3) (BinCustom str) $1 $3 }
+| '(' CI_EXPRESSION ')' { setSpan (getTransSpan $1 $3) $2 }
+| INTEGER_LITERAL { $1 }
+| LOGICAL_LITERAL { $1 }
+| STRING { $1 }
+| DATA_REF { $1 }
+
+{- p67 ALLOCATE statement -}
+MAYBE_ALLOC_OPT_LIST :: { Maybe (AList AllocOpt A0) }
+: ',' stat '=' EXPRESSION { Just (fromReverseList [AOStat () (getTransSpan $2 $4) $4]) }
+| {- empty -}             { Nothing }
+
+IN_IOLIST :: { [ Expression A0 ] }
+: IN_IOLIST ',' IN_IO_ELEMENT { $3 : $1}
+| IN_IO_ELEMENT { [ $1 ] }
+
+IN_IO_ELEMENT :: { Expression A0 }
+: DATA_REF { $1 }
+| '(' IN_IOLIST ',' DO_SPECIFICATION ')'
+  { ExpImpliedDo () (getTransSpan $1 $5) (fromReverseList $2) $4 }
+
+OUT_IOLIST :: { [ Expression A0 ] }
+: OUT_IOLIST ',' EXPRESSION { $3 : $1}
+| EXPRESSION { [ $1 ] }
+
+COMMON_GROUPS :: { [ CommonGroup A0 ] }
+: COMMON_GROUPS COMMON_GROUP { $2 : $1 }
+| COMMON_GROUPS ',2' COMMON_GROUP { $3 : $1 }
+| INIT_COMMON_GROUP { [ $1 ] }
+
+COMMON_GROUP :: { CommonGroup A0 }
+: COMMON_NAME UNINITIALIZED_DECLARATOR_LIST
+  { let alist = fromReverseList $2
+    in CommonGroup () (getTransSpan $1 alist) (Just $1) alist }
+| '/' '/' UNINITIALIZED_DECLARATOR_LIST
+  { let alist = fromReverseList $3
+    in CommonGroup () (getTransSpan $1 alist) Nothing alist }
+
+INIT_COMMON_GROUP :: { CommonGroup A0 }
+: COMMON_NAME UNINITIALIZED_DECLARATOR_LIST
+  { let alist = fromReverseList $2
+    in CommonGroup () (getTransSpan $1 alist) (Just $1) alist }
+| '/' '/' UNINITIALIZED_DECLARATOR_LIST
+  { let alist = fromReverseList $3
+    in CommonGroup () (getTransSpan $1 alist) Nothing alist }
+| UNINITIALIZED_DECLARATOR_LIST
+  { let alist = fromReverseList $1
+    in CommonGroup () (getSpan alist) Nothing alist }
+
+EQUIVALENCE_GROUPS :: { [ AList Expression A0 ] }
+: EQUIVALENCE_GROUPS ',' '(' PART_REFS ')'
+  { setSpan (getTransSpan $3 $5) (fromReverseList $4) : $1 }
+| '(' PART_REFS ')'
+  { [ setSpan (getTransSpan $1 $3) (fromReverseList $2) ] }
+
+NAMELISTS :: { [ Namelist A0 ] }
+: NAMELISTS NAMELIST { $2 : $1 }
+| NAMELISTS ',2' NAMELIST { $3 : $1 }
+| NAMELIST { [ $1 ] }
+
+NAMELIST :: { Namelist A0 }
+: '/' VARIABLE '/' VARIABLES
+  { Namelist () (getTransSpan $1 $4) $2 $ fromReverseList $4 }
+
+MAYBE_VARIABLES :: { Maybe (AList Expression A0) }
+: VARIABLES { Just $ fromReverseList $1 } | {- EMPTY -} { Nothing }
+
+VARIABLES :: { [ Expression A0 ] }
+: VARIABLES ',' VARIABLE { $3 : $1 }
+| VARIABLE { [ $1 ] }
+
+IMP_LISTS :: { [ ImpList A0 ] }
+: IMP_LISTS ',' IMP_LIST { $3 : $1 }
+| IMP_LIST { [ $1 ] }
+
+IMP_LIST :: { ImpList A0 }
+: TYPE_SPEC '(2' 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
+             }
+
+PARAMETER_ASSIGNMENTS :: { [ Declarator A0 ] }
+: PARAMETER_ASSIGNMENTS ',' PARAMETER_ASSIGNMENT { $3 : $1 }
+| PARAMETER_ASSIGNMENT { [ $1 ] }
+
+PARAMETER_ASSIGNMENT :: { Declarator A0 }
+: VARIABLE '=' EXPRESSION
+  { Declarator () (getTransSpan $1 $3) $1 ScalarDecl Nothing (Just $3) }
+
+DECLARATION_STATEMENT :: { Statement A0 }
+: TYPE_SPEC ATTRIBUTE_LIST '::' INITIALIZED_DECLARATOR_LIST
+  { let { mAttrAList = if null $2 then Nothing else Just $ fromReverseList $2;
+          declAList = fromReverseList $4 }
+    in StDeclaration () (getTransSpan $1 declAList) $1 mAttrAList declAList }
+| TYPE_SPEC INITIALIZED_DECLARATOR_LIST
+  { let { declAList = fromReverseList $2 }
+    in StDeclaration () (getTransSpan $1 declAList) $1 Nothing declAList }
+
+ATTRIBUTE_LIST :: { [ Attribute A0 ] }
+: ATTRIBUTE_LIST ',' ATTRIBUTE_SPEC { $3 : $1 }
+| {- EMPTY -} { [ ] }
+
+ATTRIBUTE_SPEC :: { Attribute A0 }
+: public { AttrPublic () (getSpan $1) }
+| private { AttrPrivate () (getSpan $1) }
+| allocatable { AttrAllocatable () (getSpan $1) }
+| dimension '(' DIMENSION_DECLARATORS ')'
+  { AttrDimension () (getTransSpan $1 $4) (aReverse $3) }
+| external { AttrExternal () (getSpan $1) }
+| intent '(' INTENT_CHOICE ')' { AttrIntent () (getTransSpan $1 $4) $3 }
+| intrinsic { AttrIntrinsic () (getSpan $1) }
+| optional { AttrOptional () (getSpan $1) }
+| pointer { AttrPointer () (getSpan $1) }
+| parameter { AttrParameter () (getSpan $1) }
+| save { AttrSave () (getSpan $1) }
+| target { AttrTarget () (getSpan $1) }
+| value { AttrValue () (getSpan $1) }
+| volatile { AttrVolatile () (getSpan $1) }
+
+INTENT_CHOICE :: { Intent } : in { In } | out { Out } | inout { InOut }
+
+DATA_GROUPS :: { [ DataGroup A0 ] }
+: DATA_GROUPS MAYBE_COMMA DATA_LIST slash EXPRESSION_LIST slash
+  { let { nameAList = fromReverseList $3;
+          dataAList = fromReverseList $5 }
+    in DataGroup () (getTransSpan nameAList $6) nameAList dataAList : $1 }
+| DATA_LIST slash EXPRESSION_LIST slash
+  { let { nameAList = fromReverseList $1;
+          dataAList = fromReverseList $3 }
+    in [ DataGroup () (getTransSpan nameAList $4) nameAList dataAList ] }
+
+MAYBE_COMMA :: { () } : ',' { () } | {- EMPTY -} { () }
+
+DATA_LIST :: { [ Expression A0 ] }
+: DATA_LIST ',' DATA_ELEMENT { $3 : $1 }
+| DATA_ELEMENT { [ $1 ] }
+
+DATA_ELEMENT :: { Expression A0 }
+: DATA_REF { $1 } | IMPLIED_DO { $1 }
+
+SAVE_ARGS :: { [ Expression A0 ] }
+: SAVE_ARGS ',' SAVE_ARG { $3 : $1 } | SAVE_ARG { [ $1 ] }
+
+SAVE_ARG :: { Expression A0 } : COMMON_NAME { $1 } | VARIABLE { $1 }
+
+COMMON_NAME :: { Expression A0 }
+: '/' VARIABLE '/' { setSpan (getTransSpan $1 $3) $2 }
+
+INITIALIZED_DECLARATOR_LIST :: { [ Declarator A0 ] }
+: INITIALIZED_DECLARATOR_LIST ',' INITIALIZED_DECLARATOR { $3 : $1 }
+| INITIALIZED_DECLARATOR { [ $1 ] }
+
+UNINITIALIZED_DECLARATOR_LIST :: { [ Declarator A0 ] }
+: UNINITIALIZED_DECLARATOR_LIST ',' DECLARATOR { $3 : $1 }
+| DECLARATOR { [ $1 ] }
+
+INITIALIZED_DECLARATOR :: { Declarator A0 }
+: DECLARATOR '=' EXPRESSION { setInitialisation $1 $3 }
+| DECLARATOR '=>' EXPRESSION { setInitialisation $1 $3 }
+| DECLARATOR { $1 }
+
+DECLARATOR :: { Declarator A0 }
+: VARIABLE
+  {     Declarator () (getSpan $1)         $1 ScalarDecl                Nothing     Nothing }
+| VARIABLE '*' EXPRESSION
+  {     Declarator () (getTransSpan $1 $3) $1 ScalarDecl                (Just $3)   Nothing }
+| VARIABLE '*' '(' '*' ')'
+  { let star = ExpValue () (getSpan $4) ValStar
+     in Declarator () (getTransSpan $1 $5) $1 ScalarDecl                (Just star) Nothing }
+| VARIABLE '(' DIMENSION_DECLARATORS ')'
+  {     Declarator () (getTransSpan $1 $4) $1 (ArrayDecl (aReverse $3)) Nothing     Nothing }
+| VARIABLE '(' DIMENSION_DECLARATORS ')' '*' EXPRESSION
+  {     Declarator () (getTransSpan $1 $6) $1 (ArrayDecl (aReverse $3)) (Just $6)   Nothing }
+-- nonstandard char array syntax (wrong order for dimensions & charlen)
+| VARIABLE '*' EXPRESSION '(' DIMENSION_DECLARATORS ')'
+  {     Declarator () (getTransSpan $1 $6) $1 (ArrayDecl (aReverse $5)) (Just $3)   Nothing }
+| VARIABLE '(' DIMENSION_DECLARATORS ')' '*' '(' '*' ')'
+  { let star = ExpValue () (getSpan $7) ValStar
+     in Declarator () (getTransSpan $1 $8) $1 (ArrayDecl (aReverse $3)) (Just star) 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 ':' EXPRESSION
+  { DimensionDeclarator () (getTransSpan $1 $3) (Just $1) (Just $3) }
+| EXPRESSION { DimensionDeclarator () (getSpan $1) Nothing (Just $1) }
+-- Lower bound only
+| EXPRESSION ':'
+  { DimensionDeclarator () (getTransSpan $1 $2) (Just $1) Nothing }
+| EXPRESSION ':' '*'
+  { let { span = getSpan $3;
+          star = ExpValue () span ValStar }
+    in DimensionDeclarator () (getTransSpan $1 span) (Just $1) (Just star) }
+| '*'
+  { let { span = getSpan $1;
+          star = ExpValue () span ValStar }
+    in DimensionDeclarator () span Nothing (Just star) }
+| ':'
+  { let span = getSpan $1
+    in DimensionDeclarator () span Nothing 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 }
+| complex   KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeComplex $2 }
+| character CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeCharacter $2 }
+| logical   KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeLogical $2 }
+| type      '(' id ')'
+  { let TId _ id = $3
+    in TypeSpec () (getTransSpan $1 $4) (TypeCustom id) Nothing }
+
+KIND_SELECTOR :: { Maybe (Selector A0) }
+: '(' EXPRESSION ')'
+  { Just $ Selector () (getTransSpan $1 $3) Nothing (Just $2) }
+| '(' kind '=' EXPRESSION ')'
+  { Just $ Selector () (getTransSpan $1 $5) Nothing (Just $4) }
+| '*' EXPRESSION -- non-standard but commonly used extension
+  { Just $ Selector () (getTransSpan $1 $2) Nothing (Just $2) }
+| {- EMPTY -} { Nothing }
+
+CHAR_SELECTOR :: { Maybe (Selector A0) }
+: '*' EXPRESSION
+  { Just $ Selector () (getTransSpan $1 $2) (Just $2) Nothing }
+-- The following rule is a bug in the spec.
+-- | '*' EXPRESSION ','
+--   { Just $ Selector () (getTransSpan $1 $2) (Just $2) Nothing }
+| '*' '(' '*' ')'
+  { let star = ExpValue () (getSpan $3) ValStar
+    in Just $ Selector () (getTransSpan $1 $4) (Just star) Nothing }
+| '(' LEN_EXPRESSION ')'
+  { Just $ Selector () (getTransSpan $1 $3) (Just $2) Nothing }
+| '(' len '=' LEN_EXPRESSION ')'
+  { Just $ Selector () (getTransSpan $1 $5) (Just $4) Nothing }
+| '(' kind '=' EXPRESSION ')'
+  { Just $ Selector () (getTransSpan $1 $5) Nothing (Just $4) }
+| '(' LEN_EXPRESSION ',' EXPRESSION ')'
+  { Just $ Selector () (getTransSpan $1 $5) (Just $2) (Just $4) }
+| '(' LEN_EXPRESSION ',' kind '=' EXPRESSION ')'
+  { Just $ Selector () (getTransSpan $1 $7) (Just $2) (Just $6) }
+| '(' len '=' LEN_EXPRESSION ',' kind '=' EXPRESSION ')'
+  { Just $ Selector () (getTransSpan $1 $9) (Just $4) (Just $8) }
+| '(' kind '=' EXPRESSION ',' len '=' LEN_EXPRESSION ')'
+  { Just $ Selector () (getTransSpan $1 $9) (Just $8) (Just $4) }
+| {- EMPTY -} { Nothing }
+
+LEN_EXPRESSION :: { Expression A0 }
+: EXPRESSION { $1 }
+| '*' { ExpValue () (getSpan $1) ValStar }
+
+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 SIGN
+  { 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 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 }
+| opCustom EXPRESSION %prec DEFINED_UNARY
+  { let TOpCustom span str = $1
+    in ExpUnary () (getTransSpan span $2) (UnCustom str) $2 }
+| EXPRESSION opCustom EXPRESSION
+  { let TOpCustom _ str = $2
+    in ExpBinary () (getTransSpan $1 $3) (BinCustom str) $1 $3 }
+| '(' EXPRESSION ')' { setSpan (getTransSpan $1 $3) $2 }
+| NUMERIC_LITERAL                   { $1 }
+| '(' EXPRESSION ',' EXPRESSION ')'
+  { ExpValue () (getTransSpan $1 $5) (ValComplex $2 $4) }
+| LOGICAL_LITERAL                   { $1 }
+| STRING                            { $1 }
+| DATA_REF                          { $1 }
+| IMPLIED_DO                        { $1 }
+| '(/' EXPRESSION_LIST '/)'
+  { ExpInitialisation () (getTransSpan $1 $3) (fromReverseList $2) }
+| operator '(' opCustom ')'
+  { let TOpCustom _ op = $3
+    in ExpValue () (getTransSpan $1 $4) (ValOperator op) }
+| assignment { ExpValue () (getSpan $1) ValAssignment }
+| '*' INTEGER_LITERAL { ExpReturnSpec () (getTransSpan $1 $2) $2 }
+
+DATA_REFS :: { [ Expression A0 ] }
+: DATA_REFS ',' DATA_REF { $3 : $1 }
+| DATA_REF { [ $1 ] }
+
+DATA_REF :: { Expression A0 }
+: DATA_REF '%' PART_REF { ExpDataRef () (getTransSpan $1 $3) $1 $3 }
+| PART_REF { $1 }
+
+PART_REFS :: { [ Expression A0 ] }
+: PART_REFS ',' PART_REF { $3 : $1 }
+| PART_REF { [ $1 ] }
+
+PART_REF :: { Expression A0 }
+: VARIABLE { $1 }
+| VARIABLE '(' ')'
+  { ExpFunctionCall () (getTransSpan $1 $3) $1 Nothing }
+| VARIABLE '(' INDICIES ')'
+  { ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3) }
+| VARIABLE '(' INDICIES ')' '(' INDICIES ')'
+  { let innerSub = ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3)
+    in ExpSubscript () (getTransSpan $1 $7) innerSub (fromReverseList $6) }
+
+INDICIES :: { [ Index A0 ] }
+: INDICIES ',' INDEX { $3 : $1 }
+| INDEX { [ $1 ] }
+
+INDEX :: { Index A0 }
+: RANGE { $1 }
+| RANGE ':' EXPRESSION
+  { let IxRange () s lower upper _ = $1
+    in IxRange () (getTransSpan s $3) lower upper (Just $3) }
+| EXPRESSION { IxSingle () (getSpan $1) Nothing $1 }
+-- Following is only as an intermediate stage before having been turned into
+-- an argument by later transformation.
+| id '=' EXPRESSION
+  { let TId s id = $1 in IxSingle () (getTransSpan $1 s) (Just id) $3 }
+
+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 }
+
+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 }
+
+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 }
+
+FORALL :: { Statement A0 }
+: id ':' forall FORALL_HEADER {
+  let (TId s1 id) = $1 in
+  let (h,s2) = $4 in
+  StForall () (getTransSpan s1 s2) (Just id) h
+}
+| forall FORALL_HEADER {
+  let (h,s) = $2 in
+  StForall () (getTransSpan $1 s) Nothing h
+}
+| forall FORALL_HEADER FORALL_ASSIGNMENT_STMT {
+  let (h,_) = $2 in
+  StForallStatement () (getTransSpan $1 $3) h $3
+}
+
+FORALL_HEADER
+  :: { (ForallHeader A0, SrcSpan) }
+FORALL_HEADER :
+  -- Standard simple forall header
+    '(' FORALL_TRIPLET_SPEC ')'   { (ForallHeader [$2] Nothing, getTransSpan $1 $3) }
+  -- forall header with scale expression
+  | '(' '(' FORALL_TRIPLET_SPEC ')' ',' EXPRESSION ')'
+                                  { (ForallHeader [$3] (Just $6), getTransSpan $1 $7) }
+  -- multi forall header
+  | '(' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE ')'
+                                  { (ForallHeader $2 Nothing, getTransSpan $1 $3) }
+  -- multi forall header with scale
+  | '(' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE ',' EXPRESSION ')'
+                                  { (ForallHeader $2 (Just $4), getTransSpan $1 $5) }
+
+FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE
+  :: { [(Name, Expression A0, Expression A0, Maybe (Expression A0))] }
+FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE
+: '(' FORALL_TRIPLET_SPEC ')' ',' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE { $2 : $5 }
+| {- empty -}                                                          { [] }
+
+FORALL_TRIPLET_SPEC :: { (Name, Expression A0, Expression A0, Maybe (Expression A0)) }
+FORALL_TRIPLET_SPEC
+: NAME '=' EXPRESSION ':' EXPRESSION { ($1, $3, $5, Nothing) }
+| NAME '=' EXPRESSION ':' EXPRESSION ',' EXPRESSION { ($1, $3, $5, Just $7) }
+
+FORALL_ASSIGNMENT_STMT :: { Statement A0 }
+FORALL_ASSIGNMENT_STMT :
+    EXPRESSION_ASSIGNMENT_STATEMENT { $1 }
+  | POINTER_ASSIGNMENT_STMT { $1 }
+
+POINTER_ASSIGNMENT_STMT :: { Statement A0 }
+POINTER_ASSIGNMENT_STMT :
+ DATA_REF '=>' EXPRESSION { StPointerAssign () (getTransSpan $1 $3) $1 $3 }
+
+END_FORALL :: { Statement A0 }
+END_FORALL :
+   endforall    { StEndForall () (getSpan $1) Nothing }
+ | endforall id { let (TId s id) = $2 in StEndForall () (getTransSpan $1 s) (Just id)}
+
+EXPRESSION_LIST :: { [ Expression A0 ] }
+: EXPRESSION_LIST ',' EXPRESSION { $3 : $1 }
+| EXPRESSION { [ $1 ] }
+
+ARITHMETIC_SIGN :: { (SrcSpan, UnaryOp) }
+: '-' { (getSpan $1, Minus) }
+| '+' { (getSpan $1, Plus) }
+
+RELATIONAL_OPERATOR :: { BinaryOp }
+: '=='  { EQ }
+| '!='  { NE }
+| '>'   { GT }
+| '>='  { GTE }
+| '<'   { LT }
+| '<='  { LTE }
+
+VARIABLE :: { Expression A0 }
+: id { ExpValue () (getSpan $1) $ let (TId _ s) = $1 in ValVariable s }
+
+NUMERIC_LITERAL :: { Expression A0 }
+: INTEGER_LITERAL { $1 } | REAL_LITERAL { $1 }
+
+INTEGERS :: { [ Expression A0 ] }
+: INTEGERS ',' INTEGER_LITERAL { $3 : $1 }
+| INTEGER_LITERAL { [ $1 ] }
+
+INTEGER_LITERAL :: { Expression A0 }
+: int
+  { let TIntegerLiteral s i = $1
+     in ExpValue () s $ ValInteger i Nothing   }
+| int '_' KIND_PARAM
+  { let TIntegerLiteral s i = $1
+     in ExpValue () s $ ValInteger i (Just $3) }
+| boz { let TBozLiteral s b = $1 in ExpValue () s $ ValBoz b }
+
+REAL_LITERAL :: { Expression A0 }
+: float
+  { let TRealLiteral s r = $1
+     in ExpValue () s $ ValReal r Nothing }
+| float '_' KIND_PARAM
+  { let TRealLiteral s r = $1
+     in ExpValue () s $ ValReal r (Just $3) }
+
+LOGICAL_LITERAL :: { Expression A0 }
+: bool
+  { let TLogicalLiteral s b = $1
+     in ExpValue () s (ValLogical b Nothing) }
+| bool '_' KIND_PARAM
+  { let TLogicalLiteral s b = $1
+     in ExpValue () s (ValLogical b (Just $3)) }
+
+KIND_PARAM :: { Expression A0 }
+: INTEGER_LITERAL { $1 }
+| VARIABLE        { $1 }
+
+STRING :: { Expression A0 }
+: string { let TString s c = $1 in ExpValue () s $ ValString c }
+
+cDATA :: { () } : {% pushContext ConData }
+cIMPLICIT :: { () } : {% pushContext ConImplicit }
+cNAMELIST :: { () } : {% pushContext ConNamelist }
+cCOMMON :: { () } : {% pushContext ConCommon }
+cPOP :: { () } : {% popContext }
diff --git a/src/Language/Fortran/Parser/Free/Lexer.x b/src/Language/Fortran/Parser/Free/Lexer.x
new file mode 100644
--- /dev/null
+++ b/src/Language/Fortran/Parser/Free/Lexer.x
@@ -0,0 +1,1377 @@
+-- -*- Mode: Haskell -*-
+-- vim: ft=haskell
+{
+{-# LANGUAGE UndecidableInstances #-}
+
+module Language.Fortran.Parser.Free.Lexer
+  (
+  -- * Main interface
+    lexer, Token(..), vanillaAlexInput, AlexInput(..), LexAction
+
+  -- * Internals
+  , lexer'
+  , StartCode(..)
+  , StartCodeStatus(..)
+  , scN
+  ) 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.Parser.Monad
+import Language.Fortran.Version
+import Language.Fortran.Util.Position
+import Language.Fortran.Util.FirstParameter
+import Language.Fortran.AST.RealLit (RealLit, parseRealLit)
+import Language.Fortran.AST.Boz
+import Language.Fortran.Parser.LexerUtils ( readIntOrBoz )
+
+}
+
+$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 :: String -> B.ByteString -> AlexInput
+vanillaAlexInput fn bs = AlexInput
+  { aiSourceBytes          = bs
+  , aiPosition             = initPosition { filePath = fn }
+  , aiEndOffset            = B.length bs
+  , 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:_
+      | 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
+
+--------------------------------------------------------------------------------
+-- 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
+
+}
diff --git a/src/Language/Fortran/Parser/Free/Utils.hs b/src/Language/Fortran/Parser/Free/Utils.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Fortran/Parser/Free/Utils.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE CPP #-}
+module Language.Fortran.Parser.Free.Utils where
+
+import Language.Fortran.Parser.Free.Lexer
+import Language.Fortran.Parser.Monad
+import Control.Monad.State
+
+unitNameCheck :: Token -> String -> Parse AlexInput Token ()
+unitNameCheck (TId _ name1) name2
+  | name1 == name2 = return ()
+  | otherwise = fail "Unit name does not match the corresponding END statement."
+unitNameCheck _ _ = return ()
+
+parseError :: Token -> LexAction a
+parseError _ = do
+    parseState <- get
+#ifdef DEBUG
+    tokens <- reverse <$> aiPreviousTokensInLine <$> getAlex
+#endif
+    fail $ psFilename parseState ++ ": parsing failed. "
+#ifdef DEBUG
+      ++ '\n' : show tokens
+#endif
diff --git a/src/Language/Fortran/Parser/LexerUtils.hs b/src/Language/Fortran/Parser/LexerUtils.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Fortran/Parser/LexerUtils.hs
@@ -0,0 +1,18 @@
+{-| Utils for both lexers. -}
+module Language.Fortran.Parser.LexerUtils ( readIntOrBoz ) where
+
+import Language.Fortran.AST.Boz
+import Numeric
+
+-- | Read a string as either a signed integer, or a BOZ constant (positive).
+--
+-- Useful in manual lexing.
+readIntOrBoz :: String -> Integer
+readIntOrBoz s = do
+    case readSToMaybe $ readSigned readDec s of
+      Just int -> int
+      Nothing  -> bozAsNatural $ parseBoz s
+
+readSToMaybe :: [(a, b)] -> Maybe a
+readSToMaybe = \case (x, _):_ -> Just x
+                     _        -> Nothing
diff --git a/src/Language/Fortran/Parser/Monad.hs b/src/Language/Fortran/Parser/Monad.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Fortran/Parser/Monad.hs
@@ -0,0 +1,224 @@
+{-| Parser/lexer monad, plus common functionality and definitions. -}
+
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE CPP #-}
+
+module Language.Fortran.Parser.Monad where
+
+#if !MIN_VERSION_base(4,13,0)
+-- Control.Monad.Fail import is redundant since GHC 8.8.1
+import qualified Control.Monad.Fail as Fail
+import Control.Monad.Fail (MonadFail)
+#endif
+
+import Language.Fortran.Version
+import Language.Fortran.Util.Position
+
+import Control.Exception
+import GHC.IO.Exception ( IOException(..), IOErrorType(..) )
+import Control.Monad.State hiding (state)
+import Control.Monad.Except
+import Data.Typeable
+
+-------------------------------------------------------------------------------
+-- Helper datatype definitions
+-------------------------------------------------------------------------------
+
+data ParanthesesCount = ParanthesesCount
+  { pcActual :: Integer
+  , pcHasReached0 :: Bool }
+  deriving (Show, Eq)
+
+data Context =
+    ConStart
+  | ConData
+  | ConImplicit
+  | ConNamelist
+  | ConCommon
+  deriving (Show, Eq)
+
+data ParseState a = ParseState
+  { psAlexInput :: a
+  , psParanthesesCount :: ParanthesesCount
+  , psVersion :: FortranVersion  -- To differentiate lexing behaviour
+  , psFilename :: String -- To save correct source location in AST
+  , psContext :: [ Context ]
+  }
+  deriving (Show)
+
+data ParseError a b = ParseError
+  { errPos        :: Position
+  , errLastToken  :: Maybe b
+  , errFilename   :: String
+  , errMsg        :: String }
+
+instance Show b => Show (ParseError a b) where
+  show err = show (errPos err) ++ ": " ++ errMsg err ++ lastTokenMsg
+    where lastTokenMsg = tokenMsg (errLastToken err)
+
+tokenMsg :: Show a => Maybe a -> String
+tokenMsg (Just a) = "Last parsed token: " ++ show a ++ "."
+tokenMsg Nothing = "No token had been lexed."
+
+data ParseResult b c a = ParseOk a (ParseState b) | ParseFailed (ParseError b c)
+    deriving stock (Functor)
+
+instance (Typeable a, Typeable b, Show a, Show b) => Exception (ParseError a b)
+
+-- Provides a way to aggregate errors that come
+-- from parses with different token types
+data ParseErrorSimple = ParseErrorSimple
+  { errorPos      :: Position
+  , errorFilename :: String
+  , errorMsg      :: String
+  } deriving (Exception)
+
+instance Show ParseErrorSimple where
+  show err = errorFilename err ++ ", " ++ show (errorPos err) ++ ": " ++ errorMsg err
+
+class LastToken a b | a -> b where
+  getLastToken :: (Show b) => a -> Maybe b
+
+class Tok a where
+  eofToken :: a -> Bool
+
+-------------------------------------------------------------------------------
+-- Parser Monad definition
+-------------------------------------------------------------------------------
+
+newtype Parse b c a = Parse { unParse :: ParseState b -> ParseResult b c a }
+
+instance (Loc b, LastToken b c, Show c) => Monad (Parse b c) where
+  return a = Parse $ \s -> ParseOk a s
+
+  (Parse m) >>= f = Parse $ \s ->
+    case m s of
+      ParseOk a s' -> unParse (f a) s'
+      ParseFailed e -> ParseFailed e
+
+#if !MIN_VERSION_base(4,13,0)
+  -- Monad(fail) was removed in GHC 8.8.1
+  fail = Fail.fail
+#endif
+
+instance (Loc b, LastToken b c, Show c) => MonadFail (Parse b c) where
+  fail msg = Parse $ \s -> ParseFailed ParseError
+    { errPos        = (getPos . psAlexInput) s
+    , errLastToken  = (getLastToken . psAlexInput) s
+    , errFilename   = psFilename s
+    , errMsg        = msg }
+
+instance (Loc b, LastToken b c, Show c) => Functor (Parse b c) where
+  fmap = liftM
+
+instance (Loc b, LastToken b c, Show c) => Applicative (Parse b c) where
+  pure  = return
+  (<*>) = ap
+
+instance (Loc b, LastToken b c, Show c) => MonadState (ParseState b) (Parse b c) where
+  get = Parse $ \s -> ParseOk s s
+  put s = Parse $ \_ -> ParseOk () s
+
+instance (Loc b, LastToken b c, Show c) => MonadError (ParseError b c) (Parse b c) where
+  throwError e = Parse $ \_ -> ParseFailed e
+
+  (Parse m) `catchError` f = Parse $ \s ->
+    case m s of
+      ParseFailed e -> unParse (f e) s
+      m' -> m'
+
+
+runParse
+    :: (Loc b, LastToken b c, Show c)
+    => Parse b c a -> ParseState b -> ParseResult b c a
+runParse = unParse
+
+runParseUnsafe
+    :: (Loc b, LastToken b c, Show c)
+    => Parse b c a -> ParseState b -> (a, ParseState b)
+runParseUnsafe lexer initState =
+  case unParse lexer initState of
+    ParseOk a s -> (a, s)
+    ParseFailed e -> throwIOError $ show e
+
+throwIOError :: String -> a
+throwIOError s = throw
+  IOError { ioe_handle      = Nothing
+          , ioe_type        = UserError
+          , ioe_location    = "fortran-src"
+          , ioe_description = s
+          , ioe_errno       = Nothing
+          , ioe_filename    = Nothing }
+
+evalParse
+    :: (Loc b, LastToken b c, Show c)
+    => Parse b c a -> ParseState b -> a
+evalParse m s = fst (runParseUnsafe m s)
+
+execParse
+    :: (Loc b, LastToken b c, Show c)
+    => Parse b c a -> ParseState b -> ParseState b
+execParse m s = snd (runParseUnsafe m s)
+
+-------------------------------------------------------------------------------
+-- Parser helper functions
+-------------------------------------------------------------------------------
+
+getVersion :: (Loc a, LastToken a b, Show b) => Parse a b FortranVersion
+getVersion = do
+  s <- get
+  return (psVersion s)
+
+putAlex :: (Loc a, LastToken a b, Show b) => a -> Parse a b ()
+putAlex ai = do
+  s <- get
+  put (s { psAlexInput = ai })
+
+getAlex :: (Loc a, LastToken a b, Show b) => Parse a b a
+getAlex = do
+  s <- get
+  return (psAlexInput s)
+
+topContext :: (Loc a, LastToken a b, Show b) => Parse a b Context
+topContext = head . psContext <$> get
+
+popContext :: (Loc a, LastToken a b, Show b) => Parse a b ()
+popContext = modify $ \ps -> ps { psContext = tail $ psContext ps }
+
+pushContext :: (Loc a, LastToken a b, Show b) => Context -> Parse a b ()
+pushContext context = modify $ \ps -> ps { psContext = context : psContext ps }
+
+getPosition :: (Loc a, LastToken a b, Show b) => Parse a b Position
+getPosition = do
+  parseState <- get
+  return $ getPos $ psAlexInput parseState
+
+getSrcSpan :: (Loc a, LastToken a b, Show b) => Position -> Parse a b SrcSpan
+getSrcSpan loc1 = do
+  loc2 <- getPosition
+  return $ SrcSpan loc1 loc2
+
+getParanthesesCount :: (Loc a, LastToken a b, Show b) => Parse a b ParanthesesCount
+getParanthesesCount = psParanthesesCount <$> get
+
+resetPar :: (Loc a, LastToken a b, Show b) => Parse a b ()
+resetPar = do
+  ps <- get
+  put $ ps { psParanthesesCount = ParanthesesCount 0 False }
+
+incPar :: (Loc a, LastToken a b, Show b) => Parse a b ()
+incPar = do
+  ps <- get
+  let pc = psParanthesesCount ps
+  let count = pcActual pc
+  put $ ps { psParanthesesCount = pc { pcActual = count + 1 } }
+
+decPar :: (Loc a, LastToken a b, Show b) => Parse a b ()
+decPar = do
+  ps <- get
+  let pc = psParanthesesCount ps
+  let newCount = pcActual pc - 1
+  let reached0 = pcHasReached0 pc || newCount == 0
+  put $ ps { psParanthesesCount = ParanthesesCount newCount reached0 }
diff --git a/src/Language/Fortran/Parser/Utils.hs b/src/Language/Fortran/Parser/Utils.hs
deleted file mode 100644
--- a/src/Language/Fortran/Parser/Utils.hs
+++ /dev/null
@@ -1,47 +0,0 @@
-{-| Simple module to provide functions that read Fortran literals -}
-module Language.Fortran.Parser.Utils
-  ( readReal
-  , readInteger
-  ) where
-
-import           Data.Char
-import           Numeric
-
-breakAtDot :: String -> (String, String)
-replaceDwithE :: Char -> Char
-readsToMaybe :: [(a, b)] -> Maybe a
-fixAtDot :: (String, String) -> (String, String)
-fixAtDot' :: (String, String) -> (String, String)
-combineAtDot :: (String, String) -> String
-
--- | Convert a Fortran literal Real into a Haskell Double.
-readReal :: String -> Maybe Double
-readReal = readsToMaybe . reads . filter (/= '+') . combineAtDot . fixAtDot . breakAtDot . map replaceDwithE . takeWhile (/= '_')
-
--- | Convert a Fortran literal Integer into a Haskell Integer.
-readInteger :: String -> Maybe Integer
-readInteger s = readsToMaybe $ case s' of
-  'b':_ -> readInt 2 (`elem` "01") digitToInt (drop 2 s')
-  'o':_ -> readInt 8 (`elem` ['0'..'7']) digitToInt (drop 2 s')
-  'z':_ -> readInt 16 (`elem` (['0'..'9'] ++ ['A'..'F'] ++ ['a'..'f'])) digitToInt (drop 2 s')
-  _     -> readSigned readDec s'
-  where
-    s' = filter (/= '+') . takeWhile (/= '_') $ s
-
-fixAtDot' ("", r)                      = ("0", r)
-fixAtDot' ("-", r)                     = ("-0", r)
-fixAtDot' (l, "")                      = (l, "0")
-fixAtDot' (l, r0:r) | not (isDigit r0) = (l, '0':r0:r)
-fixAtDot' x                            = x
-
-combineAtDot (a, b) = a ++ "." ++ b
-fixAtDot x
-  | x == x'         = x
-  | otherwise       = fixAtDot x' where x' = fixAtDot' x
-breakAtDot          = fmap (drop 1) . break (=='.')
-replaceDwithE 'd'   = 'e'
-replaceDwithE c     = c
-
-readsToMaybe r = case r of
-  (x, _):_ -> Just x
-  _ -> Nothing
diff --git a/src/Language/Fortran/ParserMonad.hs b/src/Language/Fortran/ParserMonad.hs
deleted file mode 100644
--- a/src/Language/Fortran/ParserMonad.hs
+++ /dev/null
@@ -1,276 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE CPP #-}
-
-module Language.Fortran.ParserMonad
-  ( module Language.Fortran.ParserMonad
-  , module Language.Fortran.Version -- TODO: temporary plug to avoid API change
-  ) where
-
-#if !MIN_VERSION_base(4,13,0)
--- Control.Monad.Fail import is redundant since GHC 8.8.1
-import qualified Control.Monad.Fail as Fail
-import Control.Monad.Fail (MonadFail)
-#endif
-
-import Language.Fortran.Version
-
-import GHC.IO.Exception
-import Control.Exception
-
-import Control.Monad.State hiding (state)
-import Control.Monad.Except
-
-import Data.Typeable
-import Language.Fortran.Util.Position
-
--------------------------------------------------------------------------------
--- Helper datatype definitions
--------------------------------------------------------------------------------
-
-data ParanthesesCount = ParanthesesCount
-  { pcActual :: Integer
-  , pcHasReached0 :: Bool }
-  deriving (Show, Eq)
-
-data Context =
-    ConStart
-  | ConData
-  | ConImplicit
-  | ConNamelist
-  | ConCommon
-  deriving (Show, Eq)
-
-data ParseState a = ParseState
-  { psAlexInput :: a
-  , psParanthesesCount :: ParanthesesCount
-  , psVersion :: FortranVersion  -- To differentiate lexing behaviour
-  , psFilename :: String -- To save correct source location in AST
-  , psContext :: [ Context ]
-  }
-  deriving (Show)
-
-data ParseError a b = ParseError
-  { errPos        :: Position
-  , errLastToken  :: Maybe b
-  , errFilename   :: String
-  , errMsg        :: String }
-
-
-instance Show b => Show (ParseError a b) where
-  show err = show (errPos err) ++ ": " ++ errMsg err ++ lastTokenMsg
-    where
-      lastTokenMsg = tokenMsg (errLastToken err)
-
-tokenMsg :: Show a => Maybe a -> String
-tokenMsg (Just a) = "Last parsed token: " ++ show a ++ "."
-tokenMsg Nothing = "No token had been lexed."
-
-instance Functor (ParseResult b c) where
-    fmap f (ParseOk a s) = ParseOk (f a) s
-    fmap _ (ParseFailed err) = ParseFailed err
-
-instance (Typeable a, Typeable b, Show a, Show b) => Exception (ParseError a b)
-
-data ParseResult b c a = ParseOk a (ParseState b) | ParseFailed (ParseError b c)
-
--- Provides a way to aggregate errors that come
--- from parses with different token types
-data ParseErrorSimple = ParseErrorSimple
-  { errorPos      :: Position
-  , errorFilename :: String
-  , errorMsg      :: String }
-
-fromParseResultUnsafe :: (Show c) => ParseResult b c a -> a
-fromParseResultUnsafe (ParseOk a _) = a
-fromParseResultUnsafe (ParseFailed err) = throwIOerror $ show err
-
-fromRight :: Show a => Either a b -> b
-fromRight (Left x)  = throwIOerror . show $ x
-fromRight (Right x) = x
-
-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)  }
-
-instance Show ParseErrorSimple where
-  show err = errorFilename err ++ ", " ++ show (errorPos err) ++ ": " ++ errorMsg err
-
-class LastToken a b | a -> b where
-  getLastToken :: (Show b) => a -> Maybe b
-
--------------------------------------------------------------------------------
--- Parser Monad definition
--------------------------------------------------------------------------------
-
-newtype Parse b c a = Parse { unParse :: ParseState b -> ParseResult b c a }
-
-instance (Loc b, LastToken b c, Show c) => Monad (Parse b c) where
-  return a = Parse $ \s -> ParseOk a s
-
-  (Parse m) >>= f = Parse $ \s ->
-    case m s of
-      ParseOk a s' -> unParse (f a) s'
-      ParseFailed e -> ParseFailed e
-
-#if !MIN_VERSION_base(4,13,0)
-  -- Monad(fail) was removed in GHC 8.8.1
-  fail = Fail.fail
-#endif
-
-instance (Loc b, LastToken b c, Show c) => MonadFail (Parse b c) where
-  fail msg = Parse $ \s -> ParseFailed ParseError
-    { errPos        = (getPos . psAlexInput) s
-    , errLastToken  = (getLastToken . psAlexInput) s
-    , errFilename   = psFilename s
-    , errMsg        = msg }
-
-instance (Loc b, LastToken b c, Show c) => Functor (Parse b c) where
-  fmap = liftM
-
-instance (Loc b, LastToken b c, Show c) => Applicative (Parse b c) where
-  pure  = return
-  (<*>) = ap
-
-instance (Loc b, LastToken b c, Show c) => MonadState (ParseState b) (Parse b c) where
-  get = Parse $ \s -> ParseOk s s
-  put s = Parse $ \_ -> ParseOk () s
-
-instance (Loc b, LastToken b c, Show c) => MonadError (ParseError b c) (Parse b c) where
-  throwError e = Parse $ \_ -> ParseFailed e
-
-  (Parse m) `catchError` f = Parse $ \s ->
-    case m s of
-      ParseFailed e -> unParse (f e) s
-      m' -> m'
-
--------------------------------------------------------------------------------
--- Parser helper functions
--------------------------------------------------------------------------------
-
-getVersion :: (Loc a, LastToken a b, Show b) => Parse a b FortranVersion
-getVersion = do
-  s <- get
-  return (psVersion s)
-
-putAlex :: (Loc a, LastToken a b, Show b) => a -> Parse a b ()
-putAlex ai = do
-  s <- get
-  put (s { psAlexInput = ai })
-
-getAlex :: (Loc a, LastToken a b, Show b) => Parse a b a
-getAlex = do
-  s <- get
-  return (psAlexInput s)
-
-topContext :: (Loc a, LastToken a b, Show b) => Parse a b Context
-topContext = head . psContext <$> get
-
-popContext :: (Loc a, LastToken a b, Show b) => Parse a b ()
-popContext = modify $ \ps -> ps { psContext = tail $ psContext ps }
-
-pushContext :: (Loc a, LastToken a b, Show b) => Context -> Parse a b ()
-pushContext context = modify $ \ps -> ps { psContext = context : psContext ps }
-
-getPosition :: (Loc a, LastToken a b, Show b) => Parse a b Position
-getPosition = do
-  parseState <- get
-  return $ getPos $ psAlexInput parseState
-
-getSrcSpan :: (Loc a, LastToken a b, Show b) => Position -> Parse a b SrcSpan
-getSrcSpan loc1 = do
-  loc2 <- getPosition
-  return $ SrcSpan loc1 loc2
-
-getParanthesesCount :: (Loc a, LastToken a b, Show b) => Parse a b ParanthesesCount
-getParanthesesCount = psParanthesesCount <$> get
-
-resetPar :: (Loc a, LastToken a b, Show b) => Parse a b ()
-resetPar = do
-  ps <- get
-  put $ ps { psParanthesesCount = ParanthesesCount 0 False }
-
-incPar :: (Loc a, LastToken a b, Show b) => Parse a b ()
-incPar = do
-  ps <- get
-  let pc = psParanthesesCount ps
-  let count = pcActual pc
-  put $ ps { psParanthesesCount = pc { pcActual = count + 1 } }
-
-decPar :: (Loc a, LastToken a b, Show b) => Parse a b ()
-decPar = do
-  ps <- get
-  let pc = psParanthesesCount ps
-  let newCount = pcActual pc - 1
-  let reached0 = pcHasReached0 pc || newCount == 0
-  put $ ps { psParanthesesCount = ParanthesesCount newCount reached0 }
-
--------------------------------------------------------------------------------
--- Generic token collection and functions
--------------------------------------------------------------------------------
-
-throwIOerror :: String -> a
-throwIOerror s = throw
-  IOError { ioe_handle      = Nothing
-          , ioe_type        = UserError
-          , ioe_location    = "fortran-src"
-          , ioe_description = s
-          , ioe_errno       = Nothing
-          , ioe_filename    = Nothing }
-
-runParse :: (Loc b, LastToken b c, Show c) => Parse b c a -> ParseState b -> ParseResult b c a
-runParse = unParse
-
-runParseUnsafe :: (Loc b, LastToken b c, Show c) => Parse b c a -> ParseState b -> (a, ParseState b)
-runParseUnsafe lexer initState =
-  case unParse lexer initState of
-    ParseOk a s -> (a, s)
-    ParseFailed e -> throwIOerror $ show e
-
-evalParse :: (Loc b, LastToken b c, Show c) => Parse b c a -> ParseState b -> a
-evalParse m s = fst (runParseUnsafe m s)
-
-execParse :: (Loc b, LastToken b c, Show c) => Parse b c a -> ParseState b -> ParseState b
-execParse m s = snd (runParseUnsafe m s)
-
-class Tok a where
-  eofToken :: a -> Bool
-
-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 :: (Loc b, Tok a, LastToken b a, Show a) => ParseState b -> Parse b a [a]
-    _collectTokens state = do
-      let (_token, _state) = runParseUnsafe lexer state
-      if eofToken _token
-      then return [_token]
-      else do
-        _tokens <- _collectTokens _state
-        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 :: (Loc b, Tok a, LastToken b a, Show a) => ParseState b -> Parse b a (Maybe [a])
-    _collectTokens state =
-      case unParse lexer state of
-        ParseOk _token _state ->
-          if eofToken _token
-          then return $ Just [_token]
-          else do
-            _mTokens <- _collectTokens _state
-            case _mTokens of
-              Just _tokens -> return $ Just $ _token:_tokens
-              _ -> return Nothing
-        _ -> return Nothing
diff --git a/src/Language/Fortran/PrettyPrint.hs b/src/Language/Fortran/PrettyPrint.hs
--- a/src/Language/Fortran/PrettyPrint.hs
+++ b/src/Language/Fortran/PrettyPrint.hs
@@ -1,6 +1,3 @@
-{-# LANGUAGE LambdaCase            #-}
-{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE UndecidableInstances  #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
@@ -804,6 +801,11 @@
        case key of
          Just keyName -> text keyName <+> char '=' <+> pprint' v e
          Nothing      -> pprint' v e
+
+instance Pretty (ArgumentExpression a) where
+    pprint' v = \case
+      ArgExpr        e   -> pprint' v e
+      ArgExprVar _ _ var -> "(" <> pprint' v var <> ")"
 
 instance Pretty (Attribute a) where
     pprint' v attr
diff --git a/src/Language/Fortran/Transformation/Disambiguation/Function.hs b/src/Language/Fortran/Transformation/Disambiguation/Function.hs
--- a/src/Language/Fortran/Transformation/Disambiguation/Function.hs
+++ b/src/Language/Fortran/Transformation/Disambiguation/Function.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE PatternGuards #-}
 
 module Language.Fortran.Transformation.Disambiguation.Function (disambiguateFunction) where
 
@@ -9,7 +8,7 @@
 
 import Language.Fortran.Analysis
 import Language.Fortran.AST
-import Language.Fortran.Transformation.TransformMonad
+import Language.Fortran.Transformation.Monad
 
 
 disambiguateFunction :: Data a => Transform a ()
@@ -60,7 +59,7 @@
   fromIndex :: Index b -> a b
 
 instance Indexed Argument where
-  fromIndex (IxSingle a s mKey e) = Argument a s mKey e
+  fromIndex (IxSingle a s mKey e) = Argument a s mKey (ArgExpr e)
   fromIndex IxRange{} =
     error "Deduced a function but argument is not an expression."
 
diff --git a/src/Language/Fortran/Transformation/Disambiguation/Intrinsic.hs b/src/Language/Fortran/Transformation/Disambiguation/Intrinsic.hs
--- a/src/Language/Fortran/Transformation/Disambiguation/Intrinsic.hs
+++ b/src/Language/Fortran/Transformation/Disambiguation/Intrinsic.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE PatternGuards #-}
 
 module Language.Fortran.Transformation.Disambiguation.Intrinsic (disambiguateIntrinsic) where
 
@@ -9,7 +8,7 @@
 
 import Language.Fortran.Analysis
 import Language.Fortran.AST
-import Language.Fortran.Transformation.TransformMonad
+import Language.Fortran.Transformation.Monad
 
 
 disambiguateIntrinsic :: Data a => Transform a ()
diff --git a/src/Language/Fortran/Transformation/Grouping.hs b/src/Language/Fortran/Transformation/Grouping.hs
--- a/src/Language/Fortran/Transformation/Grouping.hs
+++ b/src/Language/Fortran/Transformation/Grouping.hs
@@ -1,3 +1,7 @@
+{-|
+Note that labeled (nonblock) DO grouping must be done before block DO grouping.
+-}
+
 module Language.Fortran.Transformation.Grouping ( groupForall
                                                 , groupDo
                                                 , groupLabeledDo
@@ -6,7 +10,7 @@
 import Language.Fortran.AST
 import Language.Fortran.Util.Position
 import Language.Fortran.Analysis
-import Language.Fortran.Transformation.TransformMonad
+import Language.Fortran.Transformation.Monad
 
 import Data.Data
 import Data.List (intercalate)
diff --git a/src/Language/Fortran/Transformation/Monad.hs b/src/Language/Fortran/Transformation/Monad.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Fortran/Transformation/Monad.hs
@@ -0,0 +1,42 @@
+module Language.Fortran.Transformation.Monad
+  ( getProgramFile
+  , putProgramFile
+  , modifyProgramFile
+  , runTransform
+  , Transform
+  ) where
+
+import Prelude hiding (lookup)
+import Control.Monad.State.Lazy hiding (state)
+import Data.Data
+
+import Language.Fortran.Analysis
+import Language.Fortran.Analysis.Types
+import Language.Fortran.Analysis.Renaming
+import Language.Fortran.AST (ProgramFile)
+
+data TransformationState a = TransformationState
+  { transProgramFile :: ProgramFile (Analysis a) }
+
+type Transform a = State (TransformationState a)
+
+runTransform
+    :: Data a
+    => TypeEnv -> ModuleMap -> Transform a () -> ProgramFile a -> ProgramFile a
+runTransform env mmap trans pf =
+    stripAnalysis . transProgramFile . execState trans $ initState
+  where
+    (pf', _) = analyseTypesWithEnv env . analyseRenamesWithModuleMap mmap . initAnalysis $ pf
+    initState = TransformationState
+      { transProgramFile = pf' }
+
+getProgramFile :: Transform a (ProgramFile (Analysis a))
+getProgramFile = gets transProgramFile
+
+putProgramFile :: ProgramFile (Analysis a) -> Transform a ()
+putProgramFile pf = do
+  state <- get
+  put $ state { transProgramFile = pf }
+
+modifyProgramFile :: (ProgramFile (Analysis a) -> ProgramFile (Analysis a)) -> Transform a ()
+modifyProgramFile f = modify $ \ s -> s { transProgramFile = f (transProgramFile s) }
diff --git a/src/Language/Fortran/Transformation/TransformMonad.hs b/src/Language/Fortran/Transformation/TransformMonad.hs
deleted file mode 100644
--- a/src/Language/Fortran/Transformation/TransformMonad.hs
+++ /dev/null
@@ -1,40 +0,0 @@
-module Language.Fortran.Transformation.TransformMonad
-  ( getProgramFile
-  , putProgramFile
-  , modifyProgramFile
-  , runTransform
-  , Transform)
-
-where
-
-import Prelude hiding (lookup)
-import Control.Monad.State.Lazy hiding (state)
-import Data.Data
-
-import Language.Fortran.Analysis
-import Language.Fortran.Analysis.Types
-import Language.Fortran.Analysis.Renaming
-import Language.Fortran.AST (ProgramFile)
-
-data TransformationState a = TransformationState
-  { transProgramFile :: ProgramFile (Analysis a) }
-
-type Transform a = State (TransformationState a)
-
-runTransform :: Data a => TypeEnv -> ModuleMap -> Transform a () -> ProgramFile a -> ProgramFile a
-runTransform env mmap trans pf = stripAnalysis . transProgramFile . execState trans $ initState
-  where
-    (pf', _) = analyseTypesWithEnv env . analyseRenamesWithModuleMap mmap . initAnalysis $ pf
-    initState = TransformationState
-      { transProgramFile = pf' }
-
-getProgramFile :: Transform a (ProgramFile (Analysis a))
-getProgramFile = gets transProgramFile
-
-putProgramFile :: ProgramFile (Analysis a) -> Transform a ()
-putProgramFile pf = do
-  state <- get
-  put $ state { transProgramFile = pf }
-
-modifyProgramFile :: (ProgramFile (Analysis a) -> ProgramFile (Analysis a)) -> Transform a ()
-modifyProgramFile f = modify $ \ s -> s { transProgramFile = f (transProgramFile s) }
diff --git a/src/Language/Fortran/Transformer.hs b/src/Language/Fortran/Transformer.hs
deleted file mode 100644
--- a/src/Language/Fortran/Transformer.hs
+++ /dev/null
@@ -1,70 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-
-module Language.Fortran.Transformer
-  ( transform
-  , transformWithModFiles
-  , Transformation(..)
-  , defaultTransformations
-  ) where
-
-import Data.Map (empty)
-import Data.Data
-
-import Language.Fortran.Util.ModFile
-import Language.Fortran.Transformation.TransformMonad (Transform, runTransform)
-import Language.Fortran.Transformation.Disambiguation.Function
-import Language.Fortran.Transformation.Disambiguation.Intrinsic
-import Language.Fortran.Transformation.Grouping
-import Language.Fortran.AST (ProgramFile)
-import Language.Fortran.Version (FortranVersion(..))
-
-data Transformation =
-    GroupForall
-  | GroupDo
-  | GroupLabeledDo
-  | DisambiguateFunction
-  | DisambiguateIntrinsic
-  deriving (Eq)
-
-transformationMapping :: Data a => Transformation -> Transform a ()
-transformationMapping = \case
-  GroupForall           -> groupForall
-  GroupDo               -> groupDo
-  GroupLabeledDo        -> groupLabeledDo
-  DisambiguateFunction  -> disambiguateFunction
-  DisambiguateIntrinsic -> disambiguateIntrinsic
-
-transformWithModFiles :: Data a => ModFiles -> [ Transformation ] -> ProgramFile a -> ProgramFile a
-transformWithModFiles mods trs = runTransform (combinedTypeEnv mods) (combinedModuleMap mods) trans
-  where
-    trans = mapM_ transformationMapping trs
-
-transform :: Data a => [ Transformation ] -> ProgramFile a -> ProgramFile a
-transform trs = runTransform empty empty trans
-  where
-    trans = mapM_ transformationMapping trs
-
--- | The default post-parse AST transformations for each Fortran version.
---
--- Note that some of these may not be commutative with each other. Specifically,
--- the DO groupings are written so labeled (nonblock) DO grouping must occur
--- first, followed by block DO grouping.
-defaultTransformations :: FortranVersion -> [Transformation]
-defaultTransformations = \case
-  Fortran66 ->
-    [ GroupLabeledDo
-    , DisambiguateIntrinsic
-    , DisambiguateFunction
-    ]
-  Fortran77         -> defaultTransformations Fortran66
-  Fortran77Legacy   ->
-    [ GroupLabeledDo
-    , GroupDo
-    , DisambiguateIntrinsic
-    , DisambiguateFunction
-    ]
-  Fortran77Extended -> defaultTransformations Fortran77Legacy
-  Fortran90   -> defaultTransformations Fortran77Extended
-  Fortran95   -> defaultTransformations Fortran77Extended
-  Fortran2003 -> defaultTransformations Fortran77Extended
-  Fortran2008 -> defaultTransformations Fortran2003
diff --git a/src/Language/Fortran/Util/FirstParameter.hs b/src/Language/Fortran/Util/FirstParameter.hs
--- a/src/Language/Fortran/Util/FirstParameter.hs
+++ b/src/Language/Fortran/Util/FirstParameter.hs
@@ -1,7 +1,5 @@
 {-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FunctionalDependencies #-}
 
 module Language.Fortran.Util.FirstParameter(FirstParameter(..), GFirstParameter(..)) where
diff --git a/src/Language/Fortran/Util/ModFile.hs b/src/Language/Fortran/Util/ModFile.hs
--- a/src/Language/Fortran/Util/ModFile.hs
+++ b/src/Language/Fortran/Util/ModFile.hs
@@ -15,10 +15,6 @@
 -}
 
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DeriveDataTypeable #-}
 
 {-|
 
@@ -46,15 +42,36 @@
 -}
 
 module Language.Fortran.Util.ModFile
-  ( modFileSuffix, ModFile, ModFiles, emptyModFile, emptyModFiles
-  , lookupModFileData, getLabelsModFileData, alterModFileData -- , alterModFileDataF
-  , genModFile, regenModFile, encodeModFile, decodeModFile
-  , StringMap, DeclMap, ParamVarMap, DeclContext(..), extractModuleMap, extractDeclMap
-  , moduleFilename, combinedStringMap, combinedDeclMap, combinedModuleMap, combinedTypeEnv, combinedParamVarMap
+  (
+  -- * Main defitions
+    ModFile, ModFiles, emptyModFile, emptyModFiles, modFileSuffix
+  , lookupModFileData, getLabelsModFileData, alterModFileData, alterModFileDataF
+
+  -- * Creation
+  , genModFile, regenModFile
+
+  -- * En/decoding
+  , encodeModFile, decodeModFile, decodeModFiles, decodeModFiles'
+
+  -- * Operations
+  , moduleFilename
+  , StringMap, extractStringMap, combinedStringMap
+  , DeclContext(..), DeclMap, extractDeclMap, combinedDeclMap
+  , extractModuleMap, combinedModuleMap, combinedTypeEnv
+  , ParamVarMap, extractParamVarMap, combinedParamVarMap
   , genUniqNameToFilenameMap
-  , TimestampStatus(..), checkTimestamps )
-where
+  , TimestampStatus(..), checkTimestamps
+  ) where
 
+import qualified Language.Fortran.AST               as F
+import qualified Language.Fortran.Analysis          as FA
+import qualified Language.Fortran.Analysis.BBlocks  as FAB
+import qualified Language.Fortran.Analysis.DataFlow as FAD
+import qualified Language.Fortran.Analysis.Renaming as FAR
+import qualified Language.Fortran.Analysis.Types    as FAT
+import qualified Language.Fortran.Util.Position     as P
+import           Language.Fortran.Util.Files ( getDirContents )
+
 import Control.Monad.State
 import Data.Binary (Binary, encode, decodeOrFail)
 import qualified Data.ByteString.Lazy.Char8 as LB
@@ -63,15 +80,10 @@
 import qualified Data.Map.Strict as M
 import Data.Maybe
 import GHC.Generics (Generic)
-import qualified Language.Fortran.AST as F
-import qualified Language.Fortran.Analysis as FA
-import qualified Language.Fortran.Analysis.BBlocks as FAB
-import qualified Language.Fortran.Analysis.DataFlow as FAD
-import qualified Language.Fortran.Analysis.Renaming as FAR
-import qualified Language.Fortran.Analysis.Types as FAT
-import qualified Language.Fortran.Util.Position as P
-import System.Directory
-import System.FilePath
+import System.Directory ( doesFileExist, getModificationTime )
+import qualified System.FilePath
+import System.FilePath ( (-<.>), (</>) )
+import System.IO ( hPutStrLn, stderr )
 
 --------------------------------------------------
 
@@ -79,6 +91,11 @@
 modFileSuffix :: String
 modFileSuffix = ".fsmod"
 
+-- | Returns 'true' for filepaths with an extension that identifies them as a
+--   mod file.
+isModFile :: FilePath -> Bool
+isModFile = System.FilePath.isExtensionOf modFileSuffix
+
 -- | Context of a declaration: the ProgramUnit where it was declared.
 data DeclContext = DCMain | DCBlockData | DCModule F.ProgramUnitName
                  | DCFunction (F.ProgramUnitName, F.ProgramUnitName)    -- ^ (uniqName, srcName)
@@ -153,9 +170,12 @@
 alterModFileData :: (Maybe LB.ByteString -> Maybe LB.ByteString) -> String -> ModFile -> ModFile
 alterModFileData f k mf = mf { mfOtherData = M.alter f k . mfOtherData $ mf }
 
--- For when stackage gets containers-0.5.8.1:
--- alterModFileDataF :: Functor f => (Maybe B.ByteString -> f (Maybe B.ByteString)) -> String -> ModFile -> f ModFile
--- alterModFileDataF f k mf = (\ od -> mf { mfOtherData = od }) <$> M.alterF f k (mfOtherData mf)
+alterModFileDataF
+    :: Functor f
+    => (Maybe LB.ByteString -> f (Maybe LB.ByteString)) -> String -> ModFile
+    -> f ModFile
+alterModFileDataF f k mf =
+    (\od -> mf { mfOtherData = od }) <$> M.alterF f k (mfOtherData mf)
 
 -- | Convert ModFiles to a strict ByteString for writing to file.
 encodeModFile :: [ModFile] -> LB.ByteString
@@ -174,6 +194,25 @@
     where
       each mf = (revertStringMap sm mf { mfStringMap = M.empty }) { mfStringMap = sm }
         where sm = mfStringMap mf
+
+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
+
+decodeModFiles' :: [FilePath] -> IO ModFiles
+decodeModFiles' = fmap (map snd) . decodeModFiles
 
 -- | Extract the combined module map from a set of ModFiles. Useful
 -- for parsing a Fortran file in a large context of other modules.
diff --git a/src/Language/Fortran/Util/Position.hs b/src/Language/Fortran/Util/Position.hs
--- a/src/Language/Fortran/Util/Position.hs
+++ b/src/Language/Fortran/Util/Position.hs
@@ -1,9 +1,4 @@
-{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE DeriveGeneric #-}
 
 module Language.Fortran.Util.Position where
 
diff --git a/src/Language/Fortran/Util/SecondParameter.hs b/src/Language/Fortran/Util/SecondParameter.hs
--- a/src/Language/Fortran/Util/SecondParameter.hs
+++ b/src/Language/Fortran/Util/SecondParameter.hs
@@ -1,7 +1,5 @@
 {-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FunctionalDependencies #-}
 
 module Language.Fortran.Util.SecondParameter(SecondParameter(..)) where
diff --git a/src/Language/Fortran/Version.hs b/src/Language/Fortran/Version.hs
--- a/src/Language/Fortran/Version.hs
+++ b/src/Language/Fortran/Version.hs
@@ -1,6 +1,3 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-
 -- | Fortran version enum and tools for selecting version for a given file.
 
 module Language.Fortran.Version
@@ -8,7 +5,6 @@
   , fortranVersionAliases
   , selectFortranVersion
   , deduceFortranVersion
-  , deduceVersion -- deprecated
   ) where
 
 import           Data.Char (toLower)
@@ -77,7 +73,3 @@
   | otherwise               = Fortran90         -- unrecognized, default to F90
   where
     isExtensionOf = flip isSuffixOf $ map toLower path
-
--- | Alias for previous function name. TODO: deprecate eventually.
-deduceVersion :: FilePath -> FortranVersion
-deduceVersion = deduceFortranVersion
diff --git a/src/Main.hs b/src/Main.hs
deleted file mode 100644
--- a/src/Main.hs
+++ /dev/null
@@ -1,482 +0,0 @@
-{-# LANGUAGE FlexibleContexts, FlexibleInstances, ScopedTypeVariables, OverloadedStrings #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
-
-module Main where
-
-import Prelude hiding (readFile, mod)
-import qualified Data.ByteString.Char8 as B
-import qualified Data.ByteString.Lazy.Char8 as LB
-import Language.Fortran.Util.Files
-
-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 Language.Fortran.Version (FortranVersion(..), selectFortranVersion, deduceFortranVersion)
-import Language.Fortran.ParserMonad (fromRight)
-import qualified Language.Fortran.Lexer.FixedForm as FixedForm (collectFixedTokens, Token(..))
-import qualified Language.Fortran.Lexer.FreeForm as FreeForm (collectFreeTokens, Token(..))
-
-import Language.Fortran.Parser.Any (parserWithModFilesVersions)
-
-import Language.Fortran.Util.ModFile
-import Language.Fortran.Util.Position
-
-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 Data.Graph.Inductive hiding (trc, mf, version)
-
-import qualified Data.IntMap as IM
-import qualified Data.Map as M
-import Control.Monad
-import Text.Printf
-
-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
-      let version = fromMaybe (deduceFortranVersion path) (fortranVersion opts)
-      let parserF0 = parserWithModFilesVersions version
-      let parserF m b s = fromRight (parserF0 m b s)
-      let outfmt = outputFormat opts
-      mods <- decodeModFiles $ includeDirs opts
-      let mmap = combinedModuleMap mods
-      let tenv = combinedTypeEnv mods
-      let 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 $ FixedForm.collectFixedTokens version contents
-        Lex | version `elem` [Fortran90, Fortran2003, Fortran2008] ->
-          print $ FreeForm.collectFreeTokens version contents
-        Lex        -> ioError $ userError $ usageInfo programName options
-        Parse      -> pp $ parserF mods contents path
-        Typecheck  -> let (pf, _, errs) = runTypes (parserF mods contents path) in
-                        printTypeErrors errs >> printTypes (extractTypeEnv pf)
-        Rename     -> pp . runRenamer $ parserF mods contents path
-        BBlocks    -> putStrLn . runBBlocks $ parserF mods contents path
-        SuperGraph -> putStrLn . runSuperGraph $ parserF mods contents path
-        Reprint    ->
-          let prettyContents = render . flip (pprint version) (Just 0) $ parserF mods contents path
-           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 $ parserF mods contents path
-          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 $ parserF mods contents path
-          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
-  let parserF0 = parserWithModFilesVersions version
-  let parserF m b s = fromRight (parserF0 m b s)
-  let mmap = combinedModuleMap mods
-  let tenv = combinedTypeEnv mods
-  let runCompile = genModFile . fst . analyseTypesWithEnv tenv . analyseRenamesWithModuleMap mmap . initAnalysis
-  let mod = runCompile $ parserF mods contents path
-  let fspath = path -<.> modFileSuffix `fromMaybe` moutfile
-  LB.writeFile fspath $ encodeModFile [mod]
-  return mod
-
-decodeModFiles :: [String] -> IO ModFiles
-decodeModFiles = flip foldM emptyModFiles $ \ modFiles d -> do
-  -- Figure out the camfort mod files and parse them.
-  modFileNames <- filter isModFile `fmap` getDirContents d
-  addedModFiles <- concat <$> mapM (decodeOneModFile . (d </>)) modFileNames
-  return $ addedModFiles ++ modFiles
-
-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
-
-isModFile :: FilePath -> Bool
-isModFile = (== modFileSuffix) . takeExtension
-
-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 [ FixedForm.Token ] where
-  show = unlines . lines'
-    where
-      lines' [] = []
-      lines' xs =
-        let (x, xs') = break isNewline xs
-        in case xs' of
-             (nl@(FixedForm.TNewline _):xs'') -> ('\t' : (intercalate ", " . map show $ x ++ [nl])) : lines' xs''
-             xs'' -> [ show xs'' ]
-      isNewline (FixedForm.TNewline _) = True
-      isNewline _ = False
-
-instance {-# OVERLAPPING #-} Show [ FreeForm.Token ] where
-  show = unlines . lines'
-    where
-      lines' [] = []
-      lines' xs =
-        let (x, xs') = break isNewline xs
-        in case xs' of
-             (nl@(FreeForm.TNewline _):xs'') -> ('\t' : (intercalate ", " . map show $ x ++ [nl])) : lines' xs''
-             xs'' -> [ show xs'' ]
-      isNewline (FreeForm.TNewline _) = True
-      isNewline _ = False
diff --git a/test/Language/Fortran/Analysis/BBlocksSpec.hs b/test/Language/Fortran/Analysis/BBlocksSpec.hs
--- a/test/Language/Fortran/Analysis/BBlocksSpec.hs
+++ b/test/Language/Fortran/Analysis/BBlocksSpec.hs
@@ -2,8 +2,7 @@
 
 import Test.Hspec
 
-import Language.Fortran.Parser.Fortran77
-import Language.Fortran.ParserMonad (fromParseResultUnsafe)
+import qualified Language.Fortran.Parser as Parser
 import Language.Fortran.AST
 import Language.Fortran.Analysis
 import Language.Fortran.Analysis.BBlocks
@@ -15,8 +14,10 @@
 import qualified Data.ByteString.Char8 as B
 
 pParser :: String -> ProgramFile (Analysis ())
-pParser source = rename . analyseBBlocks . analyseRenames . initAnalysis . fromParseResultUnsafe
-               $ extended77Parser (B.pack source) "<unknown>"
+pParser source =
+    case Parser.f77e "<unknown>" (B.pack source) of
+      Left err -> error $ show err
+      Right pf -> rename . analyseBBlocks . analyseRenames . initAnalysis $ pf
 
 spec :: Spec
 spec =
diff --git a/test/Language/Fortran/Analysis/DataFlowSpec.hs b/test/Language/Fortran/Analysis/DataFlowSpec.hs
--- a/test/Language/Fortran/Analysis/DataFlowSpec.hs
+++ b/test/Language/Fortran/Analysis/DataFlowSpec.hs
@@ -6,14 +6,13 @@
 import Test.Hspec.QuickCheck
 import Test.QuickCheck (Positive(..))
 
-import Language.Fortran.Parser.Fortran77
-import qualified Language.Fortran.Parser.Fortran90 as F90
-import Language.Fortran.ParserMonad (fromParseResultUnsafe)
 import Language.Fortran.AST
 import Language.Fortran.Analysis
 import Language.Fortran.Analysis.Renaming
 import Language.Fortran.Analysis.BBlocks
 import Language.Fortran.Analysis.DataFlow
+import qualified Language.Fortran.Parser as Parser
+
 import qualified Data.Map as M
 import qualified Data.Set as S
 import qualified Data.IntMap as IM
@@ -26,24 +25,22 @@
 import qualified Data.ByteString.Char8 as B
 import Control.Arrow ((&&&))
 
-{-# ANN module "HLint: ignore Reduce duplication" #-}
-
 data F77 = F77
 data F90 = F90
 
 class Parser t where
-    parser :: t -> String -> String -> ProgramFile A0
+    parser :: t -> String -> ProgramFile A0
 instance Parser F77 where
-    parser F77 src file = fromParseResultUnsafe $ extended77Parser (B.pack src) file
+    parser F77 = Parser.parseUnsafe Parser.f77e . B.pack
 instance Parser F90 where
-    parser F90 src file = fromParseResultUnsafe $ F90.fortran90Parser (B.pack src) file
+    parser F90 = Parser.parseUnsafe Parser.f90 . B.pack
 
 pParser :: Parser t => t -> String -> ProgramFile (Analysis ())
 pParser version source = rename . analyseBBlocks . analyseRenames . initAnalysis
-                                . resetSrcSpan $ parser version source "<unknown>"
+                                . resetSrcSpan $ parser version source
 
 withParse :: Data a => Parser t => t -> String -> (ProgramFile (Analysis A0) -> a) -> a
-withParse version source f = underRenaming (f . analyseBBlocks) (parser version source "<unknown>")
+withParse version source f = underRenaming (f . analyseBBlocks) (parser version source)
 
 testGraph :: Parser t => t -> String -> String -> BBGr (Analysis A0)
 testGraph version f p = fromJust . M.lookup (Named f) . withParse version p $ genBBlockMap
diff --git a/test/Language/Fortran/Analysis/RenamingSpec.hs b/test/Language/Fortran/Analysis/RenamingSpec.hs
--- a/test/Language/Fortran/Analysis/RenamingSpec.hs
+++ b/test/Language/Fortran/Analysis/RenamingSpec.hs
@@ -7,11 +7,10 @@
 --import Data.Data (Data)
 import qualified Data.Map as M
 
-import Language.Fortran.ParserMonad
 import Language.Fortran.AST
-import qualified Language.Fortran.Parser.Fortran90 as F90
 import Language.Fortran.Analysis
 import Language.Fortran.Analysis.Renaming
+import qualified Language.Fortran.Parser as Parser
 import Data.Generics.Uniplate.Data
 import qualified Data.ByteString.Char8 as B
 
@@ -34,8 +33,8 @@
   where uniE_PF :: ProgramFile (Analysis ()) -> [Expression (Analysis ())]
         uniE_PF = universeBi
 
-fortran90Parser :: String -> String -> ProgramFile A0
-fortran90Parser src file = fromParseResultUnsafe $ F90.fortran90Parser (B.pack src) file
+fortran90Parser :: String -> ProgramFile A0
+fortran90Parser = Parser.parseUnsafe Parser.f90 . B.pack
 
 spec :: Spec
 spec = do
@@ -112,7 +111,7 @@
 
     -- GitHub issue #190 https://github.com/camfort/fortran-src/issues/190
     it "doesn't generate same unique name in edge case" $ do
-      let ex = resetSrcSpan . flip fortran90Parser "" $ unlines
+      let ex = resetSrcSpan . fortran90Parser $ unlines
                  [ "program p1"
                  , "  implicit none"
                  , "  integer x, int1, a1, a2, a3, a4, a5, a6, a7, a8, a9"
@@ -208,7 +207,7 @@
   , BlStatement () u Nothing (StExpressionAssign () u
       (ExpValue () u (ValVariable "r"))
       (ExpFunctionCall () u (ExpValue () u (ValVariable "f1"))
-                            (Just $ AList () u [ Argument () u Nothing $ intGen 1 ]))) ]
+                            (Just $ AList () u [ Argument () u Nothing $ aintGen 1 ]))) ]
 ex4pu2 :: ProgramUnit ()
 ex4pu2 = PUFunction () u (Just $ TypeSpec () u TypeInteger Nothing) emptyPrefixSuffix "f1" (Just $ AList () u [ varGen "x"]) Nothing [ BlStatement () u Nothing (StExpressionAssign () u (varGen "f1") (varGen "x")) ] Nothing
 
@@ -236,13 +235,13 @@
 ex6pu2bs :: [a]
 ex6pu2bs = []
 ex6pu2pu1 :: ProgramUnit ()
-ex6pu2pu1 = PUFunction () u (Just $ TypeSpec () u TypeInteger Nothing) emptyPrefixSuffix "f1" (Just $ AList () u [ varGen "x"]) Nothing [ BlStatement () u Nothing (StExpressionAssign () u (varGen "f1") (ExpFunctionCall () u (ExpValue () u (ValVariable "f1")) (Just $ AList () u [Argument () u Nothing (varGen "x")]))) ] (Just [ex5pu2pu1])
+ex6pu2pu1 = PUFunction () u (Just $ TypeSpec () u TypeInteger Nothing) emptyPrefixSuffix "f1" (Just $ AList () u [ varGen "x"]) Nothing [ BlStatement () u Nothing (StExpressionAssign () u (varGen "f1") (ExpFunctionCall () u (ExpValue () u (ValVariable "f1")) (Just $ AList () u [Argument () u Nothing (ArgExpr $ varGen "x")]))) ] (Just [ex5pu2pu1])
 
 --parseF90 :: [String] -> ProgramFile A0
---parseF90 = resetSrcSpan . flip fortran90Parser "" . unlines
+--parseF90 = resetSrcSpan . fortran90Parser . unlines
 
 ex8 :: ProgramFile A0
-ex8 = resetSrcSpan . flip fortran90Parser "" $ unlines [
+ex8 = resetSrcSpan . fortran90Parser $ unlines [
     "module m1"
   , "  implicit none"
   , "contains"
@@ -277,7 +276,7 @@
   ]
 
 ex9 :: ProgramFile A0
-ex9 = resetSrcSpan . flip fortran90Parser "" $ unlines [
+ex9 = resetSrcSpan . fortran90Parser $ unlines [
     "module m1"
   , "  implicit none"
   , "  integer :: x"
@@ -313,7 +312,7 @@
   , BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e3")) Nothing (Just (varGen "r2"))) ]
 
 ex12 :: ProgramFile A0
-ex12 = resetSrcSpan . flip fortran90Parser "" $ unlines [
+ex12 = resetSrcSpan . fortran90Parser $ unlines [
     "module m1"
   , "  implicit none"
   , "  integer :: z"
@@ -350,7 +349,7 @@
   ]
 
 ex13Renames :: ProgramFile A0
-ex13Renames = resetSrcSpan . flip fortran90Parser "" $ unlines [
+ex13Renames = resetSrcSpan . fortran90Parser $ unlines [
     "module m1"
   , "  implicit none"
   , "  integer :: z"
@@ -388,7 +387,7 @@
 
 
 exScope1 :: ProgramFile A0
-exScope1 = resetSrcSpan . flip fortran90Parser "" $ unlines [
+exScope1 = resetSrcSpan . fortran90Parser $ unlines [
     "program scope1"
   -- local variables cannot take on the name of subprogram, therefore
   -- this declaration must be simply redeclaring the function x.
@@ -404,7 +403,7 @@
   ]
 
 exScope2 :: ProgramFile A0
-exScope2 = resetSrcSpan . flip fortran90Parser "" $ unlines [
+exScope2 = resetSrcSpan . fortran90Parser $ unlines [
     "module scope2"
   , "  integer :: x"
   , "contains"
@@ -434,7 +433,7 @@
   ]
 
 exScope3 :: ProgramFile A0
-exScope3 = resetSrcSpan . flip fortran90Parser "" $ unlines [
+exScope3 = resetSrcSpan . fortran90Parser $ unlines [
     "module m1"
   , "  implicit none"
   , "  integer :: x"
@@ -471,7 +470,7 @@
   ]
 
 common1 :: ProgramFile A0
-common1 = resetSrcSpan . flip fortran90Parser "" $ unlines [
+common1 = resetSrcSpan . fortran90Parser $ unlines [
     "program p1"
   , "  implicit none"
   , "  integer :: x, y"
diff --git a/test/Language/Fortran/Analysis/TypesSpec.hs b/test/Language/Fortran/Analysis/TypesSpec.hs
--- a/test/Language/Fortran/Analysis/TypesSpec.hs
+++ b/test/Language/Fortran/Analysis/TypesSpec.hs
@@ -12,9 +12,7 @@
 import Language.Fortran.Analysis.Types
 import Language.Fortran.Analysis.SemanticTypes
 import Language.Fortran.Analysis.Renaming
-import qualified Language.Fortran.Parser.Fortran77 as F77
-import qualified Language.Fortran.Parser.Fortran90 as F90
-import Language.Fortran.ParserMonad
+import qualified Language.Fortran.Parser as Parser
 import qualified Data.ByteString.Char8 as B
 
 inferTable :: Data a => ProgramFile a -> TypeEnv
@@ -23,11 +21,11 @@
 typedProgramFile :: Data a => ProgramFile a -> ProgramFile (Analysis a)
 typedProgramFile = fst . analyseTypes . analyseRenames . initAnalysis
 
-legacy77Parser :: String -> String -> ProgramFile A0
-legacy77Parser src file = fromParseResultUnsafe $ F77.legacy77Parser (B.pack src) file
+legacy77Parser :: String -> ProgramFile A0
+legacy77Parser = Parser.parseUnsafe Parser.f77l . B.pack
 
-fortran90Parser :: String -> String -> ProgramFile A0
-fortran90Parser src file = fromParseResultUnsafe $ F90.fortran90Parser (B.pack src) file
+fortran90Parser :: String -> ProgramFile A0
+fortran90Parser = Parser.parseUnsafe Parser.f90 . B.pack
 
 uniExpr :: ProgramFile (Analysis A0) -> [Expression (Analysis A0)]
 uniExpr = universeBi
@@ -386,11 +384,11 @@
 
 -- | Parse a string as an F90 program with initialized 'SrcSpan's.
 parseStrF90 :: String -> ProgramFile A0
-parseStrF90 = resetSrcSpan . flip fortran90Parser ""
+parseStrF90 = resetSrcSpan . fortran90Parser
 
 commonTransform :: [String] -> String -> [String] -> Bool -> ProgramFile A0
 commonTransform front cdecl back common =
-  resetSrcSpan . flip legacy77Parser "" . unlines . (++) front $
+  resetSrcSpan . legacy77Parser . unlines . (++) front $
     if common then cdecl : back else back
 
 structArray :: Bool -> ProgramFile A0
diff --git a/test/Language/Fortran/AnalysisSpec.hs b/test/Language/Fortran/AnalysisSpec.hs
--- a/test/Language/Fortran/AnalysisSpec.hs
+++ b/test/Language/Fortran/AnalysisSpec.hs
@@ -3,16 +3,14 @@
 import Test.Hspec
 import TestUtil
 
-import Language.Fortran.Parser.Fortran77
-import Language.Fortran.ParserMonad (fromParseResultUnsafe)
-import Language.Fortran.AST
 import Language.Fortran.Analysis
+import Language.Fortran.AST
+import qualified Language.Fortran.Parser as Parser
+
 import qualified Data.ByteString.Char8 as B
 
-pParser :: String -> ProgramFile (Analysis ())
-pParser source = initAnalysis
-               . fromParseResultUnsafe
-               $ extended77Parser (B.pack source) "<unknown>"
+pParser :: String -> ProgramFile (Analysis A0)
+pParser = initAnalysis . Parser.parseUnsafe Parser.f77e . B.pack
 
 spec :: Spec
 spec =
diff --git a/test/Language/Fortran/Lexer/FixedFormSpec.hs b/test/Language/Fortran/Lexer/FixedFormSpec.hs
deleted file mode 100644
--- a/test/Language/Fortran/Lexer/FixedFormSpec.hs
+++ /dev/null
@@ -1,312 +0,0 @@
-module Language.Fortran.Lexer.FixedFormSpec where
-
-import Language.Fortran.ParserMonad
---import Language.Fortran.Version (required when ParserMonad stops exporting it)
-import Language.Fortran.Lexer.FixedForm
-import Language.Fortran.AST.Boz
-
-import Test.Hspec
-import Test.Hspec.QuickCheck
-import TestUtil
-
-import Data.List (isPrefixOf)
-import qualified Data.ByteString.Char8 as B
-
-lex66 :: String -> Maybe Token
-lex66 = collectToLex Fortran66
-
-safeLex66 :: String -> Maybe Token
-safeLex66 = collectToLexSafe Fortran66
-
-lex77 :: String -> Maybe Token
-lex77 = collectToLex Fortran77
-
-collectToLex :: FortranVersion -> String -> Maybe Token
-collectToLex version srcInput = dropUntil2 $ collectFixedTokens version (B.pack srcInput)
-  where
-    dropUntil2 [] = Nothing
-    dropUntil2 [_] = Nothing
-    dropUntil2 [a,_] = Just a
-    dropUntil2 (_:xs) = dropUntil2 xs
-
-collectToLexSafe :: FortranVersion -> String -> Maybe Token
-collectToLexSafe version srcInput = dropUntil2 $ collectFixedTokensSafe version (B.pack srcInput)
-  where
-    dropUntil2 (Just [a,_]) = Just a
-    dropUntil2 (Just (_:xs)) = dropUntil2 $ Just xs
-    dropUntil2 _ = Nothing
-
-collectFixedTokens' :: FortranVersion -> String -> [Token]
-collectFixedTokens' v = collectFixedTokens v . B.pack
-
-spec :: Spec
-spec =
-  describe "Fortran Fixed Form Lexer" $ do
-    describe "Fortran 77" $
-      describe "String" $ do
-        it "lexes 'hello'" $
-          resetSrcSpan (lex77 "      c = 'hello'") `shouldBe` resetSrcSpan (Just $ TString u "hello")
-
-        it "lexes 'he''llo'" $
-          resetSrcSpan (lex77 "      c = 'he''llo'") `shouldBe` resetSrcSpan (Just $ TString u "he'llo")
-
-        it "lexes 'he''''ll''o'" $
-          resetSrcSpan (lex77 "      c = 'he''''ll''o'") `shouldBe` resetSrcSpan (Just $ TString u "he''ll'o")
-
-        it "lexes '''hello'''" $
-          resetSrcSpan (lex77 "      c = '''hello'''") `shouldBe` resetSrcSpan (Just $ TString u "'hello'")
-
-        it "lexes 'hello world'" $
-          resetSrcSpan (lex77 "      c = 'hello world'") `shouldBe` resetSrcSpan (Just $ TString u "hello world")
-
-        it "lexes 'hello world'" $
-          resetSrcSpan (collectFixedTokens' Fortran77 "      c = 'x' // 'o'") `shouldBe` resetSrcSpan [TId u "c", TOpAssign u, TString u "x", TSlash u, TSlash u, TString u "o", TEOF u]
-
-    describe "Fortran 66" $ do
-      prop "lexes Label, Comment, Newline or EOF in the first six columns or returns Nothing " $
-        \x -> isPrefixOf "      " x || case safeLex66 x of
-                Nothing -> True
-                Just (TLabel _ _) -> True
-                Just (TComment _ _) -> True
-                Just (TEOF _) -> True
-                Just (TNewline _) -> True
-                _ -> False
-
-      it "lexes alphanumeric identifier" $
-        resetSrcSpan (collectFixedTokens' Fortran66 "      e42 =") `shouldBe` resetSrcSpan [TId u "e42", TOpAssign u, TEOF u]
-
-      it "lexes exponent" $
-        resetSrcSpan (collectFixedTokens' Fortran66 "      a = 42 e42") `shouldBe` resetSrcSpan [TId u "a", TOpAssign u, TInt u "42", TExponent u "e42", TEOF u]
-
-      it "lexes 'function foo()'" $
-        resetSrcSpan (collectFixedTokens' Fortran66 "      function foo()") `shouldBe` resetSrcSpan [TFunction u, TId u "foo", TLeftPar u, TRightPar u, TEOF u]
-
-      it "lexes 'end'" $
-        resetSrcSpan (lex66 "      end") `shouldBe` resetSrcSpan (Just $ TEnd u)
-
-      it "lexes identifier" $
-        resetSrcSpan (lex66 "      a = mistr") `shouldBe` resetSrcSpan (Just $ TId u "mistr")
-
-      it "lexes comment if first column is C" $
-        resetSrcSpan (lex66 "c this is a comment") `shouldBe` resetSrcSpan (Just $ TComment u " this is a comment")
-
-      it "lexes empty comment" $
-        resetSrcSpan (lex66 "c") `shouldBe` resetSrcSpan (Just $ TComment u "")
-
-      it "lexes comment with one char" $
-        resetSrcSpan (lex66 "ca") `shouldBe` resetSrcSpan (Just $ TComment u "a")
-
-      it "should not lex from the next line" $
-        resetSrcSpan (safeLex66 "cxxx\nselam") `shouldNotBe` resetSrcSpan (Just $ TComment u "xxxselam")
-
-      -- This is commented out as identifiers are longer than what the standard says.
-      it "lexes three tokens"  $ do
-        pending
-        resetSrcSpan (collectFixedTokens' Fortran66 "      function end format") `shouldBe` resetSrcSpan [TFunction u, TId u "endfor", TId u "mat", TEOF u]
-
-      it "lexes multiple comments in a line" $
-        resetSrcSpan (collectFixedTokens' Fortran66 "csomething\ncsomething else\n\nc\ncc\n") `shouldBe`
-          resetSrcSpan [TComment u "something", TNewline u, TComment u "something else", TNewline u, TNewline u, TComment u "", TNewline u, TComment u "c", TNewline u, TEOF u]
-
-      it "lexes example1" $
-        resetSrcSpan (collectFixedTokens' Fortran66 example1) `shouldBe` resetSrcSpan example1Expectation
-
-      it "lexes end of file" $
-        resetSrcSpan (lex66 "") `shouldBe` Nothing
-
-      it "lexes '3 + 2'" $
-        resetSrcSpan (collectFixedTokens' Fortran66 "      a = 3 + 2") `shouldBe` resetSrcSpan [TId u "a", TOpAssign u, TInt u "3", TOpPlus u , TInt u "2", TEOF u]
-
-      it "should lex continuation lines properly" $
-        resetSrcSpan (collectFixedTokens' Fortran66 continuationExample) `shouldBe` resetSrcSpan [ TType u "integer", TId u "ix", TNewline u, TId u "ix", TOpAssign u, TInt u "42", TNewline u, TEnd u, TNewline u, TEOF u ]
-
-      it "lexes 'ASSIGN 100 TO FOO'" $
-        resetSrcSpan (collectFixedTokens' Fortran66 "      ASSIGN 100 TO FOO") `shouldBe` resetSrcSpan [TAssign u, TInt u "100", TTo u, TId u "foo", TEOF u]
-
-      it "lexes 'DO 100 dovar = 1, 10'" $
-        resetSrcSpan (collectFixedTokens' Fortran66 "      DO 100 dovar = 1, 10")
-          `shouldBe`
-          resetSrcSpan [TDo u, TInt u "100", TId u "dovar", TOpAssign u, TInt u "1", TComma u, TInt u "10", TEOF u]
-
-    describe "lexN" $
-      it "`lexN 5` parses lexes next five characters" $
-        (lexemeMatch . aiLexeme) (evalParse (lexN 5 >> getAlex) (initParseState (B.pack "helloWorld") Fortran66 "")) `shouldBe` reverse "hello"
-
-    describe "lexHollerith" $ do
-      it "lexes Hollerith '7hmistral'" $
-        resetSrcSpan (lex66 "      x = 7hmistral") `shouldBe` resetSrcSpan (Just $ THollerith u "mistral")
-
-      it "becomes case sensitive" $
-        resetSrcSpan (collectFixedTokens' Fortran66 "      format (5h a= 1)") `shouldBe` resetSrcSpan [ TFormat u, TBlob u "(5ha=1)", TEOF u ]
-
-    it "lexes if statement '        IF (IY) 5,6,6'" $
-      resetSrcSpan (collectFixedTokens' Fortran66 "      IF (IY) 5,6,6") `shouldBe` resetSrcSpan [TIf u, TLeftPar u, TId u "iy", TRightPar u, TInt u "5", TComma u, TInt u "6", TComma u, TInt u "6", TEOF u]
-
-    it "lexes if then statement '      if (x) then'" $
-      resetSrcSpan (collectFixedTokens' Fortran77 "      if (x) then") `shouldBe` resetSrcSpan [TIf u, TLeftPar u, TId u "x", TRightPar u, TThen u, TEOF u]
-
-    it "lexes if variable decl '      INTEGER IF'" $  -- yes, really..
-      resetSrcSpan (collectFixedTokens' Fortran77 "      INTEGER IF")
-        `shouldBe` resetSrcSpan [TType u "integer", TId u "if", TEOF u]
-
-    describe "Fortran 77 Legacy" $ do
-      it "lexes inline comments" $
-        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      integer foo ! bar")
-          `shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TEOF u]
-
-      it "lexes continuation lines separated by comments" $ do
-        let src = unlines [ "      integer foo,"
-                          , "C hello"
-                          , "     +        bar"
-                          ]
-          in resetSrcSpan (collectFixedTokens' Fortran77Legacy src)
-            `shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TComma u, TId u "bar", TNewline u, TEOF u]
-        let src = unlines [ "      integer foo, ! hello"
-                          , "     +        bar"
-                          ]
-          in resetSrcSpan (collectFixedTokens' Fortran77Legacy src)
-            `shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TComma u, TId u "bar", TNewline u, TEOF u]
-        let src = unlines [ "      integer foo,"
-                          , ""
-                          , "     +        bar"
-                          ]
-          in resetSrcSpan (collectFixedTokens' Fortran77Legacy src)
-            `shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TComma u, TId u "bar", TNewline u, TEOF u]
-        let src = unlines [ "      integer foo,"
-                          , "  " -- the space is intentional
-                          , "     +        bar"
-                          ]
-          in resetSrcSpan (collectFixedTokens' Fortran77Legacy src)
-            `shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TComma u, TId u "bar", TNewline u, TEOF u]
-
-      it "lexes the older TYPE statement" $
-        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      type *, 'hello'")
-          `shouldBe` resetSrcSpan [TTypePrint u, TStar u, TComma u, TString u "hello", TEOF u]
-
-      it "lexes width-specific type declarations" $ do
-        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      integer*4 i")
-          `shouldBe` resetSrcSpan [TType u "integer", TStar u, TInt u "4", TId u "i", TEOF u]
-
-        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      integer*4 function foo()")
-          `shouldBe` resetSrcSpan [TType u "integer", TStar u, TInt u "4", TFunction u, TId u "foo", TLeftPar u, TRightPar u, TEOF u]
-
-        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      character*4 s")
-          `shouldBe` resetSrcSpan [TType u "character", TStar u, TInt u "4", TId u "s", TEOF u]
-
-        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      character*(*) s")
-          `shouldBe` resetSrcSpan [TType u "character", TStar u, TLeftPar u, TStar u, TRightPar u, TId u "s", TEOF u]
-
-        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      character s*(*)")
-          `shouldBe` resetSrcSpan [TType u "character", TId u "s", TStar u, TLeftPar u, TStar u, TRightPar u, TEOF u]
-
-      it "lexes strings case-sensitively" $
-        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      c = 'Hello'")
-          `shouldBe` resetSrcSpan [TId u "c", TOpAssign u, TString u "Hello", TEOF u]
-
-      it "lexes strings delimited by '\"'" $
-        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      c = \"hello\"")
-          `shouldBe` resetSrcSpan [TId u "c", TOpAssign u, TString u "hello", TEOF u]
-
-      it "lexes Hollerith constants" $ do
-        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      x = 7hmistral")
-          `shouldBe` resetSrcSpan [TId u "x", TOpAssign u, THollerith u "mistral", TEOF u]
-
-        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      x = 7hshort\n")
-          `shouldBe` resetSrcSpan [TId u "x", TOpAssign u, THollerith u "short  ", TNewline u, TEOF u]
-
-      it "lexes BOZ constants" $
-        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      integer i, j, k / b'0101', o'0755', z'ab01' /")
-          `shouldBe` resetSrcSpan [ TType u "integer"
-                                  , TId u "i", TComma u, TId u "j", TComma u, TId u "k"
-                                  , TSlash u, TBozLiteral u (parseBoz "b'0101'")
-                                  , TComma u, TBozLiteral u (parseBoz "o'0755'")
-                                  , TComma u, TBozLiteral u (parseBoz "z'ab01'")
-                                  , TSlash u , TEOF u ]
-
-      it "lexes non-standard identifiers" $
-        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      integer _this_is_a_long_identifier$")
-          `shouldBe` resetSrcSpan [TType u "integer", TId u "_this_is_a_long_identifier$", TEOF u]
-
-      it "lexes ';' as a line-terminator" $
-        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      integer i; integer j")
-          `shouldBe` resetSrcSpan [TType u "integer", TId u "i", TNewline u, TType u "integer", TId u "j", TEOF u]
-
-      it "does not lex ';' as a line-terminator in first 6 columns" $
-        safeLex66 "; integer i; integer j" `shouldBe` Nothing
-
-      it "lexes subscripts in assignments" $
-        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      x(0,0) = 0")
-          `shouldBe` resetSrcSpan [TId u "x", TLeftPar u, TInt u "0", TComma u, TInt u "0", TRightPar u, TOpAssign u, TInt u "0", TEOF u]
-
-      it "lexes labeled DO WHILE blocks" $
-        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      do 10 while (.true.)")
-          `shouldBe` resetSrcSpan [TDo u, TInt u "10", TWhile u, TLeftPar u, TBool u True, TRightPar u, TEOF u]
-
-      it "lexes structure/union/map blocks" $ do
-        let src = unlines [ "      structure /foo/"
-                          , "        union"
-                          , "          map"
-                          , "            integer i"
-                          , "            real r"
-                          , "          end map"
-                          , "        end union"
-                          , "      end structure"]
-        resetSrcSpan (collectFixedTokens' Fortran77Legacy src)
-          `shouldBe` resetSrcSpan [ TStructure u, TSlash u, TId u "foo", TSlash u, TNewline u
-                                  , TUnion u, TNewline u
-                                  , TMap u, TNewline u
-                                  , TType u "integer", TId u "i", TNewline u
-                                  , TType u "real", TId u "r", TNewline u
-                                  , TEndMap u, TNewline u
-                                  , TEndUnion u, TNewline u
-                                  , TEndStructure u, TNewline u
-                                  , TEOF u ]
-
-      it "lexes but skips comments after 72" $ do
-        let src  = unlines [ "       l = r" <> replicate 65 ' ' <> "! comment after 72"
-                           , "       r = l"
-                           , replicate 72 ' ' <> "blank line with comment"]
-        resetSrcSpan (collectFixedTokens' Fortran77Legacy src) `shouldBe`
-          resetSrcSpan [ TId u "l", TOpAssign u, TId u "r", TNewline u
-                       , TId u "r", TOpAssign u, TId u "l", TNewline u
-                       , TNewline u, TEOF u]
-      it "lexes comment overflow" $ do
-        let src = unlines
-              [ "      l = r" <> replicate 65 ' ' <>  "Comment overflowing 72 limit"
-              , "      r = l"
-              ]
-        resetSrcSpan (collectFixedTokens' Fortran77Legacy src) `shouldBe`
-          resetSrcSpan [ TId u "l", TOpAssign u, TId u "r", TNewline u
-                       , TId u "r", TOpAssign u, TId u "l", TNewline u, TEOF u]
-      it "lexel comment line overflow" $ do
-        let src = unlines [ replicate 80 'c'
-                          , "      l = r" ]
-        resetSrcSpan (collectFixedTokens' Fortran77Legacy src) `shouldBe`
-          resetSrcSpan [ TComment u (replicate 71 'c'), TNewline u
-                       , TId u "l", TOpAssign u, TId u "r", TNewline u, TEOF u]
-
-example1 :: String
-example1 = unlines [
-  "      intEGerix",
-  "1         iX= 42",
-  " 200    ix =IX* ix",
-  " 10   wrITe (*,*), ix",
-  "        EnD" ]
-
-continuationExample :: String
-continuationExample = unlines [
-  "      inte",
-  "     .ger i",
-  "     .x",
-  "      ix = 4",
-  "     .2",
-  "      end"]
-
-example1Expectation :: [Token]
-example1Expectation = [
-  TType u "integer", TId u "ix", TNewline u,
-  TLabel u "1", TId u "ix", TOpAssign u, TInt u "42", TNewline u,
-  TLabel u "200", TId u "ix", TOpAssign u, TId u "ix", TStar u, TId u "ix", TNewline u,
-  TLabel u "10", TWrite u, TLeftPar u, TStar u, TComma u, TStar u, TRightPar u, TComma u, TId u "ix", TNewline u,
-  TEnd u, TNewline u,
-  TEOF u]
diff --git a/test/Language/Fortran/Lexer/FreeFormSpec.hs b/test/Language/Fortran/Lexer/FreeFormSpec.hs
deleted file mode 100644
--- a/test/Language/Fortran/Lexer/FreeFormSpec.hs
+++ /dev/null
@@ -1,377 +0,0 @@
-module Language.Fortran.Lexer.FreeFormSpec where
-
-import Test.Hspec
-import TestUtil
-
-import Language.Fortran.AST.RealLit
-import Language.Fortran.Version
-import Language.Fortran.Lexer.FreeForm (collectFreeTokens, Token(..))
-import Language.Fortran.Util.Position (SrcSpan)
-import qualified Data.ByteString.Char8 as B
-
-collectF90 :: String -> [ Token ]
-collectF90 = collectFreeTokens Fortran90 . B.pack
-
-collectF03 :: String -> [ Token ]
-collectF03 = collectFreeTokens Fortran2003 . B.pack
-
-
-pseudoAssign :: (SrcSpan -> Token) -> [Token]
-pseudoAssign token = fmap ($u) [ flip TId "i", TOpAssign, token, TEOF ]
-
-spec :: Spec
-spec =
-  describe "Fortran Free Form Lexer" $
-    describe "Fortran 90" $ do
-      describe "Character sensitivity" $ do
-        it "lexes lower case tokens" $
-          shouldBe' (collectF90 "integer id") $
-                    fmap ($u) [ TInteger, flip TId "id", TEOF ]
-
-        it "lexes mixed case tokens" $
-          shouldBe' (collectF90 "InTEgeR ID") $
-                    fmap ($u) [ TInteger, flip TId "id", TEOF ]
-
-      describe "Identifier" $ do
-        it "lexes long ID names" $
-          shouldBe' (collectF90 "program long_id_name") $
-                    fmap ($u) [ TProgram, flip TId "long_id_name", TEOF ]
-
-        it "treats 'if' as ID if used in assignment" $
-          shouldBe' (collectF90 "if = 20") $
-                    fmap ($u) [ flip TId "if", TOpAssign
-                              , flip TIntegerLiteral "20", TEOF ]
-
-        it "'result' is an identifier in spec. context" $
-          shouldBe' (collectF90 "integer :: result") $
-                    fmap ($u) [ TInteger, TDoubleColon , flip TId "result"
-                              , TEOF ]
-
-      describe "Types" $ do
-        it "lexes length and kind selectors" $
-          shouldBe' (collectF90 "integer (KIND=1, LEN=1) :: kind, len") $
-                    fmap ($u) [ TInteger, TLeftPar, TKind, TOpAssign
-                              , flip TIntegerLiteral "1", TComma, TLen
-                              , TOpAssign, flip TIntegerLiteral "1", TRightPar
-                              , TDoubleColon , flip TId "kind", TComma
-                              , flip TId "len", TEOF ]
-
-
-        it "lexes simple type tokens" $
-          shouldBe' (collectF90 "character x") $
-                    fmap ($u) [ TCharacter, flip TId "x", TEOF ]
-
-        it "lexes simple type tokens in function" $
-          shouldBe' (collectF90 "character function x") $
-                    fmap ($u) [ TCharacter, TFunction, flip TId "x", TEOF ]
-
-        it "lexes character type with F77 length syntax (1)" $
-          shouldBe' (collectF90 "character * (*) function x") $
-                    fmap ($u) [ TCharacter, TStar, TLeftPar, TStar, TRightPar, TFunction, flip TId "x", TEOF ]
-
-        it "lexes character type with F77 length syntax (2)" $
-          shouldBe' (collectF90 "character * 20 function x") $
-                    fmap ($u) [ TCharacter, TStar, flip TIntegerLiteral "20", TFunction, flip TId "x", TEOF ]
-
-        it "lexes derived type tokens in function" $
-          shouldBe' (collectF90 "type (x) function x") $
-                    fmap ($u) [ TType, TLeftPar, flip TId "x", TRightPar
-                              , TFunction, flip TId "x", TEOF ]
-
-        it "lexes interleaved type recursive tokens" $
-          shouldBe' (collectF90 "integer (KIND=10*2) recursive function x") $
-                    fmap ($u) [ TInteger, TLeftPar, TKind, TOpAssign
-                              , flip TIntegerLiteral "10" , TStar
-                              , flip TIntegerLiteral "2", TRightPar, TRecursive
-                              , TFunction, flip TId "x", TEOF ]
-
-        it "lexes interleaved type recursive tokens (reversed)" $
-          shouldBe' (collectF90 "recursive integer (KIND=10*2) function x") $
-                    fmap ($u) [ TRecursive, TInteger, TLeftPar, TKind, TOpAssign
-                              , flip TIntegerLiteral "10" , TStar
-                              , flip TIntegerLiteral "2", TRightPar, TFunction
-                              , flip TId "x", TEOF ]
-
-      describe "Function" $ do
-        it "lexes 'function fx ( a, b, c )'" $
-          shouldBe' (collectF90 "function fx ( a, b )") $
-                    fmap ($u) [ TFunction, flip TId "fx", TLeftPar, flip TId "a"
-                              , TComma, flip TId "b", TRightPar, TEOF ]
-
-        it "lexes functions with specific result" $
-          shouldBe' (collectF90 "function fx (array) result (c_sum)") $
-                    fmap ($u) [ TFunction, flip TId "fx", TLeftPar
-                              , flip TId "array", TRightPar, TResult, TLeftPar
-                              , flip TId "c_sum", TRightPar, TEOF ]
-
-        it "lexes recursive functions" $
-          shouldBe' (collectF90 "recursive function fx (array)") $
-                    fmap ($u) [ TRecursive, TFunction, flip TId "fx", TLeftPar
-                              , flip TId "array", TRightPar, TEOF ]
-
-        it "lexes recursive functions with result specified" $
-          shouldBe' (collectF90 "RECURSIVE FUNCTION FX (ARRAY) RESULT (C_SUM)") $
-                    fmap ($u) [ TRecursive, TFunction, flip TId "fx", TLeftPar
-                              , flip TId "array", TRightPar, TResult, TLeftPar
-                              , flip TId "c_sum", TRightPar, TEOF ]
-
-      describe "Attribute" $ do
-        it "lexes PARAMETER attribute" $
-          shouldBe' (collectF90 "integer, parameter :: x") $
-                    fmap ($u) [ TInteger, TComma, TParameter, TDoubleColon
-                              , flip TId "x", TEOF ]
-
-        it "lexes INTENT attribute" $
-          shouldBe' (collectF90 "integer, intent (inout) :: x") $
-                    fmap ($u) [ TInteger, TComma, TIntent, TLeftPar, TInOut
-                              , TRightPar, TDoubleColon , flip TId "x", TEOF ]
-
-        it "lexes DIMENSION attribute" $
-          shouldBe' (collectF90 "double precision, dimension (3:10) :: x") $
-                    fmap ($u) [ TDoublePrecision, TComma, TDimension, TLeftPar
-                              , flip TIntegerLiteral "3", TColon
-                              , flip TIntegerLiteral "10" , TRightPar
-                              , TDoubleColon , flip TId "x", TEOF ]
-
-        it "lexes variable declaration with multiple attributes" $
-          shouldBe' (collectF90 "double precision, save, dimension(2), allocatable :: y") $
-                    fmap ($u) [ TDoublePrecision, TComma, TSave, TComma
-                              , TDimension, TLeftPar, flip TIntegerLiteral "2"
-                              , TRightPar, TComma, TAllocatable, TDoubleColon
-                              , flip TId "y", TEOF ]
-
-        it "try to trick lexer into parsing variables as attributes (1)" $
-          shouldBe' (collectF90 "integer save, dimension(10), target") $
-                    fmap ($u) [ TInteger, flip TId "save", TComma
-                              , flip TId "dimension", TLeftPar, flip TIntegerLiteral "10", TRightPar, TComma
-                              , flip TId "target", TEOF ]
-
-        it "try to trick lexer into parsing variables as attributes (2)" $
-          shouldBe' (collectF90 "type(foo) save, dimension(10), target") $
-                    fmap ($u) [ TType, TLeftPar, flip TId "foo", TRightPar, flip TId "save", TComma
-                              , flip TId "dimension", TLeftPar, flip TIntegerLiteral "10", TRightPar, TComma
-                              , flip TId "target", TEOF ]
-
-        it "try to trick lexer into parsing variables as attributes (3)" $
-          shouldBe' (collectF90 "allocate(type(foo) :: errmsg(stat, source), source=x)") $
-                    fmap ($u) [ TAllocate, TLeftPar, TType, TLeftPar, flip TId "foo", TRightPar, TDoubleColon
-                              , flip TId "errmsg", TLeftPar, flip TId "stat", TComma, flip TId "source", TRightPar
-                              , TComma, TSource, TOpAssign, flip TId "x", TRightPar, TEOF ]
-
-      describe "Character" $ do
-        it "lexes single quote literal" $
-          shouldBe' (collectF90 "character c = 'heL\"Lo ''daRLing'") $
-                    fmap ($u) [ TCharacter, flip TId "c", TOpAssign
-                              , flip TString "heL\"Lo 'daRLing", TEOF ]
-
-        it "lexes double quote literal" $
-          shouldBe' (collectF90 "character c = \"heL'Lo \"\"daRLing\"") $
-                    fmap ($u) [ TCharacter, flip TId "c", TOpAssign
-                              , flip TString "heL'Lo \"daRLing", TEOF ]
-
-      describe "Module" $ do
-        it "lexes module statement" $
-          shouldBe' (collectF90 "module Hello_mod") $
-                    fmap ($u) [ TModule, flip TId "hello_mod", TEOF ]
-
-        it "lexes use statement" $
-          shouldBe' (collectF90 "use Hello_mod, hello => hi") $
-                    fmap ($u) [ TUse, flip TId "hello_mod", TComma
-                              , flip TId "hello", TArrow, flip TId "hi", TEOF ]
-
-        it "lexes use statement with only" $
-          shouldBe' (collectF90 "use Hello_mod, only: a, b => c") $
-                    fmap ($u) [ TUse, flip TId "hello_mod", TComma, TOnly
-                              , TColon, flip TId "a", TComma, flip TId "b"
-                              , TArrow, flip TId "c", TEOF ]
-
-      describe "Label" $
-        it "lexes simple label" $
-          shouldBe' (collectF90 "010 print *, 'hello'") $
-                    fmap ($u) [ flip TIntegerLiteral "010", TPrint, TStar, TComma
-                              , flip TString "hello", TEOF ]
-
-      describe "Conditional" $ do
-        it "lexes logical if with array assignment" $
-          shouldBe' (collectF90 "if (.true.) a(1) = 42") $
-                    fmap ($u) [ TIf, TLeftPar, flip TLogicalLiteral True
-                              , TRightPar, flip TId "a", TLeftPar
-                              , flip TIntegerLiteral "1", TRightPar, TOpAssign
-                              , flip TIntegerLiteral "42", TEOF ]
-
-        it "lexes block if statement" $
-          shouldBe' (collectF90 "if (a > b) then") $
-                    fmap ($u) [ TIf, TLeftPar, flip TId "a", TOpGT, flip TId "b"
-                              , TRightPar, TThen, TEOF ]
-
-        it "lexes arithmetic if statement" $
-          shouldBe' (collectF90 "if (a) 10, 11, 12") $
-                    fmap ($u) [ TIf, TLeftPar, flip TId "a", TRightPar
-                              , flip TIntegerLiteral "10", TComma
-                              , flip TIntegerLiteral "11", TComma
-                              , flip TIntegerLiteral "12" , TEOF ]
-
-        it "lexes logical if statement" $
-          shouldBe' (collectF90 "if (a > b) print *, 'hello'") $
-                    fmap ($u) [ TIf, TLeftPar, flip TId "a", TOpGT, flip TId "b"
-                              , TRightPar, TPrint, TStar, TComma
-                              , flip TString "hello", TEOF ]
-
-      describe "Lexes numeric values" $ do
-        it "lexes integer" $
-          shouldBe' (collectF90 "i = 42") $
-                    pseudoAssign $ flip TIntegerLiteral "42"
-
-        describe "Real" $ do
-          it "lexes real (1)" $ do
-            let litStr      = "10.5e2"
-                expectedLit = RealLit "10.5" (Exponent ExpLetterE "2")
-                expected    = pseudoAssign $ flip TRealLiteral expectedLit
-            collectF90 ("i = "<>litStr) `shouldBe'` expected
-
-          it "lexes real (2)" $ do
-            let litStr      = "10."
-                expectedLit = RealLit "10.0" (Exponent ExpLetterE "0")
-                expected    = pseudoAssign $ flip TRealLiteral expectedLit
-            collectF90 ("i = "<>litStr) `shouldBe'` expected
-
-          it "lexes real (3)" $ do
-            let litStr      = ".42"
-                expectedLit = RealLit "0.42" (Exponent ExpLetterE "0")
-                expected    = pseudoAssign $ flip TRealLiteral expectedLit
-            collectF90 ("i = "<>litStr) `shouldBe'` expected
-
-          it "lexes real (4)" $ do
-            let litStr      = "42d-3"
-                expectedLit = RealLit "42.0" (Exponent ExpLetterD "-3")
-                expected    = pseudoAssign $ flip TRealLiteral expectedLit
-            collectF90 ("i = "<>litStr) `shouldBe'` expected
-
-          it "resolves disambiguity when xxx. follows relational operator" $
-            shouldBe' (collectF90 "if (10.EQ. 20)") $
-                      fmap ($u) [ TIf, TLeftPar, flip TIntegerLiteral "10"
-                                , TOpEQ, flip TIntegerLiteral "20"
-                                , TRightPar, TEOF ]
-
-      describe "Continuation" $ do
-        it "Single continuation char without space" $
-          shouldBe' (collectF90 "i = &\n42") $
-                    pseudoAssign $ flip TIntegerLiteral "42"
-
-        it "Single continuation char with space" $
-          shouldBe' (collectF90 "i = &   \n \t   42") $
-                    pseudoAssign $ flip TIntegerLiteral "42"
-
-        it "Double continuation (1)" $
-          shouldBe' (collectF90 "i = &\n  & 42") $
-                    pseudoAssign $ flip TIntegerLiteral "42"
-
-        it "Double continuation (2)" $
-          shouldBe' (collectF90 "i = 4&\n  &2") $
-                    pseudoAssign $ flip TIntegerLiteral "42"
-
-        it "Continuation with comment" $
-          shouldBe' (collectF90 "i = 4&\n  ! hello\n  &2") $
-                    pseudoAssign $ flip TIntegerLiteral "42"
-
-        it "Continuation with inline comment" $
-          shouldBe' (collectF90 "i = &  ! hi \n  42") $
-                    pseudoAssign $ flip TIntegerLiteral "42"
-
-      describe "Comment" $ do
-        it "Full line comment" $
-          shouldBe' (collectF90 "! = & ! hi \n") $
-                    ($u) <$> [ flip TComment " = & ! hi ", TNewline , TEOF ]
-
-        it "Inline comment" $
-          shouldBe' (collectF90 "i = 10 ! = & ! hi \n") $
-                    ($u) <$> [ flip TId "i", TOpAssign
-                             , flip TIntegerLiteral "10"
-                             , flip TComment " = & ! hi ", TNewline , TEOF ]
-        it "Empty comment" $
-          shouldBe' (collectF90 "!\n") $
-                    ($u) <$> [ flip TComment "", TNewline , TEOF ]
-
-      describe "Subscripting" $ do
-        it "Strings nested in arrays" $
-          shouldBe' (collectF90 "a(1)(2:3) = 'we'") $
-                    ($u) <$> [ flip TId "a", TLeftPar, flip TIntegerLiteral "1", TRightPar
-                             , TLeftPar, flip TIntegerLiteral "2", TColon, flip TIntegerLiteral "3", TRightPar
-                             , TOpAssign, flip TString "we", TEOF ]
-
-      describe "Fortran95" $ do
-        it "lexes value attribute" $ do
-          shouldBe' (collectF03 "value :: a, b") $
-                    fmap ($u) [ TValue, TDoubleColon, flip TId "a", TComma, flip TId "b", TEOF ]
-          shouldBe' (collectF03 "integer, value :: a, b") $
-                    fmap ($u) [ TInteger, TComma, TValue, TDoubleColon, flip TId "a", TComma, flip TId "b", TEOF ]
-
-        it "lexes volatile attribute" $ do
-          shouldBe' (collectF03 "volatile :: a, b") $
-                    fmap ($u) [ TVolatile, TDoubleColon, flip TId "a", TComma, flip TId "b", TEOF ]
-          shouldBe' (collectF03 "integer, volatile :: a, b") $
-                    fmap ($u) [ TInteger, TComma, TVolatile, TDoubleColon, flip TId "a", TComma, flip TId "b", TEOF ]
-
-      describe "Fortran2003" $ do
-        it "lexes procedures" $
-          shouldBe' (collectF03 "PROCEDURE(a), SAVE :: b => c()") $
-            ($u) <$> [ TProcedure, TLeftPar, flip TId "a", TRightPar
-                     , TComma, TSave, TDoubleColon
-                     , flip TId "b", TArrow, flip TId "c", TLeftPar, TRightPar, TEOF ]
-
-        it "lexes procedures with bind" $
-          shouldBe' (collectF03 "PROCEDURE(a), BIND(C, NAME=\"d\") :: b => c()") $
-            ($u) <$> [ TProcedure, TLeftPar, flip TId "a", TRightPar
-                     , TComma, TBind, TLeftPar, TC, TComma, TName, TOpAssign, flip TString "d", TRightPar, TDoubleColon
-                     , flip TId "b", TArrow, flip TId "c", TLeftPar, TRightPar, TEOF ]
-
-        it "lexes functions with bind" $
-          shouldBe' (collectF03 "FUNCTION f(a) RESULT(x) BIND(C, NAME=\"d\")") $
-            ($u) <$> [ TFunction, flip TId "f", TLeftPar, flip TId "a", TRightPar
-                     , TResult, TLeftPar, flip TId "x", TRightPar
-                     , TBind, TLeftPar, TC, TComma, TName, TOpAssign, flip TString "d", TRightPar, TEOF ]
-
-        it "lexes subroutines with bind" $
-          shouldBe' (collectF03 "SUBROUTINE s(a) BIND(C, NAME=\"d\")") $
-            ($u) <$> [ TSubroutine, flip TId "s", TLeftPar, flip TId "a", TRightPar
-                     , TBind, TLeftPar, TC, TComma, TName, TOpAssign, flip TString "d", TRightPar, TEOF ]
-
-        it "lexes class decl (name)" $
-          shouldBe' (collectF03 "procedure (class(c))") $
-                    fmap ($u) [ TProcedure, TLeftPar
-                              , TClass, TLeftPar, flip TId "c", TRightPar, TRightPar, TEOF ]
-
-        it "lexes class decl (*)" $
-          shouldBe' (collectF03 "procedure (class(*))") $
-                    fmap ($u) [ TProcedure, TLeftPar
-                              , TClass, TLeftPar, TStar, TRightPar, TRightPar, TEOF ]
-
-        it "lexes import statements" $
-          shouldBe' (collectF03 "import :: a, b") $
-                    fmap ($u) [ TImport, TDoubleColon, flip TId "a", TComma, flip TId "b", TEOF ]
-
-        it "lexes asynchronous attribute" $ do
-          shouldBe' (collectF03 "asynchronous :: a, b") $
-                    fmap ($u) [ TAsynchronous, TDoubleColon, flip TId "a", TComma, flip TId "b", TEOF ]
-          shouldBe' (collectF03 "integer, asynchronous :: a, b") $
-                    fmap ($u) [ TInteger, TComma, TAsynchronous, TDoubleColon, flip TId "a", TComma, flip TId "b", TEOF ]
-
-        it "lexes enums" $ do
-          shouldBe' (collectF03 "enum, bind(c)") $ fmap ($u) [ TEnum, TComma, TBind, TLeftPar, TC, TRightPar, TEOF ]
-          shouldBe' (collectF03 "enumerator :: a = 1, b") $
-                    fmap ($u) [ TEnumerator, TDoubleColon, flip TId "a", TOpAssign, flip TIntegerLiteral "1"
-                              , TComma, flip TId "b", TEOF ]
-          shouldBe' (collectF03 "end enum") $ fmap ($u) [ TEndEnum, TEOF ]
-
-        it "lexes flush" $ do
-          shouldBe' (collectF03 "flush(unit=1)") $
-            fmap ($u) [ TFlush, TLeftPar, TUnit, TOpAssign, flip TIntegerLiteral "1", TRightPar, TEOF ]
-          shouldBe' (collectF03 "flush(unit=1,iomsg=x,iostat=y,err=z)") $
-            fmap ($u) [ TFlush, TLeftPar, TUnit, TOpAssign, flip TIntegerLiteral "1", TComma
-                      , TIOMsg, TOpAssign, flip TId "x", TComma
-                      , TIOStat, TOpAssign, flip TId "y", TComma
-                      , TErr, TOpAssign, flip TId "z", TRightPar, TEOF ]
-
-        it "lexes protected" $ do
-          shouldBe' (collectF03 "real, protected, public :: x") $
-            fmap ($u) [ TReal, TComma, TProtected, TComma, TPublic, TDoubleColon, flip TId "x", TEOF ]
diff --git a/test/Language/Fortran/Parser/Fixed/Fortran66Spec.hs b/test/Language/Fortran/Parser/Fixed/Fortran66Spec.hs
new file mode 100644
--- /dev/null
+++ b/test/Language/Fortran/Parser/Fixed/Fortran66Spec.hs
@@ -0,0 +1,189 @@
+module Language.Fortran.Parser.Fixed.Fortran66Spec ( spec ) where
+
+import Test.Hspec
+import TestUtil
+
+import Language.Fortran.AST
+import Language.Fortran.Version
+import Language.Fortran.Parser
+import Language.Fortran.Parser.Monad ( Parse )
+import qualified Language.Fortran.Parser.Fixed.Fortran66 as F66
+import qualified Language.Fortran.Parser.Fixed.Lexer     as Fixed
+
+import Prelude hiding ( LT )
+import qualified Data.ByteString.Char8 as B
+
+parseWith :: Parse Fixed.AlexInput Fixed.Token a -> String -> a
+parseWith p = parseUnsafe (makeParserFixed p Fortran66) . B.pack
+
+eParser :: String -> Expression ()
+eParser = parseUnsafe p . B.pack
+  where p = makeParser initParseStateFixedExpr F66.expressionParser Fortran66
+
+sParser :: String -> Statement ()
+sParser = parseWith F66.statementParser
+
+spec :: Spec
+spec =
+  describe "Fortran 66 Parser" $ do
+    describe "Expressions" $ do
+      describe "Arithmetic expressions" $ do
+        it "parses '3'" $ do
+          let expectedExp = intGen 3
+          eParser "3" `shouldBe'` expectedExp
+
+        it "parses '-3'" $ do
+          let expectedExp = ExpUnary () u Minus $ intGen 3
+          eParser "-3" `shouldBe'` expectedExp
+
+        it "parses '3 + 2'" $ do
+          let expectedExp = ExpBinary () u Addition (intGen 3) (intGen 2)
+          eParser "3 + 2" `shouldBe'` expectedExp
+
+        it "parses '3 + -2'" $ do
+          let expectedExp = ExpBinary () u Addition (intGen 3) (ExpUnary () u Minus (intGen 2))
+          eParser "3 + -2" `shouldBe'` expectedExp
+
+        it "parses '3 + -2 + 42'" $ do
+          let expectedExp = ExpBinary () u Addition (ExpBinary () u Addition (intGen 3) (ExpUnary () u Minus (intGen 2))) (intGen 42)
+          eParser "3 + -2 + 42" `shouldBe'` expectedExp
+
+        it "parses 'f(y, 24)'" $ do
+          let subs = [ IxSingle () u Nothing $ varGen "y", ixSinGen 24 ]
+          let expectedExp = ExpSubscript () u (varGen "f") (fromList () subs)
+          eParser "f(y, 24)" `shouldBe'` expectedExp
+
+        it "parses '3 + 4 * 12'" $ do
+          let expectedExp = ExpBinary () u Addition (intGen 3) (ExpBinary () u Multiplication (intGen 4) (intGen 12))
+          eParser "3 + 4 * 12" `shouldBe'` expectedExp
+
+      describe "Logical expressions" $
+        it "parses '.true. .and. .false.'" $ do
+          let expectedExp = ExpBinary () u And valTrue valFalse
+          eParser ".true. .and. .false." `shouldBe'` expectedExp
+
+      describe "Relational expressions" $
+        it "parses '(3 * 2) .lt. 42'" $ do
+          let expectedExp = ExpBinary () u LT (ExpBinary () u Multiplication (intGen 3) (intGen 2)) (intGen 42)
+          eParser "(3 * 2) .lt. 42" `shouldBe'` expectedExp
+
+      describe "Other expressions" $
+        it "parses 'a(2 * x - 3, 10)'" $ do
+          let firstEl = ExpBinary () u Subtraction (ExpBinary () u Multiplication (intGen 2) (varGen "x")) (intGen 3)
+              expectedExp = ExpSubscript () u (varGen "a") (AList () u [ IxSingle () u Nothing firstEl, ixSinGen 10])
+          eParser "a(2 * x - 3, 10)" `shouldBe'` expectedExp
+
+    describe "Statements" $ do
+      it "parses 'EXTERNAL f, g, h'" $ do
+        let procGen s = ExpValue () u (ValVariable s)
+        let expectedSt = StExternal () u (AList () u [procGen "f", procGen "g", procGen "h"])
+        sParser "      EXTERNAL f, g, h" `shouldBe'` expectedSt
+
+      it "parses 'COMMON a, b'" $ do
+        let comGr = CommonGroup () u Nothing (AList () u [ declVarGen "a", declVarGen "b" ])
+        let st = StCommon () u (AList () u [ comGr ])
+        sParser "      COMMON a, b" `shouldBe'` st
+
+      it "parses 'COMMON // a, b /hello/ x, y, z'" $ do
+        let comGrs = [ CommonGroup () u Nothing (AList () u [ declVarGen "a", declVarGen "b" ])
+                     , CommonGroup () u (Just $ varGen "hello") (AList () u [ declVarGen "x", declVarGen "y", declVarGen "z" ]) ]
+        let st = StCommon () u (AList () u comGrs)
+        sParser "      COMMON // a, b /hello/ x, y, z" `shouldBe'` st
+
+      it "parses 'EQUIVALENCE (a,b), (x,y,z)'" $ do
+        let ls = [ AList () u [varGen "a", varGen "b"]
+                 , AList () u [varGen "x", varGen "y", varGen "z"] ]
+        let st = StEquivalence () u (AList () u ls)
+        sParser "      EQUIVALENCE (a,b), (x,y,z)" `shouldBe'` st
+
+      it "parses 'DATA a/1,2,3/,x/42/'" $ do
+        let dGrs = [ DataGroup () u (AList () u [varGen "a"]) (AList () u [intGen 1, intGen 2, intGen 3])
+                   , DataGroup () u (AList () u [varGen "x"]) (AList () u [intGen 42]) ]
+        let st = StData () u $ AList () u dGrs
+        sParser "      DATA a/1,2,3/, x/42/" `shouldBe'` st
+
+      describe "FORMAT" $ do
+        it "parses 'FORMAT ()'" $ do
+          let expectedSt = StFormatBogus () u "()"
+          sParser "      FORMAT ()" `shouldBe'` expectedSt
+
+        it "parses 'FORMAT (///)'" $ do
+          let expectedSt = StFormatBogus () u "(///)"
+          sParser "      FORMAT (///)" `shouldBe'` expectedSt
+
+        it "parses 'FORMAT (2i5/5hhello)'" $ do
+          let expectedSt = StFormatBogus () u "(2i5/5hhello)"
+          sParser "      FORMAT (2i5/5hhello)" `shouldBe'` expectedSt
+
+        it "parses 'FORMAT (/(i5))'" $ do
+          let expectedSt = StFormatBogus () u "(/(i5))"
+          sParser "      FORMAT (/(i5))" `shouldBe'` expectedSt
+
+      describe "CALL" $ do
+        it "parses 'CALL me" $ do
+          let expectedSt = StCall () u (ExpValue () u (ValVariable "me")) Nothing
+          sParser "      CALL me" `shouldBe'` expectedSt
+
+        it "parses 'CALL me(baby)" $ do
+          let args = AList () u [ Argument () u Nothing $ ArgExpr $ varGen "baby" ]
+          let expectedSt = StCall () u (ExpValue () u (ValVariable "me")) $ Just args
+          sParser "      CALL me(baby)" `shouldBe'` expectedSt
+
+      it "parses 'stop'" $ do
+        let expectedSt = StStop () u Nothing
+        sParser "      stop" `shouldBe'` expectedSt
+
+      it "parses 'integer i, j(2,2), k'" $ do
+        let dimDecls = replicate 2 $ DimensionDeclarator () u Nothing (Just $ intGen 2)
+            declarators = [ Declarator () u (varGen "i") ScalarDecl Nothing Nothing
+                          , Declarator () u (varGen "j") (ArrayDecl (AList () u dimDecls)) Nothing Nothing
+                          , Declarator () u (varGen "k") ScalarDecl Nothing Nothing ]
+            st = StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing $ AList () u declarators
+        sParser "      integer i, j(2,2), k" `shouldBe'` st
+
+      let controlPairs = AList () u [ ControlPair () u Nothing (intGen 6), ControlPair () u Nothing (labelGen 10) ]
+      let writeSt = StWrite () u controlPairs (Just $ AList () u [ varGen "i" ])
+
+      describe "WRITE" $ do
+        it "parses 'write (6)'" $ do
+          let expectedSt = StWrite () u (AList () u [ ControlPair () u Nothing (intGen 6) ]) Nothing
+          sParser "      write (6)" `shouldBe'` expectedSt
+
+        it "parses 'write (6) i'" $ do
+          let expectedSt = StWrite () u (AList () u [ ControlPair () u Nothing (intGen 6) ]) (Just $ AList () u [ varGen "i" ])
+          sParser "      write (6) i" `shouldBe'` expectedSt
+
+        it "parses 'write (6,10) i'" $
+          sParser "      write (6,10) i" `shouldBe'` writeSt
+
+      describe "IF" $ do
+        it "parses 'if (10 .LT. x) write (6,10) i'" $ do
+          let cond = ExpBinary () u LT (intGen 10) (varGen "x")
+          let expectedSt = StIfLogical () u cond writeSt
+          sParser "      if (10 .LT. x) write (6,10) i" `shouldBe'` expectedSt
+
+        it "parses 'if (10 - 5) 10, 20, 30'" $ do
+          let cond = ExpBinary () u Subtraction (intGen 10) (intGen 5)
+          let expectedSt = StIfArithmetic () u cond (labelGen 10) (labelGen 20) (labelGen 30)
+          sParser "      if (10 - 5) 10, 20, 30" `shouldBe'` expectedSt
+
+        it "parses 'IF (IY) 5,6,6" $ do
+          let expectedSt = StIfArithmetic () u (varGen "iy") (labelGen 5) (labelGen 6) (labelGen 6)
+          sParser "      IF (IY) 5,6,6" `shouldBe'` expectedSt
+
+      describe "ASSIGNMENT" $ do
+        it "parses 'f = 1'" $ do
+          let expectedSt = StExpressionAssign () u (varGen "f") (intGen 1)
+          sParser "      f = 1" `shouldBe'` expectedSt
+
+        it "parses 'f = a(1,2)'" $ do
+          let indicies = fromList () [ ixSinGen 1, ixSinGen 2 ]
+          let rhs = ExpSubscript () u (varGen "a") indicies
+          let expectedSt = StExpressionAssign () u (varGen "f") rhs
+          sParser "      f = a(1,2)" `shouldBe'` expectedSt
+
+      it "parses 'do 42 i = 10, 1, 1'" $ do
+        let st = StExpressionAssign () u (varGen "i") (intGen 10)
+        let doSpec = DoSpecification () u st (intGen 1) (Just $ intGen 1)
+        let expectedSt = StDo () u Nothing (Just $ labelGen 42) (Just doSpec)
+        sParser "      do 42 i = 10, 1, 1" `shouldBe'` expectedSt
diff --git a/test/Language/Fortran/Parser/Fixed/Fortran77/IncludeSpec.hs b/test/Language/Fortran/Parser/Fixed/Fortran77/IncludeSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Language/Fortran/Parser/Fixed/Fortran77/IncludeSpec.hs
@@ -0,0 +1,52 @@
+module Language.Fortran.Parser.Fixed.Fortran77.IncludeSpec where
+
+import System.FilePath
+import Test.Hspec
+import TestUtil
+
+import Language.Fortran.Parser ( f77lIncludes )
+import Language.Fortran.AST
+import Language.Fortran.Util.Position
+import qualified Data.ByteString.Char8 as B
+
+iParser :: [String] -> String -> IO (ProgramFile A0)
+iParser incs = f77lIncludes incs mempty "<unknown>" . B.pack
+
+makeSrcR :: (Int, Int, Int, String) -> (Int, Int, Int, String) -> SrcSpan
+makeSrcR (i1, i2, i3, s) (j1, j2, j3, s') = SrcSpan (Position i1 i2 i3 s Nothing) (Position j1 j2 j3 s' Nothing)
+
+spec :: SpecWith ()
+spec =
+  describe "Include Test" $ do
+    let source = unlines ["      program bar",
+                          "      include 'foo.f'",
+                          "      end"
+                         ]
+        inc = "./test-data/f77-include"
+        name = "bar"
+        pf = ProgramFile mi77' [pu]
+        puSpan = makeSrcR (6,7,1,"<unknown>") (48,9,3,"<unknown>")
+        st1Span = makeSrcR (24,7,2,"<unknown>") (38,21,2,"<unknown>")
+        expSpan = makeSrcR (32,15,2,"<unknown>") (38,21,2,"<unknown>")
+
+        -- the expansion returns the span in the included file
+        -- it should return the span at the inclusion
+        foo = inc </> "foo.f"
+        st2Span = makeSrcR (6,7,1, foo) (14,15,1,foo)
+        declSpan = makeSrcR (6,7,1,foo) (14,15,1,foo)
+        typeSpan = makeSrcR (6,7,1,foo) (12,13,1,foo)
+        blockSpan = makeSrcR (14,15,1,foo) (14,15,1,foo)
+        varGen' str =  ExpValue () blockSpan $ ValVariable str
+
+        pu = PUMain () puSpan (Just name) blocks Nothing
+        blocks = [bl1]
+        decl = Declarator () blockSpan (varGen' "a") ScalarDecl Nothing Nothing
+        typeSpec = TypeSpec () typeSpan TypeInteger Nothing
+        st2 = StDeclaration () st2Span typeSpec Nothing (AList () blockSpan [decl])
+        bl1 = BlStatement () st1Span Nothing st1
+        st1 = StInclude () st1Span ex (Just [bl2])
+        ex = ExpValue () expSpan (ValString "foo.f")
+        bl2 = BlStatement () declSpan Nothing st2
+    it "includes some files and expands them" $ do
+      pfParsed <- iParser [inc] source
+      pfParsed `shouldBe` pf
diff --git a/test/Language/Fortran/Parser/Fixed/Fortran77/ParserSpec.hs b/test/Language/Fortran/Parser/Fixed/Fortran77/ParserSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Language/Fortran/Parser/Fixed/Fortran77/ParserSpec.hs
@@ -0,0 +1,412 @@
+module Language.Fortran.Parser.Fixed.Fortran77.ParserSpec where
+
+import Test.Hspec
+import TestUtil
+
+import Language.Fortran.AST
+import Language.Fortran.Version
+import Language.Fortran.Parser
+import Language.Fortran.Parser.Monad ( Parse )
+import qualified Language.Fortran.Parser.Fixed.Fortran77 as F77
+import qualified Language.Fortran.Parser.Fixed.Lexer     as Fixed
+
+import Prelude hiding ( exp )
+import qualified Data.ByteString.Char8 as B
+
+parseWith :: FortranVersion -> Parse Fixed.AlexInput Fixed.Token a -> String -> a
+parseWith fv p = parseUnsafe (makeParserFixed p fv) . B.pack
+
+pParser :: String -> ProgramFile ()
+pParser = parseWith Fortran77 F77.programParser
+
+bParser :: String -> Block ()
+bParser = parseWith Fortran77Legacy F77.blockParser
+
+sParser :: String -> Statement ()
+sParser = parseWith Fortran77 F77.statementParser
+
+eParser :: String -> Expression ()
+eParser = parseUnsafe p . B.pack
+  where p = makeParser initParseStateFixedExpr F77.expressionParser Fortran77
+
+plParser :: String -> ProgramFile ()
+plParser = parseWith Fortran77Legacy F77.programParser
+
+slParser :: String -> Statement ()
+slParser = parseWith Fortran77Legacy F77.statementParser
+
+spec :: Spec
+spec =
+  describe "Fortran 77 Parser" $ do
+    describe "IO" $ do
+      it "parses 'print *, 9000" $ do
+        let expectedSt = StPrint () u starVal $ Just (AList () u [ intGen 9000 ])
+        sParser "      print *, 9000" `shouldBe'` expectedSt
+
+      it "parses 'write (UNIT=6, FORMAT=*)" $ do
+        let cp1 = ControlPair () u (Just "unit") (intGen 6)
+            cp2 = ControlPair () u (Just "format") starVal
+            expectedSt = StWrite () u (AList () u [cp1, cp2]) Nothing
+        sParser "      write (UNIT=6, FORMAT=*)" `shouldBe'` expectedSt
+
+      it "parses 'endfile i" $
+        sParser "      endfile i" `shouldBe'` StEndfile2 () u (varGen "i")
+
+      it "parses 'read *, (x, y(i), i = 1, 10, 2)'" $ do
+        let stAssign = StExpressionAssign () u (varGen "i") (intGen 1)
+            doSpec = DoSpecification () u stAssign (intGen 10) (Just $ intGen 2)
+            impliedDoVars = AList () u [ varGen "x", ExpSubscript () u (varGen "y") (AList () u [ IxSingle () u Nothing $ varGen "i" ])]
+            impliedDo = ExpImpliedDo () u impliedDoVars doSpec
+            iolist = AList () u [ impliedDo ]
+            expectedSt = StRead2 () u starVal (Just iolist)
+        sParser "      read *, (x, y(i), i = 1, 10, 2)" `shouldBe'` expectedSt
+
+    it "parses '(x, y(i), i = 1, 10, 2)'" $ do
+      let stAssign = StExpressionAssign () u (varGen "i") (intGen 1)
+          doSpec = DoSpecification () u stAssign (intGen 10) (Just $ intGen 2)
+          impliedDoVars = AList () u [ varGen "x", ExpSubscript () u (varGen "y") (AList () u [ IxSingle () u Nothing $ varGen "i" ])]
+          impliedDo = ExpImpliedDo () u impliedDoVars doSpec
+      eParser "(x, y(i), i = 1, 10, 2)" `shouldBe'` impliedDo
+
+    it "parses main program unit" $ do
+      let decl = declVarGen "x"
+          st = StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u [ decl ])
+          bl = BlStatement () u Nothing st
+          pu = ProgramFile mi77 [ PUMain () u (Just "hello") [ bl ] Nothing ]
+      pParser exampleProgram1 `shouldBe'` pu
+
+    it "parses block data unit" $ do
+      let decl = declVarGen "x"
+          st = StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u [ decl ])
+          bl = BlStatement () u Nothing st
+          pu = ProgramFile mi77 [ PUBlockData () u (Just "hello") [ bl ] ]
+      pParser exampleProgram2 `shouldBe'` pu
+
+    it "parses 'intrinsic cosh, sin'" $ do
+      let st = StIntrinsic () u (AList () u [ varGen "cosh", varGen "sin" ])
+      sParser "      intrinsic cosh, sin" `shouldBe'` st
+
+    it "parses 'intrinsic real" $ do
+      let st = StIntrinsic () u (AList () u [ varGen "real" ])
+      sParser "      intrinsic real" `shouldBe'` st
+
+    describe "CHARACTER" $ do
+      it "parses character literal assignment" $ do
+        let rhs = ExpValue () u (ValString "hello 'baby")
+            st = StExpressionAssign () u (varGen "xyz") rhs
+        sParser "      xyz = 'hello ''baby'" `shouldBe'` st
+
+      it "string concatenation" $ do
+        let str1 = ExpValue () u (ValString "hello ")
+            str2 = ExpValue () u (ValString "world")
+            exp = ExpBinary () u Concatenation str1 str2
+        eParser "'hello ' // 'world'" `shouldBe'` exp
+
+    describe "Subscript like" $ do
+      it "parses vanilla subscript" $ do
+        let exp = ExpSubscript () u (varGen "a") (AList () u [ IxSingle () u Nothing $ varGen "x", IxSingle () u Nothing $ intGen 2, IxSingle () u Nothing $ intGen 3 ])
+        eParser "a(x, 2, 3)" `shouldBe'` exp
+
+      it "parses array declarator" $ do
+        let dimDecls = [ DimensionDeclarator () u (Just $ intGen 1) (Just $ intGen 2)
+                       , DimensionDeclarator () u Nothing (Just $ intGen 15)
+                       , DimensionDeclarator () u (Just $ varGen "x") (Just starVal) ]
+            decl = declArray () u (varGen "a") (AList () u dimDecls) Nothing Nothing
+            st = StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u [ decl ])
+        sParser "      integer a(1:2, 15, x:*)" `shouldBe'` st
+
+      it "parses character substring" $ do
+        let indicies = [ ixSinGen 1, ixSinGen 2, ixSinGen 3 ]
+            subExp = ExpSubscript () u (varGen "a")  (AList () u indicies)
+            range = IxRange () u Nothing (Just $ intGen 10) Nothing
+            exp = ExpSubscript () u subExp (AList () u [ range ])
+        eParser "a(1, 2, 3)(:10)" `shouldBe'` exp
+
+      it "parses simpler substring" $ do
+        let exp = ExpSubscript () u (varGen "a") (AList () u [ ixRanGen 5 10 ])
+        eParser "a(5:10)" `shouldBe'` exp
+
+      it "parses simpler substring" $ do
+        let range = IxRange () u (Just $ intGen 5) Nothing Nothing
+            exp = ExpSubscript () u (varGen "a") (AList () u [ range ])
+        eParser "a(5:)" `shouldBe'` exp
+
+      it "parses literal string subscript" $ do
+        let range = IxRange () u (Just $ intGen 1) (Just $ intGen 2) Nothing
+            exp = ExpSubscript () u (strGen "abc") (AList () u [ range ])
+        eParser "'abc'(1:2)" `shouldBe'` exp
+
+    describe "GOTO" $ do
+      it "parses computed GOTO with integer expression" $ do
+        let exp = ExpBinary () u Multiplication (intGen 42) (intGen 24)
+            st = StGotoComputed () u (AList () u [labelGen 10, labelGen 20, labelGen 30]) exp
+        sParser "      GOTO (10, 20, 30), 42 * 24" `shouldBe'` st
+
+      let gotoSt = StGotoAssigned () u (varGen "v") (Just (AList () u [labelGen 10, labelGen 20, labelGen 30]))
+      it "parses assigned GOTO with comma" $
+        sParser "      GOTO v, (10, 20, 30)" `shouldBe'` gotoSt
+
+      it "parses assigned GOTO without comma" $
+        sParser "      GOTO v (10, 20, 30)" `shouldBe'` gotoSt
+
+    describe "IMPLICIT" $ do
+      it "parses 'implicit none'" $ do
+        let st = resetSrcSpan $ StImplicit () u Nothing
+        sParser "      implicit none" `shouldBe'` st
+
+      it "parses 'implicit character*30 (a, b, c), integer (a-z, l)" $ do
+        let impEls = [ImpCharacter () u "a", ImpCharacter () u "b", ImpCharacter () u "c"]
+            sel = Selector () u (Just (intGen 30)) Nothing
+            imp1 = ImpList () u (TypeSpec () u TypeCharacter (Just sel)) $ AList () u impEls
+            imp2 = ImpList () u (TypeSpec () u TypeInteger Nothing) $ AList () u [ImpRange () u "a" "z", ImpCharacter () u "l"]
+            st = StImplicit () u $ Just $ AList () u [imp1, imp2]
+        sParser "      implicit character*30 (a, b, c), integer (a-z, l)" `shouldBe'` st
+
+    it "parses 'parameter (pi = 3.14, b = 'X' // 'O', d = k) '" $ do
+      let sts = [ declVariable () u (varGen "pi") Nothing (Just $ realGen (3.14::Double))
+                , let e = ExpBinary () u Concatenation (strGen "X") (strGen "O")
+                  in declVariable () u (varGen "b") Nothing (Just e)
+                , declVariable () u (varGen "d") Nothing (Just $ varGen "k") ]
+          st = StParameter () u (AList () u sts)
+      sParser "      parameter (pi = 3.14, b = 'X' // 'O', d = k)" `shouldBe'` st
+
+    it "parses 'pause 'hello world''" $ do
+      let st = StPause () u $ Just $ strGen "hello world"
+      sParser "      pause 'hello world'" `shouldBe'` st
+
+    describe "SAVE" $ do
+      it "parses 'save /cb/, var, /key/'" $ do
+        let saveArgs = [ varGen "cb", varGen "var", varGen "key" ]
+            st = StSave () u (Just $ AList () u saveArgs)
+        sParser "      save /cb/, var, /key/" `shouldBe'` st
+
+      it "parses 'save'" $
+        sParser "      save" `shouldBe'` StSave () u Nothing
+
+    it "parses '.true. .eqv. f(42) .neqv. x'" $ do
+      let arg2 = ExpSubscript () u (varGen "f") $ AList () u [ ixSinGen 42 ]
+          arg3 = varGen "x"
+          subexp = ExpBinary () u Equivalent valTrue arg2
+          exp = ExpBinary () u NotEquivalent subexp arg3
+      eParser ".true. .eqv. f(42) .neqv. x" `shouldBe'` exp
+
+    it "parses 'entry me (a,b,*)'" $ do
+      let args = [ varGen "a", varGen "b", starVal ]
+          st = StEntry () u (varGen "me") (Just $ AList () u args) Nothing
+      sParser "      entry me (a,b,*)" `shouldBe'` st
+
+    it "parses 'character a*8'" $ do
+      let decl = declVariable () u (varGen "a") (Just $ intGen 8) Nothing
+          typeSpec = TypeSpec () u TypeCharacter Nothing
+          st = StDeclaration () u typeSpec Nothing (AList () u [ decl ])
+      sParser "      character a*8" `shouldBe'` st
+
+    it "parses 'character c*(ichar('A'))" $ do
+      let args = AList () u [ IxSingle () u Nothing (ExpValue () u (ValString "A")) ]
+          lenExpr = ExpSubscript () u (varGen "ichar") args
+          decl = declVariable () u (varGen "c") (Just $ lenExpr) Nothing
+          typeSpec = TypeSpec () u TypeCharacter Nothing
+          st = StDeclaration () u typeSpec Nothing (AList () u [ decl ])
+      sParser "      character c*(ichar('A'))" `shouldBe'` st
+
+    describe "parses if blocks" $ do
+      let printArgs  = Just $ AList () u [ExpValue () u $ ValString "foo"]
+          printStmt  = StPrint () u (ExpValue () u ValStar) printArgs
+          printBlock = BlStatement () u Nothing printStmt
+      it "unlabelled" $ do
+        let bl = BlIf () u Nothing Nothing [ Just valTrue, Nothing ] [[printBlock], [printBlock]]  Nothing
+            src = unlines [ "      if (.true.) then ! comment if"
+                          , "        print *, 'foo'"
+                          , "      else ! comment else"
+                          , "        print *, 'foo'"
+                          , "       endif ! comment end"
+                          ]
+        bParser src `shouldBe'` bl
+      it "labelled" $ do
+        let label = Just . intGen
+            bl = BlIf () u (label 10)  Nothing [Just valTrue, Nothing] [[printBlock], [printBlock]] (label 30)
+            src = unlines [ "10    if (.true.) then ! comment if"
+                          , "        print *, 'foo'"
+                          , "20    else ! comment else"
+                          , "        print *, 'foo'"
+                          , "30     endif ! comment end"
+                          ]
+        bParser src `shouldBe'` bl
+
+    describe "Legacy Extensions" $ do
+      it "parses structure/union/map blocks" $ do
+        let src = init
+                $ unlines [ "      structure /foo/"
+                          , "        union"
+                          , "          map"
+                          , "            integer i"
+                          , "          end map"
+                          , "          map"
+                          , "            real r"
+                          , "          end map"
+                          , "        end union"
+                          , "      end structure"]
+            ds = [ UnionMap () u $ AList () u
+                   [StructFields () u (TypeSpec () u TypeInteger Nothing) Nothing $
+                    AList () u [declVariable () u (varGen "i") Nothing Nothing]]
+                 , UnionMap () u $ AList () u
+                   [StructFields () u (TypeSpec () u TypeReal Nothing) Nothing $
+                    AList () u [declVariable () u (varGen "r") Nothing Nothing]]
+                 ]
+            st = StStructure () u (Just "foo") $ AList () u [StructUnion () u $ AList () u ds]
+        resetSrcSpan (slParser src) `shouldBe` st
+
+      it "parses structure/union/map blocks with comments" $ do
+        let src = init
+                $ unlines [ "      structure /foo/"
+                          , "C       comment before union"
+                          , "        union"
+                          , "C         comment inside union, before map"
+                          , "          map"
+                          , "C           comment inside map"
+                          , "            integer i ! more comment"
+                          , "          end map"
+                          , "C         comment between maps"
+                          , "          map"
+                          , "            real r    ! more comment"
+                          , "          end map"
+                          , "C         comment after map"
+                          , "        end union"
+                          , "C       comment after union"
+                          , "      end structure"]
+            ds = [ UnionMap () u $ AList () u
+                   [StructFields () u (TypeSpec () u TypeInteger Nothing) Nothing $
+                    AList () u [declVariable () u (varGen "i") Nothing Nothing]]
+                 , UnionMap () u $ AList () u
+                   [StructFields () u (TypeSpec () u TypeReal Nothing) Nothing $
+                    AList () u [declVariable () u (varGen "r") Nothing Nothing]]
+                 ]
+            st = StStructure () u (Just "foo") $ AList () u [StructUnion () u $ AList () u ds]
+        resetSrcSpan (slParser src) `shouldBe` st
+
+      it "parses nested structure blocks" $ do
+        let src = init
+                $ unlines [ "      structure /foo/"
+                          , "        structure /bar/ baz"
+                          , "          integer qux"
+                          , "        end structure"
+                          , "      end structure"]
+            var = declVariable () u (varGen "qux") Nothing Nothing
+            innerst = StructStructure () u (Just "bar") ("baz")
+              $ AList () u [StructFields () u (TypeSpec () u TypeInteger Nothing) Nothing
+                $ AList () u [var]]
+            st = StStructure () u (Just "foo") $ AList () u [innerst]
+        resetSrcSpan (slParser src) `shouldBe` st
+
+      it "parses structure data references " $ do
+        let st      = StPrint () u expStar $ Just $ AList () u [foobar]
+            foobar  = ExpDataRef () u (varGen "foo") (varGen "bar")
+            expStar = ExpValue () u ValStar
+        sParser "      print *, foo % bar" `shouldBe'` st
+        sParser "      print *, foo.bar"   `shouldBe'` st
+
+      it "parse special intrinsics to arguments" $ do
+        let blStmt stmt = BlStatement () u Nothing stmt
+            ext = blStmt $ StExternal () u $ AList () u [varGen "bar"]
+            arg = Just . AList () u . pure . Argument () u Nothing . ArgExpr
+            valBar = ExpFunctionCall () u (ExpValue () u (ValIntrinsic "%val"))
+                     $ arg $ varGen "baz"
+            call = blStmt $ StCall () u (varGen "bar") $ arg valBar
+            pu = ProgramFile mi77 [ PUSubroutine () u (Nothing, Nothing) "foo"
+                                   (Just $ AList () u [varGen "baz"]) [ ext, call ] Nothing ]
+        resetSrcSpan (plParser exampleProgram3) `shouldBe` pu
+
+      it "parses character declarations with unspecfied lengths" $ do
+        let src = "      character s*(*)"
+            st = StDeclaration () u (TypeSpec () u TypeCharacter Nothing) Nothing $
+                 AList () u [declVariable () u
+                               (varGen "s")
+                               (Just (ExpValue () u ValStar))
+                               Nothing]
+        resetSrcSpan (slParser src) `shouldBe` st
+
+      it "parses array initializers" $ do
+        let src = "      integer xs(3) / 1, 2, 3 /"
+            inits = [intGen 1, intGen 2, intGen 3]
+            st = StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing $
+                 AList () u [declArray () u
+                               (varGen "xs")
+                               (AList () u [DimensionDeclarator () u Nothing (Just (intGen 3))])
+                               Nothing
+                               (Just (ExpInitialisation () u $ AList () u inits))]
+        resetSrcSpan (slParser src) `shouldBe` st
+
+        let src1 = "      character xs(2)*5 / 'hello', 'world' /"
+            inits1 = [ExpValue () u (ValString "hello"), ExpValue () u (ValString "world")]
+            st1 = StDeclaration () u (TypeSpec () u TypeCharacter Nothing) Nothing $
+                 AList () u [declArray () u
+                               (varGen "xs")
+                               (AList () u [DimensionDeclarator () u Nothing (Just (intGen 2))])
+                               (Just (intGen 5))
+                               (Just (ExpInitialisation () u $ AList () u inits1))]
+        resetSrcSpan (slParser src1) `shouldBe` st1
+
+        let src2 = "      character xs*5(2) / 'hello', 'world' /"
+            inits2 = [ExpValue () u (ValString "hello"), ExpValue () u (ValString "world")]
+            st2 = StDeclaration () u (TypeSpec () u TypeCharacter Nothing) Nothing $
+                 AList () u [declArray () u
+                               (varGen "xs")
+                               (AList () u [DimensionDeclarator () u Nothing (Just (intGen 2))])
+                               (Just (intGen 5))
+                               (Just (ExpInitialisation () u $ AList () u inits2))]
+        resetSrcSpan (slParser src2) `shouldBe` st2
+
+      it "parses subscripts in assignments" $ do
+        let mkIdx i = IxSingle () u Nothing (intGen i)
+
+            src = "      x(0,1) = 0"
+            tgt = ExpSubscript () u (varGen "x") (AList () u [mkIdx 0, mkIdx 1])
+            st = StExpressionAssign () u tgt (intGen 0)
+        resetSrcSpan (slParser src) `shouldBe` st
+
+        let src1 = "      x(0).foo = 0"
+            tgt1 = ExpDataRef () u (ExpSubscript () u (varGen "x") (AList () u [mkIdx 0])) (varGen "foo")
+            st1 = StExpressionAssign () u tgt1 (intGen 0)
+        resetSrcSpan (slParser src1) `shouldBe` st1
+
+        let src2 = "      x.foo = 0"
+            tgt2 = ExpDataRef () u (varGen "x") (varGen "foo")
+            st2 = StExpressionAssign () u tgt2 (intGen 0)
+        resetSrcSpan (slParser src2) `shouldBe` st2
+
+        let src3 = "      x.foo(0) = 0"
+            tgt3 = ExpSubscript () u (ExpDataRef () u (varGen "x") (varGen "foo")) (AList () u [mkIdx 0])
+            st3 = StExpressionAssign () u tgt3 (intGen 0)
+        resetSrcSpan (slParser src3) `shouldBe` st3
+      it "parses automatic and static statements" $ do
+        let decl = declVariable () u (varGen "x") Nothing Nothing
+            autoStmt = StAutomatic () u (AList () u [decl])
+            staticStmt = StStatic () u (AList () u [decl])
+            autoSrc =  "      automatic x"
+            staticSrc = "      static x"
+        resetSrcSpan (slParser autoSrc) `shouldBe` autoStmt
+        resetSrcSpan (slParser staticSrc) `shouldBe` staticStmt
+
+exampleProgram1 :: String
+exampleProgram1 = unlines
+  [ "      program hello"
+  , "      integer x"
+  , "      end" ]
+
+exampleProgram2 :: String
+exampleProgram2 = unlines
+  [ "      block data hello"
+  , "      integer x"
+  , "      end" ]
+
+exampleProgram3 :: String
+exampleProgram3 = unlines
+  [ "      subroutine foo(baz)"
+  , "      external bar"
+  , "      call bar(%val(baz))"
+  , "      end subroutine foo"]
+
+-- Local variables:
+-- mode: haskell
+-- haskell-program-name: "cabal repl test-suite:spec"
+-- End:
diff --git a/test/Language/Fortran/Parser/Fixed/LexerSpec.hs b/test/Language/Fortran/Parser/Fixed/LexerSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Language/Fortran/Parser/Fixed/LexerSpec.hs
@@ -0,0 +1,324 @@
+module Language.Fortran.Parser.Fixed.LexerSpec where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck
+import TestUtil
+
+import Language.Fortran.Parser.Fixed.Lexer
+import Language.Fortran.Parser
+import Language.Fortran.Parser.Monad ( ParseState, getAlex, evalParse )
+import Language.Fortran.AST.Boz
+import Language.Fortran.Version
+
+import Data.List (isPrefixOf)
+import qualified Data.ByteString.Char8 as B
+
+initState :: FortranVersion -> B.ByteString -> ParseState AlexInput
+initState = initParseStateFixed "<unknown>"
+
+collectFixedTokens :: FortranVersion -> B.ByteString -> [Token]
+collectFixedTokens fv bs =
+    collectTokens lexer' $ initState fv bs
+
+collectFixedTokens' :: FortranVersion -> String -> [Token]
+collectFixedTokens' v = collectFixedTokens v . B.pack
+
+collectFixedTokensSafe :: FortranVersion -> B.ByteString -> Maybe [Token]
+collectFixedTokensSafe fv bs =
+    collectTokensSafe lexer' $ initState fv bs
+
+lex66 :: String -> Maybe Token
+lex66 = collectToLex Fortran66
+
+safeLex66 :: String -> Maybe Token
+safeLex66 = collectToLexSafe Fortran66
+
+lex77 :: String -> Maybe Token
+lex77 = collectToLex Fortran77
+
+collectToLex :: FortranVersion -> String -> Maybe Token
+collectToLex version srcInput = dropUntil2 $ collectFixedTokens version (B.pack srcInput)
+  where
+    dropUntil2 [] = Nothing
+    dropUntil2 [_] = Nothing
+    dropUntil2 [a,_] = Just a
+    dropUntil2 (_:xs) = dropUntil2 xs
+
+collectToLexSafe :: FortranVersion -> String -> Maybe Token
+collectToLexSafe version srcInput = dropUntil2 $ collectFixedTokensSafe version (B.pack srcInput)
+  where
+    dropUntil2 (Just [a,_]) = Just a
+    dropUntil2 (Just (_:xs)) = dropUntil2 $ Just xs
+    dropUntil2 _ = Nothing
+
+spec :: Spec
+spec =
+  describe "Fortran Fixed Form Lexer" $ do
+    describe "Fortran 77" $
+      describe "String" $ do
+        it "lexes 'hello'" $
+          resetSrcSpan (lex77 "      c = 'hello'") `shouldBe` resetSrcSpan (Just $ TString u "hello")
+
+        it "lexes 'he''llo'" $
+          resetSrcSpan (lex77 "      c = 'he''llo'") `shouldBe` resetSrcSpan (Just $ TString u "he'llo")
+
+        it "lexes 'he''''ll''o'" $
+          resetSrcSpan (lex77 "      c = 'he''''ll''o'") `shouldBe` resetSrcSpan (Just $ TString u "he''ll'o")
+
+        it "lexes '''hello'''" $
+          resetSrcSpan (lex77 "      c = '''hello'''") `shouldBe` resetSrcSpan (Just $ TString u "'hello'")
+
+        it "lexes 'hello world'" $
+          resetSrcSpan (lex77 "      c = 'hello world'") `shouldBe` resetSrcSpan (Just $ TString u "hello world")
+
+        it "lexes 'hello world'" $
+          resetSrcSpan (collectFixedTokens' Fortran77 "      c = 'x' // 'o'") `shouldBe` resetSrcSpan [TId u "c", TOpAssign u, TString u "x", TSlash u, TSlash u, TString u "o", TEOF u]
+
+    describe "Fortran 66" $ do
+      prop "lexes Label, Comment, Newline or EOF in the first six columns or returns Nothing " $
+        \x -> isPrefixOf "      " x || case safeLex66 x of
+                Nothing -> True
+                Just (TLabel _ _) -> True
+                Just (TComment _ _) -> True
+                Just (TEOF _) -> True
+                Just (TNewline _) -> True
+                _ -> False
+
+      it "lexes alphanumeric identifier" $
+        resetSrcSpan (collectFixedTokens' Fortran66 "      e42 =") `shouldBe` resetSrcSpan [TId u "e42", TOpAssign u, TEOF u]
+
+      it "lexes exponent" $
+        resetSrcSpan (collectFixedTokens' Fortran66 "      a = 42 e42") `shouldBe` resetSrcSpan [TId u "a", TOpAssign u, TInt u "42", TExponent u "e42", TEOF u]
+
+      it "lexes 'function foo()'" $
+        resetSrcSpan (collectFixedTokens' Fortran66 "      function foo()") `shouldBe` resetSrcSpan [TFunction u, TId u "foo", TLeftPar u, TRightPar u, TEOF u]
+
+      it "lexes 'end'" $
+        resetSrcSpan (lex66 "      end") `shouldBe` resetSrcSpan (Just $ TEnd u)
+
+      it "lexes identifier" $
+        resetSrcSpan (lex66 "      a = mistr") `shouldBe` resetSrcSpan (Just $ TId u "mistr")
+
+      it "lexes comment if first column is C" $
+        resetSrcSpan (lex66 "c this is a comment") `shouldBe` resetSrcSpan (Just $ TComment u " this is a comment")
+
+      it "lexes empty comment" $
+        resetSrcSpan (lex66 "c") `shouldBe` resetSrcSpan (Just $ TComment u "")
+
+      it "lexes comment with one char" $
+        resetSrcSpan (lex66 "ca") `shouldBe` resetSrcSpan (Just $ TComment u "a")
+
+      it "should not lex from the next line" $
+        resetSrcSpan (safeLex66 "cxxx\nselam") `shouldNotBe` resetSrcSpan (Just $ TComment u "xxxselam")
+
+      -- This is commented out as identifiers are longer than what the standard says.
+      it "lexes three tokens"  $ do
+        pending
+        resetSrcSpan (collectFixedTokens' Fortran66 "      function end format") `shouldBe` resetSrcSpan [TFunction u, TId u "endfor", TId u "mat", TEOF u]
+
+      it "lexes multiple comments in a line" $
+        resetSrcSpan (collectFixedTokens' Fortran66 "csomething\ncsomething else\n\nc\ncc\n") `shouldBe`
+          resetSrcSpan [TComment u "something", TNewline u, TComment u "something else", TNewline u, TNewline u, TComment u "", TNewline u, TComment u "c", TNewline u, TEOF u]
+
+      it "lexes example1" $
+        resetSrcSpan (collectFixedTokens' Fortran66 example1) `shouldBe` resetSrcSpan example1Expectation
+
+      it "lexes end of file" $
+        resetSrcSpan (lex66 "") `shouldBe` Nothing
+
+      it "lexes '3 + 2'" $
+        resetSrcSpan (collectFixedTokens' Fortran66 "      a = 3 + 2") `shouldBe` resetSrcSpan [TId u "a", TOpAssign u, TInt u "3", TOpPlus u , TInt u "2", TEOF u]
+
+      it "should lex continuation lines properly" $
+        resetSrcSpan (collectFixedTokens' Fortran66 continuationExample) `shouldBe` resetSrcSpan [ TType u "integer", TId u "ix", TNewline u, TId u "ix", TOpAssign u, TInt u "42", TNewline u, TEnd u, TNewline u, TEOF u ]
+
+      it "lexes 'ASSIGN 100 TO FOO'" $
+        resetSrcSpan (collectFixedTokens' Fortran66 "      ASSIGN 100 TO FOO") `shouldBe` resetSrcSpan [TAssign u, TInt u "100", TTo u, TId u "foo", TEOF u]
+
+      it "lexes 'DO 100 dovar = 1, 10'" $
+        resetSrcSpan (collectFixedTokens' Fortran66 "      DO 100 dovar = 1, 10")
+          `shouldBe`
+          resetSrcSpan [TDo u, TInt u "100", TId u "dovar", TOpAssign u, TInt u "1", TComma u, TInt u "10", TEOF u]
+
+    describe "lexN" $
+      it "`lexN 5` parses lexes next five characters" $
+        (lexemeMatch . aiLexeme) (evalParse (lexN 5 >> getAlex) (initState Fortran66 (B.pack "helloWorld"))) `shouldBe` reverse "hello"
+
+    describe "lexHollerith" $ do
+      it "lexes Hollerith '7hmistral'" $
+        resetSrcSpan (lex66 "      x = 7hmistral") `shouldBe` resetSrcSpan (Just $ THollerith u "mistral")
+
+      it "becomes case sensitive" $
+        resetSrcSpan (collectFixedTokens' Fortran66 "      format (5h a= 1)") `shouldBe` resetSrcSpan [ TFormat u, TBlob u "(5ha=1)", TEOF u ]
+
+    it "lexes if statement '        IF (IY) 5,6,6'" $
+      resetSrcSpan (collectFixedTokens' Fortran66 "      IF (IY) 5,6,6") `shouldBe` resetSrcSpan [TIf u, TLeftPar u, TId u "iy", TRightPar u, TInt u "5", TComma u, TInt u "6", TComma u, TInt u "6", TEOF u]
+
+    it "lexes if then statement '      if (x) then'" $
+      resetSrcSpan (collectFixedTokens' Fortran77 "      if (x) then") `shouldBe` resetSrcSpan [TIf u, TLeftPar u, TId u "x", TRightPar u, TThen u, TEOF u]
+
+    it "lexes if variable decl '      INTEGER IF'" $  -- yes, really..
+      resetSrcSpan (collectFixedTokens' Fortran77 "      INTEGER IF")
+        `shouldBe` resetSrcSpan [TType u "integer", TId u "if", TEOF u]
+
+    describe "Fortran 77 Legacy" $ do
+      it "lexes inline comments" $
+        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      integer foo ! bar")
+          `shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TEOF u]
+
+      it "lexes continuation lines separated by comments" $ do
+        let src = unlines [ "      integer foo,"
+                          , "C hello"
+                          , "     +        bar"
+                          ]
+          in resetSrcSpan (collectFixedTokens' Fortran77Legacy src)
+            `shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TComma u, TId u "bar", TNewline u, TEOF u]
+        let src = unlines [ "      integer foo, ! hello"
+                          , "     +        bar"
+                          ]
+          in resetSrcSpan (collectFixedTokens' Fortran77Legacy src)
+            `shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TComma u, TId u "bar", TNewline u, TEOF u]
+        let src = unlines [ "      integer foo,"
+                          , ""
+                          , "     +        bar"
+                          ]
+          in resetSrcSpan (collectFixedTokens' Fortran77Legacy src)
+            `shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TComma u, TId u "bar", TNewline u, TEOF u]
+        let src = unlines [ "      integer foo,"
+                          , "  " -- the space is intentional
+                          , "     +        bar"
+                          ]
+          in resetSrcSpan (collectFixedTokens' Fortran77Legacy src)
+            `shouldBe` resetSrcSpan [TType u "integer", TId u "foo", TComma u, TId u "bar", TNewline u, TEOF u]
+
+      it "lexes the older TYPE statement" $
+        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      type *, 'hello'")
+          `shouldBe` resetSrcSpan [TTypePrint u, TStar u, TComma u, TString u "hello", TEOF u]
+
+      it "lexes width-specific type declarations" $ do
+        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      integer*4 i")
+          `shouldBe` resetSrcSpan [TType u "integer", TStar u, TInt u "4", TId u "i", TEOF u]
+
+        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      integer*4 function foo()")
+          `shouldBe` resetSrcSpan [TType u "integer", TStar u, TInt u "4", TFunction u, TId u "foo", TLeftPar u, TRightPar u, TEOF u]
+
+        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      character*4 s")
+          `shouldBe` resetSrcSpan [TType u "character", TStar u, TInt u "4", TId u "s", TEOF u]
+
+        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      character*(*) s")
+          `shouldBe` resetSrcSpan [TType u "character", TStar u, TLeftPar u, TStar u, TRightPar u, TId u "s", TEOF u]
+
+        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      character s*(*)")
+          `shouldBe` resetSrcSpan [TType u "character", TId u "s", TStar u, TLeftPar u, TStar u, TRightPar u, TEOF u]
+
+      it "lexes strings case-sensitively" $
+        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      c = 'Hello'")
+          `shouldBe` resetSrcSpan [TId u "c", TOpAssign u, TString u "Hello", TEOF u]
+
+      it "lexes strings delimited by '\"'" $
+        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      c = \"hello\"")
+          `shouldBe` resetSrcSpan [TId u "c", TOpAssign u, TString u "hello", TEOF u]
+
+      it "lexes Hollerith constants" $ do
+        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      x = 7hmistral")
+          `shouldBe` resetSrcSpan [TId u "x", TOpAssign u, THollerith u "mistral", TEOF u]
+
+        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      x = 7hshort\n")
+          `shouldBe` resetSrcSpan [TId u "x", TOpAssign u, THollerith u "short  ", TNewline u, TEOF u]
+
+      it "lexes BOZ constants" $
+        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      integer i, j, k / b'0101', o'0755', z'ab01' /")
+          `shouldBe` resetSrcSpan [ TType u "integer"
+                                  , TId u "i", TComma u, TId u "j", TComma u, TId u "k"
+                                  , TSlash u, TBozLiteral u (parseBoz "b'0101'")
+                                  , TComma u, TBozLiteral u (parseBoz "o'0755'")
+                                  , TComma u, TBozLiteral u (parseBoz "z'ab01'")
+                                  , TSlash u , TEOF u ]
+
+      it "lexes non-standard identifiers" $
+        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      integer _this_is_a_long_identifier$")
+          `shouldBe` resetSrcSpan [TType u "integer", TId u "_this_is_a_long_identifier$", TEOF u]
+
+      it "lexes ';' as a line-terminator" $
+        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      integer i; integer j")
+          `shouldBe` resetSrcSpan [TType u "integer", TId u "i", TNewline u, TType u "integer", TId u "j", TEOF u]
+
+      it "does not lex ';' as a line-terminator in first 6 columns" $
+        safeLex66 "; integer i; integer j" `shouldBe` Nothing
+
+      it "lexes subscripts in assignments" $
+        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      x(0,0) = 0")
+          `shouldBe` resetSrcSpan [TId u "x", TLeftPar u, TInt u "0", TComma u, TInt u "0", TRightPar u, TOpAssign u, TInt u "0", TEOF u]
+
+      it "lexes labeled DO WHILE blocks" $
+        resetSrcSpan (collectFixedTokens' Fortran77Legacy "      do 10 while (.true.)")
+          `shouldBe` resetSrcSpan [TDo u, TInt u "10", TWhile u, TLeftPar u, TBool u True, TRightPar u, TEOF u]
+
+      it "lexes structure/union/map blocks" $ do
+        let src = unlines [ "      structure /foo/"
+                          , "        union"
+                          , "          map"
+                          , "            integer i"
+                          , "            real r"
+                          , "          end map"
+                          , "        end union"
+                          , "      end structure"]
+        resetSrcSpan (collectFixedTokens' Fortran77Legacy src)
+          `shouldBe` resetSrcSpan [ TStructure u, TSlash u, TId u "foo", TSlash u, TNewline u
+                                  , TUnion u, TNewline u
+                                  , TMap u, TNewline u
+                                  , TType u "integer", TId u "i", TNewline u
+                                  , TType u "real", TId u "r", TNewline u
+                                  , TEndMap u, TNewline u
+                                  , TEndUnion u, TNewline u
+                                  , TEndStructure u, TNewline u
+                                  , TEOF u ]
+
+      it "lexes but skips comments after 72" $ do
+        let src  = unlines [ "       l = r" <> replicate 65 ' ' <> "! comment after 72"
+                           , "       r = l"
+                           , replicate 72 ' ' <> "blank line with comment"]
+        resetSrcSpan (collectFixedTokens' Fortran77Legacy src) `shouldBe`
+          resetSrcSpan [ TId u "l", TOpAssign u, TId u "r", TNewline u
+                       , TId u "r", TOpAssign u, TId u "l", TNewline u
+                       , TNewline u, TEOF u]
+      it "lexes comment overflow" $ do
+        let src = unlines
+              [ "      l = r" <> replicate 65 ' ' <>  "Comment overflowing 72 limit"
+              , "      r = l"
+              ]
+        resetSrcSpan (collectFixedTokens' Fortran77Legacy src) `shouldBe`
+          resetSrcSpan [ TId u "l", TOpAssign u, TId u "r", TNewline u
+                       , TId u "r", TOpAssign u, TId u "l", TNewline u, TEOF u]
+      it "lexel comment line overflow" $ do
+        let src = unlines [ replicate 80 'c'
+                          , "      l = r" ]
+        resetSrcSpan (collectFixedTokens' Fortran77Legacy src) `shouldBe`
+          resetSrcSpan [ TComment u (replicate 71 'c'), TNewline u
+                       , TId u "l", TOpAssign u, TId u "r", TNewline u, TEOF u]
+
+example1 :: String
+example1 = unlines [
+  "      intEGerix",
+  "1         iX= 42",
+  " 200    ix =IX* ix",
+  " 10   wrITe (*,*), ix",
+  "        EnD" ]
+
+continuationExample :: String
+continuationExample = unlines [
+  "      inte",
+  "     .ger i",
+  "     .x",
+  "      ix = 4",
+  "     .2",
+  "      end"]
+
+example1Expectation :: [Token]
+example1Expectation = [
+  TType u "integer", TId u "ix", TNewline u,
+  TLabel u "1", TId u "ix", TOpAssign u, TInt u "42", TNewline u,
+  TLabel u "200", TId u "ix", TOpAssign u, TId u "ix", TStar u, TId u "ix", TNewline u,
+  TLabel u "10", TWrite u, TLeftPar u, TStar u, TComma u, TStar u, TRightPar u, TComma u, TId u "ix", TNewline u,
+  TEnd u, TNewline u,
+  TEOF u]
diff --git a/test/Language/Fortran/Parser/Fortran2003Spec.hs b/test/Language/Fortran/Parser/Fortran2003Spec.hs
deleted file mode 100644
--- a/test/Language/Fortran/Parser/Fortran2003Spec.hs
+++ /dev/null
@@ -1,180 +0,0 @@
-module Language.Fortran.Parser.Fortran2003Spec where
-
-
-import Prelude hiding (GT, EQ, exp, pred)
-
-import Test.Hspec
-import TestUtil
-import Language.Fortran.Parser.FreeFormCommon
-
-import Language.Fortran.AST
-import Language.Fortran.ParserMonad
-import Language.Fortran.Lexer.FreeForm
-import Language.Fortran.Parser.Fortran2003
-import qualified Data.ByteString.Char8 as B
-
-eParser :: String -> Expression ()
-eParser sourceCode =
-  case evalParse statementParser parseState of
-    (StExpressionAssign _ _ _ e) -> e
-    _ -> error "unhandled evalParse"
-  where
-    paddedSourceCode = B.pack $ "      a = " ++ sourceCode
-    parseState =  initParseState paddedSourceCode Fortran2003 "<unknown>"
-
-simpleParser :: Parse AlexInput Token a -> String -> a
-simpleParser p sourceCode =
-  evalParse p $ initParseState (B.pack sourceCode) Fortran2003 "<unknown>"
-
-sParser :: String -> Statement ()
-sParser = simpleParser statementParser
-
-fParser :: String -> ProgramUnit ()
-fParser = simpleParser functionParser
-
-bParser :: String -> Block ()
-bParser = simpleParser blockParser
-
-spec :: Spec
-spec =
-  describe "Fortran 2003 Parser" $ do
-    describe "Modules" $ do
-      it "parses use statement, intrinsic module" $ do
-        let renames = fromList ()
-              [ UseRename () u (varGen "sprod") (varGen "prod")
-              , UseRename () u (varGen "a") (varGen "b") ]
-            st = StUse () u (varGen "mod") (Just ModIntrinsic) Permissive (Just renames)
-        sParser "use, intrinsic :: mod, sprod => prod, a => b" `shouldBe'` st
-
-      it "parses use statement, non_intrinsic module" $ do
-        let renames = fromList ()
-              [ UseRename () u (varGen "sprod") (varGen "prod")
-              , UseRename () u (varGen "a") (varGen "b") ]
-            st = StUse () u (varGen "mod") (Just ModNonIntrinsic) Exclusive (Just renames)
-        sParser "use, non_intrinsic :: mod, only: sprod => prod, a => b" `shouldBe'` st
-
-      it "parses use statement, unspecified nature of module" $ do
-        let renames = fromList ()
-              [ UseRename () u (varGen "sprod") (varGen "prod")
-              , UseRename () u (varGen "a") (varGen "b") ]
-            st = StUse () u (varGen "mod") Nothing Permissive (Just renames)
-        sParser "use :: mod, sprod => prod, a => b" `shouldBe'` st
-
-      it "parses procedure (interface-name, attribute, proc-decl)" $ do
-        let call = ExpFunctionCall () u (varGen "c") Nothing
-            st = StProcedure () u (Just (ProcInterfaceName () u (varGen "a")))
-                                  (Just (AttrSave () u))
-                                  (AList () u [ProcDecl () u (varGen "b") (Just call)])
-        sParser "PROCEDURE(a), SAVE :: b => c()" `shouldBe'` st
-
-      it "parses procedure (class-star, bind-name, proc-decls)" $ do
-        let call = ExpFunctionCall () u (varGen "c") Nothing
-            clas = TypeSpec () u ClassStar Nothing
-            st = StProcedure () u (Just (ProcInterfaceType () u clas))
-                                  (Just (AttrSuffix () u (SfxBind () u (Just (ExpValue () u (ValString "e"))))))
-                                  (AList () u [ProcDecl () u (varGen "b") (Just call)
-                                              ,ProcDecl () u (varGen "d") (Just call)])
-        sParser "PROCEDURE(CLASS(*)), BIND(C, NAME=\"e\") :: b => c(), d => c()" `shouldBe'` st
-
-      it "parses procedure (class-custom, bind, proc-decls)" $ do
-        let call = ExpFunctionCall () u (varGen "c") Nothing
-            clas = TypeSpec () u (ClassCustom "e") Nothing
-            st = StProcedure () u (Just (ProcInterfaceType () u clas))
-                                  (Just (AttrSuffix () u (SfxBind () u Nothing)))
-                                  (AList () u [ProcDecl () u (varGen "b") (Just call)
-                                              ,ProcDecl () u (varGen "d") (Just call)])
-        sParser "PROCEDURE(CLASS(e)), BIND(C) :: b => c(), d => c()" `shouldBe'` st
-
-      it "import statements" $ do
-        let st = StImport () u (AList () u [varGen "a", varGen "b"])
-        sParser "import a, b" `shouldBe'` st
-        sParser "import :: a, b" `shouldBe'` st
-
-      it "parses function with bind" $ do
-          let puFunction = PUFunction () u
-              fType = Nothing
-              fPre = emptyPrefixes
-              fSuf = fromList' () [SfxBind () u (Just $ ExpValue () u (ValString "f"))]
-              fName = "f"
-              fArgs = Nothing
-              fRes = Nothing
-              fBody = []
-              fSub = Nothing
-              fStr = init $ unlines ["function f() bind(c,name=\"f\")"
-                                    , "end function f" ]
-          let expected = puFunction fType (fPre, fSuf) fName fArgs fRes fBody fSub
-          fParser fStr `shouldBe'` expected
-
-      it "parses asynchronous decl" $ do
-        let decls = [declVarGen "a", declVarGen "b"]
-            st = StAsynchronous () u (AList () u decls)
-        sParser "asynchronous a, b" `shouldBe'` st
-        sParser "asynchronous :: a, b" `shouldBe'` st
-
-      it "parses asynchronous attribute" $ do
-        let decls = [declVarGen "a", declVarGen "b"]
-            ty = TypeSpec () u TypeInteger Nothing
-            attrs = [AttrAsynchronous () u]
-            st = StDeclaration () u ty (Just (AList () u attrs)) (AList () u decls)
-        sParser "integer, asynchronous :: a, b" `shouldBe'` st
-
-      it "parses enumerators" $ do
-        let decls = [ declVariable () u (varGen "a") Nothing (Just (intGen 1))
-                    , declVariable () u (varGen "b") Nothing Nothing ]
-            st = StEnumerator () u (AList () u decls)
-        sParser "enum, bind(c)" `shouldBe'` StEnum () u
-        sParser "enumerator :: a = 1, b" `shouldBe'` st
-        sParser "end enum" `shouldBe'` StEndEnum () u
-
-      it "parses allocate with type_spec" $ do
-        let sel = Selector () u (Just (ExpValue () u ValColon)) (Just (varGen "foo"))
-            ty = TypeSpec () u TypeCharacter (Just sel)
-            decls = AList () u [declVarGen "s"]
-            st = StDeclaration () u ty (Just (AList () u [AttrAllocatable () u])) decls
-        sParser "character(len=:,kind=foo), allocatable :: s" `shouldBe'` st
-
-      it "parses allocate with type_spec" $ do
-        let sel = Selector () u (Just (intGen 3)) (Just (varGen "foo"))
-            ty = TypeSpec () u TypeCharacter (Just sel)
-            st = StAllocate () u (Just ty) (AList () u [varGen "s"]) Nothing
-        sParser "allocate(character(len=3,kind=foo) :: s)" `shouldBe'` st
-
-      it "parses protected" $ do
-        let ty = TypeSpec () u TypeReal Nothing
-            decls = AList () u [declVarGen "x"]
-            st1 = StDeclaration () u ty (Just (AList () u [AttrProtected () u, AttrPublic () u])) decls
-            st2 = StProtected () u (Just (AList () u [varGen "x"]))
-        sParser "real, protected, public :: x" `shouldBe'` st1
-        sParser "protected x" `shouldBe'` st2
-
-    describe "labelled where" $ do
-      it "parses where construct statement" $
-        sParser "foo: where (.true.)" `shouldBe'` StWhereConstruct () u (Just "foo") valTrue
-
-      it "parses elsewhere statement" $
-        sParser "elsewhere ab101" `shouldBe'` StElsewhere () u (Just "ab101") Nothing
-
-      it "parses elsewhere statement" $ do
-        let exp = ExpBinary () u GT (varGen "a") (varGen "b")
-        sParser "elsewhere (a > b) A123" `shouldBe'` StElsewhere () u (Just "a123") (Just exp)
-
-      it "parses endwhere statement" $
-        sParser "endwhere foo1" `shouldBe'` StEndWhere () u (Just "foo1")
-
-    describe "associate block" $ do
-      it "parses multiple assignment associate block" $ do
-        let text = unlines [ "associate (x => a, y => (a * b))"
-                           , "  print *, x"
-                           , "  print *, y"
-                           , "end associate" ]
-            expected = BlAssociate () u Nothing Nothing abbrevs body' Nothing
-            body'   = [blStmtPrint "x", blStmtPrint "y"]
-            blStmtPrint x = BlStatement () u Nothing (stmtPrint x)
-            stmtPrint x = StPrint () u starVal (Just $ AList () u [ varGen x ])
-            abbrevs = AList () u [abbrev "x" (expValVar "a"), abbrev "y" (expBinVars Multiplication "a" "b")]
-            abbrev var expr = ATuple () u (expValVar var) expr
-            expValVar x = ExpValue () u (ValVariable x)
-            expBinVars op x1 x2 = ExpBinary () u op (expValVar x1) (expValVar x2)
-        bParser text `shouldBe'` expected
-
-    specFreeFormCommon sParser eParser
diff --git a/test/Language/Fortran/Parser/Fortran2008Spec.hs b/test/Language/Fortran/Parser/Fortran2008Spec.hs
deleted file mode 100644
--- a/test/Language/Fortran/Parser/Fortran2008Spec.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-module Language.Fortran.Parser.Fortran2008Spec where
-
-import Test.Hspec
-
-spec :: Spec
-spec =
-  describe "Fortran 2008 Parser" $
-    it "TODO" pending
diff --git a/test/Language/Fortran/Parser/Fortran66Spec.hs b/test/Language/Fortran/Parser/Fortran66Spec.hs
deleted file mode 100644
--- a/test/Language/Fortran/Parser/Fortran66Spec.hs
+++ /dev/null
@@ -1,190 +0,0 @@
-module Language.Fortran.Parser.Fortran66Spec(spec) where
-
-import Test.Hspec
-import TestUtil
-
-import Prelude hiding (LT)
-
-import Language.Fortran.Parser.Fortran66
-import Language.Fortran.Lexer.FixedForm
-import Language.Fortran.ParserMonad
-import Language.Fortran.AST
-import qualified Data.ByteString.Char8 as B
-
-eParser :: String -> Expression ()
-eParser sourceCode =
-  case evalParse statementParser parseState of
-    (StExpressionAssign _ _ _ e) -> e
-    _ -> error "unhandled evalParse"
-  where
-    paddedSourceCode = B.pack $ "      a = " ++ sourceCode
-    parseState =  initParseState paddedSourceCode Fortran66 "<unknown>"
-
-sParser :: String -> Statement ()
-sParser sourceCode =
-  evalParse statementParser $ initParseState (B.pack sourceCode) Fortran66 "<unknown>"
-
-spec :: Spec
-spec =
-  describe "Fortran 66 Parser" $ do
-    describe "Expressions" $ do
-      describe "Arithmetic expressions" $ do
-        it "parses '3'" $ do
-          let expectedExp = intGen 3
-          eParser "3" `shouldBe'` expectedExp
-
-        it "parses '-3'" $ do
-          let expectedExp = ExpUnary () u Minus $ intGen 3
-          eParser "-3" `shouldBe'` expectedExp
-
-        it "parses '3 + 2'" $ do
-          let expectedExp = ExpBinary () u Addition (intGen 3) (intGen 2)
-          eParser "3 + 2" `shouldBe'` expectedExp
-
-        it "parses '3 + -2'" $ do
-          let expectedExp = ExpBinary () u Addition (intGen 3) (ExpUnary () u Minus (intGen 2))
-          eParser "3 + -2" `shouldBe'` expectedExp
-
-        it "parses '3 + -2 + 42'" $ do
-          let expectedExp = ExpBinary () u Addition (ExpBinary () u Addition (intGen 3) (ExpUnary () u Minus (intGen 2))) (intGen 42)
-          eParser "3 + -2 + 42" `shouldBe'` expectedExp
-
-        it "parses 'f(y, 24)'" $ do
-          let subs = [ IxSingle () u Nothing $ varGen "y", ixSinGen 24 ]
-          let expectedExp = ExpSubscript () u (varGen "f") (fromList () subs)
-          eParser "f(y, 24)" `shouldBe'` expectedExp
-
-        it "parses '3 + 4 * 12'" $ do
-          let expectedExp = ExpBinary () u Addition (intGen 3) (ExpBinary () u Multiplication (intGen 4) (intGen 12))
-          eParser "3 + 4 * 12" `shouldBe'` expectedExp
-
-      describe "Logical expressions" $
-        it "parses '.true. .and. .false.'" $ do
-          let expectedExp = ExpBinary () u And valTrue valFalse
-          eParser ".true. .and. .false." `shouldBe'` expectedExp
-
-      describe "Relational expressions" $
-        it "parses '(3 * 2) .lt. 42'" $ do
-          let expectedExp = ExpBinary () u LT (ExpBinary () u Multiplication (intGen 3) (intGen 2)) (intGen 42)
-          eParser "(3 * 2) .lt. 42" `shouldBe'` expectedExp
-
-      describe "Other expressions" $
-        it "parses 'a(2 * x - 3, 10)'" $ do
-          let firstEl = ExpBinary () u Subtraction (ExpBinary () u Multiplication (intGen 2) (varGen "x")) (intGen 3)
-              expectedExp = ExpSubscript () u (varGen "a") (AList () u [ IxSingle () u Nothing firstEl, ixSinGen 10])
-          eParser "a(2 * x - 3, 10)" `shouldBe'` expectedExp
-
-    describe "Statements" $ do
-      it "parses 'EXTERNAL f, g, h'" $ do
-        let procGen s = ExpValue () u (ValVariable s)
-        let expectedSt = StExternal () u (AList () u [procGen "f", procGen "g", procGen "h"])
-        sParser "      EXTERNAL f, g, h" `shouldBe'` expectedSt
-
-      it "parses 'COMMON a, b'" $ do
-        let comGr = CommonGroup () u Nothing (AList () u [ declVarGen "a", declVarGen "b" ])
-        let st = StCommon () u (AList () u [ comGr ])
-        sParser "      COMMON a, b" `shouldBe'` st
-
-      it "parses 'COMMON // a, b /hello/ x, y, z'" $ do
-        let comGrs = [ CommonGroup () u Nothing (AList () u [ declVarGen "a", declVarGen "b" ])
-                     , CommonGroup () u (Just $ varGen "hello") (AList () u [ declVarGen "x", declVarGen "y", declVarGen "z" ]) ]
-        let st = StCommon () u (AList () u comGrs)
-        sParser "      COMMON // a, b /hello/ x, y, z" `shouldBe'` st
-
-      it "parses 'EQUIVALENCE (a,b), (x,y,z)'" $ do
-        let ls = [ AList () u [varGen "a", varGen "b"]
-                 , AList () u [varGen "x", varGen "y", varGen "z"] ]
-        let st = StEquivalence () u (AList () u ls)
-        sParser "      EQUIVALENCE (a,b), (x,y,z)" `shouldBe'` st
-
-      it "parses 'DATA a/1,2,3/,x/42/'" $ do
-        let dGrs = [ DataGroup () u (AList () u [varGen "a"]) (AList () u [intGen 1, intGen 2, intGen 3])
-                   , DataGroup () u (AList () u [varGen "x"]) (AList () u [intGen 42]) ]
-        let st = StData () u $ AList () u dGrs
-        sParser "      DATA a/1,2,3/, x/42/" `shouldBe'` st
-
-      describe "FORMAT" $ do
-        it "parses 'FORMAT ()'" $ do
-          let expectedSt = StFormatBogus () u "()"
-          sParser "      FORMAT ()" `shouldBe'` expectedSt
-
-        it "parses 'FORMAT (///)'" $ do
-          let expectedSt = StFormatBogus () u "(///)"
-          sParser "      FORMAT (///)" `shouldBe'` expectedSt
-
-        it "parses 'FORMAT (2i5/5hhello)'" $ do
-          let expectedSt = StFormatBogus () u "(2i5/5hhello)"
-          sParser "      FORMAT (2i5/5hhello)" `shouldBe'` expectedSt
-
-        it "parses 'FORMAT (/(i5))'" $ do
-          let expectedSt = StFormatBogus () u "(/(i5))"
-          sParser "      FORMAT (/(i5))" `shouldBe'` expectedSt
-
-      describe "CALL" $ do
-        it "parses 'CALL me" $ do
-          let expectedSt = StCall () u (ExpValue () u (ValVariable "me")) Nothing
-          sParser "      CALL me" `shouldBe'` expectedSt
-
-        it "parses 'CALL me(baby)" $ do
-          let args = AList () u [ Argument () u Nothing $ varGen "baby" ]
-          let expectedSt = StCall () u (ExpValue () u (ValVariable "me")) $ Just args
-          sParser "      CALL me(baby)" `shouldBe'` expectedSt
-
-      it "parses 'stop'" $ do
-        let expectedSt = StStop () u Nothing
-        sParser "      stop" `shouldBe'` expectedSt
-
-      it "parses 'integer i, j(2,2), k'" $ do
-        let dimDecls = replicate 2 $ DimensionDeclarator () u Nothing (Just $ intGen 2)
-            declarators = [ Declarator () u (varGen "i") ScalarDecl Nothing Nothing
-                          , Declarator () u (varGen "j") (ArrayDecl (AList () u dimDecls)) Nothing Nothing
-                          , Declarator () u (varGen "k") ScalarDecl Nothing Nothing ]
-            st = StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing $ AList () u declarators
-        sParser "      integer i, j(2,2), k" `shouldBe'` st
-
-      let controlPairs = AList () u [ ControlPair () u Nothing (intGen 6), ControlPair () u Nothing (labelGen 10) ]
-      let writeSt = StWrite () u controlPairs (Just $ AList () u [ varGen "i" ])
-
-      describe "WRITE" $ do
-        it "parses 'write (6)'" $ do
-          let expectedSt = StWrite () u (AList () u [ ControlPair () u Nothing (intGen 6) ]) Nothing
-          sParser "      write (6)" `shouldBe'` expectedSt
-
-        it "parses 'write (6) i'" $ do
-          let expectedSt = StWrite () u (AList () u [ ControlPair () u Nothing (intGen 6) ]) (Just $ AList () u [ varGen "i" ])
-          sParser "      write (6) i" `shouldBe'` expectedSt
-
-        it "parses 'write (6,10) i'" $
-          sParser "      write (6,10) i" `shouldBe'` writeSt
-
-      describe "IF" $ do
-        it "parses 'if (10 .LT. x) write (6,10) i'" $ do
-          let cond = ExpBinary () u LT (intGen 10) (varGen "x")
-          let expectedSt = StIfLogical () u cond writeSt
-          sParser "      if (10 .LT. x) write (6,10) i" `shouldBe'` expectedSt
-
-        it "parses 'if (10 - 5) 10, 20, 30'" $ do
-          let cond = ExpBinary () u Subtraction (intGen 10) (intGen 5)
-          let expectedSt = StIfArithmetic () u cond (labelGen 10) (labelGen 20) (labelGen 30)
-          sParser "      if (10 - 5) 10, 20, 30" `shouldBe'` expectedSt
-
-        it "parses 'IF (IY) 5,6,6" $ do
-          let expectedSt = StIfArithmetic () u (varGen "iy") (labelGen 5) (labelGen 6) (labelGen 6)
-          sParser "      IF (IY) 5,6,6" `shouldBe'` expectedSt
-
-      describe "ASSIGNMENT" $ do
-        it "parses 'f = 1'" $ do
-          let expectedSt = StExpressionAssign () u (varGen "f") (intGen 1)
-          sParser "      f = 1" `shouldBe'` expectedSt
-
-        it "parses 'f = a(1,2)'" $ do
-          let indicies = fromList () [ ixSinGen 1, ixSinGen 2 ]
-          let rhs = ExpSubscript () u (varGen "a") indicies
-          let expectedSt = StExpressionAssign () u (varGen "f") rhs
-          sParser "      f = a(1,2)" `shouldBe'` expectedSt
-
-      it "parses 'do 42 i = 10, 1, 1'" $ do
-        let st = StExpressionAssign () u (varGen "i") (intGen 10)
-        let doSpec = DoSpecification () u st (intGen 1) (Just $ intGen 1)
-        let expectedSt = StDo () u Nothing (Just $ labelGen 42) (Just doSpec)
-        sParser "      do 42 i = 10, 1, 1" `shouldBe'` expectedSt
diff --git a/test/Language/Fortran/Parser/Fortran77/IncludeSpec.hs b/test/Language/Fortran/Parser/Fortran77/IncludeSpec.hs
deleted file mode 100644
--- a/test/Language/Fortran/Parser/Fortran77/IncludeSpec.hs
+++ /dev/null
@@ -1,55 +0,0 @@
-module Language.Fortran.Parser.Fortran77.IncludeSpec where
-
-import System.FilePath
-import Test.Hspec
-import TestUtil
-
-import Language.Fortran.Parser.Fortran77
-import qualified Data.ByteString.Char8 as B
-import Language.Fortran.ParserMonad
-import Language.Fortran.Lexer.FixedForm
-import Language.Fortran.AST
-import Language.Fortran.Util.Position
-
-iParser :: [String] -> String -> IO (ParseResult AlexInput Token (ProgramFile A0))
-iParser incs src = legacy77ParserWithIncludes incs (B.pack src) "<unknown>"
-
-makeSrcR :: (Int, Int, Int, String) -> (Int, Int, Int, String) -> SrcSpan
-makeSrcR (i1, i2, i3, s) (j1, j2, j3, s') = SrcSpan (Position i1 i2 i3 s Nothing) (Position j1 j2 j3 s' Nothing)
-
-spec :: SpecWith ()
-spec =
-  describe "Include Test" $ do
-    let source = unlines ["      program bar",
-                          "      include 'foo.f'",
-                          "      end"
-                         ]
-        inc = "./test-data/f77-include"
-        name = "bar"
-        pf = ProgramFile mi77 [pu]
-        puSpan = makeSrcR (6,7,1,"<unknown>") (48,9,3,"<unknown>")
-        st1Span = makeSrcR (24,7,2,"<unknown>") (38,21,2,"<unknown>")
-        expSpan = makeSrcR (32,15,2,"<unknown>") (38,21,2,"<unknown>")
-
-        -- the expansion returns the span in the included file
-        -- it should return the span at the inclusion
-        foo = inc </> "foo.f"
-        st2Span = makeSrcR (6,7,1, foo) (14,15,1,foo)
-        declSpan = makeSrcR (6,7,1,foo) (14,15,1,foo)
-        typeSpan = makeSrcR (6,7,1,foo) (12,13,1,foo)
-        blockSpan = makeSrcR (14,15,1,foo) (14,15,1,foo)
-        varGen' str =  ExpValue () blockSpan $ ValVariable str
-
-        pu = PUMain () puSpan (Just name) blocks Nothing
-        blocks = [bl1]
-        decl = Declarator () blockSpan (varGen' "a") ScalarDecl Nothing Nothing
-        typeSpec = TypeSpec () typeSpan TypeInteger Nothing
-        st2 = StDeclaration () st2Span typeSpec Nothing (AList () blockSpan [decl])
-        bl1 = BlStatement () st1Span Nothing st1
-        st1 = StInclude () st1Span ex (Just [bl2])
-        ex = ExpValue () expSpan (ValString "foo.f")
-        bl2 = BlStatement () declSpan Nothing st2
-    it "includes some files and expands them" $ do
-      ps <- iParser [inc] source
-      let pr = fromParseResultUnsafe ps
-      pr `shouldBe` pf
diff --git a/test/Language/Fortran/Parser/Fortran77/ParserSpec.hs b/test/Language/Fortran/Parser/Fortran77/ParserSpec.hs
deleted file mode 100644
--- a/test/Language/Fortran/Parser/Fortran77/ParserSpec.hs
+++ /dev/null
@@ -1,424 +0,0 @@
-module Language.Fortran.Parser.Fortran77.ParserSpec where
-
-import Test.Hspec
-import TestUtil
-
-import Prelude hiding (exp)
-import Language.Fortran.Parser.Fortran77
-import Language.Fortran.Lexer.FixedForm (initParseState)
-import Language.Fortran.ParserMonad (FortranVersion(..), evalParse, fromParseResultUnsafe)
-import Language.Fortran.AST
-import qualified Data.ByteString.Char8 as B
-
-{-# ANN module "HLint: ignore Reduce duplication" #-}
-
-eParser :: String -> Expression ()
-eParser sourceCode =
-  case evalParse statementParser parseState of
-    (StExpressionAssign _ _ _ e) -> e
-    _ -> error "unhandled evalParse"
-  where
-    paddedSourceCode = B.pack $ "      a = " ++ sourceCode
-    parseState =  initParseState paddedSourceCode Fortran77 "<unknown>"
-
-sParser :: String -> Statement ()
-sParser sourceCode =
-  evalParse statementParser $ initParseState (B.pack sourceCode) Fortran77 "<unknown>"
-
-slParser :: String -> Statement ()
-slParser sourceCode =
-  evalParse statementParser $ initParseState (B.pack sourceCode) Fortran77Legacy "<unknown>"
-
-blParser :: String -> Block ()
-blParser src = evalParse blockParser $ initParseState (B.pack src) Fortran77Legacy "<unknown>"
-
-iParser :: String -> [Block ()]
-iParser sourceCode =
-  fromParseResultUnsafe $ includeParser Fortran77Legacy (B.pack sourceCode) "<unknown>"
-
-pParser :: String -> ProgramFile ()
-pParser source = fromParseResultUnsafe $ legacy77Parser (B.pack source) "<unknown>"
-
-spec :: Spec
-spec =
-  describe "Fortran 77 Parser" $ do
-    describe "IO" $ do
-      it "parses 'print *, 9000" $ do
-        let expectedSt = StPrint () u starVal $ Just (AList () u [ intGen 9000 ])
-        sParser "      print *, 9000" `shouldBe'` expectedSt
-
-      it "parses 'write (UNIT=6, FORMAT=*)" $ do
-        let cp1 = ControlPair () u (Just "unit") (intGen 6)
-            cp2 = ControlPair () u (Just "format") starVal
-            expectedSt = StWrite () u (AList () u [cp1, cp2]) Nothing
-        sParser "      write (UNIT=6, FORMAT=*)" `shouldBe'` expectedSt
-
-      it "parses 'endfile i" $
-        sParser "      endfile i" `shouldBe'` StEndfile2 () u (varGen "i")
-
-      it "parses 'read *, (x, y(i), i = 1, 10, 2)'" $ do
-        let stAssign = StExpressionAssign () u (varGen "i") (intGen 1)
-            doSpec = DoSpecification () u stAssign (intGen 10) (Just $ intGen 2)
-            impliedDoVars = AList () u [ varGen "x", ExpSubscript () u (varGen "y") (AList () u [ IxSingle () u Nothing $ varGen "i" ])]
-            impliedDo = ExpImpliedDo () u impliedDoVars doSpec
-            iolist = AList () u [ impliedDo ]
-            expectedSt = StRead2 () u starVal (Just iolist)
-        sParser "      read *, (x, y(i), i = 1, 10, 2)" `shouldBe'` expectedSt
-
-    it "parses '(x, y(i), i = 1, 10, 2)'" $ do
-      let stAssign = StExpressionAssign () u (varGen "i") (intGen 1)
-          doSpec = DoSpecification () u stAssign (intGen 10) (Just $ intGen 2)
-          impliedDoVars = AList () u [ varGen "x", ExpSubscript () u (varGen "y") (AList () u [ IxSingle () u Nothing $ varGen "i" ])]
-          impliedDo = ExpImpliedDo () u impliedDoVars doSpec
-      eParser "(x, y(i), i = 1, 10, 2)" `shouldBe'` impliedDo
-
-    it "parses main program unit" $ do
-      let decl = declVarGen "x"
-          st = StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u [ decl ])
-          bl = BlStatement () u Nothing st
-          pu = ProgramFile mi77 [ PUMain () u (Just "hello") [ bl ] Nothing ]
-      pParser exampleProgram1 `shouldBe'` pu
-
-    it "parses block data unit" $ do
-      let decl = declVarGen "x"
-          st = StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u [ decl ])
-          bl = BlStatement () u Nothing st
-          pu = ProgramFile mi77 [ PUBlockData () u (Just "hello") [ bl ] ]
-      pParser exampleProgram2 `shouldBe'` pu
-
-    it "parses 'intrinsic cosh, sin'" $ do
-      let st = StIntrinsic () u (AList () u [ varGen "cosh", varGen "sin" ])
-      sParser "      intrinsic cosh, sin" `shouldBe'` st
-
-    it "parses 'intrinsic real" $ do
-      let st = StIntrinsic () u (AList () u [ varGen "real" ])
-      sParser "      intrinsic real" `shouldBe'` st
-
-    describe "CHARACTER" $ do
-      it "parses character literal assignment" $ do
-        let rhs = ExpValue () u (ValString "hello 'baby")
-            st = StExpressionAssign () u (varGen "xyz") rhs
-        sParser "      xyz = 'hello ''baby'" `shouldBe'` st
-
-      it "string concatenation" $ do
-        let str1 = ExpValue () u (ValString "hello ")
-            str2 = ExpValue () u (ValString "world")
-            exp = ExpBinary () u Concatenation str1 str2
-        eParser "'hello ' // 'world'" `shouldBe'` exp
-
-    describe "Subscript like" $ do
-      it "parses vanilla subscript" $ do
-        let exp = ExpSubscript () u (varGen "a") (AList () u [ IxSingle () u Nothing $ varGen "x", IxSingle () u Nothing $ intGen 2, IxSingle () u Nothing $ intGen 3 ])
-        eParser "a(x, 2, 3)" `shouldBe'` exp
-
-      it "parses array declarator" $ do
-        let dimDecls = [ DimensionDeclarator () u (Just $ intGen 1) (Just $ intGen 2)
-                       , DimensionDeclarator () u Nothing (Just $ intGen 15)
-                       , DimensionDeclarator () u (Just $ varGen "x") (Just starVal) ]
-            decl = declArray () u (varGen "a") (AList () u dimDecls) Nothing Nothing
-            st = StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u [ decl ])
-        sParser "      integer a(1:2, 15, x:*)" `shouldBe'` st
-
-      it "parses character substring" $ do
-        let indicies = [ ixSinGen 1, ixSinGen 2, ixSinGen 3 ]
-            subExp = ExpSubscript () u (varGen "a")  (AList () u indicies)
-            range = IxRange () u Nothing (Just $ intGen 10) Nothing
-            exp = ExpSubscript () u subExp (AList () u [ range ])
-        eParser "a(1, 2, 3)(:10)" `shouldBe'` exp
-
-      it "parses simpler substring" $ do
-        let exp = ExpSubscript () u (varGen "a") (AList () u [ ixRanGen 5 10 ])
-        eParser "a(5:10)" `shouldBe'` exp
-
-      it "parses simpler substring" $ do
-        let range = IxRange () u (Just $ intGen 5) Nothing Nothing
-            exp = ExpSubscript () u (varGen "a") (AList () u [ range ])
-        eParser "a(5:)" `shouldBe'` exp
-
-      it "parses literal string subscript" $ do
-        let range = IxRange () u (Just $ intGen 1) (Just $ intGen 2) Nothing
-            exp = ExpSubscript () u (strGen "abc") (AList () u [ range ])
-        eParser "'abc'(1:2)" `shouldBe'` exp
-
-    describe "GOTO" $ do
-      it "parses computed GOTO with integer expression" $ do
-        let exp = ExpBinary () u Multiplication (intGen 42) (intGen 24)
-            st = StGotoComputed () u (AList () u [labelGen 10, labelGen 20, labelGen 30]) exp
-        sParser "      GOTO (10, 20, 30), 42 * 24" `shouldBe'` st
-
-      let gotoSt = StGotoAssigned () u (varGen "v") (Just (AList () u [labelGen 10, labelGen 20, labelGen 30]))
-      it "parses assigned GOTO with comma" $
-        sParser "      GOTO v, (10, 20, 30)" `shouldBe'` gotoSt
-
-      it "parses assigned GOTO without comma" $
-        sParser "      GOTO v (10, 20, 30)" `shouldBe'` gotoSt
-
-    describe "IMPLICIT" $ do
-      it "parses 'implicit none'" $ do
-        let st = resetSrcSpan $ StImplicit () u Nothing
-        sParser "      implicit none" `shouldBe'` st
-
-      it "parses 'implicit character*30 (a, b, c), integer (a-z, l)" $ do
-        let impEls = [ImpCharacter () u "a", ImpCharacter () u "b", ImpCharacter () u "c"]
-            sel = Selector () u (Just (intGen 30)) Nothing
-            imp1 = ImpList () u (TypeSpec () u TypeCharacter (Just sel)) $ AList () u impEls
-            imp2 = ImpList () u (TypeSpec () u TypeInteger Nothing) $ AList () u [ImpRange () u "a" "z", ImpCharacter () u "l"]
-            st = StImplicit () u $ Just $ AList () u [imp1, imp2]
-        sParser "      implicit character*30 (a, b, c), integer (a-z, l)" `shouldBe'` st
-
-    it "parses 'parameter (pi = 3.14, b = 'X' // 'O', d = k) '" $ do
-      let sts = [ declVariable () u (varGen "pi") Nothing (Just $ realGen (3.14::Double))
-                , let e = ExpBinary () u Concatenation (strGen "X") (strGen "O")
-                  in declVariable () u (varGen "b") Nothing (Just e)
-                , declVariable () u (varGen "d") Nothing (Just $ varGen "k") ]
-          st = StParameter () u (AList () u sts)
-      sParser "      parameter (pi = 3.14, b = 'X' // 'O', d = k)" `shouldBe'` st
-
-    it "parses 'pause 'hello world''" $ do
-      let st = StPause () u $ Just $ strGen "hello world"
-      sParser "      pause 'hello world'" `shouldBe'` st
-
-    describe "SAVE" $ do
-      it "parses 'save /cb/, var, /key/'" $ do
-        let saveArgs = [ varGen "cb", varGen "var", varGen "key" ]
-            st = StSave () u (Just $ AList () u saveArgs)
-        sParser "      save /cb/, var, /key/" `shouldBe'` st
-
-      it "parses 'save'" $
-        sParser "      save" `shouldBe'` StSave () u Nothing
-
-    it "parses '.true. .eqv. f(42) .neqv. x'" $ do
-      let arg2 = ExpSubscript () u (varGen "f") $ AList () u [ ixSinGen 42 ]
-          arg3 = varGen "x"
-          subexp = ExpBinary () u Equivalent valTrue arg2
-          exp = ExpBinary () u NotEquivalent subexp arg3
-      eParser ".true. .eqv. f(42) .neqv. x" `shouldBe'` exp
-
-    it "parses 'entry me (a,b,*)'" $ do
-      let args = [ varGen "a", varGen "b", starVal ]
-          st = StEntry () u (varGen "me") (Just $ AList () u args) Nothing
-      sParser "      entry me (a,b,*)" `shouldBe'` st
-
-    it "parses 'character a*8'" $ do
-      let decl = declVariable () u (varGen "a") (Just $ intGen 8) Nothing
-          typeSpec = TypeSpec () u TypeCharacter Nothing
-          st = StDeclaration () u typeSpec Nothing (AList () u [ decl ])
-      sParser "      character a*8" `shouldBe'` st
-
-    it "parses 'character c*(ichar('A'))" $ do
-      let args = AList () u [ IxSingle () u Nothing (ExpValue () u (ValString "A")) ]
-          lenExpr = ExpSubscript () u (varGen "ichar") args
-          decl = declVariable () u (varGen "c") (Just $ lenExpr) Nothing
-          typeSpec = TypeSpec () u TypeCharacter Nothing
-          st = StDeclaration () u typeSpec Nothing (AList () u [ decl ])
-      sParser "      character c*(ichar('A'))" `shouldBe'` st
-
-    it "parses included files" $ do
-      let decl = declVariable () u (varGen "a") Nothing Nothing
-          typeSpec = TypeSpec () u TypeInteger Nothing
-          st = StDeclaration () u typeSpec Nothing (AList () u [ decl ])
-          bl = BlStatement () u Nothing st
-      iParser "      integer a" `shouldBe'` [bl]
-
-    describe "parses if blocks" $ do
-      let printArgs  = Just $ AList () u [ExpValue () u $ ValString "foo"]
-          printStmt  = StPrint () u (ExpValue () u ValStar) printArgs
-          printBlock = BlStatement () u Nothing printStmt
-      it "unlabelled" $ do
-        let bl = BlIf () u Nothing Nothing [ Just valTrue, Nothing ] [[printBlock], [printBlock]]  Nothing
-            src = unlines [ "      if (.true.) then ! comment if"
-                          , "        print *, 'foo'"
-                          , "      else ! comment else"
-                          , "        print *, 'foo'"
-                          , "       endif ! comment end"
-                          ]
-        blParser src `shouldBe'` bl
-      it "labelled" $ do
-        let label = Just . intGen
-            bl = BlIf () u (label 10)  Nothing [Just valTrue, Nothing] [[printBlock], [printBlock]] (label 30)
-            src = unlines [ "10    if (.true.) then ! comment if"
-                          , "        print *, 'foo'"
-                          , "20    else ! comment else"
-                          , "        print *, 'foo'"
-                          , "30     endif ! comment end"
-                          ]
-        blParser src `shouldBe'` bl
-
-    describe "Legacy Extensions" $ do
-      it "parses structure/union/map blocks" $ do
-        let src = init
-                $ unlines [ "      structure /foo/"
-                          , "        union"
-                          , "          map"
-                          , "            integer i"
-                          , "          end map"
-                          , "          map"
-                          , "            real r"
-                          , "          end map"
-                          , "        end union"
-                          , "      end structure"]
-            ds = [ UnionMap () u $ AList () u
-                   [StructFields () u (TypeSpec () u TypeInteger Nothing) Nothing $
-                    AList () u [declVariable () u (varGen "i") Nothing Nothing]]
-                 , UnionMap () u $ AList () u
-                   [StructFields () u (TypeSpec () u TypeReal Nothing) Nothing $
-                    AList () u [declVariable () u (varGen "r") Nothing Nothing]]
-                 ]
-            st = StStructure () u (Just "foo") $ AList () u [StructUnion () u $ AList () u ds]
-        resetSrcSpan (slParser src) `shouldBe` st
-
-      it "parses structure/union/map blocks with comments" $ do
-        let src = init
-                $ unlines [ "      structure /foo/"
-                          , "C       comment before union"
-                          , "        union"
-                          , "C         comment inside union, before map"
-                          , "          map"
-                          , "C           comment inside map"
-                          , "            integer i ! more comment"
-                          , "          end map"
-                          , "C         comment between maps"
-                          , "          map"
-                          , "            real r    ! more comment"
-                          , "          end map"
-                          , "C         comment after map"
-                          , "        end union"
-                          , "C       comment after union"
-                          , "      end structure"]
-            ds = [ UnionMap () u $ AList () u
-                   [StructFields () u (TypeSpec () u TypeInteger Nothing) Nothing $
-                    AList () u [declVariable () u (varGen "i") Nothing Nothing]]
-                 , UnionMap () u $ AList () u
-                   [StructFields () u (TypeSpec () u TypeReal Nothing) Nothing $
-                    AList () u [declVariable () u (varGen "r") Nothing Nothing]]
-                 ]
-            st = StStructure () u (Just "foo") $ AList () u [StructUnion () u $ AList () u ds]
-        resetSrcSpan (slParser src) `shouldBe` st
-
-      it "parses nested structure blocks" $ do
-        let src = init
-                $ unlines [ "      structure /foo/"
-                          , "        structure /bar/ baz"
-                          , "          integer qux"
-                          , "        end structure"
-                          , "      end structure"]
-            var = declVariable () u (varGen "qux") Nothing Nothing
-            innerst = StructStructure () u (Just "bar") ("baz")
-              $ AList () u [StructFields () u (TypeSpec () u TypeInteger Nothing) Nothing
-                $ AList () u [var]]
-            st = StStructure () u (Just "foo") $ AList () u [innerst]
-        resetSrcSpan (slParser src) `shouldBe` st
-
-      it "parses structure data references " $ do
-        let src = init $ unlines [ "      print *, foo % bar"
-                                 , "      print *, foo.bar" ]
-            expStar = ExpValue () u ValStar
-            foobar = ExpDataRef () u (varGen "foo") (varGen "bar")
-            blStmt = BlStatement () u Nothing $ StPrint () u expStar $ Just $ AList () u [foobar]
-        resetSrcSpan (iParser src) `shouldBe` [ blStmt, blStmt ]
-
-      it "parse special intrinsics to arguments" $ do
-        let blStmt stmt = BlStatement () u Nothing stmt
-            ext = blStmt $ StExternal () u $ AList () u [varGen "bar"]
-            arg = Just . AList () u . pure . Argument () u Nothing
-            valBar = ExpFunctionCall () u (ExpValue () u (ValIntrinsic "%val"))
-                     $ arg $ varGen "baz"
-            call = blStmt $ StCall () u (varGen "bar") $ arg valBar
-            pu = ProgramFile mi77 [ PUSubroutine () u (Nothing, Nothing) "foo"
-                                   (Just $ AList () u [varGen "baz"]) [ ext, call ] Nothing ]
-        resetSrcSpan (pParser exampleProgram3) `shouldBe` pu
-
-      it "parses character declarations with unspecfied lengths" $ do
-        let src = "      character s*(*)"
-            st = StDeclaration () u (TypeSpec () u TypeCharacter Nothing) Nothing $
-                 AList () u [declVariable () u
-                               (varGen "s")
-                               (Just (ExpValue () u ValStar))
-                               Nothing]
-        resetSrcSpan (slParser src) `shouldBe` st
-
-      it "parses array initializers" $ do
-        let src = "      integer xs(3) / 1, 2, 3 /"
-            inits = [intGen 1, intGen 2, intGen 3]
-            st = StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing $
-                 AList () u [declArray () u
-                               (varGen "xs")
-                               (AList () u [DimensionDeclarator () u Nothing (Just (intGen 3))])
-                               Nothing
-                               (Just (ExpInitialisation () u $ AList () u inits))]
-        resetSrcSpan (slParser src) `shouldBe` st
-
-        let src1 = "      character xs(2)*5 / 'hello', 'world' /"
-            inits1 = [ExpValue () u (ValString "hello"), ExpValue () u (ValString "world")]
-            st1 = StDeclaration () u (TypeSpec () u TypeCharacter Nothing) Nothing $
-                 AList () u [declArray () u
-                               (varGen "xs")
-                               (AList () u [DimensionDeclarator () u Nothing (Just (intGen 2))])
-                               (Just (intGen 5))
-                               (Just (ExpInitialisation () u $ AList () u inits1))]
-        resetSrcSpan (slParser src1) `shouldBe` st1
-
-        let src2 = "      character xs*5(2) / 'hello', 'world' /"
-            inits2 = [ExpValue () u (ValString "hello"), ExpValue () u (ValString "world")]
-            st2 = StDeclaration () u (TypeSpec () u TypeCharacter Nothing) Nothing $
-                 AList () u [declArray () u
-                               (varGen "xs")
-                               (AList () u [DimensionDeclarator () u Nothing (Just (intGen 2))])
-                               (Just (intGen 5))
-                               (Just (ExpInitialisation () u $ AList () u inits2))]
-        resetSrcSpan (slParser src2) `shouldBe` st2
-
-      it "parses subscripts in assignments" $ do
-        let mkIdx i = IxSingle () u Nothing (intGen i)
-
-            src = "      x(0,1) = 0"
-            tgt = ExpSubscript () u (varGen "x") (AList () u [mkIdx 0, mkIdx 1])
-            st = StExpressionAssign () u tgt (intGen 0)
-        resetSrcSpan (slParser src) `shouldBe` st
-
-        let src1 = "      x(0).foo = 0"
-            tgt1 = ExpDataRef () u (ExpSubscript () u (varGen "x") (AList () u [mkIdx 0])) (varGen "foo")
-            st1 = StExpressionAssign () u tgt1 (intGen 0)
-        resetSrcSpan (slParser src1) `shouldBe` st1
-
-        let src2 = "      x.foo = 0"
-            tgt2 = ExpDataRef () u (varGen "x") (varGen "foo")
-            st2 = StExpressionAssign () u tgt2 (intGen 0)
-        resetSrcSpan (slParser src2) `shouldBe` st2
-
-        let src3 = "      x.foo(0) = 0"
-            tgt3 = ExpSubscript () u (ExpDataRef () u (varGen "x") (varGen "foo")) (AList () u [mkIdx 0])
-            st3 = StExpressionAssign () u tgt3 (intGen 0)
-        resetSrcSpan (slParser src3) `shouldBe` st3
-      it "parses automatic and static statements" $ do
-        let decl = declVariable () u (varGen "x") Nothing Nothing
-            autoStmt = StAutomatic () u (AList () u [decl])
-            staticStmt = StStatic () u (AList () u [decl])
-            autoSrc =  "      automatic x"
-            staticSrc = "      static x"
-        resetSrcSpan (slParser autoSrc) `shouldBe` autoStmt
-        resetSrcSpan (slParser staticSrc) `shouldBe` staticStmt
-
-exampleProgram1 :: String
-exampleProgram1 = unlines
-  [ "      program hello"
-  , "      integer x"
-  , "      end" ]
-
-exampleProgram2 :: String
-exampleProgram2 = unlines
-  [ "      block data hello"
-  , "      integer x"
-  , "      end" ]
-
-exampleProgram3 :: String
-exampleProgram3 = unlines
-  [ "      subroutine foo(baz)"
-  , "      external bar"
-  , "      call bar(%val(baz))"
-  , "      end subroutine foo"]
-
--- Local variables:
--- mode: haskell
--- haskell-program-name: "cabal repl test-suite:spec"
--- End:
diff --git a/test/Language/Fortran/Parser/Fortran90Spec.hs b/test/Language/Fortran/Parser/Fortran90Spec.hs
deleted file mode 100644
--- a/test/Language/Fortran/Parser/Fortran90Spec.hs
+++ /dev/null
@@ -1,590 +0,0 @@
-module Language.Fortran.Parser.Fortran90Spec (spec) where
-
-import Prelude hiding (GT, exp, pred)
-
-import Test.Hspec
-import TestUtil
-import Language.Fortran.Parser.FreeFormCommon
-
-import Language.Fortran.AST
-import Language.Fortran.ParserMonad
-import Language.Fortran.Lexer.FreeForm
-import Language.Fortran.Parser.Fortran90
---import qualified Data.List as List
-import qualified Data.ByteString.Char8 as B
-
-{-# ANN module "HLint: ignore Reduce duplication" #-}
-
-eParser :: String -> Expression ()
-eParser sourceCode =
-  case evalParse statementParser parseState of
-    (StExpressionAssign _ _ _ e) -> e
-    _ -> error "unhandled evalParse"
-  where
-    paddedSourceCode = B.pack $ "      a = " ++ sourceCode
-    parseState =  initParseState paddedSourceCode Fortran90 "<unknown>"
-
-sParser :: String -> Statement ()
-sParser sourceCode =
-  evalParse statementParser $ initParseState (B.pack sourceCode) Fortran90 "<unknown>"
-
-blParser :: String -> Block ()
-blParser sourceCode =
-  evalParse blockParser $ initParseState (B.pack sourceCode) Fortran90 "<unknown>"
-
-fParser :: String -> ProgramUnit ()
-fParser sourceCode =
-  evalParse functionParser $ initParseState (B.pack sourceCode) Fortran95 "<unknown>"
-
-{- Useful for parser debugging; Lexes the given source code.
-fTok :: String -> [Token]
-fTok sourceCode = collectFreeTokens Fortran95 $ B.pack sourceCode
--}
-
-{-
- - Given a list of values, find every combination of those values:
- - combination [1,2] = [[], [1], [2], [1,2], [2,1]]
- -}
---combination :: [a] -> [[a]]
---combination = foldr ((++) . List.permutations) [] . List.subsequences
-
-spec :: Spec
-spec =
-  describe "Fortran 90 Parser" $ do
-    describe "Function" $ do
-      let puFunction = PUFunction () u
-          fType = Nothing
-          fPre = emptyPrefixes
-          fPreR = Just $ AList () u [PfxRecursive () u]
-          fSuf = emptySuffixes
-          fPreSuf = (fPre, fSuf)
-          fName = "f"
-          fArgs = Nothing
-          fRes = Nothing
-          fBody = []
-          fSub = Nothing
-
-      describe "End" $ do
-        it "parses simple functions ending with \"end function [function name]\"" $ do
-          let expected = puFunction fType fPreSuf fName fArgs fRes fBody fSub
-              fStr = init $ unlines ["function f()"
-                               , "end function f" ]
-          fParser fStr `shouldBe'` expected
-
-        it "parses simple functions ending with \"end\"" $ do
-          let expected = puFunction fType fPreSuf fName fArgs fRes fBody fSub
-              fStr = init $ unlines ["function f()"
-                               , "end" ]
-          fParser fStr `shouldBe'` expected
-
-        it "parses simple functions ending with \"end function\"" $ do
-          let expected = puFunction fType fPreSuf fName fArgs fRes fBody fSub
-              fStr = init $ unlines ["function f()"
-                               , "end function" ]
-          fParser fStr `shouldBe'` expected
-
-
-        it "parses functions with return type specs" $ do
-          let fType' = Just $ TypeSpec () u TypeInteger Nothing
-              expected = puFunction fType' fPreSuf fName fArgs fRes fBody fSub
-              fStr = init $ unlines ["integer function f()"
-                               , "end function f" ]
-          fParser fStr `shouldBe'` expected
-
-      it "parses recursive functions" $
-        let expected = puFunction fType (fPreR, fSuf) fName fArgs fRes fBody fSub
-            fStr = init $ unlines ["recursive function f()", "end"]
-        in fParser fStr `shouldBe'` expected
-
-
-      it "parses functions with a list of arguments" $
-        let fArgs' = Just $ AList () u [ varGen "x", varGen "y", varGen "z" ]
-            expected = puFunction fType fPreSuf fName fArgs' fRes fBody fSub
-            fStr = init $ unlines ["function f(x, y, z)"
-                             , "end function f" ]
-        in fParser fStr `shouldBe'` expected
-
-      it "parses functions with a result variable" $
-        let fRes' = Just $ varGen "i"
-            expected = puFunction fType fPreSuf fName fArgs fRes' fBody fSub
-            fStr = init $ unlines ["function f() result(i)"
-                             , "end function f" ]
-        in fParser fStr `shouldBe'` expected
-
-      it "parses functions with function bodies" $
-        let decrementRHS = ExpBinary () u Subtraction (varGen "i") (intGen 1)
-            f1 = StPrint () u starVal (Just $ AList () u [ varGen "i" ])
-            f2 = StExpressionAssign () u (varGen "i") decrementRHS
-            fBody' = [ BlStatement () u Nothing f1 , BlStatement () u Nothing f2 ]
-            expected = puFunction fType fPreSuf fName fArgs fRes fBody' fSub
-            fStr = init $ unlines ["function f()"
-                             , "  print *, i"
-                             , "  i = (i - 1)"
-                             , "end function f" ]
-        in fParser fStr `shouldBe'` expected
-
-      it "parses complex functions" $
-        let fType' = Just $ TypeSpec () u TypeInteger Nothing
-            fArgs' = Just $ AList () u [ varGen "x", varGen "y", varGen "z" ]
-            fRes' = Just $ varGen "i"
-            decrementRHS = ExpBinary () u Subtraction (varGen "i") (intGen 1)
-            f1 = StPrint () u starVal (Just $ AList () u [ varGen "i" ])
-            f2 = StExpressionAssign () u (varGen "i") decrementRHS
-            fBody' = [ BlStatement () u Nothing f1 , BlStatement () u Nothing f2 ]
-            expected = puFunction fType' fPreSuf fName fArgs' fRes' fBody' fSub
-            fStr = init $ unlines [ "integer function f(x, y, z) result(i)"
-                             , "  print *, i"
-                             , "  i = (i - 1)"
-                             , "end function f" ]
-        in fParser fStr `shouldBe'` expected
-
-    describe "Expression" $ do
-      it "parses logical literal without kind parameter" $ do
-        eParser ".true." `shouldBe'` valTrue
-
-      it "parses logical literal with kind parameter" $ do
-        let kp = ExpValue () u (ValVariable "kind")
-        eParser ".false._kind" `shouldBe'` valFalse' kp
-
-      it "parses array initialisation exp" $ do
-        let list = AList () u [ intGen 1, intGen 2, intGen 3, intGen 4 ]
-        eParser "(/ 1, 2, 3, 4 /)" `shouldBe'` ExpInitialisation () u list
-
-      describe "Custom operator" $ do
-        let unOp = UnCustom ".inverse."
-            unExp = ExpUnary () u unOp $ intGen 42
-
-        it "parses unary custom operator" $
-          eParser ".inverse. 42" `shouldBe'` unExp
-
-        let binOp = BinCustom ".xor."
-        it "parses binary custom operator" $ do
-          let expected = ExpBinary () u binOp (intGen 24) (intGen 42)
-          eParser "24 .xor. 42" `shouldBe'` expected
-
-        it "parses mixed unary custom operator" $ do
-          let binExp = ExpBinary () u binOp unExp (intGen 24)
-          eParser ".inverse. 42 .xor. 24" `shouldBe'` binExp
-
-        it "parses data ref" $ do
-          let range = fromList () [ IxSingle () u Nothing $ intGen 10 ]
-              sub = ExpSubscript () u (varGen "y") range
-              innerRefExp = ExpDataRef () u (varGen "x") sub
-              exp = ExpDataRef () u innerRefExp (varGen "z")
-          eParser "x % y(10) % z" `shouldBe'` exp
-
-        it "parses section subscript" $ do
-          let range = [ IxSingle () u Nothing $ intGen 10
-                      , IxRange () u Nothing (Just $ intGen 1) (Just $ intGen 2)
-                      , IxSingle () u Nothing $ varGen "y" ]
-              exp = ExpSubscript () u (varGen "x") (fromList () range)
-          eParser "x (10, : 1 : 2, y)" `shouldBe'` exp
-
-    describe "Statement" $ do
-      it "data ref assignment" $ do
-        let indicies = AList () u [ IxSingle () u Nothing (intGen 1) ]
-            subs = ExpSubscript () u (varGen "x") indicies
-            lhs = ExpDataRef () u subs (varGen "y")
-            st = StExpressionAssign () u lhs (intGen 1)
-        sParser "x(1) % y = 1" `shouldBe'` st
-
-      it "parses pause statements" $ do
-        let stPause = StPause () u Nothing
-            stStr = "PAUSE"
-        sParser stStr `shouldBe'` stPause
-
-      it "parses pause statements with expression" $ do
-        let stPause = StPause () u (Just (strGen "MESSAGE"))
-            stStr = "PAUSE \"MESSAGE\""
-        sParser stStr `shouldBe'` stPause
-
-      it "parses declaration with attributes" $ do
-        let typeSpec = TypeSpec () u TypeReal Nothing
-            attrs = AList () u [ AttrExternal () u
-                               , AttrIntent () u Out
-                               , AttrDimension () u $ AList () u
-                                  [ DimensionDeclarator () u
-                                      (Just $ intGen 3) (Just $ intGen 10)
-                                  ]
-                               ]
-            declarators = AList () u [ declVarGen "x", declVarGen "y"]
-            expected = StDeclaration () u typeSpec (Just attrs) declarators
-            stStr = "real, external, intent (out), dimension (3:10) :: x, y"
-        sParser stStr `shouldBe'` expected
-
-      it "parses declaration with old syntax" $ do
-        let typeSpec = TypeSpec () u TypeLogical Nothing
-            declarators = AList () u [ declVarGen "x", declVarGen "y"]
-            expected = StDeclaration () u typeSpec Nothing declarators
-            stStr = "logical x, y"
-        sParser stStr `shouldBe'` expected
-
-      it "parses declaration with initialisation" $
-        let typeSpec = TypeSpec () u TypeComplex Nothing
-            init' = ExpValue () u (ValComplex (intGen 24) (realGen (42.0::Double)))
-            declarators = AList () u
-              [ declVariable () u (varGen "x") Nothing (Just init') ]
-            expected = StDeclaration () u typeSpec Nothing declarators
-            stStr = "complex :: x = (24, 42.0)"
-        in sParser stStr `shouldBe'` expected
-
-      it "parses declaration of custom type" $ do
-        let typeSpec = TypeSpec () u (TypeCustom "meinetype") Nothing
-            declarators = AList () u [declVarGen "x"]
-            expected = StDeclaration () u typeSpec Nothing declarators
-            stStr = "type (MeineType) :: x"
-        sParser stStr `shouldBe'` expected
-
-      it "parses declaration type with kind selector" $ do
-        let selector = Selector () u Nothing (Just $ varGen "hello")
-            typeSpec = TypeSpec () u TypeInteger (Just selector)
-            declarators = AList () u [declVarGen "x"]
-            expected = StDeclaration () u typeSpec Nothing declarators
-            stStr = "integer (hello) :: x"
-        sParser stStr `shouldBe'` expected
-
-      it "parses intent statement" $ do
-        let stStr = "intent (inout) :: a"
-            expected = StIntent () u InOut (fromList () [ varGen "a" ])
-        sParser stStr `shouldBe'` expected
-
-      it "parses optional statement" $ do
-        let stStr = "optional x"
-            expected = StOptional () u (fromList () [ varGen "x" ])
-        sParser stStr `shouldBe'` expected
-
-      it "parses public statement" $ do
-        let stStr = "public :: x"
-            expected = StPublic () u (Just $ fromList () [ varGen "x" ])
-        sParser stStr `shouldBe'` expected
-
-      it "parses public assignment" $ do
-        let expected = StPublic () u (Just $ fromList () [ assVal ])
-        sParser "public :: assignment (=)" `shouldBe'` expected
-
-      it "parses private statement" $
-        sParser "private" `shouldBe'` StPrivate () u Nothing
-
-      it "parses private operator" $ do
-        let expected = StPrivate () u (Just $ fromList () [ opGen "*" ])
-        sParser "private operator ( * )" `shouldBe'` expected
-
-      it "parses save statement" $ do
-        let list = [ varGen "hello", varGen "bye" ]
-            expected = StSave () u (Just $ fromList () list)
-            stStr = "save /hello/, bye"
-        sParser stStr `shouldBe'` expected
-
-      it "parses parameter statement" $ do
-        let ass1 = declVariable () u (varGen "x") Nothing (Just $ intGen 10)
-            ass2 = declVariable () u (varGen "y") Nothing (Just $ intGen 20)
-            expected = StParameter () u (fromList () [ ass1, ass2 ])
-        sParser "parameter (x = 10, y = 20)" `shouldBe'` expected
-
-      describe "Implicit" $ do
-        it "parses implicit none" $ do
-          let st = StImplicit () u Nothing
-          sParser "implicit none" `shouldBe'` st
-
-        it "parses implicit with single" $ do
-          let typeSpec = TypeSpec () u TypeCharacter Nothing
-              impEls = [ ImpCharacter () u "k" ]
-              impLists = [ ImpList () u typeSpec (fromList () impEls) ]
-              st = StImplicit () u (Just $ fromList () impLists)
-          sParser "implicit character (k)" `shouldBe'` st
-
-        it "parses implicit with range" $ do
-          let typeSpec = TypeSpec () u TypeLogical Nothing
-              impEls = [ ImpRange () u "x" "z" ]
-              impLists = [ ImpList () u typeSpec (fromList () impEls) ]
-              st = StImplicit () u (Just $ fromList () impLists)
-          sParser "implicit logical (x-z)" `shouldBe'` st
-
-        it "parses implicit statement" $ do
-          let typeSpec1 = TypeSpec () u TypeCharacter Nothing
-              typeSpec2 = TypeSpec () u TypeInteger Nothing
-              impEls1 = [ ImpCharacter () u "s", ImpCharacter () u "a" ]
-              impEls2 = [ ImpRange () u "x" "z" ]
-              impLists = [ ImpList () u typeSpec1 (fromList () impEls1)
-                         , ImpList () u typeSpec2 (fromList () impEls2) ]
-              st = StImplicit () u (Just $ fromList () impLists)
-          sParser "implicit character (s, a), integer (x-z)" `shouldBe'` st
-
-      describe "Data" $ do
-        it "parses vanilla" $ do
-          let nlist = fromList () [ varGen "x", varGen "y" ]
-              vlist = fromList () [ intGen 1, intGen 2 ]
-              list = [ DataGroup () u nlist vlist ]
-              expected = StData () u (fromList () list)
-              stStr = "data x,y/1,2/"
-          sParser stStr `shouldBe'` expected
-
-        describe "Delimeter" $ do
-          let [ nlist1, vlist1 ] =
-                map (fromList () . return) [ varGen "x", intGen 1 ]
-              [ nlist2, vlist2 ] =
-                map (fromList () . return) [ varGen "y", intGen 2 ]
-              list = [ DataGroup () u nlist1 vlist1
-                     , DataGroup () u nlist2 vlist2 ]
-              expected = StData () u (fromList () list)
-
-          it "parses comma delimited init groups" $
-            sParser "data x/1/, y/2/" `shouldBe'` expected
-
-          it "parses non-comma delimited init groups" $
-            sParser "data x/1/ y/2/" `shouldBe'` expected
-
-      describe "Namelist" $ do
-        let groupNames = [ ExpValue () u (ValVariable "something")
-                         , ExpValue () u (ValVariable "other") ]
-            itemss = [ fromList () [ varGen "a", varGen "b", varGen "c" ]
-                     , fromList () [ varGen "y" ] ]
-            st = StNamelist () u $
-              fromList () [ Namelist () u (head groupNames) (head itemss)
-                          , Namelist () u (last groupNames) (last itemss) ]
-
-        it "parses namelist statement (comma delimited) (1)" $
-          sParser "namelist /something/a,b,c,/other/y" `shouldBe'` st
-
-        it "parses namelist statement (2)" $
-          sParser "namelist /something/a,b,c/other/y" `shouldBe'` st
-
-      describe "Common" $ do
-        let commonNames = [ ExpValue () u (ValVariable "something")
-                          , ExpValue () u (ValVariable "other") ]
-            itemss = [ fromList () [ declVarGen "a", declVarGen "b", declVarGen "c" ]
-                     , fromList () [ declVarGen "y" ] ]
-            st = StCommon () u $ fromList ()
-              [ CommonGroup () u Nothing (fromList () [ declVarGen "q" ])
-              , CommonGroup () u (Just $ head commonNames) (head itemss)
-              , CommonGroup () u (Just $ last commonNames) (last itemss) ]
-
-        it "parses common statement (comma delimited) (1)" $
-          sParser "common q /something/a,b,c, /other/y" `shouldBe'` st
-
-        it "parses common statement (2)" $
-          sParser "common q /something/a,b,c /other/y" `shouldBe'` st
-
-      it "parses equivalence statement" $ do
-        let eqALists = fromList ()
-              [ fromList ()
-                  [ let indicies = fromList () [ IxSingle () u Nothing (intGen 1) ]
-                    in ExpSubscript () u (varGen "a") indicies
-                  , varGen "x"
-                  ]
-              , fromList ()
-                  [ varGen "y"
-                  , varGen "z"
-                  , let indicies = fromList () [ IxRange () u (Just $ intGen 1)
-                                                              (Just $ intGen 42)
-                                                              Nothing ]
-                    in ExpSubscript () u (varGen "d") indicies
-                  ]
-              ]
-        let st = StEquivalence () u eqALists
-        sParser "equivalence (a(1), x), (y, z, d(1:42))" `shouldBe'` st
-
-      describe "Dynamic allocation" $ do
-        it "parses allocate statement" $ do
-          let opt = AOStat () u (varGen "a")
-              allocs = fromList ()
-                [ varGen "x"
-                , ExpDataRef () u (varGen "st") (varGen "part")
-                ]
-          let s = StAllocate () u Nothing allocs (Just (AList () u [opt]))
-          sParser "allocate (x, st % part, STAT = a)" `shouldBe'` s
-
-        it "parses deallocate statement" $ do
-          let opt = AOStat () u (varGen "a")
-              allocs = fromList ()
-                [ let indicies = fromList () [ IxSingle () u Nothing (intGen 20) ]
-                  in ExpSubscript () u (varGen "smt") indicies
-                ]
-              s = StDeallocate () u allocs Nothing
-              s' = StDeallocate () u allocs (Just (AList () u [opt]))
-          sParser "deallocate (smt ( 20 ))" `shouldBe'` s
-          sParser "deallocate (smt ( 20 ), stat=a)" `shouldBe'` s'
-
-        it "parses nullify statement" $ do
-          let s = StNullify () u (fromList () [ varGen "x" ])
-          sParser "nullify (x)" `shouldBe'` s
-
-      it "parses pointer assignment" $ do
-        let src = ExpDataRef () u (varGen "x") (varGen "y")
-            st = StPointerAssign () u src (varGen "exp")
-        sParser "x % y => exp" `shouldBe'` st
-
-      describe "Where" $ do
-        it "parses where statement" $ do
-          let exp = ExpBinary () u Subtraction (varGen "temp") (varGen "r_temp")
-              pred = ExpBinary () u GT (varGen "temp") (intGen 100)
-              assignment = StExpressionAssign () u (varGen "temp") exp
-              st = StWhere () u pred assignment
-          sParser "where (temp > 100) temp = temp - r_temp"`shouldBe'` st
-
-        describe "Where block" $ do
-          it "parses where construct statement" $
-            sParser "where (.true.)" `shouldBe'` StWhereConstruct () u Nothing valTrue
-
-          it "parses elsewhere statement" $
-            sParser "elsewhere" `shouldBe'` StElsewhere () u Nothing Nothing
-
-          it "parses elsewhere statement" $ do
-            let exp = ExpBinary () u GT (varGen "a") (varGen "b")
-            sParser "elsewhere (a > b)" `shouldBe'` StElsewhere () u Nothing (Just exp)
-
-          it "parses endwhere statement" $
-            sParser "endwhere" `shouldBe'` StEndWhere () u Nothing
-
-    describe "If" $ do
-      let stPrint = StPrint () u starVal (Just $ fromList () [ ExpValue () u (ValString "foo")])
-      it "parser if block" $
-        let ifBlockSrc = unlines [ "if (.false.) then", "print *, 'foo'", "end if"]
-        in blParser ifBlockSrc `shouldBe'` BlIf () u Nothing Nothing [Just valFalse] [[BlStatement () u Nothing stPrint]] Nothing
-
-      it "parses named if block" $ do
-        let ifBlockSrc = unlines [ "mylabel : if (.true.) then", "print *, 'foo'", "end if mylabel"]
-            ifBlock = BlIf () u Nothing (Just "mylabel") [Just valTrue] [[BlStatement () u Nothing stPrint]] Nothing
-        blParser ifBlockSrc `shouldBe'` ifBlock
-
-      it "parses if-else block with inline comments (stripped)" $
-        let ifBlockSrc = unlines [ "if (.false.) then ! comment if", "print *, 'foo'", "else ! comment else", "print *, 'foo'", "end if ! comment end"]
-        in blParser ifBlockSrc `shouldBe'` BlIf () u Nothing Nothing [Just valFalse, Nothing] [[BlStatement () u Nothing stPrint], [BlStatement () u Nothing stPrint]] Nothing
-
-      it "parses logical if statement" $ do
-        let assignment = StExpressionAssign () u (varGen "a") (varGen "b")
-            stIf = StIfLogical () u valTrue assignment
-        sParser "if (.true.) a = b" `shouldBe'` stIf
-
-      it "parses arithmetic if statement" $ do
-        let stIf = StIfArithmetic () u (varGen "x") (intGen 1)
-                                                    (intGen 2)
-                                                    (intGen 3)
-        sParser "if (x) 1, 2, 3" `shouldBe'` stIf
-
-    describe "Case" $ do
-      let printArgs str = Just $ AList () u [ExpValue () u $ ValString str]
-          printStmt = StPrint () u (ExpValue () u ValStar) . printArgs
-          printBlock = BlStatement () u Nothing . printStmt
-          ind2 = AList () u . pure $ IxSingle () u Nothing $ intGen 2
-          ind3Plus = AList () u . pure $ IxRange () u (Just $ intGen 3) Nothing Nothing
-          conds = [Just ind2, Just ind3Plus, Nothing]
-      it "unlabelled case block (with inline comments to be stripped)" $ do
-        let src = unlines [ "select case (x) ! comment select"
-                          , "! full line before first case (unrepresentable)"
-                          , "case (2) ! comment case 1"
-                          , "print *, 'foo'"
-                          , "case (3:) ! comment case 2"
-                          , "print *, 'bar'"
-                          , "case default ! comment case 3"
-                          , "print *, 'baz'"
-                          , "end select ! comment end"
-                          ]
-            blocks = (fmap . fmap) printBlock [["foo"], ["bar"], ["baz"]]
-            block = BlCase () u Nothing Nothing (varGen "x") conds blocks Nothing
-        blParser src `shouldBe'` block
-      it "labelled case block (with inline comments to be stripped" $ do
-        let src = unlines [ "10 mylabel: select case (x) ! comment select"
-                          , "20 case (2) ! comment case 1"
-                          , "30 print *, 'foo'"
-                          , "40 case (3:) ! comment case 2"
-                          , "50 print *, 'bar'"
-                          , "60 case default ! comment case 3"
-                          , "70 print *, 'baz'"
-                          , "80 end select mylabel ! comment end"
-                          ]
-            blocks = (fmap . fmap)
-                     (\(label, arg) -> BlStatement () u (Just $ intGen label) $ printStmt arg)
-                     [[(30, "foo")], [(50, "bar")], [(70, "baz")]]
-            block = BlCase () u
-                           (Just $ intGen 10) (Just "mylabel") (varGen "x")
-                           conds blocks
-                           (Just $ intGen 80)
-        blParser src `shouldBe'` block
-
-    describe "Do" $ do
-      it "parses do statement with label" $ do
-        let assign = StExpressionAssign () u (varGen "i") (intGen 0)
-            doSpec = DoSpecification () u assign (intGen 42) Nothing
-            st = StDo () u Nothing (Just $ intGen 24) (Just doSpec)
-        sParser "do 24, i = 0, 42" `shouldBe'` st
-
-      it "parses do statement without label" $ do
-        let assign = StExpressionAssign () u (varGen "i") (intGen 0)
-            doSpec = DoSpecification () u assign (intGen 42) Nothing
-            st = StDo () u Nothing Nothing (Just doSpec)
-        sParser "do i = 0, 42" `shouldBe'` st
-
-      it "parses infinite do" $ do
-        let st = StDo () u Nothing Nothing Nothing
-        sParser "do" `shouldBe'` st
-
-      it "parses end do statement" $ do
-        let st = StEnddo () u (Just "constructor")
-        sParser "end do constructor" `shouldBe'` st
-
-    describe "DO WHILE" $ do
-      it "parses unnamed do while statement" $ do
-        let st = StDoWhile () u Nothing Nothing valTrue
-        sParser "do while (.true.)" `shouldBe'` st
-
-      it "parses named do while statement" $ do
-        let st = StDoWhile () u (Just "name") Nothing valTrue
-        sParser "name: do while (.true.)" `shouldBe'` st
-
-      it "parses unnamed labelled do while statement" $ do
-        let st = StDoWhile () u Nothing (Just (intGen 999)) valTrue
-        sParser "do 999 while (.true.)" `shouldBe'` st
-
-    describe "Goto" $ do
-      it "parses vanilla goto" $ do
-        let st = StGotoUnconditional () u (intGen 999)
-        sParser "goto 999" `shouldBe'` st
-
-      it "parses computed goto" $ do
-        let list = fromList () [ intGen 10, intGen 20, intGen 30 ]
-            st = StGotoComputed () u list (intGen 20)
-        sParser "goto (10, 20, 30) 20" `shouldBe'` st
-
-      it "parses assigned goto" $ do
-        let list = fromList () [ intGen 10, intGen 20, intGen 30 ]
-            st = StGotoAssigned () u (varGen "i") (Just list)
-        sParser "goto i, (10, 20, 30)" `shouldBe'` st
-
-      it "parses label assignment" $ do
-        let st = StLabelAssign () u (intGen 20) (varGen "l")
-        sParser "assign 20 to l" `shouldBe'` st
-
-    describe "IO" $ do
-      it "parses vanilla print" $ do
-        let st = StPrint () u starVal (Just $ fromList () [ varGen "hex" ])
-        sParser "print *, hex" `shouldBe'` st
-
-      it "parses write with implied do" $ do
-        let cp1 = ControlPair () u Nothing (intGen 10)
-            cp2 = ControlPair () u (Just "format") (varGen "x")
-            ciList = fromList () [ cp1, cp2 ]
-            assign = StExpressionAssign () u (varGen "i") (intGen 1)
-            doSpec = DoSpecification () u assign (intGen 42) (Just $ intGen 2)
-            alist = fromList () [ varGen "i", varGen "j" ]
-            outList = fromList () [ ExpImpliedDo () u alist doSpec ]
-            st = StWrite () u ciList (Just outList)
-        sParser "write (10, FORMAT = x) (i, j,  i = 1, 42, 2)" `shouldBe'` st
-
-    it "parses use statement with renames" $ do
-      let renames = fromList ()
-            [ UseRename () u (varGen "sprod") (varGen "prod")
-            , UseRename () u (varGen "a") (varGen "b") ]
-          st = StUse () u (varGen "stats_lib") Nothing Permissive (Just renames)
-      sParser "use stats_lib, sprod => prod, a => b" `shouldBe'` st
-
-    it "parses use statement with only list" $ do
-      let onlys = fromList ()
-            [ UseID () u (varGen "a")
-            , UseRename () u (varGen "b") (varGen "c")
-            , UseID () u (ExpValue () u (ValOperator "+"))
-            , UseID () u (ExpValue () u ValAssignment) ]
-          st = StUse () u (varGen "stats_lib") Nothing Exclusive (Just onlys)
-      sParser "use stats_lib, only: a, b => c, operator(+), assignment(=)" `shouldBe'` st
-
-    specFreeFormCommon sParser eParser
diff --git a/test/Language/Fortran/Parser/Fortran95Spec.hs b/test/Language/Fortran/Parser/Fortran95Spec.hs
deleted file mode 100644
--- a/test/Language/Fortran/Parser/Fortran95Spec.hs
+++ /dev/null
@@ -1,660 +0,0 @@
-module Language.Fortran.Parser.Fortran95Spec (spec) where
-
-import Prelude hiding (GT, EQ, exp, pred)
-
-import Test.Hspec
-import TestUtil
-import Language.Fortran.Parser.FreeFormCommon
-
-import Control.Exception (evaluate)
-
-import Language.Fortran.AST
-import Language.Fortran.ParserMonad
-import Language.Fortran.Lexer.FreeForm
-import Language.Fortran.Parser.Fortran95
-import qualified Data.List as List
-import Data.Foldable(forM_)
-import qualified Data.ByteString.Char8 as B
-
-{-# ANN module "HLint: ignore Reduce duplication" #-}
-
-eParser :: String -> Expression ()
-eParser sourceCode =
-  case evalParse statementParser parseState of
-    (StExpressionAssign _ _ _ e) -> e
-    _ -> error "unhandled evalParse"
-  where
-    paddedSourceCode = B.pack $ "      a = " ++ sourceCode
-    parseState =  initParseState paddedSourceCode Fortran95 "<unknown>"
-
-sParser :: String -> Statement ()
-sParser sourceCode =
-  evalParse statementParser $ initParseState (B.pack sourceCode) Fortran95 "<unknown>"
-
-blParser :: String -> Block ()
-blParser sourceCode =
-  evalParse blockParser $ initParseState (B.pack sourceCode) Fortran95 "<unknown>"
-
-fParser :: String -> ProgramUnit ()
-fParser sourceCode =
-  evalParse functionParser $ initParseState (B.pack sourceCode) Fortran95 "<unknown>"
-
-{- Useful for parser debugging; Lexes the given source code.
-fTok :: String -> [Token]
-fTok sourceCode = collectFreeTokens Fortran95 $ B.pack sourceCode
--}
-
-{-
- - Given a list of values, find every combination of those values:
- - combination [1,2] = [[], [1], [2], [1,2], [2,1]]
- -}
-combination :: [a] -> [[a]]
-combination = foldr ((++) . List.permutations) [] . List.subsequences
-
-spec :: Spec
-spec =
-  describe "Fortran 95 Parser" $ do
-    describe "Function" $ do
-      let puFunction = PUFunction () u
-          fType = Nothing
-          fSuf = emptySuffixes
-          fPreSuf = emptyPrefixSuffix
-          fName = "f"
-          fArgs = Nothing
-          fRes = Nothing
-          fBody = []
-          fSub = Nothing
-
-      describe "End" $ do
-        it "parses simple functions ending with \"end function [function name]\"" $ do
-          let expected = puFunction fType fPreSuf fName fArgs fRes fBody fSub
-              fStr = init $ unlines ["function f()"
-                               , "end function f" ]
-          fParser fStr `shouldBe'` expected
-
-        it "parses simple functions ending with \"end\"" $ do
-          let expected = puFunction fType fPreSuf fName fArgs fRes fBody fSub
-              fStr = init $ unlines ["function f()"
-                               , "end" ]
-          fParser fStr `shouldBe'` expected
-
-        it "parses simple functions ending with \"end function\"" $ do
-          let expected = puFunction fType fPreSuf fName fArgs fRes fBody fSub
-              fStr = init $ unlines ["function f()"
-                               , "end function" ]
-          fParser fStr `shouldBe'` expected
-
-
-        it "parses functions with return type specs" $ do
-          let fType' = Just $ TypeSpec () u TypeInteger Nothing
-              expected = puFunction fType' fPreSuf fName fArgs fRes fBody fSub
-              fStr = init $ unlines ["integer function f()"
-                               , "end function f" ]
-          fParser fStr `shouldBe'` expected
-
-      describe "parses function options (recursive, pure, elemental)" $ do
-        let options_list = map unzip $ combination
-                                        [ ("recursive ", PfxRecursive () u)
-                                        , ("pure ", PfxPure () u)
-                                        , ("elemental ", PfxElemental () u) ]
-
-        forM_ options_list (\(strs, opts) -> do
-          let isElem (PfxElemental {}) = True; isElem _ = False
-              isRec  (PfxRecursive {}) = True; isRec _  = False
-              str = concat strs
-              fStr = str ++ init (unlines ["function f()", "end"])
-              pfx = fromList' () opts
-          --let expected = puFunction fType
-          if any isElem opts && any isRec opts
-            then
-              it ("Shouldn't parse: " ++ show fStr ++ ": " ++ show opts) $
-                evaluate (fParser fStr) `shouldThrow` anyIOException
-            else
-              it ("Should parse: " ++ show fStr ++ ": " ++ show opts) $ do
-                let expected' = puFunction fType (pfx, fSuf) fName fArgs fRes fBody fSub
-                fParser fStr `shouldBe'` expected'
-          )
-
-      it "parses functions with a list of arguments" $ do
-        let fArgs' = Just $ AList () u [ varGen "x", varGen "y", varGen "z" ]
-            expected = puFunction fType fPreSuf fName fArgs' fRes fBody fSub
-            fStr = init $ unlines ["function f(x, y, z)"
-                             , "end function f" ]
-        fParser fStr `shouldBe'` expected
-
-      it "parses functions with a result variable" $ do
-        let fRes' = Just $ varGen "i"
-            expected = puFunction fType fPreSuf fName fArgs fRes' fBody fSub
-            fStr = init $ unlines ["function f() result(i)"
-                             , "end function f" ]
-        fParser fStr `shouldBe'` expected
-
-      it "parses functions with function bodies" $ do
-        let decrementRHS = ExpBinary () u Subtraction (varGen "i") (intGen 1)
-            f1 = StPrint () u starVal (Just $ AList () u [ varGen "i" ])
-            f2 = StExpressionAssign () u (varGen "i") decrementRHS
-            fBody' = [ BlStatement () u Nothing f1 , BlStatement () u Nothing f2 ]
-            expected = puFunction fType fPreSuf fName fArgs fRes fBody' fSub
-            fStr = init $ unlines ["function f()"
-                             , "  print *, i"
-                             , "  i = (i - 1)"
-                             , "end function f" ]
-        fParser fStr `shouldBe'` expected
-
-      it "parses complex functions" $ do
-        let fType' = Just $ TypeSpec () u TypeInteger Nothing
-            fArgs' = Just $ AList () u [ varGen "x", varGen "y", varGen "z" ]
-            fRes' = Just $ varGen "i"
-            decrementRHS = ExpBinary () u Subtraction (varGen "i") (intGen 1)
-            f1 = StPrint () u starVal (Just $ AList () u [ varGen "i" ])
-            f2 = StExpressionAssign () u (varGen "i") decrementRHS
-            fBody' = [ BlStatement () u Nothing f1 , BlStatement () u Nothing f2 ]
-            expected = puFunction fType' fPreSuf fName fArgs' fRes' fBody' fSub
-            fStr = init $ unlines [ "integer function f(x, y, z) result(i)"
-                             , "  print *, i"
-                             , "  i = (i - 1)"
-                             , "end function f" ]
-        fParser fStr `shouldBe'` expected
-
-    describe "Expression" $ do
-      it "parses logical literal without kind parameter" $ do
-        eParser ".true." `shouldBe'` valTrue
-
-      it "parses logical literal with kind parameter" $ do
-        let kp = ExpValue () u (ValVariable "kind")
-        eParser ".false._kind" `shouldBe'` valFalse' kp
-
-      it "parses array initialisation exp" $ do
-        let list = AList () u [ intGen 1, intGen 2, intGen 3, intGen 4 ]
-        eParser "(/ 1, 2, 3, 4 /)" `shouldBe'` ExpInitialisation () u list
-
-      describe "Custom operator" $ do
-        let unOp = UnCustom ".inverse."
-            unExp = ExpUnary () u unOp $ intGen 42
-
-        it "parses unary custom operator" $
-          eParser ".inverse. 42" `shouldBe'` unExp
-
-        let binOp = BinCustom ".xor."
-        it "parses binary custom operator" $ do
-          let expected = ExpBinary () u binOp (intGen 24) (intGen 42)
-          eParser "24 .xor. 42" `shouldBe'` expected
-
-        it "parses mixed unary custom operator" $ do
-          let binExp = ExpBinary () u binOp unExp (intGen 24)
-          eParser ".inverse. 42 .xor. 24" `shouldBe'` binExp
-
-        it "parses data ref" $ do
-          let range = fromList () [ IxSingle () u Nothing $ intGen 10 ]
-              sub = ExpSubscript () u (varGen "y") range
-              innerRefExp = ExpDataRef () u (varGen "x") sub
-              exp = ExpDataRef () u innerRefExp (varGen "z")
-          eParser "x % y(10) % z" `shouldBe'` exp
-
-        it "parses section subscript" $ do
-          let range = [ IxSingle () u Nothing $ intGen 10
-                      , IxRange () u Nothing (Just $ intGen 1) (Just $ intGen 2)
-                      , IxSingle () u Nothing $ varGen "y" ]
-              exp = ExpSubscript () u (varGen "x") (fromList () range)
-          eParser "x (10, : 1 : 2, y)" `shouldBe'` exp
-
-    describe "Statement" $ do
-      it "data ref assignment" $ do
-        let indicies = AList () u [ IxSingle () u Nothing (intGen 1) ]
-            subs = ExpSubscript () u (varGen "x") indicies
-            lhs = ExpDataRef () u subs (varGen "y")
-            st = StExpressionAssign () u lhs (intGen 1)
-        sParser "x(1) % y = 1" `shouldBe'` st
-
-      it "doesn't parse assign statements" $ do
-        let stStr = "ASSIGN 1 \"LABEL\""
-        evaluate (sParser stStr) `shouldThrow` anyIOException
-
-      it "doesn't parse pause statements" $ do
-        let stStr = "PAUSE"
-        evaluate (sParser stStr) `shouldThrow` anyIOException
-
-      it "doesn't parse pause statements with expression" $ do
-        let stStr = "PAUSE \"MESSAGE\""
-        evaluate (sParser stStr) `shouldThrow` anyIOException
-
-      it "parses declaration with attributes" $ do
-        let typeSpec = TypeSpec () u TypeReal Nothing
-            attrs = AList () u [ AttrExternal () u
-                               , AttrIntent () u Out
-                               , AttrDimension () u $ AList () u
-                                  [ DimensionDeclarator () u
-                                      (Just $ intGen 3) (Just $ intGen 10)
-                                  ]
-                               ]
-            declarators = AList () u
-              [ declVariable () u (varGen "x") Nothing Nothing
-              , declVariable () u (varGen "y") Nothing Nothing ]
-            expected = StDeclaration () u typeSpec (Just attrs) declarators
-            stStr = "real, external, intent (out), dimension (3:10) :: x, y"
-        sParser stStr `shouldBe'` expected
-
-      it "parses declaration with old syntax" $ do
-        let typeSpec = TypeSpec () u TypeLogical Nothing
-            declarators = AList () u
-              [ declVariable () u (varGen "x") Nothing Nothing
-              , declVariable () u (varGen "y") Nothing Nothing ]
-            expected = StDeclaration () u typeSpec Nothing declarators
-            stStr = "logical x, y"
-        sParser stStr `shouldBe'` expected
-
-      it "parses declaration with initialisation" $ do
-        let typeSpec = TypeSpec () u TypeComplex Nothing
-            init' = ExpValue () u (ValComplex (intGen 24) (realGen (42.0::Double)))
-            declarators = AList () u
-              [ declVariable () u (varGen "x") Nothing (Just init') ]
-            expected = StDeclaration () u typeSpec Nothing declarators
-            stStr = "complex :: x = (24, 42.0)"
-        sParser stStr `shouldBe'` expected
-
-      it "parses declaration of custom type" $ do
-        let typeSpec = TypeSpec () u (TypeCustom "meinetype") Nothing
-            declarators = AList () u
-              [ declVariable () u (varGen "x") Nothing Nothing ]
-            expected = StDeclaration () u typeSpec Nothing declarators
-            stStr = "type (MeineType) :: x"
-        sParser stStr `shouldBe'` expected
-
-      it "parses declaration type with kind selector" $ do
-        let selector = Selector () u Nothing (Just $ varGen "hello")
-            typeSpec = TypeSpec () u TypeInteger (Just selector)
-            declarators = AList () u
-              [ declVariable () u (varGen "x") Nothing Nothing ]
-            expected = StDeclaration () u typeSpec Nothing declarators
-            stStr = "integer (hello) :: x"
-        sParser stStr `shouldBe'` expected
-
-      it "parses intent statement" $ do
-        let stStr = "intent (inout) :: a"
-            expected = StIntent () u InOut (fromList () [ varGen "a" ])
-        sParser stStr `shouldBe'` expected
-
-      it "parses optional statement" $ do
-        let stStr = "optional x"
-            expected = StOptional () u (fromList () [ varGen "x" ])
-        sParser stStr `shouldBe'` expected
-
-      it "parses public statement" $ do
-        let stStr = "public :: x"
-            expected = StPublic () u (Just $ fromList () [ varGen "x" ])
-        sParser stStr `shouldBe'` expected
-
-      it "parses public assignment" $ do
-        let expected = StPublic () u (Just $ fromList () [ assVal ])
-        sParser "public :: assignment (=)" `shouldBe'` expected
-
-      it "parses private statement" $
-        sParser "private" `shouldBe'` StPrivate () u Nothing
-
-      it "parses private operator" $ do
-        let expected = StPrivate () u (Just $ fromList () [ opGen "*" ])
-        sParser "private operator ( * )" `shouldBe'` expected
-
-      it "parses save statement" $ do
-        let list = [ varGen "hello", varGen "bye" ]
-            expected = StSave () u (Just $ fromList () list)
-            stStr = "save /hello/, bye"
-        sParser stStr `shouldBe'` expected
-
-      it "parses parameter statement" $ do
-        let ass1 = declVariable () u (varGen "x") Nothing (Just $ intGen 10)
-            ass2 = declVariable () u (varGen "y") Nothing (Just $ intGen 20)
-            expected = StParameter () u (fromList () [ ass1, ass2 ])
-        sParser "parameter (x = 10, y = 20)" `shouldBe'` expected
-
-      describe "FORALL blocks" $ do
-        let stride = Just $ ExpBinary () u NE (varGen "i") (intGen 2)
-            tripletSpecList = [("i", intGen 1, varGen "n", stride)]
-
-        it "parses basic FORALL blocks" $ do
-          let stStr = "FORALL (I=1:N, I /= 2)"
-              expected = StForall () u Nothing (ForallHeader tripletSpecList Nothing)
-          sParser stStr `shouldBe'` expected
-
-      describe "FORALL statements" $ do
-        let stride = Just $ ExpBinary () u NE (varGen "i") (intGen 2)
-            tripletSpecList = [("i", intGen 1, varGen "n", stride)]
-        --let varI = IxSingle () u Nothing (varGen "i")
-        --let expSub1 = ExpSubscript () u (varGen "a") (AList () u [varI, varI])
-        --let expSub2 = ExpSubscript () u (varGen "x") (AList () u [varI])
-        --let eAssign = StExpressionAssign () u expSub1 expSub2
-
-        it "parses basic FORALL statements" $ do
-          let stStr = "FORALL (I=1:N, I /= 2)" -- A(I,I) = X(I)"
-              expected = StForall () u Nothing (ForallHeader tripletSpecList Nothing)-- eAssign
-          sParser stStr `shouldBe'` expected
-
-      describe "ENDFORALL statements" $ do
-        it "parses FORALL end statements" $ do
-          let stStr = "ENDFORALL"
-              expected = StEndForall () u Nothing
-          sParser stStr `shouldBe'` expected
-
-        it "parses FORALL end statements with label" $ do
-          let stStr = "ENDFORALL A"
-              expected = StEndForall () u $ Just "a"
-          sParser stStr `shouldBe'` expected
-
-      describe "Implicit" $ do
-        it "parses implicit none" $ do
-          let st = StImplicit () u Nothing
-          sParser "implicit none" `shouldBe'` st
-
-        it "parses implicit with single" $ do
-          let typeSpec = TypeSpec () u TypeCharacter Nothing
-              impEls = [ ImpCharacter () u "k" ]
-              impLists = [ ImpList () u typeSpec (fromList () impEls) ]
-              st = StImplicit () u (Just $ fromList () impLists)
-          sParser "implicit character (k)" `shouldBe'` st
-
-        it "parses implicit with range" $ do
-          let typeSpec = TypeSpec () u TypeLogical Nothing
-              impEls = [ ImpRange () u "x" "z" ]
-              impLists = [ ImpList () u typeSpec (fromList () impEls) ]
-              st = StImplicit () u (Just $ fromList () impLists)
-          sParser "implicit logical (x-z)" `shouldBe'` st
-
-        it "parses implicit statement" $ do
-          let typeSpec1 = TypeSpec () u TypeCharacter Nothing
-              typeSpec2 = TypeSpec () u TypeInteger Nothing
-              impEls1 = [ ImpCharacter () u "s", ImpCharacter () u "a" ]
-              impEls2 = [ ImpRange () u "x" "z" ]
-              impLists = [ ImpList () u typeSpec1 (fromList () impEls1)
-                         , ImpList () u typeSpec2 (fromList () impEls2) ]
-              st = StImplicit () u (Just $ fromList () impLists)
-          sParser "implicit character (s, a), integer (x-z)" `shouldBe'` st
-
-      describe "Data" $ do
-        it "parses vanilla" $ do
-          let nlist = fromList () [ varGen "x", varGen "y" ]
-              vlist = fromList () [ intGen 1, intGen 2 ]
-              list = [ DataGroup () u nlist vlist ]
-              expected = StData () u (fromList () list)
-              stStr = "data x,y/1,2/"
-          sParser stStr `shouldBe'` expected
-
-        describe "Delimeter" $ do
-          let [ nlist1, vlist1 ] =
-                map (fromList () . return) [ varGen "x", intGen 1 ]
-              [ nlist2, vlist2 ] =
-                map (fromList () . return) [ varGen "y", intGen 2 ]
-              list = [ DataGroup () u nlist1 vlist1
-                     , DataGroup () u nlist2 vlist2 ]
-              expected = StData () u (fromList () list)
-
-          it "parses comma delimited init groups" $
-            sParser "data x/1/, y/2/" `shouldBe'` expected
-
-          it "parses non-comma delimited init groups" $
-            sParser "data x/1/ y/2/" `shouldBe'` expected
-
-      describe "Namelist" $ do
-        let groupNames = [ ExpValue () u (ValVariable "something")
-                         , ExpValue () u (ValVariable "other") ]
-            itemss = [ fromList () [ varGen "a", varGen "b", varGen "c" ]
-                     , fromList () [ varGen "y" ] ]
-            st = StNamelist () u $
-              fromList () [ Namelist () u (head groupNames) (head itemss)
-                          , Namelist () u (last groupNames) (last itemss) ]
-
-        it "parses namelist statement (comma delimited) (1)" $
-          sParser "namelist /something/a,b,c,/other/y" `shouldBe'` st
-
-        it "parses namelist statement (2)" $
-          sParser "namelist /something/a,b,c/other/y" `shouldBe'` st
-
-      describe "Common" $ do
-        let commonNames = [ ExpValue () u (ValVariable "something")
-                          , ExpValue () u (ValVariable "other") ]
-            itemss = [ fromList () [ declVarGen "a", declVarGen "b", declVarGen "c" ]
-                     , fromList () [ declVarGen "y" ] ]
-            st = StCommon () u $ fromList ()
-              [ CommonGroup () u Nothing (fromList () [ declVarGen "q" ])
-              , CommonGroup () u (Just $ head commonNames) (head itemss)
-              , CommonGroup () u (Just $ last commonNames) (last itemss) ]
-
-        it "parses common statement (comma delimited) (1)" $
-          sParser "common q /something/a,b,c, /other/y" `shouldBe'` st
-
-        it "parses common statement (2)" $
-          sParser "common q /something/a,b,c /other/y" `shouldBe'` st
-
-      it "parses equivalence statement" $ do
-        let eqALists = fromList ()
-              [ fromList ()
-                  [ let indicies = fromList () [ IxSingle () u Nothing (intGen 1) ]
-                    in ExpSubscript () u (varGen "a") indicies
-                  , varGen "x"
-                  ]
-              , fromList ()
-                  [ varGen "y"
-                  , varGen "z"
-                  , let indicies = fromList () [ IxRange () u (Just $ intGen 1)
-                                                              (Just $ intGen 42)
-                                                              Nothing ]
-                    in ExpSubscript () u (varGen "d") indicies
-                  ]
-              ]
-            st = StEquivalence () u eqALists
-        sParser "equivalence (a(1), x), (y, z, d(1:42))" `shouldBe'` st
-
-      describe "Dynamic allocation" $ do
-        it "parses allocate statement" $ do
-          let opt = AOStat () u (varGen "a")
-              allocs = fromList ()
-                [ varGen "x"
-                , ExpDataRef () u (varGen "st") (varGen "part")
-                ]
-              s = StAllocate () u Nothing allocs (Just (AList () u [opt]))
-          sParser "allocate (x, st % part, STAT = a)" `shouldBe'` s
-
-        it "parses deallocate statement" $ do
-          let allocs = fromList ()
-                [ let indicies = fromList () [ IxSingle () u Nothing (intGen 20) ]
-                  in ExpSubscript () u (varGen "smt") indicies
-                ]
-              s = StDeallocate () u allocs Nothing
-          sParser "deallocate (smt ( 20 ))" `shouldBe'` s
-
-        it "parses nullify statement" $ do
-          let s = StNullify () u (fromList () [ varGen "x" ])
-          sParser "nullify (x)" `shouldBe'` s
-
-      it "parses pointer assignment" $ do
-        let src = ExpDataRef () u (varGen "x") (varGen "y")
-            st = StPointerAssign () u src (varGen "exp")
-        sParser "x % y => exp" `shouldBe'` st
-
-      describe "Where" $ do
-        it "parses where statement" $ do
-          let exp = ExpBinary () u Subtraction (varGen "temp") (varGen "r_temp")
-              pred = ExpBinary () u GT (varGen "temp") (intGen 100)
-              assignment = StExpressionAssign () u (varGen "temp") exp
-              st = StWhere () u pred assignment
-          sParser "where (temp > 100) temp = temp - r_temp"`shouldBe'` st
-
-        describe "Where block" $ do
-          it "parses where construct statement" $
-            sParser "where (.true.)" `shouldBe'` StWhereConstruct () u Nothing valTrue
-
-          it "parses elsewhere statement" $
-            sParser "elsewhere" `shouldBe'` StElsewhere () u Nothing Nothing
-
-          it "parses elsewhere statement" $ do
-            let exp = ExpBinary () u GT (varGen "a") (varGen "b")
-            sParser "elsewhere (a > b)" `shouldBe'` StElsewhere () u Nothing (Just exp)
-
-          it "parses endwhere statement" $
-            sParser "endwhere" `shouldBe'` StEndWhere () u Nothing
-
-    describe "If" $ do
-      let stPrint = StPrint () u starVal (Just $ fromList () [ ExpValue () u (ValString "foo")])
-      it "parser if block" $
-        let ifBlockSrc = unlines [ "if (.false.) then", "print *, 'foo'", "end if"]
-        in blParser ifBlockSrc `shouldBe'` BlIf () u Nothing Nothing [Just valFalse] [[BlStatement () u Nothing stPrint]] Nothing
-
-      it "parses named if block" $ do
-        let ifBlockSrc = unlines [ "mylabel : if (.true.) then", "print *, 'foo'", "end if mylabel"]
-            ifBlock = BlIf () u Nothing (Just "mylabel") [Just valTrue] [[BlStatement () u Nothing stPrint]] Nothing
-        blParser ifBlockSrc `shouldBe'` ifBlock
-
-      it "parses if-else block with inline comments (stripped)" $
-        let ifBlockSrc = unlines [ "if (.false.) then ! comment if", "print *, 'foo'", "else ! comment else", "print *, 'foo'", "end if ! comment end"]
-        in blParser ifBlockSrc `shouldBe'` BlIf () u Nothing Nothing [Just valFalse, Nothing] [[BlStatement () u Nothing stPrint], [BlStatement () u Nothing stPrint]] Nothing
-
-      it "parses logical if statement" $ do
-        let assignment = StExpressionAssign () u (varGen "a") (varGen "b")
-            stIf = StIfLogical () u valTrue assignment
-        sParser "if (.true.) a = b" `shouldBe'` stIf
-
-      it "parses arithmetic if statement" $ do
-        let stIf = StIfArithmetic () u (varGen "x") (intGen 1)
-                                                    (intGen 2)
-                                                    (intGen 3)
-        sParser "if (x) 1, 2, 3" `shouldBe'` stIf
-
-    describe "Case" $ do
-      let printArgs str = Just $ AList () u [ExpValue () u $ ValString str]
-          printStmt = StPrint () u (ExpValue () u ValStar) . printArgs
-          printBlock = BlStatement () u Nothing . printStmt
-          ind2 = AList () u . pure $ IxSingle () u Nothing $ intGen 2
-          ind3Plus = AList () u . pure $ IxRange () u (Just $ intGen 3) Nothing Nothing
-          conds = [Just ind2, Just ind3Plus, Nothing]
-      it "unlabelled case block (with inline comments to be stripped)" $ do
-        let src = unlines [ "select case (x) ! comment select"
-                          , "! full line before first case (unrepresentable)"
-                          , "case (2) ! comment case 1"
-                          , "print *, 'foo'"
-                          , "case (3:) ! comment case 2"
-                          , "print *, 'bar'"
-                          , "case default ! comment case 3"
-                          , "print *, 'baz'"
-                          , "end select ! comment end"
-                          ]
-            blocks = (fmap . fmap) printBlock [["foo"], ["bar"], ["baz"]]
-            block = BlCase () u Nothing Nothing (varGen "x") conds blocks Nothing
-        blParser src `shouldBe'` block
-      it "labelled case block (with inline comments to be stripped" $ do
-        let src = unlines [ "10 mylabel: select case (x) ! comment select"
-                          , "20 case (2) ! comment case 1"
-                          , "30 print *, 'foo'"
-                          , "40 case (3:) ! comment case 2"
-                          , "50 print *, 'bar'"
-                          , "60 case default ! comment case 3"
-                          , "70 print *, 'baz'"
-                          , "80 end select mylabel ! comment end"
-                          ]
-            blocks = (fmap . fmap)
-                     (\(label, arg) -> BlStatement () u (Just $ intGen label) $ printStmt arg)
-                     [[(30, "foo")], [(50, "bar")], [(70, "baz")]]
-            block = BlCase () u
-                           (Just $ intGen 10) (Just "mylabel") (varGen "x")
-                           conds blocks
-                           (Just $ intGen 80)
-        blParser src `shouldBe'` block
-
-    describe "Do" $ do
-      it "parses do statement with label" $ do
-        let assign = StExpressionAssign () u (varGen "i") (intGen 0)
-            doSpec = DoSpecification () u assign (intGen 42) Nothing
-            st = StDo () u Nothing (Just $ intGen 24) (Just doSpec)
-        sParser "do 24, i = 0, 42" `shouldBe'` st
-
-      it "parses do statement without label" $ do
-        let assign = StExpressionAssign () u (varGen "i") (intGen 0)
-            doSpec = DoSpecification () u assign (intGen 42) Nothing
-            st = StDo () u Nothing Nothing (Just doSpec)
-        sParser "do i = 0, 42" `shouldBe'` st
-
-      it "parses infinite do" $ do
-        let st = StDo () u Nothing Nothing Nothing
-        sParser "do" `shouldBe'` st
-
-      it "parses end do statement" $ do
-        let st = StEnddo () u (Just "constructor")
-        sParser "end do constructor" `shouldBe'` st
-
-    describe "DO WHILE" $ do
-      it "parses unnamed do while statement" $ do
-        let st = StDoWhile () u Nothing Nothing valTrue
-        sParser "do while (.true.)" `shouldBe'` st
-
-      it "parses named do while statement" $ do
-        let st = StDoWhile () u (Just "name") Nothing valTrue
-        sParser "name: do while (.true.)" `shouldBe'` st
-
-      it "parses unnamed labelled do while statement" $ do
-        let st = StDoWhile () u Nothing (Just (intGen 999)) valTrue
-        sParser "do 999 while (.true.)" `shouldBe'` st
-
-    describe "Goto" $ do
-      it "parses vanilla goto" $ do
-        let st = StGotoUnconditional () u (intGen 999)
-        sParser "goto 999" `shouldBe'` st
-
-      it "parses computed goto" $ do
-        let list = fromList () [ intGen 10, intGen 20, intGen 30 ]
-            st = StGotoComputed () u list (intGen 20)
-        sParser "goto (10, 20, 30) 20" `shouldBe'` st
-
-      it "doesn't parse assigned goto" $
-        evaluate (sParser "goto i, (10, 20, 30)") `shouldThrow` anyIOException
-
-      it "doesn't parse label assignment" $
-        evaluate (sParser "assign 20 to l") `shouldThrow` anyIOException
-
-    describe "IO" $ do
-      it "parses vanilla print" $ do
-        let st = StPrint () u starVal (Just $ fromList () [ varGen "hex" ])
-        sParser "print *, hex" `shouldBe'` st
-
-      it "parses write with implied do" $ do
-        let cp1 = ControlPair () u Nothing (intGen 10)
-            cp2 = ControlPair () u (Just "format") (varGen "x")
-            ciList = fromList () [ cp1, cp2 ]
-            assign = StExpressionAssign () u (varGen "i") (intGen 1)
-            doSpec = DoSpecification () u assign (intGen 42) (Just $ intGen 2)
-            alist = fromList () [ varGen "i", varGen "j" ]
-            outList = fromList () [ ExpImpliedDo () u alist doSpec ]
-            st = StWrite () u ciList (Just outList)
-        sParser "write (10, FORMAT = x) (i, j,  i = 1, 42, 2)" `shouldBe'` st
-
-    it "parses use statement" $ do
-      let renames = fromList ()
-            [ UseRename () u (varGen "sprod") (varGen "prod")
-            , UseRename () u (varGen "a") (varGen "b") ]
-          st = StUse () u (varGen "stats_lib") Nothing Permissive (Just renames)
-      sParser "use stats_lib, sprod => prod, a => b" `shouldBe'` st
-
-    it "parses value decl" $ do
-      let decls = [declVarGen "a", declVarGen "b"]
-          st = StValue () u (AList () u decls)
-      sParser "value a, b" `shouldBe'` st
-      sParser "value :: a, b" `shouldBe'` st
-
-    it "parses value attribute" $ do
-      let decls = [declVarGen "a", declVarGen "b"]
-          ty = TypeSpec () u TypeInteger Nothing
-          attrs = [AttrValue () u]
-          st = StDeclaration () u ty (Just (AList () u attrs)) (AList () u decls)
-      sParser "integer, value :: a, b" `shouldBe'` st
-
-    it "parses volatile decl" $ do
-      let decls = [declVarGen "a", declVarGen "b"]
-          st = StVolatile () u (AList () u decls)
-      sParser "volatile a, b" `shouldBe'` st
-      sParser "volatile :: a, b" `shouldBe'` st
-
-    it "parses volatile attribute" $ do
-      let decls = [declVarGen "a", declVarGen "b"]
-          ty = TypeSpec () u TypeInteger Nothing
-          attrs = [AttrVolatile () u]
-          st = StDeclaration () u ty (Just (AList () u attrs)) (AList () u decls)
-      sParser "integer, volatile :: a, b" `shouldBe'` st
-
-    specFreeFormCommon sParser eParser
diff --git a/test/Language/Fortran/Parser/Free/Common.hs b/test/Language/Fortran/Parser/Free/Common.hs
new file mode 100644
--- /dev/null
+++ b/test/Language/Fortran/Parser/Free/Common.hs
@@ -0,0 +1,87 @@
+{-| Common tests for free-form Fortran.
+
+Fortran standards F90 and beyond are a lot more consistent than the
+previous 2. As such, there is lots of shared parsing, and lots of shared
+tests. This module encodes such shared/common tests, where no difference
+in behaviour between parsers is be expected.
+-}
+
+module Language.Fortran.Parser.Free.Common ( specFreeCommon ) where
+
+import           TestUtil
+import           Test.Hspec
+
+import           Language.Fortran.AST
+import           Language.Fortran.AST.RealLit
+
+specFreeCommon :: (String -> Statement A0) -> (String -> Expression A0) -> Spec
+specFreeCommon sParser eParser =
+  describe "Common Fortran 90+ tests" $ do
+    describe "Literals" $ do
+      describe "Logical" $ do
+        it "parses logical literal without kind parameter" $ do
+          eParser ".true." `shouldBe'` valTrue
+
+        it "parses logical literal with kind parameter" $ do
+          let kp = ExpValue () u (ValVariable "kind")
+          eParser ".false._kind" `shouldBe'` valFalse' kp
+
+        it "parses mixed-case logical literal" $ do
+          eParser ".tRUe." `shouldBe'` valTrue
+
+      -- Main parse testing is performed in @Language.Fortran.AST.RealLitSpec@.
+      -- Here we mainly want to test kind parameter and sign behaviour.
+      describe "Real" $ do
+        let realLitExp r mkp = ExpValue () u (ValReal (parseRealLit r) mkp)
+        it "parses various REAL literals" $ do
+          eParser "1."      `shouldBe'` realLitExp "1."    Nothing
+          eParser ".1e20_8" `shouldBe'` realLitExp ".1e20" (Just (intGen 8))
+
+        it "parses \"negative\" real literal (unary op)" $ do
+          eParser "-1.0d-1_k8" `shouldBe'` ExpUnary () u Minus (realLitExp "1.0d-1" (Just (varGen "k8")))
+
+    describe "Statement" $ do
+      describe "Declaration" $ do
+        it "parses scalar declaration with nonstandard kind param (non-CHAR)" $ do
+          let stStr    = "integer x*8"
+              expected = StDeclaration () u typeSpec Nothing decls
+              typeSpec = TypeSpec () u TypeInteger Nothing
+              decls    = AList () u
+                [ declVariable () u (varGen "x") (Just (intGen 8)) Nothing ]
+          sParser stStr `shouldBe'` expected
+
+        it "parses array declaration with nonstandard kind param (non-CHAR)" $ do
+          let stStr    = "integer x(2)*8"
+              expected = StDeclaration () u typeSpec Nothing decls
+              typeSpec = TypeSpec () u TypeInteger Nothing
+              decls    = AList () u
+                [ declArray () u (varGen "x") dims (Just (intGen 8)) Nothing ]
+              dims     = AList () u
+                [ DimensionDeclarator () u Nothing (Just (intGen 2)) ]
+          sParser stStr `shouldBe'` expected
+
+        it "parses array declaration with nonstandard kind param (non-CHAR) and nonstandard dimension/charlen order" $ do
+          let stStr    = "integer x*8(2)"
+              expected = StDeclaration () u typeSpec Nothing decls
+              typeSpec = TypeSpec () u TypeInteger Nothing
+              decls    = AList () u
+                [ declArray () u (varGen "x") dims (Just (intGen 8)) Nothing ]
+              dims     = AList () u
+                [ DimensionDeclarator () u Nothing (Just (intGen 2)) ]
+          sParser stStr `shouldBe'` expected
+
+      describe "Function call" $ do
+        it "parses a simple function call" $ do
+          let stStr    = "call double(i, i)"
+              expected = StCall () u (varGen "double") (Just args)
+              args     = AList () u [arg, arg]
+              arg      = Argument () u Nothing (ArgExpr (varGen "i"))
+          sParser stStr `shouldBe'` expected
+
+        it "parses a parenthesized variable as a special indirect/copied variable reference" $ do
+          let stStr    = "call double((i), i)"
+              expected = StCall () u (varGen "double") (Just args)
+              args     = AList () u [ genArg (ArgExprVar () u "i")
+                                    , genArg (ArgExpr (varGen "i")) ]
+              genArg   = Argument () u Nothing
+          sParser stStr `shouldBe'` expected
diff --git a/test/Language/Fortran/Parser/Free/Fortran2003Spec.hs b/test/Language/Fortran/Parser/Free/Fortran2003Spec.hs
new file mode 100644
--- /dev/null
+++ b/test/Language/Fortran/Parser/Free/Fortran2003Spec.hs
@@ -0,0 +1,176 @@
+module Language.Fortran.Parser.Free.Fortran2003Spec ( spec ) where
+
+import Prelude hiding (GT, EQ, exp, pred)
+
+import Test.Hspec
+import TestUtil
+import Language.Fortran.Parser.Free.Common
+
+import Language.Fortran.AST
+import Language.Fortran.Version
+import Language.Fortran.Parser
+import Language.Fortran.Parser.Monad ( Parse )
+import qualified Language.Fortran.Parser.Free.Fortran2003 as F2003
+import qualified Language.Fortran.Parser.Free.Lexer       as Free
+
+import qualified Data.ByteString.Char8 as B
+
+parseWith :: Parse Free.AlexInput Free.Token a -> String -> a
+parseWith p = parseUnsafe (makeParserFree p Fortran2003) . B.pack
+
+eParser :: String -> Expression ()
+eParser = parseUnsafe p . B.pack
+  where p = makeParser initParseStateFreeExpr F2003.expressionParser Fortran2003
+
+sParser :: String -> Statement ()
+sParser = parseWith F2003.statementParser
+
+bParser :: String -> Block ()
+bParser = parseWith F2003.blockParser
+
+fParser :: String -> ProgramUnit ()
+fParser = parseWith F2003.functionParser
+
+spec :: Spec
+spec =
+  describe "Fortran 2003 Parser" $ do
+    describe "Modules" $ do
+      it "parses use statement, intrinsic module" $ do
+        let renames = fromList ()
+              [ UseRename () u (varGen "sprod") (varGen "prod")
+              , UseRename () u (varGen "a") (varGen "b") ]
+            st = StUse () u (varGen "mod") (Just ModIntrinsic) Permissive (Just renames)
+        sParser "use, intrinsic :: mod, sprod => prod, a => b" `shouldBe'` st
+
+      it "parses use statement, non_intrinsic module" $ do
+        let renames = fromList ()
+              [ UseRename () u (varGen "sprod") (varGen "prod")
+              , UseRename () u (varGen "a") (varGen "b") ]
+            st = StUse () u (varGen "mod") (Just ModNonIntrinsic) Exclusive (Just renames)
+        sParser "use, non_intrinsic :: mod, only: sprod => prod, a => b" `shouldBe'` st
+
+      it "parses use statement, unspecified nature of module" $ do
+        let renames = fromList ()
+              [ UseRename () u (varGen "sprod") (varGen "prod")
+              , UseRename () u (varGen "a") (varGen "b") ]
+            st = StUse () u (varGen "mod") Nothing Permissive (Just renames)
+        sParser "use :: mod, sprod => prod, a => b" `shouldBe'` st
+
+      it "parses procedure (interface-name, attribute, proc-decl)" $ do
+        let call = ExpFunctionCall () u (varGen "c") Nothing
+            st = StProcedure () u (Just (ProcInterfaceName () u (varGen "a")))
+                                  (Just (AttrSave () u))
+                                  (AList () u [ProcDecl () u (varGen "b") (Just call)])
+        sParser "PROCEDURE(a), SAVE :: b => c()" `shouldBe'` st
+
+      it "parses procedure (class-star, bind-name, proc-decls)" $ do
+        let call = ExpFunctionCall () u (varGen "c") Nothing
+            clas = TypeSpec () u ClassStar Nothing
+            st = StProcedure () u (Just (ProcInterfaceType () u clas))
+                                  (Just (AttrSuffix () u (SfxBind () u (Just (ExpValue () u (ValString "e"))))))
+                                  (AList () u [ProcDecl () u (varGen "b") (Just call)
+                                              ,ProcDecl () u (varGen "d") (Just call)])
+        sParser "PROCEDURE(CLASS(*)), BIND(C, NAME=\"e\") :: b => c(), d => c()" `shouldBe'` st
+
+      it "parses procedure (class-custom, bind, proc-decls)" $ do
+        let call = ExpFunctionCall () u (varGen "c") Nothing
+            clas = TypeSpec () u (ClassCustom "e") Nothing
+            st = StProcedure () u (Just (ProcInterfaceType () u clas))
+                                  (Just (AttrSuffix () u (SfxBind () u Nothing)))
+                                  (AList () u [ProcDecl () u (varGen "b") (Just call)
+                                              ,ProcDecl () u (varGen "d") (Just call)])
+        sParser "PROCEDURE(CLASS(e)), BIND(C) :: b => c(), d => c()" `shouldBe'` st
+
+      it "import statements" $ do
+        let st = StImport () u (AList () u [varGen "a", varGen "b"])
+        sParser "import a, b" `shouldBe'` st
+        sParser "import :: a, b" `shouldBe'` st
+
+      it "parses function with bind" $ do
+          let puFunction = PUFunction () u
+              fType = Nothing
+              fPre = emptyPrefixes
+              fSuf = fromList' () [SfxBind () u (Just $ ExpValue () u (ValString "f"))]
+              fName = "f"
+              fArgs = Nothing
+              fRes = Nothing
+              fBody = []
+              fSub = Nothing
+              fStr = init $ unlines ["function f() bind(c,name=\"f\")"
+                                    , "end function f" ]
+          let expected = puFunction fType (fPre, fSuf) fName fArgs fRes fBody fSub
+          fParser fStr `shouldBe'` expected
+
+      it "parses asynchronous decl" $ do
+        let decls = [declVarGen "a", declVarGen "b"]
+            st = StAsynchronous () u (AList () u decls)
+        sParser "asynchronous a, b" `shouldBe'` st
+        sParser "asynchronous :: a, b" `shouldBe'` st
+
+      it "parses asynchronous attribute" $ do
+        let decls = [declVarGen "a", declVarGen "b"]
+            ty = TypeSpec () u TypeInteger Nothing
+            attrs = [AttrAsynchronous () u]
+            st = StDeclaration () u ty (Just (AList () u attrs)) (AList () u decls)
+        sParser "integer, asynchronous :: a, b" `shouldBe'` st
+
+      it "parses enumerators" $ do
+        let decls = [ declVariable () u (varGen "a") Nothing (Just (intGen 1))
+                    , declVariable () u (varGen "b") Nothing Nothing ]
+            st = StEnumerator () u (AList () u decls)
+        sParser "enum, bind(c)" `shouldBe'` StEnum () u
+        sParser "enumerator :: a = 1, b" `shouldBe'` st
+        sParser "end enum" `shouldBe'` StEndEnum () u
+
+      it "parses allocate with type_spec" $ do
+        let sel = Selector () u (Just (ExpValue () u ValColon)) (Just (varGen "foo"))
+            ty = TypeSpec () u TypeCharacter (Just sel)
+            decls = AList () u [declVarGen "s"]
+            st = StDeclaration () u ty (Just (AList () u [AttrAllocatable () u])) decls
+        sParser "character(len=:,kind=foo), allocatable :: s" `shouldBe'` st
+
+      it "parses allocate with type_spec" $ do
+        let sel = Selector () u (Just (intGen 3)) (Just (varGen "foo"))
+            ty = TypeSpec () u TypeCharacter (Just sel)
+            st = StAllocate () u (Just ty) (AList () u [varGen "s"]) Nothing
+        sParser "allocate(character(len=3,kind=foo) :: s)" `shouldBe'` st
+
+      it "parses protected" $ do
+        let ty = TypeSpec () u TypeReal Nothing
+            decls = AList () u [declVarGen "x"]
+            st1 = StDeclaration () u ty (Just (AList () u [AttrProtected () u, AttrPublic () u])) decls
+            st2 = StProtected () u (Just (AList () u [varGen "x"]))
+        sParser "real, protected, public :: x" `shouldBe'` st1
+        sParser "protected x" `shouldBe'` st2
+
+    describe "labelled where" $ do
+      it "parses where construct statement" $
+        sParser "foo: where (.true.)" `shouldBe'` StWhereConstruct () u (Just "foo") valTrue
+
+      it "parses elsewhere statement" $
+        sParser "elsewhere ab101" `shouldBe'` StElsewhere () u (Just "ab101") Nothing
+
+      it "parses elsewhere statement" $ do
+        let exp = ExpBinary () u GT (varGen "a") (varGen "b")
+        sParser "elsewhere (a > b) A123" `shouldBe'` StElsewhere () u (Just "a123") (Just exp)
+
+      it "parses endwhere statement" $
+        sParser "endwhere foo1" `shouldBe'` StEndWhere () u (Just "foo1")
+
+    describe "associate block" $ do
+      it "parses multiple assignment associate block" $ do
+        let text = unlines [ "associate (x => a, y => (a * b))"
+                           , "  print *, x"
+                           , "  print *, y"
+                           , "end associate" ]
+            expected = BlAssociate () u Nothing Nothing abbrevs body' Nothing
+            body'   = [blStmtPrint "x", blStmtPrint "y"]
+            blStmtPrint x = BlStatement () u Nothing (stmtPrint x)
+            stmtPrint x = StPrint () u starVal (Just $ AList () u [ varGen x ])
+            abbrevs = AList () u [abbrev "x" (expValVar "a"), abbrev "y" (expBinVars Multiplication "a" "b")]
+            abbrev var expr = ATuple () u (expValVar var) expr
+            expValVar x = ExpValue () u (ValVariable x)
+            expBinVars op x1 x2 = ExpBinary () u op (expValVar x1) (expValVar x2)
+        bParser text `shouldBe'` expected
+
+    specFreeCommon sParser eParser
diff --git a/test/Language/Fortran/Parser/Free/Fortran2008Spec.hs b/test/Language/Fortran/Parser/Free/Fortran2008Spec.hs
new file mode 100644
--- /dev/null
+++ b/test/Language/Fortran/Parser/Free/Fortran2008Spec.hs
@@ -0,0 +1,8 @@
+module Language.Fortran.Parser.Free.Fortran2008Spec ( spec ) where
+
+import Test.Hspec
+
+spec :: Spec
+spec =
+  describe "Fortran 2008 Parser" $
+    it "TODO" pending
diff --git a/test/Language/Fortran/Parser/Free/Fortran90Spec.hs b/test/Language/Fortran/Parser/Free/Fortran90Spec.hs
new file mode 100644
--- /dev/null
+++ b/test/Language/Fortran/Parser/Free/Fortran90Spec.hs
@@ -0,0 +1,586 @@
+module Language.Fortran.Parser.Free.Fortran90Spec ( spec ) where
+
+import Prelude hiding (GT, exp, pred)
+
+import Test.Hspec
+import TestUtil
+import Language.Fortran.Parser.Free.Common
+
+import Language.Fortran.AST
+import Language.Fortran.Version
+import Language.Fortran.Parser
+import Language.Fortran.Parser.Monad ( Parse )
+import qualified Language.Fortran.Parser.Free.Fortran90 as F90
+import qualified Language.Fortran.Parser.Free.Lexer     as Free
+
+--import qualified Data.List as List
+import qualified Data.ByteString.Char8 as B
+
+parseWith :: Parse Free.AlexInput Free.Token a -> String -> a
+parseWith p = parseUnsafe (makeParserFree p Fortran90) . B.pack
+
+eParser :: String -> Expression ()
+eParser = parseUnsafe p . B.pack
+  where p = makeParser initParseStateFreeExpr F90.expressionParser Fortran90
+
+sParser :: String -> Statement ()
+sParser = parseWith F90.statementParser
+
+bParser :: String -> Block ()
+bParser = parseWith F90.blockParser
+
+fParser :: String -> ProgramUnit ()
+fParser = parseWith F90.functionParser
+
+{- Useful for parser debugging; Lexes the given source code.
+fTok :: String -> [Token]
+fTok sourceCode = collectFreeTokens Fortran95 $ B.pack sourceCode
+-}
+
+{-
+ - Given a list of values, find every combination of those values:
+ - combination [1,2] = [[], [1], [2], [1,2], [2,1]]
+ -}
+--combination :: [a] -> [[a]]
+--combination = foldr ((++) . List.permutations) [] . List.subsequences
+
+spec :: Spec
+spec =
+  describe "Fortran 90 Parser" $ do
+    describe "Function" $ do
+      let puFunction = PUFunction () u
+          fType = Nothing
+          fPre = emptyPrefixes
+          fPreR = Just $ AList () u [PfxRecursive () u]
+          fSuf = emptySuffixes
+          fPreSuf = (fPre, fSuf)
+          fName = "f"
+          fArgs = Nothing
+          fRes = Nothing
+          fBody = []
+          fSub = Nothing
+
+      describe "End" $ do
+        it "parses simple functions ending with \"end function [function name]\"" $ do
+          let expected = puFunction fType fPreSuf fName fArgs fRes fBody fSub
+              fStr = init $ unlines ["function f()"
+                               , "end function f" ]
+          fParser fStr `shouldBe'` expected
+
+        it "parses simple functions ending with \"end\"" $ do
+          let expected = puFunction fType fPreSuf fName fArgs fRes fBody fSub
+              fStr = init $ unlines ["function f()"
+                               , "end" ]
+          fParser fStr `shouldBe'` expected
+
+        it "parses simple functions ending with \"end function\"" $ do
+          let expected = puFunction fType fPreSuf fName fArgs fRes fBody fSub
+              fStr = init $ unlines ["function f()"
+                               , "end function" ]
+          fParser fStr `shouldBe'` expected
+
+
+        it "parses functions with return type specs" $ do
+          let fType' = Just $ TypeSpec () u TypeInteger Nothing
+              expected = puFunction fType' fPreSuf fName fArgs fRes fBody fSub
+              fStr = init $ unlines ["integer function f()"
+                               , "end function f" ]
+          fParser fStr `shouldBe'` expected
+
+      it "parses recursive functions" $
+        let expected = puFunction fType (fPreR, fSuf) fName fArgs fRes fBody fSub
+            fStr = init $ unlines ["recursive function f()", "end"]
+        in fParser fStr `shouldBe'` expected
+
+
+      it "parses functions with a list of arguments" $
+        let fArgs' = Just $ AList () u [ varGen "x", varGen "y", varGen "z" ]
+            expected = puFunction fType fPreSuf fName fArgs' fRes fBody fSub
+            fStr = init $ unlines ["function f(x, y, z)"
+                             , "end function f" ]
+        in fParser fStr `shouldBe'` expected
+
+      it "parses functions with a result variable" $
+        let fRes' = Just $ varGen "i"
+            expected = puFunction fType fPreSuf fName fArgs fRes' fBody fSub
+            fStr = init $ unlines ["function f() result(i)"
+                             , "end function f" ]
+        in fParser fStr `shouldBe'` expected
+
+      it "parses functions with function bodies" $
+        let decrementRHS = ExpBinary () u Subtraction (varGen "i") (intGen 1)
+            f1 = StPrint () u starVal (Just $ AList () u [ varGen "i" ])
+            f2 = StExpressionAssign () u (varGen "i") decrementRHS
+            fBody' = [ BlStatement () u Nothing f1 , BlStatement () u Nothing f2 ]
+            expected = puFunction fType fPreSuf fName fArgs fRes fBody' fSub
+            fStr = init $ unlines ["function f()"
+                             , "  print *, i"
+                             , "  i = (i - 1)"
+                             , "end function f" ]
+        in fParser fStr `shouldBe'` expected
+
+      it "parses complex functions" $
+        let fType' = Just $ TypeSpec () u TypeInteger Nothing
+            fArgs' = Just $ AList () u [ varGen "x", varGen "y", varGen "z" ]
+            fRes' = Just $ varGen "i"
+            decrementRHS = ExpBinary () u Subtraction (varGen "i") (intGen 1)
+            f1 = StPrint () u starVal (Just $ AList () u [ varGen "i" ])
+            f2 = StExpressionAssign () u (varGen "i") decrementRHS
+            fBody' = [ BlStatement () u Nothing f1 , BlStatement () u Nothing f2 ]
+            expected = puFunction fType' fPreSuf fName fArgs' fRes' fBody' fSub
+            fStr = init $ unlines [ "integer function f(x, y, z) result(i)"
+                             , "  print *, i"
+                             , "  i = (i - 1)"
+                             , "end function f" ]
+        in fParser fStr `shouldBe'` expected
+
+    describe "Expression" $ do
+      it "parses logical literal without kind parameter" $ do
+        eParser ".true." `shouldBe'` valTrue
+
+      it "parses logical literal with kind parameter" $ do
+        let kp = ExpValue () u (ValVariable "kind")
+        eParser ".false._kind" `shouldBe'` valFalse' kp
+
+      it "parses array initialisation exp" $ do
+        let list = AList () u [ intGen 1, intGen 2, intGen 3, intGen 4 ]
+        eParser "(/ 1, 2, 3, 4 /)" `shouldBe'` ExpInitialisation () u list
+
+      describe "Custom operator" $ do
+        let unOp = UnCustom ".inverse."
+            unExp = ExpUnary () u unOp $ intGen 42
+
+        it "parses unary custom operator" $
+          eParser ".inverse. 42" `shouldBe'` unExp
+
+        let binOp = BinCustom ".xor."
+        it "parses binary custom operator" $ do
+          let expected = ExpBinary () u binOp (intGen 24) (intGen 42)
+          eParser "24 .xor. 42" `shouldBe'` expected
+
+        it "parses mixed unary custom operator" $ do
+          let binExp = ExpBinary () u binOp unExp (intGen 24)
+          eParser ".inverse. 42 .xor. 24" `shouldBe'` binExp
+
+        it "parses data ref" $ do
+          let range = fromList () [ IxSingle () u Nothing $ intGen 10 ]
+              sub = ExpSubscript () u (varGen "y") range
+              innerRefExp = ExpDataRef () u (varGen "x") sub
+              exp = ExpDataRef () u innerRefExp (varGen "z")
+          eParser "x % y(10) % z" `shouldBe'` exp
+
+        it "parses section subscript" $ do
+          let range = [ IxSingle () u Nothing $ intGen 10
+                      , IxRange () u Nothing (Just $ intGen 1) (Just $ intGen 2)
+                      , IxSingle () u Nothing $ varGen "y" ]
+              exp = ExpSubscript () u (varGen "x") (fromList () range)
+          eParser "x (10, : 1 : 2, y)" `shouldBe'` exp
+
+    describe "Statement" $ do
+      it "data ref assignment" $ do
+        let indicies = AList () u [ IxSingle () u Nothing (intGen 1) ]
+            subs = ExpSubscript () u (varGen "x") indicies
+            lhs = ExpDataRef () u subs (varGen "y")
+            st = StExpressionAssign () u lhs (intGen 1)
+        sParser "x(1) % y = 1" `shouldBe'` st
+
+      it "parses pause statements" $ do
+        let stPause = StPause () u Nothing
+            stStr = "PAUSE"
+        sParser stStr `shouldBe'` stPause
+
+      it "parses pause statements with expression" $ do
+        let stPause = StPause () u (Just (strGen "MESSAGE"))
+            stStr = "PAUSE \"MESSAGE\""
+        sParser stStr `shouldBe'` stPause
+
+      it "parses declaration with attributes" $ do
+        let typeSpec = TypeSpec () u TypeReal Nothing
+            attrs = AList () u [ AttrExternal () u
+                               , AttrIntent () u Out
+                               , AttrDimension () u $ AList () u
+                                  [ DimensionDeclarator () u
+                                      (Just $ intGen 3) (Just $ intGen 10)
+                                  ]
+                               ]
+            declarators = AList () u [ declVarGen "x", declVarGen "y"]
+            expected = StDeclaration () u typeSpec (Just attrs) declarators
+            stStr = "real, external, intent (out), dimension (3:10) :: x, y"
+        sParser stStr `shouldBe'` expected
+
+      it "parses declaration with old syntax" $ do
+        let typeSpec = TypeSpec () u TypeLogical Nothing
+            declarators = AList () u [ declVarGen "x", declVarGen "y"]
+            expected = StDeclaration () u typeSpec Nothing declarators
+            stStr = "logical x, y"
+        sParser stStr `shouldBe'` expected
+
+      it "parses declaration with initialisation" $
+        let typeSpec = TypeSpec () u TypeComplex Nothing
+            init' = ExpValue () u (ValComplex (intGen 24) (realGen (42.0::Double)))
+            declarators = AList () u
+              [ declVariable () u (varGen "x") Nothing (Just init') ]
+            expected = StDeclaration () u typeSpec Nothing declarators
+            stStr = "complex :: x = (24, 42.0)"
+        in sParser stStr `shouldBe'` expected
+
+      it "parses declaration of custom type" $ do
+        let typeSpec = TypeSpec () u (TypeCustom "meinetype") Nothing
+            declarators = AList () u [declVarGen "x"]
+            expected = StDeclaration () u typeSpec Nothing declarators
+            stStr = "type (MeineType) :: x"
+        sParser stStr `shouldBe'` expected
+
+      it "parses declaration type with kind selector" $ do
+        let selector = Selector () u Nothing (Just $ varGen "hello")
+            typeSpec = TypeSpec () u TypeInteger (Just selector)
+            declarators = AList () u [declVarGen "x"]
+            expected = StDeclaration () u typeSpec Nothing declarators
+            stStr = "integer (hello) :: x"
+        sParser stStr `shouldBe'` expected
+
+      it "parses intent statement" $ do
+        let stStr = "intent (inout) :: a"
+            expected = StIntent () u InOut (fromList () [ varGen "a" ])
+        sParser stStr `shouldBe'` expected
+
+      it "parses optional statement" $ do
+        let stStr = "optional x"
+            expected = StOptional () u (fromList () [ varGen "x" ])
+        sParser stStr `shouldBe'` expected
+
+      it "parses public statement" $ do
+        let stStr = "public :: x"
+            expected = StPublic () u (Just $ fromList () [ varGen "x" ])
+        sParser stStr `shouldBe'` expected
+
+      it "parses public assignment" $ do
+        let expected = StPublic () u (Just $ fromList () [ assVal ])
+        sParser "public :: assignment (=)" `shouldBe'` expected
+
+      it "parses private statement" $
+        sParser "private" `shouldBe'` StPrivate () u Nothing
+
+      it "parses private operator" $ do
+        let expected = StPrivate () u (Just $ fromList () [ opGen "*" ])
+        sParser "private operator ( * )" `shouldBe'` expected
+
+      it "parses save statement" $ do
+        let list = [ varGen "hello", varGen "bye" ]
+            expected = StSave () u (Just $ fromList () list)
+            stStr = "save /hello/, bye"
+        sParser stStr `shouldBe'` expected
+
+      it "parses parameter statement" $ do
+        let ass1 = declVariable () u (varGen "x") Nothing (Just $ intGen 10)
+            ass2 = declVariable () u (varGen "y") Nothing (Just $ intGen 20)
+            expected = StParameter () u (fromList () [ ass1, ass2 ])
+        sParser "parameter (x = 10, y = 20)" `shouldBe'` expected
+
+      describe "Implicit" $ do
+        it "parses implicit none" $ do
+          let st = StImplicit () u Nothing
+          sParser "implicit none" `shouldBe'` st
+
+        it "parses implicit with single" $ do
+          let typeSpec = TypeSpec () u TypeCharacter Nothing
+              impEls = [ ImpCharacter () u "k" ]
+              impLists = [ ImpList () u typeSpec (fromList () impEls) ]
+              st = StImplicit () u (Just $ fromList () impLists)
+          sParser "implicit character (k)" `shouldBe'` st
+
+        it "parses implicit with range" $ do
+          let typeSpec = TypeSpec () u TypeLogical Nothing
+              impEls = [ ImpRange () u "x" "z" ]
+              impLists = [ ImpList () u typeSpec (fromList () impEls) ]
+              st = StImplicit () u (Just $ fromList () impLists)
+          sParser "implicit logical (x-z)" `shouldBe'` st
+
+        it "parses implicit statement" $ do
+          let typeSpec1 = TypeSpec () u TypeCharacter Nothing
+              typeSpec2 = TypeSpec () u TypeInteger Nothing
+              impEls1 = [ ImpCharacter () u "s", ImpCharacter () u "a" ]
+              impEls2 = [ ImpRange () u "x" "z" ]
+              impLists = [ ImpList () u typeSpec1 (fromList () impEls1)
+                         , ImpList () u typeSpec2 (fromList () impEls2) ]
+              st = StImplicit () u (Just $ fromList () impLists)
+          sParser "implicit character (s, a), integer (x-z)" `shouldBe'` st
+
+      describe "Data" $ do
+        it "parses vanilla" $ do
+          let nlist = fromList () [ varGen "x", varGen "y" ]
+              vlist = fromList () [ intGen 1, intGen 2 ]
+              list = [ DataGroup () u nlist vlist ]
+              expected = StData () u (fromList () list)
+              stStr = "data x,y/1,2/"
+          sParser stStr `shouldBe'` expected
+
+        describe "Delimeter" $ do
+          let [ nlist1, vlist1 ] =
+                map (fromList () . return) [ varGen "x", intGen 1 ]
+              [ nlist2, vlist2 ] =
+                map (fromList () . return) [ varGen "y", intGen 2 ]
+              list = [ DataGroup () u nlist1 vlist1
+                     , DataGroup () u nlist2 vlist2 ]
+              expected = StData () u (fromList () list)
+
+          it "parses comma delimited init groups" $
+            sParser "data x/1/, y/2/" `shouldBe'` expected
+
+          it "parses non-comma delimited init groups" $
+            sParser "data x/1/ y/2/" `shouldBe'` expected
+
+      describe "Namelist" $ do
+        let groupNames = [ ExpValue () u (ValVariable "something")
+                         , ExpValue () u (ValVariable "other") ]
+            itemss = [ fromList () [ varGen "a", varGen "b", varGen "c" ]
+                     , fromList () [ varGen "y" ] ]
+            st = StNamelist () u $
+              fromList () [ Namelist () u (head groupNames) (head itemss)
+                          , Namelist () u (last groupNames) (last itemss) ]
+
+        it "parses namelist statement (comma delimited) (1)" $
+          sParser "namelist /something/a,b,c,/other/y" `shouldBe'` st
+
+        it "parses namelist statement (2)" $
+          sParser "namelist /something/a,b,c/other/y" `shouldBe'` st
+
+      describe "Common" $ do
+        let commonNames = [ ExpValue () u (ValVariable "something")
+                          , ExpValue () u (ValVariable "other") ]
+            itemss = [ fromList () [ declVarGen "a", declVarGen "b", declVarGen "c" ]
+                     , fromList () [ declVarGen "y" ] ]
+            st = StCommon () u $ fromList ()
+              [ CommonGroup () u Nothing (fromList () [ declVarGen "q" ])
+              , CommonGroup () u (Just $ head commonNames) (head itemss)
+              , CommonGroup () u (Just $ last commonNames) (last itemss) ]
+
+        it "parses common statement (comma delimited) (1)" $
+          sParser "common q /something/a,b,c, /other/y" `shouldBe'` st
+
+        it "parses common statement (2)" $
+          sParser "common q /something/a,b,c /other/y" `shouldBe'` st
+
+      it "parses equivalence statement" $ do
+        let eqALists = fromList ()
+              [ fromList ()
+                  [ let indicies = fromList () [ IxSingle () u Nothing (intGen 1) ]
+                    in ExpSubscript () u (varGen "a") indicies
+                  , varGen "x"
+                  ]
+              , fromList ()
+                  [ varGen "y"
+                  , varGen "z"
+                  , let indicies = fromList () [ IxRange () u (Just $ intGen 1)
+                                                              (Just $ intGen 42)
+                                                              Nothing ]
+                    in ExpSubscript () u (varGen "d") indicies
+                  ]
+              ]
+        let st = StEquivalence () u eqALists
+        sParser "equivalence (a(1), x), (y, z, d(1:42))" `shouldBe'` st
+
+      describe "Dynamic allocation" $ do
+        it "parses allocate statement" $ do
+          let opt = AOStat () u (varGen "a")
+              allocs = fromList ()
+                [ varGen "x"
+                , ExpDataRef () u (varGen "st") (varGen "part")
+                ]
+          let s = StAllocate () u Nothing allocs (Just (AList () u [opt]))
+          sParser "allocate (x, st % part, STAT = a)" `shouldBe'` s
+
+        it "parses deallocate statement" $ do
+          let opt = AOStat () u (varGen "a")
+              allocs = fromList ()
+                [ let indicies = fromList () [ IxSingle () u Nothing (intGen 20) ]
+                  in ExpSubscript () u (varGen "smt") indicies
+                ]
+              s = StDeallocate () u allocs Nothing
+              s' = StDeallocate () u allocs (Just (AList () u [opt]))
+          sParser "deallocate (smt ( 20 ))" `shouldBe'` s
+          sParser "deallocate (smt ( 20 ), stat=a)" `shouldBe'` s'
+
+        it "parses nullify statement" $ do
+          let s = StNullify () u (fromList () [ varGen "x" ])
+          sParser "nullify (x)" `shouldBe'` s
+
+      it "parses pointer assignment" $ do
+        let src = ExpDataRef () u (varGen "x") (varGen "y")
+            st = StPointerAssign () u src (varGen "exp")
+        sParser "x % y => exp" `shouldBe'` st
+
+      describe "Where" $ do
+        it "parses where statement" $ do
+          let exp = ExpBinary () u Subtraction (varGen "temp") (varGen "r_temp")
+              pred = ExpBinary () u GT (varGen "temp") (intGen 100)
+              assignment = StExpressionAssign () u (varGen "temp") exp
+              st = StWhere () u pred assignment
+          sParser "where (temp > 100) temp = temp - r_temp"`shouldBe'` st
+
+        describe "Where block" $ do
+          it "parses where construct statement" $
+            sParser "where (.true.)" `shouldBe'` StWhereConstruct () u Nothing valTrue
+
+          it "parses elsewhere statement" $
+            sParser "elsewhere" `shouldBe'` StElsewhere () u Nothing Nothing
+
+          it "parses elsewhere statement" $ do
+            let exp = ExpBinary () u GT (varGen "a") (varGen "b")
+            sParser "elsewhere (a > b)" `shouldBe'` StElsewhere () u Nothing (Just exp)
+
+          it "parses endwhere statement" $
+            sParser "endwhere" `shouldBe'` StEndWhere () u Nothing
+
+    describe "If" $ do
+      let stPrint = StPrint () u starVal (Just $ fromList () [ ExpValue () u (ValString "foo")])
+      it "parser if block" $
+        let ifBlockSrc = unlines [ "if (.false.) then", "print *, 'foo'", "end if"]
+        in bParser ifBlockSrc `shouldBe'` BlIf () u Nothing Nothing [Just valFalse] [[BlStatement () u Nothing stPrint]] Nothing
+
+      it "parses named if block" $ do
+        let ifBlockSrc = unlines [ "mylabel : if (.true.) then", "print *, 'foo'", "end if mylabel"]
+            ifBlock = BlIf () u Nothing (Just "mylabel") [Just valTrue] [[BlStatement () u Nothing stPrint]] Nothing
+        bParser ifBlockSrc `shouldBe'` ifBlock
+
+      it "parses if-else block with inline comments (stripped)" $
+        let ifBlockSrc = unlines [ "if (.false.) then ! comment if", "print *, 'foo'", "else ! comment else", "print *, 'foo'", "end if ! comment end"]
+        in bParser ifBlockSrc `shouldBe'` BlIf () u Nothing Nothing [Just valFalse, Nothing] [[BlStatement () u Nothing stPrint], [BlStatement () u Nothing stPrint]] Nothing
+
+      it "parses logical if statement" $ do
+        let assignment = StExpressionAssign () u (varGen "a") (varGen "b")
+            stIf = StIfLogical () u valTrue assignment
+        sParser "if (.true.) a = b" `shouldBe'` stIf
+
+      it "parses arithmetic if statement" $ do
+        let stIf = StIfArithmetic () u (varGen "x") (intGen 1)
+                                                    (intGen 2)
+                                                    (intGen 3)
+        sParser "if (x) 1, 2, 3" `shouldBe'` stIf
+
+    describe "Case" $ do
+      let printArgs str = Just $ AList () u [ExpValue () u $ ValString str]
+          printStmt = StPrint () u (ExpValue () u ValStar) . printArgs
+          printBlock = BlStatement () u Nothing . printStmt
+          ind2 = AList () u . pure $ IxSingle () u Nothing $ intGen 2
+          ind3Plus = AList () u . pure $ IxRange () u (Just $ intGen 3) Nothing Nothing
+          conds = [Just ind2, Just ind3Plus, Nothing]
+      it "unlabelled case block (with inline comments to be stripped)" $ do
+        let src = unlines [ "select case (x) ! comment select"
+                          , "! full line before first case (unrepresentable)"
+                          , "case (2) ! comment case 1"
+                          , "print *, 'foo'"
+                          , "case (3:) ! comment case 2"
+                          , "print *, 'bar'"
+                          , "case default ! comment case 3"
+                          , "print *, 'baz'"
+                          , "end select ! comment end"
+                          ]
+            blocks = (fmap . fmap) printBlock [["foo"], ["bar"], ["baz"]]
+            block = BlCase () u Nothing Nothing (varGen "x") conds blocks Nothing
+        bParser src `shouldBe'` block
+      it "labelled case block (with inline comments to be stripped" $ do
+        let src = unlines [ "10 mylabel: select case (x) ! comment select"
+                          , "20 case (2) ! comment case 1"
+                          , "30 print *, 'foo'"
+                          , "40 case (3:) ! comment case 2"
+                          , "50 print *, 'bar'"
+                          , "60 case default ! comment case 3"
+                          , "70 print *, 'baz'"
+                          , "80 end select mylabel ! comment end"
+                          ]
+            blocks = (fmap . fmap)
+                     (\(label, arg) -> BlStatement () u (Just $ intGen label) $ printStmt arg)
+                     [[(30, "foo")], [(50, "bar")], [(70, "baz")]]
+            block = BlCase () u
+                           (Just $ intGen 10) (Just "mylabel") (varGen "x")
+                           conds blocks
+                           (Just $ intGen 80)
+        bParser src `shouldBe'` block
+
+    describe "Do" $ do
+      it "parses do statement with label" $ do
+        let assign = StExpressionAssign () u (varGen "i") (intGen 0)
+            doSpec = DoSpecification () u assign (intGen 42) Nothing
+            st = StDo () u Nothing (Just $ intGen 24) (Just doSpec)
+        sParser "do 24, i = 0, 42" `shouldBe'` st
+
+      it "parses do statement without label" $ do
+        let assign = StExpressionAssign () u (varGen "i") (intGen 0)
+            doSpec = DoSpecification () u assign (intGen 42) Nothing
+            st = StDo () u Nothing Nothing (Just doSpec)
+        sParser "do i = 0, 42" `shouldBe'` st
+
+      it "parses infinite do" $ do
+        let st = StDo () u Nothing Nothing Nothing
+        sParser "do" `shouldBe'` st
+
+      it "parses end do statement" $ do
+        let st = StEnddo () u (Just "constructor")
+        sParser "end do constructor" `shouldBe'` st
+
+    describe "DO WHILE" $ do
+      it "parses unnamed do while statement" $ do
+        let st = StDoWhile () u Nothing Nothing valTrue
+        sParser "do while (.true.)" `shouldBe'` st
+
+      it "parses named do while statement" $ do
+        let st = StDoWhile () u (Just "name") Nothing valTrue
+        sParser "name: do while (.true.)" `shouldBe'` st
+
+      it "parses unnamed labelled do while statement" $ do
+        let st = StDoWhile () u Nothing (Just (intGen 999)) valTrue
+        sParser "do 999 while (.true.)" `shouldBe'` st
+
+    describe "Goto" $ do
+      it "parses vanilla goto" $ do
+        let st = StGotoUnconditional () u (intGen 999)
+        sParser "goto 999" `shouldBe'` st
+
+      it "parses computed goto" $ do
+        let list = fromList () [ intGen 10, intGen 20, intGen 30 ]
+            st = StGotoComputed () u list (intGen 20)
+        sParser "goto (10, 20, 30) 20" `shouldBe'` st
+
+      it "parses assigned goto" $ do
+        let list = fromList () [ intGen 10, intGen 20, intGen 30 ]
+            st = StGotoAssigned () u (varGen "i") (Just list)
+        sParser "goto i, (10, 20, 30)" `shouldBe'` st
+
+      it "parses label assignment" $ do
+        let st = StLabelAssign () u (intGen 20) (varGen "l")
+        sParser "assign 20 to l" `shouldBe'` st
+
+    describe "IO" $ do
+      it "parses vanilla print" $ do
+        let st = StPrint () u starVal (Just $ fromList () [ varGen "hex" ])
+        sParser "print *, hex" `shouldBe'` st
+
+      it "parses write with implied do" $ do
+        let cp1 = ControlPair () u Nothing (intGen 10)
+            cp2 = ControlPair () u (Just "format") (varGen "x")
+            ciList = fromList () [ cp1, cp2 ]
+            assign = StExpressionAssign () u (varGen "i") (intGen 1)
+            doSpec = DoSpecification () u assign (intGen 42) (Just $ intGen 2)
+            alist = fromList () [ varGen "i", varGen "j" ]
+            outList = fromList () [ ExpImpliedDo () u alist doSpec ]
+            st = StWrite () u ciList (Just outList)
+        sParser "write (10, FORMAT = x) (i, j,  i = 1, 42, 2)" `shouldBe'` st
+
+    it "parses use statement with renames" $ do
+      let renames = fromList ()
+            [ UseRename () u (varGen "sprod") (varGen "prod")
+            , UseRename () u (varGen "a") (varGen "b") ]
+          st = StUse () u (varGen "stats_lib") Nothing Permissive (Just renames)
+      sParser "use stats_lib, sprod => prod, a => b" `shouldBe'` st
+
+    it "parses use statement with only list" $ do
+      let onlys = fromList ()
+            [ UseID () u (varGen "a")
+            , UseRename () u (varGen "b") (varGen "c")
+            , UseID () u (ExpValue () u (ValOperator "+"))
+            , UseID () u (ExpValue () u ValAssignment) ]
+          st = StUse () u (varGen "stats_lib") Nothing Exclusive (Just onlys)
+      sParser "use stats_lib, only: a, b => c, operator(+), assignment(=)" `shouldBe'` st
+
+    specFreeCommon sParser eParser
diff --git a/test/Language/Fortran/Parser/Free/Fortran95Spec.hs b/test/Language/Fortran/Parser/Free/Fortran95Spec.hs
new file mode 100644
--- /dev/null
+++ b/test/Language/Fortran/Parser/Free/Fortran95Spec.hs
@@ -0,0 +1,655 @@
+module Language.Fortran.Parser.Free.Fortran95Spec ( spec ) where
+
+import Prelude hiding (GT, EQ, exp, pred)
+
+import Test.Hspec
+import TestUtil
+import Language.Fortran.Parser.Free.Common
+
+import Language.Fortran.AST
+import Language.Fortran.Version
+import Language.Fortran.Parser
+import Language.Fortran.Parser.Monad ( Parse )
+import qualified Language.Fortran.Parser.Free.Fortran95 as F95
+import qualified Language.Fortran.Parser.Free.Lexer     as Free
+
+import qualified Data.List as List
+import Data.Foldable(forM_)
+import qualified Data.ByteString.Char8 as B
+import Control.Exception (evaluate)
+
+parseWith :: Parse Free.AlexInput Free.Token a -> String -> a
+parseWith p = parseUnsafe (makeParserFree p Fortran95) . B.pack
+
+eParser :: String -> Expression ()
+eParser = parseUnsafe p . B.pack
+  where p = makeParser initParseStateFreeExpr F95.expressionParser Fortran95
+
+sParser :: String -> Statement ()
+sParser = parseWith F95.statementParser
+
+bParser :: String -> Block ()
+bParser = parseWith F95.blockParser
+
+fParser :: String -> ProgramUnit ()
+fParser = parseWith F95.functionParser
+
+{- Useful for parser debugging; Lexes the given source code.
+fTok :: String -> [Token]
+fTok sourceCode = collectFreeTokens Fortran95 $ B.pack sourceCode
+-}
+
+{-
+ - Given a list of values, find every combination of those values:
+ - combination [1,2] = [[], [1], [2], [1,2], [2,1]]
+ -}
+combination :: [a] -> [[a]]
+combination = foldr ((++) . List.permutations) [] . List.subsequences
+
+spec :: Spec
+spec =
+  describe "Fortran 95 Parser" $ do
+    describe "Function" $ do
+      let puFunction = PUFunction () u
+          fType = Nothing
+          fSuf = emptySuffixes
+          fPreSuf = emptyPrefixSuffix
+          fName = "f"
+          fArgs = Nothing
+          fRes = Nothing
+          fBody = []
+          fSub = Nothing
+
+      describe "End" $ do
+        it "parses simple functions ending with \"end function [function name]\"" $ do
+          let expected = puFunction fType fPreSuf fName fArgs fRes fBody fSub
+              fStr = init $ unlines ["function f()"
+                               , "end function f" ]
+          fParser fStr `shouldBe'` expected
+
+        it "parses simple functions ending with \"end\"" $ do
+          let expected = puFunction fType fPreSuf fName fArgs fRes fBody fSub
+              fStr = init $ unlines ["function f()"
+                               , "end" ]
+          fParser fStr `shouldBe'` expected
+
+        it "parses simple functions ending with \"end function\"" $ do
+          let expected = puFunction fType fPreSuf fName fArgs fRes fBody fSub
+              fStr = init $ unlines ["function f()"
+                               , "end function" ]
+          fParser fStr `shouldBe'` expected
+
+
+        it "parses functions with return type specs" $ do
+          let fType' = Just $ TypeSpec () u TypeInteger Nothing
+              expected = puFunction fType' fPreSuf fName fArgs fRes fBody fSub
+              fStr = init $ unlines ["integer function f()"
+                               , "end function f" ]
+          fParser fStr `shouldBe'` expected
+
+      describe "parses function options (recursive, pure, elemental)" $ do
+        let options_list = map unzip $ combination
+                                        [ ("recursive ", PfxRecursive () u)
+                                        , ("pure ", PfxPure () u)
+                                        , ("elemental ", PfxElemental () u) ]
+
+        forM_ options_list (\(strs, opts) -> do
+          let isElem (PfxElemental {}) = True; isElem _ = False
+              isRec  (PfxRecursive {}) = True; isRec _  = False
+              str = concat strs
+              fStr = str ++ init (unlines ["function f()", "end"])
+              pfx = fromList' () opts
+          --let expected = puFunction fType
+          if any isElem opts && any isRec opts
+            then
+              it ("Shouldn't parse: " ++ show fStr ++ ": " ++ show opts) $
+                evaluate (fParser fStr) `shouldThrow` anyIOException
+            else
+              it ("Should parse: " ++ show fStr ++ ": " ++ show opts) $ do
+                let expected' = puFunction fType (pfx, fSuf) fName fArgs fRes fBody fSub
+                fParser fStr `shouldBe'` expected'
+          )
+
+      it "parses functions with a list of arguments" $ do
+        let fArgs' = Just $ AList () u [ varGen "x", varGen "y", varGen "z" ]
+            expected = puFunction fType fPreSuf fName fArgs' fRes fBody fSub
+            fStr = init $ unlines ["function f(x, y, z)"
+                             , "end function f" ]
+        fParser fStr `shouldBe'` expected
+
+      it "parses functions with a result variable" $ do
+        let fRes' = Just $ varGen "i"
+            expected = puFunction fType fPreSuf fName fArgs fRes' fBody fSub
+            fStr = init $ unlines ["function f() result(i)"
+                             , "end function f" ]
+        fParser fStr `shouldBe'` expected
+
+      it "parses functions with function bodies" $ do
+        let decrementRHS = ExpBinary () u Subtraction (varGen "i") (intGen 1)
+            f1 = StPrint () u starVal (Just $ AList () u [ varGen "i" ])
+            f2 = StExpressionAssign () u (varGen "i") decrementRHS
+            fBody' = [ BlStatement () u Nothing f1 , BlStatement () u Nothing f2 ]
+            expected = puFunction fType fPreSuf fName fArgs fRes fBody' fSub
+            fStr = init $ unlines ["function f()"
+                             , "  print *, i"
+                             , "  i = (i - 1)"
+                             , "end function f" ]
+        fParser fStr `shouldBe'` expected
+
+      it "parses complex functions" $ do
+        let fType' = Just $ TypeSpec () u TypeInteger Nothing
+            fArgs' = Just $ AList () u [ varGen "x", varGen "y", varGen "z" ]
+            fRes' = Just $ varGen "i"
+            decrementRHS = ExpBinary () u Subtraction (varGen "i") (intGen 1)
+            f1 = StPrint () u starVal (Just $ AList () u [ varGen "i" ])
+            f2 = StExpressionAssign () u (varGen "i") decrementRHS
+            fBody' = [ BlStatement () u Nothing f1 , BlStatement () u Nothing f2 ]
+            expected = puFunction fType' fPreSuf fName fArgs' fRes' fBody' fSub
+            fStr = init $ unlines [ "integer function f(x, y, z) result(i)"
+                             , "  print *, i"
+                             , "  i = (i - 1)"
+                             , "end function f" ]
+        fParser fStr `shouldBe'` expected
+
+    describe "Expression" $ do
+      it "parses logical literal without kind parameter" $ do
+        eParser ".true." `shouldBe'` valTrue
+
+      it "parses logical literal with kind parameter" $ do
+        let kp = ExpValue () u (ValVariable "kind")
+        eParser ".false._kind" `shouldBe'` valFalse' kp
+
+      it "parses array initialisation exp" $ do
+        let list = AList () u [ intGen 1, intGen 2, intGen 3, intGen 4 ]
+        eParser "(/ 1, 2, 3, 4 /)" `shouldBe'` ExpInitialisation () u list
+
+      describe "Custom operator" $ do
+        let unOp = UnCustom ".inverse."
+            unExp = ExpUnary () u unOp $ intGen 42
+
+        it "parses unary custom operator" $
+          eParser ".inverse. 42" `shouldBe'` unExp
+
+        let binOp = BinCustom ".xor."
+        it "parses binary custom operator" $ do
+          let expected = ExpBinary () u binOp (intGen 24) (intGen 42)
+          eParser "24 .xor. 42" `shouldBe'` expected
+
+        it "parses mixed unary custom operator" $ do
+          let binExp = ExpBinary () u binOp unExp (intGen 24)
+          eParser ".inverse. 42 .xor. 24" `shouldBe'` binExp
+
+        it "parses data ref" $ do
+          let range = fromList () [ IxSingle () u Nothing $ intGen 10 ]
+              sub = ExpSubscript () u (varGen "y") range
+              innerRefExp = ExpDataRef () u (varGen "x") sub
+              exp = ExpDataRef () u innerRefExp (varGen "z")
+          eParser "x % y(10) % z" `shouldBe'` exp
+
+        it "parses section subscript" $ do
+          let range = [ IxSingle () u Nothing $ intGen 10
+                      , IxRange () u Nothing (Just $ intGen 1) (Just $ intGen 2)
+                      , IxSingle () u Nothing $ varGen "y" ]
+              exp = ExpSubscript () u (varGen "x") (fromList () range)
+          eParser "x (10, : 1 : 2, y)" `shouldBe'` exp
+
+    describe "Statement" $ do
+      it "data ref assignment" $ do
+        let indicies = AList () u [ IxSingle () u Nothing (intGen 1) ]
+            subs = ExpSubscript () u (varGen "x") indicies
+            lhs = ExpDataRef () u subs (varGen "y")
+            st = StExpressionAssign () u lhs (intGen 1)
+        sParser "x(1) % y = 1" `shouldBe'` st
+
+      it "doesn't parse assign statements" $ do
+        let stStr = "ASSIGN 1 \"LABEL\""
+        evaluate (sParser stStr) `shouldThrow` anyIOException
+
+      it "doesn't parse pause statements" $ do
+        let stStr = "PAUSE"
+        evaluate (sParser stStr) `shouldThrow` anyIOException
+
+      it "doesn't parse pause statements with expression" $ do
+        let stStr = "PAUSE \"MESSAGE\""
+        evaluate (sParser stStr) `shouldThrow` anyIOException
+
+      it "parses declaration with attributes" $ do
+        let typeSpec = TypeSpec () u TypeReal Nothing
+            attrs = AList () u [ AttrExternal () u
+                               , AttrIntent () u Out
+                               , AttrDimension () u $ AList () u
+                                  [ DimensionDeclarator () u
+                                      (Just $ intGen 3) (Just $ intGen 10)
+                                  ]
+                               ]
+            declarators = AList () u
+              [ declVariable () u (varGen "x") Nothing Nothing
+              , declVariable () u (varGen "y") Nothing Nothing ]
+            expected = StDeclaration () u typeSpec (Just attrs) declarators
+            stStr = "real, external, intent (out), dimension (3:10) :: x, y"
+        sParser stStr `shouldBe'` expected
+
+      it "parses declaration with old syntax" $ do
+        let typeSpec = TypeSpec () u TypeLogical Nothing
+            declarators = AList () u
+              [ declVariable () u (varGen "x") Nothing Nothing
+              , declVariable () u (varGen "y") Nothing Nothing ]
+            expected = StDeclaration () u typeSpec Nothing declarators
+            stStr = "logical x, y"
+        sParser stStr `shouldBe'` expected
+
+      it "parses declaration with initialisation" $ do
+        let typeSpec = TypeSpec () u TypeComplex Nothing
+            init' = ExpValue () u (ValComplex (intGen 24) (realGen (42.0::Double)))
+            declarators = AList () u
+              [ declVariable () u (varGen "x") Nothing (Just init') ]
+            expected = StDeclaration () u typeSpec Nothing declarators
+            stStr = "complex :: x = (24, 42.0)"
+        sParser stStr `shouldBe'` expected
+
+      it "parses declaration of custom type" $ do
+        let typeSpec = TypeSpec () u (TypeCustom "meinetype") Nothing
+            declarators = AList () u
+              [ declVariable () u (varGen "x") Nothing Nothing ]
+            expected = StDeclaration () u typeSpec Nothing declarators
+            stStr = "type (MeineType) :: x"
+        sParser stStr `shouldBe'` expected
+
+      it "parses declaration type with kind selector" $ do
+        let selector = Selector () u Nothing (Just $ varGen "hello")
+            typeSpec = TypeSpec () u TypeInteger (Just selector)
+            declarators = AList () u
+              [ declVariable () u (varGen "x") Nothing Nothing ]
+            expected = StDeclaration () u typeSpec Nothing declarators
+            stStr = "integer (hello) :: x"
+        sParser stStr `shouldBe'` expected
+
+      it "parses intent statement" $ do
+        let stStr = "intent (inout) :: a"
+            expected = StIntent () u InOut (fromList () [ varGen "a" ])
+        sParser stStr `shouldBe'` expected
+
+      it "parses optional statement" $ do
+        let stStr = "optional x"
+            expected = StOptional () u (fromList () [ varGen "x" ])
+        sParser stStr `shouldBe'` expected
+
+      it "parses public statement" $ do
+        let stStr = "public :: x"
+            expected = StPublic () u (Just $ fromList () [ varGen "x" ])
+        sParser stStr `shouldBe'` expected
+
+      it "parses public assignment" $ do
+        let expected = StPublic () u (Just $ fromList () [ assVal ])
+        sParser "public :: assignment (=)" `shouldBe'` expected
+
+      it "parses private statement" $
+        sParser "private" `shouldBe'` StPrivate () u Nothing
+
+      it "parses private operator" $ do
+        let expected = StPrivate () u (Just $ fromList () [ opGen "*" ])
+        sParser "private operator ( * )" `shouldBe'` expected
+
+      it "parses save statement" $ do
+        let list = [ varGen "hello", varGen "bye" ]
+            expected = StSave () u (Just $ fromList () list)
+            stStr = "save /hello/, bye"
+        sParser stStr `shouldBe'` expected
+
+      it "parses parameter statement" $ do
+        let ass1 = declVariable () u (varGen "x") Nothing (Just $ intGen 10)
+            ass2 = declVariable () u (varGen "y") Nothing (Just $ intGen 20)
+            expected = StParameter () u (fromList () [ ass1, ass2 ])
+        sParser "parameter (x = 10, y = 20)" `shouldBe'` expected
+
+      describe "FORALL blocks" $ do
+        let stride = Just $ ExpBinary () u NE (varGen "i") (intGen 2)
+            tripletSpecList = [("i", intGen 1, varGen "n", stride)]
+
+        it "parses basic FORALL blocks" $ do
+          let stStr = "FORALL (I=1:N, I /= 2)"
+              expected = StForall () u Nothing (ForallHeader tripletSpecList Nothing)
+          sParser stStr `shouldBe'` expected
+
+      describe "FORALL statements" $ do
+        let stride = Just $ ExpBinary () u NE (varGen "i") (intGen 2)
+            tripletSpecList = [("i", intGen 1, varGen "n", stride)]
+        --let varI = IxSingle () u Nothing (varGen "i")
+        --let expSub1 = ExpSubscript () u (varGen "a") (AList () u [varI, varI])
+        --let expSub2 = ExpSubscript () u (varGen "x") (AList () u [varI])
+        --let eAssign = StExpressionAssign () u expSub1 expSub2
+
+        it "parses basic FORALL statements" $ do
+          let stStr = "FORALL (I=1:N, I /= 2)" -- A(I,I) = X(I)"
+              expected = StForall () u Nothing (ForallHeader tripletSpecList Nothing)-- eAssign
+          sParser stStr `shouldBe'` expected
+
+      describe "ENDFORALL statements" $ do
+        it "parses FORALL end statements" $ do
+          let stStr = "ENDFORALL"
+              expected = StEndForall () u Nothing
+          sParser stStr `shouldBe'` expected
+
+        it "parses FORALL end statements with label" $ do
+          let stStr = "ENDFORALL A"
+              expected = StEndForall () u $ Just "a"
+          sParser stStr `shouldBe'` expected
+
+      describe "Implicit" $ do
+        it "parses implicit none" $ do
+          let st = StImplicit () u Nothing
+          sParser "implicit none" `shouldBe'` st
+
+        it "parses implicit with single" $ do
+          let typeSpec = TypeSpec () u TypeCharacter Nothing
+              impEls = [ ImpCharacter () u "k" ]
+              impLists = [ ImpList () u typeSpec (fromList () impEls) ]
+              st = StImplicit () u (Just $ fromList () impLists)
+          sParser "implicit character (k)" `shouldBe'` st
+
+        it "parses implicit with range" $ do
+          let typeSpec = TypeSpec () u TypeLogical Nothing
+              impEls = [ ImpRange () u "x" "z" ]
+              impLists = [ ImpList () u typeSpec (fromList () impEls) ]
+              st = StImplicit () u (Just $ fromList () impLists)
+          sParser "implicit logical (x-z)" `shouldBe'` st
+
+        it "parses implicit statement" $ do
+          let typeSpec1 = TypeSpec () u TypeCharacter Nothing
+              typeSpec2 = TypeSpec () u TypeInteger Nothing
+              impEls1 = [ ImpCharacter () u "s", ImpCharacter () u "a" ]
+              impEls2 = [ ImpRange () u "x" "z" ]
+              impLists = [ ImpList () u typeSpec1 (fromList () impEls1)
+                         , ImpList () u typeSpec2 (fromList () impEls2) ]
+              st = StImplicit () u (Just $ fromList () impLists)
+          sParser "implicit character (s, a), integer (x-z)" `shouldBe'` st
+
+      describe "Data" $ do
+        it "parses vanilla" $ do
+          let nlist = fromList () [ varGen "x", varGen "y" ]
+              vlist = fromList () [ intGen 1, intGen 2 ]
+              list = [ DataGroup () u nlist vlist ]
+              expected = StData () u (fromList () list)
+              stStr = "data x,y/1,2/"
+          sParser stStr `shouldBe'` expected
+
+        describe "Delimeter" $ do
+          let [ nlist1, vlist1 ] =
+                map (fromList () . return) [ varGen "x", intGen 1 ]
+              [ nlist2, vlist2 ] =
+                map (fromList () . return) [ varGen "y", intGen 2 ]
+              list = [ DataGroup () u nlist1 vlist1
+                     , DataGroup () u nlist2 vlist2 ]
+              expected = StData () u (fromList () list)
+
+          it "parses comma delimited init groups" $
+            sParser "data x/1/, y/2/" `shouldBe'` expected
+
+          it "parses non-comma delimited init groups" $
+            sParser "data x/1/ y/2/" `shouldBe'` expected
+
+      describe "Namelist" $ do
+        let groupNames = [ ExpValue () u (ValVariable "something")
+                         , ExpValue () u (ValVariable "other") ]
+            itemss = [ fromList () [ varGen "a", varGen "b", varGen "c" ]
+                     , fromList () [ varGen "y" ] ]
+            st = StNamelist () u $
+              fromList () [ Namelist () u (head groupNames) (head itemss)
+                          , Namelist () u (last groupNames) (last itemss) ]
+
+        it "parses namelist statement (comma delimited) (1)" $
+          sParser "namelist /something/a,b,c,/other/y" `shouldBe'` st
+
+        it "parses namelist statement (2)" $
+          sParser "namelist /something/a,b,c/other/y" `shouldBe'` st
+
+      describe "Common" $ do
+        let commonNames = [ ExpValue () u (ValVariable "something")
+                          , ExpValue () u (ValVariable "other") ]
+            itemss = [ fromList () [ declVarGen "a", declVarGen "b", declVarGen "c" ]
+                     , fromList () [ declVarGen "y" ] ]
+            st = StCommon () u $ fromList ()
+              [ CommonGroup () u Nothing (fromList () [ declVarGen "q" ])
+              , CommonGroup () u (Just $ head commonNames) (head itemss)
+              , CommonGroup () u (Just $ last commonNames) (last itemss) ]
+
+        it "parses common statement (comma delimited) (1)" $
+          sParser "common q /something/a,b,c, /other/y" `shouldBe'` st
+
+        it "parses common statement (2)" $
+          sParser "common q /something/a,b,c /other/y" `shouldBe'` st
+
+      it "parses equivalence statement" $ do
+        let eqALists = fromList ()
+              [ fromList ()
+                  [ let indicies = fromList () [ IxSingle () u Nothing (intGen 1) ]
+                    in ExpSubscript () u (varGen "a") indicies
+                  , varGen "x"
+                  ]
+              , fromList ()
+                  [ varGen "y"
+                  , varGen "z"
+                  , let indicies = fromList () [ IxRange () u (Just $ intGen 1)
+                                                              (Just $ intGen 42)
+                                                              Nothing ]
+                    in ExpSubscript () u (varGen "d") indicies
+                  ]
+              ]
+            st = StEquivalence () u eqALists
+        sParser "equivalence (a(1), x), (y, z, d(1:42))" `shouldBe'` st
+
+      describe "Dynamic allocation" $ do
+        it "parses allocate statement" $ do
+          let opt = AOStat () u (varGen "a")
+              allocs = fromList ()
+                [ varGen "x"
+                , ExpDataRef () u (varGen "st") (varGen "part")
+                ]
+              s = StAllocate () u Nothing allocs (Just (AList () u [opt]))
+          sParser "allocate (x, st % part, STAT = a)" `shouldBe'` s
+
+        it "parses deallocate statement" $ do
+          let allocs = fromList ()
+                [ let indicies = fromList () [ IxSingle () u Nothing (intGen 20) ]
+                  in ExpSubscript () u (varGen "smt") indicies
+                ]
+              s = StDeallocate () u allocs Nothing
+          sParser "deallocate (smt ( 20 ))" `shouldBe'` s
+
+        it "parses nullify statement" $ do
+          let s = StNullify () u (fromList () [ varGen "x" ])
+          sParser "nullify (x)" `shouldBe'` s
+
+      it "parses pointer assignment" $ do
+        let src = ExpDataRef () u (varGen "x") (varGen "y")
+            st = StPointerAssign () u src (varGen "exp")
+        sParser "x % y => exp" `shouldBe'` st
+
+      describe "Where" $ do
+        it "parses where statement" $ do
+          let exp = ExpBinary () u Subtraction (varGen "temp") (varGen "r_temp")
+              pred = ExpBinary () u GT (varGen "temp") (intGen 100)
+              assignment = StExpressionAssign () u (varGen "temp") exp
+              st = StWhere () u pred assignment
+          sParser "where (temp > 100) temp = temp - r_temp"`shouldBe'` st
+
+        describe "Where block" $ do
+          it "parses where construct statement" $
+            sParser "where (.true.)" `shouldBe'` StWhereConstruct () u Nothing valTrue
+
+          it "parses elsewhere statement" $
+            sParser "elsewhere" `shouldBe'` StElsewhere () u Nothing Nothing
+
+          it "parses elsewhere statement" $ do
+            let exp = ExpBinary () u GT (varGen "a") (varGen "b")
+            sParser "elsewhere (a > b)" `shouldBe'` StElsewhere () u Nothing (Just exp)
+
+          it "parses endwhere statement" $
+            sParser "endwhere" `shouldBe'` StEndWhere () u Nothing
+
+    describe "If" $ do
+      let stPrint = StPrint () u starVal (Just $ fromList () [ ExpValue () u (ValString "foo")])
+      it "parser if block" $
+        let ifBlockSrc = unlines [ "if (.false.) then", "print *, 'foo'", "end if"]
+        in bParser ifBlockSrc `shouldBe'` BlIf () u Nothing Nothing [Just valFalse] [[BlStatement () u Nothing stPrint]] Nothing
+
+      it "parses named if block" $ do
+        let ifBlockSrc = unlines [ "mylabel : if (.true.) then", "print *, 'foo'", "end if mylabel"]
+            ifBlock = BlIf () u Nothing (Just "mylabel") [Just valTrue] [[BlStatement () u Nothing stPrint]] Nothing
+        bParser ifBlockSrc `shouldBe'` ifBlock
+
+      it "parses if-else block with inline comments (stripped)" $
+        let ifBlockSrc = unlines [ "if (.false.) then ! comment if", "print *, 'foo'", "else ! comment else", "print *, 'foo'", "end if ! comment end"]
+        in bParser ifBlockSrc `shouldBe'` BlIf () u Nothing Nothing [Just valFalse, Nothing] [[BlStatement () u Nothing stPrint], [BlStatement () u Nothing stPrint]] Nothing
+
+      it "parses logical if statement" $ do
+        let assignment = StExpressionAssign () u (varGen "a") (varGen "b")
+            stIf = StIfLogical () u valTrue assignment
+        sParser "if (.true.) a = b" `shouldBe'` stIf
+
+      it "parses arithmetic if statement" $ do
+        let stIf = StIfArithmetic () u (varGen "x") (intGen 1)
+                                                    (intGen 2)
+                                                    (intGen 3)
+        sParser "if (x) 1, 2, 3" `shouldBe'` stIf
+
+    describe "Case" $ do
+      let printArgs str = Just $ AList () u [ExpValue () u $ ValString str]
+          printStmt = StPrint () u (ExpValue () u ValStar) . printArgs
+          printBlock = BlStatement () u Nothing . printStmt
+          ind2 = AList () u . pure $ IxSingle () u Nothing $ intGen 2
+          ind3Plus = AList () u . pure $ IxRange () u (Just $ intGen 3) Nothing Nothing
+          conds = [Just ind2, Just ind3Plus, Nothing]
+      it "unlabelled case block (with inline comments to be stripped)" $ do
+        let src = unlines [ "select case (x) ! comment select"
+                          , "! full line before first case (unrepresentable)"
+                          , "case (2) ! comment case 1"
+                          , "print *, 'foo'"
+                          , "case (3:) ! comment case 2"
+                          , "print *, 'bar'"
+                          , "case default ! comment case 3"
+                          , "print *, 'baz'"
+                          , "end select ! comment end"
+                          ]
+            blocks = (fmap . fmap) printBlock [["foo"], ["bar"], ["baz"]]
+            block = BlCase () u Nothing Nothing (varGen "x") conds blocks Nothing
+        bParser src `shouldBe'` block
+      it "labelled case block (with inline comments to be stripped" $ do
+        let src = unlines [ "10 mylabel: select case (x) ! comment select"
+                          , "20 case (2) ! comment case 1"
+                          , "30 print *, 'foo'"
+                          , "40 case (3:) ! comment case 2"
+                          , "50 print *, 'bar'"
+                          , "60 case default ! comment case 3"
+                          , "70 print *, 'baz'"
+                          , "80 end select mylabel ! comment end"
+                          ]
+            blocks = (fmap . fmap)
+                     (\(label, arg) -> BlStatement () u (Just $ intGen label) $ printStmt arg)
+                     [[(30, "foo")], [(50, "bar")], [(70, "baz")]]
+            block = BlCase () u
+                           (Just $ intGen 10) (Just "mylabel") (varGen "x")
+                           conds blocks
+                           (Just $ intGen 80)
+        bParser src `shouldBe'` block
+
+    describe "Do" $ do
+      it "parses do statement with label" $ do
+        let assign = StExpressionAssign () u (varGen "i") (intGen 0)
+            doSpec = DoSpecification () u assign (intGen 42) Nothing
+            st = StDo () u Nothing (Just $ intGen 24) (Just doSpec)
+        sParser "do 24, i = 0, 42" `shouldBe'` st
+
+      it "parses do statement without label" $ do
+        let assign = StExpressionAssign () u (varGen "i") (intGen 0)
+            doSpec = DoSpecification () u assign (intGen 42) Nothing
+            st = StDo () u Nothing Nothing (Just doSpec)
+        sParser "do i = 0, 42" `shouldBe'` st
+
+      it "parses infinite do" $ do
+        let st = StDo () u Nothing Nothing Nothing
+        sParser "do" `shouldBe'` st
+
+      it "parses end do statement" $ do
+        let st = StEnddo () u (Just "constructor")
+        sParser "end do constructor" `shouldBe'` st
+
+    describe "DO WHILE" $ do
+      it "parses unnamed do while statement" $ do
+        let st = StDoWhile () u Nothing Nothing valTrue
+        sParser "do while (.true.)" `shouldBe'` st
+
+      it "parses named do while statement" $ do
+        let st = StDoWhile () u (Just "name") Nothing valTrue
+        sParser "name: do while (.true.)" `shouldBe'` st
+
+      it "parses unnamed labelled do while statement" $ do
+        let st = StDoWhile () u Nothing (Just (intGen 999)) valTrue
+        sParser "do 999 while (.true.)" `shouldBe'` st
+
+    describe "Goto" $ do
+      it "parses vanilla goto" $ do
+        let st = StGotoUnconditional () u (intGen 999)
+        sParser "goto 999" `shouldBe'` st
+
+      it "parses computed goto" $ do
+        let list = fromList () [ intGen 10, intGen 20, intGen 30 ]
+            st = StGotoComputed () u list (intGen 20)
+        sParser "goto (10, 20, 30) 20" `shouldBe'` st
+
+      it "doesn't parse assigned goto" $
+        evaluate (sParser "goto i, (10, 20, 30)") `shouldThrow` anyIOException
+
+      it "doesn't parse label assignment" $
+        evaluate (sParser "assign 20 to l") `shouldThrow` anyIOException
+
+    describe "IO" $ do
+      it "parses vanilla print" $ do
+        let st = StPrint () u starVal (Just $ fromList () [ varGen "hex" ])
+        sParser "print *, hex" `shouldBe'` st
+
+      it "parses write with implied do" $ do
+        let cp1 = ControlPair () u Nothing (intGen 10)
+            cp2 = ControlPair () u (Just "format") (varGen "x")
+            ciList = fromList () [ cp1, cp2 ]
+            assign = StExpressionAssign () u (varGen "i") (intGen 1)
+            doSpec = DoSpecification () u assign (intGen 42) (Just $ intGen 2)
+            alist = fromList () [ varGen "i", varGen "j" ]
+            outList = fromList () [ ExpImpliedDo () u alist doSpec ]
+            st = StWrite () u ciList (Just outList)
+        sParser "write (10, FORMAT = x) (i, j,  i = 1, 42, 2)" `shouldBe'` st
+
+    it "parses use statement" $ do
+      let renames = fromList ()
+            [ UseRename () u (varGen "sprod") (varGen "prod")
+            , UseRename () u (varGen "a") (varGen "b") ]
+          st = StUse () u (varGen "stats_lib") Nothing Permissive (Just renames)
+      sParser "use stats_lib, sprod => prod, a => b" `shouldBe'` st
+
+    it "parses value decl" $ do
+      let decls = [declVarGen "a", declVarGen "b"]
+          st = StValue () u (AList () u decls)
+      sParser "value a, b" `shouldBe'` st
+      sParser "value :: a, b" `shouldBe'` st
+
+    it "parses value attribute" $ do
+      let decls = [declVarGen "a", declVarGen "b"]
+          ty = TypeSpec () u TypeInteger Nothing
+          attrs = [AttrValue () u]
+          st = StDeclaration () u ty (Just (AList () u attrs)) (AList () u decls)
+      sParser "integer, value :: a, b" `shouldBe'` st
+
+    it "parses volatile decl" $ do
+      let decls = [declVarGen "a", declVarGen "b"]
+          st = StVolatile () u (AList () u decls)
+      sParser "volatile a, b" `shouldBe'` st
+      sParser "volatile :: a, b" `shouldBe'` st
+
+    it "parses volatile attribute" $ do
+      let decls = [declVarGen "a", declVarGen "b"]
+          ty = TypeSpec () u TypeInteger Nothing
+          attrs = [AttrVolatile () u]
+          st = StDeclaration () u ty (Just (AList () u attrs)) (AList () u decls)
+      sParser "integer, volatile :: a, b" `shouldBe'` st
+
+    specFreeCommon sParser eParser
diff --git a/test/Language/Fortran/Parser/Free/LexerSpec.hs b/test/Language/Fortran/Parser/Free/LexerSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Language/Fortran/Parser/Free/LexerSpec.hs
@@ -0,0 +1,383 @@
+module Language.Fortran.Parser.Free.LexerSpec ( spec ) where
+
+import Test.Hspec
+import TestUtil
+
+import Language.Fortran.Parser.Free.Lexer ( Token(..), lexer' )
+import Language.Fortran.Parser ( collectTokens )
+import Language.Fortran.Parser ( initParseStateFree )
+import Language.Fortran.AST.RealLit
+import Language.Fortran.Version
+import Language.Fortran.Util.Position (SrcSpan)
+
+import qualified Data.ByteString.Char8 as B
+
+collectFreeTokens :: FortranVersion -> B.ByteString -> [Token]
+collectFreeTokens fv bs =
+    collectTokens lexer' $ initParseStateFree "<unknown>" fv bs
+
+collectF90 :: String -> [Token]
+collectF90 = collectFreeTokens Fortran90 . B.pack
+
+collectF03 :: String -> [Token]
+collectF03 = collectFreeTokens Fortran2003 . B.pack
+
+pseudoAssign :: (SrcSpan -> Token) -> [Token]
+pseudoAssign token = fmap ($u) [ flip TId "i", TOpAssign, token, TEOF ]
+
+spec :: Spec
+spec =
+  describe "Fortran Free Form Lexer" $
+    describe "Fortran 90" $ do
+      describe "Character sensitivity" $ do
+        it "lexes lower case tokens" $
+          shouldBe' (collectF90 "integer id") $
+                    fmap ($u) [ TInteger, flip TId "id", TEOF ]
+
+        it "lexes mixed case tokens" $
+          shouldBe' (collectF90 "InTEgeR ID") $
+                    fmap ($u) [ TInteger, flip TId "id", TEOF ]
+
+      describe "Identifier" $ do
+        it "lexes long ID names" $
+          shouldBe' (collectF90 "program long_id_name") $
+                    fmap ($u) [ TProgram, flip TId "long_id_name", TEOF ]
+
+        it "treats 'if' as ID if used in assignment" $
+          shouldBe' (collectF90 "if = 20") $
+                    fmap ($u) [ flip TId "if", TOpAssign
+                              , flip TIntegerLiteral "20", TEOF ]
+
+        it "'result' is an identifier in spec. context" $
+          shouldBe' (collectF90 "integer :: result") $
+                    fmap ($u) [ TInteger, TDoubleColon , flip TId "result"
+                              , TEOF ]
+
+      describe "Types" $ do
+        it "lexes length and kind selectors" $
+          shouldBe' (collectF90 "integer (KIND=1, LEN=1) :: kind, len") $
+                    fmap ($u) [ TInteger, TLeftPar, TKind, TOpAssign
+                              , flip TIntegerLiteral "1", TComma, TLen
+                              , TOpAssign, flip TIntegerLiteral "1", TRightPar
+                              , TDoubleColon , flip TId "kind", TComma
+                              , flip TId "len", TEOF ]
+
+
+        it "lexes simple type tokens" $
+          shouldBe' (collectF90 "character x") $
+                    fmap ($u) [ TCharacter, flip TId "x", TEOF ]
+
+        it "lexes simple type tokens in function" $
+          shouldBe' (collectF90 "character function x") $
+                    fmap ($u) [ TCharacter, TFunction, flip TId "x", TEOF ]
+
+        it "lexes character type with F77 length syntax (1)" $
+          shouldBe' (collectF90 "character * (*) function x") $
+                    fmap ($u) [ TCharacter, TStar, TLeftPar, TStar, TRightPar, TFunction, flip TId "x", TEOF ]
+
+        it "lexes character type with F77 length syntax (2)" $
+          shouldBe' (collectF90 "character * 20 function x") $
+                    fmap ($u) [ TCharacter, TStar, flip TIntegerLiteral "20", TFunction, flip TId "x", TEOF ]
+
+        it "lexes derived type tokens in function" $
+          shouldBe' (collectF90 "type (x) function x") $
+                    fmap ($u) [ TType, TLeftPar, flip TId "x", TRightPar
+                              , TFunction, flip TId "x", TEOF ]
+
+        it "lexes interleaved type recursive tokens" $
+          shouldBe' (collectF90 "integer (KIND=10*2) recursive function x") $
+                    fmap ($u) [ TInteger, TLeftPar, TKind, TOpAssign
+                              , flip TIntegerLiteral "10" , TStar
+                              , flip TIntegerLiteral "2", TRightPar, TRecursive
+                              , TFunction, flip TId "x", TEOF ]
+
+        it "lexes interleaved type recursive tokens (reversed)" $
+          shouldBe' (collectF90 "recursive integer (KIND=10*2) function x") $
+                    fmap ($u) [ TRecursive, TInteger, TLeftPar, TKind, TOpAssign
+                              , flip TIntegerLiteral "10" , TStar
+                              , flip TIntegerLiteral "2", TRightPar, TFunction
+                              , flip TId "x", TEOF ]
+
+      describe "Function" $ do
+        it "lexes 'function fx ( a, b, c )'" $
+          shouldBe' (collectF90 "function fx ( a, b )") $
+                    fmap ($u) [ TFunction, flip TId "fx", TLeftPar, flip TId "a"
+                              , TComma, flip TId "b", TRightPar, TEOF ]
+
+        it "lexes functions with specific result" $
+          shouldBe' (collectF90 "function fx (array) result (c_sum)") $
+                    fmap ($u) [ TFunction, flip TId "fx", TLeftPar
+                              , flip TId "array", TRightPar, TResult, TLeftPar
+                              , flip TId "c_sum", TRightPar, TEOF ]
+
+        it "lexes recursive functions" $
+          shouldBe' (collectF90 "recursive function fx (array)") $
+                    fmap ($u) [ TRecursive, TFunction, flip TId "fx", TLeftPar
+                              , flip TId "array", TRightPar, TEOF ]
+
+        it "lexes recursive functions with result specified" $
+          shouldBe' (collectF90 "RECURSIVE FUNCTION FX (ARRAY) RESULT (C_SUM)") $
+                    fmap ($u) [ TRecursive, TFunction, flip TId "fx", TLeftPar
+                              , flip TId "array", TRightPar, TResult, TLeftPar
+                              , flip TId "c_sum", TRightPar, TEOF ]
+
+      describe "Attribute" $ do
+        it "lexes PARAMETER attribute" $
+          shouldBe' (collectF90 "integer, parameter :: x") $
+                    fmap ($u) [ TInteger, TComma, TParameter, TDoubleColon
+                              , flip TId "x", TEOF ]
+
+        it "lexes INTENT attribute" $
+          shouldBe' (collectF90 "integer, intent (inout) :: x") $
+                    fmap ($u) [ TInteger, TComma, TIntent, TLeftPar, TInOut
+                              , TRightPar, TDoubleColon , flip TId "x", TEOF ]
+
+        it "lexes DIMENSION attribute" $
+          shouldBe' (collectF90 "double precision, dimension (3:10) :: x") $
+                    fmap ($u) [ TDoublePrecision, TComma, TDimension, TLeftPar
+                              , flip TIntegerLiteral "3", TColon
+                              , flip TIntegerLiteral "10" , TRightPar
+                              , TDoubleColon , flip TId "x", TEOF ]
+
+        it "lexes variable declaration with multiple attributes" $
+          shouldBe' (collectF90 "double precision, save, dimension(2), allocatable :: y") $
+                    fmap ($u) [ TDoublePrecision, TComma, TSave, TComma
+                              , TDimension, TLeftPar, flip TIntegerLiteral "2"
+                              , TRightPar, TComma, TAllocatable, TDoubleColon
+                              , flip TId "y", TEOF ]
+
+        it "try to trick lexer into parsing variables as attributes (1)" $
+          shouldBe' (collectF90 "integer save, dimension(10), target") $
+                    fmap ($u) [ TInteger, flip TId "save", TComma
+                              , flip TId "dimension", TLeftPar, flip TIntegerLiteral "10", TRightPar, TComma
+                              , flip TId "target", TEOF ]
+
+        it "try to trick lexer into parsing variables as attributes (2)" $
+          shouldBe' (collectF90 "type(foo) save, dimension(10), target") $
+                    fmap ($u) [ TType, TLeftPar, flip TId "foo", TRightPar, flip TId "save", TComma
+                              , flip TId "dimension", TLeftPar, flip TIntegerLiteral "10", TRightPar, TComma
+                              , flip TId "target", TEOF ]
+
+        it "try to trick lexer into parsing variables as attributes (3)" $
+          shouldBe' (collectF90 "allocate(type(foo) :: errmsg(stat, source), source=x)") $
+                    fmap ($u) [ TAllocate, TLeftPar, TType, TLeftPar, flip TId "foo", TRightPar, TDoubleColon
+                              , flip TId "errmsg", TLeftPar, flip TId "stat", TComma, flip TId "source", TRightPar
+                              , TComma, TSource, TOpAssign, flip TId "x", TRightPar, TEOF ]
+
+      describe "Character" $ do
+        it "lexes single quote literal" $
+          shouldBe' (collectF90 "character c = 'heL\"Lo ''daRLing'") $
+                    fmap ($u) [ TCharacter, flip TId "c", TOpAssign
+                              , flip TString "heL\"Lo 'daRLing", TEOF ]
+
+        it "lexes double quote literal" $
+          shouldBe' (collectF90 "character c = \"heL'Lo \"\"daRLing\"") $
+                    fmap ($u) [ TCharacter, flip TId "c", TOpAssign
+                              , flip TString "heL'Lo \"daRLing", TEOF ]
+
+      describe "Module" $ do
+        it "lexes module statement" $
+          shouldBe' (collectF90 "module Hello_mod") $
+                    fmap ($u) [ TModule, flip TId "hello_mod", TEOF ]
+
+        it "lexes use statement" $
+          shouldBe' (collectF90 "use Hello_mod, hello => hi") $
+                    fmap ($u) [ TUse, flip TId "hello_mod", TComma
+                              , flip TId "hello", TArrow, flip TId "hi", TEOF ]
+
+        it "lexes use statement with only" $
+          shouldBe' (collectF90 "use Hello_mod, only: a, b => c") $
+                    fmap ($u) [ TUse, flip TId "hello_mod", TComma, TOnly
+                              , TColon, flip TId "a", TComma, flip TId "b"
+                              , TArrow, flip TId "c", TEOF ]
+
+      describe "Label" $
+        it "lexes simple label" $
+          shouldBe' (collectF90 "010 print *, 'hello'") $
+                    fmap ($u) [ flip TIntegerLiteral "010", TPrint, TStar, TComma
+                              , flip TString "hello", TEOF ]
+
+      describe "Conditional" $ do
+        it "lexes logical if with array assignment" $
+          shouldBe' (collectF90 "if (.true.) a(1) = 42") $
+                    fmap ($u) [ TIf, TLeftPar, flip TLogicalLiteral True
+                              , TRightPar, flip TId "a", TLeftPar
+                              , flip TIntegerLiteral "1", TRightPar, TOpAssign
+                              , flip TIntegerLiteral "42", TEOF ]
+
+        it "lexes block if statement" $
+          shouldBe' (collectF90 "if (a > b) then") $
+                    fmap ($u) [ TIf, TLeftPar, flip TId "a", TOpGT, flip TId "b"
+                              , TRightPar, TThen, TEOF ]
+
+        it "lexes arithmetic if statement" $
+          shouldBe' (collectF90 "if (a) 10, 11, 12") $
+                    fmap ($u) [ TIf, TLeftPar, flip TId "a", TRightPar
+                              , flip TIntegerLiteral "10", TComma
+                              , flip TIntegerLiteral "11", TComma
+                              , flip TIntegerLiteral "12" , TEOF ]
+
+        it "lexes logical if statement" $
+          shouldBe' (collectF90 "if (a > b) print *, 'hello'") $
+                    fmap ($u) [ TIf, TLeftPar, flip TId "a", TOpGT, flip TId "b"
+                              , TRightPar, TPrint, TStar, TComma
+                              , flip TString "hello", TEOF ]
+
+      describe "Lexes numeric values" $ do
+        it "lexes integer" $
+          shouldBe' (collectF90 "i = 42") $
+                    pseudoAssign $ flip TIntegerLiteral "42"
+
+        describe "Real" $ do
+          it "lexes real (1)" $ do
+            let litStr      = "10.5e2"
+                expectedLit = RealLit "10.5" (Exponent ExpLetterE "2")
+                expected    = pseudoAssign $ flip TRealLiteral expectedLit
+            collectF90 ("i = "<>litStr) `shouldBe'` expected
+
+          it "lexes real (2)" $ do
+            let litStr      = "10."
+                expectedLit = RealLit "10.0" (Exponent ExpLetterE "0")
+                expected    = pseudoAssign $ flip TRealLiteral expectedLit
+            collectF90 ("i = "<>litStr) `shouldBe'` expected
+
+          it "lexes real (3)" $ do
+            let litStr      = ".42"
+                expectedLit = RealLit "0.42" (Exponent ExpLetterE "0")
+                expected    = pseudoAssign $ flip TRealLiteral expectedLit
+            collectF90 ("i = "<>litStr) `shouldBe'` expected
+
+          it "lexes real (4)" $ do
+            let litStr      = "42d-3"
+                expectedLit = RealLit "42.0" (Exponent ExpLetterD "-3")
+                expected    = pseudoAssign $ flip TRealLiteral expectedLit
+            collectF90 ("i = "<>litStr) `shouldBe'` expected
+
+          it "resolves disambiguity when xxx. follows relational operator" $
+            shouldBe' (collectF90 "if (10.EQ. 20)") $
+                      fmap ($u) [ TIf, TLeftPar, flip TIntegerLiteral "10"
+                                , TOpEQ, flip TIntegerLiteral "20"
+                                , TRightPar, TEOF ]
+
+      describe "Continuation" $ do
+        it "Single continuation char without space" $
+          shouldBe' (collectF90 "i = &\n42") $
+                    pseudoAssign $ flip TIntegerLiteral "42"
+
+        it "Single continuation char with space" $
+          shouldBe' (collectF90 "i = &   \n \t   42") $
+                    pseudoAssign $ flip TIntegerLiteral "42"
+
+        it "Double continuation (1)" $
+          shouldBe' (collectF90 "i = &\n  & 42") $
+                    pseudoAssign $ flip TIntegerLiteral "42"
+
+        it "Double continuation (2)" $
+          shouldBe' (collectF90 "i = 4&\n  &2") $
+                    pseudoAssign $ flip TIntegerLiteral "42"
+
+        it "Continuation with comment" $
+          shouldBe' (collectF90 "i = 4&\n  ! hello\n  &2") $
+                    pseudoAssign $ flip TIntegerLiteral "42"
+
+        it "Continuation with inline comment" $
+          shouldBe' (collectF90 "i = &  ! hi \n  42") $
+                    pseudoAssign $ flip TIntegerLiteral "42"
+
+      describe "Comment" $ do
+        it "Full line comment" $
+          shouldBe' (collectF90 "! = & ! hi \n") $
+                    ($u) <$> [ flip TComment " = & ! hi ", TNewline , TEOF ]
+
+        it "Inline comment" $
+          shouldBe' (collectF90 "i = 10 ! = & ! hi \n") $
+                    ($u) <$> [ flip TId "i", TOpAssign
+                             , flip TIntegerLiteral "10"
+                             , flip TComment " = & ! hi ", TNewline , TEOF ]
+        it "Empty comment" $
+          shouldBe' (collectF90 "!\n") $
+                    ($u) <$> [ flip TComment "", TNewline , TEOF ]
+
+      describe "Subscripting" $ do
+        it "Strings nested in arrays" $
+          shouldBe' (collectF90 "a(1)(2:3) = 'we'") $
+                    ($u) <$> [ flip TId "a", TLeftPar, flip TIntegerLiteral "1", TRightPar
+                             , TLeftPar, flip TIntegerLiteral "2", TColon, flip TIntegerLiteral "3", TRightPar
+                             , TOpAssign, flip TString "we", TEOF ]
+
+      describe "Fortran95" $ do
+        it "lexes value attribute" $ do
+          shouldBe' (collectF03 "value :: a, b") $
+                    fmap ($u) [ TValue, TDoubleColon, flip TId "a", TComma, flip TId "b", TEOF ]
+          shouldBe' (collectF03 "integer, value :: a, b") $
+                    fmap ($u) [ TInteger, TComma, TValue, TDoubleColon, flip TId "a", TComma, flip TId "b", TEOF ]
+
+        it "lexes volatile attribute" $ do
+          shouldBe' (collectF03 "volatile :: a, b") $
+                    fmap ($u) [ TVolatile, TDoubleColon, flip TId "a", TComma, flip TId "b", TEOF ]
+          shouldBe' (collectF03 "integer, volatile :: a, b") $
+                    fmap ($u) [ TInteger, TComma, TVolatile, TDoubleColon, flip TId "a", TComma, flip TId "b", TEOF ]
+
+      describe "Fortran2003" $ do
+        it "lexes procedures" $
+          shouldBe' (collectF03 "PROCEDURE(a), SAVE :: b => c()") $
+            ($u) <$> [ TProcedure, TLeftPar, flip TId "a", TRightPar
+                     , TComma, TSave, TDoubleColon
+                     , flip TId "b", TArrow, flip TId "c", TLeftPar, TRightPar, TEOF ]
+
+        it "lexes procedures with bind" $
+          shouldBe' (collectF03 "PROCEDURE(a), BIND(C, NAME=\"d\") :: b => c()") $
+            ($u) <$> [ TProcedure, TLeftPar, flip TId "a", TRightPar
+                     , TComma, TBind, TLeftPar, TC, TComma, TName, TOpAssign, flip TString "d", TRightPar, TDoubleColon
+                     , flip TId "b", TArrow, flip TId "c", TLeftPar, TRightPar, TEOF ]
+
+        it "lexes functions with bind" $
+          shouldBe' (collectF03 "FUNCTION f(a) RESULT(x) BIND(C, NAME=\"d\")") $
+            ($u) <$> [ TFunction, flip TId "f", TLeftPar, flip TId "a", TRightPar
+                     , TResult, TLeftPar, flip TId "x", TRightPar
+                     , TBind, TLeftPar, TC, TComma, TName, TOpAssign, flip TString "d", TRightPar, TEOF ]
+
+        it "lexes subroutines with bind" $
+          shouldBe' (collectF03 "SUBROUTINE s(a) BIND(C, NAME=\"d\")") $
+            ($u) <$> [ TSubroutine, flip TId "s", TLeftPar, flip TId "a", TRightPar
+                     , TBind, TLeftPar, TC, TComma, TName, TOpAssign, flip TString "d", TRightPar, TEOF ]
+
+        it "lexes class decl (name)" $
+          shouldBe' (collectF03 "procedure (class(c))") $
+                    fmap ($u) [ TProcedure, TLeftPar
+                              , TClass, TLeftPar, flip TId "c", TRightPar, TRightPar, TEOF ]
+
+        it "lexes class decl (*)" $
+          shouldBe' (collectF03 "procedure (class(*))") $
+                    fmap ($u) [ TProcedure, TLeftPar
+                              , TClass, TLeftPar, TStar, TRightPar, TRightPar, TEOF ]
+
+        it "lexes import statements" $
+          shouldBe' (collectF03 "import :: a, b") $
+                    fmap ($u) [ TImport, TDoubleColon, flip TId "a", TComma, flip TId "b", TEOF ]
+
+        it "lexes asynchronous attribute" $ do
+          shouldBe' (collectF03 "asynchronous :: a, b") $
+                    fmap ($u) [ TAsynchronous, TDoubleColon, flip TId "a", TComma, flip TId "b", TEOF ]
+          shouldBe' (collectF03 "integer, asynchronous :: a, b") $
+                    fmap ($u) [ TInteger, TComma, TAsynchronous, TDoubleColon, flip TId "a", TComma, flip TId "b", TEOF ]
+
+        it "lexes enums" $ do
+          shouldBe' (collectF03 "enum, bind(c)") $ fmap ($u) [ TEnum, TComma, TBind, TLeftPar, TC, TRightPar, TEOF ]
+          shouldBe' (collectF03 "enumerator :: a = 1, b") $
+                    fmap ($u) [ TEnumerator, TDoubleColon, flip TId "a", TOpAssign, flip TIntegerLiteral "1"
+                              , TComma, flip TId "b", TEOF ]
+          shouldBe' (collectF03 "end enum") $ fmap ($u) [ TEndEnum, TEOF ]
+
+        it "lexes flush" $ do
+          shouldBe' (collectF03 "flush(unit=1)") $
+            fmap ($u) [ TFlush, TLeftPar, TUnit, TOpAssign, flip TIntegerLiteral "1", TRightPar, TEOF ]
+          shouldBe' (collectF03 "flush(unit=1,iomsg=x,iostat=y,err=z)") $
+            fmap ($u) [ TFlush, TLeftPar, TUnit, TOpAssign, flip TIntegerLiteral "1", TComma
+                      , TIOMsg, TOpAssign, flip TId "x", TComma
+                      , TIOStat, TOpAssign, flip TId "y", TComma
+                      , TErr, TOpAssign, flip TId "z", TRightPar, TEOF ]
+
+        it "lexes protected" $ do
+          shouldBe' (collectF03 "real, protected, public :: x") $
+            fmap ($u) [ TReal, TComma, TProtected, TComma, TPublic, TDoubleColon, flip TId "x", TEOF ]
diff --git a/test/Language/Fortran/Parser/FreeFormCommon.hs b/test/Language/Fortran/Parser/FreeFormCommon.hs
deleted file mode 100644
--- a/test/Language/Fortran/Parser/FreeFormCommon.hs
+++ /dev/null
@@ -1,68 +0,0 @@
--- | Fortran standards F90 and beyond are a lot more consistent than the
---   previous 2. As such, there is lots of shared parsing, and lots of shared
---   tests. This module encodes such shared/common tests, where no difference
---   in behaviour between parsers is be expected.
-
-module Language.Fortran.Parser.FreeFormCommon ( specFreeFormCommon ) where
-
-import           TestUtil
-import           Test.Hspec
-
-import           Language.Fortran.AST
-import           Language.Fortran.AST.RealLit
-
-specFreeFormCommon :: (String -> Statement A0) -> (String -> Expression A0) -> Spec
-specFreeFormCommon sParser eParser =
-  describe "Common Fortran 90+ tests" $ do
-    describe "Literals" $ do
-      describe "Logical" $ do
-        it "parses logical literal without kind parameter" $ do
-          eParser ".true." `shouldBe'` valTrue
-
-        it "parses logical literal with kind parameter" $ do
-          let kp = ExpValue () u (ValVariable "kind")
-          eParser ".false._kind" `shouldBe'` valFalse' kp
-
-        it "parses mixed-case logical literal" $ do
-          eParser ".tRUe." `shouldBe'` valTrue
-
-      -- Main parse testing is performed in @Language.Fortran.AST.RealLitSpec@.
-      -- Here we mainly want to test kind parameter and sign behaviour.
-      describe "Real" $ do
-        let realLitExp r mkp = ExpValue () u (ValReal (parseRealLit r) mkp)
-        it "parses various REAL literals" $ do
-          eParser "1."      `shouldBe'` realLitExp "1."    Nothing
-          eParser ".1e20_8" `shouldBe'` realLitExp ".1e20" (Just (intGen 8))
-
-        it "parses \"negative\" real literal (unary op)" $ do
-          eParser "-1.0d-1_k8" `shouldBe'` ExpUnary () u Minus (realLitExp "1.0d-1" (Just (varGen "k8")))
-
-    describe "Statement" $ do
-      describe "Declaration" $ do
-        it "parses scalar declaration with nonstandard kind param (non-CHAR)" $ do
-          let stStr    = "integer x*8"
-              expected = StDeclaration () u typeSpec Nothing decls
-              typeSpec = TypeSpec () u TypeInteger Nothing
-              decls    = AList () u
-                [ declVariable () u (varGen "x") (Just (intGen 8)) Nothing ]
-          sParser stStr `shouldBe'` expected
-
-        it "parses array declaration with nonstandard kind param (non-CHAR)" $ do
-          let stStr    = "integer x(2)*8"
-              expected = StDeclaration () u typeSpec Nothing decls
-              typeSpec = TypeSpec () u TypeInteger Nothing
-              decls    = AList () u
-                [ declArray () u (varGen "x") dims (Just (intGen 8)) Nothing ]
-              dims     = AList () u
-                [ DimensionDeclarator () u Nothing (Just (intGen 2)) ]
-          sParser stStr `shouldBe'` expected
-
-        it "parses array declaration with nonstandard kind param (non-CHAR) and nonstandard dimension/charlen order" $ do
-          let stStr    = "integer x*8(2)"
-              expected = StDeclaration () u typeSpec Nothing decls
-              typeSpec = TypeSpec () u TypeInteger Nothing
-              decls    = AList () u
-                [ declArray () u (varGen "x") dims (Just (intGen 8)) Nothing ]
-              dims     = AList () u
-                [ DimensionDeclarator () u Nothing (Just (intGen 2)) ]
-          sParser stStr `shouldBe'` expected
diff --git a/test/Language/Fortran/Parser/MonadSpec.hs b/test/Language/Fortran/Parser/MonadSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Language/Fortran/Parser/MonadSpec.hs
@@ -0,0 +1,91 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Language.Fortran.Parser.MonadSpec where
+
+import Test.Hspec
+
+import Language.Fortran.Parser.Monad
+import Language.Fortran.Version
+import Language.Fortran.Util.Position
+
+vanillaParseState :: ParseState String
+vanillaParseState = ParseState
+  { psAlexInput = ""
+  , psVersion = Fortran66
+  , psFilename = "<unknown>"
+  , psParanthesesCount = ParanthesesCount 0 False
+  , psContext = [ ConStart ]
+  }
+
+instance Loc String where
+  getPos = error "Never needed"
+
+instance LastToken String String where
+  getLastToken  = error "Never needed"
+
+data SomeInput = SomeInput { p :: Position }
+
+initPos :: Position
+initPos = Position 5 1 2 "" Nothing
+
+initSomeInput :: SomeInput
+initSomeInput = SomeInput { p = initPos }
+
+instance Loc SomeInput where
+  getPos = p
+
+instance LastToken SomeInput String where
+  getLastToken  = error "Never needed"
+
+vanillaSomeInput :: ParseState SomeInput
+vanillaSomeInput = ParseState
+  { psAlexInput = initSomeInput
+  , psVersion = Fortran66
+  , psFilename = "some.f"
+  , psParanthesesCount = ParanthesesCount 0 False
+  , psContext = [ ConStart ]
+  }
+
+spec :: Spec
+spec =
+  describe "ParserMonad" $ do
+    describe "Parse" $ do
+      it "should give out correct version" $
+        evalParse getVersion vanillaParseState `shouldBe` Fortran66
+
+      it "satisfies read after write equals to what is written" $
+        let ai = evalParse (putAlex "l'enfer" >> getAlex) vanillaParseState in
+          ai `shouldBe` "l'enfer"
+
+      describe "Obtaining locations" $ do
+        it "getPosition returns correct location" $
+          let _expPosition = Position 6 2 3 "some.f" Nothing
+              _exampleM = do
+                _ai <- getAlex
+                putAlex $ _ai { p = _expPosition }
+                getPosition
+              _loc = evalParse _exampleM vanillaSomeInput in
+            _loc `shouldBe` _expPosition
+
+        it "getSrcSpan return correct location span" $
+          let _loc2 = Position 6 2 3 "some.f" Nothing
+              _exampleM = do
+                _ai <- getAlex
+                _loc1 <- getPosition
+                putAlex $ _ai { p = _loc2 }
+                getSrcSpan _loc1
+              _span = evalParse _exampleM vanillaSomeInput
+              _expectation = SrcSpan initPos _loc2 in
+            _span `shouldBe` _expectation
+
+    describe "Lex" $ do
+      it "reads the state correctly" $
+        evalParse getAlex vanillaParseState `shouldBe` ""
+
+      it "overrides the state correctly" $
+        let ai = evalParse (putAlex "c'est" >> getAlex) vanillaParseState in
+            ai `shouldBe` "c'est"
+
+      it "mixes operations correctly" $
+       let ai = evalParse (putAlex "hello" >> getAlex >>= \s -> putAlex (take 4 s) >> getAlex) vanillaParseState in
+             ai `shouldBe` "hell"
diff --git a/test/Language/Fortran/Parser/UtilsSpec.hs b/test/Language/Fortran/Parser/UtilsSpec.hs
deleted file mode 100644
--- a/test/Language/Fortran/Parser/UtilsSpec.hs
+++ /dev/null
@@ -1,29 +0,0 @@
-module Language.Fortran.Parser.UtilsSpec where
-
-import Test.Hspec
-
-import Language.Fortran.Parser.Utils
-
-spec :: Spec
-spec =
-  describe "Fortran Parser Utils" $ do
-
-    describe "readReal" $ do
-      it "tests" $ do
-        readReal "+12"       `shouldBe` Just 12
-        readReal "-1.2"      `shouldBe` Just (-1.2)
-        readReal "1.2d3"     `shouldBe` Just 1200
-        readReal "1.e2"      `shouldBe` Just 100
-        readReal "1.e-2"     `shouldBe` Just 0.01
-        readReal ".12"       `shouldBe` Just 0.12
-        readReal "-.12"      `shouldBe` Just (-0.12)
-        readReal "1_f"       `shouldBe` Just 1
-
-    describe "readInteger" $ do
-      it "tests" $ do
-        readInteger "b'101'" `shouldBe` Just 5
-        readInteger "o'22'"  `shouldBe` Just 18
-        readInteger "z'AF'"  `shouldBe` Just 175
-        readInteger "1_f"    `shouldBe` Just 1
-        readInteger "+123"   `shouldBe` Just 123
-        readInteger "-123"   `shouldBe` Just (-123)
diff --git a/test/Language/Fortran/ParserMonadSpec.hs b/test/Language/Fortran/ParserMonadSpec.hs
deleted file mode 100644
--- a/test/Language/Fortran/ParserMonadSpec.hs
+++ /dev/null
@@ -1,92 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
-
-module Language.Fortran.ParserMonadSpec where
-
-import Test.Hspec
-
-import Language.Fortran.ParserMonad
-import Language.Fortran.Util.Position
-
-vanillaParseState :: ParseState String
-vanillaParseState = ParseState
-  { psAlexInput = ""
-  , psVersion = Fortran66
-  , psFilename = "<unknown>"
-  , psParanthesesCount = ParanthesesCount 0 False
-  , psContext = [ ConStart ]
-  }
-
-instance Loc String where
-  getPos = error "Never needed"
-
-instance LastToken String String where
-  getLastToken  = error "Never needed"
-
-data SomeInput = SomeInput { p :: Position }
-
-initPos :: Position
-initPos = Position 5 1 2 "" Nothing
-
-initSomeInput :: SomeInput
-initSomeInput = SomeInput { p = initPos }
-
-instance Loc SomeInput where
-  getPos = p
-
-instance LastToken SomeInput String where
-  getLastToken  = error "Never needed"
-
-vanillaSomeInput :: ParseState SomeInput
-vanillaSomeInput = ParseState
-  { psAlexInput = initSomeInput
-  , psVersion = Fortran66
-  , psFilename = "some.f"
-  , psParanthesesCount = ParanthesesCount 0 False
-  , psContext = [ ConStart ]
-  }
-
-spec :: Spec
-spec =
-  describe "ParserMonad" $ do
-    describe "Parse" $ do
-      it "should give out correct version" $
-        evalParse getVersion vanillaParseState `shouldBe` Fortran66
-
-      it "satisfies read after write equals to what is written" $
-        let ai = evalParse (putAlex "l'enfer" >> getAlex) vanillaParseState in
-          ai `shouldBe` "l'enfer"
-
-      describe "Obtaining locations" $ do
-        it "getPosition returns correct location" $
-          let _expPosition = Position 6 2 3 "some.f" Nothing
-              _exampleM = do
-                _ai <- getAlex
-                putAlex $ _ai { p = _expPosition }
-                getPosition
-              _loc = evalParse _exampleM vanillaSomeInput in
-            _loc `shouldBe` _expPosition
-
-        it "getSrcSpan return correct location span" $
-          let _loc2 = Position 6 2 3 "some.f" Nothing
-              _exampleM = do
-                _ai <- getAlex
-                _loc1 <- getPosition
-                putAlex $ _ai { p = _loc2 }
-                getSrcSpan _loc1
-              _span = evalParse _exampleM vanillaSomeInput
-              _expectation = SrcSpan initPos _loc2 in
-            _span `shouldBe` _expectation
-
-    describe "Lex" $ do
-      it "reads the state correctly" $
-        evalParse getAlex vanillaParseState `shouldBe` ""
-
-      it "overrides the state correctly" $
-        let ai = evalParse (putAlex "c'est" >> getAlex) vanillaParseState in
-            ai `shouldBe` "c'est"
-
-      it "mixes operations correctly" $
-       let ai = evalParse (putAlex "hello" >> getAlex >>= \s -> putAlex (take 4 s) >> getAlex) vanillaParseState in
-             ai `shouldBe` "hell"
diff --git a/test/Language/Fortran/PrettyPrintSpec.hs b/test/Language/Fortran/PrettyPrintSpec.hs
--- a/test/Language/Fortran/PrettyPrintSpec.hs
+++ b/test/Language/Fortran/PrettyPrintSpec.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Language.Fortran.PrettyPrintSpec where
@@ -12,7 +11,7 @@
 
 import Language.Fortran.AST as LFA
 import Language.Fortran.AST.Boz
-import Language.Fortran.ParserMonad
+import Language.Fortran.Version
 import Language.Fortran.PrettyPrint
 
 import Text.PrettyPrint hiding ((<>))
diff --git a/test/Language/Fortran/Transformation/Disambiguation/FunctionSpec.hs b/test/Language/Fortran/Transformation/Disambiguation/FunctionSpec.hs
--- a/test/Language/Fortran/Transformation/Disambiguation/FunctionSpec.hs
+++ b/test/Language/Fortran/Transformation/Disambiguation/FunctionSpec.hs
@@ -4,41 +4,48 @@
 import TestUtil
 
 import Language.Fortran.AST
-import Language.Fortran.Transformer
+import Language.Fortran.Transformation.Monad
+import Language.Fortran.Transformation.Disambiguation.Function
+import Language.Fortran.Transformation.Disambiguation.Intrinsic
+import Data.Data
 
-disambiguateFunction :: ProgramFile () -> ProgramFile ()
-disambiguateFunction = transform [ DisambiguateIntrinsic, DisambiguateFunction ]
+disambiguateFunction' :: Data a => ProgramFile a -> ProgramFile a
+disambiguateFunction' = transformWith $ sequence_ [ disambiguateIntrinsic
+                                                  , disambiguateFunction ]
 
+transformWith :: Data a => Transform a () -> ProgramFile a -> ProgramFile a
+transformWith = runTransform mempty mempty
+
 spec :: Spec
 spec = do
   describe "Function statement disambiguation" $
     it "disambiguates function statements in example 1" $ do
-      let pf = disambiguateFunction $ resetSrcSpan ex1
+      let pf = disambiguateFunction' $ resetSrcSpan ex1
       pf `shouldBe'` expectedEx1
 
   describe "Function call disambiguation" $
     it "disambiguates function calls in example 2" $ do
-      let pf = disambiguateFunction $ resetSrcSpan ex2
+      let pf = disambiguateFunction' $ resetSrcSpan ex2
       pf `shouldBe'` expectedEx2
 
   describe "Function call / Intrinsic disambiguation" $
     it "disambiguates function calls / intrinsics in example 3" $ do
-      let pf = disambiguateFunction $ resetSrcSpan ex3
+      let pf = disambiguateFunction' $ resetSrcSpan ex3
       pf `shouldBe'` expectedEx3
 
   describe "Function call / Variable disambiguation" $
     it "disambiguates function calls in example 4" $ do
-      let pf = disambiguateFunction $ resetSrcSpan ex4
+      let pf = disambiguateFunction' $ resetSrcSpan ex4
       pf `shouldBe'` expectedEx4
 
   describe "Implicit Function call / Variable disambiguation" $
     it "disambiguates function calls in example 5" $ do
-      let pf = disambiguateFunction $ resetSrcSpan ex5
+      let pf = disambiguateFunction' $ resetSrcSpan ex5
       pf `shouldBe'` expectedEx5
 
   describe "Implicit array declaration with dimension disambiguation" $
     it "Should not disambiguation to a function call in example 6" $ do
-      let pf = disambiguateFunction $ resetSrcSpan ex6
+      let pf = disambiguateFunction' $ resetSrcSpan ex6
       pf `shouldBe'` expectedEx6
 
 {-
@@ -148,7 +155,7 @@
           (intGen 1)
           (ExpFunctionCall () u
             (ExpValue () u $ ValVariable "f")
-            (Just $ AList () u [ Argument () u Nothing (intGen 1) ])))) ]
+            (Just $ AList () u [ Argument () u Nothing (aintGen 1) ])))) ]
 
 
 ex3 :: ProgramFile ()
@@ -185,8 +192,8 @@
       (StExpressionAssign () u (varGen "i")
         (ExpFunctionCall () u (ExpValue () u $ ValIntrinsic "abs")
           (Just $ AList () u [ Argument () u Nothing
-            (ExpFunctionCall () u (ExpValue () u $ ValVariable "f")
-                                  (Just $ AList () u [ Argument () u Nothing (intGen 1) ])) ]))) ]
+            (ArgExpr $ ExpFunctionCall () u (ExpValue () u $ ValVariable "f")
+                                  (Just $ AList () u [ Argument () u Nothing (aintGen 1) ])) ]))) ]
 
 
 {-
@@ -221,7 +228,7 @@
   , BlStatement () u Nothing
       (StExpressionAssign () u (varGen "a")
        (ExpFunctionCall () u (ExpValue () u $ ValVariable "f")
-                                  (Just $ AList () u [ Argument () u Nothing (intGen 1) ] ))) ]
+                                  (Just $ AList () u [ Argument () u Nothing (aintGen 1) ] ))) ]
 
 {-
 - program Main
@@ -253,7 +260,7 @@
   , BlStatement () u Nothing
       (StExpressionAssign () u (varGen "a")
        (ExpFunctionCall () u (ExpValue () u $ ValVariable "f")
-                                  (Just $ AList () u [ Argument () u Nothing (intGen 1) ] ))) ]
+                                  (Just $ AList () u [ Argument () u Nothing (aintGen 1) ] ))) ]
 
 {-
 - program Main
diff --git a/test/Language/Fortran/Transformation/GroupingSpec.hs b/test/Language/Fortran/Transformation/GroupingSpec.hs
--- a/test/Language/Fortran/Transformation/GroupingSpec.hs
+++ b/test/Language/Fortran/Transformation/GroupingSpec.hs
@@ -5,39 +5,42 @@
 import TestUtil
 import Control.Exception (evaluate)
 import Control.DeepSeq (force)
-import Data.ByteString.Char8 (ByteString, pack)
+import Data.ByteString.Char8 (pack)
+import Data.Data
 
-import Language.Fortran.Transformer
+import Language.Fortran.Transformation.Monad
 import Language.Fortran.AST
 import Language.Fortran.Util.Position
-import Language.Fortran.ParserMonad
-import Language.Fortran.Parser.Fortran95
-import Language.Fortran.Parser.Fortran77
+import qualified Language.Fortran.Parser as Parser
+import           Language.Fortran.Parser ( Parser )
+import Language.Fortran.Transformation.Grouping
 
-groupDo :: ProgramFile () -> ProgramFile ()
-groupDo = transform [ GroupLabeledDo ]
-groupForall :: ProgramFile () -> ProgramFile ()
-groupForall = transform [ GroupForall ]
+transformWith :: Data a => Transform a () -> ProgramFile a -> ProgramFile a
+transformWith = runTransform mempty mempty
 
+groupDo', groupForall' :: Data a => ProgramFile a -> ProgramFile a
+groupDo'     = transformWith groupLabeledDo
+groupForall' = transformWith groupForall
+
 spec :: Spec
 spec = do
   let name = Just "name"
   let endName = Just "endName"
   describe "Block FORALL statements" $ do
     it "groups unlabelled FORALL blocks" $
-      groupForall (exampleForall Nothing Nothing) `shouldBe'` expectedForall Nothing
+      groupForall' (exampleForall Nothing Nothing) `shouldBe'` expectedForall Nothing
     it "groups unlabelled FORALL blocks" $
-      groupForall (exampleForall name name) `shouldBe'` expectedForall name
+      groupForall' (exampleForall name name) `shouldBe'` expectedForall name
     it "groups unlabelled FORALL blocks" $ do
-      let lhs = (evaluate . force) (groupForall $ exampleForall name endName)
+      let lhs = (evaluate . force) (groupForall' $ exampleForall name endName)
       lhs `shouldThrow` anyErrorCall
 
   describe "Block DO statements" $ do
     it "do group example1" $
-      groupDo example1do `shouldBe` expectedExample1do
+      groupDo' example1do `shouldBe` expectedExample1do
 
     it "do group example2 with common end-point" $
-      groupDo example2do `shouldBe` expectedExample2do
+      groupDo' example2do `shouldBe` expectedExample2do
 
   describe "Block SrcSpan's" $ do
     it "Spans all a BlIf" $
@@ -127,20 +130,24 @@
       [ ] label20
   ]
 
-getSingleParsedBlock :: Show b => (ByteString -> String -> ParseResult a b (ProgramFile A0)) -> String -> Block A0
+getSingleParsedBlock :: Parser (ProgramFile A0) -> String -> Block A0
 getSingleParsedBlock p c =
-  let pf = fromRight . fromParseResult $ p (pack c) "foobar.f"
-      ProgramFile _ ((PUSubroutine _ _ _ _ _ (b:_) _):_) = pf
-  in  b
+  case p "<unknown>" (pack c) of
+    Right (ProgramFile _ ((PUSubroutine _ _ _ _ _ (b:_) _):_)) -> b
+    e -> error $ show e
 
+-- TODO Runs internal transformations, which means we aren't explicitly asking
+-- for a grouping transformation. Bit weird.
 getSingleParsedBlock95 :: String -> Block A0
-getSingleParsedBlock95 = getSingleParsedBlock fortran95Parser
+getSingleParsedBlock95 = getSingleParsedBlock Parser.f95
 
+-- TODO Runs internal transformations, which means we aren't explicitly asking
+-- for a grouping transformation. Bit weird.
 getSingleParsedBlock77 :: String -> Block A0
-getSingleParsedBlock77 = getSingleParsedBlock fortran77Parser
+getSingleParsedBlock77 = getSingleParsedBlock Parser.f77
 
 getSingleParsedBlock77Legacy :: String -> Block A0
-getSingleParsedBlock77Legacy = getSingleParsedBlock legacy77Parser
+getSingleParsedBlock77Legacy = getSingleParsedBlock Parser.f77lNoTransform
 
 type SimpleSpan = (Int, Int, Int, Int)
 
diff --git a/test/Language/Fortran/Util/FirstParameterSpec.hs b/test/Language/Fortran/Util/FirstParameterSpec.hs
--- a/test/Language/Fortran/Util/FirstParameterSpec.hs
+++ b/test/Language/Fortran/Util/FirstParameterSpec.hs
@@ -1,7 +1,3 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-
 module Language.Fortran.Util.FirstParameterSpec(spec) where
 
 import Test.Hspec
diff --git a/test/Language/Fortran/Util/SecondParameterSpec.hs b/test/Language/Fortran/Util/SecondParameterSpec.hs
--- a/test/Language/Fortran/Util/SecondParameterSpec.hs
+++ b/test/Language/Fortran/Util/SecondParameterSpec.hs
@@ -1,7 +1,3 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-
 module Language.Fortran.Util.SecondParameterSpec(spec) where
 
 import Test.Hspec
diff --git a/test/TestUtil.hs b/test/TestUtil.hs
--- a/test/TestUtil.hs
+++ b/test/TestUtil.hs
@@ -1,6 +1,3 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-
 module TestUtil where
 
 import Test.Hspec
@@ -9,7 +6,7 @@
 
 import Language.Fortran.AST
 import Language.Fortran.AST.RealLit
-import Language.Fortran.ParserMonad
+import Language.Fortran.Version
 import Language.Fortran.Util.Position
 
 import Language.Fortran.Analysis
@@ -20,10 +17,15 @@
 u :: SrcSpan
 u = initSrcSpan
 
-mi77 :: MetaInfo
-mi77 = MetaInfo { miVersion = Fortran77, miFilename = "<unknown>" }
-mi90 :: MetaInfo
-mi90 = MetaInfo { miVersion = Fortran90, miFilename = "<unknown>" }
+-- TODO Filename only gets set with transformations (defaults to the empty
+-- string). @Parser.parseUnsafe@ uses @"<unknown>"@. So we have to define two
+-- different versions.
+--
+-- Better would be to make an equality checker that ignores 'MetaInfo'.
+mi77, mi77', mi90 :: MetaInfo
+mi77  = MetaInfo { miVersion = Fortran77, miFilename = "" }
+mi77' = MetaInfo { miVersion = Fortran77, miFilename = "<unknown>" }
+mi90  = MetaInfo { miVersion = Fortran90, miFilename = "" }
 
 valTrue, valFalse :: Expression ()
 valTrue  = ExpValue () u $ ValLogical True  Nothing
@@ -41,6 +43,9 @@
 
 intGen :: Integer -> Expression ()
 intGen i = ExpValue () u $ ValInteger (show i) Nothing
+
+aintGen :: Integer -> ArgumentExpression ()
+aintGen = ArgExpr . intGen
 
 initGen :: [Expression ()] -> Expression ()
 initGen es = ExpInitialisation () u $ fromList () es