{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}
module Language.Fortran.Vars.TypeCheck
( Kind
, TypeError(..)
, TypeOf
, typeOf
)
where
import Prelude hiding ( GT
, EQ
, LT
)
import qualified Data.Map as M
import Data.Data ( toConstr )
import Data.Maybe ( fromJust )
import Language.Fortran.AST ( Expression(..)
, Value(..)
, AList(..)
, aStrip
, aStrip'
, Argument(..)
, argExprNormalize
, DoSpecification(..)
, Statement(..)
, Name
, BinaryOp(..)
, Index(..)
)
import Language.Fortran.AST.Literal ( KindParam(..) )
import Language.Fortran.AST.Literal.Real
( RealLit(..)
, Exponent(..)
, ExponentLetter(..)
)
import Language.Fortran.AST.Literal.Complex
( ComplexLit(..)
, ComplexPart(..)
)
import Language.Fortran.Intrinsics ( getVersionIntrinsics
, getIntrinsicReturnType
, IntrinsicType(..)
)
import Language.Fortran.Version ( FortranVersion(..) )
import Language.Fortran.Util.Position ( SrcSpan
, getSpan
)
import Language.Fortran.Vars.Types ( SymbolTableEntry(..)
, ExpVal(..)
, SymbolTable
, StructureTable
, Kind
, Type
, SemType(..)
, CharacterLen(..)
, TypeError(..)
, TypeOf
, typeError
)
import Language.Fortran.Vars.Kind ( getTypeKind
, setTypeKind
, toInt
)
import Language.Fortran.Vars.Eval ( eval' )
import Language.Fortran.Vars.StructureTable
( lookupField )
import Language.Fortran.Analysis.SemanticTypes
( charLenConcat )
typeOf :: StructureTable -> SymbolTable -> Expression a -> Either TypeError Type
typeOf :: forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strTable SymbolTable
symTable Expression a
expr = case Expression a
expr of
ExpValue a
_ SrcSpan
_ (ValVariable String
name) -> SymbolTable -> String -> Either TypeError Type
typeOfSymbol SymbolTable
symTable String
name
ExpValue a
_ SrcSpan
s Value a
val -> SrcSpan
-> StructureTable
-> SymbolTable
-> Value a
-> Either TypeError Type
forall a.
SrcSpan
-> StructureTable
-> SymbolTable
-> Value a
-> Either TypeError Type
typeOfValue SrcSpan
s StructureTable
strTable SymbolTable
symTable Value a
val
ExpUnary a
_ SrcSpan
_ UnaryOp
_ Expression a
e -> StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strTable SymbolTable
symTable Expression a
e
ExpBinary a
_ SrcSpan
s BinaryOp
op Expression a
e1 Expression a
e2 -> SrcSpan
-> StructureTable
-> SymbolTable
-> BinaryOp
-> Expression a
-> Expression a
-> Either TypeError Type
forall a.
SrcSpan
-> StructureTable
-> SymbolTable
-> BinaryOp
-> Expression a
-> Expression a
-> Either TypeError Type
typeOfBinaryExp SrcSpan
s StructureTable
strTable SymbolTable
symTable BinaryOp
op Expression a
e1 Expression a
e2
ExpFunctionCall a
_ SrcSpan
_ (ExpValue a
_ SrcSpan
s (ValVariable String
name)) AList Argument a
args ->
SrcSpan
-> StructureTable
-> SymbolTable
-> String
-> [Argument a]
-> Either TypeError Type
forall a.
SrcSpan
-> StructureTable
-> SymbolTable
-> String
-> [Argument a]
-> Either TypeError Type
typeOfFunctionCall SrcSpan
s StructureTable
strTable SymbolTable
symTable String
name (AList Argument a -> [Argument a]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList Argument a
args)
ExpFunctionCall a
_ SrcSpan
_ (ExpValue a
_ SrcSpan
s (ValIntrinsic String
name)) AList Argument a
args ->
SrcSpan
-> StructureTable
-> SymbolTable
-> String
-> [Argument a]
-> Either TypeError Type
forall a.
SrcSpan
-> StructureTable
-> SymbolTable
-> String
-> [Argument a]
-> Either TypeError Type
typeOfFunctionCall SrcSpan
s StructureTable
strTable SymbolTable
symTable String
name (AList Argument a -> [Argument a]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList Argument a
args)
ExpSubscript a
_ SrcSpan
s Expression a
arr (AList a
_ SrcSpan
_ args :: [Index a]
args@(IxSingle{} : [Index a]
_)) ->
let isIxRange :: Index a -> Bool
isIxRange = \case
IxRange{} -> Bool
True
Index a
_ -> Bool
False
in if (Index a -> Bool) -> [Index a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Index a -> Bool
forall {a}. Index a -> Bool
isIxRange [Index a]
args
then TypeError -> Either TypeError Type
forall a b. a -> Either a b
Left (TypeError -> Either TypeError Type)
-> (String -> TypeError) -> String -> Either TypeError Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> String -> TypeError
typeError SrcSpan
s (String -> Either TypeError Type)
-> String -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ String
"Unexpected array range"
else case StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strTable SymbolTable
symTable Expression a
arr of
Right (TArray Type
ty Maybe Dimensions
_) -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right Type
ty
Right Type
_ ->
TypeError -> Either TypeError Type
forall a b. a -> Either a b
Left (TypeError -> Either TypeError Type)
-> (String -> TypeError) -> String -> Either TypeError Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> String -> TypeError
typeError SrcSpan
s (String -> Either TypeError Type)
-> String -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ String
"Tried to access elements of scalar"
Either TypeError Type
err -> Either TypeError Type
err
ExpSubscript a
_ SrcSpan
s Expression a
arr (AList a
_ SrcSpan
_ (r :: Index a
r@IxRange{} : [Index a]
_)) -> do
Type
ty <- StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strTable SymbolTable
symTable Expression a
arr
case Type
ty of
TCharacter CharacterLen
_ Int
_ -> SrcSpan
-> SymbolTable
-> StructureTable
-> Type
-> Index a
-> Either TypeError Type
forall a.
SrcSpan
-> SymbolTable
-> StructureTable
-> Type
-> Index a
-> Either TypeError Type
typeOfSubString SrcSpan
s SymbolTable
symTable StructureTable
strTable Type
ty Index a
r
Type
_ -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right Type
ty
ExpImpliedDo a
_ SrcSpan
_ AList Expression a
es DoSpecification a
doSpec -> do
Int
dim <- SymbolTable -> DoSpecification a -> Either TypeError Int
forall a. SymbolTable -> DoSpecification a -> Either TypeError Int
specToDim SymbolTable
symTable DoSpecification a
doSpec
Type
ty <- StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strTable SymbolTable
symTable (Expression a -> Either TypeError Type)
-> ([Expression a] -> Expression a)
-> [Expression a]
-> Either TypeError Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Expression a] -> Expression a
forall a. [a] -> a
head ([Expression a] -> Either TypeError Type)
-> [Expression a] -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ AList Expression a -> [Expression a]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList Expression a
es
Type -> Either TypeError Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Either TypeError Type) -> Type -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ case Type
ty of
TArray Type
ty' (Just [(Int
1, Int
dim')]) -> Type -> Maybe Dimensions -> Type
TArray Type
ty' (Dimensions -> Maybe Dimensions
forall a. a -> Maybe a
Just [(Int
1, Int
dim Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
dim')])
TArray Type
_ Maybe Dimensions
_ -> String -> Type
forall a. HasCallStack => String -> a
error String
"Unexpected array type in implied do"
Type
_ -> Type -> Maybe Dimensions -> Type
TArray Type
ty (Dimensions -> Maybe Dimensions
forall a. a -> Maybe a
Just [(Int
1, Int
dim)])
ExpDataRef a
_ SrcSpan
_ Expression a
es (ExpValue a
_ SrcSpan
_ (ValVariable String
name)) -> do
Type
ty <- StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strTable SymbolTable
symTable Expression a
es
StructureTable -> Type -> String -> Either TypeError Type
lookupField StructureTable
strTable Type
ty String
name
Expression a
_ -> TypeError -> Either TypeError Type
forall a b. a -> Either a b
Left (TypeError -> Either TypeError Type)
-> (SrcSpan -> TypeError) -> SrcSpan -> Either TypeError Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> TypeError
UnknownType (SrcSpan -> Either TypeError Type)
-> SrcSpan -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ Expression a -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression a
expr
specToDim :: SymbolTable -> DoSpecification a -> Either TypeError Int
specToDim :: forall a. SymbolTable -> DoSpecification a -> Either TypeError Int
specToDim SymbolTable
symt (DoSpecification a
_ SrcSpan
s (StExpressionAssign a
_ SrcSpan
_ Expression a
_ Expression a
start) Expression a
end Maybe (Expression a)
step)
= let evalInt :: Expression a -> Either TypeError Int
evalInt Expression a
x = case SymbolTable -> Expression a -> Either String ExpVal
forall a. SymbolTable -> Expression a -> Either String ExpVal
eval' SymbolTable
symt Expression a
x of
Right (Int Int
y) -> Int -> Either TypeError Int
forall a b. b -> Either a b
Right Int
y
Right ExpVal
_ -> TypeError -> Either TypeError Int
forall a b. a -> Either a b
Left (TypeError -> Either TypeError Int)
-> (String -> TypeError) -> String -> Either TypeError Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> String -> TypeError
typeError SrcSpan
s (String -> Either TypeError Int) -> String -> Either TypeError Int
forall a b. (a -> b) -> a -> b
$ String
"non int value in do spec " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SrcSpan -> String
forall a. Show a => a -> String
show SrcSpan
s
Left String
err -> TypeError -> Either TypeError Int
forall a b. a -> Either a b
Left (TypeError -> Either TypeError Int)
-> (String -> TypeError) -> String -> Either TypeError Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> String -> TypeError
typeError SrcSpan
s (String -> Either TypeError Int) -> String -> Either TypeError Int
forall a b. (a -> b) -> a -> b
$ String
err
in do
Int
start' <- Expression a -> Either TypeError Int
forall {a}. Expression a -> Either TypeError Int
evalInt Expression a
start
Int
end' <- Expression a -> Either TypeError Int
forall {a}. Expression a -> Either TypeError Int
evalInt Expression a
end
case Maybe (Expression a)
step of
Just Expression a
x -> do
Int
step' <- Expression a -> Either TypeError Int
forall {a}. Expression a -> Either TypeError Int
evalInt Expression a
x
Int -> Either TypeError Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Either TypeError Int) -> Int -> Either TypeError Int
forall a b. (a -> b) -> a -> b
$ ((Int
end' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
start') Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
step') Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
Maybe (Expression a)
Nothing -> Int -> Either TypeError Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Either TypeError Int) -> Int -> Either TypeError Int
forall a b. (a -> b) -> a -> b
$ (Int
end' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
start') Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
specToDim SymbolTable
_ DoSpecification a
_ = String -> Either TypeError Int
forall a. HasCallStack => String -> a
error String
"Unexpected do specification structure"
typeOfSymbol :: SymbolTable -> Name -> Either TypeError Type
typeOfSymbol :: SymbolTable -> String -> Either TypeError Type
typeOfSymbol SymbolTable
symTable String
name = case String -> SymbolTable -> Maybe SymbolTableEntry
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
name SymbolTable
symTable of
Just SymbolTableEntry
entry -> case SymbolTableEntry
entry of
SParameter Type
t ExpVal
_ -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right Type
t
SVariable Type
t Location
_ -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right Type
t
SDummy Type
t -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right Type
t
SExternal Type
t -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right Type
t
Maybe SymbolTableEntry
Nothing -> TypeError -> Either TypeError Type
forall a b. a -> Either a b
Left (TypeError -> Either TypeError Type)
-> TypeError -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ String -> TypeError
UnboundVariable String
name
typeOfValue
:: SrcSpan
-> StructureTable
-> SymbolTable
-> Value a
-> Either TypeError Type
typeOfValue :: forall a.
SrcSpan
-> StructureTable
-> SymbolTable
-> Value a
-> Either TypeError Type
typeOfValue SrcSpan
sp StructureTable
strTable SymbolTable
symTable Value a
v = case Value a
v of
ValInteger String
_ Maybe (KindParam a)
mkp -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Type -> Either TypeError Type) -> Type -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ Int -> Type
TInteger (Int -> Maybe (KindParam a) -> Int
forall a. Int -> Maybe (KindParam a) -> Int
kpOrDef Int
4 Maybe (KindParam a)
mkp)
ValReal RealLit
r Maybe (KindParam a)
_ ->
let k :: Int
k = case Exponent -> ExponentLetter
exponentLetter (RealLit -> Exponent
realLitExponent RealLit
r) of
ExponentLetter
ExpLetterE -> Int
4
ExponentLetter
ExpLetterD -> Int
8
ExponentLetter
ExpLetterQ -> Int
16
in Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Type -> Either TypeError Type) -> Type -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ Int -> Type
TReal Int
k
ValComplex ComplexLit a
c -> do
Type
tr <- StructureTable
-> SymbolTable -> ComplexPart a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> ComplexPart a -> Either TypeError Type
typeOfComplexPart StructureTable
strTable SymbolTable
symTable (ComplexPart a -> Either TypeError Type)
-> ComplexPart a -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ ComplexLit a -> ComplexPart a
forall a. ComplexLit a -> ComplexPart a
complexLitRealPart ComplexLit a
c
Type
ti <- StructureTable
-> SymbolTable -> ComplexPart a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> ComplexPart a -> Either TypeError Type
typeOfComplexPart StructureTable
strTable SymbolTable
symTable (ComplexPart a -> Either TypeError Type)
-> ComplexPart a -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ ComplexLit a -> ComplexPart a
forall a. ComplexLit a -> ComplexPart a
complexLitImagPart ComplexLit a
c
if Type
tr Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Type
TReal Int
8 Bool -> Bool -> Bool
|| Type
ti Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Type
TReal Int
8
then Type -> Either TypeError Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Type
TComplex Int
16)
else Type -> Either TypeError Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Type
TComplex Int
8)
ValString String
s -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Type -> Either TypeError Type) -> Type -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ CharacterLen -> Int -> Type
TCharacter (Int -> CharacterLen
CharLenInt (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s)) Int
1
ValHollerith String
s -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Type -> Either TypeError Type)
-> (Int -> Type) -> Int -> Either TypeError Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Type
TByte (Int -> Either TypeError Type) -> Int -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s
ValLogical Bool
_ Maybe (KindParam a)
mkp -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Type -> Either TypeError Type) -> Type -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ Int -> Type
TLogical (Int -> Maybe (KindParam a) -> Int
forall a. Int -> Maybe (KindParam a) -> Int
kpOrDef Int
4 Maybe (KindParam a)
mkp)
ValBoz Boz
_ -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Type -> Either TypeError Type) -> Type -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ Int -> Type
TByte Int
4
Value a
_ -> TypeError -> Either TypeError Type
forall a b. a -> Either a b
Left (TypeError -> Either TypeError Type)
-> TypeError -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ SrcSpan -> TypeError
UnknownType SrcSpan
sp
where
kpOrDef :: Kind -> Maybe (KindParam a) -> Kind
kpOrDef :: forall a. Int -> Maybe (KindParam a) -> Int
kpOrDef Int
kDef = \case
Maybe (KindParam a)
Nothing -> Int
kDef
Just KindParam a
kp -> case KindParam a
kp of
KindParamInt a
_ SrcSpan
_ String
kpLit -> String -> Int
forall a. Read a => String -> a
read String
kpLit
KindParamVar a
_ SrcSpan
_ String
kpVar ->
let kpVarExpr :: Expression a
kpVarExpr = a -> SrcSpan -> Value a -> Expression a
forall a. a -> SrcSpan -> Value a -> Expression a
ExpValue a
forall a. HasCallStack => a
undefined SrcSpan
forall a. HasCallStack => a
undefined (String -> Value a
forall a. String -> Value a
ValVariable String
kpVar)
in case SymbolTable -> Expression Any -> Either String ExpVal
forall a. SymbolTable -> Expression a -> Either String ExpVal
eval' SymbolTable
symTable Expression Any
forall {a}. Expression a
kpVarExpr of
Left{} -> Int
kDef
Right ExpVal
k -> ExpVal -> Int
toInt ExpVal
k
promote :: Type -> Type -> Type
promote :: Type -> Type -> Type
promote Type
t1 Type
t2
| Type -> Constr
forall a. Data a => a -> Constr
toConstr Type
t1 Constr -> Constr -> Bool
forall a. Eq a => a -> a -> Bool
== Type -> Constr
forall a. Data a => a -> Constr
toConstr Type
t2 = case
Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Int -> Int -> Int) -> Maybe Int -> Maybe (Int -> Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe Int
getTypeKind Type
t1 Maybe (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Maybe Int
getTypeKind Type
t2
of
Just Int
k -> Type -> Maybe Int -> Type
setTypeKind Type
t1 (Maybe Int -> Type) -> Maybe Int -> Type
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int
forall a. a -> Maybe a
Just Int
k
Maybe Int
Nothing ->
String -> Type
forall a. HasCallStack => String -> a
error
(String -> Type) -> String -> Type
forall a b. (a -> b) -> a -> b
$ String
"dynamic type in promotion between: "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Show a => a -> String
show Type
t1
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" and "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Show a => a -> String
show Type
t2
| Bool
otherwise = case (Type
t1, Type
t2) of
(TComplex Int
k , Type
_ ) -> Int -> Type
TComplex Int
k
(Type
_ , TComplex Int
k ) -> Int -> Type
TComplex Int
k
(TReal Int
k , Type
_ ) -> Int -> Type
TReal Int
k
(Type
_ , TReal Int
k ) -> Int -> Type
TReal Int
k
(TLogical Int
k1, TInteger Int
k2) -> Int -> Type
TInteger (Int -> Type) -> Int -> Type
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
k1 Int
k2
(TInteger Int
k1, TLogical Int
k2) -> Int -> Type
TInteger (Int -> Type) -> Int -> Type
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
k1 Int
k2
(TInteger Int
k , Type
_ ) -> Int -> Type
TInteger Int
k
(Type
_ , TInteger Int
k ) -> Int -> Type
TInteger Int
k
(TLogical Int
k , Type
_ ) -> Int -> Type
TLogical Int
k
(Type
_ , TLogical Int
k ) -> Int -> Type
TLogical Int
k
(Type, Type)
_ -> String -> Type
forall a. HasCallStack => String -> a
error (String -> Type) -> String -> Type
forall a b. (a -> b) -> a -> b
$ String
"Incompatible types: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Show a => a -> String
show Type
t1 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Show a => a -> String
show Type
t2
typeOfBinaryExp
:: SrcSpan
-> StructureTable
-> SymbolTable
-> BinaryOp
-> Expression a
-> Expression a
-> Either TypeError Type
typeOfBinaryExp :: forall a.
SrcSpan
-> StructureTable
-> SymbolTable
-> BinaryOp
-> Expression a
-> Expression a
-> Either TypeError Type
typeOfBinaryExp SrcSpan
sp StructureTable
strTable SymbolTable
symTable BinaryOp
op Expression a
e1 Expression a
e2
|
BinaryOp
op BinaryOp -> [BinaryOp] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BinaryOp
GT, BinaryOp
GTE, BinaryOp
LT, BinaryOp
LTE, BinaryOp
EQ, BinaryOp
NE] = Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Int -> Type
TLogical Int
4)
| Bool
otherwise = do
Type
st1 <- StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strTable SymbolTable
symTable Expression a
e1
Type
st2 <- StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strTable SymbolTable
symTable Expression a
e2
SrcSpan -> BinaryOp -> Type -> Type -> Either TypeError Type
typeOfBinaryExp' SrcSpan
sp BinaryOp
op Type
st1 Type
st2
typeOfBinaryExp' :: SrcSpan -> BinaryOp -> Type -> Type -> Either TypeError Type
typeOfBinaryExp' :: SrcSpan -> BinaryOp -> Type -> Type -> Either TypeError Type
typeOfBinaryExp' SrcSpan
sp BinaryOp
op Type
t1 Type
t2
|
BinaryOp
op BinaryOp -> BinaryOp -> Bool
forall a. Eq a => a -> a -> Bool
== BinaryOp
Concatenation
= case Type
t1 of
TCharacter CharacterLen
l1 Int
k1' -> case Type
t2 of
TCharacter CharacterLen
l2 Int
_ -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Type -> Either TypeError Type) -> Type -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ CharacterLen -> Int -> Type
TCharacter (CharacterLen -> CharacterLen -> CharacterLen
charLenConcat CharacterLen
l1 CharacterLen
l2) Int
k1'
Type
_ -> String -> Either TypeError Type
forall a. HasCallStack => String -> a
error String
"shit 1"
Type
_ -> String -> Either TypeError Type
forall a. HasCallStack => String -> a
error String
"shit 2"
|
BinaryOp
op BinaryOp -> [BinaryOp] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BinaryOp
And, BinaryOp
Or, BinaryOp
Equivalent, BinaryOp
NotEquivalent, BinaryOp
XOr]
= let
ty :: Int -> Either TypeError Type
ty = case (Type
t1, Type
t2) of
(TLogical Int
_, TLogical Int
_) -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Type -> Either TypeError Type)
-> (Int -> Type) -> Int -> Either TypeError Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Type
TLogical
(TInteger Int
_, Type
_ ) -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Type -> Either TypeError Type)
-> (Int -> Type) -> Int -> Either TypeError Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Type
TInteger
(Type
_ , TInteger Int
_) -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Type -> Either TypeError Type)
-> (Int -> Type) -> Int -> Either TypeError Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Type
TInteger
(TByte Int
_ , Type
_ ) -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Type -> Either TypeError Type)
-> (Int -> Type) -> Int -> Either TypeError Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Type
TInteger
(Type
_ , TByte Int
_ ) -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Type -> Either TypeError Type)
-> (Int -> Type) -> Int -> Either TypeError Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Type
TInteger
(Type, Type)
_ -> Either TypeError Type -> Int -> Either TypeError Type
forall a b. a -> b -> a
const
(TypeError -> Either TypeError Type
forall a b. a -> Either a b
Left (TypeError -> Either TypeError Type)
-> TypeError -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> TypeError
typeError SrcSpan
sp String
"Unexpected types used with logical operators")
in Int -> Either TypeError Type
ty (Int -> Either TypeError Type)
-> (Maybe Int -> Int) -> Maybe Int -> Either TypeError Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Either TypeError Type)
-> Maybe Int -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Int -> Int -> Int) -> Maybe Int -> Maybe (Int -> Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
k1 Maybe (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Int
k2
|
BinaryOp
op BinaryOp -> [BinaryOp] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BinaryOp
Addition, BinaryOp
Subtraction, BinaryOp
Multiplication, BinaryOp
Division, BinaryOp
Exponentiation]
= Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Type -> Either TypeError Type) -> Type -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
promote Type
t1 Type
t2
| Bool
otherwise
= TypeError -> Either TypeError Type
forall a b. a -> Either a b
Left (TypeError -> Either TypeError Type)
-> TypeError -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ SrcSpan -> TypeError
UnknownType SrcSpan
sp
where
k1 :: Maybe Int
k1 = Type -> Maybe Int
getTypeKind Type
t1
k2 :: Maybe Int
k2 = Type -> Maybe Int
getTypeKind Type
t2
typeOfSubString
:: SrcSpan
-> SymbolTable
-> StructureTable
-> Type
-> Index a
-> Either TypeError Type
typeOfSubString :: forall a.
SrcSpan
-> SymbolTable
-> StructureTable
-> Type
-> Index a
-> Either TypeError Type
typeOfSubString SrcSpan
sp SymbolTable
symt StructureTable
strt Type
ty (IxRange a
_ SrcSpan
_ Maybe (Expression a)
lower Maybe (Expression a)
upper Maybe (Expression a)
_) = do
Either TypeError (Maybe Type) -> Either TypeError ()
forall {a}. Either a (Maybe Type) -> Either TypeError ()
isInteger (Either TypeError (Maybe Type) -> Either TypeError ())
-> Either TypeError (Maybe Type) -> Either TypeError ()
forall a b. (a -> b) -> a -> b
$ (Expression a -> Either TypeError Type)
-> Maybe (Expression a) -> Either TypeError (Maybe Type)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strt SymbolTable
symt) Maybe (Expression a)
lower
Either TypeError (Maybe Type) -> Either TypeError ()
forall {a}. Either a (Maybe Type) -> Either TypeError ()
isInteger (Either TypeError (Maybe Type) -> Either TypeError ())
-> Either TypeError (Maybe Type) -> Either TypeError ()
forall a b. (a -> b) -> a -> b
$ (Expression a -> Either TypeError Type)
-> Maybe (Expression a) -> Either TypeError (Maybe Type)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strt SymbolTable
symt) Maybe (Expression a)
upper
Type -> Either TypeError Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Either TypeError Type) -> Type -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ CharacterLen -> Int -> Type
TCharacter CharacterLen
calcLen Int
1
where
calcLen :: CharacterLen
calcLen = case (\Int
x Int
y -> Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> Int -> Int) -> Maybe Int -> Maybe (Int -> Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
lowerIndex Maybe (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Int
upperIndex of
Maybe Int
Nothing -> CharacterLen
CharLenStar
Just Int
len -> Int -> CharacterLen
CharLenInt Int
len
isInteger :: Either a (Maybe Type) -> Either TypeError ()
isInteger = \case
Right (Just (TInteger Int
_)) -> () -> Either TypeError ()
forall a b. b -> Either a b
Right ()
Right Maybe Type
Nothing -> () -> Either TypeError ()
forall a b. b -> Either a b
Right ()
Either a (Maybe Type)
_ -> TypeError -> Either TypeError ()
forall a b. a -> Either a b
Left (TypeError -> Either TypeError ())
-> (String -> TypeError) -> String -> Either TypeError ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> String -> TypeError
typeError SrcSpan
sp (String -> Either TypeError ()) -> String -> Either TypeError ()
forall a b. (a -> b) -> a -> b
$ String
"Index wasn't an integer type"
upperIndex :: Maybe Int
upperIndex = let Just Int
k = Type -> Maybe Int
getTypeKind Type
ty in Int -> Maybe (Expression a) -> Maybe Int
forall a. Int -> Maybe (Expression a) -> Maybe Int
getIndex Int
k Maybe (Expression a)
upper
lowerIndex :: Maybe Int
lowerIndex = Int -> Maybe (Expression a) -> Maybe Int
forall a. Int -> Maybe (Expression a) -> Maybe Int
getIndex Int
1 Maybe (Expression a)
lower
getIndex :: Int -> Maybe (Expression a) -> Maybe Int
getIndex :: forall a. Int -> Maybe (Expression a) -> Maybe Int
getIndex Int
dflt Maybe (Expression a)
Nothing = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
dflt
getIndex Int
_ (Just Expression a
e) = case SymbolTable -> Expression a -> Either String ExpVal
forall a. SymbolTable -> Expression a -> Either String ExpVal
eval' SymbolTable
symt Expression a
e of
Right (Int Int
i) -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i
Either String ExpVal
_ -> Maybe Int
forall a. Maybe a
Nothing
typeOfSubString SrcSpan
_ SymbolTable
_ StructureTable
_ Type
_ Index a
idx = TypeError -> Either TypeError Type
forall a b. a -> Either a b
Left (TypeError -> Either TypeError Type)
-> TypeError -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ SrcSpan -> TypeError
UnknownType (Index a -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Index a
idx)
typeOfFunctionCall
:: SrcSpan
-> StructureTable
-> SymbolTable
-> Name
-> [Argument a]
-> Either TypeError Type
typeOfFunctionCall :: forall a.
SrcSpan
-> StructureTable
-> SymbolTable
-> String
-> [Argument a]
-> Either TypeError Type
typeOfFunctionCall SrcSpan
sp StructureTable
strT SymbolTable
symT String
name [Argument a]
argList =
Either TypeError Type
checkIntrinsicFunction Either TypeError Type
-> Either TypeError Type -> Either TypeError Type
forall a. Semigroup a => a -> a -> a
<> Either TypeError Type
checkF77IntrinsicFunction Either TypeError Type
-> Either TypeError Type -> Either TypeError Type
forall a. Semigroup a => a -> a -> a
<> Either TypeError Type
checkExternalFunction
where
args :: [Expression a]
args = [ ArgumentExpression a -> Expression a
forall a. ArgumentExpression a -> Expression a
argExprNormalize ArgumentExpression a
e | Argument a
_ SrcSpan
_ Maybe String
_ ArgumentExpression a
e <- [Argument a]
argList ]
checkIntrinsicFunction :: Either TypeError Type
checkIntrinsicFunction :: Either TypeError Type
checkIntrinsicFunction
| String
name String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"int", String
"nint"], [Expression a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expression a]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
= Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Int -> Type
TInteger Int
4)
| String
name String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"int", String
"nint"], [Expression a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expression a]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2
= case SymbolTable -> Expression a -> Either String ExpVal
forall a. SymbolTable -> Expression a -> Either String ExpVal
eval' SymbolTable
symT ([Expression a]
args [Expression a] -> Int -> Expression a
forall a. [a] -> Int -> a
!! Int
1) of
Right (Int Int
k) -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Int -> Type
TInteger Int
k)
Either String ExpVal
_ -> TypeError -> Either TypeError Type
forall a b. a -> Either a b
Left (TypeError -> Either TypeError Type)
-> TypeError -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> TypeError
typeError
SrcSpan
sp
( String
"Unable to determine the second argument value of "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" function"
)
| String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"int2"
= Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Int -> Type
TInteger Int
2)
| String
name String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"loc", String
"sizeof", String
"iachar"]
= Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Int -> Type
TInteger Int
4)
| String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"dfloat"
= Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Int -> Type
TReal Int
8)
| String
name String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"ishft", String
"lshift", String
"rshift", String
"ibset", String
"ibits"], Bool -> Bool
not
([Expression a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expression a]
args)
= StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strT SymbolTable
symT ([Expression a] -> Expression a
forall a. [a] -> a
head [Expression a]
args)
| String
name String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"iand", String
"ior", String
"ieor", String
"and"], [Expression a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expression a]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2
= do
Type
t1 <- StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strT SymbolTable
symT ([Expression a] -> Expression a
forall a. [a] -> a
head [Expression a]
args)
Type
t2 <- StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strT SymbolTable
symT ([Expression a]
args [Expression a] -> Int -> Expression a
forall a. [a] -> Int -> a
!! Int
1)
Type -> Either TypeError Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Either TypeError Type) -> Type -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
promote Type
t1 Type
t2
| String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"imag", [Expression a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expression a]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
= do
Type
ty <- StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strT SymbolTable
symT ([Expression a] -> Expression a
forall a. [a] -> a
head [Expression a]
args)
case Type
ty of
TComplex Int
x -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Type -> Either TypeError Type)
-> (Int -> Type) -> Int -> Either TypeError Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Type
TReal (Int -> Either TypeError Type) -> Int -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ Int
x Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
Type
_ -> TypeError -> Either TypeError Type
forall a b. a -> Either a b
Left (TypeError -> Either TypeError Type)
-> TypeError -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> TypeError
typeError SrcSpan
sp String
"Invalid argument to imag"
| String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"btest", [Expression a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expression a]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2
= Type -> Either TypeError Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Either TypeError Type) -> Type -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ Int -> Type
TLogical Int
4
| String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"not", [Expression a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expression a]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
= StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strT SymbolTable
symT ([Expression a] -> Expression a
forall a. [a] -> a
head [Expression a]
args)
| Bool
otherwise
= TypeError -> Either TypeError Type
forall a b. a -> Either a b
Left (TypeError -> Either TypeError Type)
-> TypeError -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> TypeError
typeError
SrcSpan
sp
(String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is not in the extra list of intrinsic functions")
checkF77IntrinsicFunction :: Either TypeError Type
checkF77IntrinsicFunction :: Either TypeError Type
checkF77IntrinsicFunction =
let f77intrinsics :: IntrinsicsTable
f77intrinsics = FortranVersion -> IntrinsicsTable
getVersionIntrinsics FortranVersion
Fortran77
in
case String -> IntrinsicsTable -> Maybe IntrinsicType
getIntrinsicReturnType String
name IntrinsicsTable
f77intrinsics of
Just IntrinsicType
ITReal -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Int -> Type
TReal Int
4)
Just IntrinsicType
ITInteger -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Int -> Type
TInteger Int
4)
Just IntrinsicType
ITComplex -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Int -> Type
TComplex Int
8)
Just IntrinsicType
ITDouble -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Int -> Type
TReal Int
8)
Just IntrinsicType
ITLogical -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Int -> Type
TLogical Int
4)
Just IntrinsicType
ITCharacter -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (CharacterLen -> Int -> Type
TCharacter (Int -> CharacterLen
CharLenInt Int
1) Int
1)
Just (ITParam Int
i)
| [Expression a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expression a]
args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
i -> StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strT SymbolTable
symT ([Expression a]
args [Expression a] -> Int -> Expression a
forall a. [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
| Bool
otherwise -> TypeError -> Either TypeError Type
forall a b. a -> Either a b
Left (TypeError -> Either TypeError Type)
-> TypeError -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> TypeError
typeError
SrcSpan
sp
(String
"Wrong number of arguments for intrinsic function " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name)
Maybe IntrinsicType
Nothing ->
TypeError -> Either TypeError Type
forall a b. a -> Either a b
Left (TypeError -> Either TypeError Type)
-> TypeError -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> TypeError
typeError SrcSpan
sp (String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is not in Fortran 77 intrinsic table")
checkExternalFunction :: Either TypeError Type
checkExternalFunction :: Either TypeError Type
checkExternalFunction = SymbolTable -> String -> Either TypeError Type
typeOfSymbol SymbolTable
symT String
name
typeOfComplexPart :: StructureTable -> SymbolTable -> ComplexPart a -> Either TypeError Type
typeOfComplexPart :: forall a.
StructureTable
-> SymbolTable -> ComplexPart a -> Either TypeError Type
typeOfComplexPart StructureTable
strTable SymbolTable
symTable = \case
ComplexPartReal a
_ SrcSpan
ss RealLit
cpReal Maybe (KindParam a)
mkp -> SrcSpan -> Value a -> Either TypeError Type
forall {a}. SrcSpan -> Value a -> Either TypeError Type
tOfVal SrcSpan
ss (RealLit -> Maybe (KindParam a) -> Value a
forall a. RealLit -> Maybe (KindParam a) -> Value a
ValReal RealLit
cpReal Maybe (KindParam a)
mkp)
ComplexPartInt a
_ SrcSpan
ss String
cpInt Maybe (KindParam a)
mkp -> SrcSpan -> Value a -> Either TypeError Type
forall {a}. SrcSpan -> Value a -> Either TypeError Type
tOfVal SrcSpan
ss (String -> Maybe (KindParam a) -> Value a
forall a. String -> Maybe (KindParam a) -> Value a
ValInteger String
cpInt Maybe (KindParam a)
mkp)
ComplexPartNamed a
_ SrcSpan
_ String
nm -> SymbolTable -> String -> Either TypeError Type
typeOfSymbol SymbolTable
symTable String
nm
where tOfVal :: SrcSpan -> Value a -> Either TypeError Type
tOfVal SrcSpan
ss Value a
v = SrcSpan
-> StructureTable
-> SymbolTable
-> Value a
-> Either TypeError Type
forall a.
SrcSpan
-> StructureTable
-> SymbolTable
-> Value a
-> Either TypeError Type
typeOfValue SrcSpan
ss StructureTable
strTable SymbolTable
symTable Value a
v