diff --git a/fortran-src.cabal b/fortran-src.cabal --- a/fortran-src.cabal +++ b/fortran-src.cabal @@ -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 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 @@ -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 diff --git a/src/Language/Fortran/Analysis.hs b/src/Language/Fortran/Analysis.hs --- a/src/Language/Fortran/Analysis.hs +++ b/src/Language/Fortran/Analysis.hs @@ -1,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 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 @@ -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])] 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 @@ -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. 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 @@ -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 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 @@ -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 _) diff --git a/src/Language/Fortran/Intrinsics.hs b/src/Language/Fortran/Intrinsics.hs --- a/src/Language/Fortran/Intrinsics.hs +++ b/src/Language/Fortran/Intrinsics.hs @@ -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) ] 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 @@ -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 } 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 @@ -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 } diff --git a/src/Language/Fortran/Parser/Any.hs b/src/Language/Fortran/Parser/Any.hs --- a/src/Language/Fortran/Parser/Any.hs +++ b/src/Language/Fortran/Parser/Any.hs @@ -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) diff --git a/src/Language/Fortran/Parser/Fortran95Experimental.y b/src/Language/Fortran/Parser/Fortran95Experimental.y deleted file mode 100644 --- a/src/Language/Fortran/Parser/Fortran95Experimental.y +++ /dev/null @@ -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 - -} 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,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 diff --git a/src/Language/Fortran/ParserMonad.hs b/src/Language/Fortran/ParserMonad.hs --- a/src/Language/Fortran/ParserMonad.hs +++ b/src/Language/Fortran/ParserMonad.hs @@ -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" 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 @@ -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 diff --git a/src/Language/Fortran/Transformation/Disambiguation/Function.hs b/src/Language/Fortran/Transformation/Disambiguation/Function.hs --- a/src/Language/Fortran/Transformation/Disambiguation/Function.hs +++ b/src/Language/Fortran/Transformation/Disambiguation/Function.hs @@ -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 diff --git a/src/Language/Fortran/Transformation/Disambiguation/Intrinsic.hs b/src/Language/Fortran/Transformation/Disambiguation/Intrinsic.hs --- a/src/Language/Fortran/Transformation/Disambiguation/Intrinsic.hs +++ b/src/Language/Fortran/Transformation/Disambiguation/Intrinsic.hs @@ -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) 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 @@ -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 = diff --git a/src/Language/Fortran/Transformation/TransformMonad.hs b/src/Language/Fortran/Transformation/TransformMonad.hs --- a/src/Language/Fortran/Transformation/TransformMonad.hs +++ b/src/Language/Fortran/Transformation/TransformMonad.hs @@ -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 diff --git a/src/Language/Fortran/Transformer.hs b/src/Language/Fortran/Transformer.hs --- a/src/Language/Fortran/Transformer.hs +++ b/src/Language/Fortran/Transformer.hs @@ -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 diff --git a/src/Language/Fortran/Util/ModFile.hs b/src/Language/Fortran/Util/ModFile.hs --- a/src/Language/Fortran/Util/ModFile.hs +++ b/src/Language/Fortran/Util/ModFile.hs @@ -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 diff --git a/src/Language/Fortran/Util/Position.hs b/src/Language/Fortran/Util/Position.hs --- a/src/Language/Fortran/Util/Position.hs +++ b/src/Language/Fortran/Util/Position.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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