Remove the Type/AbbrevMode information from Actual*.
It's redundant, since you can always compute them from the variable, and it makes the code that deals with actuals rather cleaner. On the other hand, it slightly complicates some of the tests, because any names you use in an Actual need to be defined...
This commit is contained in:
Adam Sampson
parent
b296706bea
commit
3283b7db41
|
|
@ -288,20 +288,21 @@ addSizesActualParameters = doGeneric `extM` doProcess
|
|||
doProcess p = doGeneric p
|
||||
|
||||
transformActual :: A.Actual -> PassM [A.Actual]
|
||||
transformActual a@(A.ActualVariable am (A.Array ds _) (A.Variable m n))
|
||||
= do let a_sizes = A.Variable m (append_sizes n)
|
||||
let sizeType = A.Array [makeDimension m $ length ds] A.Int
|
||||
return [a, A.ActualVariable A.ValAbbrev sizeType a_sizes]
|
||||
transformActual a@(A.ActualExpression (A.Array ds _) (A.ExprVariable _ (A.Variable m n)))
|
||||
= do let a_sizes = A.Variable m (append_sizes n)
|
||||
let sizeType = A.Array [makeDimension m $ length ds] A.Int
|
||||
return [a, A.ActualVariable A.ValAbbrev sizeType a_sizes]
|
||||
transformActual a = let t = case a of
|
||||
A.ActualVariable _ t _ -> t
|
||||
A.ActualExpression t _ -> t
|
||||
in case t of
|
||||
A.Array {} -> dieP (findMeta a) "Untransformed actual parameter of type array: "
|
||||
_ -> return [a]
|
||||
transformActual a@(A.ActualVariable v)
|
||||
= transformActualVariable a v
|
||||
transformActual a@(A.ActualExpression (A.ExprVariable _ v))
|
||||
= transformActualVariable a v
|
||||
transformActual a = return [a]
|
||||
|
||||
transformActualVariable :: A.Actual -> A.Variable -> PassM [A.Actual]
|
||||
transformActualVariable a v@(A.Variable m n)
|
||||
= do t <- typeOfVariable v
|
||||
case t of
|
||||
A.Array ds _ ->
|
||||
return [a, A.ActualVariable a_sizes]
|
||||
_ -> return [a]
|
||||
where
|
||||
a_sizes = A.Variable m (append_sizes n)
|
||||
|
||||
-- | Transforms all slices into the FromFor form.
|
||||
simplifySlices :: Data t => t -> PassM t
|
||||
|
|
|
|||
|
|
@ -355,7 +355,9 @@ qcTestSizeParameters =
|
|||
testActual ts = testPassWithStateCheck "qcTestSizeParameters Actual"
|
||||
(procCall "p" argsWithSizes)
|
||||
(addSizesActualParameters $ procCall "p" args)
|
||||
(return ()) (const $ return ())
|
||||
(do recordProcDef args
|
||||
recordProcFormals args)
|
||||
(const $ return ())
|
||||
where
|
||||
args = [("x" ++ show n, t, A.Abbrev) | (n, t) <- zip [(0::Integer)..] ts]
|
||||
argsWithSizes = concat [
|
||||
|
|
@ -401,7 +403,7 @@ qcTestSizeParameters =
|
|||
wrapSpec n spec = A.Spec emptyMeta (A.Specification emptyMeta (simpleName n) spec) (A.Only emptyMeta ())
|
||||
|
||||
procCall :: String -> [(String, A.Type, A.AbbrevMode)] -> A.Process
|
||||
procCall p nts = A.ProcCall emptyMeta (simpleName p) [A.ActualVariable am t (variable n) | (n, t, am) <- nts]
|
||||
procCall p nts = A.ProcCall emptyMeta (simpleName p) [A.ActualVariable (variable n) | (n, _, _) <- nts]
|
||||
|
||||
---Returns the list of tests:
|
||||
qcTests :: (Test, [LabelledQuickCheckTest])
|
||||
|
|
|
|||
|
|
@ -1367,10 +1367,11 @@ cgenActual actual = seqComma $ realActuals actual
|
|||
-- | Return generators for all the real actuals corresponding to a single
|
||||
-- actual.
|
||||
realActuals :: A.Actual -> [CGen ()]
|
||||
realActuals (A.ActualExpression t e)
|
||||
realActuals (A.ActualExpression e)
|
||||
= [call genExpression e]
|
||||
realActuals (A.ActualVariable am t v)
|
||||
= [call genVariableAM v am]
|
||||
realActuals (A.ActualVariable v)
|
||||
= [do am <- abbrevModeOfVariable v
|
||||
call genVariableAM v am]
|
||||
|
||||
-- | Return (type, name) generator pairs for all the real formals corresponding
|
||||
-- to a single formal.
|
||||
|
|
@ -1751,7 +1752,7 @@ cgenProcCall n as
|
|||
--}}}
|
||||
--{{{ intrinsic procs
|
||||
cgenIntrinsicProc :: Meta -> String -> [A.Actual] -> CGen ()
|
||||
cgenIntrinsicProc m "ASSERT" [A.ActualExpression A.Bool e] = call genAssert m e
|
||||
cgenIntrinsicProc m "ASSERT" [A.ActualExpression e] = call genAssert m e
|
||||
cgenIntrinsicProc _ "RESCHEDULE" [] = tell ["Reschedule (wptr);\n"]
|
||||
cgenIntrinsicProc _ s _ = call genMissing $ "intrinsic PROC " ++ s
|
||||
|
||||
|
|
|
|||
|
|
@ -305,15 +305,16 @@ testActuals = TestList
|
|||
,testBothSame "genActuals 1" "" $ (tcall genActuals [])
|
||||
|
||||
--For expressions, genExpression should be called:
|
||||
,testBothSame "genActual 0" "$" $ over (tcall genActual $ A.ActualExpression A.Bool (A.True undefined))
|
||||
,testBothSame "genActual 0" "$" $ over (tcall genActual $ A.ActualExpression (A.True undefined))
|
||||
|
||||
--For abbreviating arrays, nothing special should happen any more:
|
||||
,testBothSame "genActual 1" "$" $ over (tcall genActual $ A.ActualExpression (A.Array undefined undefined) (A.Literal undefined undefined undefined))
|
||||
,testBothSameS "genActual 2" "@" (over (tcall genActual $ A.ActualVariable A.Original (A.Array undefined undefined) (A.Variable undefined foo)))
|
||||
,testBothSame "genActual 1" "$" $ over (tcall genActual $ A.ActualExpression (A.Literal undefined undefined undefined))
|
||||
,testBothSameS "genActual 2" "@" (over (tcall genActual $ A.ActualVariable (A.Variable undefined foo)))
|
||||
(defineName foo $ simpleDefDecl "foo" A.Int)
|
||||
,testBothSameS "genActual 3" "&@" (over (tcall genActual $ A.ActualVariable A.Abbrev (A.Array undefined undefined) (A.Variable undefined foo)))
|
||||
(defineName foo $ simpleDefDecl "foo" A.Int)
|
||||
,testBothSameS "genActual 4" "@" (over (tcall genActual $ A.ActualVariable A.ValAbbrev (A.Array undefined undefined) (A.Variable undefined foo)))
|
||||
,testBothSameS "genActual 3" "&@" (over (tcall genActual $ A.ActualVariable (A.Variable undefined foo)))
|
||||
(do defineName foo $ simpleDefDecl "bar" A.Int
|
||||
defineIs "foo" A.Int (variable "bar"))
|
||||
,testBothSameS "genActual 4" "@" (over (tcall genActual $ A.ActualVariable (A.Variable undefined foo)))
|
||||
(defineName foo $ simpleDefDecl "foo" A.Int)
|
||||
]
|
||||
where
|
||||
|
|
|
|||
|
|
@ -224,9 +224,9 @@ checkProcCallArgsUsage = mapM_ checkArgs . listify isProcCall
|
|||
-- | Need to check that all the destinations in a parallel assignment
|
||||
-- are distinct. So we check plain variables, and array variables
|
||||
checkArgs :: A.Process -> m ()
|
||||
checkArgs (A.ProcCall m _ params)
|
||||
= do checkPlainVarUsage (m, mockedupParItems)
|
||||
checkArgs p@(A.ProcCall m _ _)
|
||||
= do vars <- getVarProcCall p
|
||||
let mockedupParItems = ParItems [SeqItems [Usage Nothing Nothing v]
|
||||
| v <- vars]
|
||||
checkPlainVarUsage (m, mockedupParItems)
|
||||
checkArrayUsage (m, mockedupParItems)
|
||||
where
|
||||
mockedupParItems :: ParItems UsageLabel
|
||||
mockedupParItems = ParItems [SeqItems [Usage Nothing Nothing v] | v <- map getVarActual params]
|
||||
|
|
|
|||
|
|
@ -32,6 +32,7 @@ import CompState
|
|||
import Errors
|
||||
import FlowGraph
|
||||
import Metadata
|
||||
import TestFramework
|
||||
import TestUtils hiding (Var)
|
||||
import UsageCheckAlgorithms
|
||||
import UsageCheckUtils
|
||||
|
|
@ -102,8 +103,23 @@ testGetVarProc = TestList (map doTest tests)
|
|||
,(502,[],[tvA,tvB],[tvC],A.Input emptyMeta vC
|
||||
(A.InputSimple emptyMeta [A.InCounted emptyMeta vA vB]))
|
||||
]
|
||||
|
||||
-- This is a custom test because there's no instance of Data for Vars.
|
||||
-- If we need to do this elsewhere, this could become a helper function in
|
||||
-- TestUtils.
|
||||
doTest :: (Int,[Var],[Var],[Var],A.Process) -> Test
|
||||
doTest (index,r,w,u,proc) = TestCase $ assertEqual ("testGetVarProc-" ++ (show index)) (vars r w u) (getVarProc proc)
|
||||
doTest (index, r, w, u, proc)
|
||||
= TestCase $ do result <- runPass (getVarProc proc) startState
|
||||
case result of
|
||||
Left err ->
|
||||
testFailure $ name ++ " failed: " ++ show err
|
||||
Right (_, result) ->
|
||||
assertEqual name (vars r w u) result
|
||||
where
|
||||
name = "testGetVarProc" ++ show index
|
||||
|
||||
startState :: CompState
|
||||
startState = emptyState
|
||||
|
||||
--TODO test declarations being recorded, when I've decided how to record them
|
||||
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ You should have received a copy of the GNU General Public License along
|
|||
with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
-}
|
||||
|
||||
module UsageCheckUtils (Decl(..), emptyVars, flattenParItems, foldUnionVars, getVarActual, getVarProc, labelFunctions, mapUnionVars, ParItems(..), processVarW, transformParItems, UsageLabel(..), Var(..), Vars(..), vars) where
|
||||
module UsageCheckUtils (Decl(..), emptyVars, flattenParItems, foldUnionVars, getVarProcCall, getVarProc, labelFunctions, mapUnionVars, ParItems(..), processVarW, transformParItems, UsageLabel(..), Var(..), Vars(..), vars) where
|
||||
|
||||
import Control.Monad.Writer (tell)
|
||||
import Data.Generics hiding (GT)
|
||||
|
|
@ -25,11 +25,14 @@ import Data.Maybe
|
|||
import qualified Data.Set as Set
|
||||
|
||||
import qualified AST as A
|
||||
import CompState
|
||||
import Errors
|
||||
import FlowGraph
|
||||
import Metadata
|
||||
import OrdAST()
|
||||
import ShowCode
|
||||
import Types
|
||||
import Utils
|
||||
|
||||
newtype Var = Var A.Variable deriving (Data, Show, Typeable)
|
||||
|
||||
|
|
@ -118,31 +121,48 @@ mapUnionVars f = foldUnionVars . (map f)
|
|||
--For subscripted variables used as Lvalues , e.g. a[b] it should return a[b] as written-to and b as read
|
||||
--For subscripted variables used as expressions, e.g. a[b] it should return a[b],b as read (with no written-to)
|
||||
|
||||
getVarProc :: A.Process -> Vars
|
||||
getVarProc :: (Die m, CSMR m) => A.Process -> m Vars
|
||||
getVarProc (A.Assign _ vars expList)
|
||||
--Join together:
|
||||
= unionVars
|
||||
= return $ unionVars
|
||||
--The written-to variables on the LHS:
|
||||
(mapUnionVars processVarW vars)
|
||||
--All variables read on the RHS:
|
||||
(getVarExpList expList)
|
||||
getVarProc (A.Output _ chanVar outItems) = (processVarUsed chanVar) `unionVars` (mapUnionVars getVarOutputItem outItems)
|
||||
getVarProc (A.Output _ chanVar outItems)
|
||||
= return $ (processVarUsed chanVar)
|
||||
`unionVars` (mapUnionVars getVarOutputItem outItems)
|
||||
where
|
||||
getVarOutputItem :: A.OutputItem -> Vars
|
||||
getVarOutputItem (A.OutExpression _ e) = getVarExp e
|
||||
getVarOutputItem (A.OutCounted _ ce ae) = (getVarExp ce) `unionVars` (getVarExp ae)
|
||||
getVarProc (A.Input _ chanVar (A.InputSimple _ iis)) = (processVarUsed chanVar) `unionVars` (mapUnionVars getVarInputItem iis)
|
||||
getVarProc (A.Input _ chanVar (A.InputSimple _ iis))
|
||||
= return $ (processVarUsed chanVar)
|
||||
`unionVars` (mapUnionVars getVarInputItem iis)
|
||||
where
|
||||
getVarInputItem :: A.InputItem -> Vars
|
||||
getVarInputItem (A.InCounted _ cv av) = mkWrittenVars [variableToVar cv,variableToVar av]
|
||||
getVarInputItem (A.InVariable _ v) = mkWrittenVars [variableToVar v]
|
||||
getVarProc (A.ProcCall _ _ params) = mapUnionVars getVarActual params
|
||||
getVarProc _ = emptyVars
|
||||
getVarInputItem (A.InCounted _ cv av)
|
||||
= mkWrittenVars [variableToVar cv,variableToVar av]
|
||||
getVarInputItem (A.InVariable _ v)
|
||||
= mkWrittenVars [variableToVar v]
|
||||
getVarProc p@(A.ProcCall _ _ _)
|
||||
= getVarProcCall p >>* foldUnionVars
|
||||
getVarProc _ = return emptyVars
|
||||
|
||||
getVarActual :: A.Actual -> Vars
|
||||
getVarActual (A.ActualExpression _ e) = getVarExp e
|
||||
getVarActual (A.ActualVariable A.ValAbbrev _ v) = processVarR v
|
||||
getVarActual (A.ActualVariable _ _ v) = processVarW v
|
||||
getVarProcCall :: (Die m, CSMR m) => A.Process -> m [Vars]
|
||||
getVarProcCall (A.ProcCall _ proc as)
|
||||
= do st <- specTypeOfName proc
|
||||
let fs = case st of A.Proc _ _ fs _ -> fs
|
||||
|
||||
sequence [getVarActual f a
|
||||
| (f, a) <- zip fs as]
|
||||
|
||||
getVarActual :: (Die m, CSMR m) => A.Formal -> A.Actual -> m Vars
|
||||
getVarActual _ (A.ActualExpression e) = return $ getVarExp e
|
||||
getVarActual (A.Formal am _ _) (A.ActualVariable v)
|
||||
= case am of
|
||||
A.ValAbbrev -> return $ processVarR v
|
||||
_ -> return $ processVarW v
|
||||
|
||||
{-
|
||||
Near the beginning, this piece of code was too clever for itself and applied processVarW using "everything".
|
||||
|
|
@ -201,13 +221,13 @@ getVarRepExp (A.ForEach _ _ e) = getVarExp e
|
|||
getVarAlternative :: A.Alternative -> Vars
|
||||
getVarAlternative = const emptyVars -- TODO
|
||||
|
||||
labelFunctions :: forall m. Die m => GraphLabelFuncs m UsageLabel
|
||||
labelFunctions :: forall m. (Die m, CSMR m) => GraphLabelFuncs m UsageLabel
|
||||
labelFunctions = GLF
|
||||
{
|
||||
labelExpression = single getVarExp
|
||||
,labelExpressionList = single getVarExpList
|
||||
,labelDummy = const (return $ Usage Nothing Nothing emptyVars)
|
||||
,labelProcess = single getVarProc
|
||||
,labelProcess = singleM getVarProc
|
||||
,labelAlternative = single getVarAlternative
|
||||
,labelStartNode = single (uncurry getVarFormals)
|
||||
,labelReplicator = \x -> return (Usage (Just x) Nothing (getVarRepExp x))
|
||||
|
|
@ -218,6 +238,9 @@ labelFunctions = GLF
|
|||
where
|
||||
single :: (a -> Vars) -> (a -> m UsageLabel)
|
||||
single f x = return $ Usage Nothing Nothing (f x)
|
||||
|
||||
|
||||
singleM :: (a -> m Vars) -> (a -> m UsageLabel)
|
||||
singleM f x = f x >>* Usage Nothing Nothing
|
||||
|
||||
pair :: (a -> Maybe Decl) -> (a -> Vars) -> (a -> m UsageLabel)
|
||||
pair f0 f1 x = return $ Usage Nothing (f0 x) (f1 x)
|
||||
|
|
|
|||
|
|
@ -456,8 +456,8 @@ instance ShowOccam A.Variant where
|
|||
>> occamIndent >> showOccamM p >> occamOutdent
|
||||
|
||||
instance ShowOccam A.Actual where
|
||||
showOccamM (A.ActualVariable _ _ v) = showOccamM v
|
||||
showOccamM (A.ActualExpression _ e) = showOccamM e
|
||||
showOccamM (A.ActualVariable v) = showOccamM v
|
||||
showOccamM (A.ActualExpression e) = showOccamM e
|
||||
|
||||
instance ShowOccam A.OutputItem where
|
||||
showOccamM (A.OutExpression _ e) = showOccamM e
|
||||
|
|
|
|||
|
|
@ -328,6 +328,11 @@ defineConst s t e
|
|||
= defineThing s A.VariableName (A.IsExpr emptyMeta A.ValAbbrev t e)
|
||||
A.ValAbbrev
|
||||
|
||||
-- | Define an @IS@ abbreviation.
|
||||
defineIs :: String -> A.Type -> A.Variable -> State CompState ()
|
||||
defineIs s t v
|
||||
= defineThing s A.VariableName (A.Is emptyMeta A.Abbrev t v) A.Abbrev
|
||||
|
||||
-- | Define a variable.
|
||||
defineVariable :: String -> A.Type -> State CompState ()
|
||||
defineVariable s t
|
||||
|
|
@ -482,6 +487,7 @@ testPassGetItems testName expected actualPass startStateTrans =
|
|||
prefixErr :: String -> String
|
||||
prefixErr err = testName ++ ": " ++ err
|
||||
|
||||
|
||||
-- | Runs a given AST pass and returns the subsequent state, along with either an error or the result. This function is primarily intended for internal use by this module.
|
||||
runPass :: TestMonad m r =>
|
||||
PassM b -- ^ The actual pass.
|
||||
|
|
|
|||
|
|
@ -522,11 +522,9 @@ data Formal =
|
|||
-- | Actual parameters for @PROC@s and @FUNCTION@s.
|
||||
data Actual =
|
||||
-- | A variable used as a parameter.
|
||||
-- 'AbbrevMode' and 'Type' are here for parity with 'Formal'; they can be
|
||||
-- figured out from the variable.
|
||||
ActualVariable AbbrevMode Type Variable
|
||||
ActualVariable Variable
|
||||
-- | An expression used as a parameter.
|
||||
| ActualExpression Type Expression
|
||||
| ActualExpression Expression
|
||||
deriving (Show, Eq, Typeable, Data)
|
||||
|
||||
-- | The mode in which a @PAR@ operates.
|
||||
|
|
|
|||
|
|
@ -312,12 +312,12 @@ checkActuals m n fs as
|
|||
checkActual :: A.Formal -> A.Actual -> PassM ()
|
||||
checkActual (A.Formal newAM et _) a
|
||||
= do rt <- case a of
|
||||
A.ActualVariable _ _ v -> typeOfVariable v
|
||||
A.ActualExpression _ e -> typeOfExpression e
|
||||
A.ActualVariable v -> typeOfVariable v
|
||||
A.ActualExpression e -> typeOfExpression e
|
||||
checkType (findMeta a) et rt
|
||||
origAM <- case a of
|
||||
A.ActualVariable _ _ v -> abbrevModeOfVariable v
|
||||
A.ActualExpression _ _ -> return A.ValAbbrev
|
||||
A.ActualVariable v -> abbrevModeOfVariable v
|
||||
A.ActualExpression _ -> return A.ValAbbrev
|
||||
checkAbbrev (findMeta a) origAM newAM
|
||||
|
||||
-- | Check a function call.
|
||||
|
|
@ -326,10 +326,7 @@ checkFunctionCall m n es
|
|||
= do st <- specTypeOfName n
|
||||
case st of
|
||||
A.Function _ _ rs fs _ ->
|
||||
do as <- sequence [do t <- typeOfExpression e
|
||||
return $ A.ActualExpression t e
|
||||
| e <- es]
|
||||
checkActuals m n fs as
|
||||
do checkActuals m n fs (map A.ActualExpression es)
|
||||
return rs
|
||||
_ -> diePC m $ formatCode "% is not a function" n
|
||||
|
||||
|
|
@ -340,12 +337,10 @@ checkIntrinsicFunctionCall m n es
|
|||
Just (rs, args) ->
|
||||
do when (length rs /= 1) $
|
||||
dieP m $ "Function " ++ n ++ " used in an expression returns more than one value"
|
||||
as <- sequence [do t <- typeOfExpression e
|
||||
return $ A.ActualExpression t e
|
||||
| e <- es]
|
||||
let fs = [A.Formal A.ValAbbrev t (A.Name m A.VariableName s)
|
||||
| (t, s) <- args]
|
||||
checkActuals m (A.Name m A.ProcName n) fs as
|
||||
checkActuals m (A.Name m A.ProcName n)
|
||||
fs (map A.ActualExpression es)
|
||||
Nothing -> dieP m $ n ++ " is not an intrinsic function"
|
||||
|
||||
-- | Check a mobile allocation.
|
||||
|
|
|
|||
|
|
@ -344,13 +344,13 @@ testOccamTypes = TestList
|
|||
|
||||
-- Proc calls
|
||||
, testOK 1600 $ proccall "proc0" []
|
||||
, testOK 1601 $ proccall "proc1" [A.ActualExpression A.Int intE]
|
||||
, testOK 1602 $ proccall "proc2" [A.ActualExpression A.Int intE,
|
||||
A.ActualVariable A.Original A.Int intV]
|
||||
, testFail 1603 $ proccall "proc0" [A.ActualExpression A.Int intE]
|
||||
, testFail 1604 $ proccall "proc1" [A.ActualExpression A.Real32 realE]
|
||||
, testFail 1605 $ proccall "proc1" [A.ActualExpression A.Int intE,
|
||||
A.ActualExpression A.Int intE]
|
||||
, testOK 1601 $ proccall "proc1" [A.ActualExpression intE]
|
||||
, testOK 1602 $ proccall "proc2" [A.ActualExpression intE,
|
||||
A.ActualVariable intV]
|
||||
, testFail 1603 $ proccall "proc0" [A.ActualExpression intE]
|
||||
, testFail 1604 $ proccall "proc1" [A.ActualExpression realE]
|
||||
, testFail 1605 $ proccall "proc1" [A.ActualExpression intE,
|
||||
A.ActualExpression intE]
|
||||
, testFail 1606 $ proccall "herring" []
|
||||
|
||||
-- Miscellaneous processes
|
||||
|
|
@ -365,12 +365,12 @@ testOccamTypes = TestList
|
|||
, testFail 1908 $ A.Processor m realE skip
|
||||
, testOK 1909 $ A.IntrinsicProcCall m "RESCHEDULE" []
|
||||
, testOK 1910 $ A.IntrinsicProcCall m "ASSERT"
|
||||
[A.ActualExpression A.Bool boolE]
|
||||
[A.ActualExpression boolE]
|
||||
, testFail 1911 $ A.IntrinsicProcCall m "ASSERT"
|
||||
[A.ActualExpression A.Int intE]
|
||||
[A.ActualExpression intE]
|
||||
, testFail 1912 $ A.IntrinsicProcCall m "ASSERT" []
|
||||
, testFail 1913 $ A.IntrinsicProcCall m "RESCHEDULE"
|
||||
[A.ActualExpression A.Bool boolE]
|
||||
[A.ActualExpression boolE]
|
||||
, testFail 1914 $ A.IntrinsicProcCall m "HERRING" []
|
||||
|
||||
--}}}
|
||||
|
|
|
|||
|
|
@ -1965,7 +1965,7 @@ actual (A.Formal am t n)
|
|||
= do case am of
|
||||
A.ValAbbrev ->
|
||||
do e <- expressionOfType t
|
||||
return $ A.ActualExpression t e
|
||||
return $ A.ActualExpression e
|
||||
_ ->
|
||||
case stripArrayType t of
|
||||
A.Chan {} -> var (channelOfType t)
|
||||
|
|
@ -1974,7 +1974,7 @@ actual (A.Formal am t n)
|
|||
_ -> var (variableOfType t)
|
||||
<?> "actual of type " ++ showOccam t ++ " for " ++ show n
|
||||
where
|
||||
var inner = liftM (A.ActualVariable am t) inner
|
||||
var inner = liftM A.ActualVariable inner
|
||||
--}}}
|
||||
--{{{ intrinsic PROC call
|
||||
intrinsicProcName :: OccParser (String, [A.Formal])
|
||||
|
|
|
|||
|
|
@ -411,8 +411,8 @@ runProcess = do m <- sRun
|
|||
return $ A.ProcCall m A.Name {A.nameName = processName, A.nameMeta = mProcess, A.nameType = A.ProcName} (map convertItem items)
|
||||
where
|
||||
convertItem :: A.Expression -> A.Actual
|
||||
convertItem (A.ExprVariable _ v) = A.ActualVariable A.Original A.Any v
|
||||
convertItem e = A.ActualExpression A.Any e
|
||||
convertItem (A.ExprVariable _ v) = A.ActualVariable v
|
||||
convertItem e = A.ActualExpression e
|
||||
|
||||
waitStatement :: Bool -> RainParser (Meta, A.InputMode)
|
||||
waitStatement isAlt
|
||||
|
|
|
|||
|
|
@ -677,9 +677,9 @@ testRun =
|
|||
[
|
||||
pass ("run foo();",RP.statement,assertPatternMatch "testRun 1" $ tag3 A.ProcCall DontCare (procNamePattern "foo") ([] :: [A.Actual]))
|
||||
,pass ("run foo(c);",RP.statement,assertPatternMatch "testRun 2" $ tag3 A.ProcCall DontCare (procNamePattern "foo")
|
||||
[tag3 A.ActualVariable A.Original A.Any (variablePattern "c")])
|
||||
[tag1 A.ActualVariable (variablePattern "c")])
|
||||
,pass ("run foo(c,0+x);",RP.statement,assertPatternMatch "testRun 3" $ tag3 A.ProcCall DontCare (procNamePattern "foo")
|
||||
[tag3 A.ActualVariable A.Original A.Any (variablePattern "c"),tag2 A.ActualExpression A.Any $ tag4 A.Dyadic DontCare A.Plus (intLiteralPattern 0) (exprVariablePattern "x")])
|
||||
[tag1 A.ActualVariable (variablePattern "c"),tag1 A.ActualExpression $ tag4 A.Dyadic DontCare A.Plus (intLiteralPattern 0) (exprVariablePattern "x")])
|
||||
,fail ("run",RP.statement)
|
||||
,fail ("run;",RP.statement)
|
||||
,fail ("run ();",RP.statement)
|
||||
|
|
|
|||
|
|
@ -180,7 +180,7 @@ 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.Formal A.ValAbbrev A.Byte $ simpleName "c"] $
|
||||
A.ProcCall m (procName "foo") [A.ActualExpression A.Byte $ exprVariable "c"]) (skipP)
|
||||
A.ProcCall m (procName "foo") [A.ActualExpression $ exprVariable "c"]) (skipP)
|
||||
exp = mSpecP
|
||||
(tag3 A.Specification DontCare (procNamePattern "foo") $ tag4 A.Proc DontCare A.PlainSpec
|
||||
[tag3 A.Formal A.ValAbbrev A.Byte newc]
|
||||
|
|
@ -188,7 +188,7 @@ testUnique4 = TestCase $ testPassWithItemsStateCheck "testUnique4" exp (uniquify
|
|||
)
|
||||
skipP
|
||||
bodyPattern n = (tag3 A.ProcCall DontCare (procNamePattern "foo")
|
||||
[tag2 A.ActualExpression A.Byte $ tag2 A.ExprVariable DontCare $ tag2 A.Variable DontCare n]
|
||||
[tag1 A.ActualExpression $ tag2 A.ExprVariable DontCare $ tag2 A.Variable DontCare n]
|
||||
)
|
||||
|
||||
newc = Named "newc" DontCare
|
||||
|
|
@ -318,8 +318,8 @@ testParamPass testName formals params transParams
|
|||
deActualise :: [A.Actual] -> [A.Expression]
|
||||
deActualise = map deActualise'
|
||||
deActualise' :: A.Actual -> A.Expression
|
||||
deActualise' (A.ActualVariable _ _ v) = A.ExprVariable m v
|
||||
deActualise' (A.ActualExpression _ e) = e
|
||||
deActualise' (A.ActualVariable v) = A.ExprVariable m v
|
||||
deActualise' (A.ActualExpression e) = e
|
||||
|
||||
-- | Test no-params:
|
||||
testParamPass0 :: Test
|
||||
|
|
@ -329,31 +329,31 @@ testParamPass0 = testParamPass "testParamPass0" (Just []) [] (Just [])
|
|||
testParamPass1 :: Test
|
||||
testParamPass1 = testParamPass "testParamPass1"
|
||||
(Just [A.Formal A.ValAbbrev A.UInt16 (simpleName "p0")])
|
||||
[A.ActualVariable A.Original A.Any (variable "x")]
|
||||
(Just [A.ActualVariable A.ValAbbrev A.UInt16 (variable "x")])
|
||||
[A.ActualVariable (variable "x")]
|
||||
(Just [A.ActualVariable (variable "x")])
|
||||
|
||||
-- | Test up-casts:
|
||||
testParamPass2 :: Test
|
||||
testParamPass2 = testParamPass "testParamPass2"
|
||||
(Just [A.Formal A.ValAbbrev A.Int32 (simpleName "p0"),A.Formal A.ValAbbrev A.UInt32 (simpleName "p1")])
|
||||
[A.ActualVariable A.Original A.Any (variable "x"),A.ActualVariable A.Original A.Any (variable "x")]
|
||||
(Just [A.ActualExpression A.Int32 $ A.Conversion m A.DefaultConversion A.Int32 (exprVariable "x"),
|
||||
A.ActualExpression A.UInt32 $ A.Conversion m A.DefaultConversion A.UInt32 (exprVariable "x")])
|
||||
[A.ActualVariable (variable "x"),A.ActualVariable (variable "x")]
|
||||
(Just [A.ActualExpression $ A.Conversion m A.DefaultConversion A.Int32 (exprVariable "x"),
|
||||
A.ActualExpression $ A.Conversion m A.DefaultConversion A.UInt32 (exprVariable "x")])
|
||||
|
||||
-- | Test invalid implicit down-cast:
|
||||
testParamPass3 :: Test
|
||||
testParamPass3 = testParamPass "testParamPass3"
|
||||
(Just [A.Formal A.ValAbbrev A.Int8 (simpleName "p0"),A.Formal A.ValAbbrev A.UInt32 (simpleName "p1")])
|
||||
[A.ActualVariable A.Original A.Any (variable "x"),A.ActualVariable A.Original A.Any (variable "x")]
|
||||
[A.ActualVariable (variable "x"),A.ActualVariable (variable "x")]
|
||||
Nothing
|
||||
|
||||
-- | Test explicit down-cast:
|
||||
testParamPass4 :: Test
|
||||
testParamPass4 = testParamPass "testParamPass4"
|
||||
(Just [A.Formal A.ValAbbrev A.Int8 (simpleName "p0"),A.Formal A.ValAbbrev A.UInt16 (simpleName "p1")])
|
||||
[A.ActualExpression A.Int8 $ A.Conversion m A.DefaultConversion A.Int8 (exprVariable "x"),A.ActualVariable A.Original A.Any (variable "x")]
|
||||
(Just [A.ActualExpression A.Int8 $ A.Conversion m A.DefaultConversion A.Int8 (exprVariable "x"),
|
||||
A.ActualVariable A.ValAbbrev A.UInt16 (variable "x")])
|
||||
[A.ActualExpression $ A.Conversion m A.DefaultConversion A.Int8 (exprVariable "x"),A.ActualVariable (variable "x")]
|
||||
(Just [A.ActualExpression $ A.Conversion m A.DefaultConversion A.Int8 (exprVariable "x"),
|
||||
A.ActualVariable (variable "x")])
|
||||
|
||||
-- | Test too few parameters:
|
||||
testParamPass5 :: Test
|
||||
|
|
@ -366,14 +366,14 @@ testParamPass5 = testParamPass "testParamPass5"
|
|||
testParamPass6 :: Test
|
||||
testParamPass6 = testParamPass "testParamPass6"
|
||||
(Just [A.Formal A.ValAbbrev A.UInt16 (simpleName "p0")])
|
||||
[A.ActualVariable A.Original A.Any (variable "x"),A.ActualVariable A.Original A.Any (variable "x")]
|
||||
[A.ActualVariable (variable "x"),A.ActualVariable (variable "x")]
|
||||
Nothing
|
||||
|
||||
-- | Test unknown process:
|
||||
testParamPass7 :: Test
|
||||
testParamPass7 = testParamPass "testParamPass7"
|
||||
Nothing
|
||||
[A.ActualVariable A.Original A.Any (variable "x"),A.ActualVariable A.Original A.Any (variable "x")]
|
||||
[A.ActualVariable (variable "x"),A.ActualVariable (variable "x")]
|
||||
Nothing
|
||||
|
||||
-- | Test calling something that is not a process:
|
||||
|
|
|
|||
|
|
@ -159,13 +159,13 @@ matchParamPass = everywhereM ((mkM matchParamPassProc) `extM` matchParamPassFunc
|
|||
|
||||
--Checks the type of a parameter (A.Actual), and inserts a cast if it is safe to do so
|
||||
doParam :: Meta -> String -> (Int,A.Formal, A.Actual) -> PassM A.Actual
|
||||
doParam m n (index, A.Formal formalAbbrev formalType formalName, A.ActualVariable _ _ v)
|
||||
doParam m n (index, A.Formal formalAbbrev formalType formalName, A.ActualVariable v)
|
||||
= do actualType <- typeOfVariable v
|
||||
if (actualType == formalType)
|
||||
then return $ A.ActualVariable formalAbbrev formalType v
|
||||
else (liftM $ A.ActualExpression formalType) $ doCast index formalType actualType (A.ExprVariable (findMeta v) v )
|
||||
doParam m n (index, for@(A.Formal _ formalType _), A.ActualExpression _ e)
|
||||
= (liftM $ A.ActualExpression formalType) $ doExpParam m n (index, for, e)
|
||||
then return $ A.ActualVariable v
|
||||
else (liftM A.ActualExpression) $ doCast index formalType actualType (A.ExprVariable (findMeta v) v )
|
||||
doParam m n (index, for@(A.Formal _ formalType _), A.ActualExpression e)
|
||||
= (liftM A.ActualExpression) $ doExpParam m n (index, for, e)
|
||||
|
||||
--Checks the type of a parameter (A.Expression), and inserts a cast if it is safe to do so
|
||||
doExpParam :: Meta -> String -> (Int, A.Formal, A.Expression) -> PassM A.Expression
|
||||
|
|
|
|||
|
|
@ -384,7 +384,7 @@ pullUp pullUpArraysInsideRecords
|
|||
|
||||
let names = [n | A.Specification _ n _ <- specs]
|
||||
let vars = [A.Variable m n | n <- names]
|
||||
let call = A.ProcCall m n ([A.ActualExpression t e | (t, e) <- zip ets es'] ++ [A.ActualVariable A.Abbrev t v | (t, v) <- zip rts vars])
|
||||
let call = A.ProcCall m n (map A.ActualExpression es' ++ map A.ActualVariable vars)
|
||||
addPulled $ (m, Right call)
|
||||
|
||||
return vars
|
||||
|
|
|
|||
|
|
@ -145,7 +145,7 @@ flattenAssign = doGeneric `extM` doProcess `ext1M` doStructured
|
|||
return $ A.Rep m rep $ A.Only m inner
|
||||
A.Record n ->
|
||||
return $ A.Only m $ A.ProcCall m (n {A.nameName = "copy_" ++ A.nameName n})
|
||||
[A.ActualVariable A.Abbrev t destV, A.ActualVariable A.ValAbbrev t srcV]
|
||||
[A.ActualVariable destV, A.ActualVariable srcV]
|
||||
|
||||
return $ A.Seq m $ A.Spec m src $ A.Spec m dest body
|
||||
|
||||
|
|
|
|||
|
|
@ -155,9 +155,9 @@ removeFreeNames = doGeneric `extM` doSpecification `extM` doProcess
|
|||
-- Note that we should add extra arguments to calls of this proc
|
||||
-- when we find them
|
||||
let newAs = [case am of
|
||||
A.Abbrev -> A.ActualVariable am t (A.Variable m n)
|
||||
_ -> A.ActualExpression t (A.ExprVariable m (A.Variable m n))
|
||||
| (am, n, t) <- zip3 ams freeNames types]
|
||||
A.Abbrev -> A.ActualVariable (A.Variable m n)
|
||||
_ -> A.ActualExpression (A.ExprVariable m (A.Variable m n))
|
||||
| (am, n) <- zip ams freeNames]
|
||||
debug $ "removeFreeNames: " ++ show n ++ " has new args " ++ show newAs
|
||||
when (newAs /= []) $
|
||||
modify $ (\ps -> ps { csAdditionalArgs = Map.insert (A.nameName n) newAs (csAdditionalArgs ps) })
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user