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

Fixed operators defined inside functions not being recorded in csOperators

Browse Source
This commit is contained in:
Neil Brown 2009-04-10 16:07:18 +00:00
parent e53da5822f
commit ce0214cbf4
1 changed files with 35 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

61
frontends/OccamTypes.hs
View File

@ -837,28 +837,20 @@ inferTypes = occamOnlyPass "Infer types"
p' <- recurse p p' <- recurse p
return $ A.Variant m n iis' p' return $ A.Variant m n iis' p'
doStructured :: Data a => Transform (A.Structured a) doStructured :: Data a => Transform (A.Structured a)
doStructured (A.Spec mspec s@(A.Specification m n st) body) doStructured (A.Spec mspec s@(A.Specification m n st) body)
= do st' <- runReaderT (doSpecType n st) body = do (st', wrap) <- runReaderT (doSpecType n st) body
-- Update the definition of each name after we handle it. -- Update the definition of each name after we handle it.
modifyName n (\nd -> nd { A.ndSpecType = st' }) modifyName n (\nd -> nd { A.ndSpecType = st' })
let doBody = recurse body >>* A.Spec mspec (A.Specification m n st') wrap (recurse body) >>* A.Spec mspec (A.Specification m n st')
mOp <- functionOperator n
case (st, mOp) of
(A.Function _ _ _ fs _, Just raw) -> do
ts <- mapM astTypeOf fs
modify $ \cs -> cs { csOperators = (raw, n, ts) : csOperators cs }
x <- doBody
modify $ \cs -> cs { csOperators = tail (csOperators cs)}
return x
_ -> doBody
doStructured s = descend s doStructured s = descend s
doSpecType :: Data a => A.Name -> A.SpecType -> ReaderT (A.Structured a) PassM A.SpecType -- The second parameter is a modifier (wrapper) for the descent into the body
doSpecType :: Data a => A.Name -> A.SpecType -> ReaderT (A.Structured a) PassM
(A.SpecType, PassM (A.Structured a) -> PassM (A.Structured a))
doSpecType n st doSpecType n st
= case st of = case st of
A.Place _ _ -> lift $ inTypeContext (Just A.Int) $ descend st A.Place _ _ -> lift $ inTypeContext (Just A.Int) $ descend st >>* addId
A.Is m am t (A.ActualVariable v) -> A.Is m am t (A.ActualVariable v) ->
do am' <- lift $ recurse am do am' <- lift $ recurse am
t' <- lift $ recurse t t' <- lift $ recurse t
@ -892,7 +884,7 @@ inferTypes = occamOnlyPass "Infer types"
return (tEnd, A.DirectedVariable m dir v') return (tEnd, A.DirectedVariable m dir v')
_ -> return (t', v') -- no direction, or two _ -> return (t', v') -- no direction, or two
_ -> return (t', v') _ -> return (t', v')
return $ A.Is m am' t'' $ A.ActualVariable v'' return $ addId $ A.Is m am' t'' $ A.ActualVariable v''
A.Is m am t (A.ActualExpression e) -> lift $ A.Is m am t (A.ActualExpression e) -> lift $
do am' <- recurse am do am' <- recurse am
t' <- recurse t t' <- recurse t
@ -901,7 +893,7 @@ inferTypes = occamOnlyPass "Infer types"
A.Infer -> astTypeOf e' A.Infer -> astTypeOf e'
A.Array ds _ | A.UnknownDimension `elem` ds -> astTypeOf e' A.Array ds _ | A.UnknownDimension `elem` ds -> astTypeOf e'
_ -> return t' _ -> return t'
return $ A.Is m am' t'' (A.ActualExpression e') return $ addId $ A.Is m am' t'' (A.ActualExpression e')
A.Is m am t (A.ActualClaim v) -> lift $ A.Is m am t (A.ActualClaim v) -> lift $
do am' <- recurse am do am' <- recurse am
t' <- recurse t t' <- recurse t
@ -909,7 +901,7 @@ inferTypes = occamOnlyPass "Infer types"
t'' <- case t' of t'' <- case t' of
A.Infer -> astTypeOf (A.ActualClaim v') A.Infer -> astTypeOf (A.ActualClaim v')
_ -> return t' _ -> return t'
return $ A.Is m am' t'' (A.ActualClaim v') return $ addId $ A.Is m am' t'' (A.ActualClaim v')
A.Is m am t (A.ActualChannelArray vs) -> A.Is m am t (A.ActualChannelArray vs) ->
-- No expressions in this -- but we may need to infer the type -- No expressions in this -- but we may need to infer the type
-- of the variable if it's something like "cs IS [c]:". -- of the variable if it's something like "cs IS [c]:".
@ -935,21 +927,35 @@ inferTypes = occamOnlyPass "Infer types"
,A.DirectedVariable m dir) ,A.DirectedVariable m dir)
_ -> return (t'', id) _ -> return (t'', id)
_ -> return (t'', id) _ -> return (t'', id)
return $ A.Is m am t''' $ A.ActualChannelArray $ map f vs' return $ addId $ A.Is m am t''' $ A.ActualChannelArray $ map f vs'
A.Function m sm ts fs (Just (Left sel)) -> lift $ A.Function m sm ts fs mbody -> lift $
do sm' <- recurse sm do sm' <- recurse sm
ts' <- recurse ts ts' <- recurse ts
fs' <- recurse fs fs' <- recurse fs
sel' <- doFuncDef ts sel sel' <- case mbody of
return $ A.Function m sm' ts' fs' $ Just (Left sel') Just (Left sel) -> doFuncDef ts sel >>* (Just . Left)
A.RetypesExpr _ _ _ _ -> lift $ noTypeContext $ descend st _ -> return mbody
mOp <- functionOperator n
let func = A.Function m sm' ts' fs' sel'
case mOp of
Just raw -> do
ts <- mapM astTypeOf fs
let before = modify $ \cs -> cs { csOperators = (raw, n, ts) : csOperators cs }
after = modify $ \cs -> cs { csOperators = tail (csOperators cs)}
return (func
,\m -> do before
x <- m
after
return x)
_ -> return func >>* addId
A.RetypesExpr _ _ _ _ -> lift $ noTypeContext $ descend st >>* addId
-- For PROCs that take any channels without direction, -- For PROCs that take any channels without direction,
-- we must determine if we can infer a specific direction -- we must determine if we can infer a specific direction
-- for that channel -- for that channel
A.Proc m sm fs body -> lift $ A.Proc m sm fs body -> lift $
do body' <- recurse body do body' <- recurse body
fs' <- mapM (processFormal body') fs fs' <- mapM (processFormal body') fs
return $ A.Proc m sm fs' body' return $ addId $ A.Proc m sm fs' body'
where where
processFormal body f@(A.Formal am t n) processFormal body f@(A.Formal am t n)
= do t' <- recurse t = do t' <- recurse t
@ -967,17 +973,20 @@ inferTypes = occamOnlyPass "Infer types"
_ -> do modifyName n (\nd -> nd {A.ndSpecType = _ -> do modifyName n (\nd -> nd {A.ndSpecType =
A.Declaration m t'}) A.Declaration m t'})
return $ A.Formal am t' n return $ A.Formal am t' n
_ -> lift $ descend st _ -> lift $ descend st >>* addId
where where
addId :: a -> (a, b -> b)
addId a = (a, id)
-- | This is a bit ugly: walk down a Structured to find the single -- | This is a bit ugly: walk down a Structured to find the single
-- ExpressionList that must be in there. -- ExpressionList that must be in there.
-- (This can go away once we represent all functions in the new Process -- (This can go away once we represent all functions in the new Process
-- form.) -- form.)
doFuncDef :: [A.Type] -> Transform (A.Structured A.ExpressionList) doFuncDef :: [A.Type] -> Transform (A.Structured A.ExpressionList)
doFuncDef ts (A.Spec m (A.Specification m' n st) s) doFuncDef ts (A.Spec m (A.Specification m' n st) s)
= do st' <- runReaderT (doSpecType n st) s = do (st', wrap) <- runReaderT (doSpecType n st) s
modifyName n (\nd -> nd { A.ndSpecType = st' }) modifyName n (\nd -> nd { A.ndSpecType = st' })
s' <- doFuncDef ts s s' <- wrap $ doFuncDef ts s
return $ A.Spec m (A.Specification m' n st') s' return $ A.Spec m (A.Specification m' n st') s'
doFuncDef ts (A.ProcThen m p s) doFuncDef ts (A.ProcThen m p s)
= do p' <- recurse p = do p' <- recurse p