camfort 1.1.2 → 1.2.0

raw patch · 36 files changed

+353/−265 lines, 36 filesdep +singletons-basedep +singletons-thdep ~directorydep ~fgldep ~fortran-srcPVP ok

version bump matches the API change (PVP)

Dependencies added: singletons-base, singletons-th

Dependency ranges changed: directory, fgl, fortran-src, ghc-prim, lens, optparse-applicative, sbv, singletons, text, time, verifiable-expressions

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• camfort.cabal +39/−23
• src/Camfort/Analysis/Annotations.hs +1/−1
• src/Camfort/Analysis/CommentAnnotator.hs +24/−21
• src/Camfort/Analysis/ModFile.hs +7/−6
• src/Camfort/Analysis/Simple.hs +13/−5
• src/Camfort/Functionality.hs +1/−1
• src/Camfort/Input.hs +1/−1
• src/Camfort/Output.hs +8/−8
• src/Camfort/Specification/DerivedDataType.hs +10/−17
• src/Camfort/Specification/Hoare/CheckBackend.hs +13/−5
• src/Camfort/Specification/Hoare/Parser.y +3/−2
• src/Camfort/Specification/Hoare/Parser/Types.hs +50/−20
• src/Camfort/Specification/Stencils/Generate.hs +7/−7
• src/Camfort/Specification/Stencils/Synthesis.hs +3/−3
• src/Camfort/Specification/Units/Analysis.hs +20/−23
• src/Camfort/Specification/Units/Analysis/Infer.hs +2/−3
• src/Camfort/Specification/Units/Environment.hs +1/−1
• src/Camfort/Specification/Units/ModFile.hs +1/−2
• src/Camfort/Transformation/CommonBlockElim.hs +17/−28
• src/Camfort/Transformation/EquivalenceElim.hs +27/−24
• src/Language/Fortran/Model/Op/Core.hs +6/−0
• src/Language/Fortran/Model/Op/Core/Core.hs +5/−0
• src/Language/Fortran/Model/Op/Core/Eval.hs +6/−0
• src/Language/Fortran/Model/Op/Core/Match.hs +5/−0
• src/Language/Fortran/Model/Op/Meta.hs +6/−0
• src/Language/Fortran/Model/Repr/Prim.hs +2/−1
• src/Language/Fortran/Model/Singletons.hs +7/−1
• src/Language/Fortran/Model/Translate.hs +24/−34
• src/Language/Fortran/Model/Types.hs +5/−0
• src/Language/Fortran/Model/Types/Match.hs +7/−1
• src/Main.hs +16/−18
• tests/Camfort/Analysis/CommentAnnotatorSpec.hs +2/−2
• tests/Camfort/Specification/Hoare/ParserSpec.hs +1/−1
• tests/Camfort/Specification/Stencils/CheckSpec.hs +2/−2
• tests/Camfort/Specification/StencilsSpec.hs +4/−4

@@ -1,3 +1,10 @@+## 1.2.0 (Oct 12, 2022)++* Improve CLI help behaviour+* Update to fortran-src 0.11.0+* Support GHC 9.0, 9.2, 9.4+* Dropped support for GHC 8.10 and older+ ## 1.1.2 (Oct 09, 2021)  Meta update to provide a release to tie new platform builds to.

@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack  name:           camfort-version:        1.1.2+version:        1.2.0 synopsis:       CamFort - Cambridge Fortran infrastructure description:    CamFort is a tool for the analysis, transformation, verification of Fortran code. category:       Language@@ -23,7 +23,7 @@ license-file:   LICENSE build-type:     Simple tested-with:-    GHC >= 8.4+    GHC == 9.0, GHC == 9.2, GHC == 9.4 extra-source-files:     tests/fixtures/Specification/Stencils/example10.expected.f     tests/fixtures/Specification/Stencils/example10.f@@ -185,8 +185,8 @@   extra-libraries:       flint   build-tools:-      alex ==3.2.*-    , happy ==1.19.*+      alex >=3.1+    , happy >=1.19   build-depends:       GenericPretty >=1.2.2 && <1.3     , array >=0.4 && <0.6@@ -195,11 +195,11 @@     , bytestring >=0.10 && <0.12     , containers >=0.5.0.0 && <0.7     , deepseq ==1.4.*-    , directory >=1.2 && <1.4-    , fgl >=5.6 && <5.8+    , directory >=1.2 && <2+    , fgl >=5.6 && <5.9     , filepath ==1.4.*-    , fortran-src ==0.6.*-    , ghc-prim >=0.3.1.0 && <0.8+    , fortran-src >=0.11.0 && <0.12+    , ghc-prim >=0.3.1.0 && <0.10     , hmatrix ==0.20.*     , lattices >=2.0.0 && <2.1     , lens >=4.15.1 && <6@@ -209,17 +209,19 @@     , parallel ==3.2.*     , pipes ==4.3.*     , pretty >=1.1 && <2-    , sbv >=8.0 && <9-    , singletons >=2.2 && <2.8+    , sbv >=8.0 && <10+    , singletons >=3.0 && <3.2+    , singletons-base >=3.0 && <3.2+    , singletons-th >=3.0 && <3.2     , strict >=0.3.2 && <1     , syb >=0.4 && <0.8     , syz ==0.2.*     , template-haskell >=2.11 && <3-    , text >=0.11.2.3 && <1.3+    , text >=0.11.2.3 && <2.1     , transformers >=0.5.5.0 && <0.6     , uniplate >=1.6.10 && <1.7     , vector >=0.1 && <0.13-    , verifiable-expressions >=0.6.0 && <0.8.0+    , verifiable-expressions >=0.6.2 && <0.8.0     , vinyl >=0.9 && <1.0   default-language: Haskell2010 @@ -227,11 +229,25 @@   main-is: src/Main.hs   ghc-options: -threaded -rtsopts -with-rtsopts=-N   build-depends:-      base >=4.6 && <5+      array >=0.4 && <0.6+    , base >=4.6 && <5+    , binary >=0.8.3.0 && <0.11+    , bytestring >=0.10 && <0.12     , camfort+    , containers >=0.5.0.0 && <0.7     , directory >=1.2 && <2-    , fortran-src ==0.6.*-    , optparse-applicative >=0.14 && <0.16+    , fgl >=5.6 && <5.9+    , filepath ==1.4.*+    , fortran-src >=0.11.0 && <0.12+    , hmatrix ==0.20.*+    , lattices >=2.0.0 && <2.1+    , lens >=4.15.1 && <6+    , mtl >=2.1 && <2.3+    , optparse-applicative >=0.14 && <0.18+    , sbv >=8.0 && <10+    , text >=0.11.2.3 && <2.1+    , uniplate >=1.6.10 && <1.7+    , verifiable-expressions >=0.6.2 && <0.8.0   default-language: Haskell2010  test-suite spec@@ -275,19 +291,19 @@     , camfort     , containers >=0.5.0.0 && <0.7     , directory >=1.2 && <2-    , fgl >=5.6 && <5.8+    , fgl >=5.6 && <5.9     , filepath ==1.4.*-    , fortran-src ==0.6.*+    , fortran-src >=0.11.0 && <0.12     , hmatrix ==0.20.*     , hspec >=2.2 && <3     , lattices >=2.0.0 && <2.1-    , lens >=4.15.1 && <5.1+    , lens >=4.15.1 && <6     , mtl >=2.1 && <2.3-    , sbv >=8.0 && <9+    , sbv >=8.0 && <10     , silently ==1.2.*     , temporary >=1.2.0.4 && <1.4-    , text >=0.11.2.3 && <1.3-    , time >=1.8 && <1.12+    , text >=0.11.2.3 && <2.1+    , time >=1.8 && <1.13     , uniplate >=1.6.10 && <1.7-    , verifiable-expressions >=0.6.0 && <0.8.0+    , verifiable-expressions >=0.6.2 && <0.8.0   default-language: Haskell2010

@@ -39,7 +39,7 @@  import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA-import Language.Fortran.ParserMonad (FortranVersion(Fortran90))+import Language.Fortran.Version (FortranVersion(Fortran90)) import qualified Language.Fortran.Util.Position as FU  type A = Annotation

@@ -16,6 +16,7 @@  {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeApplications #-}  module Camfort.Analysis.CommentAnnotator   ( annotateComments@@ -26,7 +27,7 @@   import Data.Data (Data)-import Data.Generics.Uniplate.Operations+import Data.Generics.Uniplate.Data  import Language.Fortran.AST import Language.Fortran.Util.Position@@ -63,26 +64,6 @@       writeAST a b srcSpan comment     writeASTBlocks b = pure b -    -- | Link all comments to first non-comment in the list.-    joinComments [ ] = [ ]-    joinComments dss@(d:ds)-      | isComment d =-        let (comments, rest) = span isComment dss-            -- Given a list of comments and a list of non-comment blocks which occur-            -- afterward in the code, then link them together (either forward or backward)-            -- returning a pair of processed blocks and unprocessed blocks--            -- pre-condition: first parameter is a list of comments--            -- default uses 'link' to associate every comment to the first following block-            linkMulti = (map (fmap $ flip linker (head rest)) comments, rest)-        in if null rest -- Does the group end with comments-             then comments-             else let (procs, unprocs) = linkMulti-                  in procs ++ joinComments unprocs-      | otherwise = descendBi joinComments d-                    : joinComments ds-     {-| Link all comment blocks to first non-comment block in the list. |-}     linkBlocks :: (Data a, Linkable a) => [ Block a ] -> [ Block a ]     linkBlocks = joinComments@@ -90,6 +71,28 @@     {-| Link all comment 'program units' to first non-comment program unit in the list. |-}     linkProgramUnits :: (Data a, Linkable a) => [ ProgramUnit a ] -> [ ProgramUnit a ]     linkProgramUnits = joinComments++-- | Link all comments to first non-comment in the list.+joinComments+    :: forall f a. (HasComment (f a), Linked f, Linkable a, Functor f, Data (f a))+    => [f a] -> [f a]+joinComments [ ] = [ ]+joinComments dss@(d:ds)+  | isComment d =+    let (comments, rest) = span isComment dss+        -- Given a list of comments and a list of non-comment blocks which occur+        -- afterward in the code, then link them together (either forward or backward)+        -- returning a pair of processed blocks and unprocessed blocks++        -- pre-condition: first parameter is a list of comments++        -- default uses 'link' to associate every comment to the first following block+        linkMulti = (map (fmap $ flip linker (head rest)) comments, rest)+    in if null rest -- Does the group end with comments+         then comments+         else let (procs, unprocs) = linkMulti+              in procs ++ joinComments unprocs+  | otherwise = descendBi @(f a) @[f a] joinComments d : joinComments ds  class ASTEmbeddable a ast where   annotateWithAST :: a -> ast -> a

@@ -45,10 +45,11 @@ import qualified Language.Fortran.Analysis.Renaming as FAR import qualified Language.Fortran.Analysis.Types    as FAT import qualified Language.Fortran.AST               as F-import qualified Language.Fortran.Parser.Any        as FP+import qualified Language.Fortran.Parser            as FP import qualified Language.Fortran.Util.ModFile      as FM import           Language.Fortran.Util.Files        (flexReadFile)-import           Language.Fortran.ParserMonad       (FortranVersion(..))+import           Language.Fortran.Version           (FortranVersion(..)+                                                    ,deduceFortranVersion)  import           Camfort.Analysis.Annotations       (A, unitAnnotation) import           Camfort.Helpers@@ -221,12 +222,12 @@ readParseSrcFile mv mods f = do   -- get file as ByteString, replacing non UTF-8 with space   inp <- flexReadFile f-  let result = case mv of-        Nothing -> FP.fortranParserWithModFiles mods inp f-        Just v  -> FP.fortranParserWithModFilesAndVersion v mods inp f-  case result of+  case FP.byVerWithMods mods v f inp of     Right ast -> pure $ Just (fmap (const unitAnnotation) ast, inp)     Left  err -> print err >> pure Nothing+  where+    v = case mv of Just v' -> v'+                   Nothing -> deduceFortranVersion f  getFortranFiles :: FileOrDir -> IO [String] getFortranFiles dir =

@@ -50,6 +50,7 @@ import Data.Text (unlines, intercalate, pack) import Data.List (sort, nub, nubBy, tails) import GHC.Generics+import qualified Data.List.NonEmpty as NE  import Data.Graph.Inductive @@ -395,15 +396,17 @@           getMissingUse excls (F.BlDo _ _ _ _ _ _ bs _)      = concatMap (getMissingUse excls) bs           getMissingUse excls (F.BlDoWhile _ _ _ _ _ _ bs _) = concatMap (getMissingUse excls) bs           getMissingUse excls (F.BlForall _ _ _ _ _ bs _)    = concatMap (getMissingUse excls) bs-          getMissingUse excls b@(F.BlIf F.Analysis{F.insLabel = Just i} _ _ _ mes bss _)+          getMissingUse excls b@(F.BlIf F.Analysis{F.insLabel = Just i} _ss _l _nm clauses mBlockElse _ml)             -- check If statement conditions-            | any (eligible i (length excls)) es = bads ++ rest-            | otherwise                          = rest+            | any (eligible i (length excls)) conds = bads ++ rest+            | otherwise                             = rest             where-              es = catMaybes mes+              clauses' = NE.toList clauses+              conds  = map fst clauses'+              blocks = mcons mBlockElse $ map snd clauses'               -- find any induction variables that are referenced by If-Elseif expressions               excl' = getExcludes b-              rest = concatMap (getMissingUse (excls ++ excl')) $ concat bss+              rest = concatMap (getMissingUse (excls ++ excl')) $ concat blocks               bads = getMissingUse' excls b           getMissingUse excls b@(F.BlCase F.Analysis{F.insLabel = Just i} _ _ _ e _ bss _)             -- check Case statement scrutinee@@ -478,6 +481,11 @@   let reports = map checkPU (universeBi pf'')    return $!! mconcat reports++-- | /O(1)/. Maybe cons. Borrowed from Agda.+--   @mcons ma as = maybeToList ma ++ as@+mcons :: Maybe a -> [a] -> [a]+mcons ma as = maybe as (:as) ma  -- Look through a piece of AST for the source name of a given var name. findSrcName :: forall a. Data a => F.Name -> F.Block (F.Analysis a) -> Maybe F.Name

@@ -96,7 +96,7 @@ import qualified Language.Fortran.Analysis as FA import qualified Language.Fortran.Analysis.ModGraph as FM import qualified Language.Fortran.Analysis.Renaming as FA-import           Language.Fortran.ParserMonad (FortranVersion(..))+import           Language.Fortran.Version (FortranVersion(..)) import qualified Language.Fortran.Util.ModFile as FM import           Pipes import qualified Pipes.Prelude as P

@@ -41,7 +41,7 @@  import qualified Language.Fortran.AST          as F import           Language.Fortran.Util.ModFile (ModFiles, emptyModFiles)-import           Language.Fortran.ParserMonad  (FortranVersion(..))+import           Language.Fortran.Version      (FortranVersion(..))  import           Camfort.Analysis import           Camfort.Analysis.Annotations

@@ -34,7 +34,7 @@ import qualified Language.Fortran.AST as F import qualified Language.Fortran.PrettyPrint as PP import qualified Language.Fortran.Util.Position as FU-import qualified Language.Fortran.ParserMonad as FPM+import Language.Fortran.Version ( FortranVersion )  import Camfort.Analysis.Annotations import Camfort.Reprint@@ -125,21 +125,21 @@   (uses generic query extension - remember extQ is non-symmetric) -}  refactoring :: Typeable a-            => FPM.FortranVersion+            => FortranVersion             -> a -> SourceText -> StateT FU.Position Identity (SourceText, Bool) refactoring v z inp = ((catchAll inp `extQ` refactoringsForProgramUnits v inp) `extQ` refactoringsForBlocks v inp) $ z   where     catchAll :: SourceText -> a -> StateT FU.Position Identity (SourceText, Bool)     catchAll _ _ = return (B.empty, False) -refactoringsForProgramUnits :: FPM.FortranVersion+refactoringsForProgramUnits :: FortranVersion                             -> SourceText                             -> F.ProgramUnit Annotation                             -> StateT FU.Position Identity (SourceText, Bool) refactoringsForProgramUnits v inp z =    mapStateT (\n -> Identity $ n `evalState` 0) (refactorProgramUnits v inp z) -refactorProgramUnits :: FPM.FortranVersion+refactorProgramUnits :: FortranVersion                      -> SourceText                      -> F.ProgramUnit Annotation                      -> StateT FU.Position (State Int) (SourceText, Bool)@@ -155,14 +155,14 @@  refactorProgramUnits _ _ _ = return (B.empty, False) -refactoringsForBlocks :: FPM.FortranVersion+refactoringsForBlocks :: FortranVersion                       -> SourceText                       -> F.Block Annotation                       -> StateT FU.Position Identity (SourceText, Bool) refactoringsForBlocks v inp z =    mapStateT (\n -> Identity $ n `evalState` 0) (refactorBlocks v inp z) -refactorBlocks :: FPM.FortranVersion+refactorBlocks :: FortranVersion                -> SourceText                -> F.Block Annotation                -> StateT FU.Position (State Int) (SourceText, Bool)@@ -207,13 +207,13 @@ refactorBlocks _ _ _ = return (B.empty, False)  -- Wrapper to fix the type of refactorSyntax to deal with statements-refactorStatements :: FPM.FortranVersion -> SourceText+refactorStatements :: FortranVersion -> SourceText                    -> F.Statement A -> StateT FU.Position (State Int) (SourceText, Bool) refactorStatements = refactorSyntax  refactorSyntax ::    (Typeable s, F.Annotated s, FU.Spanned (s A), PP.IndentablePretty (s A))-   => FPM.FortranVersion -> SourceText+   => FortranVersion -> SourceText    -> s A -> StateT FU.Position (State Int) (SourceText, Bool) refactorSyntax v inp e = do     cursor <- get

@@ -352,15 +352,11 @@   where     (amap, pf', tenv) = analysis mfs pf     vars = S.fromList $ M.keys amap-    vls1 = [ (v, S.singleton $ VInfo (FA.srcName e) srcFile ss)-           | F.DeclArray _ ss e _ _ _ <- universeBi pf' :: [F.Declarator DA]-           , let v = FA.varName e-           , v `S.member` vars ]-    vls2 = [ (v, S.singleton $ VInfo (FA.srcName e) srcFile ss)-           | F.DeclVariable _ ss e _ _ <- universeBi pf' :: [F.Declarator DA]+    vls  = [ (v, S.singleton $ VInfo (FA.srcName e) srcFile ss)+           | F.Declarator _ ss e _ _ _ <- universeBi pf' :: [F.Declarator DA]            , let v = FA.varName e            , v `S.member` vars ]-    vmap = M.fromListWith S.union $ vls1 ++ vls2+    vmap = M.fromListWith S.union vls      specs = [ (spec, b) | DDTAnnotation { ddtSpec = Just spec, ddtBlock = Just b } <- universeBi pf' ] @@ -535,8 +531,8 @@             -- FIXME: character length, what to do             decl' ddAList               | dds <- F.aStrip ddAList-              , null dds  = F.DeclVariable (F.getAnnotation decl) (FU.getSpan decl) (declExp decl) Nothing Nothing-              | otherwise = F.DeclArray (F.getAnnotation decl) (FU.getSpan decl) (declExp decl) ddAList Nothing Nothing+              , null dds  = F.Declarator (F.getAnnotation decl) (FU.getSpan decl) (declExp decl) F.ScalarDecl Nothing Nothing+              | otherwise = F.Declarator (F.getAnnotation decl) (FU.getSpan decl) (declExp decl) (F.ArrayDecl ddAList) Nothing Nothing              -- The list of attributes minus any dimension attributes.             attrs' = descendBi (List.filter (not . isAttrDimension)) attrs@@ -557,8 +553,8 @@                   dimDeclAList = F.AList a ss $ drop dim dimList'                   eachLabel (_, lab')                     | maxDim' == dim &&-                      dim < length dimList' = F.DeclArray a ss (FA.genVar a ss lab') dimDeclAList Nothing mInit-                    | otherwise             = F.DeclVariable a ss (FA.genVar a ss lab') Nothing mInit+                      dim < length dimList' = F.Declarator a ss (FA.genVar a ss lab') (F.ArrayDecl dimDeclAList) Nothing mInit+                    | otherwise             = F.Declarator a ss (FA.genVar a ss lab') F.ScalarDecl Nothing mInit                   labelDecls = map eachLabel . sort $ IM.toList essLabelMap                   in [ F.BlStatement a'' ss' Nothing (F.StType stA stSS Nothing tyName)                      , F.BlStatement a'' ss' Nothing (F.StDeclaration stA stSS nextTy attrs'' (F.AList alA alSS labelDecls))@@ -638,8 +634,7 @@   F.BlStatement a ss _ F.StDeclaration{} | vars <- ofInterest b -> genComment vars ++ [b]     where       ofInterest b' = filter (flip M.member amap . fst) $-        [ (FA.varName e, FA.srcName e) | F.DeclVariable _ _ e _ _ <- universeBi b' :: [F.Declarator DA] ] ++-        [ (FA.varName e, FA.srcName e) | F.DeclArray _ _ e _ _ _ <- universeBi b' :: [F.Declarator DA] ]+        [ (FA.varName e, FA.srcName e) | F.Declarator _ _ e _ _ _ <- universeBi b' :: [F.Declarator DA] ]        genComment = map $ \ var ->         F.BlComment newA newSS . F.Comment . buildCommentText mi space $ marker:genCommentText r var@@ -698,13 +693,11 @@  -- | Pattern matches the expression from the declarator declExp :: F.Declarator a -> F.Expression a-declExp (F.DeclVariable _ _ e _ _) = e-declExp (F.DeclArray _ _ e _ _ _)  = e+declExp (F.Declarator _ _ e _ _ _) = e  -- | Pattern matches the initialiser from the declarator declInitialiser :: F.Declarator a -> Maybe (F.Expression a)-declInitialiser (F.DeclVariable _ _ _ _ me) = me-declInitialiser (F.DeclArray _ _ _ _ _ me)  = me+declInitialiser (F.Declarator _ _ _ _ _ me) = me  -- | Given a parsed specification and variable information, attempts -- to 'distil' the essence of the specification. If there is a problem

@@ -46,6 +46,8 @@ import qualified Language.Fortran.LValue                as F import qualified Language.Fortran.Util.Position         as F +import qualified Data.List.NonEmpty                     as NE+ import           Camfort.Analysis import           Camfort.Analysis.Logger                (Builder, Text) import           Camfort.Helpers.TypeLevel@@ -428,13 +430,13 @@              -- Each variable may have extra information that modifies its type info             declVarsTis <- forM (F.aStrip decls) $ \case-              F.DeclVariable _ _ nameExp declLength mInitialValue -> do+              F.Declarator _ _ nameExp F.ScalarDecl declLength mInitialValue -> do                 return (nameExp,                         topTypeInfo                         & tiDeclaratorLength .~ declLength,                         mInitialValue) -              F.DeclArray _ _ nameExp declDims declLength mInitialValue ->+              F.Declarator _ _ nameExp (F.ArrayDecl declDims) declLength mInitialValue -> do                 return (nameExp,                         topTypeInfo                         & tiDeclaratorLength .~ declLength@@ -530,9 +532,15 @@ genBlock :: FortranTriplet (F.Block HA) -> GenM () genBlock (precond, postcond, bl) = do   case bl of-    F.BlIf _ _ _ _ conds bodies _ -> do-      condsExprs <- traverse (traverse tryTranslateBoolExpr) conds-      multiIfVCs genBody expr (precond, postcond, (zip condsExprs bodies))+    F.BlIf _ _ _ _ clauses mElseBlock _ -> do+      clauses' <- flip traverse clauses $ \(cond, block) ->+          tryTranslateBoolExpr cond >>= \cond' -> pure (Just cond', block)+      let clauses'' = case mElseBlock of+                        Nothing ->+                          NE.toList clauses'+                        Just elseBlock ->+                          NE.toList clauses' ++ [(Nothing, elseBlock)]+      multiIfVCs genBody expr (precond, postcond, clauses'')      F.BlDoWhile _ _ _ _ _ cond body _ -> do       primInvariant <-

@@ -5,6 +5,7 @@ import           Control.Monad.Except  import qualified Language.Fortran.AST as F+import qualified Language.Fortran.Version as F  import           Language.Verification import           Language.Expression.Prop@@ -60,7 +61,7 @@ : decl_aux '(' TYPESPEC '::' tname ')' { AuxDecl $5 $3 }  TYPESPEC :: { F.TypeSpec () }-: tquoted {% parseTypeSpec $1 }+: tquoted {% parseTypeSpec F.Fortran90 $1 }   HOARE :: { PrimSpec () }@@ -90,7 +91,7 @@ | EXPR                  { PFExpr $1 }  EXPR :: { F.Expression () }-: tquoted {% parseExpression $1 }+: tquoted {% parseExpression F.Fortran90 $1 }  { 

@@ -7,15 +7,21 @@ import           Control.Monad.Except import           Data.Data import           Control.Exception-import           Data.List                         (intercalate)+import           Data.List               ( intercalate ) -import qualified Data.ByteString.Char8             as B+import qualified Data.ByteString.Char8    as B -import qualified Language.Fortran.AST              as F-import qualified Language.Fortran.Lexer.FreeForm   as F-import qualified Language.Fortran.Parser.Fortran90 as F-import qualified Language.Fortran.ParserMonad      as F+import qualified Language.Fortran.AST     as F+import           Language.Fortran.Version ( FortranVersion(..) ) +-- for temporary definition defined in new fortran-src version, copied here+import           Language.Fortran.AST ( A0, Statement )+import           Language.Fortran.Parser ( Parser, makeParserFixed, makeParserFree )+import qualified Language.Fortran.Parser.Fixed.Fortran66  as F66+import qualified Language.Fortran.Parser.Fixed.Fortran77  as F77+import qualified Language.Fortran.Parser.Free.Fortran90   as F90+import qualified Language.Fortran.Parser.Free.Fortran95   as F95+import qualified Language.Fortran.Parser.Free.Fortran2003 as F2003  data HoareParseError   = UnmatchedQuote@@ -89,22 +95,46 @@   deriving (Show, Eq, Ord, Typeable, Data)  -- TODO: Make this report errors and deal with source position better-parseExpression :: String -> HoareSpecParser (F.Expression ())-parseExpression expr =-  case F.runParse F.statementParser parseState of-    F.ParseOk (F.StExpressionAssign _ _ _ e) _ -> return e-    _ -> throwError (MalformedExpression expr)+parseExpression :: FortranVersion -> String -> HoareSpecParser (F.Expression ())+parseExpression v strExpr =+  case byVerStmt v "<unknown>" paddedBsExpr of+    Right (F.StExpressionAssign _ _ _ e) -> return e+    _ -> throwError (MalformedExpression strExpr)   where-    paddedExpr = B.pack $ "      a = " ++ expr-    parseState = F.initParseState paddedExpr F.Fortran90 "<unknown>"+    paddedBsExpr = B.pack $ "      a = " ++ strExpr   -- TODO: Make this report errors and deal with source position better-parseTypeSpec :: String -> HoareSpecParser (F.TypeSpec ())-parseTypeSpec ts =-  case F.runParse F.statementParser parseState of-    F.ParseOk (F.StDeclaration _ _ s _ _) _ -> return s-    _ -> throwError (MalformedTypeSpec ts)+parseTypeSpec :: FortranVersion -> String -> HoareSpecParser (F.TypeSpec ())+parseTypeSpec v strTs =+  case byVerStmt v "<unknown>" paddedBsTs of+    Right (F.StDeclaration _ _ s _ _) -> return s+    _ -> throwError (MalformedTypeSpec strTs)   where-    paddedTS = B.pack $ ts ++ " :: dummy"-    parseState = F.initParseState paddedTS F.Fortran90 "<unknown>"+    paddedBsTs = B.pack $ strTs ++ " :: dummy"++--------------------------------------------------------------------------------++f66StmtNoTransform, f77StmtNoTransform, f77eStmtNoTransform, f77lStmtNoTransform,+  f90StmtNoTransform, f95StmtNoTransform, f2003StmtNoTransform+    :: Parser (Statement A0)+f66StmtNoTransform   = makeParserFixed F66.statementParser   Fortran66+f77StmtNoTransform   = makeParserFixed F77.statementParser   Fortran77+f77eStmtNoTransform  = makeParserFixed F77.statementParser   Fortran77Extended+f77lStmtNoTransform  = makeParserFixed F77.statementParser   Fortran77Legacy+f90StmtNoTransform   = makeParserFree  F90.statementParser   Fortran90+f95StmtNoTransform   = makeParserFree  F95.statementParser   Fortran95+f2003StmtNoTransform = makeParserFree  F2003.statementParser Fortran2003++byVerStmt :: FortranVersion -> Parser (Statement A0)+byVerStmt = \case+  Fortran66         -> f66StmtNoTransform+  Fortran77         -> f77StmtNoTransform+  Fortran77Extended -> f77eStmtNoTransform+  Fortran77Legacy   -> f77lStmtNoTransform+  Fortran90         -> f90StmtNoTransform+  Fortran95         -> f95StmtNoTransform+  Fortran2003       -> f2003StmtNoTransform+  v                 -> error $  "Language.Fortran.Parser.byVerStmt: "+                             <> "no parser available for requested version: "+                             <> show v

@@ -243,7 +243,7 @@ convIxToNeighbour :: (Data a) => [Variable] -> F.Index (FA.Analysis a) -> Neighbour convIxToNeighbour _ (F.IxRange _ _ Nothing Nothing Nothing)     = Neighbour "" 0 convIxToNeighbour _ (F.IxRange _ _ Nothing Nothing-                  (Just (F.ExpValue _ _ (F.ValInteger "1")))) = Neighbour "" 0+                  (Just (F.ExpValue _ _ (F.ValInteger "1" _)))) = Neighbour "" 0  convIxToNeighbour ivs (F.IxSingle _ _ _ expr)  = expToNeighbour ivs expr convIxToNeighbour _ _ = NonNeighbour -- indexing expression is a range@@ -285,7 +285,7 @@         | iname `elem` ["modulo", "mod", "amod", "dmod"]         -- We expect that the first parameter to modulo is being treated         -- as an IxSingle element-        , Just (F.Argument _ _ _ e':_) <- fmap F.aStrip subs = e'+        , arg@F.Argument{} : _ <- F.aStrip subs = F.argExprNormalize (F.argumentExpr arg)     replaceModulo e = e      genRHSsubscripts' b =@@ -315,7 +315,7 @@  expToNeighbour ivs (F.ExpBinary _ _ F.Addition                  e@(F.ExpValue _ _ (F.ValVariable _))-                   (F.ExpValue _ _ (F.ValInteger offs)))+                   (F.ExpValue _ _ (F.ValInteger offs _)))     | FA.varName e `elem` ivs = Neighbour (FA.varName e) (read offs)  -- use constant-expression analysis if available@@ -326,7 +326,7 @@     , Just (FAD.ConstInt offs) <- FA.constExp (F.getAnnotation e2) = Neighbour (FA.varName e1) (fromIntegral offs)  expToNeighbour ivs (F.ExpBinary _ _ F.Addition-                  (F.ExpValue _ _ (F.ValInteger offs))+                  (F.ExpValue _ _ (F.ValInteger offs _))                 e@(F.ExpValue _ _ (F.ValVariable _)))     | FA.varName e `elem` ivs = Neighbour (FA.varName e) (read offs) @@ -340,7 +340,7 @@  expToNeighbour ivs (F.ExpBinary _ _ F.Subtraction                  e@(F.ExpValue _ _ (F.ValVariable _))-                   (F.ExpValue _ _ (F.ValInteger offs)))+                   (F.ExpValue _ _ (F.ValInteger offs _)))    | FA.varName e `elem` ivs =          Neighbour (FA.varName e) (if x < 0 then abs x else (- x))              where x = read offs@@ -348,7 +348,7 @@ expToNeighbour ivs expr =   -- Record when there is some kind of relative index on an inducion variable   -- but that is not a neighbourhood index by our definitions-  if null ivs' then Constant (F.ValInteger "0") else NonNeighbour+  if null ivs' then Constant (F.ValInteger "0" Nothing) else NonNeighbour   where     -- set of all induction variables involved in this expression     ivs' = [i | e@(F.ExpValue _ _ F.ValVariable{})@@ -443,7 +443,7 @@       cmp (Constant _) n@Neighbour{}  = Just n       cmp NonNeighbour{} Neighbour{}  = Nothing       cmp Neighbour{} NonNeighbour{}  = Nothing-      cmp _ _                         = Just $ Constant (F.ValInteger "")+      cmp _ _                         = Just $ Constant (F.ValInteger "" Nothing)       rhsBasis = foldrM (zipWithM cmp) (head rhses) (tail rhses)       -- If there is an induction variable on the RHS, then it also occurs on       -- the LHS

@@ -75,14 +75,14 @@ offsetToIx :: F.Name -> Int -> F.Index (FA.Analysis A) offsetToIx v o   | o == absoluteRep-              = F.IxSingle a s Nothing (F.ExpValue a s (F.ValInteger "0"))+              = F.IxSingle a s Nothing (F.ExpValue a s (F.ValInteger "0" Nothing))   | o == 0    = F.IxSingle a s Nothing (F.ExpValue a s (F.ValVariable v))   | o  > 0    = F.IxSingle a s Nothing (F.ExpBinary a s F.Addition                                  (F.ExpValue a s (F.ValVariable v))-                                 (F.ExpValue a s (F.ValInteger $ show o)))+                                 (F.ExpValue a s (F.ValInteger (show o) Nothing)))   | otherwise = F.IxSingle a s Nothing (F.ExpBinary a s F.Subtraction                                  (F.ExpValue a s (F.ValVariable v))-                                 (F.ExpValue a s (F.ValInteger $ show (abs o))))+                                 (F.ExpValue a s (F.ValInteger (show (abs o)) Nothing)))   where     a = (head $ FA.initAnalysis [unitAnnotation]) { FA.insLabel = Just 0 }     s = SrcSpan (Position 0 0 0 "" Nothing) (Position 0 0 0 "" Nothing)

@@ -58,7 +58,7 @@ import qualified Language.Fortran.Analysis.SemanticTypes as FAS import qualified Language.Fortran.Analysis.BBlocks as FAB import qualified Language.Fortran.Analysis.DataFlow as FAD-import           Language.Fortran.Parser.Utils (readReal, readInteger)+import           Language.Fortran.AST.Literal.Real (readRealLit, parseRealLit) import           Language.Fortran.Util.ModFile import qualified Numeric.LinearAlgebra as H -- for debugging import           Prelude hiding (mod)@@ -327,10 +327,12 @@   where     -- Follow the LitMixed rules.     expMixed e = case e of-      F.ExpValue _ _ (F.ValInteger i) | readInteger i == Just 0 -> withLiterals genParamLit e-                                      | otherwise               -> withLiterals genUnitLiteral e-      F.ExpValue _ _ (F.ValReal i) | readReal i == Just 0       -> withLiterals genParamLit e-                                   | otherwise                  -> withLiterals genUnitLiteral e+      F.ExpValue _ _ (F.ValInteger i _)+        | read i == 0 -> withLiterals genParamLit e+        | otherwise   -> withLiterals genUnitLiteral e+      F.ExpValue _ _ (F.ValReal i _)+        | readRealLit i == 0.0 -> withLiterals genParamLit e+        | otherwise            -> withLiterals genUnitLiteral e        F.ExpBinary a s op e1 e2         | op `elem` [F.Multiplication, F.Division] -> case () of@@ -373,20 +375,20 @@  -- | Is it a literal, literally? isLiteral :: F.Expression UA -> Bool-isLiteral (F.ExpValue _ _ (F.ValReal _))    = True-isLiteral (F.ExpValue _ _ (F.ValInteger _)) = True+isLiteral (F.ExpValue _ _ F.ValReal{})    = True+isLiteral (F.ExpValue _ _ F.ValInteger{}) = True -- allow propagated constants to be interpreted as literals isLiteral e                                 = isJust (constExp (F.getAnnotation e))  -- | Is expression a literal and is it non-zero? isLiteralNonZero :: F.Expression UA -> Bool-isLiteralNonZero (F.ExpValue _ _ (F.ValInteger i)) = readInteger i /= Just 0-isLiteralNonZero (F.ExpValue _ _ (F.ValReal i))    = readReal i    /= Just 0+isLiteralNonZero (F.ExpValue _ _ (F.ValInteger i _)) = read        i /= 0+isLiteralNonZero (F.ExpValue _ _ (F.ValReal i _))    = readRealLit i /= 0.0 -- allow propagated constants to be interpreted as literals isLiteralNonZero e = case constExp (F.getAnnotation e) of   Just (FA.ConstInt i)          -> i /= 0-  Just (FA.ConstUninterpInt s)  -> readInteger s /= Just 0-  Just (FA.ConstUninterpReal s) -> readReal s /= Just 0+  Just (FA.ConstUninterpInt s)  -> read s /= 0+  Just (FA.ConstUninterpReal s) -> readRealLit (parseRealLit s) /= 0.0   _                             -> False  isLiteralZero :: F.Expression UA -> Bool@@ -606,14 +608,10 @@     setF2C f u1 u2 = pure . UA.maybeSetUnitInfo u1 $ UA.maybeSetUnitConstraintF2 f u1 u2 e  propagateFunctionCall :: F.Expression UA -> UnitSolver (F.Expression UA)-propagateFunctionCall (F.ExpFunctionCall a s f Nothing)                     = do-  (info, _) <- callHelper f []-  let cons = intrinsicHelper info f []-  pure . UA.setConstraint (ConConj cons) . UA.setUnitInfo info $ F.ExpFunctionCall a s f Nothing-propagateFunctionCall (F.ExpFunctionCall a s f (Just (F.AList a' s' args))) = do+propagateFunctionCall (F.ExpFunctionCall a s f (F.AList a' s' args)) = do   (info, args') <- callHelper f args   let cons = intrinsicHelper info f args'-  pure . UA.setConstraint (ConConj cons) . UA.setUnitInfo info $ F.ExpFunctionCall a s f (Just (F.AList a' s' args'))+  pure . UA.setConstraint (ConConj cons) . UA.setUnitInfo info $ F.ExpFunctionCall a s f (F.AList a' s' args') propagateFunctionCall _ = error "received non-function-call in propagateFunctionCall"  propagateDoSpec :: F.DoSpecification UA -> UnitSolver (F.DoSpecification UA)@@ -640,17 +638,16 @@ propagateStatement :: F.Statement UA -> UnitSolver (F.Statement UA) propagateStatement stmt = case stmt of   F.StExpressionAssign _ _ e1 e2               -> literalAssignmentSpecialCase e1 e2 stmt-  F.StCall a s sub (Just (F.AList a' s' args)) -> do+  F.StCall a s sub (F.AList a' s' args) -> do     (info, args') <- callHelper sub args     let cons = intrinsicHelper info sub args'-    pure . UA.setConstraint (ConConj cons) $ F.StCall a s sub (Just (F.AList a' s' args'))+    pure . UA.setConstraint (ConConj cons) $ F.StCall a s sub (F.AList a' s' args')   F.StDeclaration {}                           -> transformBiM propagateDeclarator stmt   _                                            -> pure stmt  propagateDeclarator :: F.Declarator UA -> UnitSolver (F.Declarator UA) propagateDeclarator decl = case decl of-  F.DeclVariable _ _ e1 _ (Just e2) -> literalAssignmentSpecialCase e1 e2 decl-  F.DeclArray _ _ e1 _ _ (Just e2)  -> literalAssignmentSpecialCase e1 e2 decl+  F.Declarator _ _ e1 _ _ (Just e2) -> literalAssignmentSpecialCase e1 e2 decl   _                                 -> pure decl  -- Allow literal assignment to overload the non-polymorphic@@ -810,8 +807,8 @@ constantExpression expr = fnumToDouble <$> ce expr   where     ce e = case e of-      (F.ExpValue _ _ (F.ValInteger i))        -> FInt <$> readInteger i-      (F.ExpValue _ _ (F.ValReal r))           -> FReal <$> readReal r+      (F.ExpValue _ _ (F.ValInteger i _))      -> Just $ FInt $ read i+      (F.ExpValue _ _ (F.ValReal r _))         -> Just $ FReal $ readRealLit r       (F.ExpBinary _ _ F.Addition e1 e2)       -> liftM2 fAdd (ce e1) (ce e2)       (F.ExpBinary _ _ F.Subtraction e1 e2)    -> liftM2 fSub (ce e1) (ce e2)       (F.ExpBinary _ _ F.Multiplication e1 e2) -> liftM2 fMul (ce e1) (ce e2)

@@ -79,9 +79,8 @@           puInfo   = M.fromList [ (eiVName ei, ei) | ei <- declVariableNamesPU ]       declVariableNamesDecl :: [ExpInfo]       declVariableNamesDecl = flip mapMaybe (universeBi pf :: [F.Declarator UA]) $ \ d -> case d of-        F.DeclVariable _ ss v@(F.ExpValue _ _ (F.ValVariable _)) _ _   -> Just (ExpInfo ss (FA.varName v) (FA.srcName v))-        F.DeclArray    _ ss v@(F.ExpValue _ _ (F.ValVariable _)) _ _ _ -> Just (ExpInfo ss (FA.varName v) (FA.srcName v))-        _                                                             -> Nothing+        F.Declarator _ ss v@(F.ExpValue _ _ (F.ValVariable _)) _ _ _ -> Just (ExpInfo ss (FA.varName v) (FA.srcName v))+        _                                                            -> Nothing       declVariableNamesPU :: [ExpInfo]       declVariableNamesPU = flip mapMaybe (universeBi pf :: [F.ProgramUnit UA]) $ \ pu -> case pu of         F.PUFunction _ ss _ _ _ _ (Just v@(F.ExpValue _ _ (F.ValVariable _))) _ _ -> Just (ExpInfo ss (FA.varName v) (FA.srcName v))

@@ -46,7 +46,7 @@ import           Data.Binary import           Data.Char import           Data.Data-import           Data.Generics.Uniplate.Operations (rewrite)+import           Data.Generics.Uniplate.Data (rewrite) import           Data.List import qualified Data.Map.Strict as M import           Data.Ratio

@@ -97,8 +97,7 @@                                [ FA.varName e | F.BlInterface _ _ (Just e) _ _ _ <- universeBi pf :: [F.Block UA] ]    let puVarNameSet pu = S.fromList $-        [ (FA.varName v, FA.srcName v) | F.DeclVariable _ _ v _ _ <- universeBi pu :: [F.Declarator UA] ] ++-        [ (FA.varName v, FA.srcName v) | F.DeclArray _ _ v _ _ _  <- universeBi pu :: [F.Declarator UA] ]+        [ (FA.varName v, FA.srcName v) | F.Declarator _ _ v _ _ _ <- universeBi pu :: [F.Declarator UA] ]    -- Map of modules -> associated declared variables   let puVarNameMap :: M.Map F.ProgramUnitName (S.Set VV)

@@ -43,7 +43,7 @@ import qualified Language.Fortran.Analysis.SemanticTypes as FAS import qualified Language.Fortran.Analysis.Renaming as FAR import qualified Language.Fortran.Analysis.Types as FAT-import qualified Language.Fortran.ParserMonad as PM+import qualified Language.Fortran.Version as F import qualified Language.Fortran.PrettyPrint as PP import qualified Language.Fortran.Util.Position as FU import           Prelude hiding (mod, init)@@ -83,7 +83,7 @@   logDebug' pfs $ describe $ r ++ r'   pure (pfs'', pfM)   where-    meta = F.MetaInfo PM.Fortran90 ""+    meta = F.MetaInfo F.Fortran90 ""  analyseAndRmCommons :: [F.ProgramFile A]                -> CommonState [F.ProgramFile A]@@ -124,17 +124,7 @@       modify (\(r, infos) -> (r ++ r', info : infos))      typeCommonExprs :: F.Declarator A1 -> (F.Name, TypeInfo)-    typeCommonExprs = \case-      F.DeclVariable _ sp nameExpr _ _ ->-        let var = FA.varName nameExpr-            src = FA.srcName nameExpr-         in case M.lookup var tenv of-              Just (FA.IDType (Just t) (Just ct@FA.CTVariable)) -> (src, (t, ct))-              Just (FA.IDType (Just t) (Just ct@FA.CTArray{}))  -> (src, (t, ct))-              _ -> error $ "Variable '" ++ src-                        ++ "' is of an unknown or higher-order type at: "-                        ++ show sp ++ " " ++ show (M.lookup var tenv)-      F.DeclArray _ sp nameExpr _ _ _ ->+    typeCommonExprs (F.Declarator _ sp nameExpr _ _ _) =         let var = FA.varName nameExpr             src = FA.srcName nameExpr          in case M.lookup var tenv of@@ -256,7 +246,7 @@     inames (F.StInclude _ _ (F.ExpValue _ _ (F.ValString fname)) _) = Just fname     inames _ = Nothing -    importIncludeCommons :: PM.FortranVersion -> F.ProgramUnit A -> F.ProgramUnit A+    importIncludeCommons :: F.FortranVersion -> F.ProgramUnit A -> F.ProgramUnit A     importIncludeCommons v p =         foldl' (flip (matchPUnit v)) p (reduceCollect inames p) @@ -273,7 +263,7 @@       where insertUses' :: [F.Block A] -> [F.Block A]             insertUses' bs = uses ++ bs -    matchPUnit :: PM.FortranVersion -> Filename -> F.ProgramUnit A -> F.ProgramUnit A+    matchPUnit :: F.FortranVersion -> Filename -> F.ProgramUnit A -> F.ProgramUnit A     matchPUnit v fname p =         removeDecls v (map snd tcrs') p'       where@@ -294,7 +284,7 @@      -- Given the list of renamed/coercerd variables form common blocks,     -- remove any declaration sites-    removeDecls :: PM.FortranVersion -> [RenamerCoercer] -> F.ProgramUnit A -> F.ProgramUnit A+    removeDecls :: F.FortranVersion -> [RenamerCoercer] -> F.ProgramUnit A -> F.ProgramUnit A     removeDecls v rcs p = addToProgramUnit v p' remainingAssignments         where      (p', remainingAssignments) = runState (transformBiM (removeDecl rcs) p) []@@ -321,10 +311,9 @@          matchVar :: ([F.Statement A], [F.Declarator A]) -> F.Declarator A                  -> ([F.Statement A], [F.Declarator A])-        -- match on variable or array declaration+        -- match on declaration (care not whether scalar or array)         matchVar (assgnsNew, declsNew) dec = case dec of-          F.DeclVariable _ _ lvar@(F.ExpValue _ _ (F.ValVariable v)) _ init -> doMatchVar lvar v init-          F.DeclArray _ _ lvar@(F.ExpValue _ _ (F.ValVariable v)) _ _ init  -> doMatchVar lvar v init+          F.Declarator _ _ lvar@(F.ExpValue _ _ (F.ValVariable v)) _ _ init  -> doMatchVar lvar v init           _                                                                 -> (assgnsNew, declsNew)           where             doMatchVar lvar v init@@ -341,7 +330,7 @@  -- Adds additional statements to the start of the statement block in a program unit addToProgramUnit ::-   PM.FortranVersion -> F.ProgramUnit A -> [F.Statement A] -> F.ProgramUnit A+   F.FortranVersion -> F.ProgramUnit A -> [F.Statement A] -> F.ProgramUnit A addToProgramUnit v pu stmnts = descendBi (addAfterDecls (map toBlock stmnts)) pu   where     -- Find the point where blocks are non-executable statements@@ -449,10 +438,10 @@       | af ty1 == af ty2 = let (r', c) = coherentCommons' xs ys                                            in (r', c && True)       | otherwise = let r = var1 ++ ":"-                          ++ PP.pprintAndRender PM.Fortran90 (fst ty1) Nothing+                          ++ PP.pprintAndRender F.Fortran90 (fst ty1) Nothing                           ++ "(" ++ show (af ty1) ++ ")"                           ++ " differs from " ++ var2-                          ++ ":" ++ PP.pprintAndRender PM.Fortran90 (fst ty2) Nothing+                          ++ ":" ++ PP.pprintAndRender F.Fortran90 (fst ty2) Nothing                           ++ "(" ++ show (af ty2) ++ ")" ++ "\n"                         (r', _) = coherentCommons' xs ys                     in (r ++ r', False)@@ -476,7 +465,7 @@     r = "Creating module " ++ modname ++ " at " ++ path ++ "\n"     mod = mkModule (F.miVersion meta) modname varTys modname -mkModule :: PM.FortranVersion -> String -> [(F.Name, TypeInfo)] -> String -> F.ProgramUnit A+mkModule :: F.FortranVersion -> String -> [(F.Name, TypeInfo)] -> String -> F.ProgramUnit A mkModule v name vtys fname =     F.PUModule a sp (caml fname) decls Nothing   where@@ -488,13 +477,13 @@     attrs = Just $ F.AList a sp [F.AttrSave a sp]     typespec = FAS.recoverSemTypeTypeSpec a sp v     toDeclarator (v, FA.CTVariable) = F.AList a sp-       [F.DeclVariable a sp-          (F.ExpValue a sp (F.ValVariable (caml name ++ "_" ++ v))) Nothing Nothing]+       [F.Declarator a sp+          (F.ExpValue a sp (F.ValVariable (caml name ++ "_" ++ v))) F.ScalarDecl Nothing Nothing]     toDeclarator (v, FA.CTArray dims) = F.AList a sp-       [F.DeclArray a sp-          (F.ExpValue a sp (F.ValVariable (caml name ++ "_" ++ v))) dimDecls Nothing Nothing]+       [F.Declarator a sp+          (F.ExpValue a sp (F.ValVariable (caml name ++ "_" ++ v))) (F.ArrayDecl dimDecls) Nothing Nothing]        where          dimDecls = F.AList a sp . flip map dims $ \ (lb, ub) -> F.DimensionDeclarator a sp (fmap expr lb) (fmap expr ub)-         expr = F.ExpValue a sp . F.ValInteger . show+         expr x = F.ExpValue a sp $ F.ValInteger (show x) Nothing     toDeclarator (_, ct) = error $ "mkModule: toDeclarator: bad construct type: " ++ show ct     decls = map toDeclBlock vtys

@@ -36,6 +36,8 @@ import qualified Language.Fortran.Analysis.Types as FAT (analyseTypes, TypeEnv) import qualified Language.Fortran.Util.Position as FU +import qualified Debug.Trace+ type EquivalenceRefactoring = PureAnalysis Void Void  type A1 = FA.Analysis Annotation@@ -81,33 +83,34 @@     -- Find all variables/cells that are equivalent to the target     -- of this assignment     eqs <- equivalentsToExpr dstE-    -- If there is only one, then it must refer to itself, so do nothing-    if length eqs <= 1-      then return [b]-    -- If there are more than one, copy statements must be generated-      else do-        (equivs, n) <- get+    Debug.Trace.trace (show (length eqs)) $+        -- If there is only one, then it must refer to itself, so do nothing+        if length eqs <= 1+          then return [b]+        -- If there are more than one, copy statements must be generated+          else do+            (equivs, n) <- get -        -- Remove the destination from the equivalents-        let eqs' = deleteBy (\ x y -> af x == af y) dstE eqs+            -- Remove the destination from the equivalents+            let eqs' = deleteBy (\ x y -> af x == af y) dstE eqs -        -- Make copy statements-        let pos = afterAligned sp-        let copies = map (mkCopy tenv pos dstE) eqs'+            -- Make copy statements+            let pos = afterAligned sp+            let copies = map (mkCopy tenv pos dstE) eqs' -        let (FU.Position ao c l f p) = s1-            reportSpan i =-              let pos' = FU.Position (ao + i) c (l + i) f p-              in (FU.SrcSpan pos' pos')+            let (FU.Position ao c l f p) = s1+                reportSpan i =+                  let pos' = FU.Position (ao + i) c (l + i) f p+                  in (FU.SrcSpan pos' pos') -        forM_ [n..(n + length copies - 1)] $ \i -> do-          origin <- atSpanned (reportSpan i)-          logInfo origin $ "added copy due to refactored equivalence"+            forM_ [n..(n + length copies - 1)] $ \i -> do+              origin <- atSpanned (reportSpan i)+              logInfo origin $ "added copy due to refactored equivalence" -        -- Update refactoring state-        put (equivs, n + length eqs')-        -- Sequence original assignment with new assignments-        return $ b : copies+            -- Update refactoring state+            put (equivs, n + length eqs')+            -- Sequence original assignment with new assignments+            return $ b : copies  addCopysPerBlock tenv x = do    x' <- descendBiM (addCopysPerBlockGroup tenv) x@@ -139,8 +142,8 @@                     where                      call = F.ExpFunctionCall a sp transf argst                      transf = F.ExpValue a sp (F.ValVariable "transfer")-                     argst  = Just (F.AList a sp args)-                     args   = map (F.Argument a sp Nothing) [srcE', dstE']+                     argst  = F.AList a sp args+                     args   = map (F.Argument a sp Nothing . F.ArgExpr) [srcE', dstE']        -- Types are equal, simple a assignment        Just _ -> F.StExpressionAssign a sp dstE' srcE'   where

@@ -8,6 +8,7 @@ {-# LANGUAGE PolyKinds             #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE CPP                   #-}  {-# OPTIONS_GHC -Wall #-} @@ -27,8 +28,13 @@  import           Data.Functor.Compose +#if MIN_VERSION_singletons(3,0,0)+import           Data.List.Singletons+import           GHC.TypeLits.Singletons+#else import           Data.Singletons.Prelude.List import           Data.Singletons.TypeLits+#endif  import           Data.Vinyl import           Data.Vinyl.Curry

@@ -6,13 +6,18 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds             #-} {-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE CPP                   #-}  {-# OPTIONS_GHC -Wall      #-}  -- TODO: Function calls module Language.Fortran.Model.Op.Core.Core where +#if MIN_VERSION_singletons(3,0,0)+import           GHC.TypeLits.Singletons+#else import           Data.Singletons.TypeLits+#endif  import           Data.Vinyl 

@@ -12,6 +12,7 @@ {-# LANGUAGE ScopedTypeVariables    #-} {-# LANGUAGE UndecidableInstances   #-} {-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE CPP                    #-}  {-# OPTIONS_GHC -Wall #-} @@ -25,9 +26,14 @@ import           Data.SBV.Dynamic                     (SVal) import qualified Data.SBV.Dynamic                     as SBV +#if MIN_VERSION_singletons(3,0,0)+import           Data.List.Singletons+import           GHC.TypeLits.Singletons+#else import           Data.Singletons import           Data.Singletons.Prelude.List import           Data.Singletons.TypeLits+#endif  import           Data.Vinyl                           hiding (Field) import           Data.Vinyl.Curry

@@ -10,6 +10,7 @@ {-# LANGUAGE RankNTypes                 #-} {-# LANGUAGE ScopedTypeVariables        #-} {-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE CPP                        #-}  {-# OPTIONS_GHC -Wall #-} @@ -22,8 +23,12 @@  import           Control.Lens +#if MIN_VERSION_singletons(3,0,0)+import           Data.List.Singletons+#else import           Data.Singletons import           Data.Singletons.Prelude.List+#endif  import           Data.Vinyl                          hiding ((:~:), Field) 

@@ -8,6 +8,7 @@ {-# LANGUAGE PolyKinds             #-} {-# LANGUAGE RankNTypes            #-} {-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE CPP                   #-}  {-# OPTIONS_GHC -Wall #-} @@ -28,7 +29,12 @@ import           Data.Vinyl.Functor                  (Lift (..)) import           Data.Vinyl.Lens                     (RElem, rput) ++#if MIN_VERSION_singletons(3,0,0)+import           GHC.TypeLits.Singletons+#else import           Data.Singletons.TypeLits+#endif  import qualified Data.SBV.Dynamic                    as SBV 

@@ -204,8 +204,9 @@   primReprHandlers :: r -> PrimReprHandlers   primReprHandlers env = PrimReprHandlers (primReprHandler env) +  -- note that we must eta expand due to GHC 9.0 simplified subsumption   primReprHandler :: r -> Prim p k a -> PrimReprHandler a-  primReprHandler = unPrimReprHandlers . primReprHandlers+  primReprHandler r p = unPrimReprHandlers (primReprHandlers r) p  newtype PrimReprHandlers =   PrimReprHandlers { unPrimReprHandlers :: forall p k a. Prim p k a -> PrimReprHandler a }

@@ -18,7 +18,7 @@ {-# LANGUAGE CPP                       #-}  -- singletons-2.7 onwards requires StandaloneKindSignatures for TH functions-#if MIN_VERSION_base(4,14,0)+#if MIN_VERSION_singletons(2,7,0) {-# LANGUAGE StandaloneKindSignatures  #-} #endif @@ -56,7 +56,13 @@ -} module Language.Fortran.Model.Singletons where +#if MIN_VERSION_singletons(3,0,0)+import Prelude.Singletons+import Data.Ord.Singletons+#else import Data.Singletons.Prelude+#endif+ import Data.Singletons.TH  $(singletons

@@ -101,8 +101,13 @@ import           Control.Monad.Reader import           Data.Map                             (Map) +#if MIN_VERSION_singletons(3,0,0) import           Data.Singletons+import           Data.List.Singletons                 (Length)+#else+import           Data.Singletons import           Data.Singletons.Prelude.List         (Length)+#endif  import           Data.Vinyl import           Data.Vinyl.Functor                   (Const (..))@@ -112,6 +117,7 @@  import qualified Language.Fortran.Analysis            as F import qualified Language.Fortran.AST                 as F+import           Language.Fortran.AST.Literal.Real    (readRealLit) import qualified Language.Fortran.Util.Position       as F  import           Language.Expression@@ -423,10 +429,7 @@    kindInt <- case mkind of     Nothing -> return 0-    Just (F.ExpValue _ _ (F.ValInteger s)) ->-      case readLitInteger s of-        Just k  -> return k-        Nothing -> throwError ErrBadLiteral+    Just (F.ExpValue _ _ (F.ValInteger s _)) -> return $ read s     _ -> unsupported "kind which isn't an integer literal"    let getKindPrec btName ksl = do@@ -541,11 +544,14 @@ -- annotations of its own. -- -- Do not call on an expression that you don't know to be an 'F.ExpValue'!+--+-- Note that we ignore potential type information in the form of the optional+-- kind parameter for some values. translateValue :: (Monad m, MonadFail m) => F.Expression (F.Analysis ann) -> TranslateT m SomeExpr translateValue e = case e of   F.ExpValue _ _ v -> case v of-    F.ValInteger s -> translateLiteral v PInt64 (fmap fromIntegral . readLitInteger) s-    F.ValReal    s -> translateLiteral v PFloat (fmap realToFrac . readLitReal) s+    F.ValInteger s _ -> translateLiteral v PInt64 (Just . read) s+    F.ValReal    s _ -> translateLiteral v PFloat (Just . readRealLit) s      -- TODO: Auxiliary variables     F.ValVariable nm -> do@@ -555,19 +561,19 @@         Just (Some v'@(FortranVar d _)) -> return (SomePair d (HPure v'))         _                               -> throwError $ ErrVarNotInScope nm -    F.ValLogical s ->-      let intoBool = fmap (\b -> if b then Bool8 1 else Bool8 0) . readLitBool-      in translateLiteral v PBool8 intoBool s+    F.ValLogical s _ ->+      let intoBool b = if b then Bool8 1 else Bool8 0+      in translateLiteral v PBool8 (Just . intoBool) s -    F.ValComplex r c  -> unsupported "complex literal"-    F.ValString s     -> unsupported "string literal"-    F.ValHollerith s  -> unsupported "hollerith literal"-    F.ValIntrinsic nm -> unsupported $ "intrinsic " <> describe nm-    F.ValOperator s   -> unsupported "user-defined operator"-    F.ValAssignment   -> unsupported "interface assignment"-    F.ValType s       -> unsupported "type value"-    F.ValStar         -> unsupported "star value"-    F.ValColon        -> unsupported "colon value"+    F.ValComplex{}     -> unsupported "complex literal"+    F.ValString{}      -> unsupported "string literal"+    F.ValHollerith{}   -> unsupported "hollerith literal"+    F.ValIntrinsic nm  -> unsupported $ "intrinsic " <> describe nm+    F.ValOperator{}    -> unsupported "user-defined operator"+    F.ValAssignment{}  -> unsupported "interface assignment"+    F.ValType{}        -> unsupported "type value"+    F.ValStar{}        -> unsupported "star value"+    F.ValColon{}       -> unsupported "colon value"   _ -> fail "impossible: translateValue called on a non-value"  @@ -670,19 +676,3 @@     Just x  -> return x     Nothing -> unsupported "unary operator"   translateOpApp operator (Const e :& RNil)-------------------------------------------------------------------------------------  Readers for things that are strings in the AST-----------------------------------------------------------------------------------readLitInteger :: String -> Maybe Integer-readLitInteger = readMaybe--readLitReal :: String -> Maybe Double-readLitReal = readMaybe--readLitBool :: String -> Maybe Bool-readLitBool l = case map toLower l of-  ".true."  -> Just True-  ".false." -> Just False-  _         -> Nothing

@@ -9,6 +9,7 @@ {-# LANGUAGE PolyKinds                  #-} {-# LANGUAGE RankNTypes                 #-} {-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE CPP                        #-}  {-# OPTIONS_GHC -Wall #-} @@ -40,7 +41,11 @@ import           Data.Typeable                         (Typeable) import           Data.Word                             (Word8) +#if MIN_VERSION_singletons(3,0,0)+import           GHC.TypeLits.Singletons+#else import           Data.Singletons.TypeLits+#endif  import           Data.Vinyl                            hiding (Field) import           Data.Vinyl.Functor                    hiding (Field)

@@ -10,6 +10,7 @@ {-# LANGUAGE RankNTypes                 #-} {-# LANGUAGE ScopedTypeVariables        #-} {-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE CPP                        #-}  {-# OPTIONS_GHC -Wall #-} @@ -20,8 +21,13 @@ import           Data.Typeable  import           Data.Singletons-import           Data.Singletons.TypeLits import           GHC.TypeLits++#if MIN_VERSION_singletons(3,0,0)+import           GHC.TypeLits.Singletons+#else+import           Data.Singletons.TypeLits+#endif  import           Data.Vinyl                        hiding ((:~:), Field) 

@@ -25,7 +25,7 @@ import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import GHC.Stack-import Language.Fortran.ParserMonad (FortranVersion(..), selectFortranVersion)+import Language.Fortran.Version (FortranVersion(..), selectFortranVersion) import Options.Applicative import System.Directory (getCurrentDirectory) import System.Exit@@ -43,7 +43,7 @@ realMain :: IO () realMain = do   currentDir <- getCurrentDirectory-  cmd <- execParser (info (commandParser currentDir) idm)+  cmd <- customExecParser (prefs showHelpOnEmpty) (info (commandParser currentDir) idm)   code <- runCommand cmd   if code == 0     then exitWith ExitSuccess@@ -457,9 +457,9 @@ commandAlias alias cmdParser = command alias . info cmdParser $ mempty  -- | Helper for building a parser for a group of commands.-commandsParser :: String -> [(String, [String], Parser Command, String)] -> Parser Command-commandsParser groupName commands =-  hsubparser (mconcat (fmap+commandsParser :: String -> String -> [(String, [String], Parser Command, String)] -> Parser Command+commandsParser mv groupName commands =+  hsubparser (metavar mv <> mconcat (fmap                         (\(name, _, cmdParser, description) ->                            (command name . info cmdParser . progDesc $ description))                         commands)@@ -473,7 +473,7 @@           <> internal  analysesParser :: Parser Command-analysesParser = commandsParser "Analysis Commands" analysesCommands+analysesParser = commandsParser "ANALYSIS_COMMAND" "Analysis Commands" analysesCommands   where     analysesCommands =       [ ("count",@@ -534,7 +534,7 @@   refactoringsParser :: Parser Command-refactoringsParser = commandsParser "Refactoring Commands" refactoringsCommands+refactoringsParser = commandsParser "REFACTORING_COMMAND" "Refactoring Commands" refactoringsCommands   where     refactoringsCommands =       [ ("common",            [],      cmdRefactCommon,      "common block elimination")@@ -542,7 +542,7 @@       , ("dead",              [],      cmdRefactDead,        "dead-code elimination") ]  derivedDatatypeParser :: Parser Command-derivedDatatypeParser = commandsParser "Derived Datatype Commands" derivedDatatypeCommands+derivedDatatypeParser = commandsParser "DDT_COMMAND" "Derived Datatype Commands" derivedDatatypeCommands   where     derivedDatatypeCommands =       [ ("ddt-infer",    ["infer-ddt"],    cmdInferDDT,   "infer derived datatypes")@@ -551,20 +551,18 @@       , ("ddt-refactor", ["refactor-ddt"], cmdRefactDDT,  "refactor marked derived datatypes from comments")       , ("ddt-compile",  ["compile-ddt"],  cmdCompileDDT, "compile derived datatypes info")] -topLevelCommands :: Parser Command-topLevelCommands = versionOption-  where versionOption = pure CmdTopVersion <* switch-                        (  long "version"-                        <> short 'v'-                        <> short '?'-                        <> help "show version number")+showVersionParser :: Parser Command+showVersionParser = flag' CmdTopVersion $  long "version"+                                        <> short 'v'+                                        <> short '?'+                                        <> help "show version number"  cmdInit :: FilePath -> Parser Command cmdInit currDir = fmap CmdInit . directoryArgument $   help "project directory" <> value currDir  projectParser :: FilePath -> Parser Command-projectParser currDir = commandsParser "Project Commands" projectCommands+projectParser currDir = commandsParser "PROJECT_COMMAND" "Project Commands" projectCommands   where     projectCommands =       [ ("init", [], cmdInit currDir, "initialize CamFort for the project") ]@@ -576,12 +574,12 @@               <|> analysesParser               <|> refactoringsParser               <|> derivedDatatypeParser-              <|> topLevelCommands)+              <|> showVersionParser )   -- | Current CamFort version. version :: String-version = "1.1.2"+version = "1.2.0"   -- | Full CamFort version string.

@@ -11,7 +11,7 @@ import Control.Monad.Writer.Strict import Data.Data import Language.Fortran.AST-import Language.Fortran.ParserMonad+import Language.Fortran.Version import Language.Fortran.Util.Position import Test.Hspec @@ -61,7 +61,7 @@ varGen :: Name -> Expression A varGen x = ExpValue ea p (ValVariable x) intGen :: Integer -> Expression A-intGen i = ExpValue ea p (ValInteger (show i))+intGen i = ExpValue ea p (ValInteger (show i) Nothing) wrapBlocks :: [Block A] -> ProgramFile A wrapBlocks bs' = ProgramFile (MetaInfo { miVersion = Fortran90, miFilename = "<unknown>" }) [ pu ]   where

@@ -53,7 +53,7 @@         y = fvar "y"         z = fvar "z" -        num n = F.ExpValue () defSpan (F.ValInteger (show n))+        num n = F.ExpValue () defSpan (F.ValInteger (show n) Nothing)          bin o e1 e2 = F.ExpBinary () defSpan o e1 e2         add = bin F.Addition

@@ -17,7 +17,7 @@ import qualified Language.Fortran.Analysis as FA import qualified Language.Fortran.Analysis.BBlocks as FAB import qualified Language.Fortran.Analysis.Renaming as FAR-import           Language.Fortran.Parser.Any (fortranParser)+import           Language.Fortran.Parser as FP import           Language.Fortran.Util.ModFile (emptyModFiles) import           Test.Hspec @@ -123,7 +123,7 @@  checkText :: BS.ByteString -> IO CheckResult checkText text = do-  case fortranParser text "example" of+  case FP.f90 "example" text of     Left x -> fail "received test input with invalid syntax"     Right pf ->       let pf' = getBlocks . fmap (const unitAnnotation) $ pf

@@ -175,7 +175,7 @@       it "consistent (2) a(i,c,j) = b(i,j+1) + b(i,j) \                         \:: forward(depth=1,dim=2)*pointed(dim=1)" $         indicesToSpec' ["i", "j"]-               [Neighbour "i" 0, Constant (F.ValInteger "0"), Neighbour "j" 0]+               [Neighbour "i" 0, Constant (F.ValInteger "0" Nothing), Neighbour "j" 0]                [[offsetToIx "i" 0, offsetToIx "j" 1],                  [offsetToIx "i" 0, offsetToIx "j" 0]]           `shouldBe` (Just $ Specification (Once $ Exact@@ -185,7 +185,7 @@       it "consistent (3) a(i+1,c,j) = b(j,i+1) + b(j,i) \                         \:: backward(depth=1,dim=2)*pointed(dim=1)" $         indicesToSpec' ["i", "j"]-               [Neighbour "i" 1, Constant (F.ValInteger "0"), Neighbour "j" 0]+               [Neighbour "i" 1, Constant (F.ValInteger "0" Nothing), Neighbour "j" 0]                [[offsetToIx "j" 0, offsetToIx "i" 1],                  [offsetToIx "j" 0, offsetToIx "i" 0]]           `shouldBe` (Just $ Specification (Once $ Exact@@ -558,7 +558,7 @@ variationsRel :: [(Neighbour, Neighbour, [[Int]], Multiplicity (Approximation Spatial))] variationsRel =   [   -- Stencil which has non-relative indices in one dimension-    (Neighbour "i" 0, Constant (F.ValInteger "0"), [ [0, absoluteRep], [1, absoluteRep] ]+    (Neighbour "i" 0, Constant (F.ValInteger "0" Nothing), [ [0, absoluteRep], [1, absoluteRep] ]     , Once $ Exact $ Spatial (Sum [Product [Forward 1 1 True]])     )   , (Neighbour "i" 1, Neighbour "j" 0, [ [0,0] ]@@ -582,7 +582,7 @@                    (Just (Spatial (Sum [Product [ Backward 3 1 False                                                 , Centered 0 2 True ]])))) -  , (Constant (F.ValInteger "0"), Neighbour "j" 0, [ [absoluteRep,1], [absoluteRep,0], [absoluteRep,-1] ]+  , (Constant (F.ValInteger "0" Nothing), Neighbour "j" 0, [ [absoluteRep,1], [absoluteRep,0], [absoluteRep,-1] ]     , Once $ Exact $ Spatial (Sum [Product [Centered 1 2 True]])     )   ]