From bf07c441ae3f965ab8c01fe5336482d2295b5cf1 Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Sat, 17 May 2008 19:47:47 +0000 Subject: [PATCH] Changed the communication type checking to be part of the type unification framework --- frontends/RainPasses.hs | 2 +- frontends/RainTypes.hs | 83 ++++++++++---------------------------- frontends/RainTypesTest.hs | 42 +++++++++---------- 3 files changed, 43 insertions(+), 84 deletions(-) diff --git a/frontends/RainPasses.hs b/frontends/RainPasses.hs index 3514014..436e8ee 100644 --- a/frontends/RainPasses.hs +++ b/frontends/RainPasses.hs @@ -58,7 +58,7 @@ rainPasses = makePassesDep' ((== FrontendRain) . csFrontend) ,("Check types in expressions",checkExpressionTypes, namesDone ++ [Prop.noInt, Prop.constantsFolded, Prop.intLiteralsInBounds, Prop.inferredTypesRecorded], [Prop.expressionTypesChecked]) -- ,("Check types in assignments", checkAssignmentTypes, typesDone ++ [Prop.expressionTypesChecked], [Prop.processTypesChecked]) -- ,("Check types in if/while conditions",checkConditionalTypes, typesDone ++ [Prop.expressionTypesChecked], [Prop.processTypesChecked]) - ,("Check types in input/output",checkCommTypes, typesDone ++ [Prop.expressionTypesChecked], [Prop.processTypesChecked]) +-- ,("Check types in input/output",checkCommTypes, typesDone ++ [Prop.expressionTypesChecked], [Prop.processTypesChecked]) ,("Check parameters in process calls", matchParamPass, typesDone, [Prop.processTypesChecked, Prop.functionTypesChecked]) diff --git a/frontends/RainTypes.hs b/frontends/RainTypes.hs index d4e36df..2a796da 100644 --- a/frontends/RainTypes.hs +++ b/frontends/RainTypes.hs @@ -90,6 +90,7 @@ performTypeUnification x -- First, we markup all the types in the tree: = do x' <- markConditionalTypes <.< markAssignmentTypes + <.< markCommTypes $ x --TODO markup everything else -- Then, we do the unification: prs <- get >>* csUnifyPairs @@ -392,76 +393,34 @@ markConditionalTypes = checkDepthM2 checkWhile checkIf = markUnify exp A.Bool -- | Checks the types in inputs and outputs, including inputs in alts -checkCommTypes :: Data t => t -> PassM t -checkCommTypes = applyDepthM2 checkInputOutput checkAltInput +markCommTypes :: Data t => t -> PassM t +markCommTypes = checkDepthM2 checkInputOutput checkAltInput where - checkInput :: A.Variable -> A.Variable -> Meta -> a -> PassM a + checkInput :: A.Variable -> A.Variable -> Meta -> a -> PassM () checkInput chanVar destVar m p - = do chanType <- astTypeOf chanVar - destType <- astTypeOf destVar - case chanType of - A.Chan dir _ innerType -> - if (dir == A.DirOutput) - then dieP m $ "Tried to input from the writing end of a channel: " ++ show chanVar - else - if (innerType == destType) - then return p - else diePC m $ formatCode "Mis-matching types; channel: \"%\" has inner-type: % but destination variable: \"%\" has type: %" - chanVar innerType destVar destType - _ -> dieP m $ "Tried to input from a variable that is not of type channel: " ++ show chanVar + = astTypeOf destVar >>= markUnify chanVar . A.Chan A.DirInput (A.ChanAttributes + False False) - checkWait :: A.InputMode -> PassM () - checkWait (A.InputTimerFor m exp) - = do t <- astTypeOf exp - when (t /= A.Time) $ - diePC m $ formatCode "Tried to wait for something that was not of time type: %" - t - checkWait (A.InputTimerAfter m exp) - = do t <- astTypeOf exp - when (t /= A.Time) $ - diePC m $ formatCode "Tried to wait for something that was not of time type: %" - t - checkWait (A.InputTimerRead m (A.InVariable _ v)) - = do t <- astTypeOf v - when (t /= A.Time) $ - diePC m $ formatCode "Tried to wait for something that was not of time type: %" - t + checkWait :: Check A.InputMode + checkWait (A.InputTimerFor m exp) = markUnify A.Time exp + checkWait (A.InputTimerAfter m exp) = markUnify A.Time exp + checkWait (A.InputTimerRead m (A.InVariable _ v)) = markUnify A.Time v checkWait _ = return () - checkInputOutput :: A.Process -> PassM A.Process + checkInputOutput :: Check A.Process checkInputOutput p@(A.Input m chanVar (A.InputSimple _ [A.InVariable _ destVar])) = checkInput chanVar destVar m p - checkInputOutput p@(A.Input _ _ im@(A.InputTimerFor {})) - = do checkWait im - return p - checkInputOutput p@(A.Input _ _ im@(A.InputTimerAfter {})) - = do checkWait im - return p - checkInputOutput p@(A.Input _ _ im@(A.InputTimerRead {})) - = do checkWait im - return p + checkInputOutput (A.Input _ _ im@(A.InputTimerFor {})) = checkWait im + checkInputOutput (A.Input _ _ im@(A.InputTimerAfter {})) = checkWait im + checkInputOutput (A.Input _ _ im@(A.InputTimerRead {})) = checkWait im checkInputOutput p@(A.Output m chanVar [A.OutExpression m' srcExp]) - = do chanType <- astTypeOf chanVar - srcType <- astTypeOf srcExp - case chanType of - A.Chan dir _ innerType -> - if (dir == A.DirInput) - then dieP m $ "Tried to output to the reading end of a channel: " ++ show chanVar - else - if (innerType == srcType) - then return p - else do castExp <- coerceType " for writing to channel" innerType srcType srcExp - return $ A.Output m chanVar [A.OutExpression m' castExp] - _ -> dieP m $ "Tried to output to a variable that is not of type channel: " ++ show chanVar - checkInputOutput p = return p + = astTypeOf srcExp >>= markUnify chanVar . A.Chan A.DirOutput (A.ChanAttributes + False False) + checkInputOutput _ = return () - checkAltInput :: A.Alternative -> PassM A.Alternative + checkAltInput :: Check A.Alternative checkAltInput a@(A.Alternative m _ chanVar (A.InputSimple _ [A.InVariable _ destVar]) body) = checkInput chanVar destVar m a - checkAltInput a@(A.Alternative m _ _ im@(A.InputTimerFor {}) _) - = do checkWait im - return a - checkAltInput a@(A.Alternative m _ _ im@(A.InputTimerAfter {}) _) - = do checkWait im - return a - checkAltInput a = return a + checkAltInput (A.Alternative m _ _ im@(A.InputTimerFor {}) _) = checkWait im + checkAltInput (A.Alternative m _ _ im@(A.InputTimerAfter {}) _) = checkWait im + checkAltInput _ = return () diff --git a/frontends/RainTypesTest.hs b/frontends/RainTypesTest.hs index a4eef32..424f496 100644 --- a/frontends/RainTypesTest.hs +++ b/frontends/RainTypesTest.hs @@ -297,26 +297,26 @@ checkExpressionTest = TestList ,passSame 6503 A.Bool $ Dy (Var "t") A.More (Var "t") --Now statements: - ,testPassUntouched 7000 checkCommTypes (getTime $ variable "t") + ,testPassUntouched 7000 performTypeUnification (getTime $ variable "t") ,TestCase $ testPassShouldFail "checkExpressionTest 7001" - (checkCommTypes $ getTime $ variable "x") state + (performTypeUnification $ getTime $ variable "x") state --Wait statements: - ,testPassUntouched 7100 checkCommTypes (waitFor $ exprVariable "t") - ,TestCase $ testPassShouldFail "checkExpressionTest 7101" (checkCommTypes $ waitFor $ exprVariable "x") state - ,testPassUntouched 7102 checkCommTypes (waitFor $ buildExpr $ Dy (Var "t") A.Plus (Var "t")) + ,testPassUntouched 7100 performTypeUnification (waitFor $ exprVariable "t") + ,TestCase $ testPassShouldFail "checkExpressionTest 7101" (performTypeUnification $ waitFor $ exprVariable "x") state + ,testPassUntouched 7102 performTypeUnification (waitFor $ buildExpr $ Dy (Var "t") A.Plus (Var "t")) - ,testPassUntouched 7200 checkCommTypes (waitUntil $ exprVariable "t") - ,TestCase $ testPassShouldFail "checkExpressionTest 7201" (checkCommTypes $ waitUntil $ exprVariable "x") state - ,testPassUntouched 7202 checkCommTypes (waitUntil $ buildExpr $ Dy (Var "t") A.Plus (Var "t")) + ,testPassUntouched 7200 performTypeUnification (waitUntil $ exprVariable "t") + ,TestCase $ testPassShouldFail "checkExpressionTest 7201" (performTypeUnification $ waitUntil $ exprVariable "x") state + ,testPassUntouched 7202 performTypeUnification (waitUntil $ buildExpr $ Dy (Var "t") A.Plus (Var "t")) - ,testPassUntouched 7300 checkCommTypes (altWaitFor (exprVariable "t") $ A.Skip m) - ,TestCase $ testPassShouldFail "checkExpressionTest 7301" (checkCommTypes $ altWaitFor (exprVariable "x") $ A.Skip m) state - ,testPassUntouched 7302 checkCommTypes (altWaitFor (buildExpr $ Dy (Var "t") A.Plus (Var "t")) $ A.Skip m) + ,testPassUntouched 7300 performTypeUnification (altWaitFor (exprVariable "t") $ A.Skip m) + ,TestCase $ testPassShouldFail "checkExpressionTest 7301" (performTypeUnification $ altWaitFor (exprVariable "x") $ A.Skip m) state + ,testPassUntouched 7302 performTypeUnification (altWaitFor (buildExpr $ Dy (Var "t") A.Plus (Var "t")) $ A.Skip m) - ,testPassUntouched 7400 checkCommTypes (altWaitUntil (exprVariable "t") $ A.Skip m) - ,TestCase $ testPassShouldFail "checkExpressionTest 7401" (checkCommTypes $ altWaitUntil (exprVariable "x") $ A.Skip m) state - ,testPassUntouched 7402 checkCommTypes (altWaitUntil (buildExpr $ Dy (Var "t") A.Plus (Var "t")) $ A.Skip m) + ,testPassUntouched 7400 performTypeUnification (altWaitUntil (exprVariable "t") $ A.Skip m) + ,TestCase $ testPassShouldFail "checkExpressionTest 7401" (performTypeUnification $ altWaitUntil (exprVariable "x") $ A.Skip m) state + ,testPassUntouched 7402 performTypeUnification (altWaitUntil (buildExpr $ Dy (Var "t") A.Plus (Var "t")) $ A.Skip m) ] where -- The type of a timer should not be checked, because it will only have parsed @@ -384,8 +384,8 @@ checkExpressionTest = TestList testCheckCommTypesIn :: Int -> (A.Direction,A.Type,A.Variable) -> (A.Type,A.Variable) -> Test testCheckCommTypesIn n (chanDir,chanType,chanVar) (destType,destVar) = if (chanType == destType && chanDir /= A.DirOutput) - then TestCase $ testPass ("testCheckCommTypesIn " ++ show n) (mkPattern st) (checkCommTypes st) state - else TestCase $ testPassShouldFail ("testCheckCommTypesIn " ++ show n) (checkCommTypes st) state + then TestCase $ testPass ("testCheckCommTypesIn " ++ show n) (mkPattern st) (performTypeUnification st) state + else TestCase $ testPassShouldFail ("testCheckCommTypesIn " ++ show n) (performTypeUnification st) state where st = A.Input m chanVar $ A.InputSimple m [A.InVariable m destVar] @@ -394,8 +394,8 @@ checkExpressionTest = TestList testCheckCommTypesInAlt :: Int -> (A.Direction,A.Type,A.Variable) -> (A.Type,A.Variable) -> Test testCheckCommTypesInAlt n (chanDir,chanType,chanVar) (destType,destVar) = if (chanType == destType && chanDir /= A.DirOutput) - then TestCase $ testPass ("testCheckCommTypesIn " ++ show n) (mkPattern st) (checkCommTypes st) state - else TestCase $ testPassShouldFail ("testCheckCommTypesIn " ++ show n) (checkCommTypes st) state + then TestCase $ testPass ("testCheckCommTypesIn " ++ show n) (mkPattern st) (performTypeUnification st) state + else TestCase $ testPassShouldFail ("testCheckCommTypesIn " ++ show n) (performTypeUnification st) state where st = A.Alt m True $ A.Only m $ A.Alternative m (A.True m) chanVar (A.InputSimple m [A.InVariable m destVar]) $ A.Skip m @@ -420,10 +420,10 @@ checkExpressionTest = TestList testCheckCommTypesOut n (chanDir,chanType,chanVar) (srcType,srcVar) = if (isImplicitConversionRain srcType chanType && chanDir /= A.DirInput) then (if srcType == chanType - then TestCase $ testPass ("testCheckCommTypesOut " ++ show n) (mkPattern st) (checkCommTypes st) state - else TestCase $ testPass ("testCheckCommTypesOut " ++ show n) stCast (checkCommTypes st) state + then TestCase $ testPass ("testCheckCommTypesOut " ++ show n) (mkPattern st) (performTypeUnification st) state + else TestCase $ testPass ("testCheckCommTypesOut " ++ show n) stCast (performTypeUnification st) state ) - else TestCase $ testPassShouldFail ("testCheckCommTypesOut " ++ show n) (checkCommTypes st) state + else TestCase $ testPassShouldFail ("testCheckCommTypesOut " ++ show n) (performTypeUnification st) state where st = A.Output m chanVar [A.OutExpression m $ A.ExprVariable m srcVar] stCast = tag3 A.Output DontCare chanVar [tag2 A.OutExpression DontCare $ tag4 A.Conversion DontCare A.DefaultConversion chanType $