{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} module Language.Fortran.Intrinsics ( getVersionIntrinsics, getIntrinsicReturnType, getIntrinsicNames, getIntrinsicDefsUses, isIntrinsic , IntrinsicType(..), IntrinsicsTable, allIntrinsics ) where import qualified Data.Map.Strict as M import Data.Data import Data.List import GHC.Generics (Generic) import Language.Fortran.ParserMonad (FortranVersion(..)) data IntrinsicType = ITReal | ITInteger | ITComplex | ITDouble | ITLogical | ITCharacter | ITParam Int deriving (Show, Eq, Ord, Typeable, Generic) data IntrinsicsEntry = IEntry { iType :: IntrinsicType, iDefsUses :: ([Int], [Int]) } deriving (Show, Eq, Ord, Typeable, Generic) mkIEntry ty du = IEntry ty du type IntrinsicsTable = M.Map String IntrinsicsEntry -- Main table of Fortran intrinsics by version fortranVersionIntrinsics = [ (Fortran66, fortran77intrinsics) -- FIXME: find list of original '66 intrinsics , (Fortran77, fortran77intrinsics) , (Fortran90, fortran90intrinisics) ] -- | Obtain set of intrinsics that are most closely aligned with given version. getVersionIntrinsics :: FortranVersion -> IntrinsicsTable getVersionIntrinsics v = snd . last . filter ((<= v) . fst) . sort $ fortranVersionIntrinsics getIntrinsicReturnType :: String -> IntrinsicsTable -> Maybe IntrinsicType getIntrinsicReturnType i = fmap iType . M.lookup i getIntrinsicDefsUses :: String -> IntrinsicsTable -> Maybe ([Int], [Int]) getIntrinsicDefsUses i = fmap iDefsUses . M.lookup i getIntrinsicNames :: IntrinsicsTable -> [String] getIntrinsicNames = M.keys isIntrinsic :: String -> IntrinsicsTable -> Bool isIntrinsic = M.member allIntrinsics :: IntrinsicsTable allIntrinsics = M.unions (map snd fortranVersionIntrinsics) func1 = ([0],[1]) func2 = ([0],[1,2]) func3 = ([0],[1,2,3]) func4 = ([0],[1,2,3,4]) funcN = func2 -- FIXME: implement arbitrary-# parameter functions -- | name => (return-unit, parameter-units) -- This is an exhaustive list of intrinsics listed in 15.10 of X3.9-1978 fortran77intrinsics :: IntrinsicsTable fortran77intrinsics = M.fromList [ ("int" , mkIEntry ITInteger func1) , ("ifix" , mkIEntry ITInteger func1) , ("idint" , mkIEntry ITInteger func1) , ("real" , mkIEntry ITReal func1) , ("float" , mkIEntry ITReal func1) , ("sngl" , mkIEntry ITReal func1) , ("dble" , mkIEntry ITDouble func1) , ("cmplx" , mkIEntry ITComplex func1) , ("ichar" , mkIEntry ITInteger func1) , ("char" , mkIEntry ITCharacter func1) , ("aint" , mkIEntry (ITParam 1) func1) , ("dint" , mkIEntry ITDouble func1) , ("anint" , mkIEntry (ITParam 1) func1) , ("dnint" , mkIEntry ITDouble func1) , ("nint" , mkIEntry (ITParam 1) func1) , ("idnint" , mkIEntry ITDouble func1) , ("abs" , mkIEntry (ITParam 1) func1) , ("iabs" , mkIEntry ITInteger func1) , ("dabs" , mkIEntry ITDouble func1) , ("cabs" , mkIEntry ITComplex func1) , ("mod" , mkIEntry (ITParam 1) func2) , ("amod" , mkIEntry ITReal func2) , ("dmod" , mkIEntry ITDouble func2) , ("sign" , mkIEntry (ITParam 1) func2) , ("isign" , mkIEntry ITInteger func2) , ("dsign" , mkIEntry ITDouble func2) , ("dim" , mkIEntry (ITParam 1) func2) , ("idim" , mkIEntry ITInteger func2) , ("ddim" , mkIEntry ITDouble func2) , ("dprod" , mkIEntry ITDouble func2) , ("max" , mkIEntry (ITParam 1) funcN) , ("max0" , mkIEntry ITInteger funcN) , ("amax1" , mkIEntry ITReal funcN) , ("dmax1" , mkIEntry ITDouble funcN) , ("amax0" , mkIEntry ITReal funcN) , ("max1" , mkIEntry ITInteger funcN) , ("min" , mkIEntry (ITParam 1) funcN) , ("min0" , mkIEntry ITInteger funcN) , ("amin1" , mkIEntry ITReal funcN) , ("dmin1" , mkIEntry ITDouble funcN) , ("amin0" , mkIEntry ITReal funcN) , ("min1" , mkIEntry ITInteger funcN) , ("len" , mkIEntry ITInteger func1) , ("index" , mkIEntry ITInteger func2) , ("aimag" , mkIEntry ITReal func1) , ("conjg" , mkIEntry ITComplex func1) , ("sqrt" , mkIEntry (ITParam 1) func1) , ("dsqrt" , mkIEntry ITDouble func1) , ("csqrt" , mkIEntry ITComplex func1) , ("exp" , mkIEntry (ITParam 1) func1) , ("dexp" , mkIEntry ITDouble func1) , ("cexp" , mkIEntry ITComplex func1) , ("log" , mkIEntry (ITParam 1) func1) , ("alog" , mkIEntry ITReal func1) , ("dlog" , mkIEntry ITDouble func1) , ("clog" , mkIEntry ITComplex func1) , ("log10" , mkIEntry (ITParam 1) func1) , ("alog10" , mkIEntry ITReal func1) , ("dlog10" , mkIEntry ITDouble func1) , ("sin" , mkIEntry (ITParam 1) func1) , ("dsin" , mkIEntry ITDouble func1) , ("csin" , mkIEntry ITComplex func1) , ("cos" , mkIEntry (ITParam 1) func1) , ("dcos" , mkIEntry ITDouble func1) , ("ccos" , mkIEntry ITComplex func1) , ("tan" , mkIEntry (ITParam 1) func1) , ("dtan" , mkIEntry ITDouble func1) , ("asin" , mkIEntry (ITParam 1) func1) , ("dasin" , mkIEntry ITDouble func1) , ("acos" , mkIEntry (ITParam 1) func1) , ("dacos" , mkIEntry ITDouble func1) , ("atan" , mkIEntry (ITParam 1) func1) , ("datan" , mkIEntry ITDouble func1) , ("atan2" , mkIEntry (ITParam 1) func2) , ("datan2" , mkIEntry ITDouble func2) , ("sinh" , mkIEntry (ITParam 1) func1) , ("dsinh" , mkIEntry ITDouble func1) , ("cosh" , mkIEntry (ITParam 1) func1) , ("dcosh" , mkIEntry ITDouble func1) , ("tanh" , mkIEntry (ITParam 1) func1) , ("dtanh" , mkIEntry ITDouble func1) , ("lge" , mkIEntry ITLogical func2) , ("lgt" , mkIEntry ITLogical func2) , ("lle" , mkIEntry ITLogical func2) , ("llt" , mkIEntry ITLogical func2) -- https://gcc.gnu.org/onlinedocs/gfortran/Argument-list-functions.html , ("%loc", mkIEntry (ITParam 1) func1) , ("%ref", mkIEntry (ITParam 1) func1) , ("%val", mkIEntry (ITParam 1) func1) ] fortran90intrinisics :: IntrinsicsTable fortran90intrinisics = fortran77intrinsics `M.union` M.fromList [ ("present" , mkIEntry (ITLogical) func1) , ("modulo" , mkIEntry (ITParam 1) func2) , ("ceiling" , mkIEntry (ITParam 1) func1) , ("iand" , mkIEntry (ITInteger) func2) , ("ior" , mkIEntry (ITInteger) func2) , ("ieor" , mkIEntry (ITInteger) func2) , ("iany" , mkIEntry (ITInteger) func2) , ("ibclr" , mkIEntry (ITInteger) func2) , ("ibits" , mkIEntry (ITInteger) func3) , ("ibset" , mkIEntry (ITInteger) func2) , ("ishftc" , mkIEntry (ITInteger) func3) , ("btest" , mkIEntry (ITInteger) func2) , ("not" , mkIEntry (ITInteger) func1) , ("dot_product" , mkIEntry (ITParam 1) func2) , ("matmul" , mkIEntry (ITParam 1) func2) , ("all" , mkIEntry ITLogical func2) , ("any" , mkIEntry ITLogical func2) , ("count" , mkIEntry ITInteger func2) , ("maxval" , mkIEntry (ITParam 1) func3) , ("minval" , mkIEntry (ITParam 1) func3) , ("product" , mkIEntry (ITParam 1) func3) , ("sum" , mkIEntry (ITParam 1) func3) , ("allocated" , mkIEntry ITLogical func1) , ("lbound" , mkIEntry ITInteger func2) , ("ubound" , mkIEntry ITInteger func2) , ("shape" , mkIEntry ITInteger func1) , ("size" , mkIEntry ITInteger func2) , ("merge" , mkIEntry ITInteger func3) , ("pack" , mkIEntry (ITParam 3) func3) , ("spread" , mkIEntry (ITParam 1) func3) , ("unpack" , mkIEntry (ITParam 3) func3) , ("reshape" , mkIEntry (ITParam 1) func4) , ("eoshift" , mkIEntry (ITParam 1) func4) , ("transpose" , mkIEntry (ITParam 1) func1) , ("maxloc" , mkIEntry (ITParam 1) func2) , ("minloc" , mkIEntry (ITParam 1) func2) ]