diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/GF/Compile/Compile.hs | 6 | ||||
| -rw-r--r-- | src/GF/Compile/MkResource.hs | 37 | ||||
| -rw-r--r-- | src/Today.hs | 2 |
3 files changed, 25 insertions, 20 deletions
diff --git a/src/GF/Compile/Compile.hs b/src/GF/Compile/Compile.hs index 404620a28..e2915c0e4 100644 --- a/src/GF/Compile/Compile.hs +++ b/src/GF/Compile/Compile.hs @@ -166,7 +166,7 @@ makeSourceModule opts env@(k,gr,can) mo@(i,mi) = case mi of sm <- ioeErr $ makeReuse gr i (extends m) c let mo2 = (i, ModMod sm) mos = modules gr - putp " type checking reused" $ ioeErr $ showCheckModule mos mo2 + --- putp " type checking reused" $ ioeErr $ showCheckModule mos mo2 return $ (k,mo2) _ -> compileSourceModule opts env mo _ -> compileSourceModule opts env mo @@ -212,7 +212,7 @@ generateModuleCode opts path minfo@(name,info) = do -- for resource, also emit gfr case info of - ModMod m | isModRes m && isCompilable info && emit && nomulti -> do + ModMod m | emitsGFR m && emit && nomulti -> do let (file,out) = (gfrFile pname, prGrammar (MGrammar [minfo])) ioeIO $ writeFile file out >> putStr (" wrote file" +++ file) _ -> return () @@ -224,6 +224,8 @@ generateModuleCode opts path minfo@(name,info) = do else ioeIO $ putStrFlush $ "no need to save module" +++ prt name return minfo' where + emitsGFR m = isModRes m && isCompilable info + ---- isModRes m || (isModCnc m && mstatus m == MSIncomplete) isCompilable mi = case mi of ModMod m -> not $ isModCnc m && mstatus m == MSIncomplete _ -> True diff --git a/src/GF/Compile/MkResource.hs b/src/GF/Compile/MkResource.hs index 9017cc157..7a63f413d 100644 --- a/src/GF/Compile/MkResource.hs +++ b/src/GF/Compile/MkResource.hs @@ -26,49 +26,52 @@ makeReuse gr r me c = do jmsA <- case ma of ModMod m' -> return $ jments m' _ -> prtBad "expected abstract to be the type of" a - liftM ((,) (opens m)) $ mkResDefs r a me (extends m) jmsA (jments m) + liftM ((,) (opens m)) $ mkResDefs gr r a me (extends m) jmsA (jments m) _ -> prtBad "expected concrete to be the type of" c _ -> prtBad "expected concrete to be the type of" c return $ Module MTResource MSComplete flags me ops jms -mkResDefs :: Ident -> Ident -> Maybe Ident -> Maybe Ident -> +mkResDefs :: SourceGrammar -> Ident -> Ident -> Maybe Ident -> Maybe Ident -> BinTree (Ident,Info) -> BinTree (Ident,Info) -> Err (BinTree (Ident,Info)) -mkResDefs r a mext maext abs cnc = mapMTree mkOne abs where +mkResDefs gr r a mext maext abs cnc = mapMTree (mkOne a maext) abs where - mkOne (f,info) = case info of + mkOne a mae (f,info) = case info of AbsCat _ _ -> do - typ <- err (const (return defLinType)) return $ look f + typ <- err (const (return defLinType)) return $ look cnc f typ' <- lockRecType f typ return (f, ResOper (Yes typeType) (Yes typ')) AbsFun (Yes typ0) _ -> do - trm <- look f + trm <- look cnc f testErr (not (isHardType typ0)) ("cannot build reuse for function" +++ prt f +++ ":" +++ prt typ0) - typ <- redirTyp typ0 + typ <- redirTyp True a mae typ0 cat <- valCat typ trm' <- unlockRecord (snd cat) trm return (f, ResOper (Yes typ) (Yes trm')) - AnyInd b _ -> case mext of - Just ext -> return (f,AnyInd b ext) - _ -> prtBad "no indirection possible in" r + AnyInd b n -> do + mo <- lookupModMod gr n + info' <- lookupInfo mo f + mkOne n (extends mo) (f,info') - look f = do + look cnc f = do info <- lookupTree prt f cnc case info of CncCat (Yes ty) _ _ -> return ty CncCat _ _ _ -> return defLinType CncFun _ (Yes tr) _ -> return tr + AnyInd _ n -> do + mo <- lookupModMod gr n + t <- look (jments mo) f + redirTyp False n (extends mo) t _ -> prtBad "not enough information to reuse" f -- type constant qualifications changed from abstract to resource - redirTyp ty = case ty of - Q n c | n == a -> return $ Q r c - Q n c | Just n == maext -> case mext of - Just ext -> return $ Q ext c - _ -> prtBad "no indirection of type possible in" r - _ -> composOp redirTyp ty + redirTyp always a mae ty = case ty of + Q _ c | always -> return $ Q r c + Q n c | n == a || Just n == mae -> return $ Q r c + _ -> composOp (redirTyp always a mae) ty lockRecType :: Ident -> Type -> Err Type lockRecType c t = plusRecType t $ RecType [(lockLabel c, RecType [])] diff --git a/src/Today.hs b/src/Today.hs index 00d8f282c..8650bdedc 100644 --- a/src/Today.hs +++ b/src/Today.hs @@ -1 +1 @@ -module Today where today = "Tue Nov 18 17:18:44 CET 2003" +module Today where today = "Wed Nov 19 17:07:15 CET 2003" |