Check Proc calls.

common/TestUtils.hs

@@ -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

frontends/OccamTypes.hs

@@ -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) $
+               do as <- sequence [do t <- typeOfExpression e
-                    diePC m $ formatCode ("Function % called with wrong number of arguments; found " ++ (show $ length es) ++ ", expected " ++ (show $ length fs)) n
+                                     return $ A.ActualExpression t e
-                  sequence_ [do rt <- typeOfExpression e
+                                  | e <- es]
-                                checkType (findMeta e) et rt
+                  checkActuals m n fs as
-                             | (e, A.Formal _ et _) <- zip es fs]
                   return rs
             _ -> diePC m $ formatCode "% is not a function" n
 
 -- | Check an intrinsic function call.
-checkIntrinsicFunctionCall :: Meta -> String -> [A.Expression] -> Bool
+checkIntrinsicFunctionCall :: Meta -> String -> [A.Expression] -> PassM ()
-                              -> PassM ()
+checkIntrinsicFunctionCall m n es
-checkIntrinsicFunctionCall m s es singleOnly
+    = case lookup n intrinsicFunctions of
-    = case lookup s intrinsicFunctions of
+        Just (rs, args) ->
-        Just (rs, tns) ->
+           do when (length rs /= 1) $
-           do when (singleOnly && length rs /= 1) $
+                dieP m $ "Function " ++ n ++ " used in an expression returns more than one value"
-                dieP m $ "Intrinsic function " ++ s ++ " used in an expression returns more than one value"
+              as <- sequence [do t <- typeOfExpression e
-              when (length es /= length tns) $
+                                 return $ A.ActualExpression t e
-                dieP m $ "Intrinsic function " ++ s ++ " called with wrong number of arguments; found " ++ (show $ length es) ++ ", expected " ++ (show $ length tns)
+                              | e <- es]
-              sequence_ [do rt <- typeOfExpression e
+              let fs = [A.Formal A.ValAbbrev t (A.Name m A.VariableName s)
-                            checkType (findMeta e) et rt
+                        | (t, s) <- args]
-                         | (e, (et, _)) <- zip es tns]
+              checkActuals m (A.Name m A.ProcName n) fs as
-        Nothing -> dieP m $ s ++ " is not an intrinsic function"
+        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
+    doProcess (A.ProcCall m n as)
-    -- IntrinsicProcCall
+        =  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 _)

frontends/OccamTypesTest.hs

@@ -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