fortran-src 0.1.0.6 → 0.2.0.0
raw patch · 23 files changed
+265/−1432 lines, 23 filesdep ~GenericPrettydep ~arraydep ~binaryPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: GenericPretty, array, binary, bytestring, containers, directory, fgl, filepath, hspec, mtl, pretty, text, uniplate
API changes (from Hackage documentation)
- Language.Fortran.Analysis.Renaming: extractNameMap :: Data a => ProgramFile (Analysis a) -> NameMap
- Language.Fortran.Analysis.Renaming: renameAndStrip :: Data a => ProgramFile (Analysis a) -> (NameMap, ProgramFile a)
- Language.Fortran.Analysis.Renaming: type NameMap = Map String String
- Language.Fortran.Analysis.Renaming: underRenaming :: (Data a, Data b) => (ProgramFile (Analysis a) -> b) -> ProgramFile a -> b
- Language.Fortran.Parser.Fortran95Experimental: fortran95Parser :: ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)
- Language.Fortran.Parser.Fortran95Experimental: fortran95ParserWithModFiles :: ModFiles -> ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)
- Language.Fortran.Parser.Fortran95Experimental: statementParser :: LexAction (Statement A0)
- Language.Fortran.ParserMonad: Fortran95 :: FortranVersion
+ Language.Fortran.AST: updateProgramUnitBody :: ProgramUnit a -> [Block a] -> ProgramUnit a
+ Language.Fortran.Analysis: isNamedExpression :: Expression a -> Bool
+ Language.Fortran.Intrinsics: allIntrinsics :: IntrinsicsTable
+ Language.Fortran.Intrinsics: getIntrinsicDefsUses :: String -> IntrinsicsTable -> Maybe ([Int], [Int])
+ Language.Fortran.Intrinsics: instance GHC.Classes.Eq Language.Fortran.Intrinsics.IntrinsicsEntry
+ Language.Fortran.Intrinsics: instance GHC.Classes.Ord Language.Fortran.Intrinsics.IntrinsicsEntry
+ Language.Fortran.Intrinsics: instance GHC.Generics.Generic Language.Fortran.Intrinsics.IntrinsicsEntry
+ Language.Fortran.Intrinsics: instance GHC.Show.Show Language.Fortran.Intrinsics.IntrinsicsEntry
+ Language.Fortran.Intrinsics: isIntrinsic :: String -> IntrinsicsTable -> Bool
- Language.Fortran.Intrinsics: type IntrinsicsTable = Map String IntrinsicType
+ Language.Fortran.Intrinsics: type IntrinsicsTable = Map String IntrinsicsEntry
- Language.Fortran.Util.ModFile: DCFunction :: ProgramUnitName -> DeclContext
+ Language.Fortran.Util.ModFile: DCFunction :: (ProgramUnitName, ProgramUnitName) -> DeclContext
- Language.Fortran.Util.ModFile: DCSubroutine :: ProgramUnitName -> DeclContext
+ Language.Fortran.Util.ModFile: DCSubroutine :: (ProgramUnitName, ProgramUnitName) -> DeclContext
Files
- fortran-src.cabal +39/−42
- src/Language/Fortran/AST.hs +15/−3
- src/Language/Fortran/Analysis.hs +33/−4
- src/Language/Fortran/Analysis/BBlocks.hs +8/−11
- src/Language/Fortran/Analysis/DataFlow.hs +9/−18
- src/Language/Fortran/Analysis/Renaming.hs +5/−38
- src/Language/Fortran/Analysis/Types.hs +3/−4
- src/Language/Fortran/Intrinsics.hs +115/−92
- src/Language/Fortran/Lexer/FixedForm.x +2/−8
- src/Language/Fortran/Lexer/FreeForm.x +1/−5
- src/Language/Fortran/Parser/Any.hs +2/−6
- src/Language/Fortran/Parser/Fortran95Experimental.y +0/−1144
- src/Language/Fortran/Parser/Utils.hs +0/−1
- src/Language/Fortran/ParserMonad.hs +0/−3
- src/Language/Fortran/PrettyPrint.hs +0/−2
- src/Language/Fortran/Transformation/Disambiguation/Function.hs +0/−5
- src/Language/Fortran/Transformation/Disambiguation/Intrinsic.hs +0/−5
- src/Language/Fortran/Transformation/Grouping.hs +0/−1
- src/Language/Fortran/Transformation/TransformMonad.hs +0/−1
- src/Language/Fortran/Transformer.hs +2/−6
- src/Language/Fortran/Util/ModFile.hs +29/−17
- src/Language/Fortran/Util/Position.hs +0/−5
- src/Main.hs +2/−11
fortran-src.cabal view
@@ -2,9 +2,10 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: fortran-src-version: 0.1.0.6+version: 0.2.0.0 synopsis: Parser and anlyses for Fortran standards 66, 77, 90. description: Provides lexing, parsing, and basic analyses of Fortran code covering standards: FORTRAN 66, FORTRAN 77, and Fortran 90. Includes data flow and basic block analysis, a renamer, and type analysis. For example usage, see the 'camfort' project, which uses fortran-src as its front end.+bug-reports: https://github.com/camfort/fortran-src/issues license: Apache-2.0 license-file: LICENSE author: Mistral Contrastin, Matthew Danish, Dominic Orchard, Andrew Rice@@ -23,18 +24,18 @@ hs-source-dirs: src build-depends: base >= 4.6 && < 5,- mtl >= 2.2,- array >= 0.5,- uniplate >= 1.6,- GenericPretty >= 1.2,- pretty >= 1.1,- containers >= 0.5,- text >= 1.2,- bytestring >= 0.10,- binary >= 0.8.3.0,- filepath,- directory >= 1.2,- fgl+ mtl >= 2.2 && < 3,+ array >= 0.5 && < 0.6,+ uniplate >= 1.6 && < 2,+ GenericPretty >= 1.2 && < 2,+ pretty >= 1.1 && < 2,+ containers >= 0.5 && < 0.6,+ text >= 1.2 && < 2,+ bytestring >= 0.10 && < 0.11,+ binary >= 0.8.3.0 && < 0.9,+ filepath >= 1.4 && < 2,+ directory >= 1.2 && < 2,+ fgl >= 5 && < 6 other-modules: Language.Fortran.Analysis Language.Fortran.Analysis.Renaming@@ -50,7 +51,6 @@ Language.Fortran.Parser.Fortran66 Language.Fortran.Parser.Fortran77 Language.Fortran.Parser.Fortran90- Language.Fortran.Parser.Fortran95Experimental Language.Fortran.Parser.Utils Language.Fortran.PrettyPrint Language.Fortran.Transformation.Disambiguation.Function@@ -81,7 +81,6 @@ Language.Fortran.Parser.Fortran66 Language.Fortran.Parser.Fortran77 Language.Fortran.Parser.Fortran90- Language.Fortran.Parser.Fortran95Experimental Language.Fortran.Parser.Utils Language.Fortran.PrettyPrint Language.Fortran.Transformation.Disambiguation.Function@@ -98,18 +97,18 @@ happy >= 1.19 build-depends: base >= 4.6 && < 5,- mtl >= 2.2,- array >= 0.5,- uniplate >= 1.6,- GenericPretty >= 1.2,- pretty >= 1.1,- containers >= 0.5,- text >= 1.2,- bytestring >= 0.10,- binary >= 0.8.3.0,- filepath,- directory >= 1.2,- fgl+ mtl >= 2.2 && < 3,+ array >= 0.5 && < 0.6,+ uniplate >= 1.6 && < 2,+ GenericPretty >= 1.2 && < 2,+ pretty >= 1.1 && < 2,+ containers >= 0.5 && < 0.6,+ text >= 1.2 && < 2,+ bytestring >= 0.10 && < 0.11,+ binary >= 0.8.3.0 && < 0.9,+ filepath >= 1.4 && < 2,+ directory >= 1.2 && < 2,+ fgl >= 5 && < 6 hs-source-dirs: src ghc-options: -fno-warn-tabs default-language: Haskell2010@@ -118,21 +117,19 @@ type: exitcode-stdio-1.0 build-depends: base >= 4.6 && < 5,- hspec >= 2.2,- mtl >= 2.2,- array >= 0.5,- uniplate >= 1.6,- directory >= 1.2,- filepath,- GenericPretty >= 1.2,- pretty >= 1.1,- containers >= 0.5,- text >= 1.2,- bytestring >= 0.10,- binary >= 0.8.3.0,- fgl,- filepath,- directory >= 1.2,+ hspec >= 2.2 && < 3,+ mtl >= 2.2 && < 3,+ array >= 0.5 && < 0.6,+ uniplate >= 1.6 && < 2,+ directory >= 1.2 && < 2,+ filepath >= 1.4 && < 2,+ GenericPretty >= 1.2 && < 2,+ pretty >= 1.1 && < 2,+ containers >= 0.5 && < 0.6,+ text >= 1.2 && < 2,+ bytestring >= 0.10 && < 0.11,+ binary >= 0.8.3.0 && < 0.9,+ fgl >= 5 && < 6, fortran-src hs-source-dirs: test main-is: Spec.hs
src/Language/Fortran/AST.hs view
@@ -9,8 +9,8 @@ module Language.Fortran.AST where import Data.Data-import Data.Typeable-import Data.Generics.Uniplate.Data+import Data.Generics.Uniplate.Data ()+import Data.Typeable () import Data.Binary import GHC.Generics (Generic) import Text.PrettyPrint.GenericPretty@@ -20,7 +20,6 @@ import Language.Fortran.Util.FirstParameter import Language.Fortran.Util.SecondParameter -import Debug.Trace type A0 = () @@ -128,6 +127,19 @@ programUnitBody (PUFunction _ _ _ _ _ _ _ bs _) = bs programUnitBody (PUBlockData _ _ _ bs) = bs programUnitBody (PUComment {}) = []++updateProgramUnitBody :: ProgramUnit a -> [Block a] -> ProgramUnit a+updateProgramUnitBody (PUMain a s n bs pu) bs' =+ PUMain a s n bs' pu+updateProgramUnitBody (PUModule a s n bs pu) bs' =+ PUModule a s n bs' pu+updateProgramUnitBody (PUSubroutine a s f n args bs pu) bs' =+ PUSubroutine a s f n args bs' pu+updateProgramUnitBody (PUFunction a s t f n args res bs pu) bs' =+ PUFunction a s t f n args res bs' pu+updateProgramUnitBody (PUBlockData a s n bs) bs' =+ PUBlockData a s n bs'+updateProgramUnitBody p@(PUComment {}) _ = p programUnitSubprograms :: ProgramUnit a -> Maybe [ProgramUnit a] programUnitSubprograms (PUMain _ _ _ _ s) = s
src/Language/Fortran/Analysis.hs view
@@ -1,9 +1,10 @@-{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, StandaloneDeriving, DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, StandaloneDeriving, DeriveGeneric, TupleSections #-} -- | -- Common data structures and functions supporting analysis of the AST. module Language.Fortran.Analysis- ( initAnalysis, stripAnalysis, Analysis(..), varName, srcName, genVar, puName, puSrcName, blockRhsExprs, rhsExprs+ ( initAnalysis, stripAnalysis, Analysis(..), varName, srcName, isNamedExpression+ , genVar, puName, puSrcName, blockRhsExprs, rhsExprs , ModEnv, NameType(..), IDType(..), ConstructType(..), BaseType(..) , lhsExprs, isLExpr, allVars, analyseAllLhsVars, analyseAllLhsVars1, allLhsVars , blockVarUses, blockVarDefs@@ -13,7 +14,6 @@ import Language.Fortran.Util.Position (SrcSpan) import Data.Generics.Uniplate.Data-import Data.Generics.Uniplate.Operations import Data.Data import Language.Fortran.AST import Data.Graph.Inductive.PatriciaTree (Gr)@@ -23,6 +23,7 @@ import qualified Data.Map.Strict as M import Data.Maybe import Data.Binary+import Language.Fortran.Intrinsics (getIntrinsicDefsUses, allIntrinsics) -------------------------------------------------- @@ -106,6 +107,12 @@ , idType = Nothing , allLhsVarsAnn = [] } +-- | True iff the expression can be used with varName or srcName+isNamedExpression :: Expression a -> Bool+isNamedExpression (ExpValue _ _ (ValVariable _)) = True+isNamedExpression (ExpValue _ _ (ValIntrinsic _)) = True+isNamedExpression _ = False+ -- | Obtain either uniqueName or source name from an ExpValue variable. varName :: Expression (Analysis a) -> String varName (ExpValue (Analysis { uniqueName = Just n }) _ (ValVariable {})) = n@@ -218,6 +225,8 @@ where lhsOfStmt :: Statement (Analysis a) -> [Name] lhsOfStmt (StExpressionAssign _ _ e e') = match' e : onExprs e'+ lhsOfStmt (StCall _ _ f@(ExpValue _ _ (ValIntrinsic _)) _)+ | Just defs <- intrinsicDefs f = defs lhsOfStmt (StCall _ _ _ (Just aexps)) = concatMap (match'' . extractExp) (aStrip aexps) lhsOfStmt s = onExprs s @@ -280,15 +289,35 @@ | ExpSubscript _ _ _ subs <- lhs = allVars rhs ++ allVars e1 ++ maybe [] allVars e2 ++ concatMap allVars (aStrip subs) | otherwise = allVars rhs ++ allVars e1 ++ maybe [] allVars e2 blockVarUses (BlStatement _ _ _ (StDeclaration {})) = []+blockVarUses (BlStatement _ _ _ (StCall _ _ f@(ExpValue _ _ (ValIntrinsic _)) _))+ | Just uses <- intrinsicUses f = uses+blockVarUses (BlStatement _ _ _ (StCall _ _ _ (Just aexps))) = allVars aexps blockVarUses (BlDoWhile _ _ e1 _ e2 _ _) = maybe [] allVars e1 ++ allVars e2 blockVarUses (BlIf _ _ e1 _ e2 _ _) = maybe [] allVars e1 ++ concatMap (maybe [] allVars) e2-blockVarUses b = allVars b+blockVarUses b = allVars b -- | Set of names defined by an AST-block. blockVarDefs :: Data a => Block (Analysis a) -> [Name] blockVarDefs b@(BlStatement _ _ _ st) = allLhsVars b blockVarDefs (BlDo _ _ _ _ _ (Just doSpec) _ _) = allLhsVarsDoSpec doSpec blockVarDefs _ = []++-- form name: n[i]+dummyArg :: Name -> Int -> Name+dummyArg n i = n ++ "[" ++ show i ++ "]"++-- return dummy arg names defined by intrinsic+intrinsicDefs :: Expression (Analysis a) -> Maybe [Name]+intrinsicDefs = fmap fst . intrinsicDefsUses++-- return dummy arg names used by intrinsic+intrinsicUses :: Expression (Analysis a) -> Maybe [Name]+intrinsicUses = fmap snd . intrinsicDefsUses++-- return dummy arg names (defined, used) by intrinsic+intrinsicDefsUses :: Expression (Analysis a) -> Maybe ([Name], [Name])+intrinsicDefsUses f = both (map (dummyArg (varName f))) <$> getIntrinsicDefsUses (srcName f) allIntrinsics+ where both f (x, y) = (f x, f y) -- Local variables: -- mode: haskell
src/Language/Fortran/Analysis/BBlocks.hs view
@@ -8,9 +8,7 @@ where import Data.Generics.Uniplate.Data-import Data.Generics.Uniplate.Operations import Data.Data-import Data.Function hiding ((&)) import Control.Monad import Control.Monad.State.Lazy import Control.Monad.Writer@@ -18,15 +16,12 @@ import Language.Fortran.Analysis import Language.Fortran.AST import Language.Fortran.Util.Position-import qualified Data.IntSet as IS import qualified Data.Map as M import qualified Data.IntMap as IM import Data.Graph.Inductive import Data.Graph.Inductive.PatriciaTree (Gr)-import Data.List (foldl', intercalate)+import Data.List (intercalate) import Data.Maybe-import Language.Fortran.Util.Position (SrcSpan(..), initPosition)-import Debug.Trace -------------------------------------------------- @@ -512,8 +507,11 @@ addToBBlock . analyseAllLhsVars1 $ BlStatement a0 s Nothing (StExpressionAssign a' s' (formal e i) e) (_, dummyCallN) <- closeBBlock - -- create "dummy call" bblock with no parameters in the StCall AST-node.- addToBBlock . analyseAllLhsVars1 $ BlStatement a s Nothing (StCall a' s' (genVar a' s' (varName fn)) Nothing)+ let retV = setName (name 0) $ ExpValue a0 s (ValVariable (name 0))+ let dummyArgs = map (Argument a0 s' Nothing) (retV:map (uncurry formal) (zip exps [1..]))++ -- create "dummy call" bblock with dummy arguments in the StCall AST-node.+ addToBBlock . analyseAllLhsVars1 $ BlStatement a s Nothing (StCall a' s' fn (Just $ fromList a0 dummyArgs)) (_, returnedN) <- closeBBlock -- re-assign the variables using the values of the formal parameters, if possible@@ -525,7 +523,6 @@ else return () tempName <- genTemp (varName fn) let temp = setName tempName $ ExpValue a0 s (ValVariable tempName)- let retV = setName (name 0) $ ExpValue a0 s (ValVariable (name 0)) addToBBlock . analyseAllLhsVars1 $ BlStatement a0 s Nothing (StExpressionAssign a0 s' temp retV) (_, nextN) <- closeBBlock@@ -587,8 +584,8 @@ -- List of Calls and their corresponding SuperNode where they appear. -- Assumption: all StCalls appear by themselves in a bblock. stCalls :: [(SuperNode, String)]- stCalls = [ (getSuperNode n, sub) | (n, [BlStatement _ _ _ (StCall _ _ e Nothing)]) <- namedNodes- , v@(ExpValue _ _ _) <- [e]+ stCalls = [ (getSuperNode n, sub) | (n, [BlStatement _ _ _ (StCall _ _ e _)]) <- namedNodes+ , v@(ExpValue _ _ _) <- [e] , let sub = varName v , Named sub `M.member` entryMap && Named sub `M.member` exitMap ] stCallCtxts :: [([SuperEdge], SuperNode, String, [SuperEdge])]
src/Language/Fortran/Analysis/DataFlow.hs view
@@ -19,16 +19,12 @@ ) where import Data.Generics.Uniplate.Data-import Data.Generics.Uniplate.Operations import GHC.Generics import Data.Data-import Data.Function import Control.Monad.State.Lazy-import Control.Monad.Writer-import Text.PrettyPrint.GenericPretty (pretty, Out)+import Text.PrettyPrint.GenericPretty (Out) import Language.Fortran.Parser.Utils import Language.Fortran.Analysis-import Language.Fortran.Analysis.BBlocks import Language.Fortran.AST import qualified Data.Map as M import qualified Data.IntMap.Lazy as IM@@ -38,8 +34,7 @@ import Data.Graph.Inductive.PatriciaTree (Gr) import Data.Graph.Inductive.Query.BFS (bfen) import Data.Maybe-import Data.List (foldl', foldl1', (\\), union, delete, nub, intersect)-import qualified Debug.Trace as D+import Data.List (foldl', foldl1', (\\), union, intersect) -------------------------------------------------- @@ -299,17 +294,13 @@ -------------------------------------------------- -- | Convert a UD or DU Map into a graph.-mapToGraph :: DynGraph gr => IM.IntMap a -> IM.IntMap IS.IntSet -> gr a ()-mapToGraph bm m = buildGr $ [- ([], i, l, jAdj) | (i, js) <- IM.toList m- , let Just l = IM.lookup i bm- , let jAdj = map ((),) $ IS.toList js- ] ++ [- (iAdj, j, l, []) | (i, js) <- IM.toList m- , j <- IS.toList js- , let Just l = IM.lookup j bm- , let iAdj = [((), i)]- ]+mapToGraph :: DynGraph gr => BlockMap a -> IM.IntMap IS.IntSet -> gr (Block (Analysis a)) ()+mapToGraph bm m = mkGraph nodes edges+ where+ nodes = [ (i, iLabel) | i <- IM.keys m ++ concatMap IS.toList (IM.elems m)+ , let iLabel = fromJustMsg "mapToGraph" (IM.lookup i bm) ]+ edges = [ (i, j, ()) | (i, js) <- IM.toList m+ , j <- IS.toList js ] -- | FlowsGraph : nodes as AST-block (numbered by label), edges -- showing which definitions contribute to which uses.
src/Language/Fortran/Analysis/Renaming.hs view
@@ -8,31 +8,24 @@ -- analysis. module Language.Fortran.Analysis.Renaming- ( analyseRenames, analyseRenamesWithModuleMap, rename, unrename, ModuleMap- -- DEPRECATED:- , extractNameMap, renameAndStrip, underRenaming, NameMap )+ ( analyseRenames, analyseRenamesWithModuleMap, rename, unrename, ModuleMap ) where import Debug.Trace import Language.Fortran.AST hiding (fromList)-import Language.Fortran.Util.Position import Language.Fortran.Intrinsics import Language.Fortran.Analysis-import Language.Fortran.Analysis.Types import Language.Fortran.ParserMonad (FortranVersion(..)) import Prelude hiding (lookup) import Data.Maybe (maybe, fromMaybe) import qualified Data.List as L-import Data.Map (findWithDefault, insert, union, empty, lookup, member, Map, fromList)+import Data.Map (insert, union, empty, lookup, Map, fromList) import qualified Data.Map.Strict as M import Control.Monad.State.Strict-import Control.Monad import Data.Generics.Uniplate.Data-import Data.Generics.Uniplate.Operations import Data.Data-import Data.Tuple -------------------------------------------------- @@ -106,33 +99,6 @@ | Just srcN <- sourceName a = PUSubroutine a s r srcN args b subs fPU pu = pu --- DEPRECATED:---- | DEPRECATED: Create a map of unique name => original name for each variable--- and function in the program.-extractNameMap :: Data a => ProgramFile (Analysis a) -> NameMap-extractNameMap pf = eMap `union` puMap- where- eMap = fromList [ (un, srcName e) | e@(ExpValue (Analysis { uniqueName = Just un }) _ _) <- uniE pf ]- puMap = fromList [ (un, n) | pu <- uniPU pf, Named un <- [puName pu], Named n <- [getName pu], n /= un ]- uniE :: Data a => ProgramFile a -> [Expression a]- uniE = universeBi- uniPU :: Data a => ProgramFile a -> [ProgramUnit a]- uniPU = universeBi---- | DEPRECATED: Perform the rename, stripAnalysis, and extractNameMap functions.-renameAndStrip :: Data a => ProgramFile (Analysis a) -> (NameMap, ProgramFile a)-renameAndStrip pf = fmap stripAnalysis (extractNameMap pf, rename pf)---- | DEPRECATED: Run a function with the program file placed under renaming--- analysis, then undo the renaming in the result of the function.-underRenaming :: (Data a, Data b) => (ProgramFile (Analysis a) -> b) -> ProgramFile a -> b-underRenaming f pf = tryUnrename `descendBi` f (rename pf')- where- renameMap = extractNameMap pf'- pf' = analyseRenames . initAnalysis $ pf- tryUnrename n = n `fromMaybe` lookup n renameMap- -------------------------------------------------- -- Renaming transformations for pieces of the AST. Uses a language of -- monadic combinators defined below.@@ -250,7 +216,7 @@ -- NameMap because it would be possible for the same program object -- to have two different names used by different parts of the -- program).- let uses = takeWhile isUseStatement blocks+ let uses = filter isUseStatement blocks fmap M.unions . forM uses $ \ use -> case use of (BlStatement _ _ _ (StUse _ _ (ExpValue _ _ (ValVariable m)) _ Nothing)) -> do mMap <- gets moduleMap@@ -307,12 +273,13 @@ -- Get a mapping, plus name type, from the combined nested -- environment, if it exists.+-- If not, check if it is an intrinsic name. getFromEnvsWithType :: String -> Renamer (Maybe (String, NameType)) getFromEnvsWithType v = do envs <- getEnvs case lookup v envs of Just (v', nt) -> return $ Just (v', nt)- Nothing -> do+ Nothing -> do itab <- gets intrinsics case getIntrinsicReturnType v itab of Nothing -> return Nothing
src/Language/Fortran/Analysis/Types.hs view
@@ -4,18 +4,16 @@ import Language.Fortran.AST import Prelude hiding (lookup)-import Data.Map (findWithDefault, insert, empty, lookup, Map)+import Data.Map (insert) import qualified Data.Map as M import Data.Maybe (maybeToList) import Control.Monad.State.Strict import Data.Generics.Uniplate.Data-import Data.Generics.Uniplate.Operations import Data.Data import Language.Fortran.Analysis import Language.Fortran.Intrinsics import Language.Fortran.ParserMonad (FortranVersion(..)) -import Debug.Trace -------------------------------------------------- @@ -84,7 +82,7 @@ intrinsicsExp (ExpFunctionCall _ _ nexp _) = intrinsicsHelper nexp intrinsicsExp _ = return () -intrinsicsHelper nexp = do+intrinsicsHelper nexp | isNamedExpression nexp = do itab <- gets intrinsics case getIntrinsicReturnType (srcName nexp) itab of Just itype -> do@@ -92,6 +90,7 @@ recordCType CTIntrinsic n -- recordBaseType _ n -- FIXME: going to skip base types for the moment _ -> return ()+intrinsicsHelper _ = return () programUnit :: Data a => InferFunc (ProgramUnit (Analysis a)) programUnit pu@(PUFunction _ _ mRetType _ _ _ mRetVar blocks _)
src/Language/Fortran/Intrinsics.hs view
@@ -2,125 +2,148 @@ {-# LANGUAGE DeriveGeneric #-} module Language.Fortran.Intrinsics- ( getVersionIntrinsics, getIntrinsicReturnType, getIntrinsicNames, IntrinsicType(..), IntrinsicsTable )+ ( getVersionIntrinsics, getIntrinsicReturnType, getIntrinsicNames, getIntrinsicDefsUses, isIntrinsic+ , IntrinsicType(..), IntrinsicsTable, allIntrinsics ) where import qualified Data.Map.Strict as M import Data.Data-import Data.Typeable-import Data.Generics.Uniplate.Data import Data.List import GHC.Generics (Generic)-import Text.PrettyPrint.GenericPretty import Language.Fortran.ParserMonad (FortranVersion(..)) -import Language.Fortran.Analysis-import Language.Fortran.Util.Position-import Language.Fortran.Util.FirstParameter-import Language.Fortran.Util.SecondParameter -import Debug.Trace- data IntrinsicType = ITReal | ITInteger | ITComplex | ITDouble | ITLogical | ITParam Int deriving (Show, Eq, Ord, Typeable, Generic) -type IntrinsicsTable = M.Map String IntrinsicType+data IntrinsicsEntry = IEntry { iType :: IntrinsicType, iDefsUses :: ([Int], [Int]) }+ deriving (Show, Eq, Ord, Typeable, Generic) +mkIEntry ty du = IEntry ty du++type IntrinsicsTable = M.Map String IntrinsicsEntry++-- Main table of Fortran intrinsics by version+fortranVersionIntrinsics =+ [ (Fortran66, fortran77intrinsics) -- FIXME: find list of original '66 intrinsics+ , (Fortran77, fortran77intrinsics)+ , (Fortran90, fortran90intrinisics) ]+ -- | Obtain set of intrinsics that are most closely aligned with given version. getVersionIntrinsics :: FortranVersion -> IntrinsicsTable getVersionIntrinsics v = snd . last . filter ((<= v) . fst) . sort $ fortranVersionIntrinsics getIntrinsicReturnType :: String -> IntrinsicsTable -> Maybe IntrinsicType-getIntrinsicReturnType = M.lookup+getIntrinsicReturnType i = fmap iType . M.lookup i +getIntrinsicDefsUses :: String -> IntrinsicsTable -> Maybe ([Int], [Int])+getIntrinsicDefsUses i = fmap iDefsUses . M.lookup i+ getIntrinsicNames :: IntrinsicsTable -> [String] getIntrinsicNames = M.keys -fortranVersionIntrinsics =- [ (Fortran66, fortran77intrinsics) -- FIXME: find list of original '66 intrinsics- , (Fortran77, fortran77intrinsics)- , (Fortran90, fortran90intrinisics) ]+isIntrinsic :: String -> IntrinsicsTable -> Bool+isIntrinsic = M.member +allIntrinsics :: IntrinsicsTable+allIntrinsics = M.unions (map snd fortranVersionIntrinsics)++func1 = ([0],[1])+func2 = ([0],[1,2])+func3 = ([0],[1,2,3])+funcN = func2 -- FIXME: implement arbitrary-# parameter functions+ -- | name => (return-unit, parameter-units) fortran77intrinsics :: IntrinsicsTable fortran77intrinsics = M.fromList- [ ("abs" , ITParam 1)- , ("aimag" , ITReal)- , ("aint" , ITReal)- , ("anint" , ITReal)- , ("cmplx" , ITComplex)- , ("conjg" , ITComplex)- , ("dble" , ITDouble)- , ("dim" , ITReal)- , ("dprod" , ITDouble)- , ("int" , ITInteger)- , ("max" , ITParam 1)- , ("min" , ITParam 1)- , ("mod" , ITParam 1)- , ("nint" , ITInteger)- , ("real" , ITReal)- , ("sign" , ITParam 1) ]+ [ ("abs" , mkIEntry (ITParam 1) func1)+ , ("aimag" , mkIEntry (ITReal) func1)+ , ("aint" , mkIEntry (ITReal) func1)+ , ("anint" , mkIEntry (ITReal) func1)+ , ("cmplx" , mkIEntry (ITComplex) func1)+ , ("conjg" , mkIEntry (ITComplex) func1)+ , ("dble" , mkIEntry (ITDouble) func1)+ , ("dim" , mkIEntry (ITReal) func1)+ , ("dprod" , mkIEntry (ITDouble) func1)+ , ("int" , mkIEntry (ITInteger) func1)+ , ("max" , mkIEntry (ITParam 1) funcN)+ , ("min" , mkIEntry (ITParam 1) funcN)+ , ("mod" , mkIEntry (ITParam 1) func2)+ , ("nint" , mkIEntry (ITInteger) func1)+ , ("real" , mkIEntry (ITReal) func1)+ , ("sign" , mkIEntry (ITParam 1) func2)+ ] fortran90intrinisics :: IntrinsicsTable fortran90intrinisics = fortran77intrinsics `M.union` M.fromList- [ ("iabs" , ITInteger)- , ("dabs" , ITDouble)- , ("cabs" , ITComplex)- , ("dint" , ITDouble)- , ("dnint" , ITDouble)- , ("idnint" , ITInteger)- , ("ifix" , ITInteger)- , ("idint" , ITInteger)- , ("min0" , ITInteger)- , ("amin1" , ITReal)- , ("dmin1" , ITDouble)- , ("amin0" , ITReal)- , ("min1" , ITInteger)- , ("amod" , ITReal)- , ("dmod" , ITDouble)- , ("float" , ITReal)- , ("sngl" , ITReal)- , ("isign" , ITInteger)- , ("dsign" , ITDouble)- , ("present" , ITLogical)- , ("sqrt" , ITParam 1)- , ("dsqrt" , ITDouble)- , ("csqrt" , ITComplex)- , ("exp" , ITParam 1)- , ("dexp" , ITDouble)- , ("cexp" , ITComplex)- , ("log" , ITParam 1)- , ("alog" , ITReal)- , ("dlog" , ITDouble)- , ("clog" , ITComplex)- , ("log10" , ITParam 1)- , ("alog10" , ITReal)- , ("dlog10" , ITDouble)- , ("idim" , ITInteger)- , ("ddim" , ITDouble)- , ("sin" , ITReal)- , ("dsin" , ITDouble)- , ("csin" , ITComplex)- , ("cos" , ITReal)- , ("dcos" , ITDouble)- , ("ccos" , ITComplex)- , ("tan" , ITReal)- , ("dtan" , ITDouble)- , ("asin" , ITReal)- , ("dasin" , ITDouble)- , ("acos" , ITReal)- , ("dacos" , ITDouble)- , ("atan" , ITReal)- , ("datan" , ITDouble)- , ("atan2" , ITReal)- , ("datan2" , ITDouble)- , ("sinh" , ITReal)- , ("dsinh" , ITDouble)- , ("cosh" , ITReal)- , ("dcosh" , ITDouble)- , ("tanh" , ITReal)- , ("dtanh" , ITDouble)- , ("modulo" , ITParam 1)- , ("ceiling" , ITParam 1)- , ("floor" , ITParam 1)+ [ ("iabs" , mkIEntry (ITInteger) func1)+ , ("dabs" , mkIEntry (ITDouble) func1)+ , ("cabs" , mkIEntry (ITComplex) func1)+ , ("dint" , mkIEntry (ITDouble) func1)+ , ("dnint" , mkIEntry (ITDouble) func1)+ , ("idnint" , mkIEntry (ITInteger) func1)+ , ("ifix" , mkIEntry (ITInteger) func1)+ , ("idint" , mkIEntry (ITInteger) func1)+ , ("min0" , mkIEntry (ITInteger) funcN)+ , ("amin1" , mkIEntry (ITReal) funcN)+ , ("dmin1" , mkIEntry (ITDouble) funcN)+ , ("amin0" , mkIEntry (ITReal) funcN)+ , ("min1" , mkIEntry (ITInteger) funcN)+ , ("amod" , mkIEntry (ITReal) func2)+ , ("dmod" , mkIEntry (ITDouble) func2)+ , ("float" , mkIEntry (ITReal) func1)+ , ("sngl" , mkIEntry (ITReal) func1)+ , ("isign" , mkIEntry (ITInteger) func2)+ , ("dsign" , mkIEntry (ITDouble) func2)+ , ("present" , mkIEntry (ITLogical) func1)+ , ("sqrt" , mkIEntry (ITParam 1) func1)+ , ("dsqrt" , mkIEntry (ITDouble) func1)+ , ("csqrt" , mkIEntry (ITComplex) func1)+ , ("exp" , mkIEntry (ITParam 1) func1)+ , ("dexp" , mkIEntry (ITDouble) func1)+ , ("cexp" , mkIEntry (ITComplex) func1)+ , ("log" , mkIEntry (ITParam 1) func1)+ , ("alog" , mkIEntry (ITReal) func1)+ , ("dlog" , mkIEntry (ITDouble) func1)+ , ("clog" , mkIEntry (ITComplex) func1)+ , ("log10" , mkIEntry (ITParam 1) func1)+ , ("alog10" , mkIEntry (ITReal) func1)+ , ("dlog10" , mkIEntry (ITDouble) func1)+ , ("idim" , mkIEntry (ITInteger) func2)+ , ("ddim" , mkIEntry (ITDouble) func2)+ , ("sin" , mkIEntry (ITReal) func1)+ , ("dsin" , mkIEntry (ITDouble) func1)+ , ("csin" , mkIEntry (ITComplex) func1)+ , ("cos" , mkIEntry (ITReal) func1)+ , ("dcos" , mkIEntry (ITDouble) func1)+ , ("ccos" , mkIEntry (ITComplex) func1)+ , ("tan" , mkIEntry (ITReal) func1)+ , ("dtan" , mkIEntry (ITDouble) func1)+ , ("asin" , mkIEntry (ITReal) func1)+ , ("dasin" , mkIEntry (ITDouble) func1)+ , ("acos" , mkIEntry (ITReal) func1)+ , ("dacos" , mkIEntry (ITDouble) func1)+ , ("atan" , mkIEntry (ITReal) func1)+ , ("datan" , mkIEntry (ITDouble) func1)+ , ("atan2" , mkIEntry (ITReal) func2)+ , ("datan2" , mkIEntry (ITDouble) func2)+ , ("sinh" , mkIEntry (ITReal) func1)+ , ("dsinh" , mkIEntry (ITDouble) func1)+ , ("cosh" , mkIEntry (ITReal) func1)+ , ("dcosh" , mkIEntry (ITDouble) func1)+ , ("tanh" , mkIEntry (ITReal) func1)+ , ("dtanh" , mkIEntry (ITDouble) func1)+ , ("modulo" , mkIEntry (ITParam 1) func2)+ , ("ceiling" , mkIEntry (ITParam 1) func1)+ , ("floor" , mkIEntry (ITParam 1) func1)+ , ("iand" , mkIEntry (ITInteger) func2)+ , ("ior" , mkIEntry (ITInteger) func2)+ , ("ieor" , mkIEntry (ITInteger) func2)+ , ("iany" , mkIEntry (ITInteger) func2)+ , ("ibclr" , mkIEntry (ITInteger) func2)+ , ("ibits" , mkIEntry (ITInteger) func3)+ , ("ibset" , mkIEntry (ITInteger) func2)+ , ("ishftc" , mkIEntry (ITInteger) func3)+ , ("btest" , mkIEntry (ITInteger) func2)+ , ("not" , mkIEntry (ITInteger) func1) ]
src/Language/Fortran/Lexer/FixedForm.x view
@@ -10,27 +10,21 @@ module Language.Fortran.Lexer.FixedForm where import Data.Word (Word8)-import Data.Char (toLower, isDigit, ord)-import Data.List (isPrefixOf, isSuffixOf, any)+import Data.Char (toLower, ord)+import Data.List (isPrefixOf, any) import Data.Maybe (fromJust, isNothing) import Data.Data-import Data.Typeable import qualified Data.Bits import qualified Data.ByteString.Char8 as B -import Control.Exception import Control.Monad.State-import Control.Monad (liftM2) -import GHC.Exts import GHC.Generics import Language.Fortran.ParserMonad import Language.Fortran.Util.FirstParameter import Language.Fortran.Util.Position--import Debug.Trace }
src/Language/Fortran/Lexer/FreeForm.x view
@@ -11,24 +11,20 @@ module Language.Fortran.Lexer.FreeForm where import Data.Data-import Data.Typeable-import Data.Maybe (isJust, isNothing, fromJust, fromMaybe)+import Data.Maybe (fromMaybe) import Data.Char (toLower) import Data.Word (Word8) import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Unsafe as BU import Control.Monad (join) import Control.Monad.State (get) import GHC.Generics-import GHC.Base (unsafeChr) import Language.Fortran.ParserMonad import Language.Fortran.Util.Position import Language.Fortran.Util.FirstParameter -import Debug.Trace }
src/Language/Fortran/Parser/Any.hs view
@@ -8,7 +8,6 @@ import Language.Fortran.Parser.Fortran77 ( fortran77Parser, fortran77ParserWithModFiles , extended77Parser, extended77ParserWithModFiles ) import Language.Fortran.Parser.Fortran90 ( fortran90Parser, fortran90ParserWithModFiles )-import Language.Fortran.Parser.Fortran95Experimental (fortran95Parser, fortran95ParserWithModFiles ) import qualified Data.ByteString.Char8 as B import Data.Char (toLower)@@ -21,7 +20,6 @@ | isExtensionOf ".fpp" = Fortran77 | isExtensionOf ".ftn" = Fortran77 | isExtensionOf ".f90" = Fortran90- | isExtensionOf ".f95" = Fortran95 | isExtensionOf ".f03" = Fortran2003 | isExtensionOf ".f2003" = Fortran2003 | isExtensionOf ".f08" = Fortran2008@@ -36,8 +34,7 @@ [ (Fortran66, fromParseResult `after` fortran66Parser) , (Fortran77, fromParseResult `after` fortran77Parser) , (Fortran77Extended, fromParseResult `after` extended77Parser)- , (Fortran90, fromParseResult `after` fortran90Parser)- , (Fortran95, fromParseResult `after` fortran95Parser) ]+ , (Fortran90, fromParseResult `after` fortran90Parser) ] type ParserWithModFiles = ModFiles -> B.ByteString -> String -> Either ParseErrorSimple (ProgramFile A0) parserWithModFilesVersions :: [(FortranVersion, ParserWithModFiles)]@@ -45,8 +42,7 @@ [ (Fortran66, \m s -> fromParseResult . fortran66ParserWithModFiles m s) , (Fortran77, \m s -> fromParseResult . fortran77ParserWithModFiles m s) , (Fortran77Extended, \m s -> fromParseResult . extended77ParserWithModFiles m s)- , (Fortran90, \m s -> fromParseResult . fortran90ParserWithModFiles m s)- , (Fortran95, \m s -> fromParseResult . fortran95ParserWithModFiles m s) ]+ , (Fortran90, \m s -> fromParseResult . fortran90ParserWithModFiles m s) ] after g f x = g . (f x)
− src/Language/Fortran/Parser/Fortran95Experimental.y
@@ -1,1144 +0,0 @@--- -*- Mode: Haskell -*--{-module Language.Fortran.Parser.Fortran95Experimental ( statementParser- , fortran95Parser- , fortran95ParserWithModFiles- ) where--import Prelude hiding (EQ,LT,GT) -- Same constructors exist in the AST-import Control.Monad.State (get)-import Data.Maybe (fromMaybe)-import qualified Data.ByteString.Char8 as B--import Control.Monad.State-#ifdef DEBUG-import Data.Data (toConstr)-#endif--import Language.Fortran.Util.Position-import Language.Fortran.Util.ModFile-import Language.Fortran.ParserMonad-import Language.Fortran.Lexer.FreeForm-import Language.Fortran.AST-import Language.Fortran.Transformer--import Debug.Trace--}--%name programParser PROGRAM-%name statementParser STATEMENT-%monad { LexAction }-%lexer { lexer } { TEOF _ }-%tokentype { Token }-%error { parseError }--%token- id { TId _ _ }- comment { TComment _ _ }- string { TString _ _ }- int { TIntegerLiteral _ _ }- float { TRealLiteral _ _ }- boz { TBozLiteral _ _ }- ',' { TComma _ }- ',2' { TComma2 _ }- ';' { TSemiColon _ }- ':' { TColon _ }- '::' { TDoubleColon _ }- '=' { TOpAssign _ }- '=>' { TArrow _ }- '%' { TPercent _ }- '(' { TLeftPar _ }- '(2' { TLeftPar2 _ }- ')' { TRightPar _ }- '(/' { TLeftInitPar _ }- '/)' { TRightInitPar _ }- opCustom { TOpCustom _ _ }- '**' { TOpExp _ }- '+' { TOpPlus _ }- '-' { TOpMinus _ }- '*' { TStar _ }- '/' { TOpDivision _ }- slash { TSlash _ }- or { TOpOr _ }- and { TOpAnd _ }- not { TOpNot _ }- eqv { TOpEquivalent _ }- neqv { TOpNotEquivalent _ }- '<' { TOpLT _ }- '<=' { TOpLE _ }- '==' { TOpEQ _ }- '!=' { TOpNE _ }- '>' { TOpGT _ }- '>=' { TOpGE _ }- bool { TLogicalLiteral _ _ }- program { TProgram _ }- endProgram { TEndProgram _ }- function { TFunction _ }- endFunction { TEndFunction _ }- result { TResult _ }- recursive { TRecursive _ }- subroutine { TSubroutine _ }- endSubroutine { TEndSubroutine _ }- blockData { TBlockData _ }- endBlockData { TEndBlockData _ }- module { TModule _ }- endModule { TEndModule _ }- contains { TContains _ }- use { TUse _ }- only { TOnly _ }- interface { TInterface _ }- endInterface { TEndInterface _ }- moduleProcedure { TModuleProcedure _ }- assignment { TAssignment _ }- operator { TOperator _ }- call { TCall _ }- return { TReturn _ }- entry { TEntry _ }- include { TInclude _ }- public { TPublic _ }- private { TPrivate _ }- parameter { TParameter _ }- allocatable { TAllocatable _ }- dimension { TDimension _ }- external { TExternal _ }- intent { TIntent _ }- intrinsic { TIntrinsic _ }- optional { TOptional _ }- pointer { TPointer _ }- save { TSave _ }- target { TTarget _ }- in { TIn _ }- out { TOut _ }- inout { TInOut _ }- data { TData _ }- namelist { TNamelist _ }- implicit { TImplicit _ }- equivalence { TEquivalence _ }- common { TCommon _ }- allocate { TAllocate _ }- deallocate { TDeallocate _ }- nullify { TNullify _ }- none { TNone _ }- goto { TGoto _ }- assign { TAssign _ }- to { TTo _ }- continue { TContinue _ }- stop { TStop _ }- pause { TPause _ }- do { TDo _ }- enddo { TEndDo _ }- while { TWhile _ }- if { TIf _ }- then { TThen _ }- else { TElse _ }- elsif { TElsif _ }- endif { TEndIf _ }- case { TCase _ }- selectcase { TSelectCase _ }- endselect { TEndSelect _ }- default { TDefault _ }- cycle { TCycle _ }- exit { TExit _ }- where { TWhere _ }- elsewhere { TElsewhere _ }- endwhere { TEndWhere _ }- type { TType _ }- endType { TEndType _ }- sequence { TSequence _ }- kind { TKind _ }- len { TLen _ }- integer { TInteger _ }- real { TReal _ }- doublePrecision { TDoublePrecision _ }- logical { TLogical _ }- character { TCharacter _ }- complex { TComplex _ }- open { TOpen _ }- close { TClose _ }- read { TRead _ }- write { TWrite _ }- print { TPrint _ }- backspace { TBackspace _ }- rewind { TRewind _ }- inquire { TInquire _ }- endfile { TEndfile _ }- format { TFormat _ }- blob { TBlob _ _ }- end { TEnd _ }- newline { TNewline _ }- forall { TForall _ }- endforall { TEndForall _ }--- Precedence of operators---- Level 6-%left opCustom---- Level 5-%left eqv neqv-%left or-%left and-%right not---- Level 4-%nonassoc '==' '!=' '>' '<' '>=' '<='-%nonassoc RELATIONAL---- Level 3-%left CONCAT---- Level 2-%left '+' '-'-%left '*' '/'-%right SIGN-%right '**'---- Level 1-%right DEFINED_UNARY---- Level 0-%left '%'--%%---- This rule is to ignore leading whitespace-PROGRAM :: { ProgramFile A0 }-: NEWLINE PROGRAM_INNER { $2 }-| PROGRAM_INNER { $1 }--PROGRAM_INNER :: { ProgramFile A0 }-: PROGRAM_UNITS { ProgramFile (MetaInfo { miVersion = Fortran95, miFilename = "" }) (reverse $1) }--PROGRAM_UNITS :: { [ ProgramUnit A0 ] }-: PROGRAM_UNITS PROGRAM_UNIT MAYBE_NEWLINE { $2 : $1 }-| PROGRAM_UNIT MAYBE_NEWLINE { [ $1 ] }--PROGRAM_UNIT :: { ProgramUnit A0 }-: program NAME NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS PROGRAM_END- {% do { unitNameCheck $6 $2;- return $ PUMain () (getTransSpan $1 $6) (Just $2) (reverse $4) $5 } }-| module NAME NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS MODULE_END- {% do { unitNameCheck $6 $2;- return $ PUModule () (getTransSpan $1 $6) $2 (reverse $4) $5 } }-| blockData NEWLINE BLOCKS BLOCK_DATA_END- { PUBlockData () (getTransSpan $1 $4) Nothing (reverse $3) }-| blockData NAME NEWLINE BLOCKS BLOCK_DATA_END- {% do { unitNameCheck $5 $2;- return $ PUBlockData () (getTransSpan $1 $5) (Just $2) (reverse $4) } }-| SUBPROGRAM_UNIT { $1 }--MAYBE_SUBPROGRAM_UNITS :: { Maybe [ ProgramUnit A0 ] }-: contains NEWLINE SUBPROGRAM_UNITS { Just $ reverse $3 }-| {- Empty -} { Nothing }--SUBPROGRAM_UNITS :: { [ ProgramUnit A0 ] }-: SUBPROGRAM_UNITS SUBPROGRAM_UNIT NEWLINE { $2 : $1 }-| {- EMPTY -} { [ ] }--SUBPROGRAM_UNIT :: { ProgramUnit A0 }-: TYPE_SPEC function NAME MAYBE_ARGUMENTS MAYBE_COMMENT RESULT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END- {% do { unitNameCheck $10 $3;- return $ PUFunction () (getTransSpan $1 $10) (Just $1) False $3 $4 $6 (reverse $8) $9 } }-| TYPE_SPEC recursive function NAME MAYBE_ARGUMENTS MAYBE_COMMENT RESULT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END- {% do { unitNameCheck $11 $4;- return $ PUFunction () (getTransSpan $1 $11) (Just $1) True $4 $5 $7 (reverse $9) $10 } }-| recursive TYPE_SPEC function NAME MAYBE_ARGUMENTS RESULT MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END- {% do { unitNameCheck $11 $4;- return $ PUFunction () (getTransSpan $1 $11) (Just $2) True $4 $5 $6 (reverse $9) $10 } }-| function NAME MAYBE_ARGUMENTS RESULT MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS FUNCTION_END- {% do { unitNameCheck $9 $2;- return $ PUFunction () (getTransSpan $1 $9) Nothing False $2 $3 $4 (reverse $7) $8 } }-| subroutine NAME MAYBE_ARGUMENTS MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS SUBROUTINE_END- {% do { unitNameCheck $8 $2;- return $ PUSubroutine () (getTransSpan $1 $8) False $2 $3 (reverse $6) $7 } }-| recursive subroutine NAME MAYBE_ARGUMENTS MAYBE_COMMENT NEWLINE BLOCKS MAYBE_SUBPROGRAM_UNITS SUBROUTINE_END- {% do { unitNameCheck $9 $3;- return $ PUSubroutine () (getTransSpan $1 $9) True $3 $4 (reverse $7) $8 } }-| comment { let (TComment s c) = $1 in PUComment () s (Comment c) }--MAYBE_ARGUMENTS :: { Maybe (AList Expression A0) }-: '(' MAYBE_VARIABLES ')' { $2 }-| {- Nothing -} { Nothing }--RESULT :: { Maybe (Expression a) }-: result '(' VARIABLE ')' { Just $3 }-| {- EMPTY -} { Nothing }--PROGRAM_END :: { Token }-: end { $1 } | endProgram { $1 } | endProgram id { $2 }-MODULE_END :: { Token }-: end { $1 } | endModule { $1 } | endModule id { $2 }-FUNCTION_END :: { Token }-: end { $1 } | endFunction { $1 } | endFunction id { $2 }-SUBROUTINE_END :: { Token }-: end { $1 } | endSubroutine { $1 } | endSubroutine id { $2 }-BLOCK_DATA_END :: { Token }-: end { $1 } | endBlockData { $1 } | endBlockData id { $2 }--NAME :: { Name } : id { let (TId _ name) = $1 in name }--BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] }--BLOCK :: { Block A0 }-: INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE- { BlStatement () (getTransSpan $1 $2) (Just $1) $2 }-| STATEMENT MAYBE_COMMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 }-| interface MAYBE_EXPRESSION NEWLINE SUBPROGRAM_UNITS2 MODULE_PROCEDURES endInterface NEWLINE- { BlInterface () (getTransSpan $1 $7) $2 $4 $5 }-| interface MAYBE_EXPRESSION NEWLINE MODULE_PROCEDURES endInterface NEWLINE- { BlInterface () (getTransSpan $1 $6) $2 [ ] $4 }-| COMMENT_BLOCK { $1 }--MAYBE_EXPRESSION :: { Maybe (Expression A0) }-: EXPRESSION { Just $1 }-| {- EMPTY -} { Nothing }--MAYBE_COMMENT :: { Maybe Token }-: comment { Just $1 }-| {- EMPTY -} { Nothing }--SUBPROGRAM_UNITS2 :: { [ ProgramUnit A0 ] }-: SUBPROGRAM_UNITS SUBPROGRAM_UNIT NEWLINE { $2 : $1 }--MODULE_PROCEDURES :: { [ Block A0 ] }-: MODULE_PROCEDURES MODULE_PROCEDURE { $2 : $1 }-| { [ ] }--MODULE_PROCEDURE :: { Block A0 }-: moduleProcedure VARIABLES NEWLINE- { let { al = fromReverseList $2;- st = StModuleProcedure () (getTransSpan $1 al) (fromReverseList $2) }- in BlStatement () (getTransSpan $1 $3) Nothing st }--COMMENT_BLOCK :: { Block A0 }-: comment NEWLINE { let (TComment s c) = $1 in BlComment () s (Comment c) }--MAYBE_NEWLINE :: { Maybe Token } : NEWLINE { Just $1 } | {- EMPTY -} { Nothing }--NEWLINE :: { Token }-: NEWLINE newline { $1 }-| NEWLINE ';' { $1 }-| newline { $1 }-| ';' { $1 }--STATEMENT :: { Statement A0 }-: NONEXECUTABLE_STATEMENT { $1 }-| EXECUTABLE_STATEMENT { $1 }--EXPRESSION_ASSIGNMENT_STATEMENT :: { Statement A0 }-: DATA_REF '=' EXPRESSION { StExpressionAssign () (getTransSpan $1 $3) $1 $3 }--NONEXECUTABLE_STATEMENT :: { Statement A0 }-: DECLARATION_STATEMENT { $1 }-| intent '(' INTENT_CHOICE ')' MAYBE_DCOLON EXPRESSION_LIST- { let expAList = fromReverseList $6- in StIntent () (getTransSpan $1 expAList) $3 expAList }-| optional MAYBE_DCOLON EXPRESSION_LIST- { let expAList = fromReverseList $3- in StOptional () (getTransSpan $1 expAList) expAList }-| public MAYBE_DCOLON EXPRESSION_LIST- { let expAList = fromReverseList $3- in StPublic () (getTransSpan $1 expAList) (Just expAList) }-| public { StPublic () (getSpan $1) Nothing }-| private MAYBE_DCOLON EXPRESSION_LIST- { let expAList = fromReverseList $3- in StPrivate () (getTransSpan $1 expAList) (Just expAList) }-| private { StPrivate () (getSpan $1) Nothing }-| save MAYBE_DCOLON SAVE_ARGS- { let saveAList = (fromReverseList $3)- in StSave () (getTransSpan $1 saveAList) (Just saveAList) }-| save { StSave () (getSpan $1) Nothing }-| dimension MAYBE_DCOLON DECLARATOR_LIST- { let declAList = fromReverseList $3- in StDimension () (getTransSpan $1 declAList) declAList }-| allocatable MAYBE_DCOLON DECLARATOR_LIST- { let declAList = fromReverseList $3- in StAllocatable () (getTransSpan $1 declAList) declAList }-| pointer MAYBE_DCOLON DECLARATOR_LIST- { let declAList = fromReverseList $3- in StPointer () (getTransSpan $1 declAList) declAList }-| target MAYBE_DCOLON DECLARATOR_LIST- { let declAList = fromReverseList $3- in StTarget () (getTransSpan $1 declAList) declAList }-| data cDATA DATA_GROUPS cPOP- { let dataAList = fromReverseList $3- in StData () (getTransSpan $1 dataAList) dataAList }-| parameter '(' PARAMETER_ASSIGNMENTS ')'- { let declAList = fromReverseList $3- in StParameter () (getTransSpan $1 $4) declAList }-| implicit none { StImplicit () (getTransSpan $1 $2) Nothing }-| implicit cIMPLICIT IMP_LISTS cPOP- { let impAList = fromReverseList $3- in StImplicit () (getTransSpan $1 impAList) $ Just $ impAList }-| namelist cNAMELIST NAMELISTS cPOP- { let nameALists = fromReverseList $3- in StNamelist () (getTransSpan $1 nameALists) nameALists }-| equivalence EQUIVALENCE_GROUPS- { let eqALists = fromReverseList $2- in StEquivalence () (getTransSpan $1 eqALists) eqALists }-| common cCOMMON COMMON_GROUPS cPOP- { let commonAList = fromReverseList $3- in StCommon () (getTransSpan $1 commonAList) commonAList }-| external VARIABLES- { let alist = fromReverseList $2- in StExternal () (getTransSpan $1 alist) alist }-| intrinsic VARIABLES- { let alist = fromReverseList $2- in StIntrinsic () (getTransSpan $1 alist) alist }-| use VARIABLE { StUse () (getTransSpan $1 $2) $2 Permissive Nothing }-| use VARIABLE ',' RENAME_LIST- { let alist = fromReverseList $4- in StUse () (getTransSpan $1 alist) $2 Permissive (Just alist) }-| use VARIABLE ',' only ':' RENAME_LIST- { let alist = fromReverseList $6- in StUse () (getTransSpan $1 alist) $2 Exclusive (Just alist) }-| entry VARIABLE RESULT- { StEntry () (getTransSpan $1 $ maybe (getSpan $2) getSpan $3) $2 Nothing $3 }-| entry VARIABLE '(' ')' RESULT- { StEntry () (getTransSpan $1 $ maybe (getSpan $4) getSpan $5) $2 Nothing $5 }-| entry VARIABLE '(' VARIABLES ')' RESULT- { StEntry () (getTransSpan $1 $ maybe (getSpan $5) getSpan $6) $2 (Just $ fromReverseList $4) $6 }-| sequence { StSequence () (getSpan $1) }-| type ATTRIBUTE_LIST '::' id- { let { TId span id = $4;- alist = if null $2 then Nothing else (Just . fromReverseList) $2 }- in StType () (getTransSpan $1 span) alist id }-| type id- { let TId span id = $2 in StType () (getTransSpan $1 span) Nothing id }-| endType { StEndType () (getSpan $1) Nothing }-| endType id- { let TId span id = $2 in StEndType () (getTransSpan $1 span) (Just id) }-| include STRING { StInclude () (getTransSpan $1 $2) $2 }--- Following is a fake node to make arbitrary FORMAT statements parsable.--- Must be fixed in the future. TODO-| format blob- { let TBlob s blob = $2 in StFormatBogus () (getTransSpan $1 s) blob }--EXECUTABLE_STATEMENT :: { Statement A0 }-: allocate '(' DATA_REFS ')'- { StAllocate () (getTransSpan $1 $4) (fromReverseList $3) Nothing }-| allocate '(' DATA_REFS ',' CILIST_PAIR ')'- { StAllocate () (getTransSpan $1 $6) (fromReverseList $3) (Just $5) }-| nullify '(' DATA_REFS ')'- { StNullify () (getTransSpan $1 $4) (fromReverseList $3) }-| deallocate '(' DATA_REFS ')'- { StDeallocate () (getTransSpan $1 $4) (fromReverseList $3) Nothing }-| deallocate '(' DATA_REFS ',' CILIST_PAIR ')'- { StDeallocate () (getTransSpan $1 $6) (fromReverseList $3) (Just $5) }-| EXPRESSION_ASSIGNMENT_STATEMENT { $1 }-| POINTER_ASSIGNMENT_STMT { $1 }-| where '(' EXPRESSION ')' EXPRESSION_ASSIGNMENT_STATEMENT- { StWhere () (getTransSpan $1 $5) $3 $5 }-| where '(' EXPRESSION ')' { StWhereConstruct () (getTransSpan $1 $4) $3 }-| elsewhere { StElsewhere () (getSpan $1) }-| endwhere { StEndWhere () (getSpan $1) }-| if '(' EXPRESSION ')' INTEGER_LITERAL ',' INTEGER_LITERAL ',' INTEGER_LITERAL- { StIfArithmetic () (getTransSpan $1 $9) $3 $5 $7 $9 }-| if '(' EXPRESSION ')' then { StIfThen () (getTransSpan $1 $5) Nothing $3 }-| id ':' if '(' EXPRESSION ')' then- { let TId s id = $1 in StIfThen () (getTransSpan s $7) (Just id) $5 }-| elsif '(' EXPRESSION ')' then { StElsif () (getTransSpan $1 $5) Nothing $3 }-| elsif '(' EXPRESSION ')' then id- { let TId s id = $6 in StElsif () (getTransSpan $1 s) (Just id) $3 }-| else { StElse () (getSpan $1) Nothing }-| else id { let TId s id = $2 in StElse () (getTransSpan $1 s) (Just id) }-| endif { StEndif () (getSpan $1) Nothing }-| endif id { let TId s id = $2 in StEndif () (getTransSpan $1 s) (Just id) }-| do { StDo () (getSpan $1) Nothing Nothing Nothing }-| id ':' do- { let TId s id = $1- in StDo () (getTransSpan s $3) (Just id) Nothing Nothing }-| do INTEGER_LITERAL MAYBE_COMMA DO_SPECIFICATION- { StDo () (getTransSpan $1 $4) Nothing (Just $2) (Just $4) }-| do DO_SPECIFICATION { StDo () (getTransSpan $1 $2) Nothing Nothing (Just $2) }-| id ':' do DO_SPECIFICATION- { let TId s id = $1- in StDo () (getTransSpan s $4) (Just id) Nothing (Just $4) }-| do INTEGER_LITERAL MAYBE_COMMA while '(' EXPRESSION ')'- { StDoWhile () (getTransSpan $1 $7) Nothing (Just $2) $6 }-| do while '(' EXPRESSION ')'- { StDoWhile () (getTransSpan $1 $5) Nothing Nothing $4 }-| id ':' do while '(' EXPRESSION ')'- { let TId s id = $1- in StDoWhile () (getTransSpan s $7) (Just id) Nothing $6 }-| enddo { StEnddo () (getSpan $1) Nothing }-| enddo id- { let TId s id = $2 in StEnddo () (getTransSpan $1 s) (Just id) }-| cycle { StCycle () (getSpan $1) Nothing }-| cycle VARIABLE { StCycle () (getTransSpan $1 $2) (Just $2) }-| exit { StExit () (getSpan $1) Nothing }-| exit VARIABLE { StExit () (getTransSpan $1 $2) (Just $2) }-| goto INTEGER_LITERAL { StGotoUnconditional () (getTransSpan $1 $2) $2 }-| goto VARIABLE { StGotoUnconditional () (getTransSpan $1 $2) $2 }-| goto VARIABLE MAYBE_COMMA '(' INTEGERS ')'- { StGotoAssigned () (getTransSpan $1 $6) $2 (fromReverseList $5) }-| goto '(' INTEGERS ')' MAYBE_COMMA EXPRESSION- { StGotoComputed () (getTransSpan $1 $6) (fromReverseList $3) $6 }-| assign INTEGER_LITERAL to VARIABLE- { StLabelAssign () (getTransSpan $1 $4) $2 $4 }-| continue { StContinue () (getSpan $1) }-| stop { StStop () (getSpan $1) Nothing }-| stop EXPRESSION { StStop () (getTransSpan $1 $2) (Just $2) }-| pause { StPause () (getSpan $1) Nothing }-| pause EXPRESSION { StPause () (getTransSpan $1 $2) (Just $2) }-| selectcase '(' EXPRESSION ')'- { StSelectCase () (getTransSpan $1 $4) Nothing $3 }-| id ':' selectcase '(' EXPRESSION ')'- { let TId s id = $1 in StSelectCase () (getTransSpan s $6) (Just id) $5 }-| case default { StCase () (getTransSpan $1 $2) Nothing Nothing }-| case default id- { let TId s id = $3 in StCase () (getTransSpan $1 s) (Just id) Nothing }-| case '(' INDICIES ')'- { StCase () (getTransSpan $1 $4) Nothing (Just $ fromReverseList $3) }-| case '(' INDICIES ')' id- { let TId s id = $5- in StCase () (getTransSpan $1 s) (Just id) (Just $ fromReverseList $3) }-| endselect { StEndcase () (getSpan $1) Nothing }-| endselect id- { let TId s id = $2 in StEndcase () (getTransSpan $1 s) (Just id) }-| if '(' EXPRESSION ')' EXECUTABLE_STATEMENT- { StIfLogical () (getTransSpan $1 $5) $3 $5 }-| read CILIST IN_IOLIST- { let alist = fromReverseList $3- in StRead () (getTransSpan $1 alist) $2 (Just alist) }-| read CILIST { StRead () (getTransSpan $1 $2) $2 Nothing }-| read FORMAT_ID ',' IN_IOLIST- { let alist = fromReverseList $4- in StRead2 () (getTransSpan $1 alist) $2 (Just alist) }-| read FORMAT_ID { StRead2 () (getTransSpan $1 $2) $2 Nothing }-| write CILIST OUT_IOLIST- { let alist = fromReverseList $3- in StWrite () (getTransSpan $1 alist) $2 (Just alist) }-| write CILIST { StWrite () (getTransSpan $1 $2) $2 Nothing }-| print FORMAT_ID ',' OUT_IOLIST- { let alist = fromReverseList $4- in StPrint () (getTransSpan $1 alist) $2 (Just alist) }-| print FORMAT_ID { StPrint () (getTransSpan $1 $2) $2 Nothing }-| open CILIST { StOpen () (getTransSpan $1 $2) $2 }-| close CILIST { StClose () (getTransSpan $1 $2) $2 }-| inquire CILIST { StInquire () (getTransSpan $1 $2) $2 }-| rewind CILIST { StRewind () (getTransSpan $1 $2) $2 }-| rewind UNIT { StRewind2 () (getTransSpan $1 $2) $2 }-| endfile CILIST { StEndfile () (getTransSpan $1 $2) $2 }-| endfile UNIT { StEndfile2 () (getTransSpan $1 $2) $2 }-| backspace CILIST { StBackspace () (getTransSpan $1 $2) $2 }-| backspace UNIT { StBackspace2 () (getTransSpan $1 $2) $2 }-| call VARIABLE { StCall () (getTransSpan $1 $2) $2 Nothing }-| call VARIABLE '(' ')' { StCall () (getTransSpan $1 $4) $2 Nothing }-| call VARIABLE '(' ARGUMENTS ')'- { let alist = fromReverseList $4- in StCall () (getTransSpan $1 $5) $2 (Just alist) }-| return { StReturn () (getSpan $1) Nothing }-| return EXPRESSION { StReturn () (getTransSpan $1 $2) (Just $2) }-| FORALL_STMNT { $1 }--ARGUMENTS :: { [ Argument A0 ] }-: ARGUMENTS ',' ARGUMENT { $3 : $1 }-| ARGUMENT { [ $1 ] }--ARGUMENT :: { Argument A0 }-: id '=' EXPRESSION- { let TId span keyword = $1- in Argument () (getTransSpan span $3) (Just keyword) $3 }-| EXPRESSION- { Argument () (getSpan $1) Nothing $1 }--RENAME_LIST :: { [ Use A0 ] }-: RENAME_LIST ',' RENAME { $3 : $1 }-| RENAME { [ $1 ] }--RENAME :: { Use A0 }-: VARIABLE '=>' VARIABLE { UseRename () (getTransSpan $1 $3) $1 $3 }-| VARIABLE { UseID () (getSpan $1) $1 }--MAYBE_DCOLON :: { () } : '::' { () } | {- EMPTY -} { () }--FORMAT_ID :: { Expression A0 }-: FORMAT_ID '/' '/' FORMAT_ID %prec CONCAT- { ExpBinary () (getTransSpan $1 $4) Concatenation $1 $4 }-| INTEGER_LITERAL { $1 }-| STRING { $1 }-| DATA_REF { $1 }-| '*' { ExpValue () (getSpan $1) ValStar }--UNIT :: { Expression A0 }-: INTEGER_LITERAL { $1 }-| DATA_REF { $1 }-| '*' { ExpValue () (getSpan $1) ValStar }--CILIST :: { AList ControlPair A0 }-: '(' CILIST_ELEMENT ',' FORMAT_ID ',' CILIST_PAIRS ')'- { let { cp1 = ControlPair () (getSpan $2) Nothing $2;- cp2 = ControlPair () (getSpan $4) Nothing $4;- tail = fromReverseList $6 }- in setSpan (getTransSpan $1 $7) $ cp1 `aCons` cp2 `aCons` tail }-| '(' CILIST_ELEMENT ',' FORMAT_ID ')'- { let { cp1 = ControlPair () (getSpan $2) Nothing $2;- cp2 = ControlPair () (getSpan $4) Nothing $4 }- in AList () (getTransSpan $1 $5) [ cp1, cp2 ] }-| '(' CILIST_ELEMENT ',' CILIST_PAIRS ')'- { let { cp1 = ControlPair () (getSpan $2) Nothing $2;- tail = fromReverseList $4 }- in setSpan (getTransSpan $1 $5) $ cp1 `aCons` tail }-| '(' CILIST_ELEMENT ')'- { let cp1 = ControlPair () (getSpan $2) Nothing $2- in AList () (getTransSpan $1 $3) [ cp1 ] }-| '(' CILIST_PAIRS ')' { fromReverseList $2 }--CILIST_PAIRS :: { [ ControlPair A0 ] }-: CILIST_PAIRS ',' CILIST_PAIR { $3 : $1 }-| CILIST_PAIR { [ $1 ] }--CILIST_PAIR :: { ControlPair A0 }-: id '=' CILIST_ELEMENT- { let (TId s id) = $1 in ControlPair () (getTransSpan s $3) (Just id) $3 }--CILIST_ELEMENT :: { Expression A0 }-: CI_EXPRESSION { $1 }-| '*' { ExpValue () (getSpan $1) ValStar }--CI_EXPRESSION :: { Expression A0 }-: CI_EXPRESSION '+' CI_EXPRESSION- { ExpBinary () (getTransSpan $1 $3) Addition $1 $3 }-| CI_EXPRESSION '-' CI_EXPRESSION- { ExpBinary () (getTransSpan $1 $3) Subtraction $1 $3 }-| CI_EXPRESSION '*' CI_EXPRESSION- { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 }-| CI_EXPRESSION '/' CI_EXPRESSION- { ExpBinary () (getTransSpan $1 $3) Division $1 $3 }-| CI_EXPRESSION '**' CI_EXPRESSION- { ExpBinary () (getTransSpan $1 $3) Exponentiation $1 $3 }-| CI_EXPRESSION '/' '/' CI_EXPRESSION %prec CONCAT- { ExpBinary () (getTransSpan $1 $4) Concatenation $1 $4 }-| ARITHMETIC_SIGN CI_EXPRESSION %prec SIGN- { ExpUnary () (getTransSpan (fst $1) $2) (snd $1) $2 }-| CI_EXPRESSION or CI_EXPRESSION- { ExpBinary () (getTransSpan $1 $3) Or $1 $3 }-| CI_EXPRESSION and CI_EXPRESSION- { ExpBinary () (getTransSpan $1 $3) And $1 $3 }-| not CI_EXPRESSION- { ExpUnary () (getTransSpan $1 $2) Not $2 }-| CI_EXPRESSION eqv CI_EXPRESSION- { ExpBinary () (getTransSpan $1 $3) Equivalent $1 $3 }-| CI_EXPRESSION neqv CI_EXPRESSION- { ExpBinary () (getTransSpan $1 $3) NotEquivalent $1 $3 }-| CI_EXPRESSION RELATIONAL_OPERATOR CI_EXPRESSION %prec RELATIONAL- { ExpBinary () (getTransSpan $1 $3) $2 $1 $3 }-| opCustom CI_EXPRESSION %prec DEFINED_UNARY- { let TOpCustom span str = $1- in ExpUnary () (getTransSpan span $2) (UnCustom str) $2 }-| CI_EXPRESSION opCustom CI_EXPRESSION- { let TOpCustom _ str = $2- in ExpBinary () (getTransSpan $1 $3) (BinCustom str) $1 $3 }-| '(' CI_EXPRESSION ')' { setSpan (getTransSpan $1 $3) $2 }-| INTEGER_LITERAL { $1 }-| LOGICAL_LITERAL { $1 }-| STRING { $1 }-| DATA_REF { $1 }--IN_IOLIST :: { [ Expression A0 ] }-: IN_IOLIST ',' IN_IO_ELEMENT { $3 : $1}-| IN_IO_ELEMENT { [ $1 ] }--IN_IO_ELEMENT :: { Expression A0 }-: DATA_REF { $1 }-| '(' IN_IOLIST ',' DO_SPECIFICATION ')'- { ExpImpliedDo () (getTransSpan $1 $5) (fromReverseList $2) $4 }--OUT_IOLIST :: { [ Expression A0 ] }-: OUT_IOLIST ',' EXPRESSION { $3 : $1}-| EXPRESSION { [ $1 ] }--COMMON_GROUPS :: { [ CommonGroup A0 ] }-: COMMON_GROUPS COMMON_GROUP { $2 : $1 }-| COMMON_GROUPS ',2' COMMON_GROUP { $3 : $1 }-| INIT_COMMON_GROUP { [ $1 ] }--COMMON_GROUP :: { CommonGroup A0 }-: COMMON_NAME PART_REFS- { let alist = fromReverseList $2- in CommonGroup () (getTransSpan $1 alist) (Just $1) alist }-| '/' '/' PART_REFS- { let alist = fromReverseList $3- in CommonGroup () (getTransSpan $1 alist) Nothing alist }--INIT_COMMON_GROUP :: { CommonGroup A0 }-: COMMON_NAME PART_REFS- { let alist = fromReverseList $2- in CommonGroup () (getTransSpan $1 alist) (Just $1) alist }-| '/' '/' PART_REFS- { let alist = fromReverseList $3- in CommonGroup () (getTransSpan $1 alist) Nothing alist }-| PART_REFS- { let alist = fromReverseList $1- in CommonGroup () (getSpan alist) Nothing alist }--EQUIVALENCE_GROUPS :: { [ AList Expression A0 ] }-: EQUIVALENCE_GROUPS ',' '(' PART_REFS ')'- { setSpan (getTransSpan $3 $5) (fromReverseList $4) : $1 }-| '(' PART_REFS ')'- { [ setSpan (getTransSpan $1 $3) (fromReverseList $2) ] }--NAMELISTS :: { [ Namelist A0 ] }-: NAMELISTS NAMELIST { $2 : $1 }-| NAMELISTS ',2' NAMELIST { $3 : $1 }-| NAMELIST { [ $1 ] }--NAMELIST :: { Namelist A0 }-: '/' VARIABLE '/' VARIABLES- { Namelist () (getTransSpan $1 $4) $2 $ fromReverseList $4 }--MAYBE_VARIABLES :: { Maybe (AList Expression A0) }-: VARIABLES { Just $ fromReverseList $1 } | {- EMPTY -} { Nothing }--VARIABLES :: { [ Expression A0 ] }-: VARIABLES ',' VARIABLE { $3 : $1 }-| VARIABLE { [ $1 ] }--IMP_LISTS :: { [ ImpList A0 ] }-: IMP_LISTS ',' IMP_LIST { $3 : $1 }-| IMP_LIST { [ $1 ] }--IMP_LIST :: { ImpList A0 }-: TYPE_SPEC '(2' IMP_ELEMENTS ')'- { ImpList () (getTransSpan $1 $4) $1 (aReverse $3) }--IMP_ELEMENTS :: { AList ImpElement A0 }-: IMP_ELEMENTS ',' IMP_ELEMENT { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }-| IMP_ELEMENT { AList () (getSpan $1) [ $1 ] }--IMP_ELEMENT :: { ImpElement A0 }-: id {% do- let (TId s id) = $1- if length id /= 1- then fail "Implicit argument must be a character."- else return $ ImpCharacter () s id- }-| id '-' id {% do- let (TId _ id1) = $1- let (TId _ id2) = $3- if length id1 /= 1 || length id2 /= 1- then fail "Implicit argument must be a character."- else return $ ImpRange () (getTransSpan $1 $3) id1 id2- }--PARAMETER_ASSIGNMENTS :: { [ Declarator A0 ] }-: PARAMETER_ASSIGNMENTS ',' PARAMETER_ASSIGNMENT { $3 : $1 }-| PARAMETER_ASSIGNMENT { [ $1 ] }--PARAMETER_ASSIGNMENT :: { Declarator A0 }-: VARIABLE '=' EXPRESSION- { DeclVariable () (getTransSpan $1 $3) $1 Nothing (Just $3) }--DECLARATION_STATEMENT :: { Statement A0 }-: TYPE_SPEC ATTRIBUTE_LIST '::' DECLARATOR_LIST- { let { mAttrAList = if null $2 then Nothing else Just $ fromReverseList $2;- declAList = fromReverseList $4 }- in StDeclaration () (getTransSpan $1 declAList) $1 mAttrAList declAList }-| TYPE_SPEC DECLARATOR_LIST- { let { declAList = fromReverseList $2 }- in StDeclaration () (getTransSpan $1 declAList) $1 Nothing declAList }--ATTRIBUTE_LIST :: { [ Attribute A0 ] }-: ATTRIBUTE_LIST ',' ATTRIBUTE_SPEC { $3 : $1 }-| {- EMPTY -} { [ ] }--ATTRIBUTE_SPEC :: { Attribute A0 }-: public { AttrPublic () (getSpan $1) }-| private { AttrPrivate () (getSpan $1) }-| allocatable { AttrAllocatable () (getSpan $1) }-| dimension '(' DIMENSION_DECLARATORS ')'- { AttrDimension () (getTransSpan $1 $4) $3 }-| external { AttrExternal () (getSpan $1) }-| intent '(' INTENT_CHOICE ')' { AttrIntent () (getTransSpan $1 $4) $3 }-| intrinsic { AttrIntrinsic () (getSpan $1) }-| optional { AttrOptional () (getSpan $1) }-| pointer { AttrPointer () (getSpan $1) }-| parameter { AttrParameter () (getSpan $1) }-| save { AttrSave () (getSpan $1) }-| target { AttrTarget () (getSpan $1) }--INTENT_CHOICE :: { Intent } : in { In } | out { Out } | inout { InOut }--DATA_GROUPS :: { [ DataGroup A0 ] }-: DATA_GROUPS MAYBE_COMMA DATA_LIST slash EXPRESSION_LIST slash- { let { nameAList = fromReverseList $3;- dataAList = fromReverseList $5 }- in DataGroup () (getTransSpan nameAList $6) nameAList dataAList : $1 }-| DATA_LIST slash EXPRESSION_LIST slash- { let { nameAList = fromReverseList $1;- dataAList = fromReverseList $3 }- in [ DataGroup () (getTransSpan nameAList $4) nameAList dataAList ] }--MAYBE_COMMA :: { () } : ',' { () } | {- EMPTY -} { () }--DATA_LIST :: { [ Expression A0 ] }-: DATA_LIST ',' DATA_ELEMENT { $3 : $1 }-| DATA_ELEMENT { [ $1 ] }--DATA_ELEMENT :: { Expression A0 }-: DATA_REF { $1 } | IMPLIED_DO { $1 }--SAVE_ARGS :: { [ Expression A0 ] }-: SAVE_ARGS ',' SAVE_ARG { $3 : $1 } | SAVE_ARG { [ $1 ] }--SAVE_ARG :: { Expression A0 } : COMMON_NAME { $1 } | VARIABLE { $1 }--COMMON_NAME :: { Expression A0 }-: '/' VARIABLE '/' { setSpan (getTransSpan $1 $3) $2 }--DECLARATOR_LIST :: { [ Declarator A0 ] }-: DECLARATOR_LIST ',' INITIALISED_DECLARATOR { $3 : $1 }-| INITIALISED_DECLARATOR { [ $1 ] }--INITIALISED_DECLARATOR :: { Declarator A0 }-: DECLARATOR '=' EXPRESSION { setInitialisation $1 $3 }-| DECLARATOR '=>' EXPRESSION { setInitialisation $1 $3 }-| DECLARATOR { $1 }--DECLARATOR :: { Declarator A0 }-: VARIABLE { DeclVariable () (getSpan $1) $1 Nothing Nothing }-| VARIABLE '*' EXPRESSION- { DeclVariable () (getTransSpan $1 $3) $1 (Just $3) Nothing }-| VARIABLE '*' '(' '*' ')'- { let star = ExpValue () (getSpan $4) ValStar- in DeclVariable () (getTransSpan $1 $5) $1 (Just star) Nothing }-| VARIABLE '(' DIMENSION_DECLARATORS ')'- { DeclArray () (getTransSpan $1 $4) $1 $3 Nothing Nothing }-| VARIABLE '(' DIMENSION_DECLARATORS ')' '*' EXPRESSION- { DeclArray () (getTransSpan $1 $6) $1 $3 (Just $6) Nothing }-| VARIABLE '(' DIMENSION_DECLARATORS ')' '*' '(' '*' ')'- { let star = ExpValue () (getSpan $7) ValStar- in DeclArray () (getTransSpan $1 $8) $1 $3 (Just star) Nothing }--DIMENSION_DECLARATORS :: { AList DimensionDeclarator A0 }-: DIMENSION_DECLARATORS ',' DIMENSION_DECLARATOR- { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }-| DIMENSION_DECLARATOR- { AList () (getSpan $1) [ $1 ] }--DIMENSION_DECLARATOR :: { DimensionDeclarator A0 }-: EXPRESSION ':' EXPRESSION- { DimensionDeclarator () (getTransSpan $1 $3) (Just $1) (Just $3) }-| EXPRESSION { DimensionDeclarator () (getSpan $1) Nothing (Just $1) }--- Lower bound only-| EXPRESSION ':'- { DimensionDeclarator () (getTransSpan $1 $2) (Just $1) Nothing }-| EXPRESSION ':' '*'- { let { span = getSpan $3;- star = ExpValue () span ValStar }- in DimensionDeclarator () (getTransSpan $1 span) (Just $1) (Just star) }-| '*'- { let { span = getSpan $1;- star = ExpValue () span ValStar }- in DimensionDeclarator () span Nothing (Just star) }-| ':'- { let span = getSpan $1- in DimensionDeclarator () span Nothing Nothing }--TYPE_SPEC :: { TypeSpec A0 }-: integer KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeInteger $2 }-| real KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeReal $2 }-| doublePrecision { TypeSpec () (getSpan $1) TypeDoublePrecision Nothing }-| complex KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeComplex $2 }-| character CHAR_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeCharacter $2 }-| logical KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeLogical $2 }-| type '(' id ')'- { let TId _ id = $3- in TypeSpec () (getTransSpan $1 $4) (TypeCustom id) Nothing }--KIND_SELECTOR :: { Maybe (Selector A0) }-: '(' EXPRESSION ')'- { Just $ Selector () (getTransSpan $1 $3) Nothing (Just $2) }-| '(' kind '=' EXPRESSION ')'- { Just $ Selector () (getTransSpan $1 $5) Nothing (Just $4) }-| {- EMPTY -} { Nothing }--CHAR_SELECTOR :: { Maybe (Selector A0) }-: '*' EXPRESSION- { Just $ Selector () (getTransSpan $1 $2) (Just $2) Nothing }--- The following rule is a bug in the spec.--- | '*' EXPRESSION ','--- { Just $ Selector () (getTransSpan $1 $2) (Just $2) Nothing }-| '*' '(' '*' ')'- { let star = ExpValue () (getSpan $3) ValStar- in Just $ Selector () (getTransSpan $1 $4) (Just star) Nothing }-| '(' LEN_EXPRESSION ')'- { Just $ Selector () (getTransSpan $1 $3) (Just $2) Nothing }-| '(' len '=' LEN_EXPRESSION ')'- { Just $ Selector () (getTransSpan $1 $5) (Just $4) Nothing }-| '(' LEN_EXPRESSION ',' EXPRESSION ')'- { Just $ Selector () (getTransSpan $1 $5) (Just $2) (Just $4) }-| '(' LEN_EXPRESSION ',' kind '=' EXPRESSION ')'- { Just $ Selector () (getTransSpan $1 $7) (Just $2) (Just $6) }-| '(' len '=' LEN_EXPRESSION ',' kind '=' EXPRESSION ')'- { Just $ Selector () (getTransSpan $1 $9) (Just $4) (Just $8) }-| '(' kind '=' EXPRESSION ',' len '=' LEN_EXPRESSION ')'- { Just $ Selector () (getTransSpan $1 $9) (Just $8) (Just $4) }-| {- EMPTY -} { Nothing }--LEN_EXPRESSION :: { Expression A0 }-: EXPRESSION { $1 }-| '*' { ExpValue () (getSpan $1) ValStar }--EXPRESSION :: { Expression A0 }-: EXPRESSION '+' EXPRESSION- { ExpBinary () (getTransSpan $1 $3) Addition $1 $3 }-| EXPRESSION '-' EXPRESSION- { ExpBinary () (getTransSpan $1 $3) Subtraction $1 $3 }-| EXPRESSION '*' EXPRESSION- { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 }-| EXPRESSION '/' EXPRESSION- { ExpBinary () (getTransSpan $1 $3) Division $1 $3 }-| EXPRESSION '**' EXPRESSION- { ExpBinary () (getTransSpan $1 $3) Exponentiation $1 $3 }-| EXPRESSION '/' '/' EXPRESSION %prec CONCAT- { ExpBinary () (getTransSpan $1 $4) Concatenation $1 $4 }-| ARITHMETIC_SIGN EXPRESSION %prec SIGN- { ExpUnary () (getTransSpan (fst $1) $2) (snd $1) $2 }-| EXPRESSION or EXPRESSION- { ExpBinary () (getTransSpan $1 $3) Or $1 $3 }-| EXPRESSION and EXPRESSION- { ExpBinary () (getTransSpan $1 $3) And $1 $3 }-| not EXPRESSION- { ExpUnary () (getTransSpan $1 $2) Not $2 }-| EXPRESSION eqv EXPRESSION- { ExpBinary () (getTransSpan $1 $3) Equivalent $1 $3 }-| EXPRESSION neqv EXPRESSION- { ExpBinary () (getTransSpan $1 $3) NotEquivalent $1 $3 }-| EXPRESSION RELATIONAL_OPERATOR EXPRESSION %prec RELATIONAL- { ExpBinary () (getTransSpan $1 $3) $2 $1 $3 }-| opCustom EXPRESSION %prec DEFINED_UNARY- { let TOpCustom span str = $1- in ExpUnary () (getTransSpan span $2) (UnCustom str) $2 }-| EXPRESSION opCustom EXPRESSION- { let TOpCustom _ str = $2- in ExpBinary () (getTransSpan $1 $3) (BinCustom str) $1 $3 }-| '(' EXPRESSION ')' { setSpan (getTransSpan $1 $3) $2 }-| NUMERIC_LITERAL { $1 }-| '(' EXPRESSION ',' EXPRESSION ')'- { ExpValue () (getTransSpan $1 $5) (ValComplex $2 $4) }-| LOGICAL_LITERAL { $1 }-| STRING { $1 }-| DATA_REF { $1 }-| IMPLIED_DO { $1 }-| '(/' EXPRESSION_LIST '/)'- { ExpInitialisation () (getTransSpan $1 $3) (fromReverseList $2) }-| operator '(' opCustom ')'- { let TOpCustom _ op = $3- in ExpValue () (getTransSpan $1 $4) (ValOperator op) }-| assignment { ExpValue () (getSpan $1) ValAssignment }-| '*' INTEGER_LITERAL { ExpReturnSpec () (getTransSpan $1 $2) $2 }--DATA_REFS :: { [ Expression A0 ] }-: DATA_REFS ',' DATA_REF { $3 : $1 }-| DATA_REF { [ $1 ] }--DATA_REF :: { Expression A0 }-: DATA_REF '%' PART_REF { ExpDataRef () (getTransSpan $1 $3) $1 $3 }-| PART_REF { $1 }--PART_REFS :: { [ Expression A0 ] }-: PART_REFS ',' PART_REF { $3 : $1 }-| PART_REF { [ $1 ] }--PART_REF :: { Expression A0 }-: VARIABLE { $1 }-| VARIABLE '(' ')'- { ExpFunctionCall () (getTransSpan $1 $3) $1 Nothing }-| VARIABLE '(' INDICIES ')'- { ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3) }-| VARIABLE '(' INDICIES ')' '(' INDICIES ')'- { let innerSub = ExpSubscript () (getTransSpan $1 $4) $1 (fromReverseList $3)- in ExpSubscript () (getTransSpan $1 $7) innerSub (fromReverseList $6) }--INDICIES :: { [ Index A0 ] }-: INDICIES ',' INDEX { $3 : $1 }-| INDEX { [ $1 ] }--INDEX :: { Index A0 }-: RANGE { $1 }-| RANGE ':' EXPRESSION- { let IxRange () s lower upper _ = $1- in IxRange () (getTransSpan s $3) lower upper (Just $3) }-| EXPRESSION { IxSingle () (getSpan $1) Nothing $1 }--- Following is only as an intermediate stage before having been turned into--- an argument by later transformation.-| id '=' EXPRESSION- { let TId s id = $1 in IxSingle () (getTransSpan $1 s) (Just id) $3 }--RANGE :: { Index A0 }-: ':' { IxRange () (getSpan $1) Nothing Nothing Nothing }-| ':' EXPRESSION { IxRange () (getTransSpan $1 $2) Nothing (Just $2) Nothing }-| EXPRESSION ':' { IxRange () (getTransSpan $1 $2) (Just $1) Nothing Nothing }-| EXPRESSION ':' EXPRESSION- { IxRange () (getTransSpan $1 $3) (Just $1) (Just $3) Nothing }--DO_SPECIFICATION :: { DoSpecification A0 }-: EXPRESSION_ASSIGNMENT_STATEMENT ',' EXPRESSION ',' EXPRESSION- { DoSpecification () (getTransSpan $1 $5) $1 $3 (Just $5) }-| EXPRESSION_ASSIGNMENT_STATEMENT ',' EXPRESSION- { DoSpecification () (getTransSpan $1 $3) $1 $3 Nothing }--IMPLIED_DO :: { Expression A0 }-: '(' EXPRESSION ',' DO_SPECIFICATION ')'- { let expList = AList () (getSpan $2) [ $2 ]- in ExpImpliedDo () (getTransSpan $1 $5) expList $4 }-| '(' EXPRESSION ',' EXPRESSION ',' DO_SPECIFICATION ')'- { let expList = AList () (getTransSpan $2 $4) [ $2, $4 ]- in ExpImpliedDo () (getTransSpan $1 $5) expList $6 }-| '(' EXPRESSION ',' EXPRESSION ',' EXPRESSION_LIST ',' DO_SPECIFICATION ')'- { let { exps = reverse $6;- expList = AList () (getTransSpan $2 exps) ($2 : $4 : reverse $6) }- in ExpImpliedDo () (getTransSpan $1 $9) expList $8 }--{--FORALL_CONSTRUCT :: { Statement A0 }-FORALL_CONSTRUCT =- FORALL_CONSTRUCT_STMT- FORALL_BODY_CONSTRUCTS- END_FORALL_STMT { StForall () (getTransSpan $1 $3) }--FORALL_BODY_CONSTRUCT :: { Statement A0 }- FORALL_ASSIGNMENT_STMT { $1 }- | WHERE_STMT { $1 }- | WHERE--}--FORALL_STMNT :: { Statement A0 }-FORALL_STMNT :- forall FORALL_HEADER FORALL_ASSIGNMENT_STMT- { StForall () (getTransSpan $1 $3) $2 $3 }--FORALL_HEADER- :: { ForallHeader A0 }-FORALL_HEADER :- -- Standard simple forall header- '(' FORALL_TRIPLET_SPEC ')' { ForallHeader [$2] Nothing }- -- forall header with scale expression- | '(' '(' FORALL_TRIPLET_SPEC ')' ',' EXPRESSION ')'- { ForallHeader [$3] (Just $6) }- -- multi forall header- | '(' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE ')'- { ForallHeader $2 Nothing }- -- multi forall header with scale- | '(' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE ',' EXPRESSION ')'- { ForallHeader $2 (Just $4) }--FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE- :: { [(Name, Expression A0, Expression A0, Maybe (Expression A0))] }-FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE-: '(' FORALL_TRIPLET_SPEC ')' ',' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE { $2 : $5 }-| {- empty -} { [] }--FORALL_TRIPLET_SPEC :: { (Name, Expression A0, Expression A0, Maybe (Expression A0)) }-FORALL_TRIPLET_SPEC-: NAME '=' EXPRESSION ':' EXPRESSION { ($1, $3, $5, Nothing) }-| NAME '=' EXPRESSION ':' EXPRESSION ',' EXPRESSION { ($1, $3, $5, Just $7) }---FORALL_ASSIGNMENT_STMT :: { Statement A0 }-FORALL_ASSIGNMENT_STMT :- EXPRESSION_ASSIGNMENT_STATEMENT { $1 }- | POINTER_ASSIGNMENT_STMT { $1 }--POINTER_ASSIGNMENT_STMT :: { Statement A0 }-POINTER_ASSIGNMENT_STMT :- DATA_REF '=>' EXPRESSION { StPointerAssign () (getTransSpan $1 $3) $1 $3 }--END_FORALL_STMT :: { Token }-END_FORALL_STMT :- endforall { $1 }- | endforall id { $2 }--EXPRESSION_LIST :: { [ Expression A0 ] }-: EXPRESSION_LIST ',' EXPRESSION { $3 : $1 }-| EXPRESSION { [ $1 ] }--ARITHMETIC_SIGN :: { (SrcSpan, UnaryOp) }-: '-' { (getSpan $1, Minus) }-| '+' { (getSpan $1, Plus) }--RELATIONAL_OPERATOR :: { BinaryOp }-: '==' { EQ }-| '!=' { NE }-| '>' { GT }-| '>=' { GTE }-| '<' { LT }-| '<=' { LTE }--VARIABLE :: { Expression A0 }-: id { ExpValue () (getSpan $1) $ let (TId _ s) = $1 in ValVariable s }--NUMERIC_LITERAL :: { Expression A0 }-: INTEGER_LITERAL { $1 } | REAL_LITERAL { $1 }--INTEGERS :: { [ Expression A0 ] }-: INTEGERS ',' INTEGER_LITERAL { $3 : $1 }-| INTEGER_LITERAL { [ $1 ] }--INTEGER_LITERAL :: { Expression A0 }-: int { let TIntegerLiteral s i = $1 in ExpValue () s $ ValInteger i }-| boz { let TBozLiteral s i = $1 in ExpValue () s $ ValInteger i }--REAL_LITERAL :: { Expression A0 }-: float { let TRealLiteral s r = $1 in ExpValue () s $ ValReal r }--LOGICAL_LITERAL :: { Expression A0 }-: bool { let TLogicalLiteral s b = $1 in ExpValue () s $ ValLogical b }--STRING :: { Expression A0 }-: string { let TString s c = $1 in ExpValue () s $ ValString c }--cDATA :: { () } : {% pushContext ConData }-cIMPLICIT :: { () } : {% pushContext ConImplicit }-cNAMELIST :: { () } : {% pushContext ConNamelist }-cCOMMON :: { () } : {% pushContext ConCommon }-cPOP :: { () } : {% popContext }--{--unitNameCheck :: Token -> String -> Parse AlexInput Token ()-unitNameCheck (TId _ name1) name2- | name1 == name2 = return ()- | otherwise = fail "Unit name does not match the corresponding END statement."-unitNameCheck _ _ = return ()--parse = runParse programParser--transformations95 =- [ GroupLabeledDo- , GroupDo- , GroupIf- , GroupCase- , DisambiguateIntrinsic- , DisambiguateFunction- ]--fortran95Parser ::- B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)-fortran95Parser sourceCode filename =- fmap (pfSetFilename filename . transform transformations95) $ parse parseState- where- parseState = initParseState sourceCode Fortran95 filename--fortran95ParserWithModFiles ::- ModFiles -> B.ByteString -> String -> ParseResult AlexInput Token (ProgramFile A0)-fortran95ParserWithModFiles mods sourceCode filename =- fmap (pfSetFilename filename . transform) $ parse parseState- where- transform = transformWithModFiles mods transformations95- parseState = initParseState sourceCode Fortran95 filename--parseError :: Token -> LexAction a-parseError _ = do- parseState <- get-#ifdef DEBUG- tokens <- reverse <$> aiPreviousTokensInLine <$> getAlex-#endif- fail $ psFilename parseState ++ ": parsing failed. "-#ifdef DEBUG- ++ '\n' : show tokens-#endif--}
src/Language/Fortran/Parser/Utils.hs view
@@ -1,6 +1,5 @@ {-| Simple module to provide functions that read Fortran literals -} module Language.Fortran.Parser.Utils (readReal, readInteger) where-import Data.List import Data.Char import Numeric
src/Language/Fortran/ParserMonad.hs view
@@ -13,7 +13,6 @@ import Control.Monad.State import Control.Monad.Except-import Control.Applicative import Data.Typeable import Data.Data@@ -28,7 +27,6 @@ | Fortran77 | Fortran77Extended | Fortran90- | Fortran95 | Fortran2003 | Fortran2008 deriving (Ord, Eq, Data, Typeable, Generic)@@ -38,7 +36,6 @@ show Fortran77 = "Fortran 77" show Fortran77Extended = "Fortran 77 Extended" show Fortran90 = "Fortran 90"- show Fortran95 = "Fortran 95" show Fortran2003 = "Fortran 2003" show Fortran2008 = "Fortran 2008"
src/Language/Fortran/PrettyPrint.hs view
@@ -5,7 +5,6 @@ module Language.Fortran.PrettyPrint where -import Data.Char import Data.Maybe (isJust, isNothing) import Data.List (foldl') @@ -13,7 +12,6 @@ import Language.Fortran.AST import Language.Fortran.ParserMonad-import Language.Fortran.Util.Position import Language.Fortran.Util.FirstParameter import Text.PrettyPrint
src/Language/Fortran/Transformation/Disambiguation/Function.hs view
@@ -5,17 +5,12 @@ import Prelude hiding (lookup) import Data.Generics.Uniplate.Data-import Data.Map ((!), lookup, Map)-import Data.Maybe (isJust, fromJust) import Data.Data -import Language.Fortran.Util.Position (getSpan) import Language.Fortran.Analysis-import Language.Fortran.Analysis.Types import Language.Fortran.AST import Language.Fortran.Transformation.TransformMonad -import Debug.Trace disambiguateFunction :: Data a => Transform a () disambiguateFunction = do
src/Language/Fortran/Transformation/Disambiguation/Intrinsic.hs view
@@ -5,17 +5,12 @@ import Prelude hiding (lookup) import Data.Generics.Uniplate.Data-import Data.Map ((!), lookup, Map)-import Data.Maybe (isJust, fromJust) import Data.Data -import Language.Fortran.Util.Position (getSpan) import Language.Fortran.Analysis-import Language.Fortran.Analysis.Types import Language.Fortran.AST import Language.Fortran.Transformation.TransformMonad -import Debug.Trace disambiguateIntrinsic :: Data a => Transform a () disambiguateIntrinsic = modifyProgramFile (trans expression)
src/Language/Fortran/Transformation/Grouping.hs view
@@ -8,7 +8,6 @@ import Language.Fortran.Analysis import Language.Fortran.Transformation.TransformMonad -import Debug.Trace genericGroup :: ([ Block (Analysis a) ] -> [ Block (Analysis a) ]) -> Transform a () genericGroup groupingFunction =
src/Language/Fortran/Transformation/TransformMonad.hs view
@@ -9,7 +9,6 @@ import Prelude hiding (lookup) import Control.Monad.State.Lazy-import Data.Map (lookup, Map, empty) import Data.Data import Language.Fortran.Analysis
src/Language/Fortran/Transformer.hs view
@@ -1,20 +1,16 @@ module Language.Fortran.Transformer ( transform, transformWithModFiles , Transformation(..) ) where -import Control.Monad import Data.Maybe (fromJust)-import Data.Map (Map, empty)+import Data.Map (empty) import Data.Data import Language.Fortran.Util.ModFile-import Language.Fortran.Analysis-import Language.Fortran.Analysis.Types-import Language.Fortran.Analysis.Renaming import Language.Fortran.Transformation.TransformMonad (Transform, runTransform) import Language.Fortran.Transformation.Disambiguation.Function import Language.Fortran.Transformation.Disambiguation.Intrinsic import Language.Fortran.Transformation.Grouping-import Language.Fortran.AST (ProgramFile, ProgramUnitName)+import Language.Fortran.AST (ProgramFile) data Transformation = GroupIf
src/Language/Fortran/Util/ModFile.hs view
@@ -51,16 +51,11 @@ , genUniqNameToFilenameMap ) where -import qualified Debug.Trace as D- import Data.Data-import Data.List-import Data.Char import Data.Maybe import Data.Generics.Uniplate.Operations import qualified Data.Map.Strict as M import Data.Binary-import Data.Typeable import GHC.Generics (Generic) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB@@ -79,7 +74,8 @@ -- | Context of a declaration: the ProgramUnit where it was declared. data DeclContext = DCMain | DCBlockData | DCModule F.ProgramUnitName- | DCFunction F.ProgramUnitName | DCSubroutine F.ProgramUnitName+ | DCFunction (F.ProgramUnitName, F.ProgramUnitName) -- ^ (uniqName, srcName)+ | DCSubroutine (F.ProgramUnitName, F.ProgramUnitName) -- ^ (uniqName, srcName) deriving (Ord, Eq, Show, Data, Typeable, Generic) instance Binary DeclContext@@ -190,28 +186,44 @@ -------------------------------------------------- +-- | Extract all module maps (name -> environment) by collecting all+-- of the stored module maps within the PUModule annotation. extractModuleMap :: forall a. Data a => F.ProgramFile (FA.Analysis a) -> FAR.ModuleMap extractModuleMap pf = M.fromList [ (n, env) | pu@(F.PUModule {}) <- universeBi pf :: [F.ProgramUnit (FA.Analysis a)] , let a = F.getAnnotation pu , let n = F.getName pu , env <- maybeToList (FA.moduleEnv a) ]- ++-- | Extract map of declared variables with their associated program+-- unit and source span. extractDeclMap :: forall a. Data a => F.ProgramFile (FA.Analysis a) -> DeclMap extractDeclMap pf = M.fromList . concatMap (blockDecls . nameAndBlocks) $ universeBi pf where- blockDecls :: (DeclContext, [F.Block (FA.Analysis a)]) -> [(F.Name, (DeclContext, P.SrcSpan))]- blockDecls (dc, bs) = flip map (universeBi bs) $ \ d ->- let (v, ss) = declVarName d in (v, (dc, ss))+ -- Extract variable names, source spans from declarations (and+ -- from function return variable if present)+ blockDecls :: (DeclContext, Maybe (F.Name, P.SrcSpan), [F.Block (FA.Analysis a)]) -> [(F.Name, (DeclContext, P.SrcSpan))]+ blockDecls (dc, mret, bs)+ | Nothing <- mret = map decls (universeBi bs)+ | Just (ret, ss) <- mret = (ret, (dc, ss)):map decls (universeBi bs)+ where+ decls d = let (v, ss) = declVarName d in (v, (dc, ss)) + -- Extract variable name and source span from declaration declVarName :: F.Declarator (FA.Analysis a) -> (F.Name, P.SrcSpan) declVarName (F.DeclVariable _ _ e _ _) = (FA.varName e, P.getSpan e) declVarName (F.DeclArray _ _ e _ _ _) = (FA.varName e, P.getSpan e) - nameAndBlocks :: F.ProgramUnit (FA.Analysis a) -> (DeclContext, [F.Block (FA.Analysis a)])+ -- Extract context identifier, a function return value (+ source+ -- span) if present, and a list of contained blocks+ nameAndBlocks :: F.ProgramUnit (FA.Analysis a) -> (DeclContext, Maybe (F.Name, P.SrcSpan), [F.Block (FA.Analysis a)]) nameAndBlocks pu = case pu of- F.PUMain _ _ _ b _ -> (DCMain, b)- F.PUModule _ _ _ b _ -> (DCModule $ FA.puName pu, b)- F.PUSubroutine _ _ _ _ _ b _ -> (DCSubroutine $ FA.puName pu, b)- F.PUFunction _ _ _ _ _ _ _ b _ -> (DCFunction $ FA.puName pu, b)- F.PUBlockData _ _ _ b -> (DCBlockData, b)- F.PUComment {} -> (DCBlockData, []) -- no decls inside of comments, so ignore it+ F.PUMain _ _ _ b _ -> (DCMain, Nothing, b)+ F.PUModule _ _ _ b _ -> (DCModule $ FA.puName pu, Nothing, b)+ F.PUSubroutine _ _ _ _ _ b _ -> (DCSubroutine (FA.puName pu, FA.puSrcName pu), Nothing, b)+ F.PUFunction _ _ _ _ _ _ mret b _+ | Nothing <- mret+ , F.Named n <- FA.puName pu -> (DCFunction (FA.puName pu, FA.puSrcName pu), Just (n, P.getSpan pu), b)+ | Just ret <- mret -> (DCFunction (FA.puName pu, FA.puSrcName pu), Just (FA.varName ret, P.getSpan ret), b)+ | otherwise -> error $ "nameAndBlocks: un-named function with no return value! " ++ show (FA.puName pu) ++ " at source-span " ++ show (P.getSpan pu)+ F.PUBlockData _ _ _ b -> (DCBlockData, Nothing, b)+ F.PUComment {} -> (DCBlockData, Nothing, []) -- no decls inside of comments, so ignore it
src/Language/Fortran/Util/Position.hs view
@@ -5,16 +5,11 @@ module Language.Fortran.Util.Position where -import qualified Data.ByteString.Char8 as B import Data.Data-import Data.Typeable import Text.PrettyPrint.GenericPretty import Text.PrettyPrint import Data.Binary -import GHC.Generics--import Language.Fortran.Util.FirstParameter import Language.Fortran.Util.SecondParameter class Loc a where
src/Main.hs view
@@ -4,7 +4,6 @@ import Prelude hiding (readFile) import qualified Data.ByteString.Char8 as B-import Data.Text (unpack) import Data.Text.Encoding (encodeUtf8, decodeUtf8With) import Data.Text.Encoding.Error (replace) @@ -16,22 +15,17 @@ import System.Directory import System.FilePath import Text.PrettyPrint.GenericPretty (pp, pretty, Out)-import Data.List (isInfixOf, isSuffixOf, intercalate, (\\))+import Data.List (isInfixOf, intercalate, (\\)) import Data.Char (toLower)-import Data.Maybe (fromMaybe, fromJust, maybeToList)+import Data.Maybe (fromMaybe, maybeToList) import Data.Data import Data.Binary import Data.Generics.Uniplate.Data-import Data.Generics.Uniplate.Operations import Language.Fortran.ParserMonad (FortranVersion(..), fromRight) import qualified Language.Fortran.Lexer.FixedForm as FixedForm (collectFixedTokens, Token(..)) import qualified Language.Fortran.Lexer.FreeForm as FreeForm (collectFreeTokens, Token(..)) -import Language.Fortran.Parser.Fortran66 (fortran66Parser)-import Language.Fortran.Parser.Fortran77 (fortran77Parser, extended77Parser)-import Language.Fortran.Parser.Fortran90 (fortran90Parser)-import Language.Fortran.Parser.Fortran95Experimental (fortran95Parser) import Language.Fortran.Parser.Any import Language.Fortran.Util.ModFile@@ -43,9 +37,7 @@ import Language.Fortran.Analysis.BBlocks import Language.Fortran.Analysis.DataFlow import Language.Fortran.Analysis.Renaming-import Language.Fortran.Analysis (initAnalysis) import Data.Graph.Inductive hiding (trc)-import Data.Graph.Inductive.PatriciaTree (Gr) import qualified Data.IntMap as IM import qualified Data.Map as M@@ -270,7 +262,6 @@ , ("77e", Fortran77Extended) , ("77", Fortran77) , ("90", Fortran90)- , ("95", Fortran95) , ("03", Fortran2003) , ("08", Fortran2008)] in tryTypes options