fortran-src 0.2.1.1 → 0.3.0

raw patch · 54 files changed

+5908/−2036 lines, 54 filesdep ~containersnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +29/−0
• LICENSE +4/−2
• fortran-src.cabal +135/−122
• src/Language/Fortran/AST.hs +221/−91
• src/Language/Fortran/Analysis.hs +98/−48
• src/Language/Fortran/Analysis/BBlocks.hs +303/−173
• src/Language/Fortran/Analysis/DataFlow.hs +256/−112
• src/Language/Fortran/Analysis/Renaming.hs +127/−64
• src/Language/Fortran/Analysis/Types.hs +231/−39
• src/Language/Fortran/Intrinsics.hs +21/−12
• src/Language/Fortran/LValue.hs +1/−0
• src/Language/Fortran/Lexer/FixedForm.x +70/−50
• src/Language/Fortran/Lexer/FreeForm.x +251/−37
• src/Language/Fortran/Parser/Any.hs +20/−3
• src/Language/Fortran/Parser/Fortran2003.y +1328/−0
• src/Language/Fortran/Parser/Fortran66.y +3/−3
• src/Language/Fortran/Parser/Fortran77.y +16/−14
• src/Language/Fortran/Parser/Fortran90.y +82/−57
• src/Language/Fortran/Parser/Fortran95.y +96/−86
• src/Language/Fortran/Parser/Utils.hs +7/−0
• src/Language/Fortran/ParserMonad.hs +23/−6
• src/Language/Fortran/PrettyPrint.hs +267/−101
• src/Language/Fortran/Transformation/Disambiguation/Function.hs +13/−6
• src/Language/Fortran/Transformation/Disambiguation/Intrinsic.hs +2/−2
• src/Language/Fortran/Transformation/Grouping.hs +105/−57
• src/Language/Fortran/Transformation/TransformMonad.hs +2/−2
• src/Language/Fortran/Util/FirstParameter.hs +4/−5
• src/Language/Fortran/Util/ModFile.hs +100/−30
• src/Language/Fortran/Util/Position.hs +27/−9
• src/Language/Fortran/Util/SecondParameter.hs +3/−4
• src/Main.hs +152/−69
• test/Language/Fortran/Analysis/BBlocksSpec.hs +139/−27
• test/Language/Fortran/Analysis/DataFlowSpec.hs +150/−90
• test/Language/Fortran/Analysis/RenamingSpec.hs +135/−34
• test/Language/Fortran/Analysis/TypesSpec.hs +162/−17
• test/Language/Fortran/AnalysisSpec.hs +5/−8
• test/Language/Fortran/Lexer/FixedFormSpec.hs +23/−22
• test/Language/Fortran/Lexer/FreeFormSpec.hs +109/−4
• test/Language/Fortran/Parser/Fortran2003Spec.hs +150/−3
• test/Language/Fortran/Parser/Fortran2008Spec.hs +3/−4
• test/Language/Fortran/Parser/Fortran66Spec.hs +1/−3
• test/Language/Fortran/Parser/Fortran77/IncludeSpec.hs +53/−0
• test/Language/Fortran/Parser/Fortran77/ParserSpec.hs +312/−0
• test/Language/Fortran/Parser/Fortran77Spec.hs +0/−306
• test/Language/Fortran/Parser/Fortran90Spec.hs +91/−70
• test/Language/Fortran/Parser/Fortran95Spec.hs +190/−152
• test/Language/Fortran/Parser/UtilsSpec.hs +8/−9
• test/Language/Fortran/ParserMonadSpec.hs +12/−13
• test/Language/Fortran/PrettyPrintSpec.hs +37/−22
• test/Language/Fortran/Transformation/Disambiguation/FunctionSpec.hs +150/−9
• test/Language/Fortran/Transformation/GroupingSpec.hs +142/−9
• test/Language/Fortran/Util/FirstParameterSpec.hs +15/−15
• test/Language/Fortran/Util/SecondParameterSpec.hs +11/−11
• test/TestUtil.hs +13/−4

@@ -1,3 +1,32 @@+### 0.3.0 (June 13, 2019)++* Add partial Fortran2003 support.+* Introduce datatype for BBGr instead of prior type alias for Gr.+  * Now split into three fields: bbgrGr, bbgrEntries and bbgrExits+  * May require refactoring of code to use bbgrGr field where a Gr was expected before.+* Introduce pragmaOffset field for Position, allowing pragmas to specify an apparent file and line-number.+  * May require refactoring of code that uses the Position constructor.+  * Fifth field is Maybe (Int, String), containing a line-offset and a target filename when present.+  * It's designed such that most Position-based transformations are not affected by the pragmaOffset.+  * They may need to preserve the field, though, as it passes through functions.+  * Default value is 'Nothing'.+* Add --show-flows-to/--show-flows-from features+  * Visualise the dataflow use/def chains using GraphViz.+* Add --show-block-numbers feature.+  * Allows user to get AST-block numbers easily in order to use them with the above visualisation features.+* Fix several bugs with dataflow analysis that had accumulated.+* Eliminate StContinue and StEnddo are eliminated during GroupLabeledDo transformations.+  * To be consistent with unlabeled Do.+* Parse and discard C-comments as a convenience feature for when fortran-src must interact with the output of C preprocessors that insert spurious comments.+* Add type propagation into type analysis, annotating every expression with a type.+  * Additional interface: analyseTypesWithEnv to access a list of type errors found.+* Add dimensional information to CTArray and length/kind to TypeCharacter.+* Stricter checking of the grouping transform - if any statements that should be grouped are not grouped, raise an error.+* Support pragmas that alter the current 'filename and position' tracker, often used by preprocessors to help pinpoint original code locations.+  * Uses a relative offset field called 'posPragmaOffset' so that relative measures continue to function correctly.+* Add constant propagation / parameter variable analysis.+* Add -c feature to compile 'fsmod files' with renaming and type info.+ ### 0.2.1.1 (May 18, 2018)  * Extend Fortran 95 support

@@ -1,10 +1,12 @@-Copyright (c) 2015, Mistral Contrastin+Copyright (c) 2015-2019: Mistral Contrastin, Matthew Danish, Dominic Orchard and Andrew Rice +Additional thanks for contributions from: Anthony Burzillo, Azeem Bande-Ali, Ben Moon, Bradley Hardy, Eric Seidel, Harry Clarke, Jason Xu, Lukasz Kolodziejczyk, TravelTissues and Vaibhav Yenamandra+ Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at -  http://www.apache.org/licenses/LICENSE-2.0+   http://www.apache.org/licenses/LICENSE-2.0  Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS,

@@ -1,135 +1,148 @@--- Initial Language.Fortran.cabal generated by cabal init.  For further--- documentation, see http://haskell.org/cabal/users-guide/+cabal-version: 1.12 -name:                fortran-src-version:             0.2.1.1-synopsis:            Parser and anlyses for Fortran standards 66, 77, 90 and 95.-description:         Provides lexing, parsing, and basic analyses of Fortran code covering standards: FORTRAN 66, FORTRAN 77, Fortran 90, and Fortran 95 and some legacy extensions. Includes data flow and basic block analysis, a renamer, and type analysis. For example usage, see the 'camfort' project, which uses fortran-src as its front end.-bug-reports:         https://github.com/camfort/fortran-src/issues-license:             Apache-2.0-license-file:        LICENSE-author:              Mistral Contrastin, Matthew Danish, Dominic Orchard, Andrew Rice-maintainer:          me@madgen.net--- copyright:-category:            Language-build-type:          Simple-extra-source-files:  CHANGELOG.md-cabal-version:       >=1.10+-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: f33857aa248d66c7f4c20fdc906e32ee466aeca57820d7fd2c0874092659737a++name:           fortran-src+version:        0.3.0+synopsis:       Parser and anlyses for Fortran standards 66, 77, 90 and 95.+description:    Provides lexing, parsing, and basic analyses of Fortran code covering standards: FORTRAN 66, FORTRAN 77, Fortran 90, and Fortran 95 and some legacy extensions. Includes data flow and basic block analysis, a renamer, and type analysis. For example usage, see the 'camfort' project, which uses fortran-src as its front end.+category:       Language+homepage:       https://github.com/camfort/fortran-src#readme+bug-reports:    https://github.com/camfort/fortran-src/issues+author:         Mistral Contrastin, Matthew Danish, Dominic Orchard, Andrew Rice+maintainer:     me@madgen.net+license:        Apache-2.0+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    CHANGELOG.md+ source-repository head-  type:     git+  type: git   location: https://github.com/camfort/fortran-src -executable fortran-src-  main-is: src/Main.hs-  build-depends:-    base >= 4.6 && < 5,-    mtl >= 2.2 && < 3,-    array >= 0.5 && < 0.6,-    uniplate >= 1.6 && < 2,-    GenericPretty >= 1.2.2 && < 2,-    pretty >= 1.1 && < 2,-    containers >= 0.5 && < 0.6,-    text >= 1.2 && < 2,-    bytestring >= 0.10 && < 0.11,-    binary >= 0.8.3.0 && < 0.9,-    filepath >= 1.4 && < 2,-    directory >= 1.2 && < 2,-    fgl >= 5 && < 6,-    fortran-src-  ghc-options: -fno-warn-tabs-  default-language: Haskell2010- library   exposed-modules:-    Language.Fortran.Analysis-    Language.Fortran.Analysis.Renaming-    Language.Fortran.Analysis.Types-    Language.Fortran.Analysis.BBlocks-    Language.Fortran.Analysis.DataFlow-    Language.Fortran.AST-    Language.Fortran.LValue-    Language.Fortran.Intrinsics-    Language.Fortran.Lexer.FixedForm-    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.Utils-    Language.Fortran.PrettyPrint-    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.Util.FirstParameter-    Language.Fortran.Util.SecondParameter-    Language.Fortran.Util.ModFile-  build-tools:-    alex >= 3.1,-    happy >= 1.19+      Language.Fortran.Analysis+      Language.Fortran.Analysis.Renaming+      Language.Fortran.Analysis.Types+      Language.Fortran.Analysis.BBlocks+      Language.Fortran.Analysis.DataFlow+      Language.Fortran.AST+      Language.Fortran.LValue+      Language.Fortran.Intrinsics+      Language.Fortran.Lexer.FixedForm+      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.PrettyPrint+      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.Util.FirstParameter+      Language.Fortran.Util.SecondParameter+      Language.Fortran.Util.ModFile+  hs-source-dirs:+      src+  ghc-options: -fno-warn-tabs   build-depends:-    base >= 4.6 && < 5,-    mtl >= 2.2 && < 3,-    array >= 0.5 && < 0.6,-    uniplate >= 1.6 && < 2,-    GenericPretty >= 1.2.2 && < 2,-    pretty >= 1.1 && < 2,-    containers >= 0.5 && < 0.6,-    text >= 1.2 && < 2,-    bytestring >= 0.10 && < 0.11,-    binary >= 0.8.3.0 && < 0.9,-    filepath >= 1.4 && < 2,-    directory >= 1.2 && < 2,-    fgl >= 5 && < 6-  hs-source-dirs:      src+      GenericPretty >=1.2.2 && <2+    , array >=0.5 && <0.6+    , base >=4.6 && <5+    , binary >=0.8.3.0 && <0.9+    , bytestring >=0.10 && <0.11+    , containers >=0.5 && <0.7+    , directory >=1.2 && <2+    , fgl >=5 && <6+    , filepath >=1.4 && <2+    , mtl >=2.2 && <3+    , pretty >=1.1 && <2+    , text >=1.2 && <2+    , uniplate >=1.6 && <2+  build-tools:+      alex >=3.1+    , happy >=1.19+  default-language: Haskell2010++executable fortran-src+  main-is: src/Main.hs+  other-modules:+      Paths_fortran_src   ghc-options: -fno-warn-tabs-  default-language:    Haskell2010+  build-depends:+      GenericPretty >=1.2.2 && <2+    , array >=0.5 && <0.6+    , base >=4.6 && <5+    , binary >=0.8.3.0 && <0.9+    , bytestring >=0.10 && <0.11+    , containers >=0.5 && <0.7+    , directory >=1.2 && <2+    , fgl >=5 && <6+    , filepath >=1.4 && <2+    , fortran-src+    , mtl >=2.2 && <3+    , pretty >=1.1 && <2+    , text >=1.2 && <2+    , uniplate >=1.6 && <2+  default-language: Haskell2010  test-suite spec   type: exitcode-stdio-1.0-  build-depends:-    deepseq,-    base >= 4.6 && < 5,-    hspec >= 2.2 && < 3,-    mtl >= 2.2 && < 3,-    array >= 0.5 && < 0.6,-    uniplate >= 1.6 && < 2,-    directory >= 1.2 && < 2,-    filepath >= 1.4 && < 2,-    GenericPretty >= 1.2.2 && < 2,-    pretty >= 1.1 && < 2,-    containers >= 0.5 && < 0.6,-    text >= 1.2 && < 2,-    bytestring >= 0.10 && < 0.11,-    binary >= 0.8.3.0 && < 0.9,-    fgl >= 5 && < 6,-    fortran-src-  hs-source-dirs: test   main-is: Spec.hs   other-modules:-    Language.Fortran.Analysis.BBlocksSpec-    Language.Fortran.Analysis.DataFlowSpec-    Language.Fortran.Analysis.RenamingSpec-    Language.Fortran.Analysis.TypesSpec-    Language.Fortran.AnalysisSpec-    Language.Fortran.Lexer.FixedFormSpec-    Language.Fortran.Lexer.FreeFormSpec-    Language.Fortran.Parser.Fortran2003Spec-    Language.Fortran.Parser.Fortran2008Spec-    Language.Fortran.Parser.Fortran66Spec-    Language.Fortran.Parser.Fortran77Spec-    Language.Fortran.Parser.Fortran90Spec-    Language.Fortran.Parser.Fortran95Spec-    Language.Fortran.Parser.UtilsSpec-    Language.Fortran.ParserMonadSpec-    Language.Fortran.PrettyPrintSpec-    Language.Fortran.Transformation.Disambiguation.FunctionSpec-    Language.Fortran.Transformation.GroupingSpec-    Language.Fortran.Util.FirstParameterSpec-    Language.Fortran.Util.SecondParameterSpec-    TestUtil-  default-language:    Haskell2010+      Language.Fortran.Analysis.BBlocksSpec+      Language.Fortran.Analysis.DataFlowSpec+      Language.Fortran.Analysis.RenamingSpec+      Language.Fortran.Analysis.TypesSpec+      Language.Fortran.AnalysisSpec+      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.UtilsSpec+      Language.Fortran.ParserMonadSpec+      Language.Fortran.PrettyPrintSpec+      Language.Fortran.Transformation.Disambiguation.FunctionSpec+      Language.Fortran.Transformation.GroupingSpec+      Language.Fortran.Util.FirstParameterSpec+      Language.Fortran.Util.SecondParameterSpec+      TestUtil+      Paths_fortran_src+  hs-source-dirs:+      test+  build-depends:+      GenericPretty >=1.2.2 && <2+    , array >=0.5 && <0.6+    , base >=4.6 && <5+    , binary >=0.8.3.0 && <0.9+    , bytestring >=0.10 && <0.11+    , containers >=0.5 && <0.7+    , deepseq+    , directory >=1.2 && <2+    , fgl >=5 && <6+    , filepath >=1.4 && <2+    , fortran-src+    , hspec >=2.2 && <3+    , mtl >=2.2 && <3+    , pretty >=1.1 && <2+    , text >=1.2 && <2+    , uniplate >=1.6 && <2+  default-language: Haskell2010

@@ -5,9 +5,12 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-}+-- orphans are instances of package-natives+{-# OPTIONS_GHC -Wno-orphans #-}  module Language.Fortran.AST where +import Prelude hiding (init) import Data.Data import Data.Generics.Uniplate.Data () import Data.Typeable ()@@ -34,12 +37,22 @@ instance Functor t => Functor (AList t) where   fmap f (AList a s xs) = AList (f a) s (map (fmap f) xs) ++-- Convert non-empty list to AList. fromList :: Spanned (t a) => a -> [ t a ] -> AList t a fromList a xs = AList a (getSpan xs) xs +-- Nothing iff list is empty+fromList' :: Spanned (t a) => a -> [ t a ] -> Maybe (AList t a)+fromList' _ [] = Nothing+fromList' a xs = Just $ fromList a xs+ fromReverseList :: Spanned (t ()) => [ t () ] -> AList t () fromReverseList = fromList () . reverse +fromReverseList' :: Spanned (t ()) => [ t () ] -> Maybe (AList t ())+fromReverseList' = fromList' () . reverse+ aCons :: t a -> AList t a -> AList t a aCons x (AList a s xs) = AList a s $ x:xs @@ -51,6 +64,10 @@ aStrip :: AList t a -> [t a] aStrip (AList _ _ l) = l +aStrip' :: Maybe (AList t a) -> [t a]+aStrip' Nothing = []+aStrip' (Just a) = aStrip a+ aMap :: (t a -> r a) -> AList t a -> AList r a aMap f (AList a s xs) = AList a s (map f xs) @@ -62,13 +79,38 @@   | TypeComplex   | TypeDoubleComplex   | TypeLogical-  | TypeCharacter+  | TypeCharacter (Maybe CharacterLen) (Maybe String) -- ^ len and kind, if specified   | TypeCustom String+  | ClassStar+  | ClassCustom String   | TypeByte   deriving (Ord, Eq, Show, Data, Typeable, Generic)  instance Binary BaseType +data CharacterLen = CharLenStar    -- ^ specified with a *+                  | CharLenColon   -- ^ specified with a : (Fortran2003)+                    -- FIXME, possibly, with a more robust const-exp:+                  | CharLenExp     -- ^ specified with a non-trivial expression+                  | CharLenInt Int -- ^ specified with a constant integer+  deriving (Ord, Eq, Show, Data, Typeable, Generic)++instance Binary CharacterLen++charLenSelector :: Maybe (Selector a) -> (Maybe CharacterLen, Maybe String)+charLenSelector Nothing                          = (Nothing, Nothing)+charLenSelector (Just (Selector _ _ mlen mkind)) = (l, k)+  where+    l | Just (ExpValue _ _ ValStar) <- mlen        = Just CharLenStar+      | Just (ExpValue _ _ ValColon) <- mlen       = Just CharLenColon+      | Just (ExpValue _ _ (ValInteger i)) <- mlen = Just $ CharLenInt (read i)+      | Nothing <- mlen                            = Nothing+      | otherwise                                  = Just CharLenExp+    k | Just (ExpValue _ _ (ValInteger i)) <- mkind  = Just i+      | Just (ExpValue _ _ (ValVariable s)) <- mkind = Just s+      -- FIXME: some references refer to things like kind=kanji but I can't find any spec for it+      | otherwise                                    = Nothing+ data TypeSpec a = TypeSpec a SrcSpan BaseType (Maybe (Selector a))   deriving (Eq, Show, Data, Typeable, Generic, Functor) @@ -84,7 +126,9 @@ data ProgramFile a = ProgramFile MetaInfo [ ProgramUnit a ]   deriving (Eq, Show, Data, Typeable, Generic, Functor) +pfSetFilename :: String -> ProgramFile a -> ProgramFile a pfSetFilename fn (ProgramFile mi pus) = ProgramFile (mi { miFilename = fn }) pus+pfGetFilename :: ProgramFile a -> String pfGetFilename (ProgramFile mi _) = miFilename mi  data ProgramUnit a =@@ -100,7 +144,7 @@       (Maybe [ProgramUnit a]) -- Subprograms   | PUSubroutine       a SrcSpan-      (PUFunctionOpt a) -- Subroutine options+      (PrefixSuffix a) -- Subroutine options       Name       (Maybe (AList Expression a)) -- Arguments       [Block a] -- Body@@ -108,7 +152,7 @@   | PUFunction       a SrcSpan       (Maybe (TypeSpec a)) -- Return type-      (PUFunctionOpt a) -- Function Options+      (PrefixSuffix a) -- Function Options       Name       (Maybe (AList Expression a)) -- Arguments       (Maybe (Expression a)) -- Result@@ -121,65 +165,66 @@   | PUComment a SrcSpan (Comment a)   deriving (Eq, Show, Data, Typeable, Generic, Functor) -type IsRecursive = Bool-data PUFunctionOpt a =-    None a SrcSpan IsRecursive-  | Pure a SrcSpan IsRecursive-  | Elemental a SrcSpan-  deriving (Eq, Show, Data, Typeable, Generic, Functor)+type Prefixes a = Maybe (AList Prefix a)+type Suffixes a = Maybe (AList Suffix a)+type PrefixSuffix a = (Prefixes a, Suffixes a) -buildPUFunctionOpt :: (PUFunctionOpt ()) -> (PUFunctionOpt ()) -> Either String (PUFunctionOpt ())-buildPUFunctionOpt a b =-  case (a, b) of-    ((None () _ False ), _)         -> Right $ setSpan (getTransSpan a b) b-    (_, (None () _ False))          -> Right $ setSpan (getTransSpan a b) a-    ((Elemental () _), _)           -> if functionIsRecursive b-                                         then Left "Function cannot be both elemental and recursive. "-                                         else Right . Elemental () $ getTransSpan a b-    (_, (Elemental () _))           -> buildPUFunctionOpt b a-    ((Pure () _ r), b)              -> Right $ Pure () (getTransSpan a b) (r || functionIsRecursive b)-    (a, (Pure () _ r))              -> Right $ Pure () (getTransSpan a b) (r || functionIsRecursive a)-    ((None () _ r), (None () _ r')) -> Right $ None () (getTransSpan a b) (r || r')--- Should parse: "elemental pure recursive function f()\nend": Right (Elemental ()) FAILED [4]+emptyPrefixes :: Prefixes a+emptyPrefixes = Nothing -buildPUFunctionOpts :: [PUFunctionOpt ()] -> Either String (PUFunctionOpt())-buildPUFunctionOpts =-  foldr merge . Right $ None () initSrcSpan False-  where merge a = either Left $ buildPUFunctionOpt a+emptySuffixes :: Suffixes a+emptySuffixes = Nothing -functionIsRecursive :: (PUFunctionOpt a) -> Bool-functionIsRecursive (Elemental _ _) = False-functionIsRecursive (Pure _ _ r)    = r-functionIsRecursive (None _ _ r)    = r+emptyPrefixSuffix :: PrefixSuffix a+emptyPrefixSuffix = (emptyPrefixes, emptySuffixes) +data Prefix a = PfxRecursive a SrcSpan+              | PfxElemental a SrcSpan+              | PfxPure a SrcSpan+  deriving (Eq, Show, Data, Typeable, Generic, Functor)++-- see C1241 & C1242 (Fortran2003)+validPrefixSuffix :: PrefixSuffix a -> Bool+validPrefixSuffix (mpfxs, msfxs) =+  not (any isElem pfxs) || (not (any isRec pfxs) && not (any isBind sfxs))+  where+    isElem (PfxElemental {}) = True; isElem _ = False+    isRec  (PfxRecursive {}) = True; isRec _  = False+    isBind (SfxBind {})      = True+    pfxs = aStrip' mpfxs+    sfxs = aStrip' msfxs++data Suffix a = SfxBind a SrcSpan (Maybe (Expression a))+  deriving (Eq, Show, Data, Typeable, Generic, Functor)+ programUnitBody :: ProgramUnit a -> [Block a] programUnitBody (PUMain _ _ _ bs _)              = bs programUnitBody (PUModule _ _ _ bs _)            = bs programUnitBody (PUSubroutine _ _ _ _ _ bs _)    = bs programUnitBody (PUFunction _ _ _ _ _ _ _ bs _)  = bs programUnitBody (PUBlockData _ _ _ bs)           = bs-programUnitBody (PUComment {})                   = []+programUnitBody PUComment{}                   = []  updateProgramUnitBody :: ProgramUnit a -> [Block a] -> ProgramUnit a-updateProgramUnitBody (PUMain a s n bs pu)   bs' =+updateProgramUnitBody (PUMain a s n _ pu)   bs' =     PUMain a s n bs' pu-updateProgramUnitBody (PUModule a s n bs pu) bs' =+updateProgramUnitBody (PUModule a s n _ pu) bs' =     PUModule a s n bs' pu-updateProgramUnitBody (PUSubroutine a s f n args bs pu) bs' =+updateProgramUnitBody (PUSubroutine a s f n args _ pu) bs' =     PUSubroutine a s f n args bs' pu-updateProgramUnitBody (PUFunction a s t f n args res bs pu) bs' =+updateProgramUnitBody (PUFunction a s t f n args res _ pu) bs' =     PUFunction a s t f n args res bs' pu-updateProgramUnitBody (PUBlockData a s n bs) bs' =+updateProgramUnitBody (PUBlockData a s n _) bs' =     PUBlockData a s n bs'-updateProgramUnitBody p@(PUComment {}) _ = p+updateProgramUnitBody p@PUComment{} _ = p  programUnitSubprograms :: ProgramUnit a -> Maybe [ProgramUnit a] programUnitSubprograms (PUMain _ _ _ _ s)             = s programUnitSubprograms (PUModule _ _ _ _ s)           = s programUnitSubprograms (PUSubroutine _ _ _ _ _ _ s)   = s programUnitSubprograms (PUFunction _ _ _ _ _ _ _ _ s) = s-programUnitSubprograms (PUBlockData {})               = Nothing-programUnitSubprograms (PUComment {})                 = Nothing+programUnitSubprograms PUBlockData{}               = Nothing+programUnitSubprograms PUComment{}                 = Nothing  newtype Comment a = Comment String   deriving (Eq, Show, Data, Typeable, Generic, Functor)@@ -229,6 +274,7 @@    | BlInterface a SrcSpan                 (Maybe (Expression a))       -- label+                Bool                         -- abstract?                 [ ProgramUnit a ]            -- Routine decls. in the interface                 [ Block a ]                  -- Module procedures @@ -242,11 +288,15 @@   | StOptional            a SrcSpan (AList Expression a)   | StPublic              a SrcSpan (Maybe (AList Expression a))   | StPrivate             a SrcSpan (Maybe (AList Expression a))+  | StProtected           a SrcSpan (Maybe (AList Expression a))   | StSave                a SrcSpan (Maybe (AList Expression a))   | StDimension           a SrcSpan (AList Declarator a)   | StAllocatable         a SrcSpan (AList Declarator a)+  | StAsynchronous        a SrcSpan (AList Declarator a)   | StPointer             a SrcSpan (AList Declarator a)   | StTarget              a SrcSpan (AList Declarator a)+  | StValue               a SrcSpan (AList Declarator a)+  | StVolatile            a SrcSpan (AList Declarator a)   | StData                a SrcSpan (AList DataGroup a)   | StAutomatic           a SrcSpan (AList Declarator a)   | StNamelist            a SrcSpan (AList Namelist a)@@ -292,6 +342,7 @@   | StTypePrint           a SrcSpan (Expression a) (Maybe (AList Expression a))   | StOpen                a SrcSpan (AList ControlPair a)   | StClose               a SrcSpan (AList ControlPair a)+  | StFlush               a SrcSpan (AList FlushSpec a)   | StInquire             a SrcSpan (AList ControlPair a)   | StRewind              a SrcSpan (AList ControlPair a)   | StRewind2             a SrcSpan (Expression a)@@ -299,26 +350,40 @@   | StBackspace2          a SrcSpan (Expression a)   | StEndfile             a SrcSpan (AList ControlPair a)   | StEndfile2            a SrcSpan (Expression a)-  | StAllocate            a SrcSpan (AList Expression a) (Maybe (ControlPair a))+  | StAllocate            a SrcSpan (Maybe (TypeSpec a)) (AList Expression a) (Maybe (AList AllocOpt a))   | StNullify             a SrcSpan (AList Expression a)-  | StDeallocate          a SrcSpan (AList Expression a) (Maybe (ControlPair a))+  | StDeallocate          a SrcSpan (AList Expression a) (Maybe (AList AllocOpt a))   | StWhere               a SrcSpan (Expression a) (Statement a)-  | StWhereConstruct      a SrcSpan (Expression a)-  | StElsewhere           a SrcSpan-  | StEndWhere            a SrcSpan-  | StUse                 a SrcSpan (Expression a) Only (Maybe (AList Use a))+  | StWhereConstruct      a SrcSpan (Maybe String) (Expression a)+  | StElsewhere           a SrcSpan (Maybe String) (Maybe (Expression a))+  | StEndWhere            a SrcSpan (Maybe String)+  | StUse                 a SrcSpan (Expression a) (Maybe ModuleNature) Only (Maybe (AList Use a))   | StModuleProcedure     a SrcSpan (AList Expression a)+  | StProcedure           a SrcSpan (Maybe (ProcInterface a)) (Maybe (Attribute a)) (AList ProcDecl a)   | StType                a SrcSpan (Maybe (AList Attribute a)) String   | StEndType             a SrcSpan (Maybe String)   | StSequence            a SrcSpan   | StForall              a SrcSpan (Maybe String) (ForallHeader a)   | StForallStatement     a SrcSpan (ForallHeader a) (Statement a)   | StEndForall           a SrcSpan (Maybe String)+  | StImport              a SrcSpan (AList Expression a)+  | StEnum                a SrcSpan+  | StEnumerator          a SrcSpan (AList Declarator a)+  | StEndEnum             a SrcSpan   -- Following is a temporary solution to a complicated FORMAT statement   -- parsing problem.   | StFormatBogus         a SrcSpan String   deriving (Eq, Show, Data, Typeable, Generic, Functor) +-- R1214 proc-decl is procedure-entity-name [=> null-init]+data ProcDecl a = ProcDecl a SrcSpan (Expression a) (Maybe (Expression a))+  deriving (Eq, Show, Data, Typeable, Generic, Functor)++-- R1212 proc-interface is interface-name or declaration-type-spec+data ProcInterface a = ProcInterfaceName a SrcSpan (Expression a)+                     | ProcInterfaceType a SrcSpan (TypeSpec a)+  deriving (Eq, Show, Data, Typeable, Generic, Functor)+ data ForallHeader a = ForallHeader     -- List of tuples: index-name, start subscript, end subscript, optional stride     [(Name, Expression a, Expression a, Maybe (Expression a))]@@ -329,6 +394,9 @@ data Only = Exclusive | Permissive   deriving (Eq, Show, Data, Typeable, Generic) +data ModuleNature = ModIntrinsic | ModNonIntrinsic+  deriving (Eq, Show, Data, Typeable, Generic)+ data Use a =     UseRename a SrcSpan (Expression a) (Expression a)   | UseID a SrcSpan (Expression a)@@ -338,18 +406,23 @@   deriving (Eq, Show, Data, Typeable, Generic, Functor)  data Attribute a =-    AttrParameter a SrcSpan-  | AttrPublic a SrcSpan-  | AttrPrivate a SrcSpan-  | AttrAllocatable a SrcSpan+    AttrAllocatable a SrcSpan+  | AttrAsynchronous a SrcSpan   | AttrDimension a SrcSpan (AList DimensionDeclarator a)   | AttrExternal a SrcSpan   | AttrIntent a SrcSpan Intent   | AttrIntrinsic a SrcSpan   | AttrOptional a SrcSpan+  | AttrParameter a SrcSpan   | AttrPointer a SrcSpan+  | AttrPrivate a SrcSpan+  | AttrProtected a SrcSpan+  | AttrPublic a SrcSpan   | AttrSave a SrcSpan+  | AttrSuffix a SrcSpan (Suffix a)  -- for language-binding-spec   | AttrTarget a SrcSpan+  | AttrValue a SrcSpan+  | AttrVolatile a SrcSpan   deriving (Eq, Show, Data, Typeable, Generic, Functor)  data Intent = In | Out | InOut@@ -358,6 +431,12 @@ data ControlPair a = ControlPair a SrcSpan (Maybe String) (Expression a)   deriving (Eq, Show, Data, Typeable, Generic, Functor) +data AllocOpt a =+    AOStat a SrcSpan (Expression a)+  | AOErrMsg a SrcSpan (Expression a)+  | AOSource a SrcSpan (Expression a)+  deriving (Eq, Show, Data, Typeable, Generic, Functor)+ data ImpList a = ImpList a SrcSpan (TypeSpec a) (AList ImpElement a)   deriving (Eq, Show, Data, Typeable, Generic, Functor) @@ -399,6 +478,13 @@   | FIScaleFactor           a             SrcSpan   Integer   deriving (Eq, Show, Data, Typeable, Generic, Functor) +data FlushSpec a =+    FSUnit a SrcSpan (Expression a)+  | FSIOStat a SrcSpan (Expression a)+  | FSIOMsg a SrcSpan (Expression a)+  | FSErr a SrcSpan (Expression a)+  deriving (Eq, Show, Data, Typeable, Generic, Functor)+ data DoSpecification a =   DoSpecification a SrcSpan (Statement a) (Expression a) (Maybe (Expression a))   deriving (Eq, Show, Data, Typeable, Generic, Functor)@@ -456,6 +542,7 @@   -- ^ Overloaded assignment in interfaces   | ValType              String   | ValStar+  | ValColon                   -- see R402 / C403 in Fortran2003 spec.   deriving (Eq, Show, Data, Typeable, Generic, Functor)  data Declarator a =@@ -475,6 +562,8 @@   DeclVariable a (getTransSpan s init) v l (Just init) setInitialisation (DeclArray a s v ds l Nothing) init =   DeclArray a (getTransSpan s init) v ds l (Just init)+-- do nothing when there is already a value+setInitialisation d _ = d  data DimensionDeclarator a =   DimensionDeclarator a SrcSpan (Maybe (Expression a)) (Maybe (Expression a))@@ -485,8 +574,10 @@   | Minus   | Not   | UnCustom String-  deriving (Eq, Show, Data, Typeable, Generic)+  deriving (Eq, Ord, Show, Data, Typeable, Generic) +instance Binary UnaryOp+ data BinaryOp =     Addition   | Subtraction@@ -506,8 +597,10 @@   | Equivalent   | NotEquivalent   | BinCustom String-  deriving (Eq, Show, Data, Typeable, Generic)+  deriving (Eq, Ord, Show, Data, Typeable, Generic) +instance Binary BinaryOp+ -- Retrieving SrcSpan and Annotation from nodes class Annotated f where   getAnnotation :: f a -> a@@ -523,12 +616,15 @@  instance FirstParameter (AList t a) a instance FirstParameter (ProgramUnit a) a-instance FirstParameter (PUFunctionOpt a) a+instance FirstParameter (Prefix a) a+instance FirstParameter (Suffix a) a instance FirstParameter (Block a) a instance FirstParameter (Statement a) a instance FirstParameter (Argument a) a instance FirstParameter (Use a) a instance FirstParameter (TypeSpec a) a+instance FirstParameter (ProcDecl a) a+instance FirstParameter (ProcInterface a) a instance FirstParameter (Selector a) a instance FirstParameter (Attribute a) a instance FirstParameter (ImpList a) a@@ -542,18 +638,23 @@ instance FirstParameter (Expression a) a instance FirstParameter (Index a) a instance FirstParameter (DoSpecification a) a+instance FirstParameter (FlushSpec a) a instance FirstParameter (Declarator a) a instance FirstParameter (DimensionDeclarator a) a instance FirstParameter (ControlPair a) a+instance FirstParameter (AllocOpt a) a  instance SecondParameter (AList t a) SrcSpan instance SecondParameter (ProgramUnit a) SrcSpan-instance SecondParameter (PUFunctionOpt a) SrcSpan+instance SecondParameter (Prefix a) SrcSpan+instance SecondParameter (Suffix a) SrcSpan instance SecondParameter (Block a) SrcSpan instance SecondParameter (Statement a) SrcSpan instance SecondParameter (Argument a) SrcSpan instance SecondParameter (Use a) SrcSpan instance SecondParameter (TypeSpec a) SrcSpan+instance SecondParameter (ProcDecl a) SrcSpan+instance SecondParameter (ProcInterface a) SrcSpan instance SecondParameter (Selector a) SrcSpan instance SecondParameter (Attribute a) SrcSpan instance SecondParameter (ImpList a) SrcSpan@@ -567,9 +668,11 @@ instance SecondParameter (Expression a) SrcSpan instance SecondParameter (Index a) SrcSpan instance SecondParameter (DoSpecification a) SrcSpan+instance SecondParameter (FlushSpec a) SrcSpan instance SecondParameter (Declarator a) SrcSpan instance SecondParameter (DimensionDeclarator a) SrcSpan instance SecondParameter (ControlPair a) SrcSpan+instance SecondParameter (AllocOpt a) SrcSpan  instance Annotated (AList t) instance Annotated ProgramUnit@@ -578,6 +681,8 @@ instance Annotated Argument instance Annotated Use instance Annotated TypeSpec+instance Annotated ProcDecl+instance Annotated ProcInterface instance Annotated Selector instance Annotated Attribute instance Annotated ImpList@@ -591,18 +696,23 @@ instance Annotated Expression instance Annotated Index instance Annotated DoSpecification+instance Annotated FlushSpec instance Annotated Declarator instance Annotated DimensionDeclarator instance Annotated ControlPair+instance Annotated AllocOpt  instance Spanned (AList t a) instance Spanned (ProgramUnit a)-instance Spanned (PUFunctionOpt a)+instance Spanned (Prefix a)+instance Spanned (Suffix a) instance Spanned (Statement a) instance Spanned (Argument a) instance Spanned (Use a) instance Spanned (Attribute a) instance Spanned (TypeSpec a)+instance Spanned (ProcDecl a)+instance Spanned (ProcInterface a) instance Spanned (Selector a) instance Spanned (ImpList a) instance Spanned (ImpElement a)@@ -616,15 +726,17 @@ instance Spanned (Expression a) instance Spanned (Index a) instance Spanned (DoSpecification a)+instance Spanned (FlushSpec a) instance Spanned (Declarator a) instance Spanned (DimensionDeclarator a) instance Spanned (ControlPair a)+instance Spanned (AllocOpt a)  instance Spanned (ProgramFile a) where   getSpan (ProgramFile _ pus) =     case pus of       [] -> SrcSpan initPosition initPosition-      pus -> getSpan pus+      pus' -> getSpan pus'    setSpan _ _ = error "Cannot set span to a program unit" @@ -644,6 +756,11 @@   getSpan (_,y) = getSpan y   setSpan _ = undefined +instance (Spanned a, Spanned b) => Spanned (Either a b) where+  getSpan (Left x) = getSpan x+  getSpan (Right x) = getSpan x+  setSpan _ = undefined+ instance {-# OVERLAPPABLE #-} (Spanned a, Spanned b) => Spanned (a, b) where   getSpan (x,y) = getTransSpan x y   setSpan _ = undefined@@ -670,7 +787,7 @@   setSpan _ = undefined  instance {-# OVERLAPPABLE #-} (Spanned a, Spanned b, Spanned c) => Spanned (a, b, c) where-  getSpan (x,y,z) = getTransSpan x z+  getSpan (x,_,z) = getTransSpan x z   setSpan _ = undefined  class (Spanned a, Spanned b) => SpannedPair a b where@@ -719,7 +836,7 @@   setLabel (BlIf a s _ mn conds bs el) l = BlIf a s (Just l) mn conds bs el   setLabel (BlDo a s _ mn tl spec bs el) l = BlDo a s (Just l) mn tl spec bs el   setLabel (BlDoWhile a s _ n tl spec bs el) l = BlDoWhile a s (Just l) n tl spec bs el-  setLabel b l = b+  setLabel b _ = b  class Conditioned f where   getCondition :: f a -> Maybe (Expression a)@@ -754,7 +871,7 @@   getName (PUFunction _ _ _ _ n _ _ _ _) = Named n   getName (PUBlockData _ _ Nothing _)  = NamelessBlockData   getName (PUBlockData _ _ (Just n) _) = Named n-  getName (PUComment {}) = NamelessComment+  getName PUComment{} = NamelessComment   setName (Named n) (PUMain a s _ b pus) = PUMain a s (Just n) b pus   setName _         (PUMain a s _ b pus) = PUMain a s Nothing b pus   setName (Named n) (PUModule a s _ b pus) = PUModule a s n b pus@@ -764,15 +881,21 @@     PUFunction a s r rec n p res b subs   setName (Named n) (PUBlockData  a s _ b) = PUBlockData  a s (Just n) b   setName _         (PUBlockData  a s _ b) = PUBlockData  a s Nothing b+  -- Identity function if first arg is nameless or second arg is comment.+  setName _ a = a  instance Out FortranVersion instance Out MetaInfo instance Out a => Out (ProgramFile a) instance Out a => Out (ProgramUnit a)-instance Out a => Out (PUFunctionOpt a)+instance Out a => Out (Prefix a)+instance Out a => Out (Suffix a) instance (Out a, Out (t a)) => Out (AList t a) instance Out a => Out (Statement a)+instance Out a => Out (ProcDecl a)+instance Out a => Out (ProcInterface a) instance Out Only+instance Out ModuleNature instance Out a => Out (Argument a) instance Out a => Out (Use a) instance Out a => Out (Attribute a)@@ -790,13 +913,16 @@ instance Out a => Out (Expression a) instance Out a => Out (Index a) instance Out a => Out (DoSpecification a)+instance Out a => Out (FlushSpec a) instance Out a => Out (Value a) instance Out a => Out (TypeSpec a) instance Out a => Out (Selector a)+instance Out CharacterLen instance Out BaseType instance Out a => Out (Declarator a) instance Out a => Out (DimensionDeclarator a) instance Out a => Out (ControlPair a)+instance Out a => Out (AllocOpt a) instance Out UnaryOp instance Out BinaryOp instance Out a => Out (ForallHeader a)@@ -804,35 +930,39 @@ -- Classifiers on statement and blocks ASTs  nonExecutableStatement :: FortranVersion -> Statement a -> Bool-nonExecutableStatement v s = case s of-    StIntent {}      -> True-    StOptional {}    -> True-    StPublic {}      -> True-    StPrivate {}     -> True-    StSave {}        -> True-    StDimension {}   -> True-    StAllocatable {} -> True-    StPointer {}     -> True-    StTarget {}      -> True-    StData {}        -> True-    StParameter {}   -> True-    StImplicit {}    -> True-    StNamelist {}    -> True-    StEquivalence {} -> True-    StCommon {}      -> True-    StExternal {}    -> True-    StIntrinsic {}   -> True-    StUse {}         -> True-    StEntry {}       -> True-    StSequence {}    -> True-    StType {}        -> True-    StEndType {}     -> True-    StFormat {}      -> True-    StFormatBogus {} -> True-    StInclude {}     -> True-    StDeclaration {} -> True-    StStructure {}   -> True-    _                -> False+nonExecutableStatement _ s = case s of+    StIntent {}       -> True+    StOptional {}     -> True+    StPublic {}       -> True+    StPrivate {}      -> True+    StProtected {}    -> True+    StSave {}         -> True+    StDimension {}    -> True+    StAllocatable {}  -> True+    StAsynchronous {} -> True+    StPointer {}      -> True+    StTarget {}       -> True+    StValue {}        -> True+    StVolatile {}     -> True+    StData {}         -> True+    StParameter {}    -> True+    StImplicit {}     -> True+    StNamelist {}     -> True+    StEquivalence {}  -> True+    StCommon {}       -> True+    StExternal {}     -> True+    StIntrinsic {}    -> True+    StUse {}          -> True+    StEntry {}        -> True+    StSequence {}     -> True+    StType {}         -> True+    StEndType {}      -> True+    StFormat {}       -> True+    StFormatBogus {}  -> True+    StInclude {}      -> True+    StDeclaration {}  -> True+    StStructure {}    -> True+    _                 -> False  executableStatement :: FortranVersion -> Statement a -> Bool -- Some statements are both executable and non-executable in Fortran 90 upwards@@ -843,9 +973,9 @@  executableStatementBlock :: FortranVersion -> Block a -> Bool executableStatementBlock v (BlStatement _ _ _ s) = executableStatement v s-executableStatementBlock v _ = False+executableStatementBlock _ _ = False  nonExecutableStatementBlock :: FortranVersion -> Block a -> Bool nonExecutableStatementBlock v (BlStatement _ _ _ s) = nonExecutableStatement v s-nonExecutableStatementBlock v BlInterface{} = True-nonExecutableStatementBlock v _ = False+nonExecutableStatementBlock _ BlInterface{} = True+nonExecutableStatementBlock _ _ = False

@@ -1,27 +1,31 @@ {-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, StandaloneDeriving, DeriveGeneric, TupleSections #-}+{-# OPTIONS_GHC -Wno-orphans #-}  -- | -- Common data structures and functions supporting analysis of the AST. module Language.Fortran.Analysis-  ( initAnalysis, stripAnalysis, Analysis(..)+  ( initAnalysis, stripAnalysis, Analysis(..), Constant(..)   , varName, srcName, lvVarName, lvSrcName, isNamedExpression   , genVar, puName, puSrcName, blockRhsExprs, rhsExprs   , ModEnv, NameType(..), IDType(..), ConstructType(..), BaseType(..)   , lhsExprs, isLExpr, allVars, analyseAllLhsVars, analyseAllLhsVars1, allLhsVars   , blockVarUses, blockVarDefs-  , BB, BBGr+  , BB, BBNode, BBGr(..), bbgrMap, bbgrMapM, bbgrEmpty   , TransFunc, TransFuncM ) where +import Prelude hiding (exp)+import Control.Monad (void) import Language.Fortran.Util.Position (SrcSpan) import Data.Generics.Uniplate.Data import Data.Data import Language.Fortran.AST import Language.Fortran.LValue+import Data.Graph.Inductive (Node, empty) import Data.Graph.Inductive.PatriciaTree (Gr) import GHC.Generics (Generic) import Text.PrettyPrint.GenericPretty-import Text.PrettyPrint+import Text.PrettyPrint hiding (empty, isEmpty) import qualified Data.Map.Strict as M import Data.Maybe import Data.Binary@@ -34,12 +38,32 @@ type BB a = [Block a]  -- | Basic block graph.-type BBGr a = Gr (BB a) ()+data BBGr a = BBGr { bbgrGr :: Gr (BB a) () -- ^ the underlying graph+                   , bbgrEntries :: [Node]  -- ^ the entry node(s)+                   , bbgrExits :: [Node]    -- ^ the exit node(s)+                   }+  deriving (Data, Show, Eq, Generic) +type BBNode = Int++-- | Empty basic block graph+bbgrEmpty :: BBGr a+bbgrEmpty = BBGr empty [] []++-- | Call function on the underlying graph+bbgrMap :: (Gr (BB a) () -> Gr (BB b) ()) -> BBGr a -> BBGr b+bbgrMap f bb = bb { bbgrGr = f (bbgrGr bb) }++-- | Monadically call function on the underlying graph+bbgrMapM :: Monad m => (Gr (BB a1) () -> m (Gr (BB a2) ())) -> BBGr a1 -> m (BBGr a2)+bbgrMapM f bb = do+  x <- f (bbgrGr bb)+  return $ bb { bbgrGr = x }+ -- Allow graphs to reside inside of annotations deriving instance (Typeable a, Typeable b) => Typeable (Gr a b) instance (Typeable a, Typeable b) => Data (Gr a b) where-    gfoldl _k z v = z v -- make graphs opaque to Uniplate+    gfoldl _k z   = z -- make graphs opaque to Uniplate     toConstr _    = error "toConstr"     gunfold _ _   = error "gunfold"     dataTypeOf _  = mkNoRepType "Gr"@@ -66,7 +90,7 @@   | CTSubroutine   | CTExternal   | CTVariable-  | CTArray+  | CTArray [(Maybe Int, Maybe Int)]   | CTParameter   | CTIntrinsic   deriving (Ord, Eq, Show, Data, Typeable, Generic)@@ -82,6 +106,18 @@ instance Out IDType instance Binary IDType +-- | Information about potential / actual constant expressions.+data Constant+  = ConstInt Integer            -- ^ interpreted integer+  | ConstUninterpInt String     -- ^ uninterpreted integer+  | ConstUninterpReal String    -- ^ uninterpreted real+  | ConstBinary BinaryOp Constant Constant -- ^ binary operation on potential constants+  | ConstUnary UnaryOp Constant -- ^ unary operation on potential constants+  deriving (Show, Ord, Eq, Typeable, Generic, Data)++instance Out Constant+instance Binary Constant+ data Analysis a = Analysis   { prevAnnotation :: a -- ^ original annotation   , uniqueName     :: Maybe String -- ^ unique name for function/variable, after variable renaming phase@@ -91,6 +127,7 @@   , moduleEnv      :: Maybe ModEnv   , idType         :: Maybe IDType   , allLhsVarsAnn  :: [Name]+  , constExp       :: Maybe Constant   }   deriving (Data, Show, Eq, Generic) @@ -100,11 +137,12 @@     { prevAnnotation = f (prevAnnotation analysis)     , uniqueName = uniqueName analysis     , sourceName = sourceName analysis-    , bBlocks = fmap (first . fmap . fmap . fmap $ f) . bBlocks $ analysis+    , bBlocks = fmap (bbgrMap (first . fmap . fmap . fmap $ f)) . bBlocks $ analysis     , insLabel = insLabel analysis     , moduleEnv = moduleEnv analysis     , idType = idType analysis     , allLhsVarsAnn = allLhsVarsAnn analysis+    , constExp = constExp analysis     }  instance Out (Analysis a) where@@ -115,6 +153,7 @@             , ("idType: ", fmap show (idType a)) ]   docPrec _ = doc +analysis0 :: a -> Analysis a analysis0 a = Analysis { prevAnnotation = a                        , uniqueName     = Nothing                        , sourceName     = Nothing@@ -122,7 +161,8 @@                        , insLabel       = Nothing                        , moduleEnv      = Nothing                        , idType         = Nothing-                       , allLhsVarsAnn  = [] }+                       , allLhsVarsAnn  = []+                       , constExp       = Nothing }  -- | True iff the expression can be used with varName or srcName isNamedExpression :: Expression a -> Bool@@ -132,32 +172,32 @@  -- | Obtain either uniqueName or source name from an ExpValue variable. varName :: Expression (Analysis a) -> String-varName (ExpValue (Analysis { uniqueName = Just n }) _ (ValVariable {}))  = n-varName (ExpValue (Analysis { sourceName = Just n }) _ (ValVariable {}))  = n-varName (ExpValue _ _ (ValVariable n))                                    = n-varName (ExpValue (Analysis { uniqueName = Just n }) _ (ValIntrinsic {})) = n-varName (ExpValue (Analysis { sourceName = Just n }) _ (ValIntrinsic {})) = n-varName (ExpValue _ _ (ValIntrinsic n))                                   = n-varName _                                                                 = error "Use of varName on non-variable."+varName (ExpValue Analysis { uniqueName = Just n } _ ValVariable{})  = n+varName (ExpValue Analysis { sourceName = Just n } _ ValVariable{})  = n+varName (ExpValue _ _ (ValVariable n))                               = n+varName (ExpValue Analysis { uniqueName = Just n } _ ValIntrinsic{}) = n+varName (ExpValue Analysis { sourceName = Just n } _ ValIntrinsic{}) = n+varName (ExpValue _ _ (ValIntrinsic n))                              = n+varName _                                                            = error "Use of varName on non-variable."  -- | Obtain the source name from an ExpValue variable. srcName :: Expression (Analysis a) -> String-srcName (ExpValue (Analysis { sourceName = Just n }) _ (ValVariable {}))  = n-srcName (ExpValue _ _ (ValVariable n))                                    = n-srcName (ExpValue (Analysis { sourceName = Just n }) _ (ValIntrinsic {})) = n-srcName (ExpValue _ _ (ValIntrinsic n))                                   = n-srcName _                                                                 = error "Use of srcName on non-variable."+srcName (ExpValue Analysis { sourceName = Just n } _ ValVariable{})  = n+srcName (ExpValue _ _ (ValVariable n))                               = n+srcName (ExpValue Analysis { sourceName = Just n } _ ValIntrinsic{}) = n+srcName (ExpValue _ _ (ValIntrinsic n))                              = n+srcName _                                                            = error "Use of srcName on non-variable."  -- | Obtain either uniqueName or source name from an LvSimpleVar variable. lvVarName :: LValue (Analysis a) -> String-lvVarName (LvSimpleVar (Analysis { uniqueName = Just n }) _ _)  = n-lvVarName (LvSimpleVar (Analysis { sourceName = Just n }) _ _)  = n-lvVarName (LvSimpleVar _ _ n)                                   = n-lvVarName _                                                     = error "Use of lvVarName on non-variable."+lvVarName (LvSimpleVar Analysis { uniqueName = Just n } _ _)  = n+lvVarName (LvSimpleVar Analysis { sourceName = Just n } _ _)  = n+lvVarName (LvSimpleVar _ _ n)                                 = n+lvVarName _                                                   = error "Use of lvVarName on non-variable."  -- | Obtain the source name from an LvSimpleVar variable. lvSrcName :: LValue (Analysis a) -> String-lvSrcName (LvSimpleVar (Analysis { sourceName = Just n }) _ _) = n+lvSrcName (LvSimpleVar Analysis { sourceName = Just n } _ _) = n lvSrcName (LvSimpleVar _ _ n) = n lvSrcName _ = error "Use of lvSrcName on a non-variable" @@ -219,9 +259,9 @@  -- | Is this an expression capable of assignment? isLExpr :: Expression a -> Bool-isLExpr (ExpValue _ _ (ValVariable {}))  = True-isLExpr (ExpSubscript _ _ _ _)           = True-isLExpr _                                = False+isLExpr (ExpValue _ _ ValVariable {}) = True+isLExpr ExpSubscript{}                = True+isLExpr _                             = False  -- | Set of names found in an AST node. allVars :: forall a b. (Data a, Data (b (Analysis a))) => b (Analysis a) -> [Name]@@ -243,10 +283,10 @@ -- an assignment statement. -- allLhsVars :: (Annotated b, Data a, Data (b (Analysis a))) => b (Analysis a) -> [Name] allLhsVars :: Data a => Block (Analysis a) -> [Name]-allLhsVars x = allLhsVarsAnn . getAnnotation $ x+allLhsVars = allLhsVarsAnn . getAnnotation  allLhsVarsDoSpec :: Data a => DoSpecification (Analysis a) -> [Name]-allLhsVarsDoSpec x = computeAllLhsVars x+allLhsVarsDoSpec = computeAllLhsVars  -- | Set of names found in the parts of an AST that are the target of -- an assignment statement.@@ -255,11 +295,16 @@   where     lhsOfStmt :: Statement (Analysis a) -> [Name]     lhsOfStmt (StExpressionAssign _ _ e e') = match' e : onExprs e'+    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 s = onExprs s +    lhsOfDecls (DeclVariable _ _ e _ (Just e')) = match' e : onExprs e'+    lhsOfDecls (DeclArray _ _ e _ _ (Just e')) = match' e : onExprs e'+    lhsOfDecls _ = []+     onExprs :: (Data (c (Analysis a))) => c (Analysis a) -> [Name]     onExprs = concatMap lhsOfExp . universeBi @@ -270,22 +315,22 @@     extractExp (Argument _ _ _ exp) = exp      -- Match and give the varname for LHS of statement-    match' v@(ExpValue _ _ (ValVariable {})) = varName v-    match' (ExpSubscript _ _ v@(ExpValue _ _ (ValVariable {})) _) = varName v+    match' v@(ExpValue _ _ ValVariable{}) = varName v+    match' (ExpSubscript _ _ v@(ExpValue _ _ ValVariable{}) _) = varName v     match' (ExpDataRef _ _ v _) = match' v-    match' e = error $ "An unexpected LHS to an expression assign: " ++ show (fmap (const ()) e)+    match' e = error $ "An unexpected LHS to an expression assign: " ++ show (void (const ()) e)      -- Match and give the varname of LHSes which occur in subroutine calls-    match'' v@(ExpValue _ _ (ValVariable {})) = [varName v]-    match'' (ExpSubscript _ _ v@(ExpValue _ _ (ValVariable {})) _) = [varName v]-    match'' (ExpDataRef _ _ v _) = match'' v-    match'' e = onExprs e+    match'' v@(ExpValue _ _ ValVariable{})                      = [varName v]+    match'' (ExpSubscript _ _ v@(ExpValue _ _ ValVariable{}) _) = [varName v]+    match'' (ExpDataRef _ _ v _)                                = match'' v+    match'' e                                                   = onExprs e     -- Match and give the varname of LHSes which occur in function calls-    match v@(ExpValue _ _ (ValVariable {})) = [varName v]-    match (ExpSubscript _ _ v@(ExpValue _ _ (ValVariable {})) _) = [varName v]-    match (ExpDataRef _ _ e _) = match e-    match e = []+    match v@(ExpValue _ _ ValVariable{})                      = [varName v]+    match (ExpSubscript _ _ v@(ExpValue _ _ ValVariable{}) _) = [varName v]+    match (ExpDataRef _ _ e _)                                = match e+    match _                                                   = []  -- | Set of expressions used -- not defined -- by an AST-block. blockRhsExprs :: Data a => Block a -> [Expression a]@@ -302,23 +347,28 @@ statementRhsExprs (StExpressionAssign _ _ lhs rhs)  | ExpSubscript _ _ _ subs <- lhs = universeBi rhs ++ universeBi subs  | otherwise                      = universeBi rhs-statementRhsExprs (StDeclaration {}) = []+statementRhsExprs StDeclaration{} = [] statementRhsExprs (StIfLogical _ _ _ s) = statementRhsExprs s-statementRhsExprs (StDo _ _ _ l s) = (universeBi l) ++ doSpecRhsExprs s+statementRhsExprs (StDo _ _ _ l s') = universeBi l ++ doSpecRhsExprs s'   where doSpecRhsExprs (Just (DoSpecification _ _ s e1 e2)) =-           (e1 : (universeBi e2)) ++ statementRhsExprs s+           (e1 : universeBi e2) ++ statementRhsExprs s         doSpecRhsExprs Nothing = [] statementRhsExprs s = universeBi s  -- | Set of names used -- not defined -- by an AST-block.-blockVarUses :: Data a => Block (Analysis a) -> [Name]+blockVarUses :: forall a. Data a => Block (Analysis a) -> [Name] blockVarUses (BlStatement _ _ _ (StExpressionAssign _ _ lhs rhs))   | ExpSubscript _ _ _ subs <- lhs = allVars rhs ++ concatMap allVars (aStrip subs)   | otherwise                      = allVars rhs blockVarUses (BlDo _ _ _ _ _ (Just (DoSpecification _ _ (StExpressionAssign _ _ lhs rhs) e1 e2)) _ _)   | ExpSubscript _ _ _ subs <- lhs = allVars rhs ++ allVars e1 ++ maybe [] allVars e2 ++ concatMap allVars (aStrip subs)   | otherwise                      = allVars rhs ++ allVars e1 ++ maybe [] allVars e2-blockVarUses (BlStatement _ _ _ (StDeclaration {})) = []+blockVarUses (BlStatement _ _ _ st@StDeclaration{}) = concat [ rhsOfDecls d | d <- universeBi st ]+  where+    rhsOfDecls :: Data a => Declarator (Analysis a) -> [Name]+    rhsOfDecls (DeclVariable _ _ _ _ (Just e)) = allVars e+    rhsOfDecls (DeclArray _ _ _ _ _ (Just e)) = allVars e+    rhsOfDecls _ = [] blockVarUses (BlStatement _ _ _ (StCall _ _ f@(ExpValue _ _ (ValIntrinsic _)) _))   | Just uses <- intrinsicUses f = uses blockVarUses (BlStatement _ _ _ (StCall _ _ _ (Just aexps))) = allVars aexps@@ -328,7 +378,7 @@  -- | Set of names defined by an AST-block. blockVarDefs :: Data a => Block (Analysis a) -> [Name]-blockVarDefs b@(BlStatement _ _ _ st) = allLhsVars b+blockVarDefs b@BlStatement{} = allLhsVars b blockVarDefs (BlDo _ _ _ _ _ (Just doSpec) _ _)  = allLhsVarsDoSpec doSpec blockVarDefs _                      = [] @@ -347,7 +397,7 @@ -- return dummy arg names (defined, used) by intrinsic intrinsicDefsUses :: Expression (Analysis a) -> Maybe ([Name], [Name]) intrinsicDefsUses f = both (map (dummyArg (varName f))) <$> getIntrinsicDefsUses (srcName f) allIntrinsics-  where both f (x, y) = (f x, f y)+  where both f' (x, y) = (f' x, f' y)  -- Local variables: -- mode: haskell

@@ -1,20 +1,22 @@ -- | Analyse a program file and create basic blocks. -{-# LANGUAGE FlexibleContexts, PatternGuards, ScopedTypeVariables #-}+{-# LANGUAGE TupleSections, FlexibleContexts, PatternGuards, ScopedTypeVariables #-} module Language.Fortran.Analysis.BBlocks-  ( analyseBBlocks, genBBlockMap, showBBGr, showAnalysedBBGr, showBBlocks, bbgrToDOT, BBlockMap-  , genSuperBBGr, SuperBBGr, showSuperBBGr, superBBGrToDOT, superBBGrGraph, superBBGrClusters, superBBGrEntries-  , findLabeledBBlock )+  ( analyseBBlocks, genBBlockMap, showBBGr, showAnalysedBBGr, showBBlocks, bbgrToDOT, BBlockMap, ASTBlockNode, ASTExprNode+  , genSuperBBGr, SuperBBGr(..), showSuperBBGr, superBBGrToDOT, findLabeledBBlock, showBlock ) where -import Data.Generics.Uniplate.Data+import Prelude hiding (exp)+import Data.Generics.Uniplate.Data hiding (transform)+import Data.Char (toLower) import Data.Data+import Data.List (unfoldr, foldl') import Control.Monad-import Control.Monad.State.Lazy-import Control.Monad.Writer+import Control.Monad.State.Lazy hiding (fix)+import Control.Monad.Writer hiding (fix) import Text.PrettyPrint.GenericPretty (pretty, Out) import Language.Fortran.Analysis-import Language.Fortran.AST+import Language.Fortran.AST hiding (setName) import Language.Fortran.Util.Position import qualified Data.Map as M import qualified Data.IntMap as IM@@ -22,6 +24,7 @@ import Data.Graph.Inductive.PatriciaTree (Gr) import Data.List (intercalate) import Data.Maybe+import Data.Functor.Identity  -------------------------------------------------- @@ -48,16 +51,18 @@  -------------------------------------------------- +type ASTBlockNode = Int+ -- Insert unique labels on each AST-block for easier look-up later.-labelBlocks :: Data a => ProgramFile (Analysis a) -> State Int (ProgramFile (Analysis a))-labelBlocks gr = transform eachBlock gr+labelBlocks :: Data a => ProgramFile (Analysis a) -> State ASTBlockNode (ProgramFile (Analysis a))+labelBlocks = transform eachBlock   where-    eachBlock :: Data a => Block (Analysis a) -> State Int (Block (Analysis a))+    eachBlock :: Data a => Block (Analysis a) -> State ASTBlockNode (Block (Analysis a))     eachBlock b = do       n <- get-      put $ (n + 1)+      put (n + 1)       return . labelWithinBlocks $ setAnnotation ((getAnnotation b) { insLabel = Just n }) b-    transform :: Data a => TransFuncM (State Int) Block ProgramFile a+    transform :: Data a => TransFuncM (State ASTBlockNode) Block ProgramFile a     transform = transformBiM  -- A version of labelBlocks that works on all AST-blocks inside of a@@ -65,27 +70,27 @@ -- numbers. The reason that this function must exist is because -- additional AST-blocks are generated within the process of creating -- basic-block graphs, and must also be labelled.-labelBlocksInBBGr :: Data a => ProgramFile (Analysis a) -> State Int (ProgramFile (Analysis a))-labelBlocksInBBGr pf = transform (nmapM' (mapM eachBlock)) pf+labelBlocksInBBGr :: Data a => ProgramFile (Analysis a) -> State ASTBlockNode (ProgramFile (Analysis a))+labelBlocksInBBGr = transform (bbgrMapM (nmapM' (mapM eachBlock)))   where-    eachBlock :: Data a => Block (Analysis a) -> State Int (Block (Analysis a))+    eachBlock :: Data a => Block (Analysis a) -> State ASTBlockNode (Block (Analysis a))     eachBlock b       | a@Analysis { insLabel = Nothing } <- getAnnotation b = do           n <- get           put $ n + 1           return . analyseAllLhsVars1 . labelWithinBlocks $ setAnnotation (a { insLabel = Just n }) b       | otherwise = return . analyseAllLhsVars1 $ b-    transform :: Data a => (BBGr a -> State Int (BBGr a)) ->-                           ProgramFile a -> State Int (ProgramFile a)+    transform :: Data a => (BBGr a -> State ASTBlockNode (BBGr a)) ->+                           ProgramFile a -> State ASTBlockNode (ProgramFile a)     transform = transformBiM  -- Sets the label on each Index within a Block to match the Block, for -- later look-up. labelWithinBlocks :: forall a. Data a => Block (Analysis a) -> Block (Analysis a)-labelWithinBlocks = perBlock+labelWithinBlocks = perBlock'   where-    perBlock :: Block (Analysis a) -> Block (Analysis a)-    perBlock b =+    perBlock' :: Block (Analysis a) -> Block (Analysis a)+    perBlock' b =       case b of         BlStatement a s e st               -> BlStatement a s (mfill i e) (fill i st)         BlIf        a s e1 mn e2 bss el    -> BlIf        a s (mfill i e1) mn (mmfill i e2) bss el@@ -98,7 +103,7 @@     mfill i  = fmap (fill i)     mmfill i = fmap (fmap (fill i)) -    fill :: forall f. (Data (f (Analysis a))) => Maybe Int -> f (Analysis a) -> f (Analysis a)+    fill :: forall f. (Data (f (Analysis a))) => Maybe ASTBlockNode -> f (Analysis a) -> f (Analysis a)     fill Nothing  = id     fill (Just i) = transform perIndex       where@@ -110,16 +115,18 @@  -------------------------------------------------- +type ASTExprNode = Int+ -- Insert unique labels on each expression for easier look-up later.-labelExprs :: Data a => ProgramFile (Analysis a) -> State Int (ProgramFile (Analysis a))-labelExprs gr = transform eachExpr gr+labelExprs :: Data a => ProgramFile (Analysis a) -> State ASTExprNode (ProgramFile (Analysis a))+labelExprs = transform eachExpr   where-    eachExpr :: Data a => Expression (Analysis a) -> State Int (Expression (Analysis a))+    eachExpr :: Data a => Expression (Analysis a) -> State ASTExprNode (Expression (Analysis a))     eachExpr e = do       n <- get-      put $ (n + 1)+      put (n + 1)       return $ setAnnotation ((getAnnotation e) { insLabel = Just n }) e-    transform :: Data a => TransFuncM (State Int) Expression ProgramFile a+    transform :: Data a => TransFuncM (State ASTExprNode) Expression ProgramFile a     transform = transformBiM  -- A version of labelExprs that works on all expressions inside of a@@ -127,21 +134,21 @@ -- numbers. The reason that this function must exist is because -- additional expressions are generated within the process of creating -- basic-block graphs, and must also be labelled.-labelExprsInBBGr :: Data a => ProgramFile (Analysis a) -> State Int (ProgramFile (Analysis a))-labelExprsInBBGr pf = transformBB (nmapM' (transformExpr eachExpr)) pf+labelExprsInBBGr :: Data a => ProgramFile (Analysis a) -> State ASTExprNode (ProgramFile (Analysis a))+labelExprsInBBGr = transformBB (bbgrMapM (nmapM' (transformExpr eachExpr)))   where-    eachExpr :: Data a => Expression (Analysis a) -> State Int (Expression (Analysis a))+    eachExpr :: Data a => Expression (Analysis a) -> State ASTExprNode (Expression (Analysis a))     eachExpr e       | a@Analysis { insLabel = Nothing } <- getAnnotation e = do           n <- get           put $ n + 1           return $ setAnnotation (a { insLabel = Just n }) e       | otherwise = return e-    transformBB :: Data a => (BBGr a -> State Int (BBGr a)) ->-                             ProgramFile a -> State Int (ProgramFile a)+    transformBB :: Data a => (BBGr a -> State ASTExprNode (BBGr a)) ->+                             ProgramFile a -> State ASTExprNode (ProgramFile a)     transformBB = transformBiM-    transformExpr :: Data a => (Expression (Analysis a) -> State Int (Expression (Analysis a))) ->-                               [Block (Analysis a)] -> State Int [Block (Analysis a)]+    transformExpr :: Data a => (Expression (Analysis a) -> State ASTExprNode (Expression (Analysis a))) ->+                               [Block (Analysis a)] -> State ASTExprNode [Block (Analysis a)]     transformExpr = transformBiM  --------------------------------------------------@@ -154,45 +161,49 @@   where     bs  =       case pu of-        PUMain _ _ _ bs _ -> bs;-        PUSubroutine _ _ _ _ _ bs _ -> bs;-        PUFunction _ _ _ _ _ _ _ bs _ -> bs+        PUMain _ _ _ bs' _ -> bs';+        PUSubroutine _ _ _ _ _ bs' _ -> bs';+        PUFunction _ _ _ _ _ _ _ bs' _ -> bs'         _ -> []     bbs = execBBlocker (processBlocks bs)     fix = delEmptyBBlocks . delUnreachable . insExitEdges pu lm . delInvalidExits . insEntryEdges pu-    gr  = fix (insEdges (newEdges bbs) (bbGraph bbs))-    pu' = setAnnotation ((getAnnotation pu) { bBlocks = Just gr }) pu+    gr  = bbgrMap (fix . insEdges (newEdges bbs)) $ bbGraph bbs+    gr' = gr { bbgrEntries = [0], bbgrExits = [-1] } -- conventional entry/exit blocks+    pu' = setAnnotation ((getAnnotation pu) { bBlocks = Just gr' }) pu     lm  = labelMap bbs  -- Create node 0 "the start node" and link it -- for now assume only one entry+insEntryEdges :: (Data a, DynGraph gr) => ProgramUnit (Analysis a) -> gr [Block (Analysis a)] () -> gr [Block (Analysis a)] () insEntryEdges pu = insEdge (0, 1, ()) . insNode (0, bs)   where     bs = genInOutAssignments pu False  -- create assignments of the form "x = f[1]" or "f[1] = x" at the -- entry/exit bblocks.+genInOutAssignments :: Data a => ProgramUnit (Analysis a) -> Bool -> [Block (Analysis a)] genInOutAssignments pu exit-  | exit, PUFunction _ _ _ _ _ _ _ _ _ <- pu = zipWith genAssign (genVar a0 noSrcSpan fn:vs) [0..]-  | otherwise                                = zipWith genAssign vs [1..]+  | exit, PUFunction{} <- pu = zipWith genAssign (genVar a0 noSrcSpan fn:vs) [(0::Integer)..]+  | otherwise                = zipWith genAssign vs [(1::Integer)..]   where     Named fn      = puName pu     name i        = fn ++ "[" ++ show i ++ "]"     a0            = head $ initAnalysis [prevAnnotation a]     (a, s, vs)    = case pu of-      PUFunction _ _ _ _ _ (Just (AList a s vs)) _ _ _ -> (a, s, vs)-      PUSubroutine _ _ _ _ (Just (AList a s vs)) _ _   -> (a, s, vs)-      PUFunction a s _ _ _ Nothing _ _ _               -> (a, s, [])-      PUSubroutine a s _ _ Nothing _ _                 -> (a, s, [])+      PUFunction _ _ _ _ _ (Just (AList a' s' vs')) _ _ _ -> (a', s', vs')+      PUSubroutine _ _ _ _ (Just (AList a' s' vs')) _ _   -> (a', s', vs')+      PUFunction a' s' _ _ _ Nothing _ _ _               -> (a', s', [])+      PUSubroutine a' s' _ _ Nothing _ _                 -> (a', s', [])       _                                                -> (error "genInOutAssignments", error "genInOutAssignments", [])     genAssign v i = analyseAllLhsVars1 $ BlStatement a0 s Nothing (StExpressionAssign a0 s vl vr)       where         (vl, vr) = if exit then (v', v) else (v, v')         v'       = case v of-          ExpValue a' s (ValVariable _) -> genVar a0 s (name i)-          _               -> error $ "unhandled genAssign case: " ++ show (fmap (const ()) v)+          ExpValue _ s' (ValVariable _) -> genVar a0 s' (name i)+          _               -> error $ "unhandled genAssign case: " ++ show (void (const ()) v)  -- Remove exit edges for bblocks where standard construction doesn't apply.+delInvalidExits :: DynGraph gr => gr [Block a] b -> gr [Block a] b delInvalidExits gr = flip delEdges gr $ do   n  <- nodes gr   bs <- maybeToList $ lab gr n@@ -201,40 +212,81 @@   return $ toEdge le  -- Insert exit edges for bblocks with special handling.+insExitEdges :: (Data a, DynGraph gr) => ProgramUnit (Analysis a) -> M.Map String Node -> gr [Block (Analysis a)] () -> gr [Block (Analysis a)] () insExitEdges pu lm gr = flip insEdges (insNode (-1, bs) gr) $ do   n <- nodes gr-  guard $ null (out gr n)-  bs <- maybeToList $ lab gr n-  n' <- examineFinalBlock lm bs+  bs' <- maybeToList $ lab gr n+  guard $ null (out gr n) || isFinalBlockExceptionalCtrlXfer bs'+  n' <- examineFinalBlock lm bs'   return (n, n', ())   where     bs = genInOutAssignments pu True +-- Given a list of ControlPairs for a StRead, return (if any exists)+-- the expression accompanying an END or ERR, respectively+getReadCtrlXfers :: [ControlPair a] -> (Maybe (Expression a), Maybe (Expression a))+getReadCtrlXfers = foldl' handler (Nothing, Nothing)+  where+    handler r@(r1, r2) (ControlPair _ _ ms e) = case ms of+      Nothing -> r+      Just s  ->+        case map toLower s of+          "end" -> (Just e, r2)+          "err" -> (r1, Just e)+          _     -> r+ -- Find target of Goto statements (Return statements default target to -1).+examineFinalBlock :: Num a1 => M.Map String a1 -> [Block a2] -> [a1] examineFinalBlock lm bs@(_:_)   | BlStatement _ _ _ (StGotoUnconditional _ _ k) <- last bs = [lookupBBlock lm k]   | BlStatement _ _ _ (StGotoAssigned _ _ _ ks)   <- last bs = map (lookupBBlock lm) (maybe [] aStrip ks)   | BlStatement _ _ _ (StGotoComputed _ _ ks _)   <- last bs = map (lookupBBlock lm) (aStrip ks)-  | BlStatement _ _ _ (StReturn _ _ _)            <- last bs = [-1]+  | BlStatement _ _ _ StReturn{}            <- last bs = [-1]   | BlStatement _ _ _ (StIfArithmetic _ _ _ k1 k2 k3) <- last bs =       [lookupBBlock lm k1, lookupBBlock lm k2, lookupBBlock lm k3]+  | BlStatement _ _ _ (StRead _ _ cs _) <- last bs =+      let (me, mr) = getReadCtrlXfers $ aStrip cs+          f = maybe [] $ \v -> [lookupBBlock lm v]+      in  f me ++ f mr examineFinalBlock _ _                                        = [-1]  -- True iff the final block in the list is an explicit control transfer.+isFinalBlockCtrlXfer :: [Block a] -> Bool isFinalBlockCtrlXfer bs@(_:_)-  | BlStatement _ _ _ (StGotoUnconditional {}) <- last bs = True-  | BlStatement _ _ _ (StGotoAssigned {})      <- last bs = True-  | BlStatement _ _ _ (StGotoComputed {})      <- last bs = True-  | BlStatement _ _ _ (StReturn {})            <- last bs = True-  | BlStatement _ _ _ (StIfArithmetic {})      <- last bs = True-isFinalBlockCtrlXfer _                                    = False+  | BlStatement _ _ _ StGotoUnconditional{} <- last bs = True+  | BlStatement _ _ _ StGotoAssigned{}      <- last bs = True+  | BlStatement _ _ _ StReturn{}            <- last bs = True+  | BlStatement _ _ _ StIfArithmetic{}      <- last bs = True+  -- Note that StGotoComputed is not handled here since it+  -- is not an explicit control transfer if the expression+  -- does not index into one of the labels, in which case+  -- it acts as a StContinue+isFinalBlockCtrlXfer _                                 = False -lookupBBlock lm (ExpValue _ _ (ValInteger l)) = (-1) `fromMaybe` M.lookup l lm+-- True iff the final block in the list has an control transfer+-- with exceptional circumstances, like a StGotoComputed or a StRead+isFinalBlockExceptionalCtrlXfer :: [Block a] -> Bool+isFinalBlockExceptionalCtrlXfer bs@(_:_)+  | BlStatement _ _ _ StGotoComputed{} <- last bs = True+  | BlStatement _ _ _ StRead{}         <- last bs = True+isFinalBlockExceptionalCtrlXfer _                   = False++-- Drop any '0' that appear at the beginning of a label since+-- labels like "40" and "040" are considered equivalent.+dropLeadingZeroes :: String -> String+dropLeadingZeroes = dropWhile (== '0')++lookupBBlock :: Num a1 => M.Map String a1 -> Expression a2 -> a1+lookupBBlock lm a =+  case a of+    ExpValue _ _ (ValInteger l) -> (-1) `fromMaybe` M.lookup (dropLeadingZeroes l) lm -- This occurs if a variable is being used for a label, e.g., from a Fortran 77 ASSIGN statement-lookupBBlock lm (ExpValue _ _ (ValVariable l)) = (-1) `fromMaybe` M.lookup l lm+    ExpValue _ _ (ValVariable l) -> (-1) `fromMaybe` M.lookup l lm+    _ -> error "unhandled lookupBBlock"  -- Seek out empty bblocks with a single entrance and a single exit -- edge, and remove them, re-establishing the edges without them.+delEmptyBBlocks :: (Foldable t, DynGraph gr) => gr (t a) b -> gr (t a) b delEmptyBBlocks gr   | (n, s, t, l):_ <- candidates = delEmptyBBlocks . insEdge (s, t, l) . delNode n $ gr   | otherwise                    = gr@@ -247,6 +299,7 @@       return (n, s, t, l)  -- Delete unreachable nodes.+delUnreachable :: DynGraph gr => gr a b -> gr a b delUnreachable gr = subgraph (reachable 0 gr) gr  --------------------------------------------------@@ -261,7 +314,8 @@                      , newEdges :: [LEdge ()] }  -- Initial state-bbs0 = BBS { bbGraph = empty, curBB = [], curNode = 1+bbs0 :: BBState a+bbs0 = BBS { bbGraph = bbgrEmpty, curBB = [], curNode = 1            , labelMap = M.empty, nums = [2..], tempNums = [0..]            , newEdges = [] } @@ -283,7 +337,7 @@   startN <- gets curNode   mapM_ perBlock bs   endN   <- gets curNode-  modify $ \ st -> st { bbGraph = insNode (endN, reverse (curBB st)) (bbGraph st)+  modify $ \ st -> st { bbGraph = bbgrMap (insNode (endN, reverse (curBB st))) (bbGraph st)                       , curBB   = [] }   return (startN, endN) @@ -295,14 +349,14 @@ -- invariant: curBB is in reverse order perBlock b@(BlIf _ _ _ _ exps bss _) = do   processLabel b-  exps' <- forM (map fromJust . filter isJust $ exps) processFunctionCalls+  _ <- forM (catMaybes . filter isJust $ exps) processFunctionCalls   addToBBlock $ stripNestedBlocks b   (ifN, _) <- closeBBlock    -- go through nested AST-blocks   startEnds <- forM bss $ \ bs -> do     (thenN, endN) <- processBlocks bs-    genBBlock+    _ <- genBBlock     return (thenN, endN)    -- connect all the new bblocks with edges, link to subsequent bblock labeled nxtN@@ -319,7 +373,7 @@   -- go through nested AST-blocks   startEnds <- forM bss $ \ bs -> do     (caseN, endN) <- processBlocks bs-    genBBlock+    _ <- genBBlock     return (caseN, endN)    -- connect all the new bblocks with edges, link to subsequent bblock labeled nxtN@@ -328,77 +382,102 @@   -- if there is no "CASE DEFAULT"-statement then we need an edge from selectN -> nxtN   createEdges $ if any isNothing inds then es else (selectN, nxtN, ()):es +perBlock b@(BlStatement _ _ _ (StGotoComputed _ _ _ exp)) = do+  processLabel b+  _ <- processFunctionCalls exp+  addToBBlock b+  (gotoN, nxtN) <- closeBBlock+  createEdges [(gotoN, nxtN, ())]+ perBlock b@(BlStatement a ss _ (StIfLogical _ _ exp stm)) = do   processLabel b-  exp' <- processFunctionCalls exp+  _ <- processFunctionCalls exp   addToBBlock $ stripNestedBlocks b    -- start a bblock for the nested statement inside the If   (ifN, thenN) <- closeBBlock    -- build pseudo-AST-block to contain nested statement-  processBlocks [BlStatement a ss Nothing stm]-  endN <- gets curNode+  _ <- processBlocks [BlStatement a{ insLabel = Nothing } ss Nothing stm]+  _ <- gets curNode    -- connect all the new bblocks with edges, link to subsequent bblock labeled nxtN   nxtN <- genBBlock   createEdges [(ifN, thenN, ()), (ifN, nxtN, ()), (thenN, nxtN, ())] -perBlock b@(BlStatement _ _ _ (StIfArithmetic {})) =+perBlock b@(BlStatement _ _ _ StIfArithmetic{}) =   -- Treat an arithmetic if similarly to a goto   processLabel b >> addToBBlock b >> closeBBlock_-perBlock b@(BlDo _ _ mlab _ _ (Just spec) bs _) = do+perBlock b@(BlDo _ _ _ _ _ (Just spec) bs _) = do   let DoSpecification _ _ (StExpressionAssign _ _ _ e1) e2 me3 = spec-  e1'  <- processFunctionCalls e1-  e2'  <- processFunctionCalls e2-  me3' <- case me3 of Just e3 -> Just `fmap` processFunctionCalls e3; Nothing -> return Nothing+  _  <- processFunctionCalls e1+  _  <- processFunctionCalls e2+  _  <- case me3 of Just e3 -> Just `fmap` processFunctionCalls e3; Nothing -> return Nothing   perDoBlock Nothing b bs perBlock b@(BlDo _ _ _ _ _ Nothing bs _) = perDoBlock Nothing b bs perBlock b@(BlDoWhile _ _ _ _ _ exp bs _) = perDoBlock (Just exp) b bs-perBlock b@(BlStatement _ _ _ (StReturn {})) =+perBlock b@(BlStatement _ _ _ StReturn{}) =   processLabel b >> addToBBlock b >> closeBBlock_-perBlock b@(BlStatement _ _ _ (StGotoUnconditional {})) =+perBlock b@(BlStatement _ _ _ StGotoUnconditional{}) =   processLabel b >> addToBBlock b >> closeBBlock_-perBlock b@(BlStatement a s l (StCall a' s' cn@(ExpValue _ _ _) Nothing)) = do+perBlock b@(BlStatement _ _ _ (StCall _ _ ExpValue{} Nothing)) = do   (prevN, callN) <- closeBBlock   -- put StCall in a bblock by itself   addToBBlock b   (_, nextN) <- closeBBlock   createEdges [ (prevN, callN, ()), (callN, nextN, ()) ]-perBlock b@(BlStatement a s l (StCall a' s' cn@(ExpValue _ _ _) (Just aargs))) = do+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   (prevN, formalN) <- closeBBlock    -- create bblock that assigns formal parameters (n[1], n[2], ...)   case l of-    Just (ExpValue _ _ (ValInteger l)) -> insertLabel l formalN -- label goes here, if present-    _                                -> return ()+    Just (ExpValue _ _ (ValInteger l')) -> insertLabel l' formalN -- label goes here, if present+    _                                   -> return ()   let name i   = varName cn ++ "[" ++ show i ++ "]"-  let formal (ExpValue a s (ValVariable _)) i = ExpValue a s (ValVariable (name i))-      formal e i                              = ExpValue a s (ValVariable (name i))-        where a = getAnnotation e; s = getSpan e-  forM_ (zip exps [1..]) $ \ (e, i) -> do-    e' <- processFunctionCalls e-    addToBBlock . analyseAllLhsVars1 $ BlStatement a s Nothing (StExpressionAssign a' s' (formal e' i) e')-  (_, dummyCallN) <- closeBBlock+  let formal (ExpValue a'' s'' (ValVariable _)) i = genVar a''{ insLabel = Nothing } s'' (name i)+      formal e i                                  = genVar a''{ insLabel = Nothing } s'' (name i)+        where a'' = getAnnotation e; s'' = getSpan e+  forM_ (zip exps [(1::Integer)..]) $ \ (e, i) -> do+    e' <- processFunctionCalls e -- may generate additional bblocks+    let b = BlStatement a{ insLabel = Nothing } s l (StExpressionAssign a' s' (formal e' i) e')+    addToBBlock $ analyseAllLhsVars1 b -  -- create "dummy call" bblock with no parameters in the StCall AST-node.-  addToBBlock . analyseAllLhsVars1 $ BlStatement a s Nothing (StCall a' s' cn Nothing)+  (formalN', dummyCallN) <- closeBBlock+  -- formalN' may differ from formalN when additional bblocks were+  -- generated by processFunctionCalls.++  let dummyArgs = map (Argument a0 s' Nothing) (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))   (_, returnedN) <- closeBBlock    -- re-assign the variables using the values of the formal parameters, if possible   -- (because call-by-reference)-  forM_ (zip exps [1..]) $ \ (e, i) ->+  forM_ (zip exps [(1::Integer)..]) $ \ (e, i) ->     -- this is only possible for l-expressions-    if isLExpr e then-      addToBBlock . analyseAllLhsVars1 $ BlStatement a s Nothing (StExpressionAssign a' s' e (formal e i))-    else return ()+    (when (isLExpr e) $+      addToBBlock . analyseAllLhsVars1 $+        BlStatement a{ insLabel = Nothing } s l (StExpressionAssign a' s' e (formal e i)))   (_, nextN) <- closeBBlock    -- connect the bblocks-  createEdges [ (prevN, formalN, ()), (formalN, dummyCallN, ())+  createEdges [ (prevN, formalN, ()), (formalN', dummyCallN, ())               , (dummyCallN, returnedN, ()), (returnedN, nextN, ()) ] +perBlock b@(BlStatement _ _ _ (StRead _ _ cs _)) = do+  let (end, err) = getReadCtrlXfers $ aStrip cs++  processLabel b+  b' <- descendBiM processFunctionCalls b+  addToBBlock b'++  when (isJust end || isJust err) $ do+    (readN, nxtN) <- closeBBlock+    createEdges [(readN, nxtN, ())]+ perBlock b = do   processLabel b   b' <- descendBiM processFunctionCalls b@@ -414,9 +493,9 @@   case getLabel b of     Just (ExpValue _ _ (ValInteger l)) -> insertLabel l doN     _                                  -> return ()-  case repeatExpr of Just e -> processFunctionCalls e >> return (); Nothing -> return ()+  case repeatExpr of Just e -> void (processFunctionCalls e); Nothing -> return ()   addToBBlock $ stripNestedBlocks b-  closeBBlock+  _ <- closeBBlock   -- process nested bblocks inside of do-statement   (startN, endN) <- processBlocks bs   n' <- genBBlock@@ -433,7 +512,8 @@ processLabel _ = return ()  -- Inserts into labelMap-insertLabel l n = modify $ \ st -> st { labelMap = M.insert l n (labelMap st) }+insertLabel :: MonadState (BBState a) m => String -> Node -> m ()+insertLabel l n = modify $ \ st -> st { labelMap = M.insert (dropLeadingZeroes l) n (labelMap st) }  -- Puts an AST block into the current bblock. addToBBlock :: Block a -> BBlocker a ()@@ -443,10 +523,11 @@ closeBBlock :: BBlocker a (Node, Node) closeBBlock = do   n  <- gets curNode-  modify $ \ st -> st { bbGraph = insNode (n, reverse (curBB st)) (bbGraph st), curBB = [] }+  modify $ \ st -> st { bbGraph = bbgrMap (insNode (n, reverse (curBB st))) (bbGraph st), curBB = [] }   n' <- genBBlock   return (n, n')-closeBBlock_ = closeBBlock >> return ()+closeBBlock_ :: StateT (BBState a) Identity ()+closeBBlock_ = void closeBBlock  -- Starts up a new bblock. genBBlock :: BBlocker a Int@@ -456,23 +537,25 @@   return n'  -- Adds labeled-edge mappings.+createEdges :: MonadState (BBState a) m => [LEdge ()] -> m () createEdges es = modify $ \ st -> st { newEdges = es ++ newEdges st }  -- Generates a new node number. gen :: BBlocker a Int gen = do-  n:ns <- gets nums+  ~(n:ns) <- gets nums   modify $ \ s -> s { nums = ns }   return n  genTemp :: String -> BBlocker a String genTemp str = do-  n:ns <- gets tempNums+  ~(n:ns) <- gets tempNums   modify $ \ s -> s { tempNums = ns }   return $ "_" ++ str ++ "_t#" ++ show n  -- Strip nested code not necessary since it is duplicated in another -- basic block.+stripNestedBlocks :: Block a -> Block a stripNestedBlocks (BlDo a s l mn tl ds _ el)     = BlDo a s l mn tl ds [] el stripNestedBlocks (BlDoWhile a s l tl n e _ el)  = BlDoWhile a s l tl n e [] el stripNestedBlocks (BlIf a s l mn exps _ el)      = BlIf a s l mn exps [] el@@ -498,17 +581,15 @@    -- create bblock that assigns formal parameters (fn[1], fn[2], ...)   let name i   = varName fn ++ "[" ++ show i ++ "]"-  let setName n e = setAnnotation ((getAnnotation e) { uniqueName = Just n, sourceName = Just n }) e-  let formal (ExpValue a s (ValVariable _)) i = setName n $ ExpValue a0 s (ValVariable n)-        where n = name i-      formal e i                              = setName n $ ExpValue a0 s (ValVariable n)-        where a = getAnnotation e; s = getSpan e; n = name i-  forM_ (zip exps [1..]) $ \ (e, i) -> do+  let formal (ExpValue _ s'' (ValVariable _)) i = genVar a0 s'' $ name i+      formal e i                                = genVar a0 (getSpan e) $ name i++  forM_ (zip exps [(1::Integer)..]) $ \ (e, i) ->     addToBBlock . analyseAllLhsVars1 $ BlStatement a0 s Nothing (StExpressionAssign a' s' (formal e i) e)   (_, dummyCallN) <- closeBBlock -  let retV = setName (name 0) $ ExpValue a0 s (ValVariable (name 0))-  let dummyArgs = map (Argument a0 s' Nothing) (retV:map (uncurry formal) (zip exps [1..]))+  let retV = genVar a0 s $ name (0::Integer)+  let dummyArgs = map (Argument a0 s' Nothing) (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))@@ -516,13 +597,12 @@    -- re-assign the variables using the values of the formal parameters, if possible   -- (because call-by-reference)-  forM_ (zip exps [1..]) $ \ (e, i) ->+  forM_ (zip exps [(1::Integer)..]) $ \ (e, i) ->     -- this is only possible for l-expressions-    if isLExpr e then-      addToBBlock . analyseAllLhsVars1 $ BlStatement a0 s Nothing (StExpressionAssign a' s' e (formal e i))-    else return ()+    (when (isLExpr e) $+      addToBBlock . analyseAllLhsVars1 $ BlStatement a0 s Nothing (StExpressionAssign a' s' e (formal e i)))   tempName <- genTemp (varName fn)-  let temp = setName tempName $ ExpValue a0 s (ValVariable tempName)+  let temp = genVar a0 s tempName    addToBBlock . analyseAllLhsVars1 $ BlStatement a0 s Nothing (StExpressionAssign a0 s' temp retV)   (_, nextN) <- closeBBlock@@ -533,26 +613,15 @@   return temp processFunctionCall e = return e +extractExp :: Argument a -> Expression a extractExp (Argument _ _ _ exp) = exp  -------------------------------------------------- -- Supergraph: all program units in one basic-block graph -data SuperBBGr a = SuperBBGr { graph :: BBGr a-                             , clusters :: IM.IntMap ProgramUnitName-                             , entries :: M.Map PUName SuperNode }---- | Extract graph from SuperBBGr-superBBGrGraph :: SuperBBGr a -> BBGr a-superBBGrGraph = graph---- | Extract entry map from SuperBBGr-superBBGrEntries :: SuperBBGr a -> M.Map ProgramUnitName SuperNode-superBBGrEntries = entries---- | Extract cluster map from SuperBBGr-superBBGrClusters :: SuperBBGr a -> IM.IntMap ProgramUnitName-superBBGrClusters = clusters+data SuperBBGr a = SuperBBGr { superBBGrGraph :: BBGr a+                             , superBBGrClusters :: IM.IntMap ProgramUnitName+                             , superBBGrEntries :: M.Map PUName SuperNode }  type SuperNode = Node type SuperEdge = (SuperNode, SuperNode, ELabel)@@ -561,12 +630,14 @@ type ELabel = ()  genSuperBBGr :: forall a. Data a => BBlockMap (Analysis a) -> SuperBBGr (Analysis a)-genSuperBBGr bbm = SuperBBGr { graph = superGraph'', clusters = cmap, entries = entryMap }+genSuperBBGr bbm = SuperBBGr { superBBGrGraph = superGraph''+                             , superBBGrClusters = cmap+                             , superBBGrEntries = entryMap }   where     namedNodes   :: [((PUName, Node), NLabel a)]-    namedNodes   = [ ((name, n), bs) | (name, gr) <- M.toList bbm, (n, bs) <- labNodes gr ]+    namedNodes   = [ ((name, n), bs) | (name, gr) <- M.toList bbm, (n, bs) <- labNodes (bbgrGr gr) ]     namedEdges   :: [((PUName, Node), (PUName, Node), ELabel)]-    namedEdges   = [ ((name, n), (name, m), l) | (name, gr) <- M.toList bbm, (n, m, l) <- labEdges gr ]+    namedEdges   = [ ((name, n), (name, m), l) | (name, gr) <- M.toList bbm, (n, m, l) <- labEdges (bbgrGr gr) ]     superNodeMap :: M.Map (PUName, Node) SuperNode     superNodeMap = M.fromList $ zip (map fst namedNodes) [1..]     getSuperNode :: (PUName, Node) -> SuperNode@@ -585,7 +656,7 @@     -- Assumption: all StCalls appear by themselves in a bblock.     stCalls      :: [(SuperNode, String)]     stCalls      = [ (getSuperNode n, sub) | (n, [BlStatement _ _ _ (StCall _ _ e _)]) <- namedNodes-                                           , v@(ExpValue _ _ _)                        <- [e]+                                           , v@ExpValue{}                              <- [e]                                            , let sub = varName v                                            , Named sub `M.member` entryMap && Named sub `M.member` exitMap ]     stCallCtxts  :: [([SuperEdge], SuperNode, String, [SuperEdge])]@@ -603,25 +674,28 @@     mainEntry    :: SuperNode -- (possibly more than one, arbitrarily take first)     mainEntry:_  = [ n | (n, _) <- labNodes superGraph', null (pre superGraph' n) ]     -- Rename the main entry point to 0-    superGraph'' :: Gr (NLabel a) ELabel-    superGraph'' = delNode mainEntry .-                   insEdges [ (0, m, l) | (_, m, l) <- out superGraph' mainEntry ] .-                   insNode (0, []) $ superGraph'+    superGraph'' :: BBGr (Analysis a)+    superGraph'' = BBGr { bbgrGr = delNode mainEntry .+                                   insEdges [ (0, m, l) | (_, m, l) <- out superGraph' mainEntry ] .+                                   insNode (0, []) $ superGraph'+                        , bbgrEntries = (0:) . filter (/=mainEntry) . map snd . M.toList $ entryMap+                        , bbgrExits   = (-1:) . map snd . M.toList $ exitMap } +fromJustMsg :: String -> Maybe a -> a fromJustMsg _ (Just x) = x fromJustMsg msg _      = error msg  --------------------------------------------------  findLabeledBBlock :: String -> BBGr a -> Maybe Node-findLabeledBBlock lab gr =-  listToMaybe [ n | (n, bs) <- labNodes gr, b <- bs-                  , ExpValue _ _ (ValInteger lab') <- maybeToList (getLabel b)-                  , lab == lab' ]+findLabeledBBlock llab gr =+  listToMaybe [ n | (n, bs) <- labNodes (bbgrGr gr), b <- bs+                  , ExpValue _ _ (ValInteger llab') <- maybeToList (getLabel b)+                  , llab == llab' ]  -- | Show a basic block graph in a somewhat decent way. showBBGr :: (Out a, Show a) => BBGr a -> String-showBBGr gr = execWriter . forM (labNodes gr) $ \ (n, bs) -> do+showBBGr (BBGr gr _ _) = execWriter . forM (labNodes gr) $ \ (n, bs) -> do   let b = "BBLOCK " ++ show n ++ " -> " ++ show (map (\ (_, m, _) -> m) $ out gr n)   tell $ "\n\n" ++ b   tell $ "\n" ++ replicate (length b) '-' ++ "\n"@@ -629,23 +703,27 @@  -- | Show a basic block graph without the clutter showAnalysedBBGr :: (Out a, Show a) => BBGr (Analysis a) -> String-showAnalysedBBGr = showBBGr . nmap strip+showAnalysedBBGr = showBBGr . bbgrMap (nmap strip)   where     strip = map (fmap insLabel)  -- | Show a basic block supergraph showSuperBBGr :: (Out a, Show a) => SuperBBGr (Analysis a) -> String-showSuperBBGr = showAnalysedBBGr . graph+showSuperBBGr = showAnalysedBBGr . superBBGrGraph  -- | Pick out and show the basic block graphs in the program file analysis. showBBlocks :: (Data a, Out a, Show a) => ProgramFile (Analysis a) -> String showBBlocks pf = perPU =<< getPUs pf   where+    perPU PUComment{} = ""     perPU pu | Analysis { bBlocks = Just gr } <- getAnnotation pu =-      dashes ++ "\n" ++ p ++ "\n" ++ dashes ++ "\n" ++ showBBGr (nmap strip gr) ++ "\n\n"+      dashes ++ "\n" ++ p ++ "\n" ++ dashes ++ "\n" ++ showBBGr (bbgrMap (nmap strip) gr) ++ "\n\n"       where p = "| Program Unit " ++ show (puName pu) ++ " |"             dashes = replicate (length p) '-'-    perPU _ = ""+    perPU pu =+      dashes ++ "\n" ++ p ++ "\n" ++ dashes ++ "\n" ++ unlines (map (pretty . fmap insLabel) (programUnitBody pu)) ++ "\n\n"+      where p = "| Program Unit " ++ show (puName pu) ++ " |"+            dashes = replicate (length p) '-'     strip = map (fmap insLabel)     getPUs :: Data a => ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]     getPUs = universeBi@@ -656,35 +734,38 @@  -- | Output a supergraph in the GraphViz DOT format superBBGrToDOT :: SuperBBGr a -> String-superBBGrToDOT sgr = bbgrToDOT' (clusters sgr) (graph sgr)+superBBGrToDOT sgr = bbgrToDOT' (superBBGrClusters sgr) (superBBGrGraph sgr)  -- shared code for DOT output bbgrToDOT' :: IM.IntMap ProgramUnitName -> BBGr a -> String-bbgrToDOT' clusters gr = execWriter $ do+bbgrToDOT' clusters' (BBGr{ bbgrGr = gr }) = execWriter $ do   tell "strict digraph {\n"   tell "node [shape=box,fontname=\"Courier New\"]\n"-  let entryNodes = filter (\ n -> null (pre gr n)) (nodes gr)-  let nodes = bfsn entryNodes gr-  forM nodes $ \ n -> do+  let entryNodes = filter (null . pre gr) (nodes gr)+  let nodes' = bfsn entryNodes gr+  _ <- forM nodes' $ \ n -> do     let Just bs = lab gr n-    let mname = IM.lookup n clusters+    let mname = IM.lookup n clusters'     case mname of Just name -> do tell $ "subgraph \"cluster " ++ showPUName name ++ "\" {\n"                                   tell $ "label=\"" ++ showPUName name ++ "\"\n"-                                  tell $ "fontname=\"Courier New\"\nfontsize=24\n"+                                  tell "fontname=\"Courier New\"\nfontsize=24\n"                   _         -> return ()-    tell $ "bb" ++ show n ++ "[label=\"" ++ show n ++ "\\l" ++ (concatMap showBlock bs) ++ "\"]\n"+    tell $ "bb" ++ show n ++ "[label=\"" ++ show n ++ "\\l" ++ concatMap showBlock bs ++ "\"]\n"     when (null bs) . tell $ "bb" ++ show n ++ "[shape=circle]\n"     tell $ "bb" ++ show n ++ " -> {"-    forM (suc gr n) $ \ m -> tell (" bb" ++ show m)+    _ <- forM (suc gr n) $ \ m -> tell (" bb" ++ show m)     tell "}\n"     when (isJust mname) $ tell "}\n"   tell "}\n" +showPUName :: ProgramUnitName -> String showPUName (Named n) = n-showPUName (NamelessBlockData) = ".blockdata."-showPUName (NamelessMain) = ".main."+showPUName NamelessBlockData = ".blockdata."+showPUName NamelessMain = ".main."+showPUName NamelessComment = ".comment." --- Some helper functions to output some pseudo-code for readability+-- | Some helper functions to output some pseudo-code for readability.+showBlock :: Block a -> String showBlock (BlStatement _ _ mlab st)     | null (str :: String) = ""     | otherwise = showLab mlab ++ str ++ "\\l"@@ -703,7 +784,8 @@             aIntercalate ", " showAttr aattrs ++             aIntercalate ", " showDecl adecls         StDimension _ _ adecls       -> "dimension " ++ aIntercalate ", " showDecl adecls-        _                            -> ""+        StExit{}                     -> "exit"+        _                            -> "<unhandled statement: " ++ show (toConstr (fmap (const ()) st)) ++ ">" showBlock (BlIf _ _ mlab _ (Just e1:_) _ _) = showLab mlab ++ "if " ++ showExpr e1 ++ "\\l" showBlock (BlDo _ _ mlab _ _ (Just spec) _ _) =     showLab mlab ++ "do " ++ showExpr e1 ++ " <- " ++@@ -712,12 +794,16 @@       maybe "1" showExpr me4 ++ "\\l"   where DoSpecification _ _ (StExpressionAssign _ _ e1 e2) e3 me4 = spec showBlock (BlDo _ _ _ _ _ Nothing _ _) = "do"-showBlock _ = ""+showBlock (BlComment{})                = ""+showBlock b = "<unhandled block: " ++ show (toConstr (fmap (const ()) b)) ++ ">" +showAttr :: Attribute a -> String showAttr (AttrParameter _ _) = "parameter" showAttr (AttrPublic _ _) = "public" showAttr (AttrPrivate _ _) = "private"+showAttr (AttrProtected _ _) = "protected" showAttr (AttrAllocatable _ _) = "allocatable"+showAttr (AttrAsynchronous _ _) = "asynchronous" showAttr (AttrDimension _ _ aDimDecs) =   "dimension ( " ++ aIntercalate ", " showDim aDimDecs ++ " )" showAttr (AttrExternal _ _) = "external"@@ -729,66 +815,110 @@ showAttr (AttrPointer _ _) = "pointer" showAttr (AttrSave _ _) = "save" showAttr (AttrTarget _ _) = "target"+showAttr (AttrValue _ _) = "value"+showAttr (AttrVolatile _ _) = "volatile"+showAttr (AttrSuffix _ _ (SfxBind _ _ Nothing)) = "bind(c)"+showAttr (AttrSuffix _ _ (SfxBind _ _ (Just e))) = "bind(c,name=" ++ showExpr e ++ ")" -showLab Nothing = replicate 6 ' '-showLab (Just (ExpValue _ _ (ValInteger l))) = ' ':l ++ replicate (5 - length l) ' '+showLab :: Maybe (Expression a) -> String+showLab a =+  case a of+    Nothing -> replicate 6 ' '+    Just (ExpValue _ _ (ValInteger l)) -> ' ':l ++ replicate (5 - length l) ' '+    _ -> error "unhandled showLab" +showValue :: Value a -> Name showValue (ValVariable v)       = v showValue (ValIntrinsic v)      = v showValue (ValInteger v)        = v showValue (ValReal v)           = v showValue (ValComplex e1 e2)    = "( " ++ showExpr e1 ++ " , " ++ showExpr e2 ++ " )"-showValue _                     = ""+showValue (ValString s)         = "\\\"" ++ escapeStr s ++ "\\\""+showValue v                     = "<unhandled value: " ++ show (toConstr (fmap (const ()) v)) ++ ">" +escapeStr :: String -> String+escapeStr = map fst . unfoldr f . map (,False)+  where+    f []                = Nothing+    f ((c,False):cs)+      | c `elem` "\"\\" = Just (('\\', False), (c, True):cs)+    f ((c,_):cs)        = Just ((c, False), cs)++showExpr :: Expression a -> String showExpr (ExpValue _ _ v)         = showValue v showExpr (ExpBinary _ _ op e1 e2) = "(" ++ showExpr e1 ++ showOp op ++ showExpr e2 ++ ")" showExpr (ExpUnary _ _ op e)      = "(" ++ showUOp op ++ showExpr e ++ ")" showExpr (ExpSubscript _ _ e1 aexps) = showExpr e1 ++ "[" ++                                        aIntercalate ", " showIndex aexps ++ "]"-showExpr _                        = ""+showExpr e                        = "<unhandled expr: " ++ show (toConstr (fmap (const ()) e)) ++ ">" +showIndex :: Index a -> String showIndex (IxSingle _ _ _ i) = showExpr i showIndex (IxRange _ _ l u s) =   maybe "" showExpr l ++ -- Lower   ':' : maybe "" showExpr u ++ -- Upper-  maybe "" (\u -> ':' : showExpr u) s -- Stride+  maybe "" (\u' -> ':' : showExpr u') s -- Stride +showUOp :: UnaryOp -> String showUOp Plus = "+" showUOp Minus = "-" showUOp Not = "!"+-- needs a custom instance+showUOp (UnCustom x) = show x +showOp :: BinaryOp -> String showOp Addition = " + " showOp Multiplication = " * " showOp Subtraction = " - " showOp Division = " / "+showOp Concatenation = " // " showOp op = " ." ++ show op ++ ". " -showType (TypeSpec _ _ t (Just s)) = showBaseType t ++ "(selector)" -- ++ show s+showType :: TypeSpec a -> String+showType (TypeSpec _ _ t (Just _)) = showBaseType t ++ "(selector)" -- ++ show s showType (TypeSpec _ _ t Nothing)  = showBaseType t +showBaseType :: BaseType -> String showBaseType TypeInteger         = "integer" showBaseType TypeReal            = "real" showBaseType TypeDoublePrecision = "double" showBaseType TypeComplex         = "complex" showBaseType TypeDoubleComplex   = "doublecomplex" showBaseType TypeLogical         = "logical"-showBaseType TypeCharacter       = "character"-showBaseType (TypeCustom s)      = s+showBaseType (TypeCharacter l k) = case (l, k) of+  (Just cl, Just ki) -> "character(" ++ showCharLen cl ++ "," ++ ki ++ ")"+  (Just cl, Nothing) -> "character(" ++ showCharLen cl ++ ")"+  (Nothing, Just ki) -> "character(kind=" ++ ki ++ ")"+  (Nothing, Nothing) -> "character"+showBaseType (TypeCustom s)      = "type(" ++ s ++ ")"+showBaseType TypeByte            = "byte"+showBaseType ClassStar           = "class(*)"+showBaseType (ClassCustom s)     = "class(" ++ s ++ ")" -showDecl (DeclArray _ _ e adims length initial) =+showCharLen :: CharacterLen -> String+showCharLen CharLenStar = "*"+showCharLen CharLenColon = ":"+showCharLen CharLenExp  = "*" -- FIXME, possibly, with a more robust const-exp+showCharLen (CharLenInt i) = show i++showDecl :: Declarator a -> String+showDecl (DeclArray _ _ e adims length' initial) =   showExpr e ++     "(" ++ aIntercalate "," showDim adims ++ ")" ++-    maybe "" (\e -> "*" ++ showExpr e) length ++-    maybe "" (\e -> " = " ++ showExpr e) initial-showDecl (DeclVariable _ _ e length initial) =+    maybe "" (\e' -> "*" ++ showExpr e') length' +++    maybe "" (\e' -> " = " ++ showExpr e') initial+showDecl (DeclVariable _ _ e length' initial) =   showExpr e ++-    maybe "" (\e -> "*" ++ showExpr e) length ++-    maybe "" (\e -> " = " ++ showExpr e) initial+    maybe "" (\e' -> "*" ++ showExpr e') length' +++    maybe "" (\e' -> " = " ++ showExpr e') initial +showDim :: DimensionDeclarator a -> String showDim (DimensionDeclarator _ _ me1 me2) = maybe "" ((++":") . showExpr) me1 ++ maybe "" showExpr me2 +aIntercalate :: [a1] -> (t a2 -> [a1]) -> AList t a2 -> [a1] aIntercalate sep f = intercalate sep . map f . aStrip +noSrcSpan :: SrcSpan noSrcSpan = SrcSpan initPosition initPosition  --------------------------------------------------@@ -798,7 +928,7 @@ ufoldM' :: (Graph gr, Monad m) => (Context a b -> c -> m c) -> c -> gr a b -> m c ufoldM' f u g   | isEmpty g = return u-  | otherwise = f c =<< (ufoldM' f u g')+  | otherwise = f c =<< ufoldM' f u g'   where     (c,g') = matchAny g 

@@ -4,52 +4,66 @@ module Language.Fortran.Analysis.DataFlow   ( dominators, iDominators, DomMap, IDomMap   , postOrder, revPostOrder, preOrder, revPreOrder, OrderF-  , dataFlowSolver, showDataFlow, InOut, InOutMap, InF, OutF+  , dataFlowSolver, InOut, InOutMap, InF, OutF   , liveVariableAnalysis, reachingDefinitions   , genUDMap, genDUMap, duMapToUdMap, UDMap, DUMap   , genFlowsToGraph, FlowsGraph   , genVarFlowsToMap, VarFlowsMap+  , Constant(..), ParameterVarMap, ConstExpMap, genConstExpMap, analyseConstExps, analyseParameterVars   , genBlockMap, genDefMap, BlockMap, DefMap   , genCallMap, CallMap   , loopNodes, genBackEdgeMap, sccWith, BackEdgeMap   , genLoopNodeMap, LoopNodeMap   , genInductionVarMap, InductionVarMap   , genInductionVarMapByASTBlock, InductionVarMapByASTBlock-  , noPredNodes, genDerivedInductionMap, DerivedInductionMap, InductionExpr(..)+  , genDerivedInductionMap, DerivedInductionMap, InductionExpr(..)+  , showDataFlow, showFlowsDOT+  , BBNodeMap, BBNodeSet, ASTBlockNodeMap, ASTBlockNodeSet, ASTExprNodeMap, ASTExprNodeSet ) where +import Prelude hiding (init) import Data.Generics.Uniplate.Data import GHC.Generics import Data.Data import Control.Monad.State.Lazy+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 import qualified Data.Map as M import qualified Data.IntMap.Lazy as IM import qualified Data.Set as S import qualified Data.IntSet as IS-import Data.Graph.Inductive hiding (trc, dom)+import Data.Graph.Inductive hiding (trc, dom, order, inn, out, rc) import Data.Graph.Inductive.PatriciaTree (Gr)-import Data.Graph.Inductive.Query.BFS (bfen) import Data.Maybe import Data.List (foldl', foldl1', (\\), union, intersect)+import Control.Monad.Writer hiding (fix)  --------------------------------------------------+-- Better names for commonly used types+type BBNodeMap = IM.IntMap+type BBNodeSet = IS.IntSet+type ASTBlockNodeMap = IM.IntMap+type ASTBlockNodeSet = IS.IntSet+type ASTExprNodeMap = IM.IntMap+type ASTExprNodeSet = IS.IntSet  -- | DomMap : node -> dominators of node-type DomMap = IM.IntMap IS.IntSet+type DomMap = BBNodeMap BBNodeSet  -- | Compute dominators of each bblock in the graph. Node A dominates -- node B when all paths from the start node of that program unit must -- pass through node A in order to reach node B. That will be -- represented as the relation (B, [A, ...]) in the DomMap. dominators :: BBGr a -> DomMap-dominators gr = IM.map snd $ dataFlowSolver gr init revPostOrder inn out+dominators bbgr = IM.map snd $ dataFlowSolver bbgr init revPostOrder inn out   where+    gr        = bbgrGr bbgr     nodeSet   = IS.fromList $ nodes gr-    init n    = (nodeSet, nodeSet)+    init _    = (nodeSet, nodeSet)      inn outF n       | preNodes@(_:_) <- pre gr n = foldl1' IS.intersection . map outF $ preNodes@@ -58,7 +72,7 @@     out inF n                      = IS.insert n $ inF n  -- | IDomMap : node -> immediate dominator of node-type IDomMap = IM.IntMap Int+type IDomMap = BBNodeMap BBNode  -- | Compute the immediate dominator of each bblock in the graph. The -- immediate dominator is, in a sense, the 'closest' dominator of a@@ -66,14 +80,14 @@ -- dominated by node B if there does not exist any node C such that: -- node A dominates node C and node C dominates node B. iDominators :: BBGr a -> IDomMap-iDominators gr = IM.unions [ IM.fromList . flip iDom n $ gr | n <- noPredNodes gr ]+iDominators gr = IM.unions [ IM.fromList . flip iDom n $ bbgrGr gr | n <- bbgrEntries gr ]  -- | An OrderF is a function from graph to a specific ordering of nodes. type OrderF a = BBGr a -> [Node]  -- | The postordering of a graph outputs the label after traversal of children. postOrder :: OrderF a-postOrder gr = concatMap postorder . dff (noPredNodes gr) $ gr+postOrder gr = concatMap postorder . dff (bbgrEntries gr) $ bbgrGr gr  -- | Reversed postordering. revPostOrder :: OrderF a@@ -81,24 +95,19 @@  -- | The preordering of a graph outputs the label before traversal of children. preOrder :: OrderF a-preOrder gr = concatMap preorder . dff (noPredNodes gr) $ gr+preOrder gr = concatMap preorder . dff (bbgrEntries gr) $ bbgrGr gr  -- | Reversed preordering. revPreOrder :: OrderF a revPreOrder = reverse . preOrder --- | Compute the set of nodes with no predecessors.-noPredNodes :: Graph g => g a b -> [Node]--- noPredNodes = flip ufold [] $ \ ctx ns -> if null (pre' ctx) then node' ctx : ns else ns -- doesn't work, though it should-noPredNodes gr = filter (null . pre gr) (nodes gr)- --------------------------------------------------  -- | InOut : (dataflow into the bblock, dataflow out of the bblock) type InOut t    = (t, t)  -- | InOutMap : node -> (dataflow into node, dataflow out of node)-type InOutMap t = IM.IntMap (InOut t)+type InOutMap t = BBNodeMap (InOut t)  -- | InF, a function that returns the in-dataflow for a given node type InF t      = Node -> t@@ -117,22 +126,22 @@   where     ordNodes = order gr     initM    = IM.fromList [ (n, initF n) | n <- ordNodes ]-    step m   = IM.fromList [ (n, (inF (snd . get m) n, outF (fst . get m) n)) | n <- ordNodes ]-    get m n  = fromJustMsg ("dataFlowSolver: get " ++ show (n)) $ IM.lookup n m+    step m   = IM.fromList [ (n, (inF (snd . get' m) n, outF (fst . get' m) n)) | n <- ordNodes ]+    get' m n  = fromJustMsg ("dataFlowSolver: get " ++ show n) $ IM.lookup n m --- | Apply the iterative dataflow analysis method.-dataFlowSolver' :: Ord t => BBGr a            -- ^ basic block graph-                        -> (Node -> InOut t) -- ^ initialisation for in and out dataflows-                        -> OrderF a          -- ^ ordering function-                        -> (OutF t -> InF t) -- ^ compute the in-flow given an out-flow function-                        -> (InF t -> OutF t) -- ^ compute the out-flow given an in-flow function-                        -> [InOutMap t]        -- ^ dataflow steps-dataFlowSolver' gr initF order inF outF = iterate step initM-  where-    ordNodes = order gr-    initM    = IM.fromList [ (n, initF n) | n <- ordNodes ]-    step m   = IM.fromList [ (n, (inF (snd . get m) n, outF (fst . get m) n)) | n <- ordNodes ]-    get m n  = fromJustMsg ("dataFlowSolver': get " ++ show (n)) $ IM.lookup n m+-- Similar to above but return a list of states instead of just the final one.+--dataFlowSolver' :: Ord t => BBGr a            -- ^ basic block graph+--                        -> (Node -> InOut t) -- ^ initialisation for in and out dataflows+--                        -> OrderF a          -- ^ ordering function+--                        -> (OutF t -> InF t) -- ^ compute the in-flow given an out-flow function+--                        -> (InF t -> OutF t) -- ^ compute the out-flow given an in-flow function+--                        -> [InOutMap t]        -- ^ dataflow steps+--dataFlowSolver' gr initF order inF outF = iterate step initM+--  where+--    ordNodes = order gr+--    initM    = IM.fromList [ (n, initF n) | n <- ordNodes ]+--    step m   = IM.fromList [ (n, (inF (snd . get m) n, outF (fst . get m) n)) | n <- ordNodes ]+--    get m n  = fromJustMsg ("dataFlowSolver': get " ++ show (n)) $ IM.lookup n m  -------------------------------------------------- @@ -140,14 +149,14 @@ -- Each AST-block has been given a unique number label during analysis -- of basic blocks. The purpose of this map is to provide the ability -- to lookup AST-blocks by label.-type BlockMap a = IM.IntMap (Block (Analysis a))+type BlockMap a = ASTBlockNodeMap (Block (Analysis a))  -- | Build a BlockMap from the AST. This can only be performed after -- analyseBasicBlocks has operated, created basic blocks, and labeled -- all of the AST-blocks with unique numbers. genBlockMap :: Data a => ProgramFile (Analysis a) -> BlockMap a genBlockMap pf = IM.fromList [ (i, b) | gr         <- uni pf-                                      , (_, bs)    <- labNodes gr+                                      , (_, bs)    <- labNodes $ bbgrGr gr                                       , b          <- bs                                       , let Just i = insLabel (getAnnotation b) ]   where@@ -155,7 +164,7 @@     uni = universeBi  -- | DefMap : variable name -> { AST-block label }-type DefMap = M.Map Name IS.IntSet+type DefMap = M.Map Name ASTBlockNodeSet  -- | Build a DefMap from the BlockMap. This allows us to quickly look -- up the AST-block labels that wrote into the given variable.@@ -174,9 +183,9 @@ liveVariableAnalysis gr = dataFlowSolver gr (const (S.empty, S.empty)) revPreOrder inn out   where     inn outF b = (outF b S.\\ kill b) `S.union` gen b-    out innF b = S.unions [ innF s | s <- suc gr b ]-    kill b     = bblockKill (fromJustMsg "liveVariableAnalysis kill" $ lab gr b)-    gen b      = bblockGen (fromJustMsg "liveVariableAnalysis gen" $ lab gr b)+    out innF b = S.unions [ innF s | s <- suc (bbgrGr gr) b ]+    kill b     = bblockKill (fromJustMsg "liveVariableAnalysis kill" $ lab (bbgrGr gr) b)+    gen b      = bblockGen (fromJustMsg "liveVariableAnalysis gen" $ lab (bbgrGr gr) b)  -- | Iterate "KILL" set through a single basic block. bblockKill :: Data a => [Block (Analysis a)] -> S.Set Name@@ -184,17 +193,10 @@  -- | Iterate "GEN" set through a single basic block. bblockGen :: Data a => [Block (Analysis a)] -> S.Set Name-bblockGen bs = S.fromList . fst . foldl' f ([], []) $ zip (map blockGen bs) (map blockKill bs)+bblockGen bs = S.fromList . fst . foldl' f ([], []) $ map (blockGen &&& blockKill) bs   where     f (bbgen, bbkill) (gen, kill) = ((gen \\ bbkill) `union` bbgen, kill `union` bbkill) --- | Iterate "GEN" set through a single basic block.--- attempt to make this faster using sets internally (no obvious speedup though)-bblockGenFast :: Data a => [Block (Analysis a)] -> S.Set Name-bblockGenFast bs = fst . foldl' f (S.empty, S.empty) $ zip (map (S.fromList . blockGen) bs) (map (S.fromList . blockKill) bs)-  where-    f (bbgen, bbkill) (gen, kill) = ((gen S.\\ bbkill) `S.union` bbgen, kill `S.union` bbkill)- -- | "KILL" set for a single AST-block. blockKill :: Data a => Block (Analysis a) -> [Name] blockKill = blockVarDefs@@ -227,41 +229,41 @@ -- named v. Label A may reach another program point labeled P if there -- is at least one program path from label A to label P that does not -- redefine variable v.-reachingDefinitions :: Data a => DefMap -> BBGr (Analysis a) -> InOutMap IS.IntSet+reachingDefinitions :: Data a => DefMap -> BBGr (Analysis a) -> InOutMap ASTBlockNodeSet reachingDefinitions dm gr = dataFlowSolver gr (const (IS.empty, IS.empty)) revPostOrder inn out   where-    inn outF b = IS.unions [ outF s | s <- pre gr b ]+    inn outF b = IS.unions [ outF s | s <- pre (bbgrGr gr) b ]     out innF b = gen `IS.union` (innF b IS.\\ kill)-      where (gen, kill) = rdBblockGenKill dm (fromJustMsg "reachingDefinitions" $ lab gr b)+      where (gen, kill) = rdBblockGenKill dm (fromJustMsg "reachingDefinitions" $ lab (bbgrGr gr) b)  -- Compute the "GEN" and "KILL" sets for a given basic block.-rdBblockGenKill :: Data a => DefMap -> [Block (Analysis a)] -> (IS.IntSet, IS.IntSet)-rdBblockGenKill dm bs = foldl' f (IS.empty, IS.empty) $ zip (map gen bs) (map kill bs)+rdBblockGenKill :: Data a => DefMap -> [Block (Analysis a)] -> (ASTBlockNodeSet, ASTBlockNodeSet)+rdBblockGenKill dm bs = foldl' f (IS.empty, IS.empty) $ map (gen &&& kill) bs   where     gen b | null (allLhsVars b) = IS.empty           | otherwise           = IS.singleton . fromJustMsg "rdBblockGenKill" . insLabel . getAnnotation $ b     kill = rdDefs dm-    f (bbgen, bbkill) (gen, kill) =-      ((bbgen IS.\\ kill) `IS.union` gen, (bbkill IS.\\ gen) `IS.union` kill)+    f (bbgen, bbkill) (gen', kill') =+      ((bbgen IS.\\ kill') `IS.union` gen', (bbkill IS.\\ gen') `IS.union` kill')  -- Set of all AST-block labels that also define variables defined by AST-block b-rdDefs :: Data a => DefMap -> Block (Analysis a) -> IS.IntSet+rdDefs :: Data a => DefMap -> Block (Analysis a) -> ASTBlockNodeSet rdDefs dm b = IS.unions [ IS.empty `fromMaybe` M.lookup y dm | y <- allLhsVars b ]  --------------------------------------------------  -- | DUMap : definition -> { use }-type DUMap = IM.IntMap IS.IntSet+type DUMap = ASTBlockNodeMap ASTBlockNodeSet  -- | def-use map: map AST-block labels of defining AST-blocks to the -- AST-blocks that may use the definition.-genDUMap :: Data a => BlockMap a -> DefMap -> BBGr (Analysis a) -> InOutMap IS.IntSet -> DUMap+genDUMap :: Data a => BlockMap a -> DefMap -> BBGr (Analysis a) -> InOutMap ASTBlockNodeSet -> DUMap genDUMap bm dm gr rdefs = IM.unionsWith IS.union duMaps   where     -- duMaps for each bblock     duMaps = [ fst (foldl' inBBlock (IM.empty, is) bs) |                (n, (is, _)) <- IM.toList rdefs,-               let Just bs = lab gr n ]+               let Just bs = lab (bbgrGr gr) n ]     -- internal analysis within bblock; fold over list of AST-blocks     inBBlock (duMap, inSet) b = (duMap', inSet')       where@@ -272,13 +274,13 @@           where Just b' = IM.lookup i' bm         uses   = blockVarUses b         duMap' = IM.unionWith IS.union duMap bduMap-        gen b | null (allLhsVars b) = IS.empty-              | otherwise           = IS.singleton . fromJustMsg "genDUMap" . insLabel . getAnnotation $ b+        gen b' | null (allLhsVars b') = IS.empty+               | otherwise           = IS.singleton . fromJustMsg "genDUMap" . insLabel . getAnnotation $ b'         kill   = rdDefs dm-        inSet' = (inSet IS.\\ (kill b)) `IS.union` (gen b)+        inSet' = (inSet IS.\\ kill b) `IS.union` gen b  -- | UDMap : use -> { definition }-type UDMap = IM.IntMap IS.IntSet+type UDMap = ASTBlockNodeMap ASTBlockNodeSet  -- | Invert the DUMap into a UDMap duMapToUdMap :: DUMap -> UDMap@@ -288,18 +290,18 @@  -- | use-def map: map AST-block labels of variable-using AST-blocks to -- the AST-blocks that define those variables.-genUDMap :: Data a => BlockMap a -> DefMap -> BBGr (Analysis a) -> InOutMap IS.IntSet -> UDMap+genUDMap :: Data a => BlockMap a -> DefMap -> BBGr (Analysis a) -> InOutMap ASTBlockNodeSet -> UDMap genUDMap bm dm gr = duMapToUdMap . genDUMap bm dm gr  --------------------------------------------------  -- | Convert a UD or DU Map into a graph.-mapToGraph :: DynGraph gr => BlockMap a -> IM.IntMap IS.IntSet -> gr (Block (Analysis a)) ()-mapToGraph bm m = mkGraph nodes edges+mapToGraph :: DynGraph gr => BlockMap a -> ASTBlockNodeMap ASTBlockNodeSet -> gr (Block (Analysis a)) ()+mapToGraph bm m = mkGraph nodes' edges'   where-    nodes = [ (i, iLabel) | i <- IM.keys m ++ concatMap IS.toList (IM.elems m)+    nodes' = [ (i, iLabel) | i <- IM.keys m ++ concatMap IS.toList (IM.elems m)                           , let iLabel = fromJustMsg "mapToGraph" (IM.lookup i bm) ]-    edges = [ (i, j, ()) | (i, js) <- IM.toList m+    edges' = [ (i, j, ()) | (i, js) <- IM.toList m                          , j       <- IS.toList js ]  -- | FlowsGraph : nodes as AST-block (numbered by label), edges@@ -310,7 +312,7 @@ genFlowsToGraph :: Data a => BlockMap a                           -> DefMap                           -> BBGr (Analysis a)-                          -> InOutMap IS.IntSet -- ^ result of reaching definitions+                          -> InOutMap ASTBlockNodeSet -- ^ result of reaching definitions                           -> FlowsGraph a genFlowsToGraph bm dm gr = mapToGraph bm . genDUMap bm dm gr @@ -328,22 +330,115 @@     -- planning to make revDM a surjection, after I flatten-out Fortran functions     revDM = IM.fromListWith (curry fst) [ (i, v) | (v, is) <- M.toList dm, i <- IS.toList is ] -{-|-Finds the transitive closure of a directed graph.-Given a graph G=(V,E), its transitive closure is the graph:-G* = (V,E*) where E*={(i,j): i,j in V and there is a path from i to j in G}--}-tc :: (DynGraph gr) => gr a b -> gr a ()-tc g = newEdges `insEdges` insNodes ln empty+--------------------------------------------------++-- Integer arithmetic can be compile-time evaluated if we guard+-- against overflow, divide-by-zero. We must interpret the various+-- lexical forms of integers.+--+-- Floating point arithmetic requires knowing the target machine and+-- being very careful with all the possible effects of IEEE FP. Will+-- leave it alone for now.++-- conservative assumption: stay within bounds of signed 32-bit integer+minConst :: Integer+minConst = (-2::Integer) ^ (31::Integer)++maxConst :: Integer+maxConst = (2::Integer) ^ (31::Integer) - (1::Integer)++inBounds :: Integer -> Bool+inBounds x = minConst <= x && x <= maxConst++-- | Evaluate possible constant expressions within tree.+constantFolding :: Constant -> Constant+constantFolding c = case c of+  ConstBinary binOp a b | ConstInt x <- constantFolding a+                        , ConstInt y <- constantFolding b -> case binOp of+    Addition       | inBounds (x + y) -> ConstInt (x + y)+    Subtraction    | inBounds (x - y) -> ConstInt (x - y)+    Multiplication | inBounds (x * y) -> ConstInt (x * y)+    Division       | y /= 0           -> ConstInt (x `div` y)+    _                                 -> ConstBinary binOp (ConstInt x) (ConstInt y)+  ConstUnary Minus a | ConstInt x <- constantFolding a -> ConstInt (-x)+  ConstUnary Plus  a                                   -> constantFolding a+  _ -> c++-- | The map of all parameter variables and their corresponding values+type ParameterVarMap = M.Map Name Constant+-- | The map of all expressions and whether they are undecided (not+-- present in map), a constant value (Just Constant), or probably not+-- constant (Nothing).+type ConstExpMap = ASTExprNodeMap (Maybe Constant)++-- | Generate a constant-expression map with information about the+-- expressions (identified by insLabel numbering) in the ProgramFile+-- pf (must have analysis initiated & basic blocks generated) .+genConstExpMap :: forall a. Data a => ProgramFile (Analysis a) -> ConstExpMap+genConstExpMap pf = ceMap   where-    ln       = labNodes g-    newEdges = [ toLEdge (u, v) () | (u, _) <- ln, (_, v) <- bfen (outU g u) g ]-    outU gr  = map toEdge . out gr+    -- Generate map of 'parameter' variables, obtaining their value from ceMap below, lazily.+    pvMap = M.fromList $+      [ (varName v, getE e)+      | st@(StDeclaration _ _ (TypeSpec _ _ _ _) _ _) <- universeBi pf :: [Statement (Analysis a)]+      , AttrParameter _ _ <- universeBi st :: [Attribute (Analysis a)]+      , (DeclVariable _ _ v _ (Just e)) <- universeBi st ] +++      [ (varName v, getE e)+      | st@StParameter{} <- universeBi pf :: [Statement (Analysis a)]+      , (DeclVariable _ _ v _ (Just e)) <- universeBi st ]+    getV :: Expression (Analysis a) -> Maybe Constant+    getV e = constExp (getAnnotation e) `mplus` (join . flip M.lookup pvMap . varName $ e) +    -- Generate map of information about 'constant expressions'.+    ceMap = IM.fromList [ (label, doExpr e) | e <- universeBi pf, Just label <- [labelOf e] ]+    getE :: Expression (Analysis a) -> Maybe Constant+    getE = join . (flip IM.lookup ceMap <=< labelOf)+    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 _ _ (ValReal str)    -> Just $ ConstUninterpReal str+      ExpValue _ _ (ValVariable _)  -> getV e+      -- Recursively seek information about sub-expressions, relying on laziness.+      ExpBinary _ _ binOp e1 e2     -> constantFolding <$> liftM2 (ConstBinary binOp) (getE e1) (getE e2)+      ExpUnary _ _ unOp e'           -> constantFolding <$> ConstUnary unOp <$> getE e'+      _ -> Nothing++-- | Get constant-expression information and put it into the AST+-- analysis annotation. Must occur after analyseBBlocks.+analyseConstExps :: forall a. Data a => ProgramFile (Analysis a) -> ProgramFile (Analysis a)+analyseConstExps pf = pf'+  where+    ceMap = genConstExpMap pf+    -- transform both the AST and the basic block graph+    pf'   = transformBB (bbgrMap (nmap (transformExpr insertConstExp))) $ transformBi insertConstExp pf+    -- insert info about constExp into Expression annotation+    insertConstExp :: Expression (Analysis a) -> Expression (Analysis a)+    insertConstExp e = flip modifyAnnotation e $ \ a ->+      a { constExp = constExp a `mplus` join (flip IM.lookup ceMap =<< insLabel (getAnnotation e)) }+    -- utility functions for transforming expressions tucked away inside of the basic block graph+    transformBB :: (BBGr (Analysis a) -> BBGr (Analysis a)) -> ProgramFile (Analysis a) -> ProgramFile (Analysis a)+    transformBB = transformBi+    transformExpr :: (Expression (Analysis a) -> Expression (Analysis a)) ->+                     [Block (Analysis a)] -> [Block (Analysis a)]+    transformExpr = transformBi++-- | Annotate AST with constant-expression information based on given+-- ParameterVarMap.+analyseParameterVars :: forall a. Data a => ParameterVarMap -> ProgramFile (Analysis a) -> ProgramFile (Analysis a)+analyseParameterVars pvm = transformBi expr+  where+    expr :: Expression (Analysis a) -> Expression (Analysis a)+    expr e@(ExpValue _ _ ValVariable{})+      | Just con <- M.lookup (varName e) pvm = flip modifyAnnotation e $ \ a -> a { constExp = Just con }+    expr e = e+ -------------------------------------------------- --- | BackEdgeMap : node -> node-type BackEdgeMap = IM.IntMap Node+-- | BackEdgeMap : bblock node -> bblock node+type BackEdgeMap = BBNodeMap BBNode  -- | Find the edges that 'loop back' in the graph; ones where the -- target node dominates the source node. If the backedges are viewed@@ -351,7 +446,7 @@ genBackEdgeMap :: Graph gr => DomMap -> gr a b -> BackEdgeMap genBackEdgeMap domMap = IM.fromList . filter isBackEdge . edges   where-    isBackEdge (s, t) = t `IS.member` (fromJustMsg "genBackEdgeMap" $ s `IM.lookup` domMap)+    isBackEdge (s, t) = t `IS.member` fromJustMsg "genBackEdgeMap" (s `IM.lookup` domMap)  -- | For each loop in the program, find out which bblock nodes are -- part of the loop by looking through the backedges (m, n) where n is@@ -360,13 +455,13 @@ -- of interest. Intersect this with the strongly-connected component -- containing m, in case of 'improper' graphs with weird control -- transfers.-loopNodes :: Graph gr => BackEdgeMap -> gr a b -> [IS.IntSet]+loopNodes :: Graph gr => BackEdgeMap -> gr a b -> [BBNodeSet] loopNodes bedges gr = [     IS.fromList (n:intersect (sccWith n gr) (rdfs [m] (delNode n gr))) | (m, n) <- IM.toList bedges   ] --- | LoopNodeMap : node -> { node }-type LoopNodeMap = IM.IntMap IS.IntSet+-- | LoopNodeMap : bblock node -> { bblock node }+type LoopNodeMap = BBNodeMap BBNodeSet  -- | Similar to loopNodes except it creates a map from loop-header to -- the set of loop nodes, for each loop-header.@@ -382,7 +477,7 @@   c:_ -> c  -- | Map of loop header nodes to the induction variables within that loop.-type InductionVarMap = IM.IntMap (S.Set Name)+type InductionVarMap = BBNodeMap (S.Set Name)  -- | Basic induction variables are induction variables that are the -- most easily derived from the syntactic structure of the program:@@ -390,8 +485,8 @@ basicInductionVars :: Data a => BackEdgeMap -> BBGr (Analysis a) -> InductionVarMap basicInductionVars bedges gr = IM.fromListWith S.union [     (n, S.singleton v) | (_, n)      <- IM.toList bedges-                       , let Just bs = lab gr n-                       , b@(BlDo {}) <- bs+                       , let Just bs = lab (bbgrGr gr) n+                       , b@BlDo{}    <- bs                        , v           <- blockVarDefs b   ] @@ -402,19 +497,19 @@ genInductionVarMap = basicInductionVars  -- | InductionVarMapByASTBlock : AST-block label -> { name }-type InductionVarMapByASTBlock = IM.IntMap (S.Set Name)+type InductionVarMapByASTBlock = ASTBlockNodeMap (S.Set Name)  -- | Generate an induction variable map that is indexed by the labels -- on AST-blocks within those loops. genInductionVarMapByASTBlock :: forall a. Data a => BackEdgeMap -> BBGr (Analysis a) -> InductionVarMapByASTBlock genInductionVarMapByASTBlock bedges gr = loopsToLabs . genInductionVarMap bedges $ gr   where-    lnMap       = genLoopNodeMap bedges gr-    get         = fromMaybe (error "missing loop-header node") . flip IM.lookup lnMap-    astLabels n = [ i | b <- (universeBi :: Maybe [Block (Analysis a)] -> [Block (Analysis a)]) (lab gr n)+    lnMap       = genLoopNodeMap bedges $ bbgrGr gr+    get'        = fromMaybe (error "missing loop-header node") . flip IM.lookup lnMap+    astLabels n = [ i | b <- (universeBi :: Maybe [Block (Analysis a)] -> [Block (Analysis a)]) (lab (bbgrGr gr) n)                       , let Just i = insLabel (getAnnotation b) ]     loopsToLabs         = IM.fromListWith S.union . concatMap loopToLabs . IM.toList-    loopToLabs (n, ivs) = (map (,ivs) . astLabels) =<< IS.toList (get n)+    loopToLabs (n, ivs) = (map (,ivs) . astLabels) =<< IS.toList (get' n)  -- It's a 'lattice' but will leave it ungeneralised for the moment. data InductionExpr@@ -423,14 +518,21 @@   | IEBottom              -- too difficult   deriving (Show, Eq, Ord, Typeable, Generic, Data) -type DerivedInductionMap = IM.IntMap InductionExpr+type DerivedInductionMap = ASTExprNodeMap InductionExpr  data IEFlow = IEFlow { ieFlowVars :: M.Map Name InductionExpr, ieFlowExprs :: DerivedInductionMap }   deriving (Show, Eq, Ord, Typeable, Generic, Data) +ieFlowInsertVar :: Name -> InductionExpr -> IEFlow -> IEFlow ieFlowInsertVar v ie flow = flow { ieFlowVars = M.insert v ie (ieFlowVars flow) }++ieFlowInsertExpr :: ASTExprNode -> InductionExpr -> IEFlow -> IEFlow ieFlowInsertExpr i ie flow = flow { ieFlowExprs = IM.insert i ie (ieFlowExprs flow) }++emptyIEFlow :: IEFlow emptyIEFlow = IEFlow M.empty IM.empty++joinIEFlows :: [IEFlow] -> IEFlow joinIEFlows flows = IEFlow flowV flowE   where     flowV = M.unionsWith joinInductionExprs (map ieFlowVars flows)@@ -442,13 +544,13 @@ genDerivedInductionMap bedges gr = ieFlowExprs . joinIEFlows . map snd . IM.elems . IM.filterWithKey inLoop $ inOutMaps   where     bivMap = basicInductionVars bedges gr -- basic indvars indexed by loop header node-    loopNodeSet = IS.unions (loopNodes bedges gr) -- set of nodes within a loop+    loopNodeSet = IS.unions (loopNodes bedges $ bbgrGr gr) -- set of nodes within a loop     inLoop i _ = i `IS.member` loopNodeSet      step :: IEFlow -> Block (Analysis a) -> IEFlow     step flow b = case b of       BlStatement _ _ _ (StExpressionAssign _ _ lv@(ExpValue _ _ (ValVariable _)) rhs)-        | rhsLabel <- insLabel (getAnnotation rhs)+        | _ <- insLabel (getAnnotation rhs)         , flow''   <- ieFlowInsertVar (varName lv) (derivedInductionExpr flow' rhs) flow' -> stepExpr flow'' lv       _ -> flow'       where@@ -461,12 +563,12 @@         label = fromJustMsg "stepExpr" $ insLabel (getAnnotation e)      out :: InF IEFlow -> OutF IEFlow-    out inF node = foldl' step flow (fromJustMsg ("analyseDerivedIE out(" ++ show node ++ ")") $ lab gr node)+    out inF node = foldl' step flow (fromJustMsg ("analyseDerivedIE out(" ++ show node ++ ")") $ lab (bbgrGr gr) node)       where         flow = joinIEFlows [fst (initF node), inF node]      inn :: OutF IEFlow -> InF IEFlow-    inn outF node = joinIEFlows [ outF p | p <- pre gr node ]+    inn outF node = joinIEFlows [ outF p | p <- pre (bbgrGr gr) node ]      initF :: Node -> InOut IEFlow     initF node = case IM.lookup node bivMap of@@ -496,8 +598,8 @@   | lc == 0                 = IELinear rn rc (lo + ro)   | rc == 0                 = IELinear ln lc (lo + ro)   | otherwise               = IEBottom -- maybe for future...-addInductionExprs ie1 IETop = IETop-addInductionExprs IETop ie2 = IETop+addInductionExprs _ IETop = IETop+addInductionExprs IETop _ = IETop addInductionExprs _ _       = IEBottom  -- Negate an induction variable relationship.@@ -508,8 +610,8 @@  -- Combine two induction variable relationships through multiplication. mulInductionExprs :: InductionExpr -> InductionExpr -> InductionExpr-mulInductionExprs (IELinear "" lc lo) (IELinear rn rc ro) = IELinear rn (rc * lo) (ro * lo)-mulInductionExprs (IELinear ln lc lo) (IELinear "" rc ro) = IELinear ln (lc * ro) (lo * ro)+mulInductionExprs (IELinear "" _ lo) (IELinear rn rc ro) = IELinear rn (rc * lo) (ro * lo)+mulInductionExprs (IELinear ln lc lo) (IELinear "" _ ro) = IELinear ln (lc * ro) (lo * ro) mulInductionExprs _ IETop                                 = IETop mulInductionExprs IETop _                                 = IETop mulInductionExprs _ _                                     = IEBottom@@ -528,7 +630,7 @@ showDataFlow :: (Data a, Out a, Show a) => ProgramFile (Analysis a) -> String showDataFlow pf = perPU =<< uni pf   where-    uni = (universeBi :: Data a => ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)])+    uni = universeBi :: Data a => ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]     perPU pu | Analysis { bBlocks = Just gr } <- getAnnotation pu =       dashes ++ "\n" ++ p ++ "\n" ++ dashes ++ "\n" ++ dfStr gr ++ "\n\n"       where p = "| Program Unit " ++ show (puName pu) ++ " |"@@ -544,25 +646,54 @@                        , ("lva",          show (IM.toList $ lva gr))                        , ("rd",           show (IM.toList $ rd gr))                        , ("backEdges",    show bedges)-                       , ("topsort",      show (topsort gr))-                       , ("scc ",         show (scc gr))-                       , ("loopNodes",    show (loopNodes bedges gr))+                       , ("topsort",      show (topsort $ bbgrGr gr))+                       , ("scc ",         show (scc $ bbgrGr gr))+                       , ("loopNodes",    show (loopNodes bedges $ bbgrGr gr))                        , ("duMap",        show (genDUMap bm dm gr (rd gr)))                        , ("udMap",        show (genUDMap bm dm gr (rd gr)))-                       , ("flowsTo",      show (edges $ genFlowsToGraph bm dm gr (rd gr)))+                       , ("flowsTo",      show (edges flTo))                        , ("varFlowsTo",   show (genVarFlowsToMap dm (genFlowsToGraph bm dm gr (rd gr))))                        , ("ivMap",        show (genInductionVarMap bedges gr))                        , ("ivMapByAST",   show (genInductionVarMapByASTBlock bedges gr))-                       , ("noPredNodes",  show (noPredNodes gr))+                       , ("constExpMap",  show (genConstExpMap pf))+                       , ("entries",      show (bbgrEntries gr))+                       , ("exits",        show (bbgrExits gr))                        ] where-                           bedges = genBackEdgeMap (dominators gr) gr-    perPU _ = ""+                           bedges = genBackEdgeMap (dominators gr) $ bbgrGr gr+                           flTo = genFlowsToGraph bm dm gr (rd gr)++    perPU pu = dashes ++ "\n" ++ p ++ "\n" ++ dashes ++ "\n" ++ dfStr ++ "\n\n"+      where p = "| Program Unit " ++ show (puName pu) ++ " |"+            dashes = replicate (length p) '-'+            dfStr = (\ (l, x) -> '\n':l ++ ": " ++ x) =<< [+                      ("constExpMap",  show (genConstExpMap pf))+                    ]+     lva = liveVariableAnalysis     bm = genBlockMap pf     dm = genDefMap bm     rd = reachingDefinitions dm     cm = genCallMap pf +-- | Outputs a DOT-formatted graph showing flow-to data starting at+-- the given AST-Block node in the given Basic Block graph.+showFlowsDOT :: (Data a, Out a, Show a) => ProgramFile (Analysis a) -> BBGr (Analysis a) -> ASTBlockNode -> Bool -> String+showFlowsDOT pf bbgr astBlockId isFrom = execWriter $ do+  let bm = genBlockMap pf+      dm = genDefMap bm+      flowsTo = genFlowsToGraph bm dm bbgr (reachingDefinitions dm bbgr)+      flows | isFrom    = grev flowsTo+            | otherwise = flowsTo+  tell "strict digraph {\n"+  forM_ (bfsn [astBlockId] flows) $ \ n -> do+    let pseudocode = maybe "<N/A>" showBlock $ IM.lookup n bm+    tell "node [shape=box,fontname=\"Courier New\"]\n"+    tell $ "Bl" ++ show n ++ "[label=\"B" ++ show n ++ "\\l" ++ pseudocode ++ "\"]\n"+    tell $ "Bl" ++ show n ++ " -> {"+    forM_ (suc flows n) $ \ m -> tell (" Bl" ++ show m)+    tell "}\n"+  tell "}\n"+ --------------------------------------------------  -- | CallMap : program unit name -> { name of function or subroutine }@@ -571,7 +702,7 @@ -- | Create a call map showing the structure of the program. genCallMap :: Data a => ProgramFile (Analysis a) -> CallMap genCallMap pf = flip execState M.empty $ do-  let uP = (universeBi :: Data a => ProgramFile a -> [ProgramUnit a])+  let uP = universeBi :: Data a => ProgramFile a -> [ProgramUnit a]   forM_ (uP pf) $ \ pu -> do     let n = puName pu     let uS :: Data a => ProgramUnit a -> [Statement a]@@ -579,18 +710,31 @@     let uE :: Data a => ProgramUnit a -> [Expression a]         uE = universeBi     m <- get-    let ns = [ varName v | StCall _ _ v@(ExpValue _ _ _) _          <- uS pu ] ++-             [ varName v | ExpFunctionCall _ _ v@(ExpValue _ _ _) _ <- uE pu ]+    let ns = [ varName v | StCall _ _ v@ExpValue{} _          <- uS pu ] +++             [ varName v | ExpFunctionCall _ _ v@ExpValue{} _ <- uE pu ]     put $ M.insert n (S.fromList ns) m  -------------------------------------------------- --- helper: iterate until predicate is satisfied.+-- | Finds the transitive closure of a directed graph.+-- Given a graph G=(V,E), its transitive closure is the graph:+-- G* = (V,E*) where E*={(i,j): i,j in V and there is a path from i to j in G}+--tc :: (DynGraph gr) => gr a b -> gr a ()+--tc g = newEdges `insEdges` insNodes ln empty+--  where+--    ln       = labNodes g+--    newEdges = [ toLEdge (u, v) () | (u, _) <- ln, (_, v) <- bfen (outU g u) g ]+--    outU gr  = map toEdge . out gr++-- helper: iterate until predicate is satisfied; expects infinite list. converge :: (a -> a -> Bool) -> [a] -> a converge p (x:ys@(y:_))   | p x y     = y   | otherwise = converge p ys+converge _ [] = error "converge: empty list"+converge _ [_] = error "converge: finite list" +fromJustMsg :: String -> Maybe a -> a fromJustMsg _ (Just x) = x fromJustMsg msg _      = error msg 

@@ -11,26 +11,25 @@   ( analyseRenames, analyseRenamesWithModuleMap, rename, unrename, ModuleMap ) where -import Debug.Trace- import Language.Fortran.AST hiding (fromList) import Language.Fortran.Intrinsics import Language.Fortran.Analysis import Language.Fortran.ParserMonad (FortranVersion(..))  import Prelude hiding (lookup)-import Data.Maybe (maybe, fromMaybe)+import Data.Maybe (mapMaybe, maybe, fromMaybe) import qualified Data.List as L-import Data.Map (insert, union, empty, lookup, Map, fromList)+import Data.Map (insert, empty, lookup, Map) import qualified Data.Map.Strict as M+import Control.Monad (void) import Control.Monad.State.Strict import Data.Generics.Uniplate.Data import Data.Data+import Data.Functor.Identity (Identity)  --------------------------------------------------  type ModuleMap     = Map ProgramUnitName ModEnv-type NameMap       = Map String String -- DEPRECATED  type Renamer a     = State RenameState a -- the monad. data RenameState   = RenameState { langVersion :: FortranVersion@@ -47,17 +46,15 @@  -- | Annotate unique names for variable and function declarations and uses. analyseRenames :: Data a => ProgramFile (Analysis a) -> ProgramFile (Analysis a)-analyseRenames (ProgramFile mi pus) = ProgramFile mi pus'+analyseRenames (ProgramFile mi pus) = cleanupUseRenames $ ProgramFile mi pus'   where-    (Just pus', _) = runRenamer (skimProgramUnits pus >> renameSubPUs (Just pus))-                                (renameState0 (miVersion mi))+    (Just pus', _) = runRenamer (renameSubPUs (Just pus)) (renameState0 (miVersion mi))  -- | Annotate unique names for variable and function declarations and uses. With external module map. analyseRenamesWithModuleMap :: Data a => ModuleMap -> ProgramFile (Analysis a) -> ProgramFile (Analysis a)-analyseRenamesWithModuleMap mmap (ProgramFile mi pus) = ProgramFile mi pus'+analyseRenamesWithModuleMap mmap (ProgramFile mi pus) = cleanupUseRenames $ ProgramFile mi pus'   where-    (Just pus', _) = runRenamer (skimProgramUnits pus >> renameSubPUs (Just pus))-                                (renameState0 (miVersion mi)) { moduleMap = mmap }+    (Just pus', _) = runRenamer (renameSubPUs (Just pus)) (renameState0 (miVersion mi)) { moduleMap = mmap }  -- | Take the unique name annotations and substitute them into the actual AST. rename :: Data a => ProgramFile (Analysis a) -> ProgramFile (Analysis a)@@ -81,7 +78,7 @@  -- | Take a renamed program and undo the renames. unrename :: Data a => ProgramFile (Analysis a) -> ProgramFile (Analysis a)-unrename pf = trPU fPU . trE fE $ pf+unrename = trPU fPU . trE fE   where     trE :: Data a => (Expression (Analysis a) -> Expression (Analysis a)) -> ProgramFile (Analysis a) -> ProgramFile (Analysis a)     trE = transformBi@@ -93,9 +90,9 @@     trPU :: Data a => (ProgramUnit (Analysis a) -> ProgramUnit (Analysis a)) -> ProgramFile (Analysis a) -> ProgramFile (Analysis a)     trPU = transformBi     fPU :: Data a => ProgramUnit (Analysis a) -> ProgramUnit (Analysis a)-    fPU (PUFunction a s ty r n args res b subs)+    fPU (PUFunction a s ty r _ args res b subs)       | Just srcN <- sourceName a = PUFunction a s ty r srcN args res b subs-    fPU (PUSubroutine a s r n args b subs)+    fPU (PUSubroutine a s r _ args b subs)       | Just srcN <- sourceName a = PUSubroutine a s r srcN args b subs     fPU           pu              = pu @@ -107,40 +104,42 @@ programUnit (PUModule a s name blocks m_contains) = do   env0        <- initialEnv blocks   pushScope name env0-  blocks'     <- mapM renameDeclDecls blocks -- handle declarations+  blocks1     <- mapM renameModDecls blocks  -- handle declarations+  blocks2     <- mapM renameUseSt blocks1    -- handle use statements   m_contains' <- renameSubPUs m_contains     -- handle contained program units+  blocks3     <- mapM renameBlock blocks2    -- process all uses of functions/subroutine names   env         <- getEnv   addModEnv name env                         -- save the module environment   let a'      = a { moduleEnv = Just env }   -- also annotate it on the module   popScope-  return (PUModule a' s name blocks' m_contains')+  return (PUModule a' s name blocks3 m_contains')  programUnit (PUFunction a s ty rec name args res blocks m_contains) = do-  Just name'  <- getFromEnv name                  -- get renamed function name-  blocks1     <- mapM renameEntryPointDecl blocks -- rename any entry points-  env0        <- initialEnv blocks1-  pushScope name env0+  ~(Just name') <- getFromEnv name                  -- get renamed function name+  (blocks1, _)  <- returnBlocksEnv blocks name   blocks2     <- mapM renameEntryPointResultDecl blocks1 -- rename the result   res'        <- mapM renameGenericDecls res             -- variable(s) if needed   args'       <- mapM renameGenericDecls args -- rename arguments   blocks3     <- mapM renameDeclDecls blocks2 -- handle declarations   m_contains' <- renameSubPUs m_contains      -- handle contained program units   blocks4     <- mapM renameBlock blocks3     -- process all uses of variables+  let env     = M.singleton name (name', NTSubprogram)+  let a'      = a { moduleEnv = Just env }    -- also annotate it on the program unit   popScope-  let pu' = PUFunction a s ty rec name args' res' blocks4 m_contains'+  let pu' = PUFunction a' s ty rec name args' res' blocks4 m_contains'   return . setSourceName name . setUniqueName name' $ pu'  programUnit (PUSubroutine a s rec name args blocks m_contains) = do-  Just name'  <- getFromEnv name                  -- get renamed subroutine name-  blocks1     <- mapM renameEntryPointDecl blocks -- rename any entry points-  env0        <- initialEnv blocks1-  pushScope name env0+  ~(Just name') <- getFromEnv name                  -- get renamed subroutine name+  (blocks1, _)  <- returnBlocksEnv blocks name   args'       <- mapM renameGenericDecls args -- rename arguments   blocks2     <- mapM renameDeclDecls blocks1 -- handle declarations   m_contains' <- renameSubPUs m_contains      -- handle contained program units   blocks3     <- mapM renameBlock blocks2     -- process all uses of variables+  let env     = M.singleton name (name', NTSubprogram)+  let a'      = a { moduleEnv = Just env }    -- also annotate it on the program unit   popScope-  let pu' = PUSubroutine a s rec name args' blocks3 m_contains'+  let pu' = PUSubroutine a' s rec name args' blocks3 m_contains'   return . setSourceName name . setUniqueName name' $ pu'  programUnit (PUMain a s n blocks m_contains) = do@@ -154,19 +153,26 @@  programUnit pu = return pu +returnBlocksEnv :: Data a => [Block (Analysis a)]+                          -> String+                          -> StateT RenameState Identity ([Block (Analysis a)], ModEnv)+returnBlocksEnv bs n = do+  bs1 <- mapM renameEntryPointDecl bs+  e0 <- initialEnv bs1+  pushScope n e0+  return (bs1, e0)+ declarator :: forall a. Data a => RenamerFunc (Declarator (Analysis a)) declarator (DeclVariable a s e1 me2 me3) = do   e1' <- renameExpDecl e1-  me2' <- traverse renameExp me2-  me3' <- traverse renameExp me3+  me2' <- transformBiM (renameExp :: RenamerFunc (Expression (Analysis a))) me2+  me3' <- transformBiM (renameExp :: RenamerFunc (Expression (Analysis a))) me3   return $ DeclVariable a s e1' me2' me3' declarator (DeclArray a s e1 ddAList me2 me3) = do   e1' <- renameExpDecl e1-  let trans :: RenamerFunc (Expression (Analysis a)) -> RenamerFunc (AList DimensionDeclarator (Analysis a))-      trans = transformBiM-  ddAList' <- trans renameExp ddAList-  me2' <- traverse renameExp me2-  me3' <- traverse renameExp me3+  ddAList' <- transformBiM (renameExp :: RenamerFunc (Expression (Analysis a))) ddAList+  me2' <- transformBiM (renameExp :: RenamerFunc (Expression (Analysis a))) me2+  me3' <- transformBiM (renameExp :: RenamerFunc (Expression (Analysis a))) me3   return $ DeclArray a s e1' ddAList' me2' me3'  expression :: Data a => RenamerFunc (Expression (Analysis a))@@ -177,6 +183,7 @@ -- transformations.  -- Initial monad state.+renameState0 :: FortranVersion -> RenameState renameState0 v = RenameState { langVersion = v                              , intrinsics  = getVersionIntrinsics v                              , scopeStack  = []@@ -185,7 +192,8 @@                              , moduleMap   = empty }  -- Run the monad.-runRenamer m = runState m+runRenamer :: State a b -> a -> (b, a)+runRenamer = runState  -- Get a freshly generated number. getUniqNum :: Renamer Int@@ -201,38 +209,56 @@   n <- getUniqNum   return $ scope ++ "_" ++ var ++ show n -isModule (PUModule {}) = True; isModule _             = False--isUseStatement (BlStatement _ _ _ (StUse _ _ (ExpValue _ _ (ValVariable _)) _ _)) = True-isUseStatement _                                                                  = False+--isModule :: ProgramUnit a -> Bool+--isModule (PUModule {}) = True; isModule _             = False -isUseID (UseID {}) = True; isUseID _ = False+isUseStatement :: Block a -> Bool+isUseStatement (BlStatement _ _ _ (StUse _ _ (ExpValue _ _ (ValVariable _)) _ _ _)) = True+isUseStatement _                                                                    = False  -- Generate an initial environment for a scope based upon any Use -- statements in the blocks.-initialEnv :: Data a => [Block (Analysis a)] -> Renamer ModEnv+initialEnv :: forall a. Data a => [Block (Analysis a)] -> Renamer ModEnv initialEnv blocks = do-  -- FIXME: add "use renaming" declarations (requires change in-  -- NameMap because it would be possible for the same program object-  -- to have two different names used by different parts of the-  -- program).   let uses = filter isUseStatement blocks-  fmap M.unions . forM uses $ \ use -> case use of-    (BlStatement _ _ _ (StUse _ _ (ExpValue _ _ (ValVariable m)) _ Nothing)) -> do-      mMap <- gets moduleMap+  mMap <- gets moduleMap+  modEnv <- fmap M.unions . forM uses $ \ use -> case use of+    (BlStatement _ _ _ (StUse _ _ (ExpValue _ _ (ValVariable m)) _ _ Nothing)) ->       return $ fromMaybe empty (Named m `lookup` mMap)-    (BlStatement _ _ _ (StUse _ _ (ExpValue _ _ (ValVariable m)) _ (Just onlyAList)))-      | only <- aStrip onlyAList, all isUseID only -> do-      mMap <- gets moduleMap+    (BlStatement _ _ _ (StUse _ _ (ExpValue _ _ (ValVariable m)) _ _ (Just onlyAList)))+      | only <- aStrip onlyAList -> do       let env = fromMaybe empty (Named m `lookup` mMap)-      let onlyNames = map (\ (UseID _ _ v) -> varName v) only-      -- filter for the the mod remappings mentioned in the list, only-      return $ M.filterWithKey (\ k _ -> k `elem` onlyNames) env-    _ -> trace "WARNING: USE renaming not supported (yet)" $ return empty+      -- list of (local name, original name) from USE declaration:+      let localNamePairs = flip mapMaybe only $ \ r -> case r of+            UseID _ _ v@(ExpValue _ _ ValVariable{}) -> Just (varName v, varName v)+            UseRename _ _ u v                        -> Just (varName u, varName v)+            _                                        -> Nothing+      -- create environment based on local name written in ONLY list+      -- (if applicable) and variable information found in imported+      -- mod env.+      let re = M.fromList [ (local, info) | (local, orig) <- localNamePairs+                                          , Just info     <- [M.lookup orig env] ]+      return re+    _ -> return empty +  -- Include any global names from program units defined outside of+  -- modules as well.+  let global = fromMaybe M.empty $ M.lookup NamelessMain mMap++  -- Include any mappings defined by COMMON blocks: use variable+  -- source name prefixed by name of COMMON block.+  let common = M.fromList [ (v, (v', NTVariable))+                          | CommonGroup _ _ me1 alist <- universeBi blocks :: [CommonGroup (Analysis a)]+                          , let prefix = case me1 of Just e1 -> srcName e1; _ -> ""+                          , e@(ExpValue _ _ ValVariable{}) <- universeBi (aStrip alist) :: [Expression (Analysis a)]+                          , let v = srcName e+                          , let v' = prefix ++ "_" ++ v ++ "_common" ]++  return $ M.unions [modEnv,  global, common]+ -- Get the current scope name.-getScope :: Renamer String-getScope = gets (head . scopeStack)+--getScope :: Renamer String+--getScope = gets (head . scopeStack)  -- Get the concatenated scopes. getScopes :: Renamer String@@ -295,7 +321,7 @@   case mEntry of     Just (v', NTSubprogram) -> return $ Just v'     Just (_, NTVariable)    -> getFromEnv v-    _                       -> return $ Nothing+    _                       -> return Nothing  -- Add a renaming mapping to the environment. addToEnv :: String -> String -> NameType -> Renamer ()@@ -309,7 +335,7 @@   return v'  addUnique_ :: String -> NameType -> Renamer ()-addUnique_ v nt = addUnique v nt >> return ()+addUnique_ v nt = void (addUnique v nt)  -- This function will be invoked by occurrences of -- declarations. First, search to see if v is a subprogram name that@@ -324,17 +350,17 @@ -- If uniqueName/sourceName property is not set, then set it. setUniqueName, setSourceName :: (Annotated f, Data a) => String -> f (Analysis a) -> f (Analysis a) setUniqueName un x-  | a@(Analysis { uniqueName = Nothing }) <- getAnnotation x = setAnnotation (a { uniqueName = Just un }) x-  | otherwise                                                = x+  | a@Analysis { uniqueName = Nothing } <- getAnnotation x = setAnnotation (a { uniqueName = Just un }) x+  | otherwise                                              = x  setSourceName sn x-  | a@(Analysis { sourceName = Nothing }) <- getAnnotation x = setAnnotation (a { sourceName = Just sn }) x-  | otherwise                                                = x+  | a@Analysis { sourceName = Nothing } <- getAnnotation x = setAnnotation (a { sourceName = Just sn }) x+  | otherwise                                              = x  -- Work recursively into sub-program units. renameSubPUs :: Data a => RenamerFunc (Maybe [ProgramUnit (Analysis a)]) renameSubPUs Nothing = return Nothing-renameSubPUs (Just pus) = skimProgramUnits pus >> Just `fmap` (mapM programUnit pus)+renameSubPUs (Just pus) = skimProgramUnits pus >> Just <$> mapM programUnit pus  -- Go through all program units at the same level and add their names -- to the environment.@@ -367,6 +393,24 @@ renameExpDecl e@(ExpValue _ _ (ValIntrinsic v)) = flip setUniqueName (setSourceName v e) `fmap` addUnique v NTIntrinsic renameExpDecl e                                 = return e +renameInterfaces :: (Data a, Data (f (Analysis a))) => RenamerFunc (f (Analysis a))+renameInterfaces = trans interface+  where+    trans :: (Data a, Data (f (Analysis a))) => RenamerFunc (Block (Analysis a)) -> RenamerFunc (f (Analysis a))+    trans = transformBiM++interface :: Data a => RenamerFunc (Block (Analysis a))+interface (BlInterface a s (Just e@(ExpValue _ _ (ValVariable v))) abst pus bs) = do+  e' <- flip setUniqueName (setSourceName v e) `fmap` maybeAddUnique v NTSubprogram+  pure $ BlInterface a s (Just e') abst pus bs+interface b = pure b++-- Handle generic-interfaces as if they were subprograms, then handle+-- other declarations, assuming they might possibly need the creation+-- of new unique mappings.+renameModDecls :: (Data a, Data (f (Analysis a))) => RenamerFunc (f (Analysis a))+renameModDecls = renameDeclDecls <=< renameInterfaces+ -- Find all declarators within a value and then dive within those -- declarators to rename any ExpValue variables, assuming they might -- possibly need the creation of new unique mappings.@@ -399,7 +443,7 @@ -- Rename an ExpValue variable, assuming that it is to be treated as a -- reference to a previous declaration, possibly in an outer scope. renameExp :: Data a => RenamerFunc (Expression (Analysis a))-renameExp e@(ExpValue _ _ (ValVariable v))  = maybe e (flip setUniqueName (setSourceName v e)) `fmap` getFromEnvs v+renameExp e@(ExpValue _ _ (ValVariable v))  = maybe e (`setUniqueName` setSourceName v e) `fmap` getFromEnvs v -- Intrinsics get unique names for each use. renameExp e@(ExpValue _ _ (ValIntrinsic v)) = flip setUniqueName (setSourceName v e) `fmap` addUnique v NTIntrinsic renameExp e                                 = return e@@ -413,7 +457,26 @@     trans :: Data a => RenamerFunc (Expression a) -> RenamerFunc (Block a)     trans = transformBiM -- search all expressions, bottom-up +-- Rename the components of a Use statement contained in the block.+renameUseSt :: Data a => RenamerFunc (Block (Analysis a))+renameUseSt (BlStatement a s l st@StUse{}) = BlStatement a s l <$> trans expression st+  where+    trans :: Data a => RenamerFunc (Expression a) -> RenamerFunc (Statement a)+    trans = transformBiM -- search all expressions, bottom-up+renameUseSt b = return b+ --------------------------------------------------++-- Ensure second part of UseRename has the right uniqueName &+-- sourceName, since that name does not appear in our mod env, because+-- it has been given a different local name by the programmer.+cleanupUseRenames :: forall a. Data a => ProgramFile (Analysis a) -> ProgramFile (Analysis a)+cleanupUseRenames = transformBi (\ u -> case u :: Use (Analysis a) of+  UseRename a s e1 e2@(ExpValue _ _ (ValVariable v)) -> UseRename a s e1 $ setUniqueName (varName e1) (setSourceName v e2)+  _                                                  -> u)+++  -- Local variables: -- mode: haskell

@@ -1,17 +1,22 @@ {-# LANGUAGE ScopedTypeVariables #-}-module Language.Fortran.Analysis.Types ( analyseTypes, analyseTypesWithEnv, extractTypeEnv, TypeEnv ) where+module Language.Fortran.Analysis.Types+  ( analyseTypes, analyseTypesWithEnv, analyseAndCheckTypesWithEnv, extractTypeEnv, TypeEnv, TypeError )+where  import Language.Fortran.AST -import Prelude hiding (lookup)+import Prelude hiding (lookup, EQ, LT, GT) import Data.Map (insert) import qualified Data.Map as M import Data.Maybe (maybeToList)+import Data.List (find) import Control.Monad.State.Strict import Data.Generics.Uniplate.Data import Data.Data+import Data.Functor.Identity (Identity ()) import Language.Fortran.Analysis import Language.Fortran.Intrinsics+import Language.Fortran.Util.Position import Language.Fortran.ParserMonad (FortranVersion(..))  @@ -20,6 +25,9 @@ -- | Mapping of names to type information. type TypeEnv = M.Map Name IDType +-- | Information about a detected type error.+type TypeError = (String, SrcSpan)+ --------------------------------------------------  -- Monad for type inference work@@ -27,7 +35,8 @@ data InferState = InferState { langVersion :: FortranVersion                              , intrinsics  :: IntrinsicsTable                              , environ     :: TypeEnv-                             , entryPoints :: M.Map Name (Name, Maybe Name) }+                             , entryPoints :: M.Map Name (Name, Maybe Name)+                             , typeErrors  :: [TypeError] }   deriving Show type InferFunc t = t -> Infer () @@ -42,7 +51,24 @@ -- environment mapping names to type information; provided with a -- starting type environment. analyseTypesWithEnv :: Data a => TypeEnv -> ProgramFile (Analysis a) -> (ProgramFile (Analysis a), TypeEnv)-analyseTypesWithEnv env pf@(ProgramFile mi _) = fmap environ . runInfer (miVersion mi) env $ do+analyseTypesWithEnv env pf = (pf', tenv)+  where+    (pf', endState) = analyseTypesWithEnv' env pf+    tenv            = environ endState++-- | Annotate AST nodes with type information, return a type+-- environment mapping names to type information and return any type+-- errors found; provided with a starting type environment.+analyseAndCheckTypesWithEnv+  :: Data a => TypeEnv -> ProgramFile (Analysis a) -> (ProgramFile (Analysis a), TypeEnv, [TypeError])+analyseAndCheckTypesWithEnv env pf = (pf', tenv, terrs)+  where+    (pf', endState) = analyseTypesWithEnv' env pf+    tenv            = environ endState+    terrs           = typeErrors endState++analyseTypesWithEnv' :: Data a => TypeEnv -> ProgramFile (Analysis a) -> (ProgramFile (Analysis a), InferState)+analyseTypesWithEnv' env pf@(ProgramFile mi _) = runInfer (miVersion mi) env $ do   -- Gather information.   mapM_ intrinsicsExp (allExpressions pf)   mapM_ programUnit (allProgramUnits pf)@@ -51,7 +77,7 @@    -- Gather types for known entry points.   eps <- gets (M.toList . entryPoints)-  forM eps $ \ (eName, (fName, mRetName)) -> do+  _ <- forM eps $ \ (eName, (fName, mRetName)) -> do     mFType <- getRecordedType fName     case mFType of       Just (IDType fVType fCType) -> do@@ -68,7 +94,7 @@     puEnv = M.fromList [ (n, ty) | pu <- universeBi pf :: [ProgramUnit (Analysis a)]                                  , Named n <- [puName pu]                                  , ty <- maybeToList (idType (getAnnotation pu)) ]-    expEnv = M.fromList [ (n, ty) | e <- universeBi pf :: [Expression (Analysis a)]+    expEnv = M.fromList [ (n, ty) | e@(ExpValue _ _ ValVariable{}) <- universeBi pf :: [Expression (Analysis a)]                                   , let n = varName e                                   , ty <- maybeToList (idType (getAnnotation e)) ] @@ -82,10 +108,11 @@ intrinsicsExp (ExpFunctionCall _ _ nexp _) = intrinsicsHelper nexp intrinsicsExp _                            = return () +intrinsicsHelper :: Expression (Analysis a) -> StateT InferState Identity () intrinsicsHelper nexp | isNamedExpression nexp = do   itab <- gets intrinsics   case getIntrinsicReturnType (srcName nexp) itab of-    Just itype -> do+    Just _ -> do       let n = varName nexp       recordCType CTIntrinsic n       -- recordBaseType _  n -- FIXME: going to skip base types for the moment@@ -103,7 +130,7 @@       _                                        -> return ()     -- record entry points for later annotation     forM_ blocks $ \ block ->-      sequence_ [ recordEntryPoint n (varName v) (fmap varName mRetVar) | (StEntry _ _ v _ mRetVar) <- allStatements block ]+      sequence_ [ recordEntryPoint n (varName v) (fmap varName mRetVar') | (StEntry _ _ v _ mRetVar') <- allStatements block ] programUnit pu@(PUSubroutine _ _ _ _ _ blocks _) | Named n <- puName pu = do   -- record the fact that this is a subroutine   recordCType CTSubroutine n@@ -113,29 +140,42 @@ programUnit _                                           = return ()  declarator :: Data a => InferFunc (Declarator (Analysis a))-declarator (DeclArray _ _ v _ _ _) = recordCType CTArray (varName v)-declarator _                       = return ()+declarator (DeclArray _ _ v ddAList _ _) = recordCType (CTArray $ dimDeclarator ddAList) (varName v)+declarator _ = return () +dimDeclarator :: AList DimensionDeclarator a -> [(Maybe Int, Maybe Int)]+dimDeclarator ddAList = [ (lb, ub) | DimensionDeclarator _ _ lbExp ubExp <- aStrip ddAList+                                   , let lb = do ExpValue _ _ (ValInteger i) <- lbExp+                                                 return $ read i+                                   , let ub = do ExpValue _ _ (ValInteger i) <- ubExp+                                                 return $ read i ]+ statement :: Data a => InferFunc (Statement (Analysis a)) -- maybe FIXME: should Kind Selectors be part of types? statement (StDeclaration _ _ (TypeSpec _ _ baseType _) mAttrAList declAList)   | mAttrs  <- maybe [] aStrip mAttrAList-  , isArray <- any isAttrDimension mAttrs+  , attrDim <- find isAttrDimension mAttrs   , isParam <- any isAttrParameter mAttrs   , isExtrn <- any isAttrExternal mAttrs   , decls   <- aStrip declAList = do     env <- gets environ-    forM_ decls $ \ decl -> case decl of-      DeclArray _ _ v _ _ _         -> recordType baseType CTArray (varName v)-      DeclVariable _ _ v (Just _) _ -> recordType baseType CTVariable (varName v)-      DeclVariable _ _ v Nothing _  -> recordType baseType cType n-        where-          n = varName v-          cType | isExtrn                                     = CTExternal-                | isArray                                     = CTArray+    let cType n | isExtrn                                     = CTExternal+                | Just (AttrDimension _ _ ddAList) <- attrDim = CTArray (dimDeclarator ddAList)                 | isParam                                     = CTParameter-                | Just (IDType _ (Just ct)) <- M.lookup n env = ct+                | Just (IDType _ (Just ct)) <- M.lookup n env+                , ct /= CTIntrinsic                           = ct                 | otherwise                                   = CTVariable+    let charLen (ExpValue _ _ (ValInteger i)) = CharLenInt (read i)+        charLen (ExpValue _ _ ValStar)        = CharLenStar+        charLen _                             = CharLenExp+    let bType (Just e)+          | TypeCharacter _ kind <- baseType = TypeCharacter (Just $ charLen e) kind+          | otherwise                        = TypeCharacter (Just $ charLen e) Nothing+        bType Nothing  = baseType+    forM_ decls $ \ decl -> case decl of+      DeclArray _ _ v ddAList e _ -> recordType (bType e) (CTArray $ dimDeclarator ddAList) (varName v)+      DeclVariable _ _ v e _      -> recordType (bType e) (cType n) n where n = varName v+ statement (StExternal _ _ varAList) = do   let vars = aStrip varAList   mapM_ (recordCType CTExternal . varName) vars@@ -145,45 +185,193 @@     let n = varName v     mIDType <- getRecordedType n     case mIDType of-      Just (IDType mBT (Just CTArray)) -> return ()                -- do nothing, it's already known to be an array+      Just (IDType _ (Just CTArray{})) -> return ()                -- do nothing, it's already known to be an array       _                                -> recordCType CTFunction n -- assume it's a function statement  -- FIXME: if StFunctions can only be identified after types analysis -- is complete and disambiguation is performed, then how do we get -- them in the first place? (iterate until fixed point?) statement (StFunction _ _ v _ _) = recordCType CTFunction (varName v)+-- (part of answer to above is) nullary function statement: foo() = ...+statement (StExpressionAssign _ _ (ExpFunctionCall _ _ v Nothing) _) = recordCType CTFunction (varName v)  statement (StDimension _ _ declAList) = do   let decls = aStrip declAList   forM_ decls $ \ decl -> case decl of-    DeclArray _ _ v _ _ _ -> recordCType CTArray (varName v)-    _                     -> return ()+    DeclArray _ _ v ddAList _ _ -> recordCType (CTArray $ dimDeclarator ddAList) (varName v)+    _                           -> return ()  statement _ = return ()  annotateExpression :: Data a => Expression (Analysis a) -> Infer (Expression (Analysis a))-annotateExpression e@(ExpValue _ _ (ValVariable _))  = maybe e (flip setIDType e) `fmap` getRecordedType (varName e)-annotateExpression e@(ExpValue _ _ (ValIntrinsic _)) = maybe e (flip setIDType e) `fmap` getRecordedType (varName e)-annotateExpression e                                 = return e+annotateExpression e@(ExpValue _ _ (ValVariable _))    = maybe e (`setIDType` e) `fmap` getRecordedType (varName e)+annotateExpression e@(ExpValue _ _ (ValIntrinsic _))   = maybe e (`setIDType` e) `fmap` getRecordedType (varName e)+annotateExpression e@(ExpValue _ _ (ValReal r))        = return $ realLiteralType r `setIDType` e+annotateExpression e@(ExpValue _ _ (ValComplex e1 e2)) = return $ complexLiteralType e1 e2 `setIDType` e+annotateExpression e@(ExpValue _ _ (ValInteger _))     = return $ IDType (Just TypeInteger) Nothing `setIDType` e+annotateExpression e@(ExpValue _ _ (ValLogical _))     = return $ IDType (Just TypeLogical) Nothing `setIDType` e+annotateExpression e@(ExpBinary _ _ op e1 e2)          = flip setIDType e `fmap` binaryOpType (getSpan e) op e1 e2+annotateExpression e@(ExpUnary _ _ op e1)              = flip setIDType e `fmap` unaryOpType (getSpan e1) op e1+annotateExpression e@(ExpSubscript _ _ e1 idxAList)    = flip setIDType e `fmap` subscriptType (getSpan e) e1 idxAList+annotateExpression e@(ExpFunctionCall _ _ e1 parAList) = flip setIDType e `fmap` functionCallType (getSpan e) e1 parAList+annotateExpression e                                   = return e  annotateProgramUnit :: Data a => ProgramUnit (Analysis a) -> Infer (ProgramUnit (Analysis a))-annotateProgramUnit pu | Named n <- puName pu = maybe pu (flip setIDType pu) `fmap` getRecordedType n+annotateProgramUnit pu | Named n <- puName pu = maybe pu (`setIDType` pu) `fmap` getRecordedType n annotateProgramUnit pu                        = return pu +realLiteralType :: String -> IDType+realLiteralType r | 'd' `elem` r = IDType (Just TypeDoublePrecision) Nothing+                  | otherwise    = IDType (Just TypeReal) Nothing++complexLiteralType :: Expression a -> Expression a -> IDType+complexLiteralType (ExpValue _ _ (ValReal r)) _+ | IDType (Just TypeDoublePrecision) _ <- realLiteralType r = IDType (Just TypeDoubleComplex) Nothing+ | otherwise                                                = IDType (Just TypeComplex) Nothing+complexLiteralType _ _ = IDType (Just TypeComplex) Nothing++binaryOpType :: Data a => SrcSpan -> BinaryOp -> Expression (Analysis a) -> Expression (Analysis a) -> Infer IDType+binaryOpType ss op e1 e2 = do+  mbt1 <- case getIDType e1 of+            Just (IDType (Just bt) _) -> return $ Just bt+            _ -> typeError "Unable to obtain type for first operand" (getSpan e1) >> return Nothing+  mbt2 <- case getIDType e2 of+            Just (IDType (Just bt) _) -> return $ Just bt+            _ -> typeError "Unable to obtain type for second operand" (getSpan e2) >> return Nothing+  case (mbt1, mbt2) of+    (_, Nothing) -> return emptyType+    (Nothing, _) -> return emptyType+    (Just bt1, Just bt2) -> do+      mbt <- case (bt1, bt2) of+        (_                   , TypeDoubleComplex   ) -> return . Just $ TypeDoubleComplex+        (TypeDoubleComplex   , _                   ) -> return . Just $ TypeDoubleComplex+        (_                   , TypeComplex         ) -> return . Just $ TypeComplex+        (TypeComplex         , _                   ) -> return . Just $ TypeComplex+        (_                   , TypeDoublePrecision ) -> return . Just $ TypeDoublePrecision+        (TypeDoublePrecision , _                   ) -> return . Just $ TypeDoublePrecision+        (_                   , TypeReal            ) -> return . Just $ TypeReal+        (TypeReal            , _                   ) -> return . Just $ TypeReal+        (_                   , TypeInteger         ) -> return . Just $ TypeInteger+        (TypeInteger         , _                   ) -> return . Just $ TypeInteger+        (TypeByte            , TypeByte            ) -> return . Just $ TypeByte+        (TypeLogical         , TypeLogical         ) -> return . Just $ TypeLogical+        (TypeCustom _        , TypeCustom _        ) -> do+          typeError "custom types / binary op not supported" ss+          return Nothing+        (TypeCharacter l1 k1 , TypeCharacter l2 _ )+          | op == Concatenation -> return . Just $ TypeCharacter (liftM2 charLenConcat l1 l2) k1+          | op `elem` [EQ, NE]  -> return $ Just TypeLogical+          | otherwise -> do typeError "Invalid op on character strings" ss+                            return Nothing+        _ -> do typeError "Type error between operands of binary operator" ss+                return Nothing+      mbt' <- case mbt of+        Just bt+          | op `elem` [ Addition, Subtraction, Multiplication, Division+                      , Exponentiation, Concatenation, Or, XOr, And ]       -> return $ Just bt+          | op `elem` [GT, GTE, LT, LTE, EQ, NE, Equivalent, NotEquivalent] -> return $ Just TypeLogical+          | BinCustom{} <- op -> typeError "custom binary ops not supported" ss >> return Nothing+        _ -> return Nothing++      return $ IDType mbt' Nothing++unaryOpType :: Data a => SrcSpan -> UnaryOp -> Expression (Analysis a) -> Infer IDType+unaryOpType ss op e = do+  mbt <- case getIDType e of+           Just (IDType (Just bt) _) -> return $ Just bt+           _ -> typeError "Unable to obtain type for" (getSpan e) >> return Nothing+  mbt' <- case (mbt, op) of+    (Nothing, _)               -> return Nothing+    (Just TypeCustom{}, _)     -> typeError "custom types / unary ops not supported" ss >> return Nothing+    (_, UnCustom{})            -> typeError "custom unary ops not supported" ss >> return Nothing+    (Just TypeLogical, Not)    -> return $ Just TypeLogical+    (Just bt, _)+      | op `elem` [Plus, Minus] &&+        bt `elem` numericTypes -> return $ Just bt+    _ -> typeError "Type error for unary operator" ss >> return Nothing+  return $ IDType mbt' Nothing++subscriptType :: Data a => SrcSpan -> Expression (Analysis a) -> AList Index (Analysis a) -> Infer IDType+subscriptType ss e1 (AList _ _ idxs) = do+  let isInteger ie | Just (IDType (Just TypeInteger) _) <- getIDType ie = True | otherwise = False+  forM_ idxs $ \ idx -> case idx of+    IxSingle _ _ _ ie+      | not (isInteger ie) -> typeError "Invalid or unknown type for index" (getSpan ie)+    IxRange _ _ mie1 mie2 mie3+      | Just ie1 <- mie1, not (isInteger ie1) -> typeError "Invalid or unknown type for index" (getSpan ie1)+      | Just ie2 <- mie2, not (isInteger ie2) -> typeError "Invalid or unknown type for index" (getSpan ie2)+      | Just ie3 <- mie3, not (isInteger ie3) -> typeError "Invalid or unknown type for index" (getSpan ie3)+    _ -> return ()+  case getIDType e1 of+    Just ty@(IDType mbt (Just (CTArray dds))) -> do+      when (length idxs /= length dds) $ typeError "Length of indices does not match rank of array." ss+      let isSingle (IxSingle{}) = True; isSingle _ = False+      if all isSingle idxs+        then return $ IDType mbt Nothing+        else return ty+    _ -> return emptyType++functionCallType :: Data a => SrcSpan -> Expression (Analysis a) -> Maybe (AList Argument (Analysis a)) -> Infer IDType+functionCallType ss (ExpValue _ _ (ValIntrinsic n)) (Just (AList _ _ params)) = do+  itab <- gets intrinsics+  let mRetType = getIntrinsicReturnType n itab+  case mRetType of+    Nothing -> return emptyType+    Just retType -> do+      mbt <- case retType of+            ITReal      -> return $ Just TypeReal+            ITInteger   -> return $ Just TypeInteger+            ITComplex   -> return $ Just TypeComplex+            ITDouble    -> return $ Just TypeDoublePrecision+            ITLogical   -> return $ Just TypeLogical+            ITCharacter -> return . Just $ TypeCharacter Nothing Nothing+            ITParam i+              | length params >= i, Argument _ _ _ e <- params !! (i-1)+                -> return $ idVType =<< getIDType e+              | otherwise -> typeError ("Invalid parameter list to intrinsic '" ++ n ++ "'") ss >> return Nothing+      case mbt of+        Nothing -> return emptyType+        Just _ -> return $ IDType mbt Nothing+functionCallType ss e1 _ = case getIDType e1 of+  Just (IDType (Just bt) (Just CTFunction)) -> return $ IDType (Just bt) Nothing+  Just (IDType (Just bt) (Just CTExternal)) -> return $ IDType (Just bt) Nothing+  _ -> typeError "non-function invoked by call" ss >> return emptyType++charLenConcat :: CharacterLen -> CharacterLen -> CharacterLen+charLenConcat l1 l2 = case (l1, l2) of+  (CharLenExp    , _             ) -> CharLenExp+  (_             , CharLenExp    ) -> CharLenExp+  (CharLenStar   , _             ) -> CharLenStar+  (_             , CharLenStar   ) -> CharLenStar+  (CharLenColon  , _             ) -> CharLenColon+  (_             , CharLenColon  ) -> CharLenColon+  (CharLenInt i1 , CharLenInt i2 ) -> CharLenInt (i1 + i2)++numericTypes :: [BaseType]+numericTypes = [TypeDoubleComplex, TypeComplex, TypeDoublePrecision, TypeReal, TypeInteger, TypeByte]+ -------------------------------------------------- -- Monadic helper combinators. -inferState0 v = InferState { environ = M.empty, entryPoints = M.empty, langVersion = v, intrinsics = getVersionIntrinsics v }+inferState0 :: FortranVersion -> InferState+inferState0 v = InferState { environ = M.empty, entryPoints = M.empty, langVersion = v+                           , intrinsics = getVersionIntrinsics v, typeErrors = [] } runInfer :: FortranVersion -> TypeEnv -> State InferState a -> (a, InferState) runInfer v env = flip runState ((inferState0 v) { environ = env }) +typeError :: String -> SrcSpan -> Infer ()+typeError msg ss = modify $ \ s -> s { typeErrors = (msg, ss):typeErrors s }++emptyType :: IDType+emptyType = IDType Nothing Nothing+ -- Record the type of the given name. recordType :: BaseType -> ConstructType -> Name -> Infer () recordType bt ct n = modify $ \ s -> s { environ = insert n (IDType (Just bt) (Just ct)) (environ s) }  -- Record the type (maybe) of the given name. recordMType :: Maybe BaseType -> Maybe ConstructType -> Name -> Infer ()-recordMType bt ct n = modify $ \ s -> s { environ = insert n (IDType (bt) (ct)) (environ s) }+recordMType bt ct n = modify $ \ s -> s { environ = insert n (IDType bt ct) (environ s) }  -- Record the CType of the given name. recordCType :: ConstructType -> Name -> Infer ()@@ -204,7 +392,7 @@ -- Set the idType annotation setIDType :: Annotated f => IDType -> f (Analysis a) -> f (Analysis a) setIDType ty x-  | a@(Analysis {}) <- getAnnotation x = setAnnotation (a { idType = Just ty }) x+  | a@Analysis {} <- getAnnotation x = setAnnotation (a { idType = Just ty }) x   | otherwise                          = x  -- Get the idType annotation@@ -212,10 +400,10 @@ getIDType x = idType (getAnnotation x)  -- Set the CType part of idType annotation-setCType :: (Annotated f, Data a) => ConstructType -> f (Analysis a) -> f (Analysis a)-setCType ct x-  | a@(Analysis { idType = Nothing }) <- getAnnotation x = setAnnotation (a { idType = Just (IDType Nothing (Just ct)) }) x-  | a@(Analysis { idType = Just it }) <- getAnnotation x = setAnnotation (a { idType = Just (it { idCType = Just ct }) }) x+--setCType :: (Annotated f, Data a) => ConstructType -> f (Analysis a) -> f (Analysis a)+--setCType ct x+--  | a@(Analysis { idType = Nothing }) <- getAnnotation x = setAnnotation (a { idType = Just (IDType Nothing (Just ct)) }) x+--  | a@(Analysis { idType = Just it }) <- getAnnotation x = setAnnotation (a { idType = Just (it { idCType = Just ct }) }) x  type UniFunc f g a = f (Analysis a) -> [g (Analysis a)] @@ -231,16 +419,20 @@ allExpressions :: (Data a, Data (f (Analysis a))) => UniFunc f Expression a allExpressions = universeBi -isAttrDimension (AttrDimension {}) = True-isAttrDimension _                  = False+isAttrDimension :: Attribute a -> Bool+isAttrDimension AttrDimension {} = True+isAttrDimension _                = False -isAttrParameter (AttrParameter {}) = True+isAttrParameter :: Attribute a -> Bool+isAttrParameter AttrParameter {} = True isAttrParameter _                  = False -isAttrExternal (AttrExternal {}) = True+isAttrExternal :: Attribute a -> Bool+isAttrExternal AttrExternal {} = True isAttrExternal _                 = False -isIxSingle (IxSingle {}) = True+isIxSingle :: Index a -> Bool+isIxSingle IxSingle {} = True isIxSingle _             = False  --------------------------------------------------

@@ -19,11 +19,13 @@ data IntrinsicsEntry = IEntry { iType :: IntrinsicType, iDefsUses :: ([Int], [Int]) }   deriving (Show, Eq, Ord, Typeable, Generic) -mkIEntry ty du = IEntry ty du+mkIEntry :: IntrinsicType -> ([Int], [Int]) -> IntrinsicsEntry+mkIEntry = IEntry  type IntrinsicsTable = M.Map String IntrinsicsEntry  -- Main table of Fortran intrinsics by version+fortranVersionIntrinsics :: [(FortranVersion, IntrinsicsTable)] fortranVersionIntrinsics =   [ (Fortran66, fortran77intrinsics) -- FIXME: find list of original '66 intrinsics   , (Fortran77, fortran77intrinsics)@@ -48,10 +50,15 @@ allIntrinsics :: IntrinsicsTable allIntrinsics = M.unions (map snd fortranVersionIntrinsics) +func1 :: ([Int], [Int]) func1 = ([0],[1])+func2 :: ([Int], [Int]) func2 = ([0],[1,2])+func3 :: ([Int], [Int]) func3 = ([0],[1,2,3])+func4 :: ([Int], [Int]) func4 = ([0],[1,2,3,4])+funcN :: ([Int], [Int]) funcN = func2 -- FIXME: implement arbitrary-# parameter functions  -- | name => (return-unit, parameter-units)@@ -68,6 +75,7 @@   , ("cmplx"   , mkIEntry ITComplex func1)   , ("ichar"   , mkIEntry ITInteger func1)   , ("char"    , mkIEntry ITCharacter func1)+  , ("achar"   , mkIEntry ITCharacter func1)   , ("aint"    , mkIEntry (ITParam 1) func1)   , ("dint"    , mkIEntry ITDouble func1)   , ("anint"   , mkIEntry (ITParam 1) func1)@@ -151,19 +159,19 @@  fortran90intrinisics :: IntrinsicsTable fortran90intrinisics = fortran77intrinsics `M.union` M.fromList-  [ ("present" , mkIEntry (ITLogical)   func1)+  [ ("present" , mkIEntry ITLogical     func1)   , ("modulo"  , mkIEntry (ITParam 1)   func2)   , ("ceiling" , mkIEntry (ITParam 1)   func1)-  , ("iand"    , mkIEntry (ITInteger)   func2)-  , ("ior"     , mkIEntry (ITInteger)   func2)-  , ("ieor"    , mkIEntry (ITInteger)   func2)-  , ("iany"    , mkIEntry (ITInteger)   func2)-  , ("ibclr"   , mkIEntry (ITInteger)   func2)-  , ("ibits"   , mkIEntry (ITInteger)   func3)-  , ("ibset"   , mkIEntry (ITInteger)   func2)-  , ("ishftc"  , mkIEntry (ITInteger)   func3)-  , ("btest"   , mkIEntry (ITInteger)   func2)-  , ("not"     , mkIEntry (ITInteger)   func1)+  , ("iand"    , mkIEntry ITInteger     func2)+  , ("ior"     , mkIEntry ITInteger     func2)+  , ("ieor"    , mkIEntry ITInteger     func2)+  , ("iany"    , mkIEntry ITInteger     func2)+  , ("ibclr"   , mkIEntry ITInteger     func2)+  , ("ibits"   , mkIEntry ITInteger     func3)+  , ("ibset"   , mkIEntry ITInteger     func2)+  , ("ishftc"  , mkIEntry ITInteger     func3)+  , ("btest"   , mkIEntry ITInteger     func2)+  , ("not"     , mkIEntry ITInteger     func1)   , ("dot_product"  , mkIEntry (ITParam 1)   func2)   , ("matmul"       , mkIEntry (ITParam 1)   func2)   , ("all"          , mkIEntry ITLogical     func2)@@ -187,4 +195,5 @@   , ("transpose"    , mkIEntry (ITParam 1)   func1)   , ("maxloc"       , mkIEntry (ITParam 1)   func2)   , ("minloc"       , mkIEntry (ITParam 1)   func2)+  , ("epsilon"      , mkIEntry (ITReal)      func1)   ]

@@ -6,6 +6,7 @@  module Language.Fortran.LValue where +import           Prelude                               hiding (exp) import           Data.Data import           GHC.Generics                          (Generic) 

@@ -29,6 +29,7 @@  import Language.Fortran.Util.FirstParameter import Language.Fortran.Util.Position+import Language.Fortran.Parser.Utils (readInteger)  } @@ -37,6 +38,8 @@ $hexDigit = [a-f $digit] $bit = 0-1 +$hash = [\#]+ @binary = b\'$bit+\' | \'$bit+\'b @octal = o\'$octalDigit+\' | \'$octalDigit+\'o @hex = x\'$hexDigit+\' | \'$hexDigit+\'x | z\'$hexDigit+\' | \'$hexDigit+\'z@@ -72,12 +75,14 @@  tokens :- -  <0> [c!\*d] / { commentP }                  { lexComment Nothing }-  "!" / { bangCommentP &&& legacy77P }        { lexComment Nothing }+  <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              ;   <0,st,keyword,iif,assn,doo> ";"             { resetPar >> toSC keyword >> addSpan TNewline }@@ -279,7 +284,7 @@ implicitTypeExtendedP fv b c d = extended77P fv b c d && implicitStP fv b c d  implicitStP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool-implicitStP fv _ _ ai = checkPreviousTokensInLine f ai+implicitStP _ _ _ ai = checkPreviousTokensInLine f ai   where     f (TImplicit _) = True     f _ = False@@ -296,7 +301,7 @@  doP :: FortranVersion -> AlexInput -> Bool doP fv ai = isPrefixOf "do" (reverse . lexemeMatch . aiLexeme $ ai) &&-    case unParse (lexer $ f 0) ps of+    case unParse (lexer $ f (0::Integer)) ps of       ParseOk True _ -> True       _ -> False   where@@ -357,14 +362,14 @@         _ -> return False  hollerithP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool-hollerithP fv _ _ ai = isDigit (lookBack 2 ai)+hollerithP _ _ _ ai = isDigit (lookBack 2 ai)  notToP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool-notToP fv _ _ ai = not $ "to" `isPrefixOf` (reverse . lexemeMatch . aiLexeme $ ai)+notToP _ _ _ ai = not $ "to" `isPrefixOf` (reverse . lexemeMatch . aiLexeme $ ai)  equalFollowsP :: FortranVersion -> AlexInput -> Bool equalFollowsP fv ai =-    case unParse (lexer $ f False 0) ps of+    case unParse (lexer $ f False (0::Integer)) ps of       ParseOk True _ -> True       _ -> False   where@@ -383,6 +388,7 @@         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@@ -421,7 +427,7 @@     _endsWithLine = (posColumn . aiPosition) aiNew /= 1  bangCommentP :: FortranVersion -> AlexInput -> Int -> AlexInput -> Bool-bangCommentP fv aiOld i aiNew = _endsWithLine+bangCommentP _ _ _ aiNew = _endsWithLine   where     _endsWithLine = (posColumn . aiPosition) aiNew /= 1 @@ -558,38 +564,44 @@   lexeme <- getLexeme   return $ getSpan lexeme --- With the existing alexGetByte implementation comments are matched without--- whitespace characters. However, we have access to final column number,--- we know the comment would start at column, and we have access to the absolute--- offset so instead of using match, lexComment takes a slice from the original--- source input-lexComment :: Maybe Char -> LexAction (Maybe Token)-lexComment mc = do-  m <- getMatch-  s <- getLexemeSpan+-- 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-  version <- getVersion-  let emitComment = case version of-                      Fortran77Legacy-                        -> return Nothing-                      _ -> return $ Just $ TComment s $ tail m   let modifiedAlex = alex { aiWhiteSensitiveCharCount = 1 }-  case mc of-    Just '\n' -> emitComment-    Just _ ->-      case alexGetByte modifiedAlex of-        Just (w, _) | fromIntegral w == ord '\n' -> do-          emitComment-        Just (_, newAlex) -> do-          putAlex newAlex-          lexComment Nothing-        Nothing -> fail "Comment abruptly ended."-    Nothing ->-      case alexGetByte modifiedAlex of-        Just (_, newAlex) -> lexComment (Just $ (head . lexemeMatch . aiLexeme) newAlex)-        Nothing -> emitComment+  case alexGetByte modifiedAlex of+    Just (w, newAlex)+      | fromIntegral w /= ord '\n' -> putAlex newAlex >> lexLineWithWhitespace k+    _                              -> getMatch >>= k  +--------------------------------------------------+ {-      Chars       +-+@@ -635,13 +647,13 @@         strAutomaton c 0       else strAutomaton c 2     Nothing -> strAutomaton c 2-strAutomaton c 2 = do+strAutomaton _ 2 = do   s <- getLexemeSpan   m <- getMatch   resetWhiteSensitiveCharCount   setCaseInsensitive   return $ Just $ TString s $ (init . tail) m-strAutomaton c 3 = fail "Unmatched string."+strAutomaton _ _ = fail "Unmatched string."  lexHollerith :: LexAction (Maybe Token) lexHollerith = do@@ -665,7 +677,7 @@   then return $ Just match'   else     case alexGetByte alex of-      Just (w, newAlex) | fromIntegral w == ord '\n' -> do+      Just (w, _) | fromIntegral w == ord '\n' -> do         return . Just $! pad match'       Just (_, newAlex) -> do         putAlex newAlex@@ -677,8 +689,8 @@ maybeToKeyword :: LexAction (Maybe Token) maybeToKeyword = do   decPar-  pcActual <- pcActual . psParanthesesCount <$> get-  if pcActual == 0+  pcActual' <- pcActual . psParanthesesCount <$> get+  if pcActual' == 0   then toSC keyword   else return Nothing @@ -910,8 +922,8 @@   -- Skip the continuation line altogether   | isContinuation ai && _isWhiteInsensitive = skip Continuation ai   -- Skip the newline before a comment-  | aiFortranVersion ai == Fortran77Legacy &&-    _isWhiteInsensitive && isNewlineComment ai = skip NewlineComment ai+  | 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@@ -968,6 +980,13 @@     _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@@ -1004,12 +1023,12 @@ skipCommentLines :: AlexInput -> Position -> Position skipCommentLines ai p = go p p   where-  go p' p+  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+    , 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'@@ -1017,7 +1036,7 @@       -- after skipping comment lines, place cursor right at the last newline     = p2     where-    line = takeLine p ai+    line = takeLine p'' ai     line' = takeLine p' ai     p2 = p' { posAbsoluteOffset = posAbsoluteOffset p' + length line'             , posColumn = length line' + 1@@ -1081,7 +1100,7 @@       parseState <- get       fail $ psFilename parseState ++ ": lexing failed. "     AlexSkip newAlex _ -> putAlex newAlex >> lexer'-    AlexToken newAlex startCode action -> do+    AlexToken newAlex _ action -> do       putAlex newAlex       maybeToken <- action       case maybeToken of@@ -1110,7 +1129,8 @@     _vanillaAlexInput = vanillaAlexInput       { aiSourceBytes = srcBytes       , aiEndOffset   = fromIntegral $ B.length srcBytes-      , aiFortranVersion = fortranVersion }+      , aiFortranVersion = fortranVersion+      , aiPosition = initPosition {filePath = filename} }  collectFixedTokens :: FortranVersion -> B.ByteString -> [Token] collectFixedTokens version srcInput =

@@ -10,8 +10,10 @@  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@@ -24,7 +26,7 @@ import Language.Fortran.ParserMonad import Language.Fortran.Util.Position import Language.Fortran.Util.FirstParameter-+import Language.Fortran.Parser.Utils (readInteger)  } @@ -36,6 +38,8 @@ $letter = a-z $alphanumeric = [$letter $digit \_] +$hash = [\#]+ @label = $digit{1,5} @name = $letter $alphanumeric* @@ -77,8 +81,11 @@ -------------------------------------------------------------------------------- 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\ ]+                           ; @@ -87,6 +94,8 @@ <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 }@@ -120,8 +129,12 @@ <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 }@@ -132,16 +145,27 @@  -- 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 }@@ -151,10 +175,14 @@ <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 }@@ -163,6 +191,8 @@ <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 }@@ -171,12 +201,23 @@ <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 }@@ -207,12 +248,17 @@  -- 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 }@@ -233,6 +279,11 @@ <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 }@@ -293,6 +344,13 @@   | 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@@ -324,7 +382,7 @@  partOfExpOrPointerAssignmentP :: User -> AlexInput -> Int -> AlexInput -> Bool partOfExpOrPointerAssignmentP (User fv pc) _ _ ai =-    case unParse (lexer $ f False 0) ps of+    case unParse (lexer $ f False (0::Integer)) ps of       ParseOk True _ -> True       _ -> False   where@@ -351,6 +409,8 @@           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@@ -367,18 +427,88 @@ 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 && startsWithTypeSpec+attributeP _ _ _ ai = followsComma && precedesDoubleColon ai && lineStartOK   where     followsComma       | Just TComma{} <- aiPreviousToken ai = True       | otherwise = False-    startsWithTypeSpec-      | (token:_) <- prevTokens =-        isTypeSpec token || fillConstr TType == toConstr token++    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@@ -388,10 +518,13 @@ genericSpecP :: User -> AlexInput -> Int -> AlexInput -> Bool genericSpecP _ _ _ ai = Just True == do   constr <- prevTokenConstr ai-  if constr `elem` fmap fillConstr [ TInterface, TPublic, TPrivate ]+  if constr `elem` fmap fillConstr [ TAbstract, TInterface, TPublic, TPrivate, TProtected ]   then return True-  else if constr `elem` fmap fillConstr [ TComma, TDoubleColon ]-  then return $ seenConstr (fillConstr TPublic) ai || seenConstr (fillConstr TPrivate) ai+  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@@ -411,7 +544,7 @@   , isTypeSpec prevToken = True   | otherwise = isTypeSpecImmediatelyBefore $ reverse prevTokens   where-    isTypeSpecImmediatelyBefore tokens@(x:xs)+    isTypeSpecImmediatelyBefore tokens@(_:xs)       | isTypeSpec tokens = True       | otherwise = isTypeSpecImmediatelyBefore xs     isTypeSpecImmediatelyBefore [] = False@@ -431,6 +564,25 @@   (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 @@ -484,7 +636,7 @@           ParseOk tokenCons _ -> do             span <- getLexemeSpan             return $ Just $ tokenCons span-          ParseFailed e -> fail "Left parantheses is not matched."+          ParseFailed _ -> fail "Left parantheses is not matched."       else addSpan TLeftPar   where     f :: LexAction (SrcSpan -> Token)@@ -493,7 +645,7 @@       mPrevToken <- aiPreviousToken <$> getAlex       case mPrevToken of         Just TRightPar{} | pc == 0 -> do-          span <- getLexemeSpan+          _ <- getLexemeSpan           curToken <- lexer'           case curToken of             TComma{} -> return TLeftPar2@@ -620,7 +772,7 @@     putAlex $ alex { aiStartCode = StartCode scC Stable }     match <- getMatch     let boundaryMarker = last match-    _lexChar 0 boundaryMarker+    _lexChar (0::Integer) boundaryMarker   where     _lexChar 0 bm = do       alex <- getAlex@@ -650,6 +802,7 @@       match <- getMatch       putMatch . init . tail $ match       addSpanAndMatch TString+    _lexChar _ _ = do fail "unhandled lexCharacter"  toSC :: Int -> LexAction () toSC startCode = do@@ -675,7 +828,7 @@ --------------------------------------------------------------------------------  invalidPosition :: Position-invalidPosition = Position 0 0 0+invalidPosition = Position 0 0 0 "" Nothing  {-# INLINE isValidPosition #-} isValidPosition :: Position -> Bool@@ -774,8 +927,10 @@ currentChar :: AlexInput -> Char currentChar !ai   -- case sensitivity matters only in character literals-  | sCode == scC = _currentChar-  | otherwise    = {-# SCC toLower_currentChar #-} toLower _currentChar+  | 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)@@ -806,26 +961,27 @@     (scActual . aiStartCode) ai /= scC     -- No continuation while lexing a comment.     && (null match || not (lexemeIsCmt lexeme))-    && _isContinuation ai 0+    && _isContinuation ai (0::Integer)   where     match  = lexemeMatch lexeme     lexeme = aiLexeme $ ai-    _isContinuation !ai 0 =-      if currentChar ai == '&'-      then _advance 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+    _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+    _advance !ai' =+      case advanceWithoutContinuation ai' of+        Just ai'' -> _isContinuation ai'' (1::Integer)         Nothing -> False  -- Here's the skip continuation automaton:@@ -850,7 +1006,7 @@ -- 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+skipContinuation ai' = _skipCont ai' (0::Integer)   where     _skipCont ai 0 =       if currentChar ai == '&'@@ -888,11 +1044,24 @@         -- 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+        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@@ -901,11 +1070,31 @@         { 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 --------------------------------------------------------------------------------@@ -919,11 +1108,11 @@   alex <- getAlex   let startCode = scActual . aiStartCode $ alex   normaliseStartCode-  newAlex <- getAlex+  newAlex' <- getAlex   version <- getVersion   paranthesesCount <- getParanthesesCount   let user = User version paranthesesCount-  case alexScanUser user newAlex startCode of+  case alexScanUser user newAlex' startCode of     AlexEOF -> return $ TEOF $ SrcSpan (getPos alex) (getPos alex)     AlexError _ -> do       parseState <- get@@ -997,7 +1186,7 @@   | TFunction           SrcSpan   | TEndFunction        SrcSpan   | TResult             SrcSpan-  | TPure          SrcSpan+  | TPure               SrcSpan   | TElemental          SrcSpan   | TRecursive          SrcSpan   | TSubroutine         SrcSpan@@ -1009,8 +1198,11 @@   | TContains           SrcSpan   | TUse                SrcSpan   | TOnly               SrcSpan+  | TImport             SrcSpan+  | TAbstract           SrcSpan   | TInterface          SrcSpan   | TEndInterface       SrcSpan+  | TProcedure          SrcSpan   | TModuleProcedure    SrcSpan   | TAssignment         SrcSpan   | TOperator           SrcSpan@@ -1018,19 +1210,28 @@   | TReturn             SrcSpan   | TEntry              SrcSpan   | TInclude            SrcSpan+  -- language-binding-spec+  | TBind               SrcSpan+  | TC                  SrcSpan+  | TName               SrcSpan   -- Attributes-  | TPublic             SrcSpan-  | TPrivate            SrcSpan-  | TParameter          SrcSpan   | 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@@ -1044,6 +1245,9 @@   | TFormat             SrcSpan   | TBlob               SrcSpan String   | TAllocate           SrcSpan+  | TStat               SrcSpan+  | TErrMsg             SrcSpan+  | TSource             SrcSpan   | TDeallocate         SrcSpan   | TNullify            SrcSpan   -- Misc@@ -1079,6 +1283,10 @@   | TType               SrcSpan   | TEndType            SrcSpan   | TSequence           SrcSpan+  | TClass              SrcSpan+  | TEnum               SrcSpan+  | TEnumerator         SrcSpan+  | TEndEnum            SrcSpan   -- Selector   | TKind               SrcSpan   | TLen                SrcSpan@@ -1103,6 +1311,11 @@   | 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@@ -1158,7 +1371,8 @@       , psContext = [ ConStart ] }     _vanillaAlexInput = vanillaAlexInput       { aiSourceBytes = srcBytes-      , aiEndOffset   = B.length srcBytes }+      , aiEndOffset   = B.length srcBytes+      , aiPosition    = initPosition {filePath = filename} }  collectFreeTokens :: FortranVersion -> B.ByteString -> [Token] collectFreeTokens version srcInput =

@@ -10,6 +10,7 @@                                          , 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 import Data.Char (toLower)@@ -39,7 +40,8 @@   , (Fortran77Extended, fromParseResult `after` extended77Parser)   , (Fortran77Legacy, fromParseResult `after` legacy77Parser)   , (Fortran90, fromParseResult `after` fortran90Parser)-  , (Fortran95, fromParseResult `after` fortran95Parser) ]+  , (Fortran95, fromParseResult `after` fortran95Parser)+  , (Fortran2003, fromParseResult `after` fortran2003Parser) ]  type ParserWithModFiles = ModFiles -> B.ByteString -> String -> Either ParseErrorSimple (ProgramFile A0) parserWithModFilesVersions :: [(FortranVersion, ParserWithModFiles)]@@ -49,9 +51,11 @@   , (Fortran77Extended, \m s -> fromParseResult . extended77ParserWithModFiles m s)   , (Fortran77Legacy, \m s -> fromParseResult . legacy77ParserWithModFiles m s)   , (Fortran90, \m s -> fromParseResult . fortran90ParserWithModFiles m s)-  , (Fortran95, \m s -> fromParseResult . fortran95ParserWithModFiles m s) ]+  , (Fortran95, \m s -> fromParseResult . fortran95ParserWithModFiles m s)+  , (Fortran2003, \m s -> fromParseResult . fortran2003ParserWithModFiles m s) ] -after g f x = g . (f x)+after :: (b -> c) -> (t -> a -> b) -> t -> a -> c+after g f x = g . f x  -- | Deduce the type of parser from the filename and parse the -- contents of the file.@@ -65,4 +69,17 @@ fortranParserWithModFiles :: ParserWithModFiles fortranParserWithModFiles mods contents filename = do    let Just parserF = lookup (deduceVersion filename) parserWithModFilesVersions+   parserF mods contents filename++-- | Given a FortranVersion, parse the contents of the file.+fortranParserWithVersion :: FortranVersion -> Parser+fortranParserWithVersion v contents filename = do+   let Just parserF = lookup v parserVersions+   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 = do+   let Just parserF = lookup v parserWithModFilesVersions    parserF mods contents filename

@@ -0,0 +1,1328 @@+-- -*- Mode: Haskell -*-+{+-- Incomplete work-in-progress.+module Language.Fortran.Parser.Fortran2003 ( functionParser+                                           , statementParser+                                           , fortran2003Parser+                                           , fortran2003ParserWithModFiles+                                           ) 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 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 _ _ }+  ','                         { 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 _ }+  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 '%'++%%++-- 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) }++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 }+: 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 }++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 DECLARATOR_LIST+  { let declAList = fromReverseList $3+    in StDimension () (getTransSpan $1 declAList) declAList }+| allocatable MAYBE_DCOLON DECLARATOR_LIST+  { let declAList = fromReverseList $3+    in StAllocatable () (getTransSpan $1 declAList) declAList }+| asynchronous MAYBE_DCOLON DECLARATOR_LIST+  { let declAList = fromReverseList $3+    in StAsynchronous () (getTransSpan $1 declAList) declAList }+| pointer MAYBE_DCOLON DECLARATOR_LIST+  { let declAList = fromReverseList $3+    in StPointer () (getTransSpan $1 declAList) declAList }+| target MAYBE_DCOLON DECLARATOR_LIST+  { let declAList = fromReverseList $3+    in StTarget () (getTransSpan $1 declAList) declAList }+| value MAYBE_DCOLON DECLARATOR_LIST+  { let declAList = fromReverseList $3+    in StValue () (getTransSpan $1 declAList) declAList }+| volatile MAYBE_DCOLON 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 }+: VARIABLE '=' EXPRESSION { DeclVariable () (getTransSpan $1 $3) $1 Nothing (Just $3) }+| VARIABLE { DeclVariable () (getSpan $1) $1 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 }+| if '(' EXPRESSION ')' then { StIfThen () (getTransSpan $1 $5) Nothing $3 }+| id ':' if '(' EXPRESSION ')' then+  { let TId s id = $1 in StIfThen () (getTransSpan s $7) (Just id) $5 }+| elsif '(' EXPRESSION ')' then { StElsif () (getTransSpan $1 $5) Nothing $3 }+| elsif '(' EXPRESSION ')' then id+  { let TId s id = $6 in StElsif () (getTransSpan $1 s) (Just id) $3 }+| else { StElse () (getSpan $1) Nothing }+| else id { let TId s id = $2 in StElse () (getTransSpan $1 s) (Just id) }+| endif { StEndif () (getSpan $1) Nothing }+| endif id { let TId s id = $2 in StEndif () (getTransSpan $1 s) (Just id) }+| 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) }+| selectcase '(' EXPRESSION ')'+  { StSelectCase () (getTransSpan $1 $4) Nothing $3 }+| id ':' selectcase '(' EXPRESSION ')'+  { let TId s id = $1 in StSelectCase () (getTransSpan s $6) (Just id) $5 }+| case default { StCase () (getTransSpan $1 $2) Nothing Nothing }+| case default id+  { let TId s id = $3 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) }+| 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 PART_REFS+  { let alist = fromReverseList $2+    in CommonGroup () (getTransSpan $1 alist) (Just $1) alist }+| '/' '/' PART_REFS+  { let alist = fromReverseList $3+    in CommonGroup () (getTransSpan $1 alist) Nothing alist }++INIT_COMMON_GROUP :: { CommonGroup A0 }+: COMMON_NAME PART_REFS+  { let alist = fromReverseList $2+    in CommonGroup () (getTransSpan $1 alist) (Just $1) alist }+| '/' '/' PART_REFS+  { let alist = fromReverseList $3+    in CommonGroup () (getTransSpan $1 alist) Nothing alist }+| PART_REFS+  { 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+  { DeclVariable () (getTransSpan $1 $3) $1 Nothing (Just $3) }++DECLARATION_STATEMENT :: { Statement A0 }+: TYPE_SPEC ATTRIBUTE_LIST '::' 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 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 }++DECLARATOR_LIST :: { [ Declarator A0 ] }+: DECLARATOR_LIST ',' INITIALISED_DECLARATOR { $3 : $1 }+| INITIALISED_DECLARATOR { [ $1 ] }++INITIALISED_DECLARATOR :: { Declarator A0 }+: DECLARATOR '=' EXPRESSION { setInitialisation $1 $3 }+| DECLARATOR '=>' EXPRESSION { setInitialisation $1 $3 }+| DECLARATOR { $1 }++DECLARATOR :: { Declarator A0 }+: VARIABLE { DeclVariable () (getSpan $1) $1 Nothing Nothing }+| VARIABLE '*' EXPRESSION+  { DeclVariable () (getTransSpan $1 $3) $1 (Just $3) Nothing }+| VARIABLE '*' '(' '*' ')'+  { let star = ExpValue () (getSpan $4) ValStar+    in DeclVariable () (getTransSpan $1 $5) $1 (Just star) Nothing }+| VARIABLE '(' DIMENSION_DECLARATORS ')'+  { DeclArray () (getTransSpan $1 $4) $1 (aReverse $3) Nothing Nothing }+| VARIABLE '(' DIMENSION_DECLARATORS ')' '*' EXPRESSION+  { DeclArray () (getTransSpan $1 $6) $1 (aReverse $3) (Just $6) Nothing }+| VARIABLE '(' DIMENSION_DECLARATORS ')' '*' '(' '*' ')'+  { let star = ExpValue () (getSpan $7) ValStar+    in DeclArray () (getTransSpan $1 $8) $1 (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)) (uncurry TypeCharacter $ charLenSelector $2) $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) }+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 }+| boz { let TBozLiteral s i = $1 in ExpValue () s $ ValInteger i }++REAL_LITERAL :: { Expression A0 }+: float { let TRealLiteral s r = $1 in ExpValue () s $ ValReal r }++LOGICAL_LITERAL :: { Expression A0 }+: bool { let TLogicalLiteral s b = $1 in ExpValue () s $ ValLogical b }++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++transformations2003 =+  [ GroupLabeledDo+  , GroupDo+  , GroupIf+  , GroupCase+  , DisambiguateIntrinsic+  , DisambiguateFunction+  ]++fortran2003Parser ::+     B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)+fortran2003Parser sourceCode filename =+    (pfSetFilename filename . transform transformations2003) <$> parse parseState+  where+    parseState = initParseState sourceCode Fortran2003 filename++fortran2003ParserWithModFiles ::+     ModFiles -> B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)+fortran2003ParserWithModFiles mods sourceCode filename =+    fmap (pfSetFilename filename . transform) $ parse parseState+  where+    transform = transformWithModFiles mods transformations2003+    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 _ = ""++}

@@ -128,11 +128,11 @@ OTHER_PROGRAM_UNIT :: { ProgramUnit A0 } OTHER_PROGRAM_UNIT : TYPE_SPEC function NAME MAYBE_ARGUMENTS NEWLINE BLOCKS end MAYBE_NEWLINE-  { PUFunction () (getTransSpan $1 $7) (Just $1) (None () initSrcSpan False) $3 $4 Nothing (reverse $6) Nothing }+  { 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 (None () initSrcSpan False) $2 $3 Nothing (reverse $5) Nothing  }+  { 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) (None () initSrcSpan False) $2 $3 (reverse $5) Nothing }+  { 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) }

@@ -207,11 +207,11 @@ : 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) (None () initSrcSpan False) $3 $4 Nothing (reverse $6) Nothing }+  { 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 (None () initSrcSpan False) $2 $3 Nothing (reverse $5) Nothing }+  { PUFunction () (getTransSpan $1 $6) Nothing emptyPrefixSuffix $2 $3 Nothing (reverse $5) Nothing } | subroutine NAME MAYBE_ARGUMENTS NEWLINE BLOCKS ENDSUB-  { PUSubroutine () (getTransSpan $1 $6) (None () initSrcSpan False) $2 $3 (reverse $5) Nothing }+  { 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) }@@ -1003,7 +1003,7 @@ | complex KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeComplex $2 } | doubleComplex KIND_SELECTOR   { TypeSpec () (getSpan ($1, $2)) TypeDoubleComplex $2 }-| character CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeCharacter $2 }+| character CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) (uncurry TypeCharacter $ charLenSelector $2) $2 } | byte KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeByte $2 } | record '/' NAME '/' { TypeSpec () (getSpan ($1, $4)) (TypeCustom $3) Nothing } @@ -1121,10 +1121,10 @@     doParse = case parse parseState of       ParseFailed e -> return (ParseFailed e)       ParseOk p x -> do-        p' <- descendBiM (inlineInclude Fortran77Legacy incs) p+        p' <- descendBiM (inlineInclude Fortran77Legacy incs []) p         return (ParseOk p' x)     transform = transformWithModFiles emptyModFiles transformations77Legacy-    parseState = initParseState sourceCode Fortran77Legacy filename+    parseState = initParseState (truncateLines sourceCode) Fortran77Legacy filename  includeParser ::     FortranVersion -> B.ByteString -> String -> ParseResult AlexInput Token [Block A0]@@ -1134,15 +1134,17 @@     -- ensure the file ends with a newline..     parseState = initParseState (sourceCode `B.snoc` '\n') version filename -inlineInclude :: FortranVersion -> [String] -> Statement A0 -> IO (Statement A0)-inlineInclude fv dirs st = case st of+inlineInclude :: FortranVersion -> [String] -> [String] -> Statement A0 -> IO (Statement A0)+inlineInclude fv dirs seen st = case st of   StInclude a s e@(ExpValue _ _ (ValString path)) Nothing -> do-    inc <- truncateLines <$> readInDirs dirs path-    case includeParser fv inc path of-      ParseOk blocks _ -> do-        blocks' <- descendBiM (inlineInclude fv dirs) blocks-        return $ StInclude a s e (Just blocks')-      ParseFailed e -> throwIO e+    if notElem path seen then do+      inc <- truncateLines <$> readInDirs dirs path+      case includeParser fv inc path of+        ParseOk blocks _ -> do+          blocks' <- descendBiM (inlineInclude fv dirs (path:seen)) blocks+          return $ StInclude a s e (Just blocks')+        ParseFailed e -> throwIO e+    else return st   _ -> return st  readInDirs :: [String] -> String -> IO B.ByteString

@@ -9,6 +9,7 @@ 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@@ -119,6 +120,7 @@   equivalence                 { TEquivalence _ }   common                      { TCommon _ }   allocate                    { TAllocate _ }+  stat                        { TStat _ }   deallocate                  { TDeallocate _ }   nullify                     { TNullify _ }   none                        { TNone _ }@@ -237,37 +239,45 @@ | {- EMPTY -} { [ ] }  SUBPROGRAM_UNIT :: { ProgramUnit A0 }-: TYPE_SPEC function NAME MAYBE_ARGUMENTS MAYBE_COMMENT RESULT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END-  {% do { unitNameCheck $10 $3;-          return $ PUFunction () (getTransSpan $1 $10) (Just $1) (None () initSrcSpan False) $3 $4 $6 (reverse $8) $9 } }-| TYPE_SPEC recursive function NAME MAYBE_ARGUMENTS MAYBE_COMMENT RESULT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END-  {% do { unitNameCheck $11 $4;-          return $ PUFunction () (getTransSpan $1 $11) (Just $1) (None () (getSpan $2) True) $4 $5 $7 (reverse $9) $10 } }-| recursive TYPE_SPEC function NAME MAYBE_ARGUMENTS RESULT MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END-  {% do { unitNameCheck $11 $4;-          return $ PUFunction () (getTransSpan $1 $11) (Just $2) (None () (getSpan $1) True) $4 $5 $6 (reverse $9) $10 } }-| function NAME MAYBE_ARGUMENTS RESULT MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END-  {% do { unitNameCheck $9 $2;-          return $ PUFunction () (getTransSpan $1 $9) Nothing (None () initSrcSpan False) $2 $3 $4 (reverse $7) $8 } }-| recursive function NAME MAYBE_ARGUMENTS RESULT MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END+: PREFIXES function NAME MAYBE_ARGUMENTS MAYBE_RESULT MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END   {% do { unitNameCheck $10 $3;-          return $ PUFunction () (getTransSpan $1 $10) Nothing (None () initSrcSpan True) $3 $4 $5 (reverse $8) $9 } }-| subroutine NAME MAYBE_ARGUMENTS MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS SUBROUTINE_END-  {% do { unitNameCheck $8 $2;-          return $ PUSubroutine () (getTransSpan $1 $8) (None () initSrcSpan False) $2 $3 (reverse $6) $7 } }-| recursive subroutine NAME MAYBE_ARGUMENTS MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS SUBROUTINE_END+          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;-          return $ PUSubroutine () (getTransSpan $1 $9) (None () initSrcSpan True) $3 $4 (reverse $7) $8 } }+          (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 } -RESULT :: { Maybe (Expression a) }-: result '(' VARIABLE ')' { Just $3 }-| {- EMPTY -} { Nothing }- PROGRAM_END :: { Token } : end { $1 } | endProgram { $1 } | endProgram id { $2 } MODULE_END :: { Token }@@ -278,6 +288,8 @@ : 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 } @@ -287,10 +299,10 @@ : 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 NEWLINE SUBPROGRAM_UNITS2 MODULE_PROCEDURES endInterface NEWLINE-  { BlInterface () (getTransSpan $1 $7) $2 $4 $5 }-| interface MAYBE_EXPRESSION NEWLINE MODULE_PROCEDURES endInterface NEWLINE-  { BlInterface () (getTransSpan $1 $6) $2 [ ] $4 }+| 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 }  MAYBE_EXPRESSION :: { Maybe (Expression A0) }@@ -306,13 +318,14 @@  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 NEWLINE+: moduleProcedure VARIABLES MAYBE_COMMENT NEWLINE   { let { al = fromReverseList $2;           st = StModuleProcedure () (getTransSpan $1 al) (fromReverseList $2) }-    in BlStatement () (getTransSpan $1 $3) Nothing st }+    in BlStatement () (getTransSpan $1 $4) Nothing st }  COMMENT_BLOCK :: { Block A0 } : comment NEWLINE { let (TComment s c) = $1 in BlComment () s (Comment c) }@@ -383,24 +396,23 @@ | common cCOMMON COMMON_GROUPS cPOP   { let commonAList = fromReverseList $3     in StCommon () (getTransSpan $1 commonAList) commonAList }-| external VARIABLES-  { let alist = fromReverseList $2+| external MAYBE_DCOLON VARIABLES+  { let alist = fromReverseList $3     in StExternal () (getTransSpan $1 alist) alist }-| intrinsic VARIABLES-  { let alist = fromReverseList $2+| intrinsic MAYBE_DCOLON VARIABLES+  { let alist = fromReverseList $3     in StIntrinsic () (getTransSpan $1 alist) alist }-| use VARIABLE { StUse () (getTransSpan $1 $2) $2 Permissive Nothing }+| use VARIABLE { StUse () (getTransSpan $1 $2) $2 Nothing Permissive Nothing } | use VARIABLE ',' RENAME_LIST   { let alist = fromReverseList $4-    in StUse () (getTransSpan $1 alist) $2 Permissive (Just alist) }-| use VARIABLE ',' only ':' RENAME_LIST-  { let alist = fromReverseList $6-    in StUse () (getTransSpan $1 alist) $2 Exclusive (Just alist) }-| entry VARIABLE RESULT+    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 '(' ')' RESULT+| entry VARIABLE '(' ')' MAYBE_RESULT   { StEntry () (getTransSpan $1 $ maybe (getSpan $4) getSpan $5) $2 Nothing $5 }-| entry VARIABLE '(' VARIABLES ')' RESULT+| 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@@ -419,23 +431,20 @@   { let TBlob s blob = $2 in StFormatBogus () (getTransSpan $1 s) blob }  EXECUTABLE_STATEMENT :: { Statement A0 }-: allocate '(' DATA_REFS ')'-  { StAllocate () (getTransSpan $1 $4) (fromReverseList $3) Nothing }-| allocate '(' DATA_REFS ',' CILIST_PAIR ')'-  { StAllocate () (getTransSpan $1 $6) (fromReverseList $3) (Just $5) }+: 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 ')'-  { StDeallocate () (getTransSpan $1 $4) (fromReverseList $3) Nothing }-| deallocate '(' DATA_REFS ',' CILIST_PAIR ')'-  { StDeallocate () (getTransSpan $1 $6) (fromReverseList $3) (Just $5) }+| 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) $3 }-| elsewhere { StElsewhere () (getSpan $1) }-| endwhere { StEndWhere () (getSpan $1) }+| 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 } | if '(' EXPRESSION ')' then { StIfThen () (getTransSpan $1 $5) Nothing $3 }@@ -550,6 +559,10 @@ | 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 ] }@@ -557,6 +570,10 @@ 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 -} { () } @@ -643,6 +660,10 @@ | 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 ] }@@ -755,7 +776,7 @@ | private { AttrPrivate () (getSpan $1) } | allocatable { AttrAllocatable () (getSpan $1) } | dimension '(' DIMENSION_DECLARATORS ')'-  { AttrDimension () (getTransSpan $1 $4) $3 }+  { AttrDimension () (getTransSpan $1 $4) (aReverse $3) } | external { AttrExternal () (getSpan $1) } | intent '(' INTENT_CHOICE ')' { AttrIntent () (getTransSpan $1 $4) $3 } | intrinsic { AttrIntrinsic () (getSpan $1) }@@ -811,12 +832,12 @@   { let star = ExpValue () (getSpan $4) ValStar     in DeclVariable () (getTransSpan $1 $5) $1 (Just star) Nothing } | VARIABLE '(' DIMENSION_DECLARATORS ')'-  { DeclArray () (getTransSpan $1 $4) $1 $3 Nothing Nothing }+  { DeclArray () (getTransSpan $1 $4) $1 (aReverse $3) Nothing Nothing } | VARIABLE '(' DIMENSION_DECLARATORS ')' '*' EXPRESSION-  { DeclArray () (getTransSpan $1 $6) $1 $3 (Just $6) Nothing }+  { DeclArray () (getTransSpan $1 $6) $1 (aReverse $3) (Just $6) Nothing } | VARIABLE '(' DIMENSION_DECLARATORS ')' '*' '(' '*' ')'   { let star = ExpValue () (getSpan $7) ValStar-    in DeclArray () (getTransSpan $1 $8) $1 $3 (Just star) Nothing }+    in DeclArray () (getTransSpan $1 $8) $1 (aReverse $3) (Just star) Nothing }  DIMENSION_DECLARATORS :: { AList DimensionDeclarator A0 } : DIMENSION_DECLARATORS ',' DIMENSION_DECLARATOR@@ -848,7 +869,7 @@ | 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 }+| character CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) (uncurry TypeCharacter $ charLenSelector $2) $2 } | logical KIND_SELECTOR   { TypeSpec () (getSpan ($1, $2)) TypeLogical $2 } | type '(' id ')'   { let TId _ id = $3@@ -859,6 +880,8 @@   { 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) }@@ -874,6 +897,8 @@   { 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 ')'