Added types to all the cases where the monomorhpism restriction applied

This commit is contained in:
Neil Brown 2008-01-26 20:51:11 +00:00
parent 16d4320909
commit bdda623d7e
14 changed files with 30 additions and 4 deletions

View File

@ -337,6 +337,7 @@ testArraySubscript = TestList
]
where
stateTrans :: CSM m => m ()
stateTrans = defineName (simpleName "foo") $ simpleDefDecl "foo" (A.Array [A.Dimension 7,A.Dimension 8,A.Dimension 8] A.Int)
m = "\"" ++ show emptyMeta ++ "\""
@ -398,7 +399,9 @@ testOverArray = TestList $ map testOverArray'
"for\\(int ([[:alnum:]_]+)=0;\\2<foo" ++ sz 1 ++ ";\\2\\+\\+)\\{" ++
"for\\(int ([[:alnum:]_]+)=0;\\3<foo" ++ sz 2 ++ ";\\3\\+\\+)\\{" ++
"foo" ++ (f' [("\\1",[1,2]),("\\2",[2]),("\\3",[])]) ++ suff ++ ";\\}\\}\\}$"
state1 :: CSM m => m ()
state1 = defineName (simpleName "foo") $ simpleDefDecl "foo" (A.Array [A.Dimension 7] A.Int)
state3 :: CSM m => m ()
state3 = defineName (simpleName "foo") $ simpleDefDecl "foo" (A.Array [A.Dimension 7, A.Dimension 8, A.Dimension 9] A.Int)
testReplicator :: Test
@ -1046,6 +1049,7 @@ testOutput = TestList
chan = simpleName "c"
chanOut = simpleName "cOut"
state :: CSM m => m ()
state = do defineName chan $ simpleDefDecl "c" (A.Chan A.DirUnknown (A.ChanAttributes False False) $ A.UserProtocol foo)
defineName chanOut $ simpleDefDecl "cOut" (A.Chan A.DirOutput (A.ChanAttributes False False) $ A.UserProtocol foo)
overOutput ops = ops {genOutput = override2 caret}

View File

@ -61,6 +61,7 @@ dieIO (Just m@(Meta (Just fn) line column),s) = liftIO $
putStrLn ""
printError $ (show m) ++ " " ++ s
where
contextLines :: Int
contextLines = 5
-- start is unit-based, so we need to convert to zero-based
getLines :: String -> Int -> Int -> [String]

View File

@ -511,6 +511,7 @@ genProcess n = nextIdT >>* makeMeta' >>= \m -> (flip oneofLS) n
genGraph :: A.Structured -> FlowGraph Identity ()
genGraph s = either (\e -> error $ "QuickCheck graph did not build properly: " ++ e ++ ", from: " ++ pshow s) id $ runIdentity $ buildFlowGraph funcs s
where
empty :: a -> Identity ()
empty = const (return ())
funcs = GLF empty empty empty empty empty empty

View File

@ -370,6 +370,7 @@ matchType et rt
else bad
_ -> if rt == et then return () else bad
where
bad :: OccParser ()
bad = die $ "type mismatch (got " ++ showOccam rt ++ "; expected " ++ showOccam et ++ ")"
-- | Check that two lists of types match (for example, for parallel assignment).
@ -1462,7 +1463,9 @@ formalArgSet
<|> formalItem (aa channelSpecifier) newChannelName
<|> formalItem (aa timerSpecifier) newTimerName
<|> formalItem (aa portSpecifier) newPortName
where aa = liftM (\t -> (A.Abbrev, t))
where
aa :: OccParser A.Type -> OccParser (A.AbbrevMode, A.Type)
aa = liftM (\t -> (A.Abbrev, t))
formalVariableType :: OccParser (A.AbbrevMode, A.Type)
formalVariableType

View File

@ -64,6 +64,7 @@ structureOccam ts = analyse 1 firstLine ts (emptyMeta, EndOfLine)
_ -> False
-- A new line -- look to see what's going on with the indentation.
newLine :: [Token] -> PassM [Token]
newLine rest
| col == prevCol + 2 = withEOL $ (m, Indent) : rest
-- FIXME: If col > prevCol, then look to see if there's a VALOF
@ -76,6 +77,7 @@ structureOccam ts = analyse 1 firstLine ts (emptyMeta, EndOfLine)
| otherwise = bad
where
steps = (prevCol - col) `div` 2
bad :: PassM [Token]
bad = dieP m "Invalid indentation"
-- This is actually the position at which the new line starts
-- rather than the end of the previous line.

View File

@ -531,7 +531,7 @@ getIneqs (low, high) = concatMap getLH
getLH :: EqualityConstraintEquation -> [InequalityConstraintEquation]
getLH eq = [eq `addEq` (amap negate low),high `addEq` amap negate eq]
addEq :: EqualityConstraintEquation -> EqualityConstraintEquation -> EqualityConstraintEquation
addEq = arrayZipWith' 0 (+)
-- | Given an expression, forms equations (and accompanying additional equation-sets) and returns it
@ -662,4 +662,3 @@ squareEquations (eqs,ineqs) = uncurry transformPair (mkPair $ map $ makeSize (0,
where
highest = maximum $ 0 : (concatMap indices $ eqs ++ ineqs)

View File

@ -187,7 +187,8 @@ makeConsistent eqs ineqs = (map ensure eqs', map ensure ineqs')
where
eqs' = map (\(Eq e) -> e) eqs
ineqs' = map (\(Ineq e) -> e) ineqs
ensure :: [(CoeffIndex, Integer)] -> EqualityConstraintEquation
ensure = accumArray (+) 0 (0, largestIndex)
largestIndex = maximum $ map (maximum . map fst) $ [[(0,0)]] ++ eqs' ++ ineqs'
@ -374,9 +375,13 @@ testMakeEquations = TestList
joinMapping :: [VarMap] -> ([HandyEq],[HandyIneq]) -> [(VarMap,[HandyEq],[HandyIneq])]
joinMapping vms (eq,ineq) = map (\vm -> (vm,eq,ineq)) vms
i_mapping :: VarMap
i_mapping = Map.singleton (Scale 1 $ (variable "i",0)) 1
ij_mapping :: VarMap
ij_mapping = Map.fromList [(Scale 1 $ (variable "i",0),1),(Scale 1 $ (variable "j",0),2)]
i_mod_mapping :: Integer -> VarMap
i_mod_mapping n = Map.fromList [(Scale 1 $ (variable "i",0),1),(Modulo (Set.singleton $ Scale 1 $ (variable "i",0)) (Set.singleton $ Const n),2)]
i_mod_j_mapping :: VarMap
i_mod_j_mapping = Map.fromList [(Scale 1 $ (variable "i",0),1),(Scale 1 $ (variable "j",0),2),
(Modulo (Set.singleton $ Scale 1 $ (variable "i",0)) (Set.singleton $ Scale 1 $ (variable "j",0)),3)]
_3i_2j_mod_mapping n = Map.fromList [(Scale 1 $ (variable "i",0),1),(Scale 1 $ (variable "j",0),2),
@ -387,7 +392,9 @@ testMakeEquations = TestList
,(Modulo (Set.fromList [Scale 1 $ (variable "i",0), Const 1]) (Set.singleton $ Const n),3)
]
rep_i_mapping :: VarMap
rep_i_mapping = Map.fromList [((Scale 1 (variable "i",0)),1), ((Scale 1 (variable "i",1)),2)]
rep_i_mapping' :: VarMap
rep_i_mapping' = Map.fromList [((Scale 1 (variable "i",0)),2), ((Scale 1 (variable "i",1)),1)]
both_rep_i = joinMapping [rep_i_mapping, rep_i_mapping']
@ -507,6 +514,7 @@ testIndexes = TestList
isMod var@[(ind,1)] alpha divisor = ([alpha_minus_div_sigma === var], leq [con 0, alpha_minus_div_sigma, con $ divisor - 1])
where
alpha_minus_div_sigma = alpha ++ (negate divisor) ** sigma
sigma :: [(Int, Integer)]
sigma = [(ind+1,1)]
-- | Adds both k and m to the equation!

View File

@ -352,6 +352,7 @@ pruneIneq ineq = do let (opps,others) = splitEither $ groupOpposites $ map prune
numVariables :: InequalityProblem -> Int
numVariables ineq = length (nub $ concatMap findVars ineq)
where
findVars :: InequalityConstraintEquation -> [CoeffIndex]
findVars = map fst . filter ((/= 0) . snd) . tail . assocs
-- | Adds a constant value to an equation:

View File

@ -451,9 +451,11 @@ testInputCase = TestList
a0 = simpleName "a0"
b2 = simpleName "b2"
c1 = simpleName "c1"
defineMyProtocol :: CSM m => m ()
defineMyProtocol = defineName (simpleName "prot") $ A.NameDef emptyMeta "prot" "prot" A.ProtocolName
(A.ProtocolCase emptyMeta [(a0,[]),(b2,[A.Int,A.Int]),(c1,[A.Int])])
A.Original A.Unplaced
defineC :: CSM m => m ()
defineC = defineName (simpleName "c") $ simpleDefDecl "c" (A.Chan A.DirUnknown (A.ChanAttributes False False) (A.UserProtocol $ simpleName "prot"))
specInt s = A.Spec emptyMeta (A.Specification emptyMeta (simpleName s) $ A.Declaration emptyMeta A.Int Nothing)

View File

@ -66,6 +66,7 @@ a_eq_not_b = A.Assign m [vA] $ A.ExpressionList m [A.Monadic m A.MonadicNot (A.E
testGetVarProc :: Test
testGetVarProc = TestList (map doTest tests)
where
tests :: [(Int,[Var],[Var],[Var],[Var],A.Process)]
tests =
[
--TODO test channel reads and writes (incl. reads in alts)

View File

@ -33,6 +33,7 @@ import Utils
simplifyComms :: Pass
simplifyComms = runPasses passes
where
passes :: [(String, Pass)]
passes =
[ ("Define temporary variables for outputting expressions", outExprs)
,("Transform ? CASE statements/guards into plain CASE", transformInputCase)

View File

@ -33,6 +33,7 @@ import Types
simplifyExprs :: Pass
simplifyExprs = runPasses passes
where
passes :: [(String, Pass)]
passes =
[ ("Convert FUNCTIONs to PROCs", functionsToProcs)
, ("Convert AFTER to MINUS", removeAfter)

View File

@ -31,6 +31,7 @@ import Pass
simplifyProcs :: Pass
simplifyProcs = runPasses passes
where
passes :: [(String, Pass)]
passes =
[ ("Wrap PAR subprocesses in PROCs", parsToProcs)
, ("Remove parallel assignment", removeParAssign)

View File

@ -29,6 +29,7 @@ import Types
simplifyTypes :: Pass
simplifyTypes = runPasses passes
where
passes :: [(String,Pass)]
passes =
[ ("Resolve types in AST", resolveNamedTypes)
, ("Resolve types in state", rntState)