From e457d82f0c7df053b7f2f28dea61a8f4f679d864 Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Sat, 4 Apr 2009 14:56:35 +0000 Subject: [PATCH] Changed FUNCTIONs and PROCs to have optional bodies, and put all the externals into the AST (without bodies) This may seem like an odd change, but it simplifies the logic a lot. I kept having problems with passes not operating on externals (e.g. functions-to-procs, adding array sizes, constant folding in array dimensions) and adding a special case every time to also process the externals was getting silly. Putting the externals in the AST therefore made sense, but I didn't want to just add dummy bodies as this would cause them to throw up errors (e.g. in the type-checking for functions). So I turned the bodies into a Maybe type, and that has worked out well. I also stopped storing the formals in csExternals (since they are now in csNames, and the tree), which streamlined that nicely, and stopped me having to keep them up to date. --- backends/BackendPasses.hs | 26 ++++++-------------------- backends/GenerateC.hs | 8 +++++--- backends/GenerateCPPCSP.hs | 2 +- common/GenericUtils.hs | 8 +++++++- common/OccamEDSL.hs | 2 +- common/ShowCode.hs | 6 +++--- common/TestUtils.hs | 6 +++--- data/AST.hs | 8 ++++---- data/CompState.hs | 6 +++--- flow/FlowGraph.hs | 10 +++++----- flow/FlowGraphTest.hs | 10 +++++----- frontends/OccamPasses.hs | 4 ++-- frontends/OccamTypes.hs | 7 ++++--- frontends/OccamTypesTest.hs | 15 ++++++++------- frontends/ParseOccam.hs | 23 ++++++++++++----------- frontends/ParseRain.hs | 4 ++-- frontends/ParseRainTest.hs | 20 ++++++++++++-------- frontends/RainPasses.hs | 2 +- frontends/RainPassesTest.hs | 20 +++++++++++--------- pass/PassList.hs | 8 +++----- transformations/PassTest.hs | 10 +++++----- transformations/SimplifyAbbrevs.hs | 4 ++-- transformations/SimplifyAbbrevsTest.hs | 8 ++++---- transformations/SimplifyExprs.hs | 18 +++++------------- transformations/SimplifyProcs.hs | 2 +- 25 files changed, 115 insertions(+), 122 deletions(-) diff --git a/backends/BackendPasses.hs b/backends/BackendPasses.hs index 0ab22d8..3e330ed 100644 --- a/backends/BackendPasses.hs +++ b/backends/BackendPasses.hs @@ -234,14 +234,6 @@ declareSizesArray = occamOnlyPass "Declare array-size arrays" \t -> do pushPullContext t' <- recurse t >>= applyPulled popPullContext - exts <- getCompState >>* csExternals - exts' <- sequence [do fs' <- transformExternal (findMeta t) extType fs - modifyName (A.Name emptyMeta n) $ \nd -> nd - {A.ndSpecType = A.Proc (findMeta t) - (A.PlainSpec, A.PlainRec) fs' (A.Skip (findMeta t))} - return $ (n, (extType, fs')) - | (n, (extType, fs)) <- exts] - modify $ \cs -> cs { csExternals = exts' } return t' ) where @@ -358,7 +350,8 @@ declareSizesArray = occamOnlyPass "Declare array-size arrays" do -- We descend into the scope first, so that all the actuals get -- fixed before the formals: s' <- recurse s - (args', newargs) <- transformFormals Nothing m args + ext <- getCompState >>* csExternals >>* lookup (A.nameName n) + (args', newargs) <- transformFormals ext m args sequence_ [defineSizesName m' n (A.Declaration m' t) | A.Formal _ t n <- newargs] -- We descend into the body after the formals have been @@ -372,13 +365,6 @@ declareSizesArray = occamOnlyPass "Declare array-size arrays" _ -> descend str doStructured s = descend s - transformExternal :: Meta -> ExternalType -> [A.Formal] -> PassM [A.Formal] - transformExternal m extType args - = do (args', newargs) <- transformFormals (Just extType) m args - sequence_ [defineSizesName m n (A.Declaration m t) - | A.Formal _ t n <- newargs] - return args' - transformFormals :: Maybe ExternalType -> Meta -> [A.Formal] -> PassM ([A.Formal], [A.Formal]) transformFormals _ _ [] = return ([],[]) transformFormals ext m ((f@(A.Formal am t n)):fs) @@ -413,7 +399,7 @@ declareSizesArray = occamOnlyPass "Declare array-size arrays" doProcess :: A.Process -> PassM A.Process doProcess (A.ProcCall m n params) - = do ext <- getCompState >>* csExternals >>* lookup (A.nameName n) >>* fmap fst + = do ext <- getCompState >>* csExternals >>* lookup (A.nameName n) A.Proc _ _ fs _ <- specTypeOfName n concatMapM (transformActual ext) (zip fs params) >>* A.ProcCall m n doProcess p = descend p @@ -536,16 +522,16 @@ mobileReturn = cOnlyPass "Add MOBILE returns" [] [] recurse _ -> return (ps, f : fs') doStructured :: Data a => Transform (A.Structured a) - doStructured s@(A.Spec msp (A.Specification m n (A.Proc m' sm fs pr)) scope) + doStructured s@(A.Spec msp (A.Specification m n (A.Proc m' sm fs (Just pr))) scope) = do pr' <- recurse pr -- We do the scope first, so that all the callers are updated before -- we fix our state: scope' <- recurse scope ig <- ignoreProc n if ig - then return $ A.Spec msp (A.Specification m n (A.Proc m' sm fs pr')) scope' + then return $ A.Spec msp (A.Specification m n (A.Proc m' sm fs $ Just pr')) scope' else do (ps, fs') <- addChansForm m fs - let newSpec = A.Proc m' sm fs' (A.Seq m' $ A.Several m' $ + let newSpec = A.Proc m' sm fs' $ Just (A.Seq m' $ A.Several m' $ map (A.Only m') $ pr' : ps) modifyName n (\nd -> nd {A.ndSpecType = newSpec}) return $ A.Spec msp (A.Specification m n newSpec) scope' diff --git a/backends/GenerateC.hs b/backends/GenerateC.hs index add6a20..ff5e898 100644 --- a/backends/GenerateC.hs +++ b/backends/GenerateC.hs @@ -204,7 +204,7 @@ cgenTopLevel headerName s -- Forward declarations of externals: sequence_ [tell ["extern void ", mungeExternalName n, "(int*);"] - | (n, (ExternalOldStyle, _)) <- csExternals cs] + | (n, ExternalOldStyle) <- csExternals cs] call genStructured TopLevel s (\m _ -> tell ["\n#error Invalid top-level item: ", show m]) @@ -1584,7 +1584,7 @@ realFormals (A.Formal am t n) -- one of the original top-level procs, other than to add an occam_ prefix (which -- avoids name collisions). genProcSpec :: Level -> A.Name -> A.SpecType -> Bool -> CGen () -genProcSpec lvl n (A.Proc _ (sm, rm) fs p) forwardDecl +genProcSpec lvl n (A.Proc _ (sm, rm) fs (Just p)) forwardDecl = do cs <- getCompState let (header, params) = if n `Set.member` csParProcs cs || rm == A.Recursive @@ -1631,6 +1631,8 @@ genProcSpec lvl n (A.Proc _ (sm, rm) fs p) forwardDecl n | (t, n) <- rfs] tell [")"] +-- For externals, do nothing here: +genProcSpec _ _ (A.Proc _ _ _ Nothing) _ = return () -- | Generate a ProcAlloc for a PAR subprocess, returning a nonce for the -- workspace pointer and the name of the function to call. @@ -2060,7 +2062,7 @@ cgenProcCall n as (A.Recursive, _) -> let m = A.nameMeta n in call genPar A.PlainPar $ A.Only m $ A.ProcCall m n as - (_, Just (ExternalOldStyle, _)) -> + (_, Just ExternalOldStyle) -> do let (c:cs) = A.nameName n tell ["{int ext_args[] = {"] -- We don't use the formals in csExternals because they won't diff --git a/backends/GenerateCPPCSP.hs b/backends/GenerateCPPCSP.hs index f1864c0..11f11ca 100644 --- a/backends/GenerateCPPCSP.hs +++ b/backends/GenerateCPPCSP.hs @@ -574,7 +574,7 @@ cppgenForwardDeclaration _ = return () cppintroduceSpec :: Level -> A.Specification -> CGen () --I generate process wrappers for all functions by default: -cppintroduceSpec lvl (A.Specification _ n (A.Proc _ (sm, _) fs p)) +cppintroduceSpec lvl (A.Specification _ n (A.Proc _ (sm, _) fs (Just p))) = do --Generate the "process" as a C++ function: genStatic lvl n call genSpecMode sm diff --git a/common/GenericUtils.hs b/common/GenericUtils.hs index 224ecd6..a35f01a 100644 --- a/common/GenericUtils.hs +++ b/common/GenericUtils.hs @@ -29,7 +29,7 @@ module GenericUtils ( , gmapMFor , gmapMForRoute , routeModify, routeGet, routeSet, Route(..), (@->), routeIdentity, routeId, routeList - , route22, route23, route33, route34, route44, route45, route55 + , route11, route22, route23, route33, route34, route44, route45, route55 ) where import Control.Monad.Identity @@ -286,6 +286,9 @@ gmapMWithRoute f = gmapFuncs [GM {unGM = f' n} | n <- [0..]] makeRoute :: (Data s, Data t) => Int -> Route s t makeRoute target = Route [target] (\f -> gmapFuncs [mkM' (if n == target then f else return) | n <- [0..]]) +decomp11 :: (Monad m, Data a, Typeable a0) => (a0 -> a) -> (a0 -> m a0) -> (a -> m a) +decomp11 con f1 = decomp1 con f1 + decomp22 :: (Monad m, Data a, Typeable a0, Typeable a1) => (a0 -> a1 -> a) -> (a1 -> m a1) -> (a -> m a) decomp22 con f1 = decomp2 con return f1 @@ -311,6 +314,9 @@ decomp55 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3 (a0 -> a1 -> a2 -> a3 -> a4 -> a) -> (a4 -> m a4) -> (a -> m a) decomp55 con f4 = decomp5 con return return return return f4 +route11 :: (Data a, Typeable a0) => Route a b -> (a0 -> a) -> Route a0 b +route11 route con = route @-> Route [0] (decomp11 con) + route22 :: (Data a, Typeable a0, Typeable a1) => Route a b -> (a0 -> a1 -> a) -> Route a1 b route22 route con = route @-> Route [1] (decomp22 con) diff --git a/common/OccamEDSL.hs b/common/OccamEDSL.hs index cda7e2a..2b5f038 100644 --- a/common/OccamEDSL.hs +++ b/common/OccamEDSL.hs @@ -250,7 +250,7 @@ oPROC str params body scope = do s <- scope defineProc str [(A.nameName name, A.Original, t) | (t, A.Variable _ name) <- params] return $ A.Spec emptyMeta (A.Specification emptyMeta (simpleName str) $ - A.Proc emptyMeta (A.PlainSpec, A.PlainRec) formals p + A.Proc emptyMeta (A.PlainSpec, A.PlainRec) formals (Just p) ) (singlify s) where formals = [A.Formal A.Original t n | (t, A.Variable _ n) <- params] diff --git a/common/ShowCode.hs b/common/ShowCode.hs index 302be00..9ec4f22 100644 --- a/common/ShowCode.hs +++ b/common/ShowCode.hs @@ -508,7 +508,7 @@ instance ShowOccam A.RecordAttr where instance ShowOccam A.Specification where -- TODO add specmode to the output - showOccamM (A.Specification _ n (A.Proc _ sm params body)) + showOccamM (A.Specification _ n (A.Proc _ sm params (Just body))) = do let params' = intersperse (tell [","]) $ map showOccamM params showOccamLine $ do tell ["PROC "] showName n @@ -535,11 +535,11 @@ instance ShowOccam A.Specification where occamOutdent (showOccamLine colon) --TODO use the specmode - showOccamM (A.Specification _ n (A.Function _ sm retTypes params (Left el@(A.Only {})))) + showOccamM (A.Specification _ n (A.Function _ sm retTypes params (Just (Left el@(A.Only {}))))) = showOccamLine $ showWithCommas retTypes >> (tell [" FUNCTION "]) >> showName n >> tell ["("] >> showWithCommas params >> tell [")"] >> tell [" IS "] >> showOccamM el >> colon - showOccamM (A.Specification _ n (A.Function _ sm retTypes params (Left body))) + showOccamM (A.Specification _ n (A.Function _ sm retTypes params (Just (Left body)))) = (showOccamLine $ showWithCommas retTypes >> (tell [" FUNCTION "]) >> showName n >> tell ["("] >> showWithCommas params >> tell [")"]) >> occamIndent >> showOccamM body diff --git a/common/TestUtils.hs b/common/TestUtils.hs index 0fd8e56..7186138 100644 --- a/common/TestUtils.hs +++ b/common/TestUtils.hs @@ -111,7 +111,7 @@ testCheck config property = -- | Wraps a structured process into a complete AST fragment. wrapProcSeq :: A.Structured A.Process -> A.AST wrapProcSeq x = A.Spec emptyMeta (A.Specification emptyMeta (simpleName "foo") - $ A.Proc emptyMeta (A.PlainSpec, A.PlainRec) [] $ A.Seq emptyMeta x) (A.Several emptyMeta []) + $ A.Proc emptyMeta (A.PlainSpec, A.PlainRec) [] $ Just $ A.Seq emptyMeta x) (A.Several emptyMeta []) -- | Helper function to generate an array dimension. @@ -367,7 +367,7 @@ defineFunction :: String -> [A.Type] -> [(String, A.Type)] defineFunction s rs as = defineThing s st A.Original A.NameUser where - st = A.Function emptyMeta (A.PlainSpec, A.PlainRec) rs fs (Right $ A.Skip emptyMeta) + st = A.Function emptyMeta (A.PlainSpec, A.PlainRec) rs fs (Just $ Right $ A.Skip emptyMeta) fs = [A.Formal A.ValAbbrev t (simpleName s) | (s, t) <- as] -- | Define a proc. @@ -375,7 +375,7 @@ defineProc :: CSM m => String -> [(String, A.AbbrevMode, A.Type)] -> m () defineProc s as = defineThing s st A.Original A.NameUser where - st = A.Proc emptyMeta (A.PlainSpec, A.PlainRec) fs $ A.Skip emptyMeta + st = A.Proc emptyMeta (A.PlainSpec, A.PlainRec) fs $ Just $ A.Skip emptyMeta fs = [A.Formal am t (simpleName s) | (s, am, t) <- as] -- | Define a protocol. diff --git a/data/AST.hs b/data/AST.hs index 69c163e..78a3707 100644 --- a/data/AST.hs +++ b/data/AST.hs @@ -496,11 +496,11 @@ data SpecType = -- | Declare a variant protocol. -- The list pairs tag names with item types. | ProtocolCase Meta [(Name, [Type])] - -- | Declare a @PROC@. - | Proc Meta (SpecMode, RecMode) [Formal] Process - -- | Declare a @FUNCTION@. + -- | Declare a @PROC@. Body is Nothing if it's external + | Proc Meta (SpecMode, RecMode) [Formal] (Maybe Process) + -- | Declare a @FUNCTION@. Body is Nothing if it's external | Function Meta (SpecMode, RecMode) [Type] [Formal] - (Either (Structured ExpressionList) Process) + (Maybe (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/data/CompState.hs b/data/CompState.hs index b9b6fcc..58c27c3 100644 --- a/data/CompState.hs +++ b/data/CompState.hs @@ -135,7 +135,7 @@ data CompState = CompState { -- up (and therefore the things that should be visible to other files during -- separate compilation) csOriginalTopLevelProcs :: [String], - csExternals :: [(String, (ExternalType, [A.Formal]))], + csExternals :: [(String, ExternalType)], -- Maps an array variable name to the name of its _sizes array: csArraySizes :: Map String A.Name, -- Stores a map of constant sizes arrays declared for that size: @@ -396,7 +396,7 @@ defineNonce m s st am -- | Generate and define a no-arg wrapper PROC around a process. makeNonceProc :: CSM m => Meta -> A.Process -> m A.Specification makeNonceProc m p - = defineNonce m "wrapper_proc" (A.Proc m (A.PlainSpec, A.PlainRec) [] p) A.Abbrev + = defineNonce m "wrapper_proc" (A.Proc m (A.PlainSpec, A.PlainRec) [] (Just p)) A.Abbrev -- | Generate and define a counter for a replicator. makeNonceCounter :: CSM m => String -> Meta -> m A.Name @@ -440,7 +440,7 @@ findAllProcesses findAllProcesses' :: (String, A.NameDef) -> Maybe (String, A.Process) findAllProcesses' (n, nd) = case A.ndSpecType nd of - A.Proc _ _ _ p -> Just (n, p) + A.Proc _ _ _ (Just p) -> Just (n, p) _ -> Nothing -- | A new identifer for the unify types in the tree diff --git a/flow/FlowGraph.hs b/flow/FlowGraph.hs index c8b78ee..c4994af 100644 --- a/flow/FlowGraph.hs +++ b/flow/FlowGraph.hs @@ -69,16 +69,16 @@ addSpecNodes spec route -- Descends into process or function specifications, but doesn't join them up. Any other specifications are ignored buildProcessOrFunctionSpec :: (Monad mAlter, Monad mLabel) => A.Specification -> ASTModifier mAlter (A.Specification) structType -> GraphMaker mLabel mAlter label structType () -buildProcessOrFunctionSpec (A.Specification _ _ (A.Proc m _ args p)) route +buildProcessOrFunctionSpec (A.Specification _ _ (A.Proc m _ args (Just 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 es)) route + addNewSubProcFunc m args (Left (p, route11 (route44 procRoute A.Proc) Just)) (route34 procRoute A.Proc) +buildProcessOrFunctionSpec (A.Specification _ _ (A.Function m _ _ args (Just es))) route = let funcRoute = (route33 route A.Specification) in case es of Left sel -> addNewSubProcFunc m args (Right (sel, route55 funcRoute A.Function @-> (Route - [0] $ \f (Left e) -> f e >>* Left))) (route45 funcRoute A.Function) + [0,0] $ \f (Just (Left e)) -> f e >>* (Just . Left)))) (route45 funcRoute A.Function) Right p -> addNewSubProcFunc m args (Left (p, route55 funcRoute A.Function @-> (Route - [0] $ \f (Right p) -> f p >>* Right))) (route45 funcRoute A.Function) + [0,0] $ \f (Just (Right p)) -> f p >>* (Just . 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/flow/FlowGraphTest.hs b/flow/FlowGraphTest.hs index c980a88..3fc0196 100644 --- a/flow/FlowGraphTest.hs +++ b/flow/FlowGraphTest.hs @@ -386,27 +386,27 @@ testProcFuncSpec = TestLabel "testProcFuncSpec" $ TestList [ -- Single spec of process (with SKIP body) in AST (not connected up): testGraph' "testProcFuncSpec 0" [(0, m0), (5,m5)] [5] [(5,0,ESeq Nothing)] - (A.Spec mU (A.Specification m1 undefined $ A.Proc m5 undefined undefined sm0) $ A.Several mU []) + (A.Spec mU (A.Specification m1 undefined $ A.Proc m5 undefined undefined $ Just sm0) $ A.Several mU []) -- Single spec of process (with body with SEQ SKIP SKIP): ,testGraph' "testProcFuncSpec 1" [(0, m3), (4,m5), (9,m9)] [9] ([(9,0,ESeq Nothing), (0,4,ESeq Nothing)]) (A.Spec mU (A.Specification m6 undefined $ A.Proc m9 undefined undefined $ - A.Seq m0 $ A.Several m1 [A.Only m2 sm3,A.Only m4 sm5] + Just $ A.Seq m0 $ A.Several m1 [A.Only m2 sm3,A.Only m4 sm5] ) $ A.Several mU []) -- Nested spec of process (with bodies with SEQ SKIP SKIP): ,testGraph' "testProcFuncSpec 2" [(3,m2),(4,m3),(5,m4),(6,m5), (10,m10), (11, m11)] [10,11] ([(10,3,ESeq Nothing), (3,4,ESeq Nothing)] ++ [(11,5,ESeq Nothing), (5,6,ESeq Nothing)]) (A.Spec mU (A.Specification m6 undefined $ A.Proc m10 undefined undefined $ - A.Seq mU $ A.Several mU [A.Only mU sm2,A.Only mU sm3] + Just $ A.Seq mU $ A.Several mU [A.Only mU sm2,A.Only mU sm3] ) $ A.Spec mU (A.Specification m7 undefined $ A.Proc m11 undefined undefined $ - A.Seq mU $ A.Several mU [A.Only mU sm4,A.Only mU sm5] + Just $ A.Seq mU $ A.Several mU [A.Only mU sm4,A.Only mU sm5] ) $ A.Several mU []) -- Single spec of process (with SKIP body) in a SEQ (connected up): ,testGraph "testProcFuncSpec 10" [(0, m0),(1,m1),(2,sub m1 100), (3, m3), (5,m5)] [1,5] [(5,0,ESeq Nothing), (1,3,ESeq Nothing), (3,2,ESeq Nothing)] - (A.Seq mU $ A.Spec mU (A.Specification m1 undefined $ A.Proc m5 undefined undefined sm0) $ A.Several m3 []) + (A.Seq mU $ A.Spec mU (A.Specification m1 undefined $ A.Proc m5 undefined undefined $ Just sm0) $ A.Several m3 []) ] diff --git a/frontends/OccamPasses.hs b/frontends/OccamPasses.hs index 95f34a5..fde9c27 100644 --- a/frontends/OccamPasses.hs +++ b/frontends/OccamPasses.hs @@ -69,7 +69,7 @@ writeIncFile = occamOnlyPass "Write .inc file" [] [] )) where emitProcsAsExternal :: A.AST -> PassM (Seq.Seq String) - emitProcsAsExternal (A.Spec _ (A.Specification _ n (A.Proc _ _ fs _)) scope) + emitProcsAsExternal (A.Spec _ (A.Specification _ n (A.Proc _ _ fs (Just _))) scope) = do origN <- lookupName n >>* A.ndOrigName thisProc <- sequence ( [return $ "#PRAGMA TOCKEXTERNAL \"PROC " ++ origN ++ "(" @@ -79,7 +79,7 @@ writeIncFile = occamOnlyPass "Write .inc file" [] [] modify $ \cs -> cs { csOriginalTopLevelProcs = A.nameName n : csOriginalTopLevelProcs cs } emitProcsAsExternal scope >>* (thisProc Seq.<|) - emitProcsAsExternal (A.Spec _ (A.Specification _ n (A.Function _ _ ts fs _)) scope) + emitProcsAsExternal (A.Spec _ (A.Specification _ n (A.Function _ _ ts fs (Just _))) scope) = do origN <- lookupName n >>* A.ndOrigName thisProc <- sequence ( [return $ "#PRAGMA TOCKEXTERNAL \"" diff --git a/frontends/OccamTypes.hs b/frontends/OccamTypes.hs index b5744b8..bf1f724 100644 --- a/frontends/OccamTypes.hs +++ b/frontends/OccamTypes.hs @@ -937,12 +937,12 @@ inferTypes = occamOnlyPass "Infer types" _ -> return (t'', id) _ -> return (t'', id) return $ A.Is m am t''' $ A.ActualChannelArray $ map f vs' - A.Function m sm ts fs (Left sel) -> lift $ + A.Function m sm ts fs (Just (Left sel)) -> lift $ do sm' <- recurse sm ts' <- recurse ts fs' <- recurse fs sel' <- doFuncDef ts sel - return $ A.Function m sm' ts' fs' (Left sel') + return $ A.Function m sm' ts' fs' $ Just (Left sel') A.RetypesExpr _ _ _ _ -> lift $ noTypeContext $ descend st -- For PROCs that take any channels without direction, -- we must determine if we can infer a specific direction @@ -1404,7 +1404,7 @@ checkSpecTypes = checkDepthM doSpecType doSpecType (A.Proc m _ fs _) = sequence_ [when (am == A.Original) $ unexpectedAM m | A.Formal am _ n <- fs] - doSpecType (A.Function m _ rs fs body) + doSpecType (A.Function m _ rs fs (Just body)) = do when (length rs == 0) $ dieP m "A function must have at least one return type" sequence_ [do when (am /= A.ValAbbrev) $ @@ -1420,6 +1420,7 @@ checkSpecTypes = checkDepthM doSpecType doFunctionBody rs (Left s) = checkStructured (checkExpressionList rs) s -- FIXME: Need to know the name of the function to do this doFunctionBody rs (Right p) = dieP m "Cannot check function process body" + doSpecType (A.Function _ _ _ _ Nothing) = return () doSpecType (A.Retypes m am t v) = do fromT <- astTypeOf v checkRetypes m fromT t diff --git a/frontends/OccamTypesTest.hs b/frontends/OccamTypesTest.hs index dad2d44..7516ad5 100644 --- a/frontends/OccamTypesTest.hs +++ b/frontends/OccamTypesTest.hs @@ -457,18 +457,18 @@ testOccamTypes = TestList ] -- Proc - , testOK 2090 $ A.Proc m (A.PlainSpec, A.PlainRec) [] skip - , testOK 2091 $ A.Proc m (A.InlineSpec, A.PlainRec) [] skip + , testOK 2090 $ A.Proc m (A.PlainSpec, A.PlainRec) [] jskip + , testOK 2091 $ A.Proc m (A.InlineSpec, A.PlainRec) [] jskip , testOK 2092 $ A.Proc m (A.PlainSpec, A.PlainRec) [ A.Formal A.Abbrev A.Int (simpleName "x") , A.Formal A.ValAbbrev A.Int (simpleName "y") , A.Formal A.Abbrev chanIntT (simpleName "c") ] - skip + jskip , testFail 2093 $ A.Proc m (A.PlainSpec, A.PlainRec) [ A.Formal A.Original A.Int (simpleName "x") ] - skip + jskip -- Function , testOK 2100 $ A.Function m (A.PlainSpec, A.PlainRec) [A.Int] [] returnOne @@ -600,6 +600,7 @@ testOccamTypes = TestList --{{{ process fragments skip = A.Skip m + jskip = Just skip sskip = A.Only m skip insim iis = A.InputSimple m iis inputSimple c iis = A.Input m c $ insim iis @@ -620,9 +621,9 @@ testOccamTypes = TestList --}}} --{{{ specification fragments - returnNone = Left $ A.Only m $ A.ExpressionList m [] - returnOne = Left $ A.Only m $ A.ExpressionList m [intE] - returnTwo = Left $ A.Only m $ A.ExpressionList m [intE, intE] + returnNone = Just $ Left $ A.Only m $ A.ExpressionList m [] + returnOne = Just $ Left $ A.Only m $ A.ExpressionList m [intE] + returnTwo = Just $ Left $ A.Only m $ A.ExpressionList m [intE, intE] retypesV = A.Retypes m A.Abbrev retypesE = A.RetypesExpr m A.ValAbbrev diff --git a/frontends/ParseOccam.hs b/frontends/ParseOccam.hs index 1c914bd..ad51929 100644 --- a/frontends/ParseOccam.hs +++ b/frontends/ParseOccam.hs @@ -371,8 +371,7 @@ handleSpecs specs inner specMarker v <- inner mapM scopeOutSpec (reverse ss') after - return $ foldl (\e s -> specMarker m s e) v - [s | (s,(_,_,(_,A.NameUser))) <- zip ss' ss] + return $ foldl (\e s -> specMarker m s e) v ss' -- | Run several different parsers with a separator between them. -- If you give it [a, b, c] and s, it'll parse [a, s, b, s, c] then @@ -1179,7 +1178,7 @@ definition indent n' <- if rm == A.Recursive then scopeIn n ProcName - (A.Proc m (sm, rm) (map fst fs) (A.Skip m)) A.Original normalName + (A.Proc m (sm, rm) (map fst fs) Nothing) A.Original normalName else return n fs' <- scopeInFormals fs p <- process @@ -1187,7 +1186,7 @@ definition outdent sColon eol - return (A.Specification m n' $ A.Proc m (sm, rm) fs' p, ProcName, normalName) + return (A.Specification m n' $ A.Proc m (sm, rm) fs' (Just p), ProcName, normalName) <|> do m <- md (rs, (sm, (rm, _))) <- tryVV (sepBy1 dataType sComma) (specMode $ recMode sFUNCTION) n <- newFunctionName @@ -1195,7 +1194,7 @@ definition let addScope body = do n' <- if rm == A.Recursive then scopeIn n FunctionName - (A.Function m (sm, rm) rs (map fst fs) (Left $ A.Several m [])) + (A.Function m (sm, rm) rs (map fst fs) Nothing) A.Original normalName else return n fs' <- scopeInFormals fs @@ -1203,9 +1202,11 @@ definition scopeOutFormals fs' return (x, fs', n') do { sIS; (el, fs', n') <- addScope expressionList; sColon; eol; - return (A.Specification m n' $ A.Function m (sm, rm) rs fs' (Left $ A.Only m el), FunctionName, normalName) } + return (A.Specification m n' $ A.Function m (sm, rm) rs fs' + (Just $ Left $ A.Only m el), FunctionName, normalName) } <|> do { eol; indent; (vp, fs', n') <- addScope valueProcess; outdent; sColon; eol; - return (A.Specification m n' $ A.Function m (sm, rm) rs fs' (Left vp), FunctionName, normalName) } + return (A.Specification m n' $ A.Function m (sm, rm) rs fs' + (Just $ Left vp), FunctionName, normalName) } <|> retypesAbbrev "definition" where @@ -1421,23 +1422,23 @@ pragma = do m <- getPosition >>* sourcePosToMeta fs <- formalList' sEq integer - return (n, ProcName, n, fs, A.Proc m (A.PlainSpec, A.PlainRec) fs (A.Skip m)) + return (n, ProcName, n, fs, A.Proc m (A.PlainSpec, A.PlainRec) fs Nothing) else do sPROC origN <- anyName ProcName fs <- formalList' sEq n <- newProcName - return (n, ProcName, origN, fs, A.Proc m (A.PlainSpec, A.PlainRec) fs (A.Skip m)) + return (n, ProcName, origN, fs, A.Proc m (A.PlainSpec, A.PlainRec) fs Nothing) <|> do ts <- tryVX (sepBy1 dataType sComma) sFUNCTION origN <- anyName FunctionName fs <- formalList' sEq n <- newFunctionName return (n, FunctionName, origN, fs, A.Function m (A.PlainSpec, A.PlainRec) ts fs - $ Right (A.Skip m)) + Nothing) let ext = if pragmaType == 2 then ExternalOldStyle else ExternalOccam modify $ \st -> st - { csExternals = (A.nameName n, (ext, fs)) : csExternals st + { csExternals = (A.nameName n, ext) : csExternals st } return $ Just (A.Specification m origN sp, nt, (Just n, A.NameExternal)) ns <- case (prag, mprod) of diff --git a/frontends/ParseRain.hs b/frontends/ParseRain.hs index 706b49a..c2d2c7d 100644 --- a/frontends/ParseRain.hs +++ b/frontends/ParseRain.hs @@ -495,13 +495,13 @@ terminator = A.Several emptyMeta [] processDecl :: RainParser A.AST processDecl = do {m <- sProcess ; procName <- name ; params <- tupleDef ; body <- block ; return $ A.Spec m - (A.Specification m procName (A.Proc m (A.PlainSpec, A.Recursive) (formaliseTuple params) body)) + (A.Specification m procName (A.Proc m (A.PlainSpec, A.Recursive) (formaliseTuple params) $ Just body)) terminator} functionDecl :: RainParser A.AST functionDecl = do {m <- sFunction ; retType <- dataType ; sColon ; funcName <- name ; params <- tupleDef ; body <- innerBlock False (Just funcName) ; return $ A.Spec m - (A.Specification m funcName (A.Function m (A.PlainSpec, A.Recursive) [retType] (formaliseTuple params) (Right $ A.Seq m body))) + (A.Specification m funcName (A.Function m (A.PlainSpec, A.Recursive) [retType] (formaliseTuple params) (Just $ Right $ A.Seq m body))) terminator} topLevelDecl :: RainParser A.AST diff --git a/frontends/ParseRainTest.hs b/frontends/ParseRainTest.hs index b58bc93..ca2ae9e 100644 --- a/frontends/ParseRainTest.hs +++ b/frontends/ParseRainTest.hs @@ -487,21 +487,22 @@ testTopLevelDecl :: [ParseTest A.AST] testTopLevelDecl = [ passTop (0, "process noargs() {}", - [A.Spec m (A.Specification m (simpleName "noargs") $ A.Proc m (A.PlainSpec, A.Recursive) [] emptyBlock) emptySeveral]) + [A.Spec m (A.Specification m (simpleName "noargs") $ A.Proc m (A.PlainSpec, A.Recursive) [] jemptyBlock) emptySeveral]) ,passTop (1, "process onearg(int: x) {x = 0;}", [A.Spec m (A.Specification m (simpleName "onearg") $ A.Proc m (A.PlainSpec, A.Recursive) - [A.Formal A.ValAbbrev A.Int (simpleName "x")] $ + [A.Formal A.ValAbbrev A.Int (simpleName "x")] $ Just $ makeSeq [makeAssign (variable "x") (intLiteral 0)]) emptySeveral ]) ,passTop (2, "process noargs0() {} process noargs1 () {}", - [A.Spec m (A.Specification m (simpleName "noargs0") $ A.Proc m (A.PlainSpec, A.Recursive) [] emptyBlock) emptySeveral - ,A.Spec m (A.Specification m (simpleName "noargs1") $ A.Proc m (A.PlainSpec, A.Recursive) [] emptyBlock) emptySeveral]) + [A.Spec m (A.Specification m (simpleName "noargs0") $ A.Proc m (A.PlainSpec, A.Recursive) [] jemptyBlock) emptySeveral + ,A.Spec m (A.Specification m (simpleName "noargs1") $ A.Proc m (A.PlainSpec, A.Recursive) [] jemptyBlock) emptySeveral]) ,passTop (4, "process noargs() par {}", - [A.Spec m (A.Specification m (simpleName "noargs") $ A.Proc m (A.PlainSpec, A.Recursive) [] $ A.Par m A.PlainPar emptySeveral) emptySeveral]) + [A.Spec m (A.Specification m (simpleName "noargs") $ A.Proc m (A.PlainSpec, A.Recursive) [] $ + Just $ A.Par m A.PlainPar emptySeveral) emptySeveral]) , fail ("process", RP.topLevelDecl) , fail ("process () {}", RP.topLevelDecl) @@ -513,22 +514,25 @@ testTopLevelDecl = , fail ("process foo (int x) {}", RP.topLevelDecl) ,passTop (100, "function uint8: cons() {}", - [A.Spec m (A.Specification m (simpleName "cons") $ A.Function m (A.PlainSpec,A.Recursive) [A.Byte] [] $ Right emptyBlock) emptySeveral]) + [A.Spec m (A.Specification m (simpleName "cons") $ A.Function m (A.PlainSpec,A.Recursive) [A.Byte] [] + $ Just $ Right emptyBlock) emptySeveral]) ,passTop (101, "function uint8: f(uint8: x) {}", [A.Spec m (A.Specification m (simpleName "f") $ - A.Function m (A.PlainSpec, A.Recursive) [A.Byte] [A.Formal A.ValAbbrev A.Byte (simpleName "x")] $ Right emptyBlock) + A.Function m (A.PlainSpec, A.Recursive) [A.Byte] [A.Formal A.ValAbbrev A.Byte (simpleName "x")] + $ Just $ Right emptyBlock) emptySeveral]) ,passTop (102, "function uint8: id(uint8: x) {return x;}", [A.Spec m (A.Specification m (simpleName "id") $ - A.Function m (A.PlainSpec, A.Recursive) [A.Byte] [A.Formal A.ValAbbrev A.Byte (simpleName "x")] $ Right $ + A.Function m (A.PlainSpec, A.Recursive) [A.Byte] [A.Formal A.ValAbbrev A.Byte (simpleName "x")] $ Just $ Right $ A.Seq m $ A.Several m [A.Only m $ A.Assign m [variable "id"] (A.ExpressionList m [exprVariable "x"])]) emptySeveral]) ] where passTop :: (Int, String, [A.AST]) -> ParseTest A.AST passTop (ind, input, exp) = pass (input, RP.topLevelDecl, assertPatternMatch ("testTopLevelDecl " ++ show ind) $ pat $ A.Several m exp) + jemptyBlock = Just emptyBlock nonShared :: A.ChanAttributes nonShared = A.ChanAttributes { A.caWritingShared = A.Unshared, A.caReadingShared = A.Unshared} diff --git a/frontends/RainPasses.hs b/frontends/RainPasses.hs index bfb5a4b..023d7c7 100644 --- a/frontends/RainPasses.hs +++ b/frontends/RainPasses.hs @@ -223,7 +223,7 @@ checkFunction :: PassType checkFunction = return -- applyDepthM checkFunction' where checkFunction' :: A.Specification -> PassM A.Specification - checkFunction' spec@(A.Specification _ n (A.Function m _ _ _ (Right body))) + checkFunction' spec@(A.Specification _ n (A.Function m _ _ _ (Just (Right body)))) = case body of (A.Seq m' seqBody) -> let A.Several _ statements = skipSpecs seqBody in diff --git a/frontends/RainPassesTest.hs b/frontends/RainPassesTest.hs index 5e2723d..4fd3ed7 100644 --- a/frontends/RainPassesTest.hs +++ b/frontends/RainPassesTest.hs @@ -175,17 +175,19 @@ testUnique2b = TestCase $ testPassWithItemsStateCheck "testUnique2b" exp uniquif testUnique3 :: Test testUnique3 = TestCase $ testPassWithItemsStateCheck "testUnique3" exp uniquifyAndResolveVars orig (return ()) check where - orig = A.Spec m (A.Specification m (procName "foo") $ A.Proc m (A.PlainSpec, A.Recursive) [] $ A.Skip m) (A.Only m $ A.ProcCall m (procName "foo") []) + orig = A.Spec m (A.Specification m (procName "foo") $ A.Proc m (A.PlainSpec, A.Recursive) [] $ Just + $ A.Skip m) (A.Only m $ A.ProcCall m (procName "foo") []) exp = orig check (items,state) = assertVarDef "testUnique3: Variable was not recorded" state "foo" (tag7 A.NameDef DontCare "foo" "foo" - (A.Proc m (A.PlainSpec, A.Recursive) [] $ A.Skip m) A.Original A.NameUser A.Unplaced) + (A.Proc m (A.PlainSpec, A.Recursive) [] $ Just $ + A.Skip m) A.Original A.NameUser A.Unplaced) -- | Tests that parameters are uniquified and resolved: testUnique4 :: Test testUnique4 = TestCase $ testPassWithItemsStateCheck "testUnique4" exp uniquifyAndResolveVars orig (return ()) check where - orig = A.Spec m (A.Specification m (procName "foo") $ A.Proc m (A.PlainSpec, A.Recursive) [A.Formal A.ValAbbrev A.Byte $ simpleName "c"] $ + orig = A.Spec m (A.Specification m (procName "foo") $ A.Proc m (A.PlainSpec, A.Recursive) [A.Formal A.ValAbbrev A.Byte $ simpleName "c"] $ Just $ A.ProcCall m (procName "foo") [A.ActualExpression $ exprVariable "c"]) (skipP) exp = mSpecP (tag3 A.Specification DontCare (procNamePattern "foo") $ tag4 A.Proc DontCare (A.PlainSpec, A.Recursive) @@ -226,7 +228,7 @@ testUnique4 = TestCase $ testPassWithItemsStateCheck "testUnique4" exp uniquifyA testFindMain0 :: Test testFindMain0 = TestCase $ testPassWithItemsStateCheck "testFindMain0" exp (uniquifyAndResolveVars >>> findMain) orig (return ()) check where - orig = A.Spec m (A.Specification m (A.Name m "main") $ A.Proc m (A.PlainSpec, A.Recursive) [] (A.Skip m)) $ A.Several m [] :: A.AST + orig = A.Spec m (A.Specification m (A.Name m "main") $ A.Proc m (A.PlainSpec, A.Recursive) [] (Just $ A.Skip m)) $ A.Several m [] :: A.AST exp = mSpecAST (tag3 A.Specification DontCare (tag2 A.Name DontCare ("main"@@DontCare)) $ tag4 A.Proc DontCare (A.PlainSpec, A.Recursive) ([] :: [A.Formal]) (tag1 A.Skip DontCare)) $ mSeveralAST ([] :: [A.AST]) check (items,state) @@ -239,15 +241,15 @@ testFindMain0 = TestCase $ testPassWithItemsStateCheck "testFindMain0" exp (uniq testFindMain1 :: Test testFindMain1 = TestCase $ testPassWithStateCheck "testFindMain1" orig (uniquifyAndResolveVars >>> findMain) orig (return ()) check where - orig = A.Spec m (A.Specification m (A.Name m "foo") $ A.Proc m (A.PlainSpec, A.Recursive) [] (A.Skip m)) $ A.Several m ([] :: [A.AST]) + orig = A.Spec m (A.Specification m (A.Name m "foo") $ A.Proc m (A.PlainSpec, A.Recursive) [] (Just $ A.Skip m)) $ A.Several m ([] :: [A.AST]) check state = assertEqual "testFindMain1" [] (csMainLocals state) testFindMain2 :: Test testFindMain2 = TestCase $ testPassWithItemsStateCheck "testFindMain2" exp (uniquifyAndResolveVars >>> findMain) orig (return ()) check where - inner = A.Spec m (A.Specification m (A.Name m "foo") $ A.Proc m (A.PlainSpec, A.Recursive) [] (A.Skip m)) $ + inner = A.Spec m (A.Specification m (A.Name m "foo") $ A.Proc m (A.PlainSpec, A.Recursive) [] (Just $ A.Skip m)) $ A.Several m ([] :: [A.AST]) - orig = A.Spec m (A.Specification m (A.Name m "main") $ A.Proc m (A.PlainSpec, A.Recursive) [] (A.Skip m)) inner + orig = A.Spec m (A.Specification m (A.Name m "main") $ A.Proc m (A.PlainSpec, A.Recursive) [] (Just $ A.Skip m)) inner exp = mSpecAST (tag3 A.Specification DontCare (tag2 A.Name DontCare ("main"@@DontCare)) $ tag4 A.Proc DontCare (A.PlainSpec, A.Recursive) ([] :: [A.Formal]) (tag1 A.Skip DontCare)) (stopCaringPattern m $ mkPattern inner) @@ -274,12 +276,12 @@ testParamPass testName formals params transParams startStateProc = do defineName (simpleName "x") $ simpleDefDecl "x" (A.UInt16) case formals of Nothing -> return () - Just formals' -> defineName (procName "foo") $ simpleDef "foo" $ A.Proc m (A.PlainSpec, A.Recursive) formals' (A.Skip m) + Just formals' -> defineName (procName "foo") $ simpleDef "foo" $ A.Proc m (A.PlainSpec, A.Recursive) formals' (Just $ A.Skip m) startStateFunc :: State CompState () 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.Recursive) [A.Byte] formals' (Left $ A.Only m $ A.ExpressionList m []) + Just formals' -> defineName (funcName "foo") $ simpleDef "foo" $ A.Function m (A.PlainSpec,A.Recursive) [A.Byte] formals' (Just $ 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/pass/PassList.hs b/pass/PassList.hs index 513dcc3..8438c8c 100644 --- a/pass/PassList.hs +++ b/pass/PassList.hs @@ -88,11 +88,9 @@ nullStateBodies = Pass where nullProcFuncDefs :: A.NameDef -> A.NameDef nullProcFuncDefs (A.NameDef m n on (A.Proc m' sm fs _) am ns pl) - = (A.NameDef m n on (A.Proc m' sm fs (A.Skip m')) am ns pl) - nullProcFuncDefs (A.NameDef m n on (A.Function m' sm ts fs (Left _)) am ns pl) - = (A.NameDef m n on (A.Function m' sm ts fs (Left $ A.Several m' [])) am ns pl) - nullProcFuncDefs (A.NameDef m n on (A.Function m' sm ts fs (Right _)) am ns pl) - = (A.NameDef m n on (A.Function m' sm ts fs (Right $ A.Skip m')) am ns pl) + = (A.NameDef m n on (A.Proc m' sm fs Nothing) am ns pl) + nullProcFuncDefs (A.NameDef m n on (A.Function m' sm ts fs _) am ns pl) + = (A.NameDef m n on (A.Function m' sm ts fs Nothing) am ns pl) nullProcFuncDefs x = x diff --git a/transformations/PassTest.hs b/transformations/PassTest.hs index 0cb3968..77dcd68 100644 --- a/transformations/PassTest.hs +++ b/transformations/PassTest.hs @@ -61,11 +61,11 @@ 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.PlainRec) [A.Int] [A.Formal A.ValAbbrev A.Byte (simpleName "param0")] (Left body)) + A.PlainRec) [A.Int] [A.Formal A.ValAbbrev A.Byte (simpleName "param0")] (Just $ Left body)) singleParamFuncProc :: A.Process -> A.Specification singleParamFuncProc body = A.Specification m (simpleName "foo") (A.Function m (A.PlainSpec, - A.PlainRec) [A.Int] [A.Formal A.ValAbbrev A.Byte (simpleName "param0")] (Right body)) + A.PlainRec) [A.Int] [A.Formal A.ValAbbrev A.Byte (simpleName "param0")] (Just $ Right body)) -- | Returns the expected body of the single parameter process (when the function had valof0 as a body) singleParamBodyExp :: Pattern -- ^ to match: A.Process @@ -100,7 +100,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.Recursive) [A.Int,A.Real32] - [A.Formal A.ValAbbrev A.Byte (simpleName "param0"),A.Formal A.Abbrev A.Real32 (simpleName "param1")] (Left $ valofTwo "param0" "param1")) + [A.Formal A.ValAbbrev A.Byte (simpleName "param0"),A.Formal A.Abbrev A.Real32 (simpleName "param1")] (Just $ Left $ valofTwo "param0" "param1")) exp = tag3 A.Specification DontCare (simpleName "foo") procBody procBody = tag4 A.Proc DontCare (A.PlainSpec, A.Recursive) [tag3 A.Formal A.ValAbbrev A.Byte (simpleName "param0"), @@ -134,7 +134,7 @@ 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.PlainRec) [A.Int] [A.Formal A.ValAbbrev A.Byte (simpleName "paramOuter0")] $ Left $ + A.PlainRec) [A.Int] [A.Formal A.ValAbbrev A.Byte (simpleName "paramOuter0")] $ Just $ Left $ A.Spec m (singleParamFunc valof0) valof0) exp = tag3 A.Specification DontCare (simpleName "fooOuter") procBodyOuter procHeader body = tag4 A.Proc DontCare (A.PlainSpec, A.PlainRec) [tag3 A.Formal A.ValAbbrev A.Byte (simpleName "paramOuter0"), tag3 A.Formal A.Abbrev A.Int (Named "retOuter0" DontCare)] body @@ -190,7 +190,7 @@ testFunctionsToProcs4 = TestCase $ testPassWithItemsStateCheck "testFunctionsToP where orig = A.Specification m (simpleName "foo") (A.Function m (A.PlainSpec, A.PlainRec) [A.Int,A.Real32] [A.Formal A.ValAbbrev A.Byte (simpleName "param0"),A.Formal A.Abbrev A.Real32 (simpleName "param1")] $ - Right $ A.Seq m $ A.Only m $ A.Assign m [variable "foo"] $ A.ExpressionList m [exprVariable "param0", exprVariable "param1"]) + Just $ Right $ A.Seq m $ A.Only m $ A.Assign m [variable "foo"] $ A.ExpressionList m [exprVariable "param0", exprVariable "param1"]) exp = tag3 A.Specification DontCare (simpleName "foo") procBody procBody = tag4 A.Proc DontCare (A.PlainSpec, A.PlainRec) [tag3 A.Formal A.ValAbbrev A.Byte (simpleName "param0"), tag3 A.Formal A.Abbrev A.Real32 (simpleName "param1"), diff --git a/transformations/SimplifyAbbrevs.hs b/transformations/SimplifyAbbrevs.hs index 87ab273..db2833f 100644 --- a/transformations/SimplifyAbbrevs.hs +++ b/transformations/SimplifyAbbrevs.hs @@ -111,7 +111,7 @@ removeInitial -- process -- : -- inner - A.Proc m'' sm fs p -> + A.Proc m'' sm fs (Just p) -> do -- Find the INITIAL formals, and note their positions. let (positions, fromFS) = unzip [(i, f) @@ -144,7 +144,7 @@ removeInitial A.Only m' p)) p (reverse $ zip temps fromFS) - let spec' = A.Specification m' n (A.Proc m'' sm fs' p') + let spec' = A.Specification m' n (A.Proc m'' sm fs' (Just p')) return $ A.Spec m spec' inner _ -> leave diff --git a/transformations/SimplifyAbbrevsTest.hs b/transformations/SimplifyAbbrevsTest.hs index 017d834..e9132b4 100644 --- a/transformations/SimplifyAbbrevsTest.hs +++ b/transformations/SimplifyAbbrevsTest.hs @@ -60,11 +60,11 @@ testRemoveInitial = TestLabel "testRemoveInitial" $ TestList , ok 30 (spec foo (A.Proc m (A.PlainSpec, A.PlainRec) [A.Formal A.InitialAbbrev A.Int bar] - skip) + $ Just skip) inner) (mSpec foo (mProc (A.PlainSpec, A.PlainRec) [mFormal' A.ValAbbrev A.Int mTemp] - (mSeq + (Just $ mSeq (mDeclareAssign bar A.Int mTempE (A.Only m skip)))) inner) @@ -76,14 +76,14 @@ testRemoveInitial = TestLabel "testRemoveInitial" $ TestList , A.Formal A.ValAbbrev A.Int baz , A.Formal A.InitialAbbrev A.Int quux ] - skip) + (Just skip)) inner) (mSpec foo (mProc (A.PlainSpec, A.PlainRec) [ mFormal' A.ValAbbrev A.Int mTemp , mFormal' A.ValAbbrev A.Int baz , mFormal' A.ValAbbrev A.Int mTemp2 ] - (mSeq + (Just $ mSeq (mDeclareAssign bar A.Int mTempE (mOnlyP (mSeq diff --git a/transformations/SimplifyExprs.hs b/transformations/SimplifyExprs.hs index c3033cb..ffd6385 100644 --- a/transformations/SimplifyExprs.hs +++ b/transformations/SimplifyExprs.hs @@ -51,15 +51,7 @@ functionsToProcs = pass "Convert FUNCTIONs to PROCs" (Prop.agg_namesDone ++ [Prop.expressionTypesChecked, Prop.parUsageChecked, Prop.functionTypesChecked]) [Prop.functionsRemoved] - (\t -> do exts <- getCompState >>* csExternals - exts' <- sequence [do st <- specTypeOfName $ A.Name emptyMeta n - A.Specification _ _ st'@(A.Proc _ _ fs' _) <- - doSpecification $ A.Specification - (findMeta st) (A.Name emptyMeta n) st - return $ (n, (extType, fs')) - | (n, (extType, fs)) <- exts] - modify $ \cs -> cs { csExternals = exts' } - applyDepthM doSpecification t) + (applyDepthM doSpecification) where doSpecification :: A.Specification -> PassM A.Specification doSpecification (A.Specification m n (A.Function mf smrm rts fs evp)) @@ -69,7 +61,7 @@ functionsToProcs = pass "Convert FUNCTIONs to PROCs" -- 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 = vpToSeq m n evp [A.Variable mf n | n <- names] + let p = fmap (vpToSeq m n [A.Variable mf n | n <- names]) evp let st = A.Proc mf smrm (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 @@ -86,9 +78,9 @@ functionsToProcs = pass "Convert FUNCTIONs to PROCs" return spec doSpecification s = return s - vpToSeq :: Meta -> A.Name -> Either (A.Structured A.ExpressionList) A.Process -> [A.Variable] -> A.Process - vpToSeq m n (Left el) vs = A.Seq m $ vpToSeq' el vs - vpToSeq _ n (Right p) vs = subst p + vpToSeq :: Meta -> A.Name -> [A.Variable] -> Either (A.Structured A.ExpressionList) A.Process -> A.Process + vpToSeq m n vs (Left el) = A.Seq m $ vpToSeq' el vs + vpToSeq _ n vs (Right p) = subst p where subst :: Data t => t -> t subst = doGenericSubst `extT` doAssignSubst diff --git a/transformations/SimplifyProcs.hs b/transformations/SimplifyProcs.hs index f5bd411..1e4b161 100644 --- a/transformations/SimplifyProcs.hs +++ b/transformations/SimplifyProcs.hs @@ -169,7 +169,7 @@ flattenAssign = pass "Flatten assignment" let code = A.Seq m $ A.Several m $ map (A.Only m) assigns proc = A.Proc m (A.InlineSpec, A.PlainRec) [A.Formal A.Abbrev t nonceLHS, A.Formal A.ValAbbrev t nonceRHS] - code + (Just code) defineName n' $ A.NameDef { A.ndMeta = m, A.ndName = A.nameName n',