fortran-src 0.6.1 → 0.7.0

raw patch · 43 files changed

+1056/−600 lines, 43 filesdep +QuickCheckPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck

API changes (from Hackage documentation)

Files

• CHANGELOG.md +26/−0
• README.md +80/−36
• fortran-src.cabal +18/−5
• src/Language/Fortran/AST.hs +19/−14
• src/Language/Fortran/AST/Boz.hs +71/−0
• src/Language/Fortran/AST/RealLit.hs +96/−0
• src/Language/Fortran/Analysis/BBlocks.hs +9/−8
• src/Language/Fortran/Analysis/DataFlow.hs +11/−6
• src/Language/Fortran/Analysis/Renaming.hs +17/−3
• src/Language/Fortran/Analysis/SemanticTypes.hs +4/−4
• src/Language/Fortran/Analysis/Types.hs +102/−61
• src/Language/Fortran/Lexer/FixedForm.x +14/−12
• src/Language/Fortran/Lexer/FixedForm/Utils.hs +19/−0
• src/Language/Fortran/Lexer/FreeForm.x +25/−24
• src/Language/Fortran/Parser/Fortran2003.y +28/−4
• src/Language/Fortran/Parser/Fortran66.y +15/−74
• src/Language/Fortran/Parser/Fortran77.y +8/−18
• src/Language/Fortran/Parser/Fortran90.y +28/−4
• src/Language/Fortran/Parser/Fortran95.y +28/−4
• src/Language/Fortran/Parser/Utils.hs +2/−87
• src/Language/Fortran/PrettyPrint.hs +18/−4
• src/Language/Fortran/Rewriter/Internal.hs +39/−15
• src/Language/Fortran/Transformation/Grouping.hs +2/−2
• test/Language/Fortran/AST/BozSpec.hs +14/−0
• test/Language/Fortran/AST/RealLitSpec.hs +29/−0
• test/Language/Fortran/Analysis/BBlocksSpec.hs +1/−1
• test/Language/Fortran/Analysis/DataFlowSpec.hs +8/−1
• test/Language/Fortran/Analysis/RenamingSpec.hs +21/−0
• test/Language/Fortran/Analysis/SemanticTypesSpec.hs +1/−1
• test/Language/Fortran/Analysis/TypesSpec.hs +72/−18
• test/Language/Fortran/Lexer/FixedFormSpec.hs +9/−5
• test/Language/Fortran/Lexer/FreeFormSpec.hs +23/−14
• test/Language/Fortran/Parser/Fortran2003Spec.hs +4/−1
• test/Language/Fortran/Parser/Fortran66Spec.hs +0/−29
• test/Language/Fortran/Parser/Fortran77/ParserSpec.hs +32/−38
• test/Language/Fortran/Parser/Fortran90Spec.hs +28/−26
• test/Language/Fortran/Parser/Fortran95Spec.hs +20/−17
• test/Language/Fortran/Parser/FreeFormCommon.hs +68/−0
• test/Language/Fortran/Parser/UtilsSpec.hs +0/−51
• test/Language/Fortran/PrettyPrintSpec.hs +15/−0
• test/Language/Fortran/Rewriter/InternalSpec.hs +12/−0
• test/Language/Fortran/Transformation/GroupingSpec.hs +9/−6
• test/TestUtil.hs +11/−7

@@ -1,3 +1,29 @@+### 0.7.0 (Dec 09, 2021)+  * No longer treat `!` in strings as comments in continuation reformatter+    (thanks @envp) #179+  * CI builds on Mac; more release automation #181 #189+  * Handle nonstandard kind parameter in parsing & type analysis #188+  * Fix renamer ambiguity resulting in unusual name-related breakages (e.g.+    `ValVariable` not getting transformed to `ValIntrinsic`) #190+  * Fully parse logical literals early (don't leave as `String`) #185+    * Code that touches `ValLogical` will have to be updated -- it should mean+      removal of user-side parsing.+  * Explicitly parse integer literal kind parameter #191+    * The `String` representation stored should now always be safe to `read` to+      a Haskell `Integral`.+  * Provide real literals in a semi-parsed "decomposed" format #193+    * Kind parameters are also made explicit.+    * Libraries with custom real literal parsing should be able to replace it+      with `readRealLit :: (Fractional a, Read a) => RealLit -> a`.+  * BOZ literal constants receive their own `Value` constructor (instead of+    sharing one with integers) #194+    * Also parse them to an intermediate data type and provide handling+      functions.++Note that kind parameters are disabled in fixed form parsers (F77, F66), so for+codebases targeting older standards, many changes will be along the lines of+`ValInteger x` -> `ValInteger x _`.+ ### 0.6.1 (Sep 17, 2021)   * Properly include test data in package dist (in preparation for placing on     Stackage)

@@ -1,33 +1,68 @@ # fortran-src-![CI status badge](https://github.com/camfort/fortran-src/workflows/CI/badge.svg)+![CI status badge](https://github.com/camfort/fortran-src/actions/workflows/ci.yml/badge.svg) -Provides lexing, parsing, and basic analyses of Fortran code covering standards: FORTRAN 66, FORTRAN 77, Fortran 90, Fortran 95 and part of Fortran 2003. Includes data flow and basic block analysis, a renamer, and type analysis. For example usage, see the 'camfort' project (https://github.com/camfort/camfort), which uses fortran-src as its front end.+Provides lexing/parsing and early static analyses of Fortran code. The following+Fortran standards are covered: -For features that output graphs, the intended usage is to pipe it into the command 'dot -Tpdf' and redirect that into a PDF file. The 'dot' command is part of the GraphViz project (https://www.graphviz.org/), please see their manual for the many other options that can be explored for visualisation purposes.+  * FORTRAN 66 (ANSI X3.9-1966)+  * FORTRAN 77 (ANSI X3.9-1978 / ISO 1539:1980)+  * Fortran 90 (ISO/IEC 1539:1991)+  * Fortran 95 (ISO/IEC 1539-1:1997+  * Fortran 2003 (partial) -    Usage: fortran-src [OPTION...] <file>-      -v VERSION, -F VERSION  --fortranVersion=VERSION         Fortran version to use, format: Fortran[66/77/77Legacy/77Extended/90]-      -a ACTION               --action=ACTION                  lex or parse action-      -t                      --typecheck                      parse and run typechecker-      -R                      --rename                         parse and rename variables-      -B                      --bblocks                        analyse basic blocks-      -S                      --supergraph                     analyse super graph of basic blocks-      -r                      --reprint                        Parse and output using pretty printer-                              --dot                            output graphs in GraphViz DOT format-                              --dump-mod-file                  dump the information contained within mod files-      -I DIR                  --include-dir=DIR                directory to search for precompiled 'mod files'-      -c                      --compile                        compile an .fsmod file from the input-                              --show-block-numbers[=LINE-NUM]  Show the corresponding AST-block identifier number next to every line of code.-                              --show-flows-to=AST-BLOCK-ID     dump a graph showing flows-to information from the given AST-block ID; prefix with 's' for supergraph-                              --show-flows-from=AST-BLOCK-ID   dump a graph showing flows-from information from the given AST-block ID; prefix with 's' for supergraph+Parsing is configurable, and you can select the Fortran standard to target,+including special extended modes for nonstandard FORTRAN 77. +Includes data flow and basic block analysis, a renamer, and type analysis.++This package primarily exports a Haskell library, but also builds an executable+that can be used for testing and debugging. For example usage, see the+[CamFort](https://github.com/camfort/camfort) project, which uses fortran-src as+its front end.++## Obtaining+We provide [prebuilt binaries](https://github.com/camfort/fortran-src/releases)+for Windows, Mac and Linux.++## Usage+Add `fortran-src` as a dependency in your Haskell project. We're on+[Hackage](https://hackage.haskell.org/package/fortran-src) and also on+[Stackage](https://www.stackage.org/package/fortran-src).++### Command-line tool+You can also invoke `fortran-src` on the command line.++For features that output graphs, the intended usage is to pipe it into the+command `dot -Tpdf` and redirect that into a PDF file. The `dot` command is part+of the [GraphViz project](https://www.graphviz.org/), please see their manual+for the many other options that can be explored for visualisation purposes.++```+Usage: fortran-src [OPTION...] <file>+  -v VERSION, -F VERSION  --fortranVersion=VERSION         Fortran version to use, format: Fortran[66/77/77Legacy/77Extended/90]+  -a ACTION               --action=ACTION                  lex or parse action+  -t                      --typecheck                      parse and run typechecker+  -R                      --rename                         parse and rename variables+  -B                      --bblocks                        analyse basic blocks+  -S                      --supergraph                     analyse super graph of basic blocks+  -r                      --reprint                        Parse and output using pretty printer+                          --dot                            output graphs in GraphViz DOT format+                          --dump-mod-file                  dump the information contained within mod files+  -I DIR                  --include-dir=DIR                directory to search for precompiled 'mod files'+  -c                      --compile                        compile an .fsmod file from the input+                          --show-block-numbers[=LINE-NUM]  Show the corresponding AST-block identifier number next to every line of code.+                          --show-flows-to=AST-BLOCK-ID     dump a graph showing flows-to information from the given AST-block ID; prefix with 's' for supergraph+                          --show-flows-from=AST-BLOCK-ID   dump a graph showing flows-from information from the given AST-block ID; prefix with 's' for supergraph+```+ ## Building fortran-src supports building with Stack or Cabal. You should be able to build-and use without any dependencies other than GHC itself.+and use without any system dependencies other than GHC itself. Haskell library+dependencies are listed in `package.yaml`. -As of 2021-04-28, fortran-src supports and is regularly tested on **GHC 8.6,-8.8, 8.10 and 9.0**. Releases prior to/newer than those may have issues. We-welcome fixes that would let us support a wider range of compilers.+fortran-src supports **GHC 8.4 through GHC 9.0**. We regularly test at least the+minimum and maximum supported GHCs. Releases prior to/newer than those may have+issues. We welcome fixes that would let us support a wider range of compilers.  You will likely need **at least 3 GiBs of memory** to build fortran-src. @@ -72,21 +107,16 @@ cabal build ``` +### Testing+Unit tests are stored in `test`. Run with `stack test` or `cabal test`.+ ## Usage ### As a dependency-fortran-src is available on Hackage, so add `fortran-src` to your project-dependencies. That's all.--If you're using Stack, note that Stackage retains an old version watch out,-because TODO--TODO you can stuff a Hackage reference into `stack.yaml` using-`extra-deps`, like:--fortran-src is available on Hackage. Stackage has a very old version and is-definitely not what you want, but you can specify a newer Hackage version in-`stack.yaml` to use it conveniently with Stack-based projects.+fortran-src is available on Hackage and Stackage, so for Cabal or Stack projects+you should only need to add `fortran-src` to your project dependencies. +If you need a specific version of fortran-src in a Stack setup, you can stuff a+Hackage reference into `stack.yaml` using `extra-deps`, like:  ```yaml resolver: ...@@ -105,5 +135,19 @@ cabal install fortran-src ``` -Otherwise, we suggest building from source if you want to use the fortran-src-CLI tool. See [#Build from source](#build-from-source) for details.+We provide prebuilt binaries for some platforms: see the+[Releases](https://github.com/camfort/fortran-src/releases) tab.++Otherwise, you can build from source and use convenience commands like `cabal+run`, `stack run`. See [#Building](#building) for details.++## Contributing+We welcome bug reports, fixes and feature proposals. Add an issue or create a+pull request on the GitHub repository.++## Support+You may be able to find maintainers on the [Libera.Chat](https://libera.chat/)+IRC network. Check in #fortran-src and #camfort . Otherwise, you could get into+contact with one of the team on the [CamFort team+page](https://camfort.github.io/team.html) -- or create an issue describing your+problem and we'll have a look.

@@ -5,17 +5,23 @@ -- see: https://github.com/sol/hpack  name:           fortran-src-version:        0.6.1-synopsis:       Parsers and analyses 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.+version:        0.7.0+synopsis:       Parsers and analyses for Fortran standards 66, 77, 90, 95 and 2003 (partial).+description:    Provides lexing, parsing, and basic analyses of Fortran code covering standards: FORTRAN 66, FORTRAN 77, Fortran 90, Fortran 95, Fortran 2003 (partial) and some legacy extensions. Includes data flow and basic block analysis, a renamer, and type analysis. For example usage, see the @<https://hackage.haskell.org/package/camfort CamFort>@ project, which uses fortran-src as its front end. category:       Language 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+author:         Mistral Contrastin,+                Matthew Danish,+                Dominic Orchard,+                Andrew Rice+maintainer:     me@madgen.net,+                Ben Orchard license:        Apache-2.0 license-file:   LICENSE build-type:     Simple+tested-with:+    GHC >= 8.4 extra-source-files:     README.md     CHANGELOG.md@@ -65,10 +71,13 @@       Language.Fortran.Analysis.DataFlow       Language.Fortran.AST       Language.Fortran.AST.AList+      Language.Fortran.AST.RealLit+      Language.Fortran.AST.Boz       Language.Fortran.Version       Language.Fortran.LValue       Language.Fortran.Intrinsics       Language.Fortran.Lexer.FixedForm+      Language.Fortran.Lexer.FixedForm.Utils       Language.Fortran.Lexer.FreeForm       Language.Fortran.ParserMonad       Language.Fortran.Parser.Any@@ -149,6 +158,8 @@       Language.Fortran.Analysis.SemanticTypesSpec       Language.Fortran.Analysis.TypesSpec       Language.Fortran.AnalysisSpec+      Language.Fortran.AST.BozSpec+      Language.Fortran.AST.RealLitSpec       Language.Fortran.Lexer.FixedFormSpec       Language.Fortran.Lexer.FreeFormSpec       Language.Fortran.Parser.Fortran2003Spec@@ -158,6 +169,7 @@       Language.Fortran.Parser.Fortran77.ParserSpec       Language.Fortran.Parser.Fortran90Spec       Language.Fortran.Parser.Fortran95Spec+      Language.Fortran.Parser.FreeFormCommon       Language.Fortran.Parser.UtilsSpec       Language.Fortran.ParserMonadSpec       Language.Fortran.PrettyPrintSpec@@ -176,6 +188,7 @@       hspec-discover:hspec-discover   build-depends:       GenericPretty >=1.2.2 && <2+    , QuickCheck >=2.10 && <2.15     , array ==0.5.*     , base >=4.6 && <5     , binary >=0.8.3.0 && <0.11

@@ -114,19 +114,22 @@   ) where  import Prelude hiding (init)++import Language.Fortran.AST.AList+import Language.Fortran.AST.RealLit+import Language.Fortran.AST.Boz (Boz)+import Language.Fortran.Util.Position+import Language.Fortran.Util.FirstParameter+import Language.Fortran.Util.SecondParameter+import Language.Fortran.Version (FortranVersion(..))+ import Data.Data import Data.Generics.Uniplate.Data () import Data.Typeable () import Data.Binary import Control.DeepSeq import Text.PrettyPrint.GenericPretty-import Language.Fortran.Version (FortranVersion(..)) -import Language.Fortran.Util.Position-import Language.Fortran.Util.FirstParameter-import Language.Fortran.Util.SecondParameter-import Language.Fortran.AST.AList- -- | The empty annotation. type A0 = () @@ -604,22 +607,24 @@   deriving (Eq, Show, Data, Typeable, Generic, Functor)  -- All recursive Values-data Value a =-    ValInteger           String+data Value a+  = ValInteger           String (Maybe (Expression a))   -- ^ The string representation of an integer literal-  | ValReal              String+  | ValReal              RealLit (Maybe (Expression a))   -- ^ The string representation of a real literal   | ValComplex           (Expression a) (Expression a)   -- ^ The real and imaginary parts of a complex value   | ValString            String   -- ^ A string literal+  | ValBoz               Boz+  -- ^ A BOZ literal constant   | ValHollerith         String   -- ^ A Hollerith literal   | ValVariable          Name   -- ^ The name of a variable   | ValIntrinsic         Name   -- ^ The name of a built-in function-  | ValLogical           String+  | ValLogical           Bool (Maybe (Expression a))   -- ^ A boolean value   | ValOperator          String   -- ^ User-defined operators in interfaces@@ -655,10 +660,10 @@ -- Syntax note: length is set like @character :: str*10@, dimensions are set -- like @integer :: arr(10)@. Careful to not get confused. ----- Note that according to HP's F90 spec, lengths may only be specified for--- CHARACTER types. So for any declarations that aren't 'TypeCharacter' in the--- outer 'TypeSpec', the length expression should be Nothing. However, this is--- not enforced by the AST or parser, so be warned.+-- Note that lengths may only be specified for CHARACTER types. However, a+-- nonstandard syntax feature is to use this as a kind parameter for non+-- CHARACTERs. So we parse length for all 'Declarator's, handle the nonstandard+-- feature and print a warning during our type analysis. data Declarator a =     DeclVariable a SrcSpan                  (Expression a)             -- ^ Variable

@@ -0,0 +1,71 @@+{- | Supporting code for handling Fortran BOZ literal constants.++Using the definition from the latest Fortran standards (F2003, F2008), BOZ+constants are bitstrings (untyped!) which have basically no implicit rules. How+they're interpreted depends on context (they are generally limited to DATA+statements and a small handful of intrinsic functions).+-}++{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, DeriveAnyClass #-}+{-# LANGUAGE LambdaCase #-}++module Language.Fortran.AST.Boz where++import           GHC.Generics+import           Data.Data+import           Control.DeepSeq                ( NFData )+import           Text.PrettyPrint.GenericPretty ( Out )++import qualified Data.List as List+import qualified Data.Char as Char++-- | A Fortran BOZ literal constant.+--+-- The prefix defines the characters allowed in the string:+--+--   * @B@: @[01]@+--   * @O@: @[0-7]@+--   * @Z@: @[0-9 a-f A-F]@+data Boz = Boz+  { bozPrefix :: BozPrefix+  , bozString :: String+  } deriving (Eq, Show, Data, Typeable, Generic, NFData, Out, Ord)++data BozPrefix+  = BozPrefixB+  | BozPrefixO+  | BozPrefixZ -- also @x@+    deriving (Eq, Show, Data, Typeable, Generic, NFData, Out, Ord)++-- | UNSAFE. Parses a BOZ literal constant string.+--+-- Looks for prefix or suffix. Strips the quotes from the string (single quotes+-- only).+parseBoz :: String -> Boz+parseBoz s =+    case List.uncons s of+      Nothing -> errInvalid+      Just (pc, ps) -> case parsePrefix pc of+                         Just p -> Boz p (shave ps)+                         Nothing -> case parsePrefix (List.last s) of+                                      Just p -> Boz p (shave (init s))+                                      Nothing -> errInvalid+  where+    parsePrefix p+      | p' == 'b'            = Just BozPrefixB+      | p' == 'o'            = Just BozPrefixO+      | p' `elem` ['z', 'x'] = Just BozPrefixZ+      | otherwise            = Nothing+      where p' = Char.toLower p+    errInvalid = error "Language.Fortran.AST.BOZ.parseBoz: invalid BOZ string"+    -- | Remove the first and last elements in a list.+    shave = tail . init++-- | Pretty print a BOZ constant. Uses prefix style, and @z@ over nonstandard+--   @x@ for hexadecimal.+prettyBoz :: Boz -> String+prettyBoz b = prettyBozPrefix (bozPrefix b) : '\'' : bozString b <> "'"+  where prettyBozPrefix = \case+          BozPrefixB -> 'b'+          BozPrefixO -> 'o'+          BozPrefixZ -> 'z'

@@ -0,0 +1,96 @@+{- |+Supporting code for handling Fortran REAL literals.++Fortran REAL literals have some idiosyncrasies that prevent them from lining up+with Haskell's reals immediately. So, we parse into an intermediate data type+that can be easily exported with full precision later. Things we do:++  * Strip explicit positive signs so that signed values either begin with the+    minus sign @-@ or no sign. ('Read' doesn't allow explicit positive signs.)+  * Make exponent explicit by adding the default exponent @E0@ if not present.+  * Make implicit zeroes explicit. @.123 -> 0.123@, @123. -> 123.0@. (Again,+    Haskell literals do not support this.)+-}++{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, DeriveAnyClass #-}+{-# LANGUAGE RecordWildCards, LambdaCase #-}++module Language.Fortran.AST.RealLit where++import qualified Data.Char as Char+import           GHC.Generics+import           Data.Data+import           Control.DeepSeq                ( NFData )+import           Text.PrettyPrint.GenericPretty ( Out )++-- | A Fortran real literal. (Does not include the optional kind parameter.)+--+-- A real literal is formed of a signed rational significand, and an 'Exponent'.+--+-- See F90 ISO spec pg.27 / R412-416.+--+-- Note that we support signed real literals, even though the F90 spec indicates+-- non-signed real literals are the "default" (signed are only used in a "spare"+-- rule). Our parsers should parse explicit signs as unary operators. There's no+-- harm in supporting signed literals though, especially since the exponent *is*+-- signed.+data RealLit = RealLit+  { realLitSignificand :: String+  -- ^ A string representing a signed decimal.+  -- ^ Approximate regex: @-? ( [0-9]+ \. [0-9]* | \. [0-9]+ )@+  , realLitExponent    :: Exponent+  } deriving (Eq, Show, Data, Typeable, Generic, NFData, Out, Ord)++-- | An exponent is an exponent letter (E, D) and a signed integer.+data Exponent = Exponent+  { exponentLetter :: ExponentLetter+  , exponentNum    :: String+  } deriving (Eq, Show, Data, Typeable, Generic, NFData, Out, Ord)++-- Note: Some Fortran language references include extensions here. HP's F90+-- reference provides a Q exponent letter which sets kind to 16.+data ExponentLetter+  = ExpLetterE -- ^ KIND=4 (float)+  | ExpLetterD -- ^ KIND=8 (double)+  | ExpLetterQ -- ^ KIND=16 ("quad", rare? extension)+    deriving (Eq, Show, Data, Typeable, Generic, NFData, Out, Ord)++-- | Prettify a 'RealLit' in a Haskell-compatible way.+prettyHsRealLit :: RealLit -> String+prettyHsRealLit r = realLitSignificand r <> "e" <> exponentNum (realLitExponent r)++readRealLit :: (Fractional a, Read a) => RealLit -> a+readRealLit = read . prettyHsRealLit++-- UNSAFE. Expects a valid Fortran REAL literal.+parseRealLit :: String -> RealLit+parseRealLit r =+    let (significandStr, exponentStr) = span isSignificand r+        realLitExponent = parseExponent exponentStr+        realLitSignificand = normalizeSignificand (stripPositiveSign significandStr)+     in RealLit{..}+  where+    -- | Ensure that the given decimal string is in form @x.y@.+    normalizeSignificand str = case span (/= '.') str of+                                 ([], d)  -> '0':d   --    .456+                                 (i, ".") -> i<>".0" -- 123.+                                 (i, "")  -> i<>".0" -- 123+                                 _        -> str     -- 123.456+    parseExponent "" = Exponent { exponentLetter = ExpLetterE, exponentNum = "0" }+    parseExponent (l:str) =+        let exponentLetter = parseExponentLetter l+            exponentNum = stripPositiveSign str+         in Exponent{..}+    stripPositiveSign = \case+      []  -> []+      c:s -> case c of+               '+' ->   s+               _   -> c:s+    isSignificand ch | Char.isDigit ch                 = True+                     | ch `elem` ['.', '-', '+']  = True+                     | otherwise                  = False+    parseExponentLetter ch = case Char.toLower ch of+                               'e' -> ExpLetterE+                               'd' -> ExpLetterD+                               'q' -> ExpLetterQ+                               _   -> error $ "Language.Fortran.AST.RealLit.parseRealLit: invalid exponent letter: " <> [ch]

@@ -17,6 +17,7 @@ import Text.PrettyPrint.GenericPretty (pretty, Out) import Language.Fortran.Analysis import Language.Fortran.AST hiding (setName)+import Language.Fortran.AST.RealLit import Language.Fortran.Util.Position import qualified Data.Map as M import qualified Data.IntMap as IM@@ -278,7 +279,7 @@ 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+    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     ExpValue _ _ (ValVariable l) -> (-1) `fromMaybe` M.lookup l lm     _ -> error "unhandled lookupBBlock"@@ -432,7 +433,7 @@    -- 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+    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 = genVar a''{ insLabel = Nothing } s'' (name i)@@ -490,7 +491,7 @@ perDoBlock repeatExpr b bs = do   (n, doN) <- closeBBlock   case getLabel b of-    Just (ExpValue _ _ (ValInteger l)) -> insertLabel l doN+    Just (ExpValue _ _ (ValInteger l _)) -> insertLabel l doN     _                                  -> return ()   case repeatExpr of Just e -> void (processFunctionCalls e); Nothing -> return ()   addToBBlock $ stripNestedBlocks b@@ -504,7 +505,7 @@ -- Maintains perBlock invariants while potentially starting a new -- bblock in case of a label. processLabel :: Block a -> BBlocker a ()-processLabel b | Just (ExpValue _ _ (ValInteger l)) <- getLabel b = do+processLabel b | Just (ExpValue _ _ (ValInteger l _)) <- getLabel b = do   (n, n') <- closeBBlock   insertLabel l n'   createEdges [(n, n', ())]@@ -687,7 +688,7 @@ findLabeledBBlock :: String -> BBGr a -> Maybe Node findLabeledBBlock llab gr =   listToMaybe [ n | (n, bs) <- labNodes (bbgrGr gr), b <- bs-                  , ExpValue _ _ (ValInteger llab') <- maybeToList (getLabel b)+                  , ExpValue _ _ (ValInteger llab' _) <- maybeToList (getLabel b)                   , llab == llab' ]  -- | Show a basic block graph in a somewhat decent way.@@ -821,14 +822,14 @@ showLab a =   case a of     Nothing -> replicate 6 ' '-    Just (ExpValue _ _ (ValInteger l)) -> ' ':l ++ replicate (5 - length l) ' '+    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 (ValInteger v _)      = v+showValue (ValReal v _)         = prettyHsRealLit v showValue (ValComplex e1 e2)    = "( " ++ showExpr e1 ++ " , " ++ showExpr e2 ++ " )" showValue (ValString s)         = "\\\"" ++ escapeStr s ++ "\\\"" showValue v                     = "<unhandled value: " ++ show (toConstr (fmap (const ()) v)) ++ ">"

@@ -9,7 +9,7 @@   , genUDMap, genDUMap, duMapToUdMap, UDMap, DUMap   , genFlowsToGraph, FlowsGraph   , genVarFlowsToMap, VarFlowsMap-  , Constant(..), ParameterVarMap, ConstExpMap, genConstExpMap, analyseConstExps, analyseParameterVars+  , Constant(..), ParameterVarMap, ConstExpMap, genConstExpMap, analyseConstExps, analyseParameterVars, constantFolding   , genBlockMap, genDefMap, BlockMap, DefMap   , genCallMap, CallMap   , loopNodes, genBackEdgeMap, sccWith, BackEdgeMap@@ -34,6 +34,7 @@ import Language.Fortran.Analysis import Language.Fortran.Analysis.BBlocks (showBlock, ASTBlockNode, ASTExprNode) import Language.Fortran.AST+import Language.Fortran.AST.RealLit import qualified Data.Map as M import qualified Data.IntMap.Lazy as IM import qualified Data.IntMap.Strict as IMS@@ -364,6 +365,10 @@     Subtraction    | inBounds (x - y) -> ConstInt (x - y)     Multiplication | inBounds (x * y) -> ConstInt (x * y)     Division       | y /= 0           -> ConstInt (x `div` y)+    -- gfortran appears to do real exponentiation (allowing negative exponent)+    -- and cast back to integer via floor() (?) as required+    -- but we keep it simple & stick with Haskell-style integer exponentiation+    Exponentiation | y >= 0           -> ConstInt (x ^ y)     _                                 -> ConstBinary binOp (ConstInt x) (ConstInt y)   ConstUnary Minus a | ConstInt x <- constantFolding a -> ConstInt (-x)   ConstUnary Plus  a                                   -> constantFolding a@@ -401,10 +406,10 @@     labelOf = insLabel . getAnnotation     doExpr :: Expression (Analysis a) -> Maybe Constant     doExpr e = case e of-      ExpValue _ _ (ValInteger str)+      ExpValue _ _ (ValInteger str _)         | Just i <- readInteger str -> Just . ConstInt $ fromIntegral i-      ExpValue _ _ (ValInteger str) -> Just $ ConstUninterpInt str-      ExpValue _ _ (ValReal str)    -> Just $ ConstUninterpReal str+      ExpValue _ _ (ValInteger str _) -> Just $ ConstUninterpInt str+      ExpValue _ _ (ValReal r _)    -> Just $ ConstUninterpReal (prettyHsRealLit r) -- TODO       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)@@ -598,7 +603,7 @@ derivedInductionExpr :: Data a => IEFlow -> Expression (Analysis a) -> InductionExpr derivedInductionExpr flow e = case e of   v@(ExpValue _ _ (ValVariable _))   -> fromMaybe IETop $ M.lookup (varName v) (ieFlowVars flow)-  ExpValue _ _ (ValInteger str)+  ExpValue _ _ (ValInteger str _)     | Just i <- readInteger str      -> IELinear "" 0 (fromIntegral i)   ExpBinary _ _ Addition e1 e2       -> derive e1 `addInductionExprs` derive e2   ExpBinary _ _ Subtraction e1 e2    -> derive e1 `addInductionExprs` negInductionExpr (derive e2)@@ -616,7 +621,7 @@                 | otherwise = derivedInductionExprM e'   ie <- case e of         v@(ExpValue _ _ (ValVariable _))   -> pure . fromMaybe IETop $ M.lookup (varName v) (ieFlowVars flow)-        ExpValue _ _ (ValInteger str)+        ExpValue _ _ (ValInteger str _)           | Just i <- readInteger str      -> pure $ IELinear "" 0 (fromIntegral i)         ExpBinary _ _ Addition e1 e2       -> addInductionExprs <$> derive e1 <*> derive e2         ExpBinary _ _ Subtraction e1 e2    -> addInductionExprs <$> derive e1 <*> (negInductionExpr <$> derive e2)

@@ -201,12 +201,26 @@   modify $ \ s -> s { uniqNums = drop 1 (uniqNums s) }   return uniqNum --- Concat a scope, a variable, and a freshly generated number together--- to generate a "unique name".+-- | Concat a scope, a variable, and a freshly generated number together to+--   generate a "unique name".+--+-- GitHub issue #190 showed it was possible to generate the same unique name for+-- two different variables, if using the following unique name schema:+--+--     scope "_" var n+--     n=3:  int1 -> func_int13+--     n=13: int  -> func_int13+--+-- Instead, we now insert another underscore between the variable and the fresh+-- number, to disambiguate where the fresh number starts.+--+--     scope "_" var "_" n+--     n=3:  int1 -> func_int1_3+--     n=13: int  -> func_int_13 uniquify :: String -> String -> Renamer String uniquify scope var = do   n <- getUniqNum-  return $ scope ++ "_" ++ var ++ show n+  return $ scope ++ "_" ++ var ++ "_" ++ show n  --isModule :: ProgramUnit a -> Bool --isModule (PUModule {}) = True; isModule _             = False

@@ -80,7 +80,7 @@ charLenSelector (Just (Selector _ _ mlen mkind)) = (l, k)   where     l = charLenSelector' <$> mlen-    k | Just (ExpValue _ _ (ValInteger i)) <- mkind  = Just i+    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@@ -89,7 +89,7 @@ charLenSelector' = \case   ExpValue _ _ ValStar        -> CharLenStar   ExpValue _ _ ValColon       -> CharLenColon-  ExpValue _ _ (ValInteger i) -> CharLenInt (read i)+  ExpValue _ _ (ValInteger i _) -> CharLenInt (read i)   _                           -> CharLenExp  -- | Attempt to recover the 'Value' that generated the given 'CharacterLen'.@@ -97,7 +97,7 @@ charLenToValue = \case   CharLenStar  -> Just ValStar   CharLenColon -> Just ValColon-  CharLenInt i -> Just (ValInteger (show i))+  CharLenInt i -> Just (ValInteger (show i) Nothing)   CharLenExp   -> Nothing  getTypeKind :: SemType -> Kind@@ -173,7 +173,7 @@   where     ts = TypeSpec a ss     intValExpr :: Int -> Expression a-    intValExpr x = ExpValue a ss (ValInteger (show x))+    intValExpr x = ExpValue a ss (ValInteger (show x) Nothing)      -- | Wraps 'BaseType' and 'Kind' into 'TypeSpec'. If the kind is the     --   'BaseType''s default kind, it is omitted.

@@ -1,5 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE FlexibleContexts    #-}  module Language.Fortran.Analysis.Types   ( analyseTypes@@ -16,6 +17,7 @@   ) where  import Language.Fortran.AST+import Language.Fortran.AST.RealLit  import Prelude hiding (lookup, EQ, LT, GT) import Data.Map (insert)@@ -23,15 +25,14 @@ import Data.Maybe (maybeToList) import Data.List (find, foldl') import Control.Monad.State.Strict+import Control.Monad.Reader import Data.Generics.Uniplate.Data import Data.Data-import Data.Functor.Identity (Identity ()) import Language.Fortran.Analysis import Language.Fortran.Analysis.SemanticTypes import Language.Fortran.Intrinsics import Language.Fortran.Util.Position import Language.Fortran.Version (FortranVersion(..))-import Language.Fortran.Parser.Utils  -------------------------------------------------- @@ -48,7 +49,7 @@ --------------------------------------------------  -- Monad for type inference work-type Infer a = State InferState a+type Infer a = StateT InferState (Reader InferConfig) a data InferState = InferState { langVersion :: FortranVersion                              , intrinsics  :: IntrinsicsTable                              , environ     :: TypeEnv@@ -56,6 +57,12 @@                              , entryPoints :: M.Map Name (Name, Maybe Name)                              , typeErrors  :: [TypeError] }   deriving Show+data InferConfig = InferConfig+  { inferConfigAcceptNonCharLengthAsKind :: Bool+  -- ^ How to handle declarations like @INTEGER x*8@. If true, providing a+  --   character length for a non-character data type will treat it as a kind+  --   parameter. In both cases, a warning is logged (nonstandard syntax).+  } deriving (Eq, Show) type InferFunc t = t -> Infer ()  --------------------------------------------------@@ -126,7 +133,7 @@ intrinsicsExp (ExpFunctionCall _ _ nexp _) = intrinsicsHelper nexp intrinsicsExp _                            = return () -intrinsicsHelper :: Expression (Analysis a) -> StateT InferState Identity ()+intrinsicsHelper :: MonadState InferState m => Expression (Analysis a) -> m () intrinsicsHelper nexp | isNamedExpression nexp = do   itab <- gets intrinsics   case getIntrinsicReturnType (srcName nexp) itab of@@ -167,9 +174,9 @@  dimDeclarator :: AList DimensionDeclarator a -> [(Maybe Int, Maybe Int)] dimDeclarator ddAList = [ (lb, ub) | DimensionDeclarator _ _ lbExp ubExp <- aStrip ddAList-                                   , let lb = do ExpValue _ _ (ValInteger i) <- lbExp+                                   , let lb = do ExpValue _ _ (ValInteger i _) <- lbExp                                                  return $ read i-                                   , let ub = do ExpValue _ _ (ValInteger i) <- ubExp+                                   , let ub = do ExpValue _ _ (ValInteger i _) <- ubExp                                                  return $ read i ]  -- | Auxiliary function for getting semantic and construct type of a declaration.@@ -257,17 +264,17 @@ -- handle the various literals 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 _ ss (ValReal r))        = do-    k <- deriveRealLiteralKind ss r+annotateExpression e@(ExpValue _ ss (ValReal r mkp))        = do+    k <- deriveRealLiteralKind ss r mkp     return $ setSemType (TReal k) e annotateExpression e@(ExpValue _ ss (ValComplex e1 e2)) = do     st <- complexLiteralType ss e1 e2     return $ setSemType st e-annotateExpression e@(ExpValue _ _ (ValInteger _))     =+annotateExpression e@(ExpValue _ _ ValInteger{})     =     -- FIXME: in >F90, int lits can have kind info on end @_8@, same as real     -- lits. We do parse this into the lit string, it is available to us.     return $ setSemType (deriveSemTypeFromBaseType TypeInteger) e-annotateExpression e@(ExpValue _ _ (ValLogical _))     =+annotateExpression e@(ExpValue _ _ (ValLogical{}))     =     return $ setSemType (deriveSemTypeFromBaseType TypeLogical) e  annotateExpression e@(ExpBinary _ _ op e1 e2)          = flip setIDType e `fmap` binaryOpType (getSpan e) op e1 e2@@ -284,39 +291,28 @@ -- -- Logic taken from HP's F90 reference pg.33, written to gfortran's behaviour. -- Stays in the 'Infer' monad so it can report type errors-deriveRealLiteralKind :: SrcSpan -> String -> Infer Kind-deriveRealLiteralKind ss r =-    case realLitKindParam realLit of-      Nothing -> return kindFromExpOrDefault-      Just k  ->-        case realLitExponent realLit of-          Nothing  -> return k  -- no exponent, use kind param-          Just expo ->-            -- can only use kind param with 'e' or no exponent-            case expLetter expo of-              ExpLetterE -> return k-              _          -> do-                -- badly formed literal, but we'll allow and use the provided-                -- kind param (with no doubling or anything)-                typeError "only real literals with exponent letter 'e' can specify explicit kind parameter" ss-                return k-  where-    realLit = parseRealLiteral r-    kindFromExpOrDefault =-        case realLitExponent realLit of-          -- no exponent: select default real kind-          Nothing             -> 4-          Just expo           ->-            case expLetter expo of-              ExpLetterE -> 4-              ExpLetterD -> 8+deriveRealLiteralKind :: SrcSpan -> RealLit -> Maybe (Expression a) -> Infer Kind+deriveRealLiteralKind ss r mkp =+    case mkp of+      Nothing -> case exponentLetter (realLitExponent r) of+                   ExpLetterE -> return  4+                   ExpLetterD -> return  8+                   ExpLetterQ -> return 16+      Just _ {- kp -} -> case exponentLetter (realLitExponent r) of+                   ExpLetterE -> return 0 -- TODO return k+                   _          -> do+                     -- badly formed literal, but we'll allow and use the+                     -- provided kind param (with no doubling or anything)+                     typeError ("only real literals with exponent letter 'e'"+                             <> "can specify explicit kind parameter") ss+                     return 0 -- TODO return k  -- | Get the type of a COMPLEX literal constant. -- -- The kind is derived only from the first expression, the second is ignored. complexLiteralType :: SrcSpan -> Expression a -> Expression a -> Infer SemType-complexLiteralType ss (ExpValue _ _ (ValReal r)) _ = do-    k1 <- deriveRealLiteralKind ss r+complexLiteralType ss (ExpValue _ _ (ValReal r mkp)) _ = do+    k1 <- deriveRealLiteralKind ss r mkp     return $ TComplex k1 complexLiteralType _ _ _ = return $ deriveSemTypeFromBaseType TypeComplex @@ -451,12 +447,24 @@ -- Monadic helper combinators.  inferState0 :: FortranVersion -> InferState-inferState0 v = InferState { environ = M.empty, structs = 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 })+inferState0 v = InferState+  { environ     = M.empty+  , structs     = M.empty+  , entryPoints = M.empty+  , langVersion = v+  , intrinsics  = getVersionIntrinsics v+  , typeErrors  = []+  } -typeError :: String -> SrcSpan -> Infer ()+inferConfig0 :: InferConfig+inferConfig0 = InferConfig+  { inferConfigAcceptNonCharLengthAsKind = True+  }++runInfer :: FortranVersion -> TypeEnv -> Infer a -> (a, InferState)+runInfer v env f = flip runReader inferConfig0 $ flip runStateT ((inferState0 v) { environ = env }) f++typeError :: MonadState InferState m => String -> SrcSpan -> m () typeError msg ss = modify $ \ s -> s { typeErrors = (msg, ss):typeErrors s }  emptyType :: IDType@@ -474,7 +482,7 @@ recordMType st ct n = modify $ \ s -> s { environ = insert n (IDType st ct) (environ s) }  -- Record the CType of the given name.-recordCType :: ConstructType -> Name -> Infer ()+recordCType :: MonadState InferState m => ConstructType -> Name -> m () recordCType ct n = modify $ \ s -> s { environ = M.alter changeFunc n (environ s) }   where changeFunc mIDType = Just (IDType (mIDType >>= idVType) (Just ct)) @@ -591,8 +599,9 @@ -- This matches gfortran's behaviour, though even with -Wall they don't warn on -- this rather confusing syntax usage. We report a (soft) type error. deriveSemTypeFromDeclaration-    :: SrcSpan -> SrcSpan -> TypeSpec a -> Maybe (Expression a) -> Infer SemType-deriveSemTypeFromDeclaration stmtSs declSs ts@(TypeSpec _ _ bt mSel) mLenExpr =+    :: (MonadState InferState m, MonadReader InferConfig m)+    => SrcSpan -> SrcSpan -> TypeSpec a -> Maybe (Expression a) -> m SemType+deriveSemTypeFromDeclaration stmtSs declSs ts@(TypeSpec tsA tsSS bt mSel) mLenExpr =     case mLenExpr of       Nothing ->         -- no RHS length, can continue with regular deriving@@ -602,14 +611,45 @@         -- we got a RHS length; only CHARACTERs permit this         case bt of           TypeCharacter -> deriveCharWithLen lenExpr+           _ -> do-            -- can't use RHS @var*length = x@ syntax on non-CHARACTER: complain,-            -- continue regular deriving without length-            flip typeError declSs $-                "non-CHARACTER variable at declaration "-             <> show stmtSs-             <> " given a length"-            deriveSemTypeFromTypeSpec ts+            -- oh dear! probably the nonstandard kind param syntax @INTEGER x*2@+            asks inferConfigAcceptNonCharLengthAsKind >>= \case+              False -> do+                flip typeError stmtSs $+                    "non-CHARACTER variable given a length @ "+                 <> show (getSpan lenExpr)+                 <> ": ignoring"+                deriveSemTypeFromTypeSpec ts+              True -> do+                flip typeError stmtSs $+                    "non-CHARACTER variable given a length @ "+                 <> show (getSpan lenExpr)+                 <> ": treating as nonstandard kind parameter syntax"++                -- silly check to give an in-depth type error+                case mSel of+                  Just (Selector sA sSS sLen sMKpExpr) -> do+                    _ <- case sMKpExpr of+                           Nothing     -> return ()+                           Just kpExpr -> do+                             -- also got a LHS kind param, inform that we are+                             -- overriding+                             flip typeError stmtSs $+                                 "non-CHARACTER variable"+                              <> " given both"+                              <> " LHS kind @ " <> show (getSpan kpExpr) <> " and"+                              <> " nonstandard RHS kind @ " <> show (getSpan lenExpr)+                              <> ": specific RHS declarator overrides"+                             return ()+                    let sel = Selector sA sSS sLen (Just lenExpr)+                        ts' = TypeSpec tsA tsSS bt (Just sel)+                     in deriveSemTypeFromTypeSpec ts'+                  Nothing ->+                    let sel = Selector undefined undefined Nothing (Just lenExpr)+                        ts' = TypeSpec tsA tsSS bt (Just sel)+                     in deriveSemTypeFromTypeSpec ts'+   where     -- Function called when we have a TypeCharacter and a RHS declarator length.     -- (no function signature due to type variable scoping)@@ -623,9 +663,8 @@                       -- Ben has seen this IRL: a high-ranking Fortran                       -- tutorial site uses it (2021-04-30):                       -- http://web.archive.org/web/20210118202503/https://www.tutorialspoint.com/fortran/fortran_strings.htm-                     flip typeError declSs $-                         "warning: CHARACTER variable at declaration "-                      <> show stmtSs+                     flip typeError stmtSs $+                         "warning: CHARACTER variable @ " <> show declSs                       <> " has length in LHS type spec and RHS declarator"                       <> " -- specific RHS declarator overrides"                    _ -> return ()@@ -639,7 +678,8 @@              in return $ TCharacter (charLenSelector' lenExpr) k  -- | Attempt to derive a 'SemType' from a 'TypeSpec'.-deriveSemTypeFromTypeSpec :: TypeSpec a -> Infer SemType+deriveSemTypeFromTypeSpec+    :: MonadState InferState m => TypeSpec a -> m SemType deriveSemTypeFromTypeSpec (TypeSpec _ _ bt mSel) =     case mSel of       -- Selector present: we might have kind/other info provided@@ -648,7 +688,8 @@       Nothing  -> return $ deriveSemTypeFromBaseType bt  -- | Attempt to derive a SemType from a 'BaseType' and a 'Selector'.-deriveSemTypeFromBaseTypeAndSelector :: BaseType -> Selector a -> Infer SemType+deriveSemTypeFromBaseTypeAndSelector+    :: MonadState InferState m => BaseType -> Selector a -> m SemType deriveSemTypeFromBaseTypeAndSelector bt (Selector _ ss mLen mKindExpr) = do     st <- deriveFromBaseTypeAndKindExpr mKindExpr     case mLen of@@ -663,14 +704,13 @@             typeError "only CHARACTER types can specify length (separate to kind)" ss             return st   where-    deriveFromBaseTypeAndKindExpr :: Maybe (Expression a) -> Infer SemType     deriveFromBaseTypeAndKindExpr = \case       Nothing -> defaultSemType       Just kindExpr ->         case kindExpr of           -- FIXME: only support integer kind selectors for now, no params/exprs           -- (would require a wide change across codebase)-          ExpValue _ _ (ValInteger k) ->+          ExpValue _ _ (ValInteger k _) ->             deriveSemTypeFromBaseTypeAndKind bt (read k)           _ -> do             typeError "unsupported or invalid kind selector, only literal integers allowed" (getSpan kindExpr)@@ -708,7 +748,8 @@ noKind :: Kind noKind = -1 -deriveSemTypeFromBaseTypeAndKind :: BaseType -> Kind -> Infer SemType+deriveSemTypeFromBaseTypeAndKind+    :: MonadState InferState m => BaseType -> Kind -> m SemType deriveSemTypeFromBaseTypeAndKind bt k =     return $ setTypeKind (deriveSemTypeFromBaseType bt) k 

@@ -26,25 +26,26 @@ import GHC.Generics  import Language.Fortran.ParserMonad-+--import Language.Fortran.Version (required when ParserMonad stops exporting it) import Language.Fortran.Util.FirstParameter import Language.Fortran.Util.Position import Language.Fortran.Parser.Utils (readInteger)+import Language.Fortran.AST.Boz  } -$digit = [0-9]+$digit      = 0-9+$bit        = 0-1 $octalDigit = 0-7-$hexDigit = [a-f $digit]-$bit = 0-1+$hexDigit   = [a-f $digit]  $hash = [\#]  @binary = b\'$bit+\' | \'$bit+\'b-@octal = o\'$octalDigit+\' | \'$octalDigit+\'o-@hex = x\'$hexDigit+\' | \'$hexDigit+\'x | z\'$hexDigit+\' | \'$hexDigit+\'z+@octal  = o\'$octalDigit+\' | \'$octalDigit+\'o+@hex    = [xz]\'$hexDigit+\' | \'$hexDigit+\'[xz] -$letter = [a-z]+$letter = a-z $alphanumeric = [$letter $digit] $alphanumericExtended = [$letter $digit \_] $special = [\ \=\+\-\*\/\(\)\,\.\$]@@ -62,7 +63,7 @@           | "byte"  -- Numbers-@integerConst = $digit+ -- Integer constant+@integerConst = $digit+ @posIntegerConst = [1-9] $digit* @bozLiteralConst = (@binary|@octal|@hex) @@ -210,14 +211,15 @@   <st,iif> @integerConst                      { addSpanAndMatch TInt }     -- can be part (end) of function type declaration   <keyword> @integerConst                     { typeSCChange >> addSpanAndMatch TInt }-  <st,iif,keyword> @bozLiteralConst / { legacy77P } { addSpanAndMatch TBozInt }+  <st,iif,keyword> @bozLiteralConst / { legacy77P } { addSpanAndMatch $ \ss s -> TBozLiteral ss (parseBoz s) }    -- String   <st,iif> \' / { fortran77P }                { strAutomaton '\'' 0 }   <st,iif> \" / { legacy77P }                 { strAutomaton '"'  0 }    -- Logicals-  <st,iif> (".true."|".false.")               { addSpanAndMatch TBool  }+  <st,iif> ".true."                           { addSpan (\s -> TBool s True)  }+  <st,iif> ".false."                          { addSpan (\s -> TBool s False) }    -- Arithmetic operators   <st,iif> "+"                                { addSpan TOpPlus  }@@ -802,9 +804,9 @@            | TFormat              SrcSpan            | TBlob                SrcSpan String            | TInt                 SrcSpan String-           | TBozInt              SrcSpan String+           | TBozLiteral          SrcSpan Boz            | TExponent            SrcSpan String-           | TBool                SrcSpan String+           | TBool                SrcSpan Bool            | TOpPlus              SrcSpan            | TOpMinus             SrcSpan            | TOpExp               SrcSpan

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

@@ -24,16 +24,19 @@ import GHC.Generics  import Language.Fortran.ParserMonad+--import Language.Fortran.Version (required when ParserMonad stops exporting it) import Language.Fortran.Util.Position import Language.Fortran.Util.FirstParameter import Language.Fortran.Parser.Utils (readInteger)+import Language.Fortran.AST.RealLit (RealLit, parseRealLit)+import Language.Fortran.AST.Boz  } -$digit = 0-9+$digit      = 0-9+$bit        = 0-1 $octalDigit = 0-7-$hexDigit = [a-f $digit]-$bit = 0-1+$hexDigit   = [a-f $digit]  $letter = a-z $alphanumeric = [$letter $digit \_]@@ -44,31 +47,27 @@ @name = $letter $alphanumeric*  @binary = b\'$bit+\'-@octal = o\'$octalDigit+\'-@hex = z\'$hexDigit+\'+@octal  = o\'$octalDigit+\'+@hex    = z\'$hexDigit+\'  @digitString = $digit+ @kindParam = (@digitString|@name)-@intLiteralConst = @digitString (\_ @kindParam)? @bozLiteralConst = (@binary|@octal|@hex) +-- Real literals $expLetter = [ed] @exponent = [\-\+]? @digitString @significand = @digitString? \. @digitString-@realLiteral = @significand ($expLetter @exponent)? (\_ @kindParam)?-             | @digitString $expLetter @exponent (\_ @kindParam)?-             -- The following two complements @altRealLiteral the reason they-             -- are included in the general case is to reduce the number of+@realLiteral = @significand ($expLetter @exponent)?+             | @digitString $expLetter @exponent+             -- The following complements @altRealLiteral . The reason it is+             -- included in the general case is to reduce the number of              -- semantic predicates to be made while lexing.-             | @digitString \. $expLetter @exponent (\_ @kindParam)?-             | @digitString \. \_ @kindParam+             | @digitString \. $expLetter @exponent @altRealLiteral = @digitString \.  @characterLiteralBeg = (@kindParam \_)? (\'|\") -@bool = ".true." | ".false."-@logicalLiteral = @bool (\_ @kindParam)?- -------------------------------------------------------------------------------- -- Start codes | Explanation --------------------------------------------------------------------------------@@ -293,16 +292,18 @@ <scN> "(".*")" / { formatP }                      { addSpanAndMatch TBlob }  -- Literals+<scN> "_"                                         { addSpan TUnderscore } <0> @label                                        { toSC 0 >> addSpanAndMatch TIntegerLiteral }-<scN,scI> @intLiteralConst                        { addSpanAndMatch TIntegerLiteral  }-<scN> @bozLiteralConst                            { addSpanAndMatch TBozLiteral }+<scN,scI> @digitString                            { addSpanAndMatch TIntegerLiteral }+<scN> @bozLiteralConst                            { addSpanAndMatch $ \ss s -> TBozLiteral ss (parseBoz s) } -<scN> @realLiteral                                { addSpanAndMatch TRealLiteral }-<scN> @altRealLiteral / { notPrecedingDotP }      { addSpanAndMatch TRealLiteral }+<scN> @realLiteral                                { addSpanAndMatch $ \ss s -> TRealLiteral ss (parseRealLit s) }+<scN> @altRealLiteral / { notPrecedingDotP }      { addSpanAndMatch $ \ss s -> TRealLiteral ss (parseRealLit s) }  <scN,scC> @characterLiteralBeg                    { lexCharacter } -<scN> @logicalLiteral                             { addSpanAndMatch TLogicalLiteral }+<scN> ".true."  { addSpan (\s -> TLogicalLiteral s True)  }+<scN> ".false." { addSpan (\s -> TLogicalLiteral s False) }  -- Operators <scN> ("."$letter+"."|"**"|\*|\/|\+|\-) / { opP } { addSpanAndMatch TOpCustom }@@ -1154,9 +1155,8 @@   | TComment            SrcSpan String   | TString             SrcSpan String   | TIntegerLiteral     SrcSpan String-  -- | TRealLiteral        SrcSpan String (Maybe RealExponent) (Maybe KindParam)-  | TRealLiteral        SrcSpan String-  | TBozLiteral         SrcSpan String+  | TRealLiteral        SrcSpan RealLit+  | TBozLiteral         SrcSpan Boz   | TComma              SrcSpan   | TComma2             SrcSpan   | TSemiColon          SrcSpan@@ -1189,7 +1189,8 @@   | TOpNE               SrcSpan   | TOpGT               SrcSpan   | TOpGE               SrcSpan-  | TLogicalLiteral     SrcSpan String+  | TLogicalLiteral     SrcSpan Bool+  | TUnderscore         SrcSpan   -- Keywords   -- Program unit related   | TProgram            SrcSpan

@@ -50,6 +50,7 @@   int                         { TIntegerLiteral _ _ }   float                       { TRealLiteral _ _ }   boz                         { TBozLiteral _ _ }+  '_'                         { TUnderscore _ }   ','                         { TComma _ }   ',2'                        { TComma2 _ }   ';'                         { TSemiColon _ }@@ -1105,6 +1106,10 @@   { DeclArray () (getTransSpan $1 $4) $1 (aReverse $3) Nothing Nothing } | VARIABLE '(' DIMENSION_DECLARATORS ')' '*' EXPRESSION   { DeclArray () (getTransSpan $1 $6) $1 (aReverse $3) (Just $6) Nothing }+-- nonstandard char array syntax (wrong order for dimensions & charlen)+ | VARIABLE '*' EXPRESSION '(' DIMENSION_DECLARATORS ')'+   { let star = ExpValue () (getSpan $4) ValStar+    in DeclArray () (getTransSpan $1 $6) $1 (aReverse $5) (Just $3) Nothing } | VARIABLE '(' DIMENSION_DECLARATORS ')' '*' '(' '*' ')'   { let star = ExpValue () (getSpan $7) ValStar     in DeclArray () (getTransSpan $1 $8) $1 (aReverse $3) (Just star) Nothing }@@ -1383,14 +1388,33 @@ | 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 }+: int+  { let TIntegerLiteral s i = $1+     in ExpValue () s $ ValInteger i Nothing   }+| int '_' KIND_PARAM+  { let TIntegerLiteral s i = $1+     in ExpValue () s $ ValInteger i (Just $3) }+| boz { let TBozLiteral s b = $1 in ExpValue () s $ ValBoz b }  REAL_LITERAL :: { Expression A0 }-: float { let TRealLiteral s r = $1 in ExpValue () s $ ValReal r }+: float+  { let TRealLiteral s r = $1+     in ExpValue () s $ ValReal r Nothing }+| float '_' KIND_PARAM+  { let TRealLiteral s r = $1+     in ExpValue () s $ ValReal r (Just $3) }  LOGICAL_LITERAL :: { Expression A0 }-: bool { let TLogicalLiteral s b = $1 in ExpValue () s $ ValLogical b }+: bool+  { let TLogicalLiteral s b = $1+     in ExpValue () s (ValLogical b Nothing) }+| bool '_' KIND_PARAM+  { let TLogicalLiteral s b = $1+     in ExpValue () s (ValLogical b (Just $3)) }++KIND_PARAM :: { Expression A0 }+: INTEGER_LITERAL { $1 }+| VARIABLE        { $1 }  STRING :: { Expression A0 } : string { let TString s c = $1 in ExpValue () s $ ValString c }

@@ -18,8 +18,10 @@ import Language.Fortran.Util.ModFile import Language.Fortran.ParserMonad import Language.Fortran.Lexer.FixedForm+import Language.Fortran.Lexer.FixedForm.Utils import Language.Fortran.Transformer import Language.Fortran.AST+import Language.Fortran.AST.RealLit  } @@ -107,30 +109,25 @@  -- This rule is to ignore leading whitespace PROGRAM :: { ProgramFile A0 }-PROGRAM : NEWLINE PROGRAM_INNER { $2 } | PROGRAM_INNER { $1 }  PROGRAM_INNER :: { ProgramFile A0 }-PROGRAM_INNER : PROGRAM_UNITS BLOCKS { ProgramFile (MetaInfo { miVersion = Fortran66, miFilename = "" })  (reverse $1 ++ convCmts (reverse $2)) } | {- empty -}   { ProgramFile (MetaInfo { miVersion = Fortran66, miFilename = "" }) [] }  PROGRAM_UNITS :: { [ ProgramUnit A0 ] }-PROGRAM_UNITS : PROGRAM_UNITS MAIN_PROGRAM_UNIT { $2 : $1 } | PROGRAM_UNITS BLOCKS OTHER_PROGRAM_UNIT { convCmts (reverse $2) ++ ($3 : $1) } | MAIN_PROGRAM_UNIT { [ $1 ] } | BLOCKS OTHER_PROGRAM_UNIT { convCmts (reverse $1) ++ [ $2 ] }  MAIN_PROGRAM_UNIT :: { ProgramUnit A0 }-MAIN_PROGRAM_UNIT : BLOCKS end MAYBE_NEWLINE   { let blocks = reverse $1     in PUMain () (getTransSpan $1 $2) Nothing blocks Nothing }  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) emptyPrefixSuffix $3 $4 Nothing (reverse $6) Nothing } | function NAME MAYBE_ARGUMENTS NEWLINE BLOCKS end MAYBE_NEWLINE@@ -146,12 +143,10 @@ NAME :: { Name } : id { let (TId _ name) = $1 in name }  BLOCKS :: { [ Block A0 ] }-BLOCKS : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] }  BLOCK :: { Block A0 }-BLOCK : LABEL_IN_6COLUMN STATEMENT NEWLINE { BlStatement () (getTransSpan $1 $2) (Just $1) $2 } | STATEMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 } | comment NEWLINE { let (TComment s c) = $1 in BlComment () s (Comment c) }@@ -159,33 +154,28 @@ MAYBE_NEWLINE :: { Maybe Token } : NEWLINE { Just $1 } | {- EMPTY -} { Nothing }  NEWLINE :: { Token }-NEWLINE : NEWLINE newline { $1 } | newline { $1 }  STATEMENT :: { Statement A0 }-STATEMENT : LOGICAL_IF_STATEMENT { $1 } | DO_STATEMENT { $1 } | OTHER_EXECUTABLE_STATEMENT { $1 } | NONEXECUTABLE_STATEMENT { $1 }  LOGICAL_IF_STATEMENT :: { Statement A0 }-LOGICAL_IF_STATEMENT : if '(' EXPRESSION ')' OTHER_EXECUTABLE_STATEMENT { StIfLogical () (getTransSpan $1 $5) $3 $5 }+: if '(' EXPRESSION ')' OTHER_EXECUTABLE_STATEMENT { StIfLogical () (getTransSpan $1 $5) $3 $5 }  DO_STATEMENT :: { Statement A0 }-DO_STATEMENT : do LABEL_IN_STATEMENT DO_SPECIFICATION { StDo () (getTransSpan $1 $3) Nothing (Just $2) (Just $3) }  DO_SPECIFICATION :: { DoSpecification A0 }-DO_SPECIFICATION : EXPRESSION_ASSIGNMENT_STATEMENT ',' INT_OR_VAR ',' INT_OR_VAR { DoSpecification () (getTransSpan $1 $5) $1 $3 (Just $5) } | EXPRESSION_ASSIGNMENT_STATEMENT ',' INT_OR_VAR                { DoSpecification () (getTransSpan $1 $3) $1 $3 Nothing }  INT_OR_VAR :: { Expression A0 } : INTEGER_LITERAL { $1 } | VARIABLE { $1 }  OTHER_EXECUTABLE_STATEMENT :: { Statement A0 }-OTHER_EXECUTABLE_STATEMENT : EXPRESSION_ASSIGNMENT_STATEMENT { $1 } | assign LABEL_IN_STATEMENT to VARIABLE { StLabelAssign () (getTransSpan $1 $4) $2 $4 } | goto LABEL_IN_STATEMENT { StGotoUnconditional () (getTransSpan $1 $2) $2 }@@ -208,10 +198,9 @@ | read READ_WRITE_ARGUMENTS { let (cilist, iolist) = $2 in StRead () (getTransSpan $1 $2) cilist iolist }  EXPRESSION_ASSIGNMENT_STATEMENT :: { Statement A0 }-EXPRESSION_ASSIGNMENT_STATEMENT : ELEMENT '=' EXPRESSION { StExpressionAssign () (getTransSpan $1 $3) $1 $3 }+: ELEMENT '=' EXPRESSION { StExpressionAssign () (getTransSpan $1 $3) $1 $3 }  NONEXECUTABLE_STATEMENT :: { Statement A0 }-NONEXECUTABLE_STATEMENT : external FUNCTION_NAMES { StExternal () (getTransSpan $1 $2) (aReverse $2) } | dimension ARRAY_DECLARATORS { StDimension () (getTransSpan $1 $2) (aReverse $2) } | common COMMON_GROUPS { StCommon () (getTransSpan $1 $2) (aReverse $2) }@@ -224,7 +213,6 @@ | TYPE_SPEC DECLARATORS { StDeclaration () (getTransSpan $1 $2) $1 Nothing (aReverse $2) }  READ_WRITE_ARGUMENTS :: { (AList ControlPair A0, Maybe (AList Expression A0)) }-READ_WRITE_ARGUMENTS : '(' UNIT ')' IO_ELEMENTS { (AList () (getSpan $2) [ ControlPair () (getSpan $2) Nothing $2 ], Just (aReverse $4)) } | '(' UNIT ',' FORM ')' IO_ELEMENTS { (AList () (getTransSpan $2 $4) [ ControlPair () (getSpan $2) Nothing $2, ControlPair () (getSpan $4) Nothing $4 ], Just (aReverse $6)) } | '(' UNIT ')' { (AList () (getSpan $2) [ ControlPair () (getSpan $2) Nothing $2 ], Nothing) }@@ -236,12 +224,10 @@ FORM :: { Expression A0 } : VARIABLE { $1 } | LABEL_IN_STATEMENT { $1 }  IO_ELEMENTS :: { AList Expression A0 }-IO_ELEMENTS : IO_ELEMENTS ',' IO_ELEMENT { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1} | IO_ELEMENT { AList () (getSpan $1) [ $1 ] }  IO_ELEMENT :: { Expression A0 }-IO_ELEMENT : VARIABLE { $1 } -- There should also be a caluse for variable names but not way to -- differentiate it at this stage from VARIABLE. Hence, it is omitted to prevent@@ -250,60 +236,50 @@ | '(' IO_ELEMENTS ',' DO_SPECIFICATION ')' { ExpImpliedDo () (getTransSpan $1 $5) $2 $4 }  ELEMENT :: { Expression A0 }-ELEMENT : VARIABLE { $1 } | SUBSCRIPT { $1 }  DATA_GROUPS :: { AList DataGroup A0 }-DATA_GROUPS : DATA_GROUPS ',' NAME_LIST  '/' DATA_ITEMS '/' { setSpan (getTransSpan $1 $6) $ (DataGroup () (getTransSpan $3 $6) (aReverse $3) (aReverse $5)) `aCons` $1 } | NAME_LIST  '/' DATA_ITEMS '/' { AList () (getTransSpan $1 $4) [ DataGroup () (getTransSpan $1 $4) (aReverse $1) (aReverse $3) ] }  DATA_ITEMS :: { AList Expression A0 }-DATA_ITEMS : DATA_ITEMS ',' DATA_ITEM { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1} | DATA_ITEM { AList () (getSpan $1) [ $1 ] }  DATA_ITEM :: { Expression A0 }-DATA_ITEM : INTEGER_LITERAL '*' DATA_ITEM_LEVEL1 { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 } | DATA_ITEM_LEVEL1 { $1 }  DATA_ITEM_LEVEL1 :: { Expression A0 }-DATA_ITEM_LEVEL1 : SIGNED_NUMERIC_LITERAL  { $1 } | COMPLEX_LITERAL         { $1 } | LOGICAL_LITERAL         { $1 } | HOLLERITH               { $1 }  EQUIVALENCE_GROUPS :: { AList (AList Expression) A0 }-EQUIVALENCE_GROUPS : EQUIVALENCE_GROUPS ','  '(' NAME_LIST ')' { setSpan (getTransSpan $1 $5) $ (setSpan (getTransSpan $3 $5) $ aReverse $4) `aCons` $1 } | '(' NAME_LIST ')' { let s = (getTransSpan $1 $3) in AList () s [ setSpan s $ aReverse $2 ] }  COMMON_GROUPS :: { AList CommonGroup A0 }-COMMON_GROUPS : COMMON_GROUPS COMMON_GROUP { setSpan (getTransSpan $1 $2) $ $2 `aCons` $1 } | INIT_COMMON_GROUP { AList () (getSpan $1) [ $1 ] }  COMMON_GROUP :: { CommonGroup A0 }-COMMON_GROUP : COMMON_NAME DECLARATORS   { CommonGroup () (getTransSpan $1 $2) (Just $1) $ aReverse $2 } | '/' '/' DECLARATORS { CommonGroup () (getTransSpan $1 $3) Nothing $ aReverse $3 }  INIT_COMMON_GROUP :: { CommonGroup A0 }-INIT_COMMON_GROUP : COMMON_NAME DECLARATORS   { CommonGroup () (getTransSpan $1 $2) (Just $1) $ aReverse $2 } | '/' '/' DECLARATORS { CommonGroup () (getTransSpan $1 $3) Nothing $ aReverse $3 } | DECLARATORS { CommonGroup () (getSpan $1) Nothing $ aReverse $1 }  COMMON_NAME :: { Expression A0 }-COMMON_NAME : '/' VARIABLE '/' { setSpan (getTransSpan $1 $3) $2 }+: '/' VARIABLE '/' { setSpan (getTransSpan $1 $3) $2 }  NAME_LIST :: { AList Expression A0 }-NAME_LIST : NAME_LIST ',' NAME_LIST_ELEMENT { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 } | NAME_LIST_ELEMENT { AList () (getSpan $1) [ $1 ] } @@ -311,64 +287,52 @@  -- Note that declarator lists in the F66 parser don't have initializers. DECLARATORS :: { AList Declarator A0 }-DECLARATORS : DECLARATORS ',' DECLARATOR { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 } | DECLARATOR { AList () (getSpan $1) [ $1 ] }  -- Parses arrays as DeclVariable, otherwise we get a conflict. DECLARATOR :: { Declarator A0 }-DECLARATOR : ARRAY_DECLARATOR { $1 } | VARIABLE_DECLARATOR { $1 }  ARRAY_DECLARATORS :: { AList Declarator A0 }-ARRAY_DECLARATORS : ARRAY_DECLARATORS ',' ARRAY_DECLARATOR { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 } | ARRAY_DECLARATOR { AList () (getSpan $1) [ $1 ] }  ARRAY_DECLARATOR :: { Declarator A0 }-ARRAY_DECLARATOR : VARIABLE '(' DIMENSION_DECLARATORS ')' { DeclArray () (getTransSpan $1 $4) $1 (aReverse $3) Nothing Nothing }  DIMENSION_DECLARATORS :: { AList DimensionDeclarator A0 }-DIMENSION_DECLARATORS : DIMENSION_DECLARATORS ',' DIMENSION_DECLARATOR { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 } | DIMENSION_DECLARATOR { AList () (getSpan $1) [ $1 ] }  DIMENSION_DECLARATOR :: { DimensionDeclarator A0 }-DIMENSION_DECLARATOR : EXPRESSION { DimensionDeclarator () (getSpan $1) Nothing (Just $1) }  VARIABLE_DECLARATOR :: { Declarator A0 }-VARIABLE_DECLARATOR : VARIABLE { DeclVariable () (getSpan $1) $1 Nothing Nothing }  -- Here the procedure should be either a function or subroutine name, but -- since they are syntactically identical at this stage subroutine names -- are also emitted as function names. FUNCTION_NAMES :: { AList Expression A0 }-FUNCTION_NAMES : FUNCTION_NAMES ',' VARIABLE { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 } | VARIABLE { AList () (getSpan $1) [ $1 ] }  ARGUMENTS :: { AList Argument A0 }-ARGUMENTS :  ARGUMENTS_LEVEL1 ')' { setSpan (getTransSpan $1 $2) $ aReverse $1 }  ARGUMENTS_LEVEL1 :: { AList Argument A0 }-ARGUMENTS_LEVEL1 : ARGUMENTS_LEVEL1 ',' CALLABLE_EXPRESSION { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 } | '(' CALLABLE_EXPRESSION { AList () (getTransSpan $1 $2) [ $2 ] } | '(' { AList () (getSpan $1) [ ] }  -- Expression all by itself subsumes all other callable expressions. CALLABLE_EXPRESSION :: { Argument A0 }-CALLABLE_EXPRESSION : HOLLERITH   { Argument () (getSpan $1) Nothing $1 } | EXPRESSION  { Argument () (getSpan $1) Nothing $1 }  EXPRESSION :: { Expression A0 }-EXPRESSION : 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 }@@ -390,7 +354,6 @@ | VARIABLE                      { $1 }  RELATIONAL_OPERATOR :: { BinaryOp }-RELATIONAL_OPERATOR : '=='  { EQ } | '!='  { NE } | '>'   { GT }@@ -399,19 +362,16 @@ | '<='  { LTE }  SUBSCRIPT :: { Expression A0 }-SUBSCRIPT : VARIABLE '(' ')'   { ExpFunctionCall () (getTransSpan $1 $3) $1 Nothing } | VARIABLE '(' INDICIES ')'   { ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3) }  INDICIES :: { [ Index A0 ] }-INDICIES : INDICIES ',' EXPRESSION { IxSingle () (getSpan $3) Nothing $3 : $1 } | EXPRESSION { [ IxSingle () (getSpan $1) Nothing $1 ] }  ARITHMETIC_SIGN :: { (SrcSpan, UnaryOp) }-ARITHMETIC_SIGN : '-' { (getSpan $1, Minus) } | '+' { (getSpan $1, Plus) } @@ -419,75 +379,68 @@ : VARIABLES { Just $ fromReverseList $1 } | {- EMPTY -} { Nothing }  VARIABLES :: { [ Expression A0 ] }-VARIABLES : VARIABLES ',' VARIABLE { $3 : $1 } | VARIABLE { [ $1 ] }+: VARIABLES ',' VARIABLE { $3 : $1 } | VARIABLE { [ $1 ] }  -- This may also be used to parse a function name, or an array name. Since when -- are valid options in a production there is no way of differentiating them at -- this stage. -- This at least reduces reduce/reduce conflicts. VARIABLE :: { Expression A0 }-VARIABLE : id { ExpValue () (getSpan $1) $ let (TId _ s) = $1 in ValVariable s }  SIGNED_INTEGER_LITERAL :: { Expression A0 }-SIGNED_INTEGER_LITERAL : ARITHMETIC_SIGN INTEGER_LITERAL { ExpUnary () (getTransSpan (fst $1) $2) (snd $1) $2 } | INTEGER_LITERAL { $1 } -INTEGER_LITERAL :: { Expression A0 } : int { ExpValue () (getSpan $1) $ let (TInt _ i) = $1 in ValInteger i }+INTEGER_LITERAL :: { Expression A0 }+: int { ExpValue () (getSpan $1) $ let (TInt _ i) = $1 in ValInteger i Nothing }  SIGNED_REAL_LITERAL :: { Expression A0 }-SIGNED_REAL_LITERAL : ARITHMETIC_SIGN REAL_LITERAL { ExpUnary () (getTransSpan (fst $1) $2) (snd $1) $2 } | REAL_LITERAL { $1 }  REAL_LITERAL :: { Expression A0 }-REAL_LITERAL : int EXPONENT { makeReal (Just $1) Nothing Nothing (Just $2) } | int '.' MAYBE_EXPONENT { makeReal (Just $1) (Just $2) Nothing $3 } | '.' int MAYBE_EXPONENT { makeReal Nothing (Just $1) (Just $2) $3 } | int '.' int MAYBE_EXPONENT { makeReal (Just $1) (Just $2) (Just $3) $4 }  MAYBE_EXPONENT :: { Maybe (SrcSpan, String) }-MAYBE_EXPONENT : EXPONENT { Just $1 } | {-EMPTY-} { Nothing }  EXPONENT :: { (SrcSpan, String) }-EXPONENT : exponent { let (TExponent s exp) = $1 in (s, exp) }  SIGNED_NUMERIC_LITERAL :: { Expression A0 }-SIGNED_NUMERIC_LIETERAL : SIGNED_INTEGER_LITERAL { $1 } | SIGNED_REAL_LITERAL    { $1 }  COMPLEX_LITERAL :: { Expression A0 }-COMPLEX_LITERAL :  '(' SIGNED_NUMERIC_LITERAL ',' SIGNED_NUMERIC_LITERAL ')' { ExpValue () (getTransSpan $1 $5) (ValComplex $2 $4)}  LOGICAL_LITERAL :: { Expression A0 }-LOGICAL_LITERAL : bool { let TBool s b = $1 in ExpValue () s $ ValLogical b }+: bool { let TBool s b = $1 in ExpValue () s $ ValLogical b Nothing } -HOLLERITH :: { Expression A0 } : hollerith { ExpValue () (getSpan $1) $ let (THollerith _ h) = $1 in ValHollerith h }+HOLLERITH :: { Expression A0 }+: hollerith { ExpValue () (getSpan $1) $ let (THollerith _ h) = $1 in ValHollerith h }  LABELS_IN_STATEMENT :: { AList Expression A0 }-LABELS_IN_STATEMENT : LABELS_IN_STATEMENT_LEVEL1 ')' { setSpan (getTransSpan $1 $2) $ aReverse $1 }  LABELS_IN_STATEMENT_LEVEL1 :: { AList Expression A0 }-LABELS_IN_STATEMENT_LEVEL1 : LABELS_IN_STATEMENT_LEVEL1 ',' LABEL_IN_STATEMENT { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 } | '(' LABEL_IN_STATEMENT { AList () (getTransSpan $1 $2) [ $2 ] }  -- Labels that occur in the first 6 columns-LABEL_IN_6COLUMN :: { Expression A0 } : label { ExpValue () (getSpan $1) (let (TLabel _ l) = $1 in ValInteger l) }+LABEL_IN_6COLUMN :: { Expression A0 }+: label { ExpValue () (getSpan $1) (let (TLabel _ l) = $1 in ValInteger l Nothing) }  -- Labels that occur in statements-LABEL_IN_STATEMENT :: { Expression A0 } : int { ExpValue () (getSpan $1) (let (TInt _ l) = $1 in ValInteger l) }+LABEL_IN_STATEMENT :: { Expression A0 }+: int { ExpValue () (getSpan $1) (let (TInt _ l) = $1 in ValInteger l Nothing) }  TYPE_SPEC :: { TypeSpec A0 }-TYPE_SPEC : integer           { TypeSpec () (getSpan $1) TypeInteger Nothing } | real              { TypeSpec () (getSpan $1) TypeReal Nothing } | doublePrecision   { TypeSpec () (getSpan $1) TypeDoublePrecision Nothing }@@ -495,18 +448,6 @@ | complex           { TypeSpec () (getSpan $1) TypeComplex Nothing }  {--makeReal :: Maybe Token -> Maybe Token -> Maybe Token -> Maybe (SrcSpan, String) -> Expression A0-makeReal i1 dot i2 exp =-  let span1   = getSpan (i1, dot, i2)-      span2   = case exp of-                  Just e -> getTransSpan span1 (fst e)-                  Nothing -> span1-      i1Str   = case i1 of { Just (TInt _ s) -> s ; _ -> "" }-      dotStr  = case dot of { Just (TDot _) -> "." ; _ -> "" }-      i2Str   = case i2 of { Just (TInt _ s) -> s ; _ -> "" }-      expStr  = case exp of { Just (_, s) -> s ; _ -> "" } in-    ExpValue () span2 (ValReal $ i1Str ++ dotStr ++ i2Str ++ expStr)  parse = runParse programParser defTransforms = defaultTransformations Fortran66

@@ -35,8 +35,10 @@ import Language.Fortran.Util.ModFile import Language.Fortran.ParserMonad import Language.Fortran.Lexer.FixedForm hiding (Move(..))+import Language.Fortran.Lexer.FixedForm.Utils import Language.Fortran.Transformer import Language.Fortran.AST+import Language.Fortran.AST.RealLit  import Data.Generics.Uniplate.Operations import System.Directory@@ -139,7 +141,7 @@   format                { TFormat _ }   blob                  { TBlob _ _ }   int                   { TInt _ _ }-  boz                   { TBozInt _ _ }+  boz                   { TBozLiteral _ _ }   exponent              { TExponent _ _ }   bool                  { TBool _ _ }   '+'                   { TOpPlus _ }@@ -917,8 +919,8 @@ : id { ExpValue () (getSpan $1) $ let (TId _ s) = $1 in ValVariable s }  INTEGER_LITERAL :: { Expression A0 }-: int { ExpValue () (getSpan $1) $ let (TInt _ i) = $1 in ValInteger i }-| boz { let TBozInt s i = $1 in ExpValue () s $ ValInteger i }+: int { ExpValue () (getSpan $1) $ let (TInt _ i) = $1 in ValInteger i Nothing}+| boz { let TBozLiteral s b = $1 in ExpValue () s $ ValBoz b }  REAL_LITERAL :: { Expression A0 } : int EXPONENT { makeReal (Just $1) Nothing Nothing (Just $2) }@@ -942,7 +944,7 @@ | REAL_LITERAL { $1 }  LOGICAL_LITERAL :: { Expression A0 }-: bool { let TBool s b = $1 in ExpValue () s $ ValLogical b }+: bool { let TBool s b = $1 in ExpValue () s $ ValLogical b Nothing }  HOLLERITH :: { Expression A0 } : hollerith { ExpValue () (getSpan $1) $ let (THollerith _ h) = $1 in ValHollerith h } @@ -954,10 +956,10 @@ | '(' LABEL_IN_STATEMENT { AList () (getTransSpan $1 $2) [ $2 ] }  -- Labels that occur in the first 6 columns-LABEL_IN_6COLUMN :: { Expression A0 } : label { ExpValue () (getSpan $1) (let (TLabel _ l) = $1 in ValInteger l) }+LABEL_IN_6COLUMN :: { Expression A0 } : label { ExpValue () (getSpan $1) (let (TLabel _ l) = $1 in ValInteger l Nothing) }  -- Labels that occur in statements-LABEL_IN_STATEMENT :: { Expression A0 } : int { ExpValue () (getSpan $1) (let (TInt _ l) = $1 in ValInteger l) }+LABEL_IN_STATEMENT :: { Expression A0 } : int { ExpValue () (getSpan $1) (let (TInt _ l) = $1 in ValInteger l Nothing) }  TYPE_SPEC :: { TypeSpec A0 } : integer   KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeInteger $2 }@@ -996,18 +998,6 @@ STAR : '*' { ExpValue () (getSpan $1) ValStar }  {--makeReal :: Maybe Token -> Maybe Token -> Maybe Token -> Maybe (SrcSpan, String) -> Expression A0-makeReal i1 dot i2 exp =-  let span1   = getSpan (i1, dot, i2)-      span2   = case exp of-                  Just e -> getTransSpan span1 (fst e)-                  Nothing -> span1-      i1Str   = case i1 of { Just (TInt _ s) -> s ; _ -> "" }-      dotStr  = case dot of { Just (TDot _) -> "." ; _ -> "" }-      i2Str   = case i2 of { Just (TInt _ s) -> s ; _ -> "" }-      expStr  = case exp of { Just (_, s) -> s ; _ -> "" } in-    ExpValue () span2 (ValReal $ i1Str ++ dotStr ++ i2Str ++ expStr)  parse = runParse programParser 

@@ -47,6 +47,7 @@   int                         { TIntegerLiteral _ _ }   float                       { TRealLiteral _ _ }   boz                         { TBozLiteral _ _ }+  '_'                         { TUnderscore _ }   ','                         { TComma _ }   ',2'                        { TComma2 _ }   ';'                         { TSemiColon _ }@@ -908,6 +909,10 @@   { DeclArray () (getTransSpan $1 $4) $1 (aReverse $3) Nothing Nothing } | VARIABLE '(' DIMENSION_DECLARATORS ')' '*' EXPRESSION   { DeclArray () (getTransSpan $1 $6) $1 (aReverse $3) (Just $6) Nothing }+-- nonstandard char array syntax (wrong order for dimensions & charlen)+| VARIABLE '*' EXPRESSION '(' DIMENSION_DECLARATORS ')'+  { let star = ExpValue () (getSpan $4) ValStar+    in DeclArray () (getTransSpan $1 $6) $1 (aReverse $5) (Just $3) Nothing } | VARIABLE '(' DIMENSION_DECLARATORS ')' '*' '(' '*' ')'   { let star = ExpValue () (getSpan $7) ValStar     in DeclArray () (getTransSpan $1 $8) $1 (aReverse $3) (Just star) Nothing }@@ -1124,14 +1129,33 @@ | 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 }+: int+  { let TIntegerLiteral s i = $1+     in ExpValue () s $ ValInteger i Nothing   }+| int '_' KIND_PARAM+  { let TIntegerLiteral s i = $1+     in ExpValue () s $ ValInteger i (Just $3) }+| boz { let TBozLiteral s b = $1 in ExpValue () s $ ValBoz b }  REAL_LITERAL :: { Expression A0 }-: float { let TRealLiteral s r = $1 in ExpValue () s $ ValReal r }+: float+  { let TRealLiteral s r = $1+     in ExpValue () s $ ValReal r Nothing }+| float '_' KIND_PARAM+  { let TRealLiteral s r = $1+     in ExpValue () s $ ValReal r (Just $3) }  LOGICAL_LITERAL :: { Expression A0 }-: bool { let TLogicalLiteral s b = $1 in ExpValue () s $ ValLogical b }+: bool+  { let TLogicalLiteral s b = $1+     in ExpValue () s (ValLogical b Nothing) }+| bool '_' KIND_PARAM+  { let TLogicalLiteral s b = $1+     in ExpValue () s (ValLogical b (Just $3)) }++KIND_PARAM :: { Expression A0 }+: INTEGER_LITERAL { $1 }+| VARIABLE        { $1 }  STRING :: { Expression A0 } : string { let TString s c = $1 in ExpValue () s $ ValString c }

@@ -49,6 +49,7 @@   int                         { TIntegerLiteral _ _ }   float                       { TRealLiteral _ _ }   boz                         { TBozLiteral _ _ }+  '_'                         { TUnderscore _ }   ','                         { TComma _ }   ',2'                        { TComma2 _ }   ';'                         { TSemiColon _ }@@ -925,6 +926,10 @@   { DeclArray () (getTransSpan $1 $4) $1 (aReverse $3) Nothing Nothing } | VARIABLE '(' DIMENSION_DECLARATORS ')' '*' EXPRESSION   { DeclArray () (getTransSpan $1 $6) $1 (aReverse $3) (Just $6) Nothing }+-- nonstandard char array syntax (wrong order for dimensions & charlen)+| VARIABLE '*' EXPRESSION '(' DIMENSION_DECLARATORS ')'+  { let star = ExpValue () (getSpan $4) ValStar+    in DeclArray () (getTransSpan $1 $6) $1 (aReverse $5) (Just $3) Nothing } | VARIABLE '(' DIMENSION_DECLARATORS ')' '*' '(' '*' ')'   { let star = ExpValue () (getSpan $7) ValStar     in DeclArray () (getTransSpan $1 $8) $1 (aReverse $3) (Just star) Nothing }@@ -1196,14 +1201,33 @@ | 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 }+: int+  { let TIntegerLiteral s i = $1+     in ExpValue () s $ ValInteger i Nothing   }+| int '_' KIND_PARAM+  { let TIntegerLiteral s i = $1+     in ExpValue () s $ ValInteger i (Just $3) }+| boz { let TBozLiteral s b = $1 in ExpValue () s $ ValBoz b }  REAL_LITERAL :: { Expression A0 }-: float { let TRealLiteral s r = $1 in ExpValue () s $ ValReal r }+: float+  { let TRealLiteral s r = $1+     in ExpValue () s $ ValReal r Nothing }+| float '_' KIND_PARAM+  { let TRealLiteral s r = $1+     in ExpValue () s $ ValReal r (Just $3) }  LOGICAL_LITERAL :: { Expression A0 }-: bool { let TLogicalLiteral s b = $1 in ExpValue () s $ ValLogical b }+: bool+  { let TLogicalLiteral s b = $1+     in ExpValue () s (ValLogical b Nothing) }+| bool '_' KIND_PARAM+  { let TLogicalLiteral s b = $1+     in ExpValue () s (ValLogical b (Just $3)) }++KIND_PARAM :: { Expression A0 }+: INTEGER_LITERAL { $1 }+| VARIABLE        { $1 }  STRING :: { Expression A0 } : string { let TString s c = $1 in ExpValue () s $ ValString c }

@@ -1,21 +1,11 @@-{-# LANGUAGE LambdaCase #-}- {-| Simple module to provide functions that read Fortran literals -} module Language.Fortran.Parser.Utils   ( readReal   , readInteger-  , parseRealLiteral-  , RealLit(..)-  , Exponent(..)-  , NumSign(..)-  , ExponentLetter(..)   ) where -import Language.Fortran.AST (Kind)--import Data.Char-import Numeric-import Text.Read (readMaybe)+import           Data.Char+import           Numeric  breakAtDot :: String -> (String, String) replaceDwithE :: Char -> Char@@ -55,78 +45,3 @@ readsToMaybe r = case r of   (x, _):_ -> Just x   _ -> Nothing-------------------------------------------------------------------------------------- TODO limitation--- Kind params allow 'Name's as well (which are checked at compile time to be a--- special type of constant expression). We limit ourselves to integer kind--- params only, because currently we don't handle full kind params in the later--- stages anyway.-type KindParam = Kind---- | A REAL literal may have an optional exponent and kind.------ The value can be retrieved as a 'Double' by using these parts.-data RealLit = RealLit-  { realLitValue     :: String -- xyz.abc, xyz, xyz., .abc-  , realLitExponent  :: Maybe Exponent-  , realLitKindParam :: Maybe KindParam-  } deriving (Eq, Ord, Show)---- | An exponent is an exponent letter (E, D) and a value (with an optional--- sign).-data Exponent = Exponent-  { expLetter :: ExponentLetter-  , expSign   :: Maybe NumSign-  , expNum    :: Int-  } deriving (Eq, Ord, Show)---- Note: Some Fortran language references include extensions here. HP's F90--- reference provides a Q exponent letter which sets kind to 16.-data ExponentLetter-  = ExpLetterD-  | ExpLetterE-    deriving (Eq, Ord, Show)--data NumSign-  = SignPos-  | SignNeg-    deriving (Eq, Ord, Show)---- | Parse a Fortran literal real to its constituent parts.-parseRealLiteral :: String -> RealLit-parseRealLiteral r =-    RealLit { realLitValue     = takeWhile isValuePart r-            , realLitExponent  = parseRealLitExponent (dropWhile isValuePart r)-            , realLitKindParam = parseRealLitKindInt (dropWhile (/= '_') r)-            }-  where-    -- slightly ugly: we add the signs in here to allow -1.0 easily-    isValuePart :: Char -> Bool-    isValuePart ch-      | isDigit ch                 = True-      | ch `elem` ['.', '-', '+']  = True-      | otherwise                  = False-    parseRealLitKindInt :: String -> Maybe Kind-    parseRealLitKindInt = \case-      '_':chs -> readMaybe chs-      _       -> Nothing-    parseRealLitExponent :: String -> Maybe Exponent-    parseRealLitExponent "" = Nothing-    parseRealLitExponent (c:cs) = do-        letter <--                case toLower c of-                  'e' -> Just ExpLetterE-                  'd' -> Just ExpLetterD-                  _   -> Nothing-        let (sign, cs'') =-                case cs of-                  ""       -> (Nothing, cs)-                  c':cs'  -> -- TODO: want to locally scope cs' but unsure how to??-                    case c' of-                      '-' -> (Just SignNeg, cs')-                      '+' -> (Just SignPos, cs')-                      _   -> (Nothing     , cs)-            digitStr = read (takeWhile isDigit cs'')-        return $ Exponent letter sign digitStr

@@ -1,7 +1,8 @@-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE UndecidableInstances  #-} {-# OPTIONS_GHC -Wno-orphans #-}  module Language.Fortran.PrettyPrint where@@ -12,6 +13,8 @@ import Prelude hiding (EQ,LT,GT,pred,exp,(<>))  import Language.Fortran.AST+import Language.Fortran.AST.RealLit+import Language.Fortran.AST.Boz import Language.Fortran.Version import Language.Fortran.Util.FirstParameter @@ -430,7 +433,7 @@     where       len e  = "len=" <> pprint' v e       kind e = "kind=" <> pprint' v e-      noParensLit e@(ExpValue _ _ (ValInteger _))  = pprint' v e+      noParensLit e@(ExpValue _ _ (ValInteger _ _))  = pprint' v e       noParensLit e = parens $ pprint' v e  instance Pretty (Statement a) where@@ -964,7 +967,18 @@       | otherwise = tooOld v "Operator" Fortran90     pprint' v (ValComplex e1 e2) = parens $ commaSep [pprint' v e1, pprint' v e2]     pprint' _ (ValString str) = quotes $ text str+    pprint' v (ValLogical b kp) = text litStr <> kpPretty v kp+      where litStr = if b then ".true." else ".false."+    pprint' v (ValInteger i kp) = text i <> kpPretty v kp+    pprint' v (ValReal r kp) = text (prettyHsRealLit r) <> kpPretty v kp+    pprint' _ (ValBoz b) = text $ prettyBoz b     pprint' _ valLit = text . getFirstParameter $ valLit++-- | Helper for pretty printing an optional kind parameter 'Expression'.+kpPretty :: FortranVersion -> Maybe (Expression a) -> Doc+kpPretty v = \case+  Nothing -> empty+  Just kp -> text "_" <> pprint' v kp  instance IndentablePretty (StructureItem a) where   pprint v (StructFields a s spec mAttrs decls) _ = pprint' v (StDeclaration a s spec mAttrs decls)

@@ -189,26 +189,29 @@ -- | Transform a list of 'Chunk's into a single string, applying -- continuation lines when neccessary. evaluateChunks :: [Chunk] -> ByteString-evaluateChunks ls = evaluateChunks_ ls 0+evaluateChunks ls = evaluateChunks_ ls 0 Nothing -evaluateChunks_ :: [Chunk] -> Int64 -> ByteString-evaluateChunks_ []       _       = ""-evaluateChunks_ (x : xs) currLen =-    if overLength-    then "\n     +"-         <> evaluateRChars xPadded-         <> maybe (evaluateChunks_ xs (6 + nextLen)) (evaluateChunks_ xs)-                lastLen-    else chStr-         <> maybe (evaluateChunks_ xs (currLen + nextLen)) (evaluateChunks_ xs)-                lastLen+evaluateChunks_ :: [Chunk] -> Int64 -> Maybe Char -> ByteString+evaluateChunks_ []       _       _         = ""+evaluateChunks_ (x : xs) currLen quotation = if overLength+  then+    "\n     +"+    <> evaluateRChars xPadded+    <> maybe (evaluateChunks_ xs (6 + nextLen) nextState)+             (\len -> evaluateChunks_ xs len nextState)+             lastLen+  else+    chStr+      <> maybe (evaluateChunks_ xs (currLen + nextLen) nextState)+               (\len -> evaluateChunks_ xs len nextState)+               lastLen  where   overLength = currLen + nextLen > 72 && currLen > 0   xPadded    = padImplicitComments x (72 - 6)   chStr      = evaluateRChars x-  nextLen    = fromMaybe-    (BC.length chStr)-    (myMin (BC.elemIndex '\n' chStr) (BC.elemIndex '!' chStr)) -- don't line break for comments+  isQuote    = (`elem` ['\'', '"'])+  nextLen    = fromMaybe (BC.length chStr)+                         (myMin (BC.elemIndex '\n' chStr) explicitCommentIdx) -- don't line break for comments   lastLen = BC.elemIndex '\n' $ BC.reverse chStr   -- min for maybes that doesn't short circuit if there's a Nothing   myMin y z = case (y, z) of@@ -216,6 +219,27 @@     (Nothing, Just a ) -> Just a     (Just a , Nothing) -> Just a     (Nothing, Nothing) -> Nothing+  (nextState, explicitCommentIdx) =+    elemIndexOutsideStringLiteral quotation '!' (BC.unpack chStr)+  elemIndexOutsideStringLiteral currentState needle haystack = elemIndexImpl_+    currentState+    needle+    haystack+    0+   where+      -- Search space is empty, therefore no result is possible+    elemIndexImpl_ state _ "" _ = (state, Nothing)+    -- We have already entered a string literal+    elemIndexImpl_ state@(Just quoteChar) query (top : rest) idx+      | top == quoteChar = elemIndexImpl_ Nothing query rest (idx + 1)+      | otherwise        = elemIndexImpl_ state query rest (idx + 1)+    -- Searching outside a string literal, might find the query or+    -- enter a string literal+    elemIndexImpl_ Nothing query (top : rest) idx+      | top == query = (Nothing, Just idx)+      | isQuote top  = elemIndexImpl_ (Just top) query rest (idx + 1)+      | otherwise    = elemIndexImpl_ Nothing query rest (idx + 1)+   -- Text after line 72 is an implicit comment, so should stay there   padImplicitComments :: Chunk -> Int -> Chunk   padImplicitComments chunk targetCol = case findCommentRChar chunk of

@@ -172,8 +172,8 @@   compLabel :: Maybe (Expression a) -> Maybe (Expression a) -> Bool-compLabel (Just (ExpValue _ _ (ValInteger l1)))-          (Just (ExpValue _ _ (ValInteger l2))) = strip l1 == strip l2+compLabel (Just (ExpValue _ _ (ValInteger l1 _)))+          (Just (ExpValue _ _ (ValInteger l2 _))) = strip l1 == strip l2 compLabel _ _ = False  strip :: String -> String

@@ -0,0 +1,14 @@+module Language.Fortran.AST.BozSpec where++import Test.Hspec++import Language.Fortran.AST.Boz++spec :: Spec+spec = do+  describe "BOZ literal constants" $ do+    it "parses a prefix and suffix BOZ constant identically" $ do+      parseBoz "z'123abc'" `shouldBe` parseBoz "'123abc'z"++    it "parses nonstandard X as Z (hex)" $ do+      parseBoz "x'09af'" `shouldBe` parseBoz "z'09af'"

@@ -0,0 +1,29 @@+module Language.Fortran.AST.RealLitSpec where++import           Prelude hiding ( exp )++import           Test.Hspec++import           Language.Fortran.AST.RealLit++spec :: Spec+spec = do+  describe "Fortran real literals" $ do+    it "parses & normalizes various well-formed valid real literals" $ do+      prl "1.0"    `shouldBe` rl "1.0" expDef+      prl "1.0e0"  `shouldBe` rl "1.0" expDef+      prl "10e-1"  `shouldBe` rl "10.0" (exp e "-1")+      prl "-1.e-1" `shouldBe` rl "-1.0" (exp e "-1")+      prl "+1.e+1" `shouldBe` rl "1.0" (exp e "1")+      prl "1.e1"   `shouldBe` rl "1.0" (exp e "1")+      prl ".1"     `shouldBe` rl "0.1" expDef+      prl "1.0d0"  `shouldBe` rl "1.0" (exp d "0")+      prl "1.0q0"  `shouldBe` rl "1.0" (exp q "0")+    where+      prl = parseRealLit+      rl = RealLit+      exp = Exponent+      expDef = Exponent ExpLetterE "0"+      e = ExpLetterE+      d = ExpLetterD+      q = ExpLetterQ

@@ -62,7 +62,7 @@         reached `shouldBe` nodeSet     describe "gotos" $ do       let pf = pParser programGotos-          gr = fromJust . M.lookup (Named "_gotos1") $ genBBlockMap pf+          gr = fromJust . M.lookup (Named "_gotos_1") $ genBBlockMap pf           ns = nodes $ bbgrGr gr           es = edges $ bbgrGr gr           nodeSet = IS.fromList ns

@@ -3,6 +3,8 @@  import Test.Hspec import TestUtil+import Test.Hspec.QuickCheck+import Test.QuickCheck (Positive(..))  import Language.Fortran.Parser.Fortran77 import qualified Language.Fortran.Parser.Fortran90 as F90@@ -254,6 +256,11 @@       it "dominators on disconnected graph" $         dominators (BBGr (nmap (const []) (mkUGraph [0,1,3,4,5,6,7,8,9] [(0,3) ,(3,1) ,(5,6) ,(6,7) ,(7,4) ,(7,8) ,(8,7) ,(8,9) ,(9,8)])) [0,5] [3,9]) `shouldBe` IM.fromList [(0,IS.fromList [0]),(1,IS.fromList [0,1,3]),(3,IS.fromList [0,3]),(4,IS.fromList [4,5,6,7]),(5,IS.fromList [5]),(6,IS.fromList [5,6]),(7,IS.fromList [5,6,7]),(8,IS.fromList [5,6,7,8]),(9,IS.fromList [5,6,7,8,9])] +    describe "Constants" $ do+      prop "constant folding evaluates exponentation (positive exponent)" $+        let constExpoExpr b e = ConstBinary Exponentiation (ConstInt b) (ConstInt e)+         in \(base, Positive expo) -> constantFolding (constExpoExpr base expo) `shouldBe` ConstInt (base ^ expo)+ -------------------------------------------------- -- Label-finding helper functions to help write tests that are -- insensitive to minor changes to the AST.@@ -274,7 +281,7 @@ -- For each Fortran label in the list, find the AST-block label numbers ('insLabel') associated findLabelsBl :: forall a. Data a => ProgramFile (Analysis a) -> [Int] -> IS.IntSet findLabelsBl pf labs = IS.fromList [ i | b <- universeBi pf :: [Block (Analysis a)]-                                       , ExpValue _ _ (ValInteger lab') <- maybeToList (getLabel b)+                                       , ExpValue _ _ (ValInteger lab' _) <- maybeToList (getLabel b)                                        , lab' `elem` labsS                                        , let a = getAnnotation b                                        , i <- maybeToList (insLabel a) ]

@@ -24,6 +24,11 @@ --renameAndStrip' :: Data a => ProgramFile a -> ProgramFile a --renameAndStrip' x = stripAnalysis . rename . analyseRenames . initAnalysis $ x +-- ideally use renaming internals instead of redefining here (but tests should+-- error if they don't match)+buildUniqueName :: String -> String -> Int -> String+buildUniqueName scope var n = scope <> "_" <> var <> "_" <> show n+ countUnrenamed :: ProgramFile (Analysis ()) -> Int countUnrenamed e = length [ () | ExpValue Analysis { uniqueName = Nothing } _ ValVariable {} <- uniE_PF e ]   where uniE_PF :: ProgramFile (Analysis ()) -> [Expression (Analysis ())]@@ -104,6 +109,22 @@     it "exScope2 testing shadowing of variables" $ do       let entry = extractNameMap' exScope2       length (filter (=="x") (elems entry)) `shouldBe` 2++    -- GitHub issue #190 https://github.com/camfort/fortran-src/issues/190+    it "doesn't generate same unique name in edge case" $ do+      let ex = resetSrcSpan . flip fortran90Parser "" $ unlines+                 [ "program p1"+                 , "  implicit none"+                 , "  integer x, int1, a1, a2, a3, a4, a5, a6, a7, a8, a9"+                 , "  x = INT(int1)"+                 , "end program p1"+                 ]+          entry  = extractNameMap' ex+          v1 = buildUniqueName "p1" "int1" 2+          v2 = buildUniqueName "p1" "int" 12+          Just v1uniq = M.lookup v1 entry   -- p1_int1_2+          Just v2uniq = M.lookup v2 entry   -- p1_int_12+      v1uniq `shouldNotBe` v2uniq    describe "Ordering" $     it "exScope3 testing out-of-order definitions" $ do

@@ -22,7 +22,7 @@      it "recovers REAL(8) for REAL(8) in Fortran 90" $ do       let semtype  = TReal 8-          typespec = TypeSpec () u TypeReal (Just (Selector () u Nothing (Just (ExpValue () u (ValInteger "8")))))+          typespec = TypeSpec () u TypeReal (Just (Selector () u Nothing (Just (intGen 8))))        in recoverSemTypeTypeSpec () u Fortran90 semtype `shouldBe` typespec      it "recovers CHARACTER(*)" $ do

@@ -1,4 +1,4 @@-module Language.Fortran.Analysis.TypesSpec where+module Language.Fortran.Analysis.TypesSpec ( spec ) where  import Test.Hspec import TestUtil@@ -37,6 +37,8 @@ defSTy :: BaseType -> SemType defSTy = deriveSemTypeFromBaseType +--------------------------------------------------------------------------------+ spec :: Spec spec = do   describe "Global type inference" $ do@@ -128,10 +130,10 @@         [ a | ExpFunctionCall a _ (ExpValue _ _ (ValIntrinsic "abs")) _ <- uniExpr pf             , idType a == Just (IDType (Just (defSTy TypeReal)) Nothing) ]           `shouldNotSatisfy` null-        [ a | ExpBinary a _ Addition (ExpValue _ _ (ValInteger "1")) _ <- uniExpr pf+        [ a | ExpBinary a _ Addition (ExpValue _ _ (ValInteger "1" _)) _ <- uniExpr pf             , idType a == Just (IDType (Just (defSTy TypeComplex)) Nothing) ]           `shouldNotSatisfy` null-        [ a | ExpBinary a _ Addition (ExpValue _ _ (ValInteger "2")) _ <- uniExpr pf+        [ a | ExpBinary a _ Addition (ExpValue _ _ (ValInteger "2" _)) _ <- uniExpr pf             , idType a == Just (IDType (Just (TReal 8)) Nothing) ]           `shouldNotSatisfy` null @@ -152,6 +154,36 @@                                         (Just (CTArray [(Nothing, Just 20)])))]           `shouldNotSatisfy` null +    describe "Kind parameters and lengths" $ do+      let mapping = inferTable testkinds+      it "handles CHARACTER x*2 (RHS CHARACTER length)" $ do+        idVType (mapping ! "a") `shouldBe` Just (TCharacter (CharLenInt 2) 1)+      it "handles CHARACTER*2 x (LHS CHARACTER length)" $ do+        idVType (mapping ! "b") `shouldBe` Just (TCharacter (CharLenInt 2) 1)+      it "handles INTEGER*2 x (standard kind parameter)" $ do+        idVType (mapping ! "c") `shouldBe` Just (TInteger 2)+      it "handles INTEGER x*2 (nonstandard kind parameter)" $ do+        idVType (mapping ! "d") `shouldBe` Just (TInteger 2)+      it "handles multiple declarators with various kind parameter configurations" $ do+        idVType (mapping ! "e") `shouldBe` Just (TInteger 1)+        idVType (mapping ! "f") `shouldBe` Just (TInteger 2)+        idVType (mapping ! "g") `shouldBe` Just (TInteger 8)+        idVType (mapping ! "h") `shouldBe` Just (TInteger 8)++      it "handles array types with nonstandard kind parameters" $ do+        -- default kind after a nonstandard (declarator) kind param+        idVType (mapping ! "i") `shouldBe` Just (TInteger 4)++      it "handles nonstandard character array + length syntax" $ do+        idVType (mapping ! "i2_arr") `shouldBe` Just (TInteger 2)+        idCType (mapping ! "i2_arr") `shouldBe` Just (CTArray [(Nothing, Just 2)])++      it "handles multiple declarators with various kind parameter configurations correctly" $ do+        idVType (mapping ! "ilhs_arr") `shouldBe` Just (TInteger 1)+        idCType (mapping ! "ilhs_arr") `shouldBe` Just (CTArray [(Nothing, Just 2)])+        idVType (mapping ! "i8_arr") `shouldBe` Just (TInteger 8)+        idCType (mapping ! "i8_arr") `shouldBe` Just (CTArray [(Nothing, Just 2)])+     describe "structs and arrays" $ do       it "can handle typing assignments to arrays within structs" $ do         let mapping = inferTable $ structArray False@@ -252,6 +284,7 @@   , BlStatement () u Nothing (StExpressionAssign () u       (ExpSubscript () u (varGen "d") (fromList () [ ixSinGen 1 ])) (intGen 1)) ] +{- ex11 :: ProgramFile () ex11 = ProgramFile mi77 [ ex11pu1 ] ex11pu1 :: ProgramUnit ()@@ -261,9 +294,10 @@   [ BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e1")) Nothing Nothing)   , BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e2")) Nothing Nothing)   , BlStatement () u Nothing (StEntry () u (ExpValue () u (ValVariable "e3")) Nothing (Just (varGen "r2"))) ]+-}  intrinsics1 :: ProgramFile A0-intrinsics1 = resetSrcSpan . flip fortran90Parser "" $ unlines [+intrinsics1 = parseStrF90 $ unlines [     "module intrinsics"   , "contains"   , "  subroutine main()"@@ -283,7 +317,7 @@   ]  intrinsics2 :: ProgramFile A0-intrinsics2 = resetSrcSpan . flip fortran90Parser "" $ unlines [+intrinsics2 = parseStrF90 $ unlines [     "module intrinsics"   , "contains"   , "  subroutine main()"@@ -301,7 +335,7 @@   ]  numerics1 :: ProgramFile A0-numerics1 = resetSrcSpan . flip fortran90Parser "" $ unlines [+numerics1 = parseStrF90 $ unlines [     "module numerics1"   , "contains"   , "  subroutine main()"@@ -319,20 +353,41 @@   , "end module numerics1"   ] - teststrings1 :: ProgramFile A0-teststrings1 = resetSrcSpan . flip fortran90Parser "" $ unlines [-    "program teststrings"-  , "  character(5,1) :: a"-  , "  character :: b*10"-  , "  character(kind=1,len=3) :: c"-  , "  integer, parameter :: k = 8"-  , "  character(k), dimension(10) :: d"-  , "  character :: e(20)*10"-  , "  character(kind=2) :: f"-  , "end program teststrings"+teststrings1 = parseStrF90 . fProgStr $+  [ "character(5,1) :: a"+  , "character :: b*10"+  , "character(kind=1,len=3) :: c"+  , "integer, parameter :: k = 8"+  , "character(k), dimension(10) :: d"+  , "character :: e(20)*10"+  , "character(kind=2) :: f"   ] +testkinds :: ProgramFile A0+testkinds = parseStrF90 . fProgStr $+  [ "character   a*2"+  , "character*2 b"+  , "integer     c*2"+  , "integer*2   d"+  , "integer*2   e*1, f, g*8"+  , "integer     h*8, i"+  , "integer*1   i2_arr*2(2), ilhs_arr(2), i8_arr(2)*8"+  ]++--------------------------------------------------------------------------------++-- | Wrapper for creating a string representation of a simple Fortran program.+--+-- Wraps in F90-style program.+fProgStr :: [String] -> String+fProgStr progContents = unlines prog+  where prog = ["program test"] <> progContents <> ["end program test"]++-- | Parse a string as an F90 program with initialized 'SrcSpan's.+parseStrF90 :: String -> ProgramFile A0+parseStrF90 = resetSrcSpan . flip fortran90Parser ""+ commonTransform :: [String] -> String -> [String] -> Bool -> ProgramFile A0 commonTransform front cdecl back common =   resetSrcSpan . flip legacy77Parser "" . unlines . (++) front $@@ -391,7 +446,6 @@       , "       print *, 'DONE'"       , "      end subroutine totes"       ]-  -- Local variables: -- mode: haskell

@@ -1,7 +1,9 @@ module Language.Fortran.Lexer.FixedFormSpec where  import Language.Fortran.ParserMonad+--import Language.Fortran.Version (required when ParserMonad stops exporting it) import Language.Fortran.Lexer.FixedForm+import Language.Fortran.AST.Boz  import Test.Hspec import Test.Hspec.QuickCheck@@ -214,9 +216,12 @@        it "lexes BOZ constants" $         resetSrcSpan (collectFixedTokens' Fortran77Legacy "      integer i, j, k / b'0101', o'0755', z'ab01' /")-          `shouldBe` resetSrcSpan [ TType u "integer", TId u "i", TComma u, TId u "j", TComma u, TId u"k"-                                  , TSlash u, TBozInt u "b'0101'", TComma u, TBozInt u "o'0755'", TComma u, TBozInt u "z'ab01'", TSlash u-                                  , TEOF u ]+          `shouldBe` resetSrcSpan [ TType u "integer"+                                  , TId u "i", TComma u, TId u "j", TComma u, TId u "k"+                                  , TSlash u, TBozLiteral u (parseBoz "b'0101'")+                                  , TComma u, TBozLiteral u (parseBoz "o'0755'")+                                  , TComma u, TBozLiteral u (parseBoz "z'ab01'")+                                  , TSlash u , TEOF u ]        it "lexes non-standard identifiers" $         resetSrcSpan (collectFixedTokens' Fortran77Legacy "      integer _this_is_a_long_identifier$")@@ -235,8 +240,7 @@        it "lexes labeled DO WHILE blocks" $         resetSrcSpan (collectFixedTokens' Fortran77Legacy "      do 10 while (.true.)")-          `shouldBe` resetSrcSpan [TDo u, TInt u "10", TWhile u, TLeftPar u, TBool u ".true.", TRightPar u, TEOF u]-+          `shouldBe` resetSrcSpan [TDo u, TInt u "10", TWhile u, TLeftPar u, TBool u True, TRightPar u, TEOF u]        it "lexes structure/union/map blocks" $ do         let src = unlines [ "      structure /foo/"

@@ -3,7 +3,8 @@ import Test.Hspec import TestUtil -import Language.Fortran.ParserMonad (FortranVersion(..))+import Language.Fortran.AST.RealLit+import Language.Fortran.Version import Language.Fortran.Lexer.FreeForm (collectFreeTokens, Token(..)) import Language.Fortran.Util.Position (SrcSpan) import qualified Data.ByteString.Char8 as B@@ -193,7 +194,7 @@       describe "Conditional" $ do         it "lexes logical if with array assignment" $           shouldBe' (collectF90 "if (.true.) a(1) = 42") $-                    fmap ($u) [ TIf, TLeftPar, flip TLogicalLiteral ".true."+                    fmap ($u) [ TIf, TLeftPar, flip TLogicalLiteral True                               , TRightPar, flip TId "a", TLeftPar                               , flip TIntegerLiteral "1", TRightPar, TOpAssign                               , flip TIntegerLiteral "42", TEOF ]@@ -222,21 +223,29 @@                     pseudoAssign $ flip TIntegerLiteral "42"          describe "Real" $ do-          it "lexes real (1)" $-            shouldBe' (collectF90 "i = 10.5e2") $-                      pseudoAssign $ flip TRealLiteral "10.5e2"+          it "lexes real (1)" $ do+            let litStr      = "10.5e2"+                expectedLit = RealLit "10.5" (Exponent ExpLetterE "2")+                expected    = pseudoAssign $ flip TRealLiteral expectedLit+            collectF90 ("i = "<>litStr) `shouldBe'` expected -          it "lexes real (2)" $-            shouldBe' (collectF90 "i = 10.") $-                      pseudoAssign $ flip TRealLiteral "10."+          it "lexes real (2)" $ do+            let litStr      = "10."+                expectedLit = RealLit "10.0" (Exponent ExpLetterE "0")+                expected    = pseudoAssign $ flip TRealLiteral expectedLit+            collectF90 ("i = "<>litStr) `shouldBe'` expected -          it "lexes real (3)" $-            shouldBe' (collectF90 "i = .42") $-                      pseudoAssign $ flip TRealLiteral ".42"+          it "lexes real (3)" $ do+            let litStr      = ".42"+                expectedLit = RealLit "0.42" (Exponent ExpLetterE "0")+                expected    = pseudoAssign $ flip TRealLiteral expectedLit+            collectF90 ("i = "<>litStr) `shouldBe'` expected -          it "lexes real (3)" $-            shouldBe' (collectF90 "i = 42d-3") $-                      pseudoAssign $ flip TRealLiteral "42d-3"+          it "lexes real (4)" $ do+            let litStr      = "42d-3"+                expectedLit = RealLit "42.0" (Exponent ExpLetterD "-3")+                expected    = pseudoAssign $ flip TRealLiteral expectedLit+            collectF90 ("i = "<>litStr) `shouldBe'` expected            it "resolves disambiguity when xxx. follows relational operator" $             shouldBe' (collectF90 "if (10.EQ. 20)") $

@@ -3,8 +3,9 @@  import Prelude hiding (GT, EQ, exp, pred) -import TestUtil import Test.Hspec+import TestUtil+import Language.Fortran.Parser.FreeFormCommon  import Language.Fortran.AST import Language.Fortran.ParserMonad@@ -175,3 +176,5 @@             expValVar x = ExpValue () u (ValVariable x)             expBinVars op x1 x2 = ExpBinary () u op (expValVar x1) (expValVar x2)         bParser text `shouldBe'` expected++    specFreeFormCommon sParser eParser

@@ -29,35 +29,6 @@   describe "Fortran 66 Parser" $ do     describe "Expressions" $ do       describe "Arithmetic expressions" $ do-        describe "Real numbers" $ do-          it "parses 'hello" $ do-            let expectedExp = varGen "hello"-            eParser "hello" `shouldBe'` expectedExp--          it "parses '3.14" $ do-            let expectedExp = ExpValue () u (ValReal "3.14")-            eParser "3.14" `shouldBe'` expectedExp--          it "parses '.14" $ do-            let expectedExp = ExpValue () u (ValReal ".14")-            eParser ".14" `shouldBe'` expectedExp--          it "parses '3." $ do-            let expectedExp = ExpValue () u (ValReal "3.")-            eParser "3." `shouldBe'` expectedExp--          it "parses '3E12" $ do-            let expectedExp = ExpValue () u (ValReal "3e12")-            eParser "3E12" `shouldBe'` expectedExp--          it "parses '3.14d12" $ do-            let expectedExp = ExpValue () u (ValReal "3.14d12")-            eParser "3.14d12" `shouldBe'` expectedExp--          it "parses '.14d+1" $ do-            let expectedExp = ExpValue () u (ValReal ".14d+1")-            eParser ".14d+1" `shouldBe'` expectedExp-         it "parses '3'" $ do           let expectedExp = intGen 3           eParser "3" `shouldBe'` expectedExp

@@ -87,14 +87,11 @@       pParser exampleProgram2 `shouldBe'` pu      it "parses 'intrinsic cosh, sin'" $ do-      let fun1 = ExpValue () u (ValVariable "cosh")-          fun2 = ExpValue () u (ValVariable "sin")-          st = StIntrinsic () u (AList () u [ fun1, fun2 ])+      let st = StIntrinsic () u (AList () u [ varGen "cosh", varGen "sin" ])       sParser "      intrinsic cosh, sin" `shouldBe'` st      it "parses 'intrinsic real" $ do-      let fun = ExpValue () u (ValVariable "real")-          st = StIntrinsic () u (AList () u [ fun ])+      let st = StIntrinsic () u (AList () u [ varGen "real" ])       sParser "      intrinsic real" `shouldBe'` st      describe "CHARACTER" $ do@@ -198,9 +195,8 @@       eParser ".true. .eqv. f(42) .neqv. x" `shouldBe'` exp      it "parses 'entry me (a,b,*)'" $ do-      let func = ExpValue () u (ValVariable "me")-          args = [ varGen "a", varGen "b", starVal ]-          st = StEntry () u func (Just $ AList () u args) Nothing+      let args = [ varGen "a", varGen "b", starVal ]+          st = StEntry () u (varGen "me") (Just $ AList () u args) Nothing       sParser "      entry me (a,b,*)" `shouldBe'` st      it "parses 'character a*8'" $ do@@ -211,7 +207,7 @@      it "parses 'character c*(ichar('A'))" $ do       let args = AList () u [ IxSingle () u Nothing (ExpValue () u (ValString "A")) ]-          lenExpr = ExpSubscript () u (ExpValue () u (ValVariable "ichar")) args+          lenExpr = ExpSubscript () u (varGen "ichar") args           decl = DeclVariable () u (varGen "c") (Just $ lenExpr) Nothing           typeSpec = TypeSpec () u TypeCharacter Nothing           st = StDeclaration () u typeSpec Nothing (AList () u [ decl ])@@ -228,9 +224,8 @@       let printArgs  = Just $ AList () u [ExpValue () u $ ValString "foo"]           printStmt  = StPrint () u (ExpValue () u ValStar) printArgs           printBlock = BlStatement () u Nothing printStmt-          trueLit = ExpValue () u $ ValLogical ".true."       it "unlabelled" $ do-        let bl = BlIf () u Nothing Nothing [ Just trueLit, Nothing ] [[printBlock], [printBlock]]  Nothing+        let bl = BlIf () u Nothing Nothing [ Just valTrue, Nothing ] [[printBlock], [printBlock]]  Nothing             src = unlines [ "      if (.true.) then ! comment if"                           , "        print *, 'foo'"                           , "      else ! comment else"@@ -239,8 +234,8 @@                           ]         blParser src `shouldBe'` bl       it "labelled" $ do-        let label str = Just $ ExpValue () u $ ValInteger str-            bl = BlIf () u (label "10")  Nothing [Just trueLit, Nothing] [[printBlock], [printBlock]] (label "30")+        let label = Just . intGen+            bl = BlIf () u (label 10)  Nothing [Just valTrue, Nothing] [[printBlock], [printBlock]] (label 30)             src = unlines [ "10    if (.true.) then ! comment if"                           , "        print *, 'foo'"                           , "20    else ! comment else"@@ -318,38 +313,37 @@         let src = init $ unlines [ "      print *, foo % bar"                                  , "      print *, foo.bar" ]             expStar = ExpValue () u ValStar-            foobar = ExpDataRef () u (ExpValue () u (ValVariable "foo")) (ExpValue () u (ValVariable "bar"))+            foobar = ExpDataRef () u (varGen "foo") (varGen "bar")             blStmt = BlStatement () u Nothing $ StPrint () u expStar $ Just $ AList () u [foobar]         resetSrcSpan (iParser src) `shouldBe` [ blStmt, blStmt ]        it "parse special intrinsics to arguments" $ do         let blStmt stmt = BlStatement () u Nothing stmt-            var = ExpValue () u . ValVariable-            ext = blStmt $ StExternal () u $ AList () u [var "bar"]+            ext = blStmt $ StExternal () u $ AList () u [varGen "bar"]             arg = Just . AList () u . pure . Argument () u Nothing             valBar = ExpFunctionCall () u (ExpValue () u (ValIntrinsic "%val"))-                     $ arg $ var "baz"-            call = blStmt $ StCall () u (var "bar") $ arg valBar+                     $ arg $ varGen "baz"+            call = blStmt $ StCall () u (varGen "bar") $ arg valBar             pu = ProgramFile mi77 [ PUSubroutine () u (Nothing, Nothing) "foo"-                                   (Just $ AList () u [var "baz"]) [ ext, call ] Nothing ]+                                   (Just $ AList () u [varGen "baz"]) [ ext, call ] Nothing ]         resetSrcSpan (pParser exampleProgram3) `shouldBe` pu        it "parses character declarations with unspecfied lengths" $ do         let src = "      character s*(*)"             st = StDeclaration () u (TypeSpec () u TypeCharacter Nothing) Nothing $                  AList () u [DeclVariable () u-                               (ExpValue () u (ValVariable "s"))+                               (varGen "s")                                (Just (ExpValue () u ValStar))                                Nothing]         resetSrcSpan (slParser src) `shouldBe` st        it "parses array initializers" $ do         let src = "      integer xs(3) / 1, 2, 3 /"-            inits = [ExpValue () u (ValInteger "1"), ExpValue () u (ValInteger "2"), ExpValue () u (ValInteger "3")]+            inits = [intGen 1, intGen 2, intGen 3]             st = StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing $                  AList () u [DeclArray () u-                               (ExpValue () u (ValVariable "xs"))-                               (AList () u [DimensionDeclarator () u Nothing (Just (ExpValue () u (ValInteger "3")))])+                               (varGen "xs")+                               (AList () u [DimensionDeclarator () u Nothing (Just (intGen 3))])                                Nothing                                (Just (ExpInitialisation () u $ AList () u inits))]         resetSrcSpan (slParser src) `shouldBe` st@@ -358,9 +352,9 @@             inits1 = [ExpValue () u (ValString "hello"), ExpValue () u (ValString "world")]             st1 = StDeclaration () u (TypeSpec () u TypeCharacter Nothing) Nothing $                  AList () u [DeclArray () u-                               (ExpValue () u (ValVariable "xs"))-                               (AList () u [DimensionDeclarator () u Nothing (Just (ExpValue () u (ValInteger "2")))])-                               (Just (ExpValue () u (ValInteger "5")))+                               (varGen "xs")+                               (AList () u [DimensionDeclarator () u Nothing (Just (intGen 2))])+                               (Just (intGen 5))                                (Just (ExpInitialisation () u $ AList () u inits1))]         resetSrcSpan (slParser src1) `shouldBe` st1 @@ -368,33 +362,33 @@             inits2 = [ExpValue () u (ValString "hello"), ExpValue () u (ValString "world")]             st2 = StDeclaration () u (TypeSpec () u TypeCharacter Nothing) Nothing $                  AList () u [DeclArray () u-                               (ExpValue () u (ValVariable "xs"))-                               (AList () u [DimensionDeclarator () u Nothing (Just (ExpValue () u (ValInteger "2")))])-                               (Just (ExpValue () u (ValInteger "5")))+                               (varGen "xs")+                               (AList () u [DimensionDeclarator () u Nothing (Just (intGen 2))])+                               (Just (intGen 5))                                (Just (ExpInitialisation () u $ AList () u inits2))]         resetSrcSpan (slParser src2) `shouldBe` st2        it "parses subscripts in assignments" $ do-        let mkIdx i = IxSingle () u Nothing (ExpValue () u (ValInteger i))+        let mkIdx i = IxSingle () u Nothing (intGen i)              src = "      x(0,1) = 0"-            tgt = ExpSubscript () u (ExpValue () u (ValVariable "x")) (AList () u [mkIdx "0", mkIdx "1"])-            st = StExpressionAssign () u tgt (ExpValue () u (ValInteger "0"))+            tgt = ExpSubscript () u (varGen "x") (AList () u [mkIdx 0, mkIdx 1])+            st = StExpressionAssign () u tgt (intGen 0)         resetSrcSpan (slParser src) `shouldBe` st          let src1 = "      x(0).foo = 0"-            tgt1 = ExpDataRef () u (ExpSubscript () u (ExpValue () u (ValVariable "x")) (AList () u [mkIdx "0"])) (ExpValue () u (ValVariable "foo"))-            st1 = StExpressionAssign () u tgt1 (ExpValue () u (ValInteger "0"))+            tgt1 = ExpDataRef () u (ExpSubscript () u (varGen "x") (AList () u [mkIdx 0])) (varGen "foo")+            st1 = StExpressionAssign () u tgt1 (intGen 0)         resetSrcSpan (slParser src1) `shouldBe` st1          let src2 = "      x.foo = 0"-            tgt2 = ExpDataRef () u (ExpValue () u (ValVariable "x")) (ExpValue () u (ValVariable "foo"))-            st2 = StExpressionAssign () u tgt2 (ExpValue () u (ValInteger "0"))+            tgt2 = ExpDataRef () u (varGen "x") (varGen "foo")+            st2 = StExpressionAssign () u tgt2 (intGen 0)         resetSrcSpan (slParser src2) `shouldBe` st2          let src3 = "      x.foo(0) = 0"-            tgt3 = ExpSubscript () u (ExpDataRef () u (ExpValue () u (ValVariable "x")) (ExpValue () u (ValVariable "foo"))) (AList () u [mkIdx "0"])-            st3 = StExpressionAssign () u tgt3 (ExpValue () u (ValInteger "0"))+            tgt3 = ExpSubscript () u (ExpDataRef () u (varGen "x") (varGen "foo")) (AList () u [mkIdx 0])+            st3 = StExpressionAssign () u tgt3 (intGen 0)         resetSrcSpan (slParser src3) `shouldBe` st3       it "parses automatic and static statements" $ do         let decl = DeclVariable () u (varGen "x") Nothing Nothing

@@ -2,8 +2,9 @@  import Prelude hiding (GT, exp, pred) -import TestUtil import Test.Hspec+import TestUtil+import Language.Fortran.Parser.FreeFormCommon  import Language.Fortran.AST import Language.Fortran.ParserMonad@@ -138,10 +139,13 @@         in fParser fStr `shouldBe'` expected      describe "Expression" $ do-      it "parses logial literals with kind" $ do-        let expected = ExpValue () u (ValLogical ".true._kind")-        eParser ".true._kind" `shouldBe'` expected+      it "parses logical literal without kind parameter" $ do+        eParser ".true." `shouldBe'` valTrue +      it "parses logical literal with kind parameter" $ do+        let kp = ExpValue () u (ValVariable "kind")+        eParser ".false._kind" `shouldBe'` valFalse' kp+       it "parses array initialisation exp" $ do         let list = AList () u [ intGen 1, intGen 2, intGen 3, intGen 4 ]         eParser "(/ 1, 2, 3, 4 /)" `shouldBe'` ExpInitialisation () u list@@ -442,19 +446,16 @@       let stPrint = StPrint () u starVal (Just $ fromList () [ ExpValue () u (ValString "foo")])       it "parser if block" $         let ifBlockSrc = unlines [ "if (.false.) then", "print *, 'foo'", "end if"]-            falseLit = ExpValue () u (ValLogical ".false.")-        in blParser ifBlockSrc `shouldBe'` BlIf () u Nothing Nothing [Just falseLit] [[BlStatement () u Nothing stPrint]] Nothing+        in blParser ifBlockSrc `shouldBe'` BlIf () u Nothing Nothing [Just valFalse] [[BlStatement () u Nothing stPrint]] Nothing        it "parses named if block" $ do         let ifBlockSrc = unlines [ "mylabel : if (.true.) then", "print *, 'foo'", "end if mylabel"]-            trueLit = ExpValue () u (ValLogical ".true.")-            ifBlock = BlIf () u Nothing (Just "mylabel") [Just trueLit] [[BlStatement () u Nothing stPrint]] Nothing+            ifBlock = BlIf () u Nothing (Just "mylabel") [Just valTrue] [[BlStatement () u Nothing stPrint]] Nothing         blParser ifBlockSrc `shouldBe'` ifBlock        it "parses if-else block with inline comments (stripped)" $         let ifBlockSrc = unlines [ "if (.false.) then ! comment if", "print *, 'foo'", "else ! comment else", "print *, 'foo'", "end if ! comment end"]-            falseLit = ExpValue () u (ValLogical ".false.")-        in blParser ifBlockSrc `shouldBe'` BlIf () u Nothing Nothing [Just falseLit, Nothing] [[BlStatement () u Nothing stPrint], [BlStatement () u Nothing stPrint]] Nothing+        in blParser ifBlockSrc `shouldBe'` BlIf () u Nothing Nothing [Just valFalse, Nothing] [[BlStatement () u Nothing stPrint], [BlStatement () u Nothing stPrint]] Nothing        it "parses logical if statement" $ do         let assignment = StExpressionAssign () u (varGen "a") (varGen "b")@@ -471,41 +472,40 @@       let printArgs str = Just $ AList () u [ExpValue () u $ ValString str]           printStmt = StPrint () u (ExpValue () u ValStar) . printArgs           printBlock = BlStatement () u Nothing . printStmt-          intLit = ExpValue () u . ValInteger-          ind2 = AList () u . pure $ IxSingle () u Nothing $ intLit "2"-          ind3Plus = AList () u . pure $ IxRange () u (Just $ intLit "3") Nothing Nothing+          ind2 = AList () u . pure $ IxSingle () u Nothing $ intGen 2+          ind3Plus = AList () u . pure $ IxRange () u (Just $ intGen 3) Nothing Nothing           conds = [Just ind2, Just ind3Plus, Nothing]       it "unlabelled case block (with inline comments to be stripped)" $ do-        let src = unlines [ "select case (x) ! inline select"+        let src = unlines [ "select case (x) ! comment select"                           , "! full line before first case (unrepresentable)"-                          , "case (2) ! inline case 1"+                          , "case (2) ! comment case 1"                           , "print *, 'foo'"-                          , "case (3:) ! inline case 2"+                          , "case (3:) ! comment case 2"                           , "print *, 'bar'"-                          , "case default ! inline case 3"+                          , "case default ! comment case 3"                           , "print *, 'baz'"-                          , "end select ! inline end"+                          , "end select ! comment end"                           ]             blocks = (fmap . fmap) printBlock [["foo"], ["bar"], ["baz"]]             block = BlCase () u Nothing Nothing (varGen "x") conds blocks Nothing         blParser src `shouldBe'` block       it "labelled case block (with inline comments to be stripped" $ do         let src = unlines [ "10 mylabel: select case (x) ! comment select"-                          , "20 case (2) ! inline case 1"+                          , "20 case (2) ! comment case 1"                           , "30 print *, 'foo'"-                          , "40 case (3:) ! inline case 2"+                          , "40 case (3:) ! comment case 2"                           , "50 print *, 'bar'"-                          , "60 case default ! inline case 3"+                          , "60 case default ! comment case 3"                           , "70 print *, 'baz'"-                          , "80 end select mylabel ! inline end"+                          , "80 end select mylabel ! comment end"                           ]             blocks = (fmap . fmap)-                     (\(label, arg) -> BlStatement () u (Just $ intLit label) $ printStmt arg)-                     [[("30", "foo")], [("50", "bar")], [("70", "baz")]]+                     (\(label, arg) -> BlStatement () u (Just $ intGen label) $ printStmt arg)+                     [[(30, "foo")], [(50, "bar")], [(70, "baz")]]             block = BlCase () u-                           (Just $ intLit "10") (Just "mylabel") (varGen "x")+                           (Just $ intGen 10) (Just "mylabel") (varGen "x")                            conds blocks-                           (Just $ intLit "80")+                           (Just $ intGen 80)         blParser src `shouldBe'` block      describe "Do" $ do@@ -592,3 +592,5 @@             , UseID () u (ExpValue () u ValAssignment) ]       let st = StUse () u (varGen "stats_lib") Nothing Exclusive (Just onlys)       sParser "use stats_lib, only: a, b => c, operator(+), assignment(=)" `shouldBe'` st++    specFreeFormCommon sParser eParser

@@ -2,8 +2,10 @@  import Prelude hiding (GT, EQ, exp, pred) -import TestUtil import Test.Hspec+import TestUtil+import Language.Fortran.Parser.FreeFormCommon+ import Control.Exception (evaluate)  import Language.Fortran.AST@@ -155,10 +157,13 @@         fParser fStr `shouldBe'` expected      describe "Expression" $ do-      it "parses logial literals with kind" $ do-        let expected = ExpValue () u (ValLogical ".true._kind")-        eParser ".true._kind" `shouldBe'` expected+      it "parses logical literal without kind parameter" $ do+        eParser ".true." `shouldBe'` valTrue +      it "parses logical literal with kind parameter" $ do+        let kp = ExpValue () u (ValVariable "kind")+        eParser ".false._kind" `shouldBe'` valFalse' kp+       it "parses array initialisation exp" $ do         let list = AList () u [ intGen 1, intGen 2, intGen 3, intGen 4 ]         eParser "(/ 1, 2, 3, 4 /)" `shouldBe'` ExpInitialisation () u list@@ -491,19 +496,16 @@       let stPrint = StPrint () u starVal (Just $ fromList () [ ExpValue () u (ValString "foo")])       it "parser if block" $         let ifBlockSrc = unlines [ "if (.false.) then", "print *, 'foo'", "end if"]-            falseLit = ExpValue () u (ValLogical ".false.")-        in blParser ifBlockSrc `shouldBe'` BlIf () u Nothing Nothing [Just falseLit] [[BlStatement () u Nothing stPrint]] Nothing+        in blParser ifBlockSrc `shouldBe'` BlIf () u Nothing Nothing [Just valFalse] [[BlStatement () u Nothing stPrint]] Nothing        it "parses named if block" $ do         let ifBlockSrc = unlines [ "mylabel : if (.true.) then", "print *, 'foo'", "end if mylabel"]-            trueLit = ExpValue () u (ValLogical ".true.")-            ifBlock = BlIf () u Nothing (Just "mylabel") [Just trueLit] [[BlStatement () u Nothing stPrint]] Nothing+            ifBlock = BlIf () u Nothing (Just "mylabel") [Just valTrue] [[BlStatement () u Nothing stPrint]] Nothing         blParser ifBlockSrc `shouldBe'` ifBlock        it "parses if-else block with inline comments (stripped)" $         let ifBlockSrc = unlines [ "if (.false.) then ! comment if", "print *, 'foo'", "else ! comment else", "print *, 'foo'", "end if ! comment end"]-            falseLit = ExpValue () u (ValLogical ".false.")-        in blParser ifBlockSrc `shouldBe'` BlIf () u Nothing Nothing [Just falseLit, Nothing] [[BlStatement () u Nothing stPrint], [BlStatement () u Nothing stPrint]] Nothing+        in blParser ifBlockSrc `shouldBe'` BlIf () u Nothing Nothing [Just valFalse, Nothing] [[BlStatement () u Nothing stPrint], [BlStatement () u Nothing stPrint]] Nothing        it "parses logical if statement" $ do         let assignment = StExpressionAssign () u (varGen "a") (varGen "b")@@ -520,9 +522,8 @@       let printArgs str = Just $ AList () u [ExpValue () u $ ValString str]           printStmt = StPrint () u (ExpValue () u ValStar) . printArgs           printBlock = BlStatement () u Nothing . printStmt-          intLit = ExpValue () u . ValInteger-          ind2 = AList () u . pure $ IxSingle () u Nothing $ intLit "2"-          ind3Plus = AList () u . pure $ IxRange () u (Just $ intLit "3") Nothing Nothing+          ind2 = AList () u . pure $ IxSingle () u Nothing $ intGen 2+          ind3Plus = AList () u . pure $ IxRange () u (Just $ intGen 3) Nothing Nothing           conds = [Just ind2, Just ind3Plus, Nothing]       it "unlabelled case block (with inline comments to be stripped)" $ do         let src = unlines [ "select case (x) ! comment select"@@ -549,12 +550,12 @@                           , "80 end select mylabel ! comment end"                           ]             blocks = (fmap . fmap)-                     (\(label, arg) -> BlStatement () u (Just $ intLit label) $ printStmt arg)-                     [[("30", "foo")], [("50", "bar")], [("70", "baz")]]+                     (\(label, arg) -> BlStatement () u (Just $ intGen label) $ printStmt arg)+                     [[(30, "foo")], [(50, "bar")], [(70, "baz")]]             block = BlCase () u-                           (Just $ intLit "10") (Just "mylabel") (varGen "x")+                           (Just $ intGen 10) (Just "mylabel") (varGen "x")                            conds blocks-                           (Just $ intLit "80")+                           (Just $ intGen 80)         blParser src `shouldBe'` block      describe "Do" $ do@@ -655,3 +656,5 @@       let attrs = [AttrVolatile () u]       let st = StDeclaration () u ty (Just (AList () u attrs)) (AList () u decls)       sParser "integer, volatile :: a, b" `shouldBe'` st++    specFreeFormCommon sParser eParser

@@ -0,0 +1,68 @@+-- | Fortran standards F90 and beyond are a lot more consistent than the+--   previous 2. As such, there is lots of shared parsing, and lots of shared+--   tests. This module encodes such shared/common tests, where no difference+--   in behaviour between parsers is be expected.++module Language.Fortran.Parser.FreeFormCommon ( specFreeFormCommon ) where++import           TestUtil+import           Test.Hspec++import           Language.Fortran.AST+import           Language.Fortran.AST.RealLit++specFreeFormCommon :: (String -> Statement A0) -> (String -> Expression A0) -> Spec+specFreeFormCommon sParser eParser =+  describe "Common Fortran 90+ tests" $ do+    describe "Literals" $ do+      describe "Logical" $ do+        it "parses logical literal without kind parameter" $ do+          eParser ".true." `shouldBe'` valTrue++        it "parses logical literal with kind parameter" $ do+          let kp = ExpValue () u (ValVariable "kind")+          eParser ".false._kind" `shouldBe'` valFalse' kp++        it "parses mixed-case logical literal" $ do+          eParser ".tRUe." `shouldBe'` valTrue++      -- Main parse testing is performed in @Language.Fortran.AST.RealLitSpec@.+      -- Here we mainly want to test kind parameter and sign behaviour.+      describe "Real" $ do+        let realLitExp r mkp = ExpValue () u (ValReal (parseRealLit r) mkp)+        it "parses various REAL literals" $ do+          eParser "1."      `shouldBe'` realLitExp "1."    Nothing+          eParser ".1e20_8" `shouldBe'` realLitExp ".1e20" (Just (intGen 8))++        it "parses \"negative\" real literal (unary op)" $ do+          eParser "-1.0d-1_k8" `shouldBe'` ExpUnary () u Minus (realLitExp "1.0d-1" (Just (varGen "k8")))++    describe "Statement" $ do+      describe "Declaration" $ do+        it "parses scalar declaration with nonstandard kind param (non-CHAR)" $ do+          let stStr    = "integer x*8"+              expected = StDeclaration () u typeSpec Nothing decls+              typeSpec = TypeSpec () u TypeInteger Nothing+              decls    = AList () u+                [ DeclVariable () u (varGen "x") (Just (intGen 8)) Nothing ]+          sParser stStr `shouldBe'` expected++        it "parses array declaration with nonstandard kind param (non-CHAR)" $ do+          let stStr    = "integer x(2)*8"+              expected = StDeclaration () u typeSpec Nothing decls+              typeSpec = TypeSpec () u TypeInteger Nothing+              decls    = AList () u+                [ DeclArray () u (varGen "x") dims (Just (intGen 8)) Nothing ]+              dims     = AList () u+                [ DimensionDeclarator () u Nothing (Just (intGen 2)) ]+          sParser stStr `shouldBe'` expected++        it "parses array declaration with nonstandard kind param (non-CHAR) and nonstandard dimension/charlen order" $ do+          let stStr    = "integer x*8(2)"+              expected = StDeclaration () u typeSpec Nothing decls+              typeSpec = TypeSpec () u TypeInteger Nothing+              decls    = AList () u+                [ DeclArray () u (varGen "x") dims (Just (intGen 8)) Nothing ]+              dims     = AList () u+                [ DimensionDeclarator () u Nothing (Just (intGen 2)) ]+          sParser stStr `shouldBe'` expected

@@ -27,54 +27,3 @@         readInteger "1_f"    `shouldBe` Just 1         readInteger "+123"   `shouldBe` Just 123         readInteger "-123"   `shouldBe` Just (-123)--    describe "parseRealLiteral" $ do-      it "parses various well-formed valid real literals" $ do-        prl "1"         `shouldBe` rl "1"    n n-        prl "1."        `shouldBe` rl "1."   n n-        prl ".0"        `shouldBe` rl ".0"   n n-        prl "1e0"       `shouldBe` rl "1"    (jExp expE n 0) n-        prl "1e0_4"     `shouldBe` rl "1"    (jExp expE n 0) (j 4)-        --prl "1e0_k"     `shouldBe` rl "1" _ _-        prl "1.0e0_4"   `shouldBe` rl "1.0"  (jExp expE n 0) (j 4)-        prl "+1.0e0_4"  `shouldBe` rl "+1.0" (jExp expE n 0) (j 4)-        prl "-1.0e0_4"  `shouldBe` rl "-1.0" (jExp expE n 0) (j 4)-        prl "-1.0e+0_4" `shouldBe` rl "-1.0" (jExp expE (j SignPos) 0) (j 4)-        prl "-1.0e-0_4" `shouldBe` rl "-1.0" (jExp expE (j SignNeg) 0) (j 4)-        prl "-1.0d-0_4" `shouldBe` rl "-1.0" (jExp expD (j SignNeg) 0) (j 4)--      -- Literals we gladly parse, but that most Fortran specs consider invalid.-      -- These will prompt an error during type analysis.-      it "parses various well-formed invalid real literals" $ do-        -- only exponent letter e allows kind param-        -- even if you use kind 8 (== what d sets), it should be considered-        -- invalid-        prl "1d0_8"   `shouldBe` rl "1" (jExp expD n 0) (j 8)-        prl "1d0_4"   `shouldBe` rl "1" (jExp expD n 0) (j 4)--      -- parseRealLiteral runtime errors on poorly-formed real literals because-      -- the parser should ensure we only ever receive well-formed ones.-      -- TODO: unable to test these while the parser uses 'error'-      it "fails to parse poorly-formed real literals" $ do-        pending-        {--        -- exponent number can't be empty-        fails $ prl "1e"--        -- exponent number must be an integer-        fails $ prl "1ex"-        fails $ prl "1ex1"-        --fails $ prl "1e0.0"       -- not detected, we take the digits before-                                    -- the decimal point-        -}---      where-        prl = parseRealLiteral-        rl = RealLit-        n = Nothing-        j = Just-        jExp a b c = Just (Exponent a b c)-        expE = ExpLetterE-        expD = ExpLetterD-        -- fails test = return test `shouldThrow` anyException

@@ -11,6 +11,7 @@ import Data.Maybe (catMaybes)  import Language.Fortran.AST as LFA+import Language.Fortran.AST.Boz import Language.Fortran.ParserMonad import Language.Fortran.PrettyPrint @@ -97,6 +98,20 @@         let f = StFlush () u (AList () u [ FSUnit () u (intGen 1), FSIOStat () u (varGen "x")                                          , FSIOMsg () u (varGen "y"), FSErr () u (varGen "z") ])         pprint Fortran2003 f Nothing `shouldBe` "flush (unit=1, iostat=x, iomsg=y, err=z)"++    describe "Value" $ do+      it "prints logical literal with no kind parameter" $ do+        let lit = ValLogical True Nothing+        pprint Fortran77 lit Nothing `shouldBe` ".true."++      it "prints logical literal with kind parameter (>=F90)" $ do+        let lit    = ValLogical False (Just kpExpr)+            kpExpr = intGen 8+        pprint Fortran90 lit Nothing `shouldBe` ".false._8"++      it "prints BOZ constant with prefix" $ do+        let lit = ValBoz $ Boz BozPrefixZ "123abc"+        pprint Fortran90 lit Nothing `shouldBe` "z'123abc'"      describe "Statement" $ do       describe "Declaration" $ do

@@ -546,6 +546,18 @@         <>         BC.pack replS1         <>         BC.pack replS2         <>         BC.replicate 24 'a'+    it "Apply replacement ('!' in a string literal)" $ do+      let+        source =+          "      write(8, *) 'hi! this string is really long, overflowing even'"+                                                                           -- ^ Column 68+        range = SourceRange (SourceLocation 0 68) (SourceLocation 0 68)+        replS = ", variableHello"+        r     = Replacement range replS+        res   = applyReplacements source [r]+      res+        `shouldBe`+          "      write(8, *) 'hi! this string is really long, overflowing even'\n     +, variableHello"     it "Apply replacements (overlapping)" $ do       let source = BC.replicate 30 'a'           range1 = SourceRange (SourceLocation 0 2) (SourceLocation 0 4)

@@ -74,7 +74,7 @@ -- do 10 i = 0, 10 -- 10   continue label10 :: Maybe (Expression ())-label10 = Just (ExpValue () u (ValInteger "10"))+label10 = Just (labelGen 10) example1do :: ProgramFile () example1do = ProgramFile mi77 [ PUMain () u (Just "example1") example1doblocks Nothing ] example1doblocks :: [Block ()]@@ -82,10 +82,13 @@   [ BlStatement () u Nothing (StDo () u Nothing label10 dospec)   , BlStatement () u label10 (StContinue () u) ] dospec :: Maybe (DoSpecification ())-dospec = Just (DoSpecification () u-           (StExpressionAssign () u (ExpValue () u (ValVariable "i"))-                                    (ExpValue () u (ValInteger "0")))-                                    (ExpValue () u (ValInteger "10")) Nothing)+dospec = Just $+  DoSpecification+    ()+    u+    (StExpressionAssign () u (varGen "i") (intGen 0))+    (intGen 10)+    Nothing  expectedExample1do :: ProgramFile () expectedExample1do = ProgramFile mi77 [ PUMain () u (Just "example1") expectedExample1doBlocks Nothing ]@@ -95,7 +98,7 @@      [ ] label10 ]  label20 :: Maybe (Expression ())-label20 = Just (ExpValue () u (ValInteger "20"))+label20 = Just (labelGen 20) -- do 10 i = 0, 10 -- do 10 i = 0, 10 -- 10   continue

@@ -8,6 +8,7 @@ import Data.Generics.Uniplate.Data  import Language.Fortran.AST+import Language.Fortran.AST.RealLit import Language.Fortran.ParserMonad import Language.Fortran.Util.Position @@ -24,11 +25,14 @@ mi90 :: MetaInfo mi90 = MetaInfo { miVersion = Fortran90, miFilename = "<unknown>" } -valTrue :: Expression ()-valTrue = ExpValue () u $ ValLogical ".true."-valFalse :: Expression ()-valFalse = ExpValue () u $ ValLogical ".false."+valTrue, valFalse :: Expression ()+valTrue  = ExpValue () u $ ValLogical True  Nothing+valFalse = ExpValue () u $ ValLogical False Nothing +valTrue', valFalse' :: Expression () -> Expression ()+valTrue'  kp = ExpValue () u $ ValLogical True  (Just kp)+valFalse' kp = ExpValue () u $ ValLogical False (Just kp)+ varGen :: String -> Expression () varGen str = ExpValue () u $ ValVariable str @@ -36,19 +40,19 @@ declVarGen str = DeclVariable () u (varGen str) Nothing Nothing  intGen :: Integer -> Expression ()-intGen i = ExpValue () u $ ValInteger $ show i+intGen i = ExpValue () u $ ValInteger (show i) Nothing  initGen :: [Expression ()] -> Expression () initGen es = ExpInitialisation () u $ fromList () es  realGen :: (Fractional a, Show a) => a -> Expression ()-realGen i = ExpValue () u $ ValReal $ show i+realGen i = ExpValue () u $ ValReal (parseRealLit (show i)) Nothing  strGen :: String -> Expression () strGen str = ExpValue () u $ ValString str  labelGen :: Integer -> Expression ()-labelGen i = ExpValue () u $ ValInteger $ show i+labelGen = intGen  starVal :: Expression () starVal = ExpValue () u ValStar