suzanne.soy/tock-mirror
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Check Proc calls.

Browse Source
This commit is contained in:
Adam Sampson 2008-03-26 12:26:04 +00:00
parent 4e890a45d5
commit c9cb7d2bf9
3 changed files with 100 additions and 21 deletions

8
common/TestUtils.hs
View File

@ -365,6 +365,14 @@ defineFunction s rs as
st = A.Function emptyMeta A.PlainSpec rs fs (Right $ A.Skip emptyMeta)
fs = [A.Formal A.ValAbbrev t (simpleName s) | (s, t) <- as]
-- | Define a proc.
defineProc :: String -> [(String, A.AbbrevMode, A.Type)] -> State CompState ()
defineProc s as
= defineThing s A.ProcName st A.Original
where
st = A.Proc emptyMeta A.PlainSpec fs $ A.Skip emptyMeta
fs = [A.Formal am t (simpleName s) | (s, am, t) <- as]
-- | Define a protocol.
defineProtocol :: String -> [A.Type] -> State CompState ()
defineProtocol s ts

89
frontends/OccamTypes.hs
View File

@ -270,34 +270,70 @@ checkDyadicOp op l r
ListOp ->
checkList lm lt >> checkList rm rt >> checkType rm lt rt
-- | Check an abbreviation.
-- Is the second abbrev mode a valid abbreviation of the first?
checkAbbrev :: Meta -> A.AbbrevMode -> A.AbbrevMode -> PassM ()
checkAbbrev m orig new
= case (orig, new) of
(_, A.Original) -> bad
(A.ValAbbrev, A.ValAbbrev) -> ok
(A.ValAbbrev, _) -> bad
_ -> ok
where
bad = dieP m $ "You can't abbreviate " ++ showAM orig ++ " as " ++ showAM new
showAM :: A.AbbrevMode -> String
showAM A.Original = "an original declaration"
showAM A.Abbrev = "a reference abbreviation"
showAM A.ValAbbrev = "a value abbreviation"
-- | Check a set of actuals against the formals they're meant to match.
checkActuals :: Meta -> A.Name -> [A.Formal] -> [A.Actual] -> PassM ()
checkActuals m n fs as
= do when (length fs /= length as) $
diePC m $ formatCode ("% called with wrong number of arguments; found " ++ (show $ length as) ++ ", expected " ++ (show $ length fs)) n
sequence_ [checkActual f a
| (f, a) <- zip fs as]
-- | Check an actual against its matching formal.
checkActual :: A.Formal -> A.Actual -> PassM ()
checkActual (A.Formal newAM et _) a
= do rt <- case a of
A.ActualVariable _ _ v -> typeOfVariable v
A.ActualExpression _ e -> typeOfExpression e
checkType (findMeta a) et rt
origAM <- case a of
A.ActualVariable _ _ v -> abbrevModeOfVariable v
A.ActualExpression _ _ -> return A.ValAbbrev
checkAbbrev (findMeta a) origAM newAM
-- | Check a function call.
checkFunctionCall :: Meta -> A.Name -> [A.Expression] -> PassM [A.Type]
checkFunctionCall m n es
= do st <- specTypeOfName n
case st of
A.Function _ _ rs fs _ ->
do 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]
do as <- sequence [do t <- typeOfExpression e
return $ A.ActualExpression t e
| e <- es]
checkActuals m n fs as
return rs
_ -> diePC m $ formatCode "% is not a function" 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"
checkIntrinsicFunctionCall :: Meta -> String -> [A.Expression] -> PassM ()
checkIntrinsicFunctionCall m n es
= case lookup n intrinsicFunctions of
Just (rs, args) ->
do when (length rs /= 1) $
dieP m $ "Function " ++ n ++ " used in an expression returns more than one value"
as <- sequence [do t <- typeOfExpression e
return $ A.ActualExpression t e
| e <- es]
let fs = [A.Formal A.ValAbbrev t (A.Name m A.VariableName s)
| (t, s) <- args]
checkActuals m (A.Name m A.ProcName n) fs as
Nothing -> dieP m $ n ++ " is not an intrinsic function"
-- | Check a mobile allocation.
checkAllocMobile :: Meta -> A.Type -> Maybe A.Expression -> PassM ()
@ -410,6 +446,7 @@ checkProtocol m t tag items doItem
sequence_ [doItem it item
| (it, item) <- zip its items]
-- | Check an 'ExpressionList' matches a set of types.
checkExpressionList :: [A.Type] -> A.ExpressionList -> PassM ()
checkExpressionList ets el
= case el of
@ -497,7 +534,7 @@ checkExpressions = checkDepthM doExpression
when (length rs /= 1) $
diePC m $ formatCode "Function % used in an expression returns more than one value" n
doExpression (A.IntrinsicFunctionCall m s es)
= checkIntrinsicFunctionCall m s es True
= checkIntrinsicFunctionCall m s es
doExpression (A.SubscriptedExpr m s e)
= do t <- typeOfExpression e
checkSubscript m s t
@ -557,8 +594,18 @@ checkProcesses = checkDepthM doProcess
doProcess (A.Par _ _ s) = doStructured (\p -> ok) s
doProcess (A.Processor _ e _) = checkExpressionInt e
doProcess (A.Alt _ _ s) = doStructured doAlternative s
-- ProcCall
-- IntrinsicProcCall
doProcess (A.ProcCall m n as)
= do st <- specTypeOfName n
case st of
A.Proc _ _ fs _ -> checkActuals m n fs as
_ -> diePC m $ formatCode "% is not a procedure" n
doProcess (A.IntrinsicProcCall m n as)
= case lookup n intrinsicProcs of
Just args ->
do let fs = [A.Formal am t (A.Name m A.VariableName s)
| (am, t, s) <- args]
checkActuals m (A.Name m A.ProcName n) fs as
Nothing -> dieP m $ n ++ " is not an intrinsic procedure"
doAlternative :: A.Alternative -> PassM ()
doAlternative (A.Alternative m v im _)

24
frontends/OccamTypesTest.hs
View File

@ -67,6 +67,9 @@ startState
]
defineChannel "chanCaseProto" caseProtoT
defineTimer "tim" $ A.Timer A.OccamTimer
defineProc "proc0" []
defineProc "proc1" [("x", A.ValAbbrev, A.Int)]
defineProc "proc2" [("x", A.ValAbbrev, A.Int), ("y", A.Abbrev, A.Int)]
where
intsT = A.Array [A.UnknownDimension] A.Int
arrayLit = A.ArrayLiteral m []
@ -336,6 +339,17 @@ testOccamTypes = TestList
(insim [inv intV]) skip
, testFail 1507 $ testAlt $ A.AlternativeSkip m intE skip
-- Proc calls
, testOK 1600 $ proccall "proc0" []
, testOK 1601 $ proccall "proc1" [A.ActualExpression A.Int intE]
, testOK 1602 $ proccall "proc2" [A.ActualExpression A.Int intE,
A.ActualVariable A.Original A.Int intV]
, testFail 1603 $ proccall "proc0" [A.ActualExpression A.Int intE]
, testFail 1604 $ proccall "proc1" [A.ActualExpression A.Real32 realE]
, testFail 1605 $ proccall "proc1" [A.ActualExpression A.Int intE,
A.ActualExpression A.Int intE]
, testFail 1606 $ proccall "herring" []
-- Miscellaneous processes
, testOK 1900 $ A.ClearMobile m mobileIntV
, testFail 1901 $ A.ClearMobile m intV
@ -346,6 +360,15 @@ testOccamTypes = TestList
, testOK 1906 $ A.Par m A.PlainPar sskip
, testOK 1907 $ A.Processor m intE skip
, testFail 1908 $ A.Processor m realE skip
, testOK 1909 $ A.IntrinsicProcCall m "RESCHEDULE" []
, testOK 1910 $ A.IntrinsicProcCall m "ASSERT"
[A.ActualExpression A.Bool boolE]
, testFail 1911 $ A.IntrinsicProcCall m "ASSERT"
[A.ActualExpression A.Int intE]
, testFail 1912 $ A.IntrinsicProcCall m "ASSERT" []
, testFail 1913 $ A.IntrinsicProcCall m "RESCHEDULE"
[A.ActualExpression A.Bool boolE]
, testFail 1914 $ A.IntrinsicProcCall m "HERRING" []
--}}}
]
where
@ -426,6 +449,7 @@ testOccamTypes = TestList
oute = A.OutExpression m
tim = variable "tim"
testAlt a = A.Alt m True $ A.Only m a
proccall n = A.ProcCall m (simpleName n)
--}}}
tests :: Test