fortran-src 0.1.0.1 → 0.1.0.2

raw patch · 16 files changed

+46/−224 lines, 16 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• dist/build/Language/Fortran/Parser/Fortran66.hs +2/−2
• dist/build/Language/Fortran/Parser/Fortran77.hs +2/−2
• dist/build/Language/Fortran/Parser/Fortran90.hs +2/−2
• dist/build/fortran-src/fortran-src-tmp/Language/Fortran/Parser/Fortran66.hs +2/−2
• dist/build/fortran-src/fortran-src-tmp/Language/Fortran/Parser/Fortran77.hs +2/−2
• dist/build/fortran-src/fortran-src-tmp/Language/Fortran/Parser/Fortran90.hs +2/−2
• fortran-src.cabal +1/−1
• src/Language/Fortran/AST.hs +10/−2
• src/Language/Fortran/Analysis/DataFlow.hs +1/−1
• src/Language/Fortran/Analysis/Renaming.hs +1/−1
• src/Language/Fortran/Analysis/Types.hs +9/−198
• src/Language/Fortran/Parser/Fortran66.y +2/−2
• src/Language/Fortran/Parser/Fortran77.y +2/−2
• src/Language/Fortran/Parser/Fortran90.y +2/−2
• src/Language/Fortran/ParserMonad.hs +5/−2
• src/Language/Fortran/Transformation/Grouping.hs +1/−1

@@ -708,7 +708,7 @@ happyReduction_5 happy_x_1 	 =  case happyOut8 happy_x_1 of { happy_var_1 ->  	happyIn7-		 (ProgramFile (reverse happy_var_1) [ ]+		 (ProgramFile (MetaInfo { miVersion = Fortran66 })  (reverse happy_var_1) [ ] 	)}  happyReduce_6 = happySpecReduce_2  1# happyReduction_6@@ -717,7 +717,7 @@ 	 =  case happyOut8 happy_x_1 of { happy_var_1 ->  	case happyOut13 happy_x_2 of { happy_var_2 ->  	happyIn7-		 (ProgramFile (reverse happy_var_1) (reverse happy_var_2)+		 (ProgramFile (MetaInfo { miVersion = Fortran66 })  (reverse happy_var_1) (reverse happy_var_2) 	)}}  happyReduce_7 = happySpecReduce_2  2# happyReduction_7

@@ -1038,7 +1038,7 @@ happyReduction_5 happy_x_1 	 =  case happyOut8 happy_x_1 of { happy_var_1 ->  	happyIn7-		 (ProgramFile (reverse happy_var_1) [ ]+		 (ProgramFile (MetaInfo { miVersion = Fortran77 }) (reverse happy_var_1) [ ] 	)}  happyReduce_6 = happySpecReduce_2  1# happyReduction_6@@ -1047,7 +1047,7 @@ 	 =  case happyOut8 happy_x_1 of { happy_var_1 ->  	case happyOut14 happy_x_2 of { happy_var_2 ->  	happyIn7-		 (ProgramFile (reverse happy_var_1) (reverse happy_var_2)+		 (ProgramFile (MetaInfo { miVersion = Fortran77 }) (reverse happy_var_1) (reverse happy_var_2) 	)}}  happyReduce_7 = happySpecReduce_3  2# happyReduction_7

@@ -1115,7 +1115,7 @@ happyReduction_4 happy_x_1 	 =  case happyOut7 happy_x_1 of { happy_var_1 ->  	happyIn6-		 (ProgramFile (reverse happy_var_1) [ ]+		 (ProgramFile (MetaInfo { miVersion = Fortran90 }) (reverse happy_var_1) [ ] 	)}  happyReduce_5 = happySpecReduce_2  1# happyReduction_5@@ -1124,7 +1124,7 @@ 	 =  case happyOut7 happy_x_1 of { happy_var_1 ->  	case happyOut27 happy_x_2 of { happy_var_2 ->  	happyIn6-		 (ProgramFile (reverse happy_var_1) (reverse happy_var_2)+		 (ProgramFile (MetaInfo { miVersion = Fortran90 }) (reverse happy_var_1) (reverse happy_var_2) 	)}}  happyReduce_6 = happySpecReduce_3  2# happyReduction_6

@@ -708,7 +708,7 @@ happyReduction_5 happy_x_1 	 =  case happyOut8 happy_x_1 of { happy_var_1 ->  	happyIn7-		 (ProgramFile (reverse happy_var_1) [ ]+		 (ProgramFile (MetaInfo { miVersion = Fortran66 })  (reverse happy_var_1) [ ] 	)}  happyReduce_6 = happySpecReduce_2  1# happyReduction_6@@ -717,7 +717,7 @@ 	 =  case happyOut8 happy_x_1 of { happy_var_1 ->  	case happyOut13 happy_x_2 of { happy_var_2 ->  	happyIn7-		 (ProgramFile (reverse happy_var_1) (reverse happy_var_2)+		 (ProgramFile (MetaInfo { miVersion = Fortran66 })  (reverse happy_var_1) (reverse happy_var_2) 	)}}  happyReduce_7 = happySpecReduce_2  2# happyReduction_7

@@ -1038,7 +1038,7 @@ happyReduction_5 happy_x_1 	 =  case happyOut8 happy_x_1 of { happy_var_1 ->  	happyIn7-		 (ProgramFile (reverse happy_var_1) [ ]+		 (ProgramFile (MetaInfo { miVersion = Fortran77 }) (reverse happy_var_1) [ ] 	)}  happyReduce_6 = happySpecReduce_2  1# happyReduction_6@@ -1047,7 +1047,7 @@ 	 =  case happyOut8 happy_x_1 of { happy_var_1 ->  	case happyOut14 happy_x_2 of { happy_var_2 ->  	happyIn7-		 (ProgramFile (reverse happy_var_1) (reverse happy_var_2)+		 (ProgramFile (MetaInfo { miVersion = Fortran77 }) (reverse happy_var_1) (reverse happy_var_2) 	)}}  happyReduce_7 = happySpecReduce_3  2# happyReduction_7

@@ -1115,7 +1115,7 @@ happyReduction_4 happy_x_1 	 =  case happyOut7 happy_x_1 of { happy_var_1 ->  	happyIn6-		 (ProgramFile (reverse happy_var_1) [ ]+		 (ProgramFile (MetaInfo { miVersion = Fortran90 }) (reverse happy_var_1) [ ] 	)}  happyReduce_5 = happySpecReduce_2  1# happyReduction_5@@ -1124,7 +1124,7 @@ 	 =  case happyOut7 happy_x_1 of { happy_var_1 ->  	case happyOut27 happy_x_2 of { happy_var_2 ->  	happyIn6-		 (ProgramFile (reverse happy_var_1) (reverse happy_var_2)+		 (ProgramFile (MetaInfo { miVersion = Fortran90 }) (reverse happy_var_1) (reverse happy_var_2) 	)}}  happyReduce_6 = happySpecReduce_3  2# happyReduction_6

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                fortran-src-version:             0.1.0.1+version:             0.1.0.2 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. license:             Apache-2.0

@@ -13,6 +13,7 @@ import Data.Generics.Uniplate.Data import GHC.Generics (Generic) import Text.PrettyPrint.GenericPretty+import Language.Fortran.ParserMonad (FortranVersion(..))  import Language.Fortran.Util.Position import Language.Fortran.Util.FirstParameter@@ -73,8 +74,11 @@   Selector a SrcSpan (Maybe (Expression a)) (Maybe (Expression a))   deriving (Eq, Show, Data, Typeable, Generic, Functor) +data MetaInfo = MetaInfo { miVersion :: FortranVersion }+  deriving (Eq, Show, Data, Typeable, Generic)+ -- Program structure definition-data ProgramFile a = ProgramFile [ ([ Block a ], ProgramUnit a) ] [ Block a ]+data ProgramFile a = ProgramFile MetaInfo [ ([ Block a ], ProgramUnit a) ] [ Block a ]   deriving (Eq, Show, Data, Typeable, Generic, Functor)  data ProgramUnit a =@@ -350,13 +354,15 @@ class Annotated f where   getAnnotation :: f a -> a   setAnnotation :: a -> f a -> f a-+  modifyAnnotation :: (a -> a) -> f a -> f a   default getAnnotation :: (FirstParameter (f a) a) => f a -> a   getAnnotation = getFirstParameter    default setAnnotation :: (FirstParameter (f a) a) => a -> f a -> f a   setAnnotation = setFirstParameter +  modifyAnnotation f x = setAnnotation (f (getAnnotation x)) x+ instance FirstParameter (AList t a) a instance FirstParameter (ProgramUnit a) a instance FirstParameter (Block a) a@@ -553,6 +559,8 @@   setName (Named n) (PUBlockData  a s _ b) = PUBlockData  a s (Just n) b   setName _         (PUBlockData  a s _ b) = PUBlockData  a s Nothing b +instance Out FortranVersion+instance Out MetaInfo instance Out a => Out (ProgramFile a) instance Out a => Out (ProgramUnit a) instance (Out a, Out (t a)) => Out (AList t a)

@@ -441,7 +441,7 @@ -- | Create a call map showing the structure of the program. genCallMap :: Data a => ProgramFile (Analysis a) -> CallMap genCallMap pf = flip execState M.empty $ do-  let (ProgramFile cm_pus _) = pf+  let (ProgramFile _ cm_pus _) = pf   let uP = (universeBi :: Data a => ProgramFile a -> [ProgramUnit a])   forM_ (uP pf) $ \ pu -> do     let n = puName pu

@@ -49,7 +49,7 @@  -- | Annotate unique names for variable and function declarations and uses. analyseRenames :: Data a => ProgramFile (Analysis a) -> ProgramFile (Analysis a)-analyseRenames (ProgramFile cm_pus bs) = ProgramFile cm_pus' bs+analyseRenames (ProgramFile mi cm_pus bs) = ProgramFile mi cm_pus' bs   where     cm_pus'        = zip (map fst cm_pus) pus'     (Just pus', _) = runRenamer (skimProgramUnits pus >> renameSubPUs (Just pus)) renameState0

@@ -1,5 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}-module Language.Fortran.Analysis.Types ( inferTypes, analyseTypes, TypeScope(..), TypeEnv ) where+module Language.Fortran.Analysis.Types ( analyseTypes, TypeEnv ) where  import Language.Fortran.AST @@ -16,14 +16,21 @@  -------------------------------------------------- +-- | Mapping of names to type information. type TypeEnv = M.Map Name IDType++--------------------------------------------------++-- Monad for type inference work+type Infer a = State InferState a data InferState = InferState { environ :: TypeEnv, entryPoints :: M.Map Name (Name, Maybe Name) }   deriving Show-type Infer a = State InferState a type InferFunc t = t -> Infer ()  -------------------------------------------------- +-- | Annotate AST nodes with type information and also return a type+-- environment mapping names to type information. analyseTypes :: Data a => ProgramFile (Analysis a) -> (ProgramFile (Analysis a), TypeEnv) analyseTypes pf = fmap environ . runInfer $ do   -- Gather information.@@ -172,202 +179,6 @@  isIxSingle (IxSingle {}) = True isIxSingle _             = False------------------------------------------------------------------------------------------------------------------------------------------ Type mapping definitions-----------------------------------------------------------------------------------data TypeScope = Global | Local ProgramUnitName deriving (Ord,Eq,Show)--data TypeState a = TypeState-  { tsProgramFile :: ProgramFile a-  , tsMapping :: Map TypeScope (Map String IDType) }--type TypeMapping a = State (TypeState a)------------------------------------------------------------------------------------- Monadic helpers-----------------------------------------------------------------------------------getProgramFile :: Data a => TypeMapping a (ProgramFile a)-getProgramFile = fmap tsProgramFile get--putProgramFile :: Data a => ProgramFile a -> TypeMapping a ()-putProgramFile pf = get >>= (\ts -> put $ ts { tsProgramFile = pf })--getMapping :: Data a => TypeMapping a (Map TypeScope (Map String IDType))-getMapping = fmap tsMapping get--queryIDType :: Data a => TypeScope -> String -> TypeMapping a (Maybe IDType)-queryIDType ts s = do-  mapping <- getMapping-  return $ do-    inner <- lookup ts mapping-    lookup s inner--putMapping :: Data a => Map TypeScope (Map String IDType) -> TypeMapping a ()-putMapping mapping = get >>= (\ts -> put $ ts { tsMapping = mapping })--addToMapping :: Data a => TypeScope -> String -> BaseType -> ConstructType -> TypeMapping a ()-addToMapping ts s vt ct = addToMappingViaFunc ts s typeFunction-  where-    typeFunction idt = idt { idVType = Just vt, idCType = Just ct }--addValueToMapping :: Data a => TypeScope -> String -> BaseType -> TypeMapping a ()-addValueToMapping ts s vt = addToMappingViaFunc ts s typeFunction-  where-    typeFunction idt = idt { idVType = Just vt }--addConstructToMapping :: Data a => TypeScope -> String -> ConstructType -> TypeMapping a ()-addConstructToMapping ts s ct = addToMappingViaFunc ts s typeFunction-  where-    typeFunction idt = idt { idCType = Just ct }--addToMappingViaFunc :: Data a => TypeScope -> String -> (IDType -> IDType) -> TypeMapping a ()-addToMappingViaFunc ts s tf = do-  mapping <- getMapping-  let innerMapping = findWithDefault empty ts mapping-  let idType = findWithDefault (IDType Nothing Nothing) s innerMapping-  let newIdType = tf idType-  let newInnerMapping = insert s newIdType innerMapping-  let newMapping = insert ts newInnerMapping mapping-  putMapping newMapping------------------------------------------------------------------------------------- Inference mechanism-----------------------------------------------------------------------------------inferTypes :: Data a => ProgramFile a -> Map TypeScope (Map String IDType)-inferTypes pf = tsMapping . execState (inferGlobal >> inferLocal) $ state-  where-    state = TypeState pf empty--inferGlobal :: Data a => TypeMapping a ()-inferGlobal = do-  (ProgramFile comAndPus _) <- getProgramFile-  let pus = map snd comAndPus-  mapM_ inferSubprograms pus--inferSubprograms :: Data a => ProgramUnit a -> TypeMapping a ()-inferSubprograms pu =-  case pu of-    (PUFunction _ _ mts _ n _ _ _ _) -> do-      addToMappingViaFunc Global n $ updateForFunction mts-      addEntries (updateForFunction mts)-    (PUSubroutine _ _ _ n _ _ _) -> do-      addConstructToMapping Global n CTSubroutine-      addEntries (\idt -> idt { idCType = Just CTSubroutine })-    _ -> return ()-  where-    addEntries :: Data a => (IDType -> IDType) -> TypeMapping a ()-    addEntries func = do-      let statements = universeBi :: Data a => ProgramUnit a -> [Statement a]-      let entryExps = [ e | (StEntry _ _ e _ _) <- statements pu ]-      let entryNames = [ n | n :: String <- universeBi entryExps :: [String] ]-      mapM_ (\n' -> addToMappingViaFunc Global n' func) entryNames-    updateForFunction Nothing it =-      it { idCType = Just CTFunction }-    updateForFunction (Just (TypeSpec _ _ bt _)) it =-      it { idCType = Just CTFunction, idVType = Just bt }--inferLocal :: Data a => TypeMapping a ()-inferLocal = do-  (ProgramFile comAndPus _) <- getProgramFile-  let pus = map snd comAndPus-  mapM_ inferInProgramFile pus--inferInProgramFile :: Data a => ProgramUnit a -> TypeMapping a ()-inferInProgramFile pu = do-  let declPairs = [ (bt, vars) | (StDeclaration _ _ bt _ (AList _ _ vars)) <- universeBi pu ]-  inferFromDeclarations puName declPairs-  let paramSts = [ paramSt | paramSt@StParameter{} <- universeBi pu]-  inferFromParameters puName paramSts-  let dimSts = [ dim | dim@StDimension{} <- universeBi pu]-  inferFromDimensions puName dimSts-  inferFromFuncStatements pu-  where-    puName = Local $ getName pu--inferFromFuncStatements :: Data a => ProgramUnit a -> TypeMapping a ()-inferFromFuncStatements pu = do-  let statements = universeBi :: Data a => ProgramUnit a -> [Statement a]-  let lhsNames = [ s | StExpressionAssign _ _ (ExpSubscript _ _ (ExpValue _ _ (ValVariable s)) _) _ <- statements pu ]-  idts <- mapM (queryIDType puName) lhsNames-  let filteredNames = map fst $ filter p $ zip lhsNames idts-  mapM_ (\n -> addConstructToMapping puName n CTFunction) filteredNames-  let lhsNames = [ s | StFunction _ _ (ExpValue _ _ (ValVariable s)) _ _ <- statements pu ]-  mapM_ (\n -> addConstructToMapping puName n CTFunction) lhsNames-  where-    puName = Local $ getName pu-    -- Predicate makes sure Dimension or Type statements did not register-    -- this Array seeming LHS value as an Array. In which case it can only-    -- be a Function Statement.-    p (_, Nothing) = True-    p (_, (Just (IDType _ Nothing))) = True-    p _ = False--inferFromDimensions :: Data a => TypeScope -> [ Statement a ] -> TypeMapping a ()-inferFromDimensions ts dimSts = do-  let decls = universeBi :: Data a => [Statement a] -> [Declarator a]-  let arrayExps = [ exp | DeclArray _ _ exp _ _ _ <- decls dimSts]-  let arrayNames = [ s | ExpValue _ _ (ValVariable s) <- arrayExps ]-  mapM_ (\n -> addConstructToMapping ts n CTArray) arrayNames--inferFromParameters :: Data a => TypeScope -> [ Statement a ] -> TypeMapping a ()-inferFromParameters ts paramSts = do-  let values = universeBi :: Data a => [ Statement a ] -> [ Declarator a ]-  let paramNames = [ n | DeclVariable _ _ (ExpValue _ _ (ValVariable n)) _ _ <- values paramSts ]-  mapM_ (\n -> addConstructToMapping ts n CTParameter) paramNames--inferFromDeclarations :: Data a => TypeScope -> [ (TypeSpec a, [ Declarator a ]) ] -> TypeMapping a ()-inferFromDeclarations _ [ ] = return ()-inferFromDeclarations ts (((TypeSpec _ _ bt _), decls):ds) = do-  addDecls decls-  inferFromDeclarations ts ds-  where-    addDecls [ ] = return ()-    addDecls (d':ds') = do-      case d' of-        DeclArray _ _ e _ _ _ -> addToMapping ts (expToId e) bt CTArray-        -- Decl variables might also be functions or arrays qualified by-        -- later specifications.-        DeclVariable _ _ e _ _ -> addValueToMapping ts (expToId e) bt-      addDecls ds'-    expToId (ExpValue _ _ (ValVariable s)) = s------------------------------------------------------------------------------------- Utility methods-----------------------------------------------------------------------------------genImplicitMapping :: Data a => ProgramUnit a -> (Char -> Maybe BaseType)-genImplicitMapping pu-  | null impSts = globalImplicitMapping -- Apply default type mappings-  | containsNone impSts = const Nothing -- If IMPLICIT NONE is in-  | otherwise = -- Try all possible mappings.-    tryImps $ map impElToFun impPairs-  where-    statements = universeBi :: Data a => ProgramUnit a -> [Statement a]-    impSts = [ imp | imp@(StImplicit _ _ _) <- statements pu ]-    implists = universeBi :: Data a => ProgramUnit a -> [ImpList a]-    impPairs = join . join . map couple $ ([ (bt,xs) | ((ImpList _ _ (TypeSpec _ _ bt _) (AList _ _ xs))) <- implists pu ])-    couple (a, []) = []-    couple (a, x:xs) = [ (a,x) ] : couple (a, xs)-    containsNone imps = length [ x | x@(StImplicit _ _ Nothing) <- impSts ] == 1-    impElToFun (vt, ImpCharacter _ _ c) c' = if c' == head c then Just vt else Nothing-    impElToFun (vt, ImpRange _ _ c1 c2) c' = if c' >= head c1 && c' <= head c2 then Just vt else Nothing-    tryImps [] c = Nothing-    tryImps (x:xs) c =-      case x c of-        Just bt -> Just bt-        Nothing -> tryImps xs c--globalImplicitMapping :: Char -> Maybe BaseType-globalImplicitMapping c-  | c `elem` "ijklmn" = Just TypeInteger-  | otherwise = Just TypeReal  -------------------------------------------------- 

@@ -109,8 +109,8 @@  PROGRAM_INNER :: { ProgramFile A0 } PROGRAM_INNER-: PROGRAM_UNITS { ProgramFile (reverse $1) [ ] }-| PROGRAM_UNITS BLOCKS { ProgramFile (reverse $1) (reverse $2) }+: PROGRAM_UNITS { ProgramFile (MetaInfo { miVersion = Fortran66 })  (reverse $1) [ ] }+| PROGRAM_UNITS BLOCKS { ProgramFile (MetaInfo { miVersion = Fortran66 })  (reverse $1) (reverse $2) }  PROGRAM_UNITS :: { [ ([ Block A0 ], ProgramUnit A0) ] } PROGRAM_UNITS

@@ -143,8 +143,8 @@  PROGRAM_INNER :: { ProgramFile A0 } PROGRAM_INNER-: PROGRAM_UNITS { ProgramFile (reverse $1) [ ] }-| PROGRAM_UNITS COMMENT_BLOCKS { ProgramFile (reverse $1) (reverse $2) }+: PROGRAM_UNITS { ProgramFile (MetaInfo { miVersion = Fortran77 }) (reverse $1) [ ] }+| PROGRAM_UNITS COMMENT_BLOCKS { ProgramFile (MetaInfo { miVersion = Fortran77 }) (reverse $1) (reverse $2) }  PROGRAM_UNITS :: { [ ([ Block A0 ], ProgramUnit A0) ] } PROGRAM_UNITS

@@ -203,8 +203,8 @@ | PROGRAM_INNER { $1 }  PROGRAM_INNER :: { ProgramFile A0 }-: PROGRAM_UNITS { ProgramFile (reverse $1) [ ] }-| PROGRAM_UNITS COMMENT_BLOCKS { ProgramFile (reverse $1) (reverse $2) }+: PROGRAM_UNITS { ProgramFile (MetaInfo { miVersion = Fortran90 }) (reverse $1) [ ] }+| PROGRAM_UNITS COMMENT_BLOCKS { ProgramFile (MetaInfo { miVersion = Fortran90 }) (reverse $1) (reverse $2) }  PROGRAM_UNITS :: { [ ([ Block A0 ], ProgramUnit A0) ] } : PROGRAM_UNITS PROGRAM_UNIT MAYBE_NEWLINE { ([ ], $2) : $1 }

@@ -1,3 +1,5 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-}@@ -13,7 +15,8 @@ import Control.Applicative  import Data.Typeable-+import Data.Data+import GHC.Generics (Generic) import Language.Fortran.Util.Position  -------------------------------------------------------------------------------@@ -27,7 +30,7 @@                     | Fortran95                     | Fortran2003                     | Fortran2008-                    deriving (Ord, Eq, Show)+                    deriving (Ord, Eq, Show, Data, Typeable, Generic)  data ParanthesesCount = ParanthesesCount   { pcActual :: Integer

@@ -12,7 +12,7 @@  genericGroup :: ([ Block (Analysis a) ] -> [ Block (Analysis a) ]) -> Transform a () genericGroup groupingFunction = do-    modifyProgramFile $ \ (ProgramFile pus e) -> ProgramFile (zip (map fst pus) . map (go . snd) $ pus) e+    modifyProgramFile $ \ (ProgramFile mi pus e) -> ProgramFile mi (zip (map fst pus) . map (go . snd) $ pus) e   where     go pu =       case pu of