forgiving names in concrete that are not in abstract, with a warning (no warning guaranteed if this is because restricted inheritance)

This commit is contained in:
aarne
2008-08-14 20:25:52 +00:00
parent bf7ec18141
commit 0ce04f1a6e
2 changed files with 23 additions and 4 deletions

View File

@@ -184,10 +184,25 @@ checkAbsInfo st m mo (c,info) = do
checkCompleteGrammar :: SourceAbs -> SourceCnc -> Check (BinTree Ident Info)
checkCompleteGrammar abs cnc = do
let js = jments cnc
let fs = tree2list $ jments abs
foldM checkOne js fs
let jsa = jments abs
let fsa = tree2list jsa
let jsc = jments cnc
let fsc = map fst $ filter (isCnc . snd) $ tree2list jsc
-- remove those lincat and lin in concrete that are not in abstract
let unkn = filter (not . flip isInBinTree jsa) fsc
jsc1 <- if (null unkn) then return jsc else do
checkWarn $ "WARNING: ignoring constants not in abstract:" +++
unwords (map prt unkn)
return $ filterBinTree (\f _ -> notElem f unkn) jsc
-- check that all abstract constants are in concrete; build default lincats
foldM checkOne jsc1 fsa
where
isCnc j = case j of
CncFun _ _ _ -> True
CncCat _ _ _ -> True
_ -> False
checkOne js i@(c,info) = case info of
AbsFun (Yes _) _ -> case lookupIdent c js of
Ok _ -> return js