diff --git a/Makefile.am b/Makefile.am
index 6235e9a..80d248f 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -136,6 +136,7 @@ tock_SOURCES_hs += data/TagAST.hs
tock_SOURCES_hs += flow/FlowGraph.hs
tock_SOURCES_hs += flow/FlowAlgorithms.hs
tock_SOURCES_hs += frontends/OccamPasses.hs
+tock_SOURCES_hs += frontends/OccamTypes.hs
tock_SOURCES_hs += frontends/ParseOccam.hs
tock_SOURCES_hs += frontends/ParseRain.hs
tock_SOURCES_hs += frontends/ParseUtils.hs
@@ -166,6 +167,7 @@ tocktest_SOURCES += common/TestHarness.hs
tocktest_SOURCES += common/TestUtils.hs
tocktest_SOURCES += flow/FlowGraphTest.hs
tocktest_SOURCES += frontends/OccamPassesTest.hs
+tocktest_SOURCES += frontends/OccamTypesTest.hs
tocktest_SOURCES += frontends/ParseRainTest.hs
tocktest_SOURCES += frontends/PreprocessOccamTest.hs
tocktest_SOURCES += frontends/RainPassesTest.hs
diff --git a/TestMain.hs b/TestMain.hs
index 54250cb..cde1fd8 100644
--- a/TestMain.hs
+++ b/TestMain.hs
@@ -30,6 +30,8 @@ with this program. If not, see .
--
-- * "OccamPassesTest"
--
+-- * "OccamTypesTest"
+--
-- * "ParseRainTest"
--
-- * "PassTest"
@@ -59,6 +61,7 @@ import qualified CommonTest (tests)
import qualified FlowGraphTest (qcTests)
import qualified GenerateCTest (tests)
import qualified OccamPassesTest (tests)
+import qualified OccamTypesTest (tests)
import qualified ParseRainTest (tests)
import qualified PassTest (tests)
import qualified PreprocessOccamTest (tests)
@@ -174,6 +177,7 @@ main = do (opts, nonOpts, errs) <- getArgs >>* getOpt RequireOrder options
,return FlowGraphTest.qcTests
,noqc GenerateCTest.tests
,noqc OccamPassesTest.tests
+ ,noqc OccamTypesTest.tests
,noqc ParseRainTest.tests
,noqc PassTest.tests
,noqc PreprocessOccamTest.tests
diff --git a/frontends/OccamPasses.hs b/frontends/OccamPasses.hs
index 032284a..1198640 100644
--- a/frontends/OccamPasses.hs
+++ b/frontends/OccamPasses.hs
@@ -29,6 +29,7 @@ import Errors
import EvalConstants
import EvalLiterals
import Metadata
+import OccamTypes
import Pass
import qualified Properties as Prop
import ShowCode
@@ -46,6 +47,9 @@ occamPasses = makePassesDep' ((== FrontendOccam) . csFrontend)
, ("Check mandatory constants", checkConstants,
[Prop.constantsFolded, Prop.arrayConstructorTypesDone],
[Prop.constantsChecked])
+ , ("Check types", checkTypes,
+ [],
+ [Prop.expressionTypesChecked, Prop.processTypesChecked])
, ("Check retyping", checkRetypes,
[],
[Prop.retypesChecked])
diff --git a/frontends/OccamTypes.hs b/frontends/OccamTypes.hs
new file mode 100644
index 0000000..decfc71
--- /dev/null
+++ b/frontends/OccamTypes.hs
@@ -0,0 +1,407 @@
+{-
+Tock: a compiler for parallel languages
+Copyright (C) 2008 University of Kent
+
+This program is free software; you can redistribute it and/or modify it
+under the terms of the GNU General Public License as published by the
+Free Software Foundation, either version 2 of the License, or (at your
+option) any later version.
+
+This program is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License along
+with this program. If not, see .
+-}
+
+-- | The occam typechecker.
+module OccamTypes (checkTypes) where
+
+import Control.Monad.State
+import Data.Generics
+
+import qualified AST as A
+import CompState
+import Errors
+import EvalLiterals
+import Intrinsics
+import Metadata
+import Pass
+import ShowCode
+import Types
+
+-- | A successful check.
+ok :: PassM ()
+ok = return ()
+
+--{{{ type checks
+
+-- | Are two types the same?
+sameType :: A.Type -> A.Type -> PassM Bool
+sameType (A.Array (A.Dimension e1 : ds1) t1)
+ (A.Array (A.Dimension e2 : ds2) t2)
+ = do n1 <- evalIntExpression e1
+ n2 <- evalIntExpression e2
+ same <- sameType (A.Array ds1 t1) (A.Array ds2 t2)
+ return $ (n1 == n2) && same
+sameType (A.Array (A.UnknownDimension : ds1) t1)
+ (A.Array (A.UnknownDimension : ds2) t2)
+ = sameType (A.Array ds1 t1) (A.Array ds2 t2)
+sameType a b = return $ a == b
+
+-- | Check that the second dimension can be used in a context where the first
+-- is expected.
+isValidDimension :: A.Dimension -> A.Dimension -> PassM Bool
+isValidDimension A.UnknownDimension A.UnknownDimension = return True
+isValidDimension A.UnknownDimension (A.Dimension _) = return True
+isValidDimension (A.Dimension e1) (A.Dimension e2)
+ = do n1 <- evalIntExpression e1
+ n2 <- evalIntExpression e2
+ return $ n1 == n2
+isValidDimension _ _ = return False
+
+-- | Check that the second second of dimensions can be used in a context where
+-- the first is expected.
+areValidDimensions :: [A.Dimension] -> [A.Dimension] -> PassM Bool
+areValidDimensions [] [] = return True
+areValidDimensions (d1:ds1) (d2:ds2)
+ = do valid <- isValidDimension d1 d2
+ if valid
+ then areValidDimensions ds1 ds2
+ else return False
+areValidDimensions _ _ = return False
+
+-- | Check that a type we've inferred matches the type we expected.
+checkType :: Meta -> A.Type -> A.Type -> PassM ()
+checkType m et rt
+ = case (et, rt) of
+ ((A.Array ds t), (A.Array ds' t')) ->
+ do valid <- areValidDimensions ds ds'
+ if valid
+ then checkType m t t'
+ else bad
+ _ ->
+ do same <- sameType rt et
+ when (not same) $ bad
+ where
+ bad :: PassM ()
+ bad = diePC m $ formatCode "Type mismatch: found %, expected %" rt et
+
+-- | Check that a type is numeric.
+checkNumeric :: Meta -> A.Type -> PassM ()
+checkNumeric m rawT
+ = do t <- underlyingType m rawT
+ if isIntegerType t || isRealType t
+ then ok
+ else diePC m $ formatCode "Expected numeric type; found %" t
+
+-- | Check that a type is integral.
+checkInteger :: Meta -> A.Type -> PassM ()
+checkInteger m rawT
+ = do t <- underlyingType m rawT
+ if isIntegerType t
+ then ok
+ else diePC m $ formatCode "Expected integer type; found %" t
+
+-- | Check that a type is scalar.
+checkScalar :: Meta -> A.Type -> PassM ()
+checkScalar m rawT
+ = do t <- underlyingType m rawT
+ if isScalarType t
+ then ok
+ else diePC m $ formatCode "Expected scalar type; found %" t
+
+-- | Check that a type is an array.
+-- (This also gets used elsewhere where we *know* the argument isn't an array,
+-- so that we get a consistent error message.)
+checkArray :: Meta -> A.Type -> PassM ()
+checkArray m rawT
+ = do t <- underlyingType m rawT
+ case t of
+ (A.Array _ _) -> ok
+ _ -> diePC m $ formatCode "Expected array type; found %" t
+
+-- | Check that a type is a list.
+checkList :: Meta -> A.Type -> PassM ()
+checkList m rawT
+ = do t <- underlyingType m rawT
+ case t of
+ (A.List _) -> ok
+ _ -> diePC m $ formatCode "Expected list type; found %" t
+
+-- | Check the type of an expression.
+checkExpressionType :: Meta -> A.Type -> A.Expression -> PassM ()
+checkExpressionType m et e = typeOfExpression e >>= checkType m et
+
+-- | Check that an expression is of integer type.
+checkExpressionInt :: Meta -> A.Expression -> PassM ()
+checkExpressionInt m e = checkExpressionType m A.Int e
+
+-- | Check that an expression is of boolean type.
+checkExpressionBool :: Meta -> A.Expression -> PassM ()
+checkExpressionBool m e = checkExpressionType m A.Bool e
+
+-- | Check the type of a variable.
+checkVariableType :: Meta -> A.Type -> A.Variable -> PassM ()
+checkVariableType m et v = typeOfVariable v >>= checkType m et
+
+-- | Check that two lists of types match (for example, for parallel
+-- assignment).
+checkTypeList :: Meta -> [A.Type] -> [A.Type] -> PassM ()
+checkTypeList m ets rts
+ = sequence_ [checkType m et rt | (et, rt) <- zip ets rts]
+
+--}}}
+--{{{ more complex checks
+
+-- | Check that an array literal's length matches its type.
+checkArraySize :: Meta -> A.Type -> Int -> PassM ()
+checkArraySize m rawT want
+ = do t <- underlyingType m rawT
+ case t of
+ A.Array (A.UnknownDimension:_) _ -> ok
+ A.Array (A.Dimension e:_) _ ->
+ do n <- evalIntExpression e
+ when (n /= want) $
+ dieP m $ "Array literal has wrong number of elements: found " ++ show n ++ ", expected " ++ show want
+ _ -> checkArray m t
+
+-- | Check that a record field name is valid.
+checkRecordField :: Meta -> A.Type -> A.Name -> PassM ()
+checkRecordField m t n
+ = do rfs <- recordFields m t
+ let validNames = map fst rfs
+ when (not $ n `elem` validNames) $
+ diePC m $ formatCode "Invalid field name % in record type %" n t
+
+-- | Check that a subscript is being applied to an appropriate type.
+checkSubscriptType :: Meta -> A.Subscript -> A.Type -> PassM ()
+checkSubscriptType m s rawT
+ = do t <- underlyingType m rawT
+ case s of
+ -- A record subscript.
+ A.SubscriptField m n ->
+ checkRecordField m t n
+ -- An array subscript.
+ _ ->
+ case t of
+ A.Array _ _ -> ok
+ _ -> checkArray m t
+
+-- | Classes of operators.
+data OpClass = NumericOp | IntegerOp | ShiftOp | BooleanOp | ComparisonOp
+ | ListOp
+
+-- | Figure out the class of a monadic operator.
+classifyMOp :: A.MonadicOp -> OpClass
+classifyMOp A.MonadicSubtr = NumericOp
+classifyMOp A.MonadicMinus = NumericOp
+classifyMOp A.MonadicBitNot = IntegerOp
+classifyMOp A.MonadicNot = BooleanOp
+
+-- | Figure out the class of a dyadic operator.
+classifyOp :: A.DyadicOp -> OpClass
+classifyOp A.Add = NumericOp
+classifyOp A.Subtr = NumericOp
+classifyOp A.Mul = NumericOp
+classifyOp A.Div = NumericOp
+classifyOp A.Rem = NumericOp
+classifyOp A.Plus = NumericOp
+classifyOp A.Minus = NumericOp
+classifyOp A.Times = NumericOp
+classifyOp A.BitAnd = IntegerOp
+classifyOp A.BitOr = IntegerOp
+classifyOp A.BitXor = IntegerOp
+classifyOp A.LeftShift = ShiftOp
+classifyOp A.RightShift = ShiftOp
+classifyOp A.And = BooleanOp
+classifyOp A.Or = BooleanOp
+classifyOp A.Eq = ComparisonOp
+classifyOp A.NotEq = ComparisonOp
+classifyOp A.Less = ComparisonOp
+classifyOp A.More = ComparisonOp
+classifyOp A.LessEq = ComparisonOp
+classifyOp A.MoreEq = ComparisonOp
+classifyOp A.After = ComparisonOp
+classifyOp A.Concat = ListOp
+
+-- | Check a monadic operator.
+checkMonadicOp :: A.MonadicOp -> A.Expression -> PassM ()
+checkMonadicOp op e
+ = do t <- typeOfExpression e
+ let m = findMeta e
+ case classifyMOp op of
+ NumericOp -> checkNumeric m t
+ IntegerOp -> checkInteger m t
+ BooleanOp -> checkType m A.Bool t
+
+-- | Check a dyadic operator.
+checkDyadicOp :: A.DyadicOp -> A.Expression -> A.Expression -> PassM ()
+checkDyadicOp op l r
+ = do lt <- typeOfExpression l
+ let lm = findMeta l
+ rt <- typeOfExpression r
+ let rm = findMeta r
+ case classifyOp op of
+ NumericOp ->
+ checkNumeric lm lt >> checkNumeric rm rt >> checkType rm lt rt
+ IntegerOp ->
+ checkInteger lm lt >> checkInteger rm rt >> checkType rm lt rt
+ ShiftOp ->
+ checkNumeric lm lt >> checkType rm A.Int rt
+ BooleanOp ->
+ checkType lm A.Bool lt >> checkType rm A.Bool rt
+ ComparisonOp ->
+ checkScalar lm lt >> checkScalar rm rt >> checkType rm lt rt
+ ListOp ->
+ checkList lm lt >> checkList rm rt >> checkType rm lt rt
+
+-- | Check a function call.
+checkFunctionCall :: Meta -> A.Name -> [A.Expression] -> Bool -> PassM ()
+checkFunctionCall m n es singleOnly
+ = do st <- specTypeOfName n
+ case st of
+ A.Function _ _ rs fs _ ->
+ do when (singleOnly && length rs /= 1) $
+ diePC m $ formatCode "Function % used in an expression returns more than one value" n
+ when (length es /= length fs) $
+ diePC m $ formatCode ("Function % called with wrong number of arguments; found " ++ (show $ length es) ++ ", expected " ++ (show $ length fs)) n
+ sequence_ [do rt <- typeOfExpression e
+ checkType (findMeta e) et rt
+ | (e, A.Formal _ et _) <- zip es fs]
+ _ -> diePC m $ formatCode ("% is not a function; it's a " ++ show st) n
+
+-- | Check an intrinsic function call.
+checkIntrinsicFunctionCall :: Meta -> String -> [A.Expression] -> Bool
+ -> PassM ()
+checkIntrinsicFunctionCall m s es singleOnly
+ = case lookup s intrinsicFunctions of
+ Just (rs, tns) ->
+ do when (singleOnly && length rs /= 1) $
+ dieP m $ "Intrinsic function " ++ s ++ " used in an expression returns more than one value"
+ when (length es /= length tns) $
+ dieP m $ "Intrinsic function " ++ s ++ " called with wrong number of arguments; found " ++ (show $ length es) ++ ", expected " ++ (show $ length tns)
+ sequence_ [do rt <- typeOfExpression e
+ checkType (findMeta e) et rt
+ | (e, (et, _)) <- zip es tns]
+ Nothing -> dieP m $ s ++ " is not an intrinsic function"
+
+-- | Check a mobile allocation.
+checkAllocMobile :: Meta -> A.Type -> Maybe A.Expression -> PassM ()
+checkAllocMobile m rawT me
+ = do t <- underlyingType m rawT
+ case t of
+ A.Mobile innerT ->
+ do case innerT of
+ A.Array ds _ -> sequence_ $ map checkFullDimension ds
+ _ -> ok
+ case me of
+ Just e ->
+ do et <- typeOfExpression e
+ checkType (findMeta e) innerT et
+ Nothing -> ok
+ _ -> diePC m $ formatCode "Expected mobile type in allocation; found %" t
+ where
+ checkFullDimension :: A.Dimension -> PassM ()
+ checkFullDimension A.UnknownDimension
+ = dieP m $ "Type in allocation contains unknown dimensions"
+ checkFullDimension _ = ok
+--}}}
+
+-- | Check the AST for type consistency.
+-- This is actually a series of smaller passes that check particular types
+-- inside the AST, but it doesn't really make sense to split it up.
+checkTypes :: Data t => t -> PassM t
+checkTypes t =
+ checkSubscripts t >>=
+ checkLiterals >>=
+ checkVariables >>=
+ checkExpressions
+
+checkSubscripts :: Data t => t -> PassM t
+checkSubscripts = checkDepthM doSubscript
+ where
+ doSubscript :: A.Subscript -> PassM ()
+ doSubscript (A.Subscript m _ e) = checkExpressionInt m e
+ doSubscript (A.SubscriptFromFor m e f)
+ = checkExpressionInt m e >> checkExpressionInt m f
+ doSubscript (A.SubscriptFrom m e) = checkExpressionInt m e
+ doSubscript (A.SubscriptFor m e) = checkExpressionInt m e
+ doSubscript _ = ok
+
+checkLiterals :: Data t => t -> PassM t
+checkLiterals = checkDepthM doExpression
+ where
+ doExpression :: A.Expression -> PassM ()
+ doExpression (A.Literal m t lr) = doLiteralRepr t lr
+ doExpression _ = ok
+
+ doLiteralRepr :: A.Type -> A.LiteralRepr -> PassM ()
+ doLiteralRepr t (A.ArrayLiteral m aes)
+ = doArrayElem m t (A.ArrayElemArray aes)
+ doLiteralRepr t (A.RecordLiteral m es)
+ = do rfs <- underlyingType m t >>= recordFields m
+ when (length es /= length rfs) $
+ dieP m $ "Record literal has wrong number of fields: found " ++ (show $ length es) ++ ", expected " ++ (show $ length rfs)
+ sequence_ [checkExpressionType (findMeta fe) ft fe
+ | ((_, ft), fe) <- zip rfs es]
+ doLiteralRepr _ _ = ok
+
+ doArrayElem :: Meta -> A.Type -> A.ArrayElem -> PassM ()
+ doArrayElem m t (A.ArrayElemArray aes)
+ = do checkArraySize m t (length aes)
+ t' <- subscriptType (A.Subscript m A.NoCheck undefined) t
+ sequence_ $ map (doArrayElem m t') aes
+ doArrayElem _ t (A.ArrayElemExpr e) = checkExpressionType (findMeta e) t e
+
+checkVariables :: Data t => t -> PassM t
+checkVariables = checkDepthM doVariable
+ where
+ doVariable :: A.Variable -> PassM ()
+ doVariable (A.SubscriptedVariable m s v)
+ = do t <- typeOfVariable v
+ checkSubscriptType m s t
+ doVariable (A.DirectedVariable m _ v)
+ = do t <- typeOfVariable v >>= underlyingType m
+ case t of
+ A.Chan _ _ _ -> ok
+ _ -> dieP m $ "Direction applied to non-channel variable"
+ doVariable (A.DerefVariable m v)
+ = do t <- typeOfVariable v >>= underlyingType m
+ case t of
+ A.Mobile _ -> ok
+ _ -> dieP m $ "Dereference applied to non-mobile variable"
+ doVariable _ = ok
+
+checkExpressions :: Data t => t -> PassM t
+checkExpressions = checkDepthM doExpression
+ where
+ doExpression :: A.Expression -> PassM ()
+ doExpression (A.Monadic _ op e) = checkMonadicOp op e
+ doExpression (A.Dyadic _ op le re) = checkDyadicOp op le re
+ doExpression (A.MostPos m t) = checkNumeric m t
+ doExpression (A.MostNeg m t) = checkNumeric m t
+ doExpression (A.SizeType m t) = checkArray m t
+ doExpression (A.SizeExpr m e)
+ = do t <- typeOfExpression e
+ checkArray m t
+ doExpression (A.SizeVariable m v)
+ = do t <- typeOfVariable v
+ checkArray m t
+ doExpression (A.Conversion m _ t e)
+ = do et <- typeOfExpression e
+ checkScalar m t >> checkScalar (findMeta e) et
+ doExpression (A.FunctionCall m n es)
+ = checkFunctionCall m n es True
+ doExpression (A.IntrinsicFunctionCall m s es)
+ = checkIntrinsicFunctionCall m s es True
+ doExpression (A.SubscriptedExpr m s e)
+ = do t <- typeOfExpression e
+ checkSubscriptType m s t
+ doExpression (A.OffsetOf m rawT n)
+ = do t <- underlyingType m rawT
+ checkRecordField m t n
+ doExpression (A.AllocMobile m t me) = checkAllocMobile m t me
+ doExpression _ = ok
diff --git a/frontends/OccamTypesTest.hs b/frontends/OccamTypesTest.hs
new file mode 100644
index 0000000..f558699
--- /dev/null
+++ b/frontends/OccamTypesTest.hs
@@ -0,0 +1,245 @@
+{-
+Tock: a compiler for parallel languages
+Copyright (C) 2008 University of Kent
+
+This program is free software; you can redistribute it and/or modify it
+under the terms of the GNU General Public License as published by the
+Free Software Foundation, either version 2 of the License, or (at your
+option) any later version.
+
+This program is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License along
+with this program. If not, see .
+-}
+
+-- #ignore-exports
+
+-- | Tests for 'OccamTypes'.
+module OccamTypesTest (tests) where
+
+import Control.Monad.State
+import Data.Generics
+import Test.HUnit hiding (State)
+
+import qualified AST as A
+import CompState
+import Metadata
+import qualified OccamTypes
+import TestUtils
+
+m :: Meta
+m = emptyMeta
+
+-- | Initial state for the tests.
+startState :: State CompState ()
+startState
+ = do defineConst "const" A.Int (intLiteral 2)
+ defineConst "someInt" A.Int (intLiteral 42)
+ defineConst "someByte" A.Byte (byteLiteral 24)
+ defineConst "someInts" (A.Array [A.UnknownDimension] A.Int)
+ (A.Literal m (A.Array [A.UnknownDimension] A.Int)
+ (A.ArrayLiteral m []))
+ defineConst "someBytes" (A.Array [A.UnknownDimension] A.Byte)
+ (A.Literal m (A.Array [A.UnknownDimension] A.Int)
+ (A.ArrayLiteral m []))
+ defineUserDataType "MYINT" A.Int
+ defineUserDataType "MY2INT" (A.Array [dimension 2] A.Int)
+ defineRecordType "COORD2" [("x", A.Int), ("y", A.Int)]
+ defineRecordType "COORD3" [("x", A.Real32), ("y", A.Real32),
+ ("z", A.Real32)]
+ defineChannel "chanInt" (A.Chan A.DirUnknown ca A.Int)
+ defineVariable "mobileInt" (A.Mobile A.Int)
+ defineFunction "function0" [A.Int] []
+ defineFunction "function1" [A.Int] [("x", A.Int)]
+ defineFunction "function2" [A.Int] [("x", A.Int), ("y", A.Int)]
+ defineFunction "function22" [A.Int, A.Int]
+ [("x", A.Int), ("y", A.Int)]
+ where
+ ca = A.ChanAttributes False False
+
+-- | Test the typechecker.
+testOccamTypes :: Test
+testOccamTypes = TestList
+ [
+ -- Subscript expressions
+ testOK 0 $ A.Subscript m A.NoCheck intE
+ , testFail 1 $ A.Subscript m A.NoCheck byteE
+ , testOK 2 $ A.SubscriptFromFor m intE intE
+ , testFail 3 $ A.SubscriptFromFor m byteE byteE
+ , testOK 4 $ A.SubscriptFrom m intE
+ , testFail 5 $ A.SubscriptFrom m byteE
+ , testOK 6 $ A.SubscriptFor m intE
+ , testFail 7 $ A.SubscriptFor m byteE
+
+ -- Trivial literals
+ , testOK 20 $ intE
+ , testOK 21 $ byteE
+
+ -- Array literals
+ , testOK 30 $ A.Literal m twoIntsT twoInts
+ , testFail 31 $ A.Literal m threeIntsT twoInts
+ , testFail 32 $ A.Literal m twoBytesT twoInts
+ , testFail 33 $ A.Literal m A.Int twoInts
+ , testFail 34 $ A.Literal m twoTwoIntsT twoInts
+ , testOK 35 $ A.Literal m myTwoIntsT twoInts
+ , testFail 36 $ A.Literal m myIntT twoInts
+
+ -- Record literals
+ , testFail 40 $ A.Literal m coord2T twoInts
+ , testOK 41 $ A.Literal m coord2T coord2
+ , testFail 42 $ A.Literal m coord2T coord3
+ , testOK 43 $ A.Literal m coord3T coord3
+ , testFail 44 $ A.Literal m coord3T coord2
+ , testFail 45 $ A.Literal m A.Int coord2
+ , testFail 46 $ A.Literal m twoIntsT coord2
+ , testFail 47 $ A.Literal m myTwoIntsT coord2
+
+ -- Variables
+ , testOK 50 $ intV
+ , testOK 51 $ bytesV
+ , testOK 52 $ A.DirectedVariable m A.DirInput chanIntV
+ , testFail 53 $ A.DirectedVariable m A.DirInput intV
+ , testOK 54 $ A.DerefVariable m mobileIntV
+ , testFail 55 $ A.DerefVariable m chanIntV
+
+ -- Operators in expressions
+ , testOK 100 $ A.Monadic m A.MonadicSubtr intE
+ , testFail 101 $ A.Monadic m A.MonadicSubtr twoIntsE
+ , testFail 102 $ A.Monadic m A.MonadicSubtr boolE
+ , testFail 103 $ A.Monadic m A.MonadicNot intE
+ , testOK 104 $ A.Monadic m A.MonadicNot boolE
+ , testOK 105 $ A.Dyadic m A.Add intE intE
+ , testFail 106 $ A.Dyadic m A.Add intE byteE
+ , testFail 107 $ A.Dyadic m A.Add byteE intE
+ , testFail 108 $ A.Dyadic m A.Add byteE boolE
+ , testOK 109 $ A.Dyadic m A.LeftShift intE intE
+ , testOK 110 $ A.Dyadic m A.LeftShift byteE intE
+ , testFail 111 $ A.Dyadic m A.LeftShift intE byteE
+ , testOK 112 $ A.Dyadic m A.And boolE boolE
+ , testFail 113 $ A.Dyadic m A.And boolE intE
+ , testFail 114 $ A.Dyadic m A.And intE boolE
+ , testFail 115 $ A.Dyadic m A.Add twoIntsE twoIntsE
+ , testOK 116 $ A.Dyadic m A.Concat listE listE
+ , testFail 117 $ A.Dyadic m A.Concat listE intE
+ , testFail 118 $ A.Dyadic m A.Concat intE listE
+
+ -- Miscellaneous expressions
+ , testOK 150 $ A.MostPos m A.Int
+ , testFail 151 $ A.MostPos m twoIntsT
+ , testOK 152 $ A.MostNeg m A.Int
+ , testFail 153 $ A.MostNeg m twoIntsT
+ , testOK 154 $ A.SizeType m twoIntsT
+ , testFail 155 $ A.SizeType m A.Int
+ , testOK 156 $ A.SizeExpr m twoIntsE
+ , testFail 157 $ A.SizeExpr m intE
+ , testOK 158 $ A.SizeExpr m twoTwoIntsE
+ , testOK 159 $ A.SizeExpr m (sub0E twoTwoIntsE)
+ , testFail 160 $ A.SizeExpr m (sub0E (sub0E twoTwoIntsE))
+ , testFail 161 $ A.SizeExpr m (sub0E intE)
+ , testOK 162 $ A.SizeVariable m intsV
+ , testFail 163 $ A.SizeVariable m byteV
+ , testOK 164 $ A.ExprVariable m intV
+ , testOK 165 $ intE
+ , testOK 166 $ boolLiteral True
+ , testOK 167 $ A.IntrinsicFunctionCall m "SQRT" [realE]
+ , testFail 168 $ A.IntrinsicFunctionCall m "SQRT" [intE]
+ , testFail 169 $ A.IntrinsicFunctionCall m "SQRT" [realE, intE]
+ , testOK 170 $ subxE coord2E
+ , testFail 171 $ subxE twoTwoIntsE
+ , testFail 172 $ subxE intE
+ , testFail 173 $ A.SubscriptedExpr m (A.SubscriptField m function0) coord2E
+ , testOK 174 $ A.OffsetOf m coord2T (simpleName "x")
+ , testFail 175 $ A.OffsetOf m coord2T function0
+ , testFail 176 $ A.OffsetOf m A.Int (simpleName "x")
+
+ -- Conversions
+ , testOK 200 $ A.Conversion m A.Round A.Int realE
+ , testOK 201 $ A.Conversion m A.Round A.Real32 intE
+ , testFail 202 $ A.Conversion m A.Round A.Real32 twoIntsE
+ , testFail 203 $ A.Conversion m A.Round twoIntsT realE
+
+ -- Function calls
+ , testOK 220 $ A.FunctionCall m function0 []
+ , testOK 221 $ A.FunctionCall m function1 [intE]
+ , testOK 222 $ A.FunctionCall m function2 [intE, intE]
+ , testFail 223 $ A.FunctionCall m function22 [intE, intE]
+ , testFail 224 $ A.FunctionCall m function0 [intE]
+ , testFail 225 $ A.FunctionCall m function1 [intE, intE]
+ , testFail 226 $ A.FunctionCall m function2 [intE]
+ , testFail 227 $ A.FunctionCall m function2 [intE, intE, intE]
+ , testFail 228 $ A.FunctionCall m (simpleName "someInt") [intE]
+ , testFail 229 $ A.FunctionCall m function1 [realE]
+ , testFail 230 $ A.FunctionCall m function2 [intE, realE]
+ , testFail 231 $ A.FunctionCall m function2 [twoIntsE, intE]
+ , testOK 232 $ A.FunctionCall m function1 [sub0E twoIntsE]
+
+ -- Mobile allocations
+ , testOK 250 $ A.AllocMobile m (A.Mobile A.Int) (Just intE)
+ , testOK 251 $ A.AllocMobile m (A.Mobile A.Int) Nothing
+ , testFail 252 $ A.AllocMobile m (A.Mobile A.Int) (Just realE)
+ , testFail 253 $ A.AllocMobile m (A.Mobile A.Int) (Just realE)
+ , testOK 254 $ A.AllocMobile m (A.Mobile A.Real32) (Just realE)
+ , testOK 254 $ A.AllocMobile m (A.Mobile twoIntsT) (Just twoIntsE)
+ , testFail 255 $ A.AllocMobile m (A.Mobile unknownIntsT) (Just twoIntsE)
+ , testFail 256 $ A.AllocMobile m (A.Mobile unknownIntsT) Nothing
+ ]
+ where
+ testOK :: (Show a, Data a) => Int -> a -> Test
+ testOK n orig
+ = TestCase $ testPass ("testOccamTypes" ++ show n)
+ orig (OccamTypes.checkTypes orig)
+ startState
+
+ testFail :: (Show a, Data a) => Int -> a -> Test
+ testFail n orig
+ = TestCase $ testPassShouldFail ("testOccamTypes" ++ show n)
+ (OccamTypes.checkTypes orig)
+ startState
+
+ intV = variable "someInt"
+ intE = intLiteral 42
+ realE = A.Literal m A.Real32 $ A.RealLiteral m "3.14159"
+ byteV = variable "someByte"
+ byteE = byteLiteral 42
+ intsV = variable "someInts"
+ bytesV = variable "someBytes"
+ boolE = boolLiteral True
+ unknownIntsT = A.Array [A.UnknownDimension] A.Int
+ twoIntsT = A.Array [dimension 2] A.Int
+ twoTwoIntsT = A.Array [dimension 2, dimension 2] A.Int
+ twoBytesT = A.Array [dimension 2] A.Byte
+ threeIntsT = A.Array [dimension 3] A.Int
+ ae = A.ArrayElemExpr intE
+ twoInts = A.ArrayLiteral m [ae, ae]
+ twoIntsE = A.Literal m twoIntsT twoInts
+ twoTwoInts = A.ArrayLiteral m [A.ArrayElemArray [ae, ae],
+ A.ArrayElemArray [ae, ae]]
+ twoTwoIntsE = A.Literal m twoTwoIntsT twoTwoInts
+ myIntT = A.UserDataType (simpleName "MYINT")
+ myTwoIntsT = A.UserDataType (simpleName "MY2INT")
+ coord2T = A.Record (simpleName "COORD2")
+ coord2 = A.RecordLiteral m [intE, intE]
+ coord2E = A.Literal m coord2T coord2
+ coord3T = A.Record (simpleName "COORD3")
+ coord3 = A.RecordLiteral m [realE, realE, realE]
+ chanIntV = variable "chanInt"
+ mobileIntV = variable "mobileInt"
+ sub0 = A.Subscript m A.NoCheck (intLiteral 0)
+ sub0E = A.SubscriptedExpr m sub0
+ subx = A.SubscriptField m (simpleName "x")
+ subxE = A.SubscriptedExpr m subx
+ function0 = simpleName "function0"
+ function1 = simpleName "function1"
+ function2 = simpleName "function2"
+ function22 = simpleName "function22"
+ listT = A.List A.Int
+ listE = A.Literal m listT (A.ListLiteral m [intE, intE, intE])
+
+tests :: Test
+tests = TestLabel "OccamTypesTest" $ TestList
+ [ testOccamTypes
+ ]