diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +## 1.1.1 (Sept 24, 2021) + +* Fix Flint interface for Windows +* Update to fortran-src 0.6.0 +* Improve COMMON block elimination (array type support) + ## 1.1.0 (July 06, 2021) * Update fortran-src diff --git a/camfort.cabal b/camfort.cabal --- a/camfort.cabal +++ b/camfort.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: camfort -version: 1.1.0 +version: 1.1.1 synopsis: CamFort - Cambridge Fortran infrastructure description: CamFort is a tool for the analysis, transformation, verification of Fortran code. category: Language @@ -84,6 +84,7 @@ tests/fixtures/Specification/Units/squarePoly1.f90 tests/fixtures/Specification/Units/transfer.f90 tests/fixtures/Transformation/cmn.expected.f90 + tests/fixtures/Transformation/cmnnext.expected.f90 tests/fixtures/Transformation/common.expected.f90 tests/fixtures/Transformation/common.f90 tests/fixtures/Transformation/equiv.expected.f90 @@ -193,7 +194,7 @@ , directory >=1.2 && <1.4 , fgl >=5.6 && <5.8 , filepath ==1.4.* - , fortran-src ==0.5.* + , fortran-src ==0.6.* , ghc-prim >=0.3.1.0 && <0.8 , hmatrix ==0.20.* , lattices >=2.0.0 && <2.1 @@ -225,7 +226,7 @@ base >=4.6 && <5 , camfort , directory >=1.2 && <2 - , fortran-src ==0.5.* + , fortran-src ==0.6.* , optparse-applicative >=0.14 && <0.16 default-language: Haskell2010 @@ -272,7 +273,7 @@ , directory >=1.2 && <2 , fgl >=5.6 && <5.8 , filepath ==1.4.* - , fortran-src ==0.5.* + , fortran-src ==0.6.* , hmatrix ==0.20.* , hspec >=2.2 && <3 , lattices >=2.0.0 && <2.1 diff --git a/src/Camfort/Analysis.hs b/src/Camfort/Analysis.hs --- a/src/Camfort/Analysis.hs +++ b/src/Camfort/Analysis.hs @@ -9,6 +9,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wall #-} @@ -95,7 +96,6 @@ import qualified Control.Monad.State as Lazy import Control.Monad.State.Strict import Control.Monad.Writer -import Control.Monad.Fail import Control.DeepSeq import GHC.Generics (Generic) @@ -111,6 +111,11 @@ import qualified Language.Fortran.Util.Position as F import Camfort.Analysis.Logger + +#if !MIN_VERSION_base(4,13,0) +-- Control.Monad.Fail import is redundant since GHC 8.8.1 +import Control.Monad.Fail +#endif -------------------------------------------------------------------------------- -- Analysis Monad diff --git a/src/Camfort/Analysis/Logger.hs b/src/Camfort/Analysis/Logger.hs --- a/src/Camfort/Analysis/Logger.hs +++ b/src/Camfort/Analysis/Logger.hs @@ -13,6 +13,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wall #-} @@ -91,7 +92,6 @@ import qualified Control.Monad.State as Lazy import Control.Monad.State.Strict import Control.Monad.Writer -import Control.Monad.Fail import Data.Text (Text) import qualified Data.Text.IO as Text @@ -103,6 +103,11 @@ import Text.Read (readMaybe) import qualified Language.Fortran.Util.Position as F + +#if !MIN_VERSION_base(4,13,0) +-- Control.Monad.Fail import is redundant since GHC 8.8.1 +import Control.Monad.Fail +#endif -------------------------------------------------------------------------------- -- 'Describe' class diff --git a/src/Camfort/Specification/Hoare/CheckBackend.hs b/src/Camfort/Specification/Hoare/CheckBackend.hs --- a/src/Camfort/Specification/Hoare/CheckBackend.hs +++ b/src/Camfort/Specification/Hoare/CheckBackend.hs @@ -8,6 +8,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wall #-} module Camfort.Specification.Hoare.CheckBackend @@ -25,7 +27,6 @@ import Control.Exception (Exception (..)) import Control.Lens import Control.Monad.Reader -import Control.Monad.Fail import Control.Monad.State.Strict import Control.Monad.Writer.Lazy import Control.Monad.Trans.Maybe @@ -38,7 +39,7 @@ import Data.Maybe (isJust, maybeToList) import Data.Void (Void) -import Data.SBV (SBool, defaultSMTCfg) +import Data.SBV (SBool) import qualified Language.Fortran.Analysis as F import qualified Language.Fortran.AST as F @@ -62,6 +63,11 @@ import Language.Expression.Prop import Language.Verification import Language.Verification.Conditions + +#if !MIN_VERSION_base(4,13,0) +-- Control.Monad.Fail import is redundant since GHC 8.8.1 +import Control.Monad.Fail +#endif -------------------------------------------------------------------------------- -- Data types diff --git a/src/Camfort/Specification/Hoare/Translate.hs b/src/Camfort/Specification/Hoare/Translate.hs --- a/src/Camfort/Specification/Hoare/Translate.hs +++ b/src/Camfort/Specification/Hoare/Translate.hs @@ -6,6 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wall #-} @@ -35,7 +36,11 @@ import Control.Lens import Control.Monad.Except (MonadError (..)) + +#if !MIN_VERSION_base(4,13,0) +-- Control.Monad.Fail import is redundant since GHC 8.8.1 import Control.Monad.Fail +#endif import qualified Language.Fortran.Analysis as F import qualified Language.Fortran.AST as F diff --git a/src/Camfort/Specification/Units/InferenceBackendFlint.hs b/src/Camfort/Specification/Units/InferenceBackendFlint.hs --- a/src/Camfort/Specification/Units/InferenceBackendFlint.hs +++ b/src/Camfort/Specification/Units/InferenceBackendFlint.hs @@ -14,13 +14,10 @@ limitations under the License. -} -{- - Units of measure extension to Fortran: backend --} - -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Camfort.Specification.Units.InferenceBackendFlint where @@ -33,11 +30,75 @@ import qualified Numeric.LinearAlgebra as H import System.IO.Unsafe (unsafePerformIO) -foreign import ccall unsafe "flint/fmpz_mat.h fmpz_mat_init" fmpz_mat_init :: Ptr FMPZMat -> CLong -> CLong -> IO () +-- | Units of measure extension to Fortran: Flint backend components +-- +-- Some notes on the Flint library to aid comprehension of the original C and +-- this interface: +-- +-- * They use a @typedef TYPE TYPE_t[1]@ convention to do call-by-reference +-- without an explicit pointer. It appears to be an unmentioned convention +-- borrowed from related library & depedency GMP, explained in a GMP doc +-- page: https://gmplib.org/manual/Parameter-Conventions . Any time one of +-- these is a function parameter, it is correct to use 'Ptr a' in Haskell. +-- * Flint extensively uses two typedefs @ulong@ and @slong@, which are "long +-- integers" in unsigned and signed representations respectively. However, +-- the story is more complicated in cross-platform contexts, because 64-bit +-- Linux's @long@s are 64 bits (8 bytes), while 64-bit Windows kept them at +-- 32 bits (4 bytes). That type is 'CLong' in Haskell, and it doesn't match +-- up with Flint's @slong@, so we roll our own newtypes instead. (See the +-- definition for further explanation.) + +-- | @typedef slong fmpz@ +-- +-- GHC's generalized newtype deriving handles deriving all the instances we +-- require for us. +newtype FMPZ = FMPZ { unFMPZ :: SLong } + deriving (Storable, Eq, Ord, Num, Real, Enum, Integral) + +-- | Flint's long signed integer type @slong@ (= GMP's @mp_limb_signed_t@). +-- +-- As described in their Portability doc page +-- https://flintlib.org/doc/portability.html , this replaces @long@ (long signed +-- integer). Importantly, it is *always* 64-bits, regardless of platform. @long@ +-- on Windows is usually 32-bits (whether on a 32-bit or 64-bit install), and +-- you're meant to use @long long@ instead. +-- +-- We tie the typedef to Haskell's 'Int64', since that should be the appropriate +-- size for any regular platform. Better would be to do some CPP or hsc2hs magic +-- to check the size of an @slong@ and use the appropriate Haskell signed +-- integer type. +-- +-- GHC's generalized newtype deriving handles deriving all the instances we +-- require for us. +newtype SLong = SLong { unSLong :: Int64 } + deriving (Storable, Eq, Ord, Num, Real, Enum, Integral) + +{- + typedef struct + { + fmpz * entries; + slong r; + slong c; + fmpz ** rows; + } fmpz_mat_struct; +-} +data FMPZMat + +instance Storable FMPZMat where + sizeOf _ = + sizeOf nullPtr + + sizeOf (undefined :: SLong) + + sizeOf (undefined :: SLong) + + sizeOf nullPtr + alignment _ = alignment (undefined :: SLong) -- TODO: ?? + peek _ = undefined + poke _ = undefined + +foreign import ccall unsafe "flint/fmpz_mat.h fmpz_mat_init" fmpz_mat_init :: Ptr FMPZMat -> SLong -> SLong -> IO () foreign import ccall unsafe "flint/fmpz_mat.h fmpz_mat_set" fmpz_mat_set :: Ptr FMPZMat -> Ptr FMPZMat -> IO () -foreign import ccall unsafe "flint/fmpz_mat.h fmpz_mat_entry" fmpz_mat_entry :: Ptr FMPZMat -> CLong -> CLong -> IO (Ptr CLong) -foreign import ccall unsafe "flint/fmpz.h fmpz_set_si" fmpz_set_si :: Ptr CLong -> CLong -> IO () -foreign import ccall unsafe "flint/fmpz.h fmpz_get_si" fmpz_get_si :: Ptr CLong -> IO CLong +foreign import ccall unsafe "flint/fmpz_mat.h fmpz_mat_entry" fmpz_mat_entry :: Ptr FMPZMat -> SLong -> SLong -> IO (Ptr FMPZ) +foreign import ccall unsafe "flint/fmpz.h fmpz_set_si" fmpz_set_si :: Ptr FMPZ -> SLong -> IO () +foreign import ccall unsafe "flint/fmpz.h fmpz_get_si" fmpz_get_si :: Ptr FMPZ -> IO SLong foreign import ccall unsafe "flint/fmpz_mat.h fmpz_mat_clear" fmpz_mat_clear :: Ptr FMPZMat -> IO () foreign import ccall unsafe "flint/fmpz_mat.h fmpz_mat_print_pretty" fmpz_mat_print_pretty :: Ptr FMPZMat -> IO () foreign import ccall unsafe "flint/fmpz_mat.h fmpz_mat_mul" fmpz_mat_mul :: Ptr FMPZMat -> Ptr FMPZMat -> Ptr FMPZMat -> IO () @@ -47,7 +108,7 @@ -- Initializes the matrix window to be an r2 - r1 by c2 - c1 submatrix -- of mat whose (0,0) entry is the (r1, c1) entry of mat. The memory -- for the elements of window is shared with mat. -foreign import ccall unsafe "flint/fmpz_mat.h fmpz_mat_window_init" fmpz_mat_window_init :: Ptr FMPZMat -> Ptr FMPZMat -> CLong -> CLong -> CLong -> CLong -> IO () +foreign import ccall unsafe "flint/fmpz_mat.h fmpz_mat_window_init" fmpz_mat_window_init :: Ptr FMPZMat -> Ptr FMPZMat -> SLong -> SLong -> SLong -> SLong -> IO () -- Frees the window (leaving underlying matrix alone). foreign import ccall unsafe "flint/fmpz_mat.h fmpz_mat_window_clear" fmpz_mat_window_clear :: Ptr FMPZMat -> IO () @@ -57,51 +118,19 @@ -- Uses fraction-free Gauss-Jordan elimination to set (B, den) to the -- reduced row echelon form of A and returns the rank of A. Aliasing -- of A and B is allowed. r is rank of A. -foreign import ccall unsafe "flint/fmpz_mat.h fmpz_mat_rref" fmpz_mat_rref :: Ptr FMPZMat -> Ptr CLong -> Ptr FMPZMat -> IO CLong +foreign import ccall unsafe "flint/fmpz_mat.h fmpz_mat_rref" fmpz_mat_rref :: Ptr FMPZMat -> Ptr FMPZ -> Ptr FMPZMat -> IO SLong -- r <- fmp_mat_inv B den A -- -foreign import ccall unsafe "flint/fmpz_mat.h fmpz_mat_inv" fmpz_mat_inv :: Ptr FMPZMat -> Ptr CLong -> Ptr FMPZMat -> IO CLong +-- Returns 1 if @A@ is nonsingular and 0 if @A@ is singular. +foreign import ccall unsafe "flint/fmpz_mat.h fmpz_mat_inv" fmpz_mat_inv :: Ptr FMPZMat -> Ptr FMPZ -> Ptr FMPZMat -> IO CInt -- fmpz_mat_hnf H A -- -- H is the Hermite Normal Form of A. foreign import ccall unsafe "flint/fmpz_mat.h fmpz_mat_hnf" fmpz_mat_hnf :: Ptr FMPZMat -> Ptr FMPZMat -> IO () -foreign import ccall unsafe "flint/fmpz_mat.h fmpz_mat_rank" fmpz_mat_rank :: Ptr FMPZMat -> IO CLong - -data FMPZMat - -instance Storable FMPZMat where - sizeOf _ = 4 * sizeOf (undefined :: CLong) - alignment _ = alignment (undefined :: CLong) - peek _ = undefined - poke _ = undefined - --- testFlint :: IO () --- testFlint = do --- traceM "***********************8 testFlint 8***********************" --- alloca $ \ a -> do --- alloca $ \ b -> do --- alloca $ \ den -> do --- let n = 10 --- fmpz_mat_init a n n --- fmpz_mat_init b n n --- forM_ [0..n-1] $ \ i -> do --- forM_ [0..n-1] $ \ j -> do --- e <- fmpz_mat_entry a i j --- fmpz_set_si e (2 * i + j) - --- -- fmpz_mat_mul b a a --- r <- fmpz_mat_rref b den a --- fmpz_mat_print_pretty a --- fmpz_mat_print_pretty b --- d <- peek den --- traceM $ "r = " ++ show r ++ " den = " ++ show d --- fmpz_mat_hnf b a --- fmpz_mat_print_pretty b --- fmpz_mat_clear a --- fmpz_mat_clear b +foreign import ccall unsafe "flint/fmpz_mat.h fmpz_mat_rank" fmpz_mat_rank :: Ptr FMPZMat -> IO SLong rref :: H.Matrix Double -> (H.Matrix Double, Int, Int) rref m = unsafePerformIO $ do @@ -195,7 +224,7 @@ else return Nothing -withMatrix :: H.Matrix Double -> ((CLong, CLong, Ptr FMPZMat) -> IO b) -> IO b +withMatrix :: H.Matrix Double -> ((SLong, SLong, Ptr FMPZMat) -> IO b) -> IO b withMatrix m f = do alloca $ \ outputM -> do let numRows = fromIntegral $ rows m @@ -204,12 +233,12 @@ forM_ [0 .. numRows - 1] $ \ i -> forM_ [0 .. numCols - 1] $ \ j -> do e <- fmpz_mat_entry outputM i j - fmpz_set_si e (floor (m `atIndex` (fromIntegral i, fromIntegral j)) :: CLong) + fmpz_set_si e (floor (m `atIndex` (fromIntegral i, fromIntegral j)) :: SLong) x <- f (numRows, numCols, outputM) fmpz_mat_clear outputM return x -withBlankMatrix :: CLong -> CLong -> (Ptr FMPZMat -> IO b) -> IO b +withBlankMatrix :: SLong -> SLong -> (Ptr FMPZMat -> IO b) -> IO b withBlankMatrix numRows numCols f = do alloca $ \ outputM -> do fmpz_mat_init outputM (fromIntegral numRows) (fromIntegral numCols) @@ -217,7 +246,7 @@ fmpz_mat_clear outputM return x -withWindow :: Ptr FMPZMat -> CLong -> CLong -> CLong -> CLong -> (Ptr FMPZMat -> IO b) -> IO b +withWindow :: Ptr FMPZMat -> SLong -> SLong -> SLong -> SLong -> (Ptr FMPZMat -> IO b) -> IO b withWindow underM r1 c1 r2 c2 f = do alloca $ \ window -> do fmpz_mat_window_init window underM r1 c1 r2 c2 @@ -225,7 +254,7 @@ fmpz_mat_window_clear window return x -flintToHMatrix :: CLong -> CLong -> Ptr FMPZMat -> IO (H.Matrix Double) +flintToHMatrix :: SLong -> SLong -> Ptr FMPZMat -> IO (H.Matrix Double) flintToHMatrix numRows numCols flintM = do lists <- forM [0..numRows-1] $ \ i -> do forM [0..numCols-1] $ \ j -> do @@ -233,17 +262,17 @@ fromIntegral `fmap` fmpz_get_si e return $ H.fromLists lists -pokeM :: Ptr FMPZMat -> CLong -> CLong -> CLong -> IO () +pokeM :: Ptr FMPZMat -> SLong -> SLong -> SLong -> IO () pokeM flintM i j v = do e <- fmpz_mat_entry flintM i j fmpz_set_si e v -peekM :: Ptr FMPZMat -> CLong -> CLong -> IO CLong +peekM :: Ptr FMPZMat -> SLong -> SLong -> IO SLong peekM flintM i j = do e <- fmpz_mat_entry flintM i j fmpz_get_si e -copyMatrix :: Ptr FMPZMat -> Ptr FMPZMat -> CLong -> CLong -> CLong -> CLong -> IO () +copyMatrix :: Ptr FMPZMat -> Ptr FMPZMat -> SLong -> SLong -> SLong -> SLong -> IO () copyMatrix m1 m2 r1 c1 r2 c2 = forM_ [r1 .. r2-1] $ \ i -> forM_ [c1 .. c2-1] $ \ j -> @@ -315,7 +344,7 @@ normHNF' :: H.Matrix Double -> (H.Matrix Double, [Int]) normHNF' m = fmap (map fromIntegral) . unsafePerformIO $ withMatrix m normhnf -normhnf :: (CLong, CLong, Ptr FMPZMat) -> IO (H.Matrix Double, [CLong]) +normhnf :: (SLong, SLong, Ptr FMPZMat) -> IO (H.Matrix Double, [SLong]) normhnf (numRows, numCols, inputM) = do withBlankMatrix numRows numCols $ \ outputM -> do fmpz_mat_hnf outputM inputM @@ -393,7 +422,7 @@ -- rows accordingly to reach RREF -- -- precondition: matrix outputM is in HNF -elemrowscale :: Ptr FMPZMat -> CLong -> CLong -> IO [(CLong, CLong)] +elemrowscale :: Ptr FMPZMat -> SLong -> SLong -> IO [(SLong, SLong)] elemrowscale outputM rank numCols = do -- column indices of leading co-efficients > 1 lcoefs <- filter ((> 1) . head . snd) <$> forM [0 .. rank-1] (\ i -> do @@ -417,7 +446,7 @@ -- just scaled the leading-coefficient to 1 and now we must look to -- see if there are any non-zeroes in the column above the -- leading-coefficient, because that is allowed by HNF. -elemrowadds :: Ptr FMPZMat -> CLong -> CLong -> [(CLong, CLong)] -> IO () +elemrowadds :: Ptr FMPZMat -> SLong -> SLong -> [(SLong, SLong)] -> IO () elemrowadds outputM _ numCols indices = do -- look for non-zero members of the columns above the -- leading-coefficient and wipe them out. @@ -440,7 +469,34 @@ -- add lower row scaled by sf to upper row pokeM outputM i j' (x1 - x2 * sf) --------------------------------------------------- +-------------------------------------------------------------------------------- + +-- testFlint :: IO () +-- testFlint = do +-- traceM "***********************8 testFlint 8***********************" +-- alloca $ \ a -> do +-- alloca $ \ b -> do +-- alloca $ \ den -> do +-- let n = 10 +-- fmpz_mat_init a n n +-- fmpz_mat_init b n n +-- forM_ [0..n-1] $ \ i -> do +-- forM_ [0..n-1] $ \ j -> do +-- e <- fmpz_mat_entry a i j +-- fmpz_set_si e (2 * i + j) + +-- -- fmpz_mat_mul b a a +-- r <- fmpz_mat_rref b den a +-- fmpz_mat_print_pretty a +-- fmpz_mat_print_pretty b +-- d <- peek den +-- traceM $ "r = " ++ show r ++ " den = " ++ show d +-- fmpz_mat_hnf b a +-- fmpz_mat_print_pretty b +-- fmpz_mat_clear a +-- fmpz_mat_clear b + +-------------------------------------------------------------------------------- -- m1 :: H.Matrix Double -- m1 = (8><6) diff --git a/src/Camfort/Transformation/CommonBlockElim.hs b/src/Camfort/Transformation/CommonBlockElim.hs --- a/src/Camfort/Transformation/CommonBlockElim.hs +++ b/src/Camfort/Transformation/CommonBlockElim.hs @@ -123,20 +123,26 @@ let info = (fname, (punitName pname, (commonNameFromAST cname, tcommon))) modify (\(r, infos) -> (r ++ r', info : infos)) - typeCommonExprs :: F.Expression A1 -> (F.Name, TypeInfo) - typeCommonExprs e@(F.ExpValue _ sp (F.ValVariable _)) = - 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) - where - var = FA.varName e - src = FA.srcName e - typeCommonExprs e = error $ "Not expecting a non-variable expression \ - \in expression at: " ++ show (FU.getSpan e) - + 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 _ _ _ -> + 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) {- Comparison functions for common block names and variables -} cmpTLConFName :: TLCommon a -> TLCommon a -> Ordering @@ -192,9 +198,14 @@ groupSortCommonBlock commons = gccs where -- Group by names of the common blocks - gcs = groupBy (\x y -> cmpEq $ cmpTLConBNames x y) commons + gcs = groupCommonBlocksByName commons -- Group within by the different common block variable-type fields gccs = map (sortBy (\y x -> length x `compare` length y) . group . sortBy cmpVarName) gcs + +groupCommonBlocksByName :: [TLCommon A] -> [[TLCommon A]] +groupCommonBlocksByName commons = + groupBy (\x y -> cmpEq $ cmpTLConBNames x y) commons + where cmpEq = (== EQ) mkTLCommonRenamers :: [TLCommon A] -> [(TLCommon A, RenamerCoercer)] @@ -407,23 +418,30 @@ typR = if ty1 == ty2 then Nothing else Just (ty1, ty2) generate _ _ _ = error "Common blocks of different field length\n" +-- Checks whether all commons of the same name (i.e., across program units) +-- are coherent with regards their types, returning a string of errors (if there are any) +-- and a boolean to indicate coherence or not allCoherentCommons :: [TLCommon A] -> (String, Bool) -allCoherentCommons commons = - foldM (\p (c1, c2) -> coherentCommons c1 c2 >>= \p' -> return $ p && p') - True (pairs commons) +allCoherentCommons commons = do + ps <- mapM checkCoherence (groupCommonBlocksByName commons) + return (and ps) where - -- Computes all pairwise combinations - pairs :: [a] -> [(a, a)] - pairs [] = [] - pairs (x:xs) = zip (repeat x) xs ++ pairs xs + checkCoherence :: [TLCommon A] -> (String, Bool) + checkCoherence cs = + foldM (\p (c1, c2) -> coherentCommons c1 c2 >>= \p' -> return $ p && p') True (pairs cs) + -- Computes all pairwise combinations + pairs :: [a] -> [(a, a)] + pairs [] = [] + pairs (x:xs) = zip (repeat x) xs ++ pairs xs coherentCommons :: TLCommon A -> TLCommon A -> (String, Bool) coherentCommons (_, (_, (n1, vtys1))) (_, (_, (n2, vtys2))) = if n1 == n2 - then coherentCommons' vtys1 vtys2 - else error $ "Trying to compare differently named common blocks: " - ++ show n1 ++ " and " ++ show n2 ++ "\n" + then + coherentCommons' vtys1 vtys2 + else error $ "Trying to compare differently named common blocks: " + ++ show n1 ++ " and " ++ show n2 ++ "\n" coherentCommons' :: [(F.Name, TypeInfo)] -> [(F.Name, TypeInfo)] -> (String, Bool) coherentCommons' [] [] = ("", True) diff --git a/src/Language/Fortran/Model/Translate.hs b/src/Language/Fortran/Model/Translate.hs --- a/src/Language/Fortran/Model/Translate.hs +++ b/src/Language/Fortran/Model/Translate.hs @@ -17,6 +17,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE CPP #-} -- TODO: Implement translation for more unsupported language parts @@ -98,7 +99,6 @@ indices, op, rmap, (.>)) import Control.Monad.Except import Control.Monad.Reader -import Control.Monad.Fail hiding (fail) import Data.Map (Map) import Data.Singletons @@ -126,6 +126,11 @@ import Language.Fortran.Model.Types import Language.Fortran.Model.Types.Match import Language.Fortran.Model.Vars + +#if !MIN_VERSION_base(4,13,0) +-- Control.Monad.Fail import is redundant since GHC 8.8.1 +import Control.Monad.Fail hiding (fail) +#endif -------------------------------------------------------------------------------- -- General types diff --git a/tests/Camfort/Transformation/CommonSpec.hs b/tests/Camfort/Transformation/CommonSpec.hs --- a/tests/Camfort/Transformation/CommonSpec.hs +++ b/tests/Camfort/Transformation/CommonSpec.hs @@ -25,7 +25,9 @@ context "common.f90 into common.expect.f90 and foo.f90" $ do expected <- runIO $ readSample "common.expected.f90" expectedMod <- runIO $ readSample "cmn.expected.f90" + expectedMod2 <- runIO $ readSample "cmnnext.expected.f90" + let outFile = samplesBase "common.f90.out" commonFile = samplesBase "common.f90" @@ -42,9 +44,15 @@ actual <- runIO $ readSample "common.f90.out" actualMod <- runIO $ readSample "cmn.f90" + actualMod2 <- runIO $ readSample "cmnnext.f90" + runIO $ removeSample "common.f90.out" runIO $ removeSample "cmn.f90" + runIO $ removeSample "cmnnext.f90" + it "it eliminates common statement" $ - actual `shouldBe` expected + actual `shouldBe` expected it "it produces a correct module file" $ - actualMod `shouldBe` expectedMod + actualMod `shouldBe` expectedMod + it "it produces a correct module file (2)" $ + actualMod2 `shouldBe` expectedMod2 diff --git a/tests/fixtures/Transformation/cmnnext.expected.f90 b/tests/fixtures/Transformation/cmnnext.expected.f90 new file mode 100644 --- /dev/null +++ b/tests/fixtures/Transformation/cmnnext.expected.f90 @@ -0,0 +1,4 @@ +module Cmnnext + integer, save :: Cmnnext_c4 + real, save :: Cmnnext_c5 +end module Cmnnext diff --git a/tests/fixtures/Transformation/common.expected.f90 b/tests/fixtures/Transformation/common.expected.f90 --- a/tests/fixtures/Transformation/common.expected.f90 +++ b/tests/fixtures/Transformation/common.expected.f90 @@ -1,6 +1,8 @@ subroutine test(a,b, c) +use Cmnnext, c4 => Cmnnext_c4, c5 => Cmnnext_c5 use Cmn, c1 => Cmn_c1, c2 => Cmn_c2, c3 => Cmn_c3 + real :: a, b, c diff --git a/tests/fixtures/Transformation/common.f90 b/tests/fixtures/Transformation/common.f90 --- a/tests/fixtures/Transformation/common.f90 +++ b/tests/fixtures/Transformation/common.f90 @@ -3,6 +3,10 @@ integer :: c1, c2, c3 COMMON /cmn/ c1, c2, c3 +integer :: c4 +real :: c5 +COMMON /cmnNext/ c4, c5 + real :: a, b, c print *, a, b, c