diff --git a/common/AST.hs b/common/AST.hs index 5c25e69..7d49cac 100644 --- a/common/AST.hs +++ b/common/AST.hs @@ -475,7 +475,7 @@ data SpecType = -- | Declare a @PROC@. | Proc Meta SpecMode [Formal] Process -- | Declare a @FUNCTION@. - | Function Meta SpecMode [Type] [Formal] (Structured ExpressionList) + | Function Meta SpecMode [Type] [Formal] (Either (Structured ExpressionList) Process) -- | Declare a retyping abbreviation of a variable. | Retypes Meta AbbrevMode Type Variable -- | Declare a retyping abbreviation of an expression. diff --git a/common/FlowGraph.hs b/common/FlowGraph.hs index 7d30bf6c..828e62a 100644 --- a/common/FlowGraph.hs +++ b/common/FlowGraph.hs @@ -282,9 +282,11 @@ buildProcessOrFunctionSpec :: (Monad mAlter, Monad mLabel) => A.Specification -> buildProcessOrFunctionSpec (A.Specification _ _ (A.Proc m _ args p)) route = let procRoute = (route33 route A.Specification) in addNewSubProcFunc m args (Left (p, route44 procRoute A.Proc)) (route34 procRoute A.Proc) -buildProcessOrFunctionSpec (A.Specification _ _ (A.Function m _ _ args s)) route +buildProcessOrFunctionSpec (A.Specification _ _ (A.Function m _ _ args es)) route = let funcRoute = (route33 route A.Specification) in - addNewSubProcFunc m args (Right (s, route55 funcRoute A.Function)) (route45 funcRoute A.Function) + case es of + Left sel -> addNewSubProcFunc m args (Right (sel, route55 funcRoute A.Function @-> (\f (Left e) -> f e >>* Left))) (route45 funcRoute A.Function) + Right p -> addNewSubProcFunc m args (Left (p, route55 funcRoute A.Function @-> (\f (Right p) -> f p >>* Right))) (route45 funcRoute A.Function) buildProcessOrFunctionSpec _ _ = return () -- All the various types of Structured (SEQ, PAR, ALT, IF, CASE, input-CASE, VALOF) deal with their nodes so differently diff --git a/common/ShowCode.hs b/common/ShowCode.hs index dcd6090..96290c0 100644 --- a/common/ShowCode.hs +++ b/common/ShowCode.hs @@ -389,11 +389,11 @@ instance ShowOccam A.Specification where +>> occamOutdent +>> (showOccamLine colon) --TODO use the specmode - showOccamM (A.Specification _ n (A.Function _ sm retTypes params el@(A.Only {}))) + showOccamM (A.Specification _ n (A.Function _ sm retTypes params (Left el@(A.Only {})))) = showOccamLine $ showWithCommas retTypes +>> (return " FUNCTION ") +>> showName n +>> return "(" +>> showWithCommas params +>> return ")" +>> return " IS " +>> showOccamM el +>> colon - showOccamM (A.Specification _ n (A.Function _ sm retTypes params body)) + showOccamM (A.Specification _ n (A.Function _ sm retTypes params (Left body))) = (showOccamLine $ showWithCommas retTypes +>> (return " FUNCTION ") +>> showName n +>> return "(" +>> showWithCommas params +>> return ")") +>> occamIndent +>> showOccamM body diff --git a/frontends/ParseOccam.hs b/frontends/ParseOccam.hs index 90a6579..9a7e118 100644 --- a/frontends/ParseOccam.hs +++ b/frontends/ParseOccam.hs @@ -1373,8 +1373,8 @@ definition (rs, sm) <- tryVV (sepBy1 dataType sComma) (specMode sFUNCTION) n <- newFunctionName fs <- formalList - do { sIS; fs' <- scopeInFormals fs; el <- expressionList rs; scopeOutFormals fs'; sColon; eol; return $ A.Specification m n $ A.Function m sm rs fs' (A.Only m el) } - <|> do { eol; indent; fs' <- scopeInFormals fs; vp <- valueProcess rs; scopeOutFormals fs'; outdent; sColon; eol; return $ A.Specification m n $ A.Function m sm rs fs' vp } + do { sIS; fs' <- scopeInFormals fs; el <- expressionList rs; scopeOutFormals fs'; sColon; eol; return $ A.Specification m n $ A.Function m sm rs fs' (Left $ A.Only m el) } + <|> do { eol; indent; fs' <- scopeInFormals fs; vp <- valueProcess rs; scopeOutFormals fs'; outdent; sColon; eol; return $ A.Specification m n $ A.Function m sm rs fs' (Left vp) } <|> retypesAbbrev "definition" diff --git a/frontends/RainPassesTest.hs b/frontends/RainPassesTest.hs index f7cefce..9185bb2 100644 --- a/frontends/RainPassesTest.hs +++ b/frontends/RainPassesTest.hs @@ -384,7 +384,7 @@ testParamPass testName formals params transParams startStateFunc = do defineName (simpleName "x") $ simpleDefDecl "x" (A.UInt16) case formals of Nothing -> return () - Just formals' -> defineName (funcName "foo") $ simpleDef "foo" $ A.Function m A.PlainSpec [A.Byte] formals' (A.Only m $ A.ExpressionList m []) + Just formals' -> defineName (funcName "foo") $ simpleDef "foo" $ A.Function m A.PlainSpec [A.Byte] formals' (Left $ A.Only m $ A.ExpressionList m []) origProc = A.ProcCall m (procName "foo") params expProc ps = A.ProcCall m (procName "foo") ps origFunc = A.FunctionCall m (funcName "foo") (deActualise params) diff --git a/transformations/PassTest.hs b/transformations/PassTest.hs index ac3b31b..d13be71 100644 --- a/transformations/PassTest.hs +++ b/transformations/PassTest.hs @@ -61,7 +61,7 @@ assertGetItemCast k kv -- | Given a body, returns a function spec: singleParamFunc :: A.Structured A.ExpressionList -> A.Specification -singleParamFunc body = A.Specification m (simpleName "foo") (A.Function m A.PlainSpec [A.Int] [A.Formal A.ValAbbrev A.Byte (simpleName "param0")] body) +singleParamFunc body = A.Specification m (simpleName "foo") (A.Function m A.PlainSpec [A.Int] [A.Formal A.ValAbbrev A.Byte (simpleName "param0")] (Left body)) -- | Returns the expected body of the single parameter process (when the function had valof0 as a body) singleParamBodyExp :: Pattern -- ^ to match: A.Process @@ -94,7 +94,7 @@ testFunctionsToProcs1 :: Test testFunctionsToProcs1 = TestCase $ testPassWithItemsStateCheck "testFunctionsToProcs1 A" exp (functionsToProcs orig) (return ()) check where orig = A.Specification m (simpleName "foo") (A.Function m A.PlainSpec [A.Int,A.Real32] - [A.Formal A.ValAbbrev A.Byte (simpleName "param0"),A.Formal A.Abbrev A.Real32 (simpleName "param1")] (valofTwo "param0" "param1")) + [A.Formal A.ValAbbrev A.Byte (simpleName "param0"),A.Formal A.Abbrev A.Real32 (simpleName "param1")] (Left $ valofTwo "param0" "param1")) exp = tag3 A.Specification DontCare (simpleName "foo") procBody procBody = tag4 A.Proc DontCare A.PlainSpec [tag3 A.Formal A.ValAbbrev A.Byte (simpleName "param0"), tag3 A.Formal A.Abbrev A.Real32 (simpleName "param1"), @@ -123,7 +123,7 @@ testFunctionsToProcs1 = TestCase $ testPassWithItemsStateCheck "testFunctionsToP testFunctionsToProcs2 :: Test testFunctionsToProcs2 = TestCase $ testPassWithItemsStateCheck "testFunctionsToProcs2 A" exp (functionsToProcs orig) (return ()) check where - orig = A.Specification m (simpleName "fooOuter") (A.Function m A.PlainSpec [A.Int] [A.Formal A.ValAbbrev A.Byte (simpleName "paramOuter0")] $ + orig = A.Specification m (simpleName "fooOuter") (A.Function m A.PlainSpec [A.Int] [A.Formal A.ValAbbrev A.Byte (simpleName "paramOuter0")] $ Left $ A.Spec m (singleParamFunc valof0) valof0) exp = tag3 A.Specification DontCare (simpleName "fooOuter") procBodyOuter procHeader body = tag4 A.Proc DontCare A.PlainSpec [tag3 A.Formal A.ValAbbrev A.Byte (simpleName "paramOuter0"), tag3 A.Formal A.Abbrev A.Int (Named "retOuter0" DontCare)] body diff --git a/transformations/SimplifyExprs.hs b/transformations/SimplifyExprs.hs index 4319492..6669ea0 100644 --- a/transformations/SimplifyExprs.hs +++ b/transformations/SimplifyExprs.hs @@ -48,14 +48,14 @@ functionsToProcs = doGeneric `extM` doSpecification doGeneric = makeGeneric functionsToProcs doSpecification :: A.Specification -> PassM A.Specification - doSpecification (A.Specification m n (A.Function mf sm rts fs vp)) + doSpecification (A.Specification m n (A.Function mf sm rts fs evp)) = do -- Create new names for the return values. specs <- sequence [makeNonceVariable "return_formal" mf t A.VariableName A.Abbrev | t <- rts] let names = [n | A.Specification mf n _ <- specs] -- Note the return types so we can fix calls later. modify $ (\ps -> ps { csFunctionReturns = Map.insert (A.nameName n) rts (csFunctionReturns ps) }) -- Turn the value process into an assignment process. - let p = A.Seq mf $ vpToSeq vp [A.Variable mf n | n <- names] + let p = A.Seq mf $ vpToSeq evp [A.Variable mf n | n <- names] let st = A.Proc mf sm (fs ++ [A.Formal A.Abbrev t n | (t, n) <- zip rts names]) p -- Build a new specification and redefine the function. let spec = A.Specification m n st @@ -72,10 +72,12 @@ functionsToProcs = doGeneric `extM` doSpecification doGeneric spec doSpecification s = doGeneric s - vpToSeq :: A.Structured A.ExpressionList -> [A.Variable] -> A.Structured A.Process - vpToSeq (A.Spec m spec s) vs = A.Spec m spec (vpToSeq s vs) - vpToSeq (A.ProcThen m p s) vs = A.ProcThen m p (vpToSeq s vs) - vpToSeq (A.Only m el) vs = A.Only m $ A.Assign m vs el + vpToSeq :: Either (A.Structured A.ExpressionList) A.Process -> [A.Variable] -> A.Structured A.Process + vpToSeq (Left (A.Spec m spec s)) vs = A.Spec m spec (vpToSeq (Left s) vs) + vpToSeq (Left (A.ProcThen m p s)) vs = A.ProcThen m p (vpToSeq (Left s) vs) + vpToSeq (Left (A.Only m el)) vs = A.Only m $ A.Assign m vs el + -- TODO test and implement: + -- vpToSeq (Right p) vs = -- | Convert AFTER expressions to the equivalent using MINUS (which is how the -- occam 3 manual defines AFTER). diff --git a/transformations/SimplifyTypes.hs b/transformations/SimplifyTypes.hs index cded018..31d74c4 100644 --- a/transformations/SimplifyTypes.hs +++ b/transformations/SimplifyTypes.hs @@ -56,6 +56,7 @@ rntState p = (get >>= nullBodies >>= resolveNamedTypes >>= put) >> return p nullProcFuncDefs :: A.NameDef -> A.NameDef nullProcFuncDefs (A.NameDef m n on nt (A.Proc m' sm fs _) am pl) = (A.NameDef m n on nt (A.Proc m' sm fs (A.Skip m')) am pl) - nullProcFuncDefs (A.NameDef m n on nt (A.Function m' sm ts fs _) am pl) = (A.NameDef m n on nt (A.Function m' sm ts fs (A.Several m' [])) am pl) + nullProcFuncDefs (A.NameDef m n on nt (A.Function m' sm ts fs (Left _)) am pl) = (A.NameDef m n on nt (A.Function m' sm ts fs (Left $ A.Several m' [])) am pl) + nullProcFuncDefs (A.NameDef m n on nt (A.Function m' sm ts fs (Right _)) am pl) = (A.NameDef m n on nt (A.Function m' sm ts fs (Right $ A.Skip m')) am pl) nullProcFuncDefs x = x