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.
This commit is contained in:
Neil Brown
parent
2a321d7910
commit
e457d82f0c
|
|
@ -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'
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 [])
|
||||
|
||||
]
|
||||
|
||||
|
|
|
|||
|
|
@ -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 \""
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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"),
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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',
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user