diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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...] - -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...] + -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. diff --git a/fortran-src.cabal b/fortran-src.cabal --- a/fortran-src.cabal +++ b/fortran-src.cabal @@ -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 @@ 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 diff --git a/src/Language/Fortran/AST.hs b/src/Language/Fortran/AST.hs --- a/src/Language/Fortran/AST.hs +++ b/src/Language/Fortran/AST.hs @@ -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 diff --git a/src/Language/Fortran/AST/Boz.hs b/src/Language/Fortran/AST/Boz.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fortran/AST/Boz.hs @@ -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' diff --git a/src/Language/Fortran/AST/RealLit.hs b/src/Language/Fortran/AST/RealLit.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fortran/AST/RealLit.hs @@ -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] diff --git a/src/Language/Fortran/Analysis/BBlocks.hs b/src/Language/Fortran/Analysis/BBlocks.hs --- a/src/Language/Fortran/Analysis/BBlocks.hs +++ b/src/Language/Fortran/Analysis/BBlocks.hs @@ -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 = "" diff --git a/src/Language/Fortran/Analysis/DataFlow.hs b/src/Language/Fortran/Analysis/DataFlow.hs --- a/src/Language/Fortran/Analysis/DataFlow.hs +++ b/src/Language/Fortran/Analysis/DataFlow.hs @@ -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) diff --git a/src/Language/Fortran/Analysis/Renaming.hs b/src/Language/Fortran/Analysis/Renaming.hs --- a/src/Language/Fortran/Analysis/Renaming.hs +++ b/src/Language/Fortran/Analysis/Renaming.hs @@ -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 diff --git a/src/Language/Fortran/Analysis/SemanticTypes.hs b/src/Language/Fortran/Analysis/SemanticTypes.hs --- a/src/Language/Fortran/Analysis/SemanticTypes.hs +++ b/src/Language/Fortran/Analysis/SemanticTypes.hs @@ -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. diff --git a/src/Language/Fortran/Analysis/Types.hs b/src/Language/Fortran/Analysis/Types.hs --- a/src/Language/Fortran/Analysis/Types.hs +++ b/src/Language/Fortran/Analysis/Types.hs @@ -1,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 diff --git a/src/Language/Fortran/Lexer/FixedForm.x b/src/Language/Fortran/Lexer/FixedForm.x --- a/src/Language/Fortran/Lexer/FixedForm.x +++ b/src/Language/Fortran/Lexer/FixedForm.x @@ -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 @@ @integerConst { addSpanAndMatch TInt } -- can be part (end) of function type declaration @integerConst { typeSCChange >> addSpanAndMatch TInt } - @bozLiteralConst / { legacy77P } { addSpanAndMatch TBozInt } + @bozLiteralConst / { legacy77P } { addSpanAndMatch $ \ss s -> TBozLiteral ss (parseBoz s) } -- String \' / { fortran77P } { strAutomaton '\'' 0 } \" / { legacy77P } { strAutomaton '"' 0 } -- Logicals - (".true."|".false.") { addSpanAndMatch TBool } + ".true." { addSpan (\s -> TBool s True) } + ".false." { addSpan (\s -> TBool s False) } -- Arithmetic operators "+" { 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 diff --git a/src/Language/Fortran/Lexer/FixedForm/Utils.hs b/src/Language/Fortran/Lexer/FixedForm/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fortran/Lexer/FixedForm/Utils.hs @@ -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 diff --git a/src/Language/Fortran/Lexer/FreeForm.x b/src/Language/Fortran/Lexer/FreeForm.x --- a/src/Language/Fortran/Lexer/FreeForm.x +++ b/src/Language/Fortran/Lexer/FreeForm.x @@ -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 @@ "(".*")" / { formatP } { addSpanAndMatch TBlob } -- Literals + "_" { addSpan TUnderscore } <0> @label { toSC 0 >> addSpanAndMatch TIntegerLiteral } - @intLiteralConst { addSpanAndMatch TIntegerLiteral } - @bozLiteralConst { addSpanAndMatch TBozLiteral } + @digitString { addSpanAndMatch TIntegerLiteral } + @bozLiteralConst { addSpanAndMatch $ \ss s -> TBozLiteral ss (parseBoz s) } - @realLiteral { addSpanAndMatch TRealLiteral } - @altRealLiteral / { notPrecedingDotP } { addSpanAndMatch TRealLiteral } + @realLiteral { addSpanAndMatch $ \ss s -> TRealLiteral ss (parseRealLit s) } + @altRealLiteral / { notPrecedingDotP } { addSpanAndMatch $ \ss s -> TRealLiteral ss (parseRealLit s) } @characterLiteralBeg { lexCharacter } - @logicalLiteral { addSpanAndMatch TLogicalLiteral } + ".true." { addSpan (\s -> TLogicalLiteral s True) } + ".false." { addSpan (\s -> TLogicalLiteral s False) } -- Operators ("."$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 diff --git a/src/Language/Fortran/Parser/Fortran2003.y b/src/Language/Fortran/Parser/Fortran2003.y --- a/src/Language/Fortran/Parser/Fortran2003.y +++ b/src/Language/Fortran/Parser/Fortran2003.y @@ -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 } diff --git a/src/Language/Fortran/Parser/Fortran66.y b/src/Language/Fortran/Parser/Fortran66.y --- a/src/Language/Fortran/Parser/Fortran66.y +++ b/src/Language/Fortran/Parser/Fortran66.y @@ -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 diff --git a/src/Language/Fortran/Parser/Fortran77.y b/src/Language/Fortran/Parser/Fortran77.y --- a/src/Language/Fortran/Parser/Fortran77.y +++ b/src/Language/Fortran/Parser/Fortran77.y @@ -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 diff --git a/src/Language/Fortran/Parser/Fortran90.y b/src/Language/Fortran/Parser/Fortran90.y --- a/src/Language/Fortran/Parser/Fortran90.y +++ b/src/Language/Fortran/Parser/Fortran90.y @@ -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 } diff --git a/src/Language/Fortran/Parser/Fortran95.y b/src/Language/Fortran/Parser/Fortran95.y --- a/src/Language/Fortran/Parser/Fortran95.y +++ b/src/Language/Fortran/Parser/Fortran95.y @@ -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 } diff --git a/src/Language/Fortran/Parser/Utils.hs b/src/Language/Fortran/Parser/Utils.hs --- a/src/Language/Fortran/Parser/Utils.hs +++ b/src/Language/Fortran/Parser/Utils.hs @@ -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 diff --git a/src/Language/Fortran/PrettyPrint.hs b/src/Language/Fortran/PrettyPrint.hs --- a/src/Language/Fortran/PrettyPrint.hs +++ b/src/Language/Fortran/PrettyPrint.hs @@ -1,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) diff --git a/src/Language/Fortran/Rewriter/Internal.hs b/src/Language/Fortran/Rewriter/Internal.hs --- a/src/Language/Fortran/Rewriter/Internal.hs +++ b/src/Language/Fortran/Rewriter/Internal.hs @@ -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 diff --git a/src/Language/Fortran/Transformation/Grouping.hs b/src/Language/Fortran/Transformation/Grouping.hs --- a/src/Language/Fortran/Transformation/Grouping.hs +++ b/src/Language/Fortran/Transformation/Grouping.hs @@ -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 diff --git a/test/Language/Fortran/AST/BozSpec.hs b/test/Language/Fortran/AST/BozSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Fortran/AST/BozSpec.hs @@ -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'" diff --git a/test/Language/Fortran/AST/RealLitSpec.hs b/test/Language/Fortran/AST/RealLitSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Fortran/AST/RealLitSpec.hs @@ -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 diff --git a/test/Language/Fortran/Analysis/BBlocksSpec.hs b/test/Language/Fortran/Analysis/BBlocksSpec.hs --- a/test/Language/Fortran/Analysis/BBlocksSpec.hs +++ b/test/Language/Fortran/Analysis/BBlocksSpec.hs @@ -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 diff --git a/test/Language/Fortran/Analysis/DataFlowSpec.hs b/test/Language/Fortran/Analysis/DataFlowSpec.hs --- a/test/Language/Fortran/Analysis/DataFlowSpec.hs +++ b/test/Language/Fortran/Analysis/DataFlowSpec.hs @@ -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) ] diff --git a/test/Language/Fortran/Analysis/RenamingSpec.hs b/test/Language/Fortran/Analysis/RenamingSpec.hs --- a/test/Language/Fortran/Analysis/RenamingSpec.hs +++ b/test/Language/Fortran/Analysis/RenamingSpec.hs @@ -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 diff --git a/test/Language/Fortran/Analysis/SemanticTypesSpec.hs b/test/Language/Fortran/Analysis/SemanticTypesSpec.hs --- a/test/Language/Fortran/Analysis/SemanticTypesSpec.hs +++ b/test/Language/Fortran/Analysis/SemanticTypesSpec.hs @@ -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 diff --git a/test/Language/Fortran/Analysis/TypesSpec.hs b/test/Language/Fortran/Analysis/TypesSpec.hs --- a/test/Language/Fortran/Analysis/TypesSpec.hs +++ b/test/Language/Fortran/Analysis/TypesSpec.hs @@ -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 diff --git a/test/Language/Fortran/Lexer/FixedFormSpec.hs b/test/Language/Fortran/Lexer/FixedFormSpec.hs --- a/test/Language/Fortran/Lexer/FixedFormSpec.hs +++ b/test/Language/Fortran/Lexer/FixedFormSpec.hs @@ -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/" diff --git a/test/Language/Fortran/Lexer/FreeFormSpec.hs b/test/Language/Fortran/Lexer/FreeFormSpec.hs --- a/test/Language/Fortran/Lexer/FreeFormSpec.hs +++ b/test/Language/Fortran/Lexer/FreeFormSpec.hs @@ -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)") $ diff --git a/test/Language/Fortran/Parser/Fortran2003Spec.hs b/test/Language/Fortran/Parser/Fortran2003Spec.hs --- a/test/Language/Fortran/Parser/Fortran2003Spec.hs +++ b/test/Language/Fortran/Parser/Fortran2003Spec.hs @@ -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 diff --git a/test/Language/Fortran/Parser/Fortran66Spec.hs b/test/Language/Fortran/Parser/Fortran66Spec.hs --- a/test/Language/Fortran/Parser/Fortran66Spec.hs +++ b/test/Language/Fortran/Parser/Fortran66Spec.hs @@ -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 diff --git a/test/Language/Fortran/Parser/Fortran77/ParserSpec.hs b/test/Language/Fortran/Parser/Fortran77/ParserSpec.hs --- a/test/Language/Fortran/Parser/Fortran77/ParserSpec.hs +++ b/test/Language/Fortran/Parser/Fortran77/ParserSpec.hs @@ -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 diff --git a/test/Language/Fortran/Parser/Fortran90Spec.hs b/test/Language/Fortran/Parser/Fortran90Spec.hs --- a/test/Language/Fortran/Parser/Fortran90Spec.hs +++ b/test/Language/Fortran/Parser/Fortran90Spec.hs @@ -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 diff --git a/test/Language/Fortran/Parser/Fortran95Spec.hs b/test/Language/Fortran/Parser/Fortran95Spec.hs --- a/test/Language/Fortran/Parser/Fortran95Spec.hs +++ b/test/Language/Fortran/Parser/Fortran95Spec.hs @@ -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 diff --git a/test/Language/Fortran/Parser/FreeFormCommon.hs b/test/Language/Fortran/Parser/FreeFormCommon.hs new file mode 100644 --- /dev/null +++ b/test/Language/Fortran/Parser/FreeFormCommon.hs @@ -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 diff --git a/test/Language/Fortran/Parser/UtilsSpec.hs b/test/Language/Fortran/Parser/UtilsSpec.hs --- a/test/Language/Fortran/Parser/UtilsSpec.hs +++ b/test/Language/Fortran/Parser/UtilsSpec.hs @@ -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 diff --git a/test/Language/Fortran/PrettyPrintSpec.hs b/test/Language/Fortran/PrettyPrintSpec.hs --- a/test/Language/Fortran/PrettyPrintSpec.hs +++ b/test/Language/Fortran/PrettyPrintSpec.hs @@ -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 diff --git a/test/Language/Fortran/Rewriter/InternalSpec.hs b/test/Language/Fortran/Rewriter/InternalSpec.hs --- a/test/Language/Fortran/Rewriter/InternalSpec.hs +++ b/test/Language/Fortran/Rewriter/InternalSpec.hs @@ -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) diff --git a/test/Language/Fortran/Transformation/GroupingSpec.hs b/test/Language/Fortran/Transformation/GroupingSpec.hs --- a/test/Language/Fortran/Transformation/GroupingSpec.hs +++ b/test/Language/Fortran/Transformation/GroupingSpec.hs @@ -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 diff --git a/test/TestUtil.hs b/test/TestUtil.hs --- a/test/TestUtil.hs +++ b/test/TestUtil.hs @@ -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 = "" } -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