camfort 1.1.0 → 1.1.1

raw patch · 13 files changed

+221/−96 lines, 13 filesdep ~fortran-srcPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: fortran-src

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• camfort.cabal +5/−4
• src/Camfort/Analysis.hs +6/−1
• src/Camfort/Analysis/Logger.hs +6/−1
• src/Camfort/Specification/Hoare/CheckBackend.hs +8/−2
• src/Camfort/Specification/Hoare/Translate.hs +5/−0
• src/Camfort/Specification/Units/InferenceBackendFlint.hs +116/−60
• src/Camfort/Transformation/CommonBlockElim.hs +43/−25
• src/Language/Fortran/Model/Translate.hs +6/−1
• tests/Camfort/Transformation/CommonSpec.hs +10/−2
• tests/fixtures/Transformation/cmnnext.expected.f90 +4/−0
• tests/fixtures/Transformation/common.expected.f90 +2/−0
• tests/fixtures/Transformation/common.f90 +4/−0

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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)

@@ -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

@@ -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

@@ -0,0 +1,4 @@+module Cmnnext+  integer, save :: Cmnnext_c4+  real, save :: Cmnnext_c5+end module Cmnnext

@@ -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 

@@ -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