diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,12 @@ +### 0.15.0 (May 04, 2023) + * handle more `INT` intrinsic forms + [#263](https://github.com/camfort/fortran-src/pull/263) + * add more `Language.Fortran.Common.Array` utils + [#263](https://github.com/camfort/fortran-src/pull/263) + * Analysis.SemanticTypes: use `type Dimensions = Dims NonEmpty (Maybe Int)` + instead of `type Dimensions = Dims NonEmpty Int` + [#263](https://github.com/camfort/fortran-src/pull/263) + ### 0.14.0 (Mar 21, 2023) * provide extended evaluated array dimensions type at `Language.Fortran.Common.Array` (#261, @raehik) diff --git a/fortran-src.cabal b/fortran-src.cabal --- a/fortran-src.cabal +++ b/fortran-src.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: fortran-src -version: 0.14.0 +version: 0.15.0 synopsis: Parsers and analyses for Fortran standards 66, 77, 90, 95 and 2003 (partial). description: Provides lexing, parsing, and basic analyses of Fortran code covering standards: FORTRAN 66, FORTRAN 77, Fortran 90, Fortran 95, Fortran 2003 (partial) and some legacy extensions. Includes data flow and basic block analysis, a renamer, and type analysis. For example usage, see the @@ project, which uses fortran-src as its front end. category: Language diff --git a/src/Language/Fortran/Analysis/SemanticTypes.hs b/src/Language/Fortran/Analysis/SemanticTypes.hs --- a/src/Language/Fortran/Analysis/SemanticTypes.hs +++ b/src/Language/Fortran/Analysis/SemanticTypes.hs @@ -52,7 +52,10 @@ deriving stock (Ord, Eq, Show, Data, Generic) deriving anyclass (NFData, Binary, Out) -type Dimensions = Dims NonEmpty Int +-- | The main dimension type is a non-empty list of dimensions where each bound +-- is @'Maybe' 'Int'@. @'Nothing'@ bounds indicate a dynamic bound (e.g. uses +-- a dummy variable). +type Dimensions = Dims NonEmpty (Maybe Int) instance Pretty SemType where pprint' v @@ -81,11 +84,15 @@ -- | Convert 'Dimensions' data type to its previous type synonym -- @(Maybe [(Int, Int)])@. -- --- Will not return @Just []@. +-- Drops all information for array dimensions that aren't fully static/known. dimensionsToTuples :: Dimensions -> Maybe [(Int, Int)] dimensionsToTuples = \case - DimsExplicitShape ds -> - Just $ NonEmpty.toList $ fmap (\(Dim lb ub) -> (lb, ub)) ds + DimsExplicitShape ds -> fmap NonEmpty.toList $ traverse go ds + where + go (Dim mlb mub) = do + lb <- mlb + ub <- mub + pure $ (lb, ub) DimsAssumedSize _ds _d -> Nothing DimsAssumedShape _ss -> Nothing diff --git a/src/Language/Fortran/Common/Array.hs b/src/Language/Fortran/Common/Array.hs --- a/src/Language/Fortran/Common/Array.hs +++ b/src/Language/Fortran/Common/Array.hs @@ -12,6 +12,15 @@ import qualified Language.Fortran.PrettyPrint as F +-- | A single array dimension with bounds of type @a@. +-- +-- * @'Num' a => 'Dim' a@ is a static, known-size dimension. +-- * @'Dim' ('Language.Fortran.AST.Expression' '()')@ is a dimension with +-- unevaluated bounds expressions. Note that these bounds may be constant +-- expressions, or refer to dummy variables, or be invalid. +-- * @'Num' a => 'Dim' ('Maybe' a)@ is a dimension where some bounds are +-- known, and others are not. This may be useful to record some information +-- about dynamic explicit-shape arrays. data Dim a = Dim { dimLower :: a -- ^ Dimension lower bound. , dimUpper :: a -- ^ Dimension upper bound. @@ -31,34 +40,38 @@ instance Out (Dim a) => F.Pretty (Dim a) where pprint' _ = doc --- | Evaluated dimensions of a Fortran array. --- --- A known-length dimension is defined by a lower bound and an upper bound. This --- data type takes a syntactic view, rather than normalizing lower bound to 0 --- and passing just dimension extents. +-- | Fortran array dimensions, defined by a list of 'Dim's storing lower and +-- upper bounds. -- -- You select the list type @t@ (which should be 'Functor', 'Foldable' and --- 'Traversable') and the numeric index type @a@ (e.g. 'Int'). +-- 'Traversable') and the bound type @a@ (e.g. 'Int'). -- --- Note that using a non-empty list type such as 'Data.List.NonEmpty.NonEmpty' --- will disallow representing zero-dimension arrays, which may be useful for --- soundness. +-- Using a non-empty list type such as 'Data.List.NonEmpty.NonEmpty' will +-- disallow representing zero-dimension arrays, providing extra soundness. -- -- Note the following excerpt from the F2018 standard (8.5.8.2 Explicit-shape -- array): -- -- > If the upper bound is less than the lower bound, the range is empty, the -- > extent in that dimension is zero, and the array is of zero size. +-- +-- Note that the 'Foldable' instance does not provide "dimension-like" access to +-- this type. That is, @'length' (a :: 'Dims' t a)@ will _not_ tell you how many +-- dimensions 'a' represents. Use 'dimsLength' for that. data Dims t a + -- | Explicit-shape array. All dimensions are known. = DimsExplicitShape (t (Dim a)) -- ^ list of all dimensions + -- | Assumed-size array. The final dimension has no upper bound (it is + -- obtained from its effective argument). Earlier dimensions may be defined + -- like explicit-shape arrays. | DimsAssumedSize (Maybe (t (Dim a))) -- ^ list of all dimensions except last - a -- ^ lower bound of last dimension + a -- ^ lower bound of last dimension - -- | Assumed-shape array dimensions. Here, we only have the lower bound for - -- each dimension, and the rank (via length). + -- | Assumed-shape array. Shape is taken from effective argument. We store the + -- lower bound for each dimension, and thus also the rank (via list length). | DimsAssumedShape (t a) -- ^ list of lower bounds @@ -105,7 +118,8 @@ instance Out (Dims t a) => F.Pretty (Dims t a) where pprint' _ = doc --- Faster is possible for non-@List@s, but this is OK for the general case. +-- Faster is possible for non @[]@ list-likes, but this is OK for the general +-- case. prettyIntersperse :: Foldable t => Pretty.Doc -> t Pretty.Doc -> Pretty.Doc prettyIntersperse dBetween ds = case foldMap (\d -> [dBetween, d]) ds of @@ -114,3 +128,20 @@ prettyAfter :: Foldable t => Pretty.Doc -> t Pretty.Doc -> Pretty.Doc prettyAfter dAfter = foldMap (\d -> d <> dAfter) + +-- | Traverse over the functor in a 'Dims' value with a functor bound type. +-- +-- For example, to turn a @'Dims' t ('Maybe' a)@ into a @'Maybe' ('Dims' t a)@. +dimsTraverse :: (Traversable t, Applicative f) => Dims t (f a) -> f (Dims t a) +dimsTraverse = traverse id +-- TODO provide a SPECIALIZE clause for the above Maybe case. performance! :) + +-- | How many dimensions does the given 'Dims' represent? +dimsLength :: Foldable t => Dims t a -> Int +dimsLength = \case + DimsExplicitShape ds -> length ds + DimsAssumedShape ss -> length ss + DimsAssumedSize mds _d -> + case mds of + Nothing -> 1 + Just ds -> length ds + 1 diff --git a/src/Language/Fortran/Repr/Eval/Value.hs b/src/Language/Fortran/Repr/Eval/Value.hs --- a/src/Language/Fortran/Repr/Eval/Value.hs +++ b/src/Language/Fortran/Repr/Eval/Value.hs @@ -29,6 +29,7 @@ import qualified Data.Text as Text import qualified Data.Char import qualified Data.Bits +import Data.Int import Control.Monad.Except @@ -45,11 +46,19 @@ = ENoSuchVar F.Name | EKindLitBadType F.Name FType | ENoSuchKindForType String FKindLit + | EUnsupported String + -- ^ Syntax which probably should be supported, but (currently) isn't. + | EOp Op.Error | EOpTypeError String + + | ESpecial String + -- ^ Special value-like expression that we can't evaluate usefully. + | ELazy String -- ^ Catch-all for non-grouped errors. + deriving stock (Generic, Show, Eq) -- | A convenience constraint tuple defining the base requirements of the @@ -156,13 +165,13 @@ warn "requested to evaluate BOZ literal with no context: defaulting to INTEGER(4)" pure $ FSVInt $ FInt4 $ F.bozAsTwosComp boz F.ValHollerith s -> pure $ FSVString $ Text.pack s - F.ValIntrinsic{} -> error "you tried to evaluate a lit, but it was an intrinsic name" - F.ValVariable{} -> error "you tried to evaluate a lit, but it was a variable name" - F.ValOperator{} -> error "you tried to evaluate a lit, but it was a custom operator name" - F.ValAssignment -> error "you tried to evaluate a lit, but it was an overloaded assignment name" - F.ValStar -> error "you tried to evaluate a lit, but it was a star" - F.ValColon -> error "you tried to evaluate a lit, but it was a colon" - F.ValType{} -> error "not used anywhere, don't know what it is" + F.ValIntrinsic{} -> err $ ESpecial "lit was ValIntrinsic{} (intrinsic name)" + F.ValVariable{} -> err $ ESpecial "lit was ValVariable{} (variable name)" + F.ValOperator{} -> err $ ESpecial "lit was ValOperator{} (custom operator name)" + F.ValAssignment -> err $ ESpecial "lit was ValAssignment (overloaded assignment name)" + F.ValStar -> err $ ESpecial "lit was ValStar" + F.ValColon -> err $ ESpecial "lit was ValColon" + F.ValType{} -> err $ ELazy "lit was ValType: not used anywhere, don't know what it is" err :: MonadError Error m => Error -> m a err = throwError @@ -339,21 +348,20 @@ err $ EOpTypeError $ "not: expected INT(x), got "<>show (fScalarValueType v') - "int" -> do - -- TODO a real pain. just implementing common bits for now - -- TODO gfortran actually performs some range checks for constants! - -- @int(128, 1)@ errors with "this INT(4) is too big for INT(1)". - args' <- forceArgs 1 args - let [v] = args' - v' <- forceScalar v - case v' of - FSVInt{} -> - pure $ MkFScalarValue v' - FSVReal r -> - pure $ MkFScalarValue $ FSVInt $ FInt4 $ fRealUOp truncate r - _ -> - err $ EOpTypeError $ - "int: unsupported or unimplemented type: "<>show (fScalarValueType v') + "int" -> + case args of + [] -> err $ EOpTypeError $ "int: expected 1 or 2 arguments, got 0" + [v] -> do + -- @INT(x)@ == @INT(x, 4)@ (F2018 16.9.100:23, pg.381) + (MkFScalarValue . FSVInt . FInt4) <$> evalIntrinsicInt4 v + [v, vk] -> do + vk' <- forceScalar vk + case vk' of + FSVInt vkI -> (MkFScalarValue . FSVInt) <$> evalIntrinsicInt v vkI + _ -> + err $ EOpTypeError $ + "int: kind argument must be INTEGER, got "<>show (fScalarValueType vk') + _ -> err $ EOpTypeError $ "int: expected 1 or 2 arguments, got >2" -- TODO all lies "int2" -> do @@ -371,6 +379,52 @@ _ -> err $ EUnsupported $ "function call: " <> fname +-- TODO 2023-05-03 raehik: gfortran actually performs some range checks for +-- constants! @int(128, 1)@ errors with "this INT(4) is too big for INT(1)". +-- we don't do that currently. just means more plumbing +evalIntrinsicInt :: MonadFEvalValue m => FValue -> FInt -> m FInt +evalIntrinsicInt v = fIntUOp go + where + go :: (MonadFEvalValue m, Num a, Eq a) => a -> m FInt + go = \case + 1 -> FInt1 <$> evalIntrinsicInt1 v + 2 -> FInt2 <$> evalIntrinsicInt2 v + 4 -> FInt4 <$> evalIntrinsicInt4 v + 8 -> FInt8 <$> evalIntrinsicInt8 v + _ -> err $ ELazy "int: kind argument wasn't 1, 2, 4 or 8" + +-- | @INT(a, 1)@ +evalIntrinsicInt1 :: MonadFEvalValue m => FValue -> m Int8 +evalIntrinsicInt1 = evalIntrinsicIntXCoerce coerceToI1 + where coerceToI1 = fIntUOp' id fromIntegral fromIntegral fromIntegral + +-- | @INT(a, 2)@ +evalIntrinsicInt2 :: MonadFEvalValue m => FValue -> m Int16 +evalIntrinsicInt2 = evalIntrinsicIntXCoerce coerceToI2 + where coerceToI2 = fIntUOp' fromIntegral id fromIntegral fromIntegral + +-- | @INT(a, 4)@, @INT(a)@ +evalIntrinsicInt4 :: MonadFEvalValue m => FValue -> m Int32 +evalIntrinsicInt4 = evalIntrinsicIntXCoerce coerceToI4 + where coerceToI4 = fIntUOp' fromIntegral fromIntegral id fromIntegral + +-- | @INT(a, 8)@ +evalIntrinsicInt8 :: MonadFEvalValue m => FValue -> m Int64 +evalIntrinsicInt8 = evalIntrinsicIntXCoerce coerceToI8 + where coerceToI8 = fIntUOp' fromIntegral fromIntegral fromIntegral id + +evalIntrinsicIntXCoerce + :: forall r m + . (MonadFEvalValue m, Integral r) => (FInt -> r) -> FValue -> m r +evalIntrinsicIntXCoerce coerceToIX v = do + v' <- forceScalar v + case v' of + FSVInt i -> pure $ coerceToIX i + FSVReal r -> pure $ fRealUOp truncate r + _ -> + err $ EOpTypeError $ + "int: unsupported or unimplemented type: "<>show (fScalarValueType v') + evalArg :: MonadFEvalValue m => F.Argument a -> m FValue evalArg (F.Argument _ _ _ ae) = case ae of @@ -437,3 +491,7 @@ _ -> err $ EOpTypeError $ "max: unsupported type: "<> show (fScalarValueType vCurMax) + +-- | Evaluate a constant expression (F2018 10.1.12). +evalConstExpr :: MonadFEvalValue m => F.Expression a -> m FValue +evalConstExpr = evalExpr