also count lin in oper circ check (some problems remain)

This commit is contained in:
aarne
2006-06-02 15:42:57 +00:00
parent f1bfa118c6
commit 3da949d3d7

View File

@@ -63,6 +63,7 @@ evalModule oopts ms mo@(name,mod) = case mod of
MGrammar (mod' : _) <- foldM evalOp gr ids
return $ mod'
MTConcrete a -> do
topoSortOpers $ allOperDependencies name js
js' <- mapMTree (evalCncInfo oopts gr name a) js ---- <- gr0 6/12/2005
return $ (name, ModMod (Module mt st fs me ops js'))
@@ -212,18 +213,25 @@ recordExpand typ trm = case unComputed typ of
-- | auxiliaries for compiling the resource
allOperDependencies :: Ident -> BinTree Ident Info -> [(Ident,[Ident])]
allOperDependencies m b =
[(f, nub (opty pty ++ opty pt)) | (f, ResOper pty pt) <- tree2list b]
[(f, nub (concatMap opty (pts i))) | (f,i) <- tree2list b]
where
opersIn t = case t of
Q n c | n == m -> [c]
_ -> collectOp opersIn t
opty (Yes ty) = opersIn ty
opty _ = []
pts i = case i of
ResOper pty pt -> [pty,pt]
CncFun _ pt _ -> [pt] ---- (Maybe (Ident,(Context,Type))
_ -> [] ---- ResParam
topoSortOpers :: [(Ident,[Ident])] -> Err [Ident]
topoSortOpers st = do
let eops = topoTest st
either return (\ops -> Bad ("circular operations" +++ unwords (map prt (head ops)))) eops
either
return
(\ops -> Bad ("circular definitions:" +++ unwords (map prt (head ops))))
eops
mkLinDefault :: SourceGrammar -> Type -> Err Term
mkLinDefault gr typ = do