From fa70d81eb4baf8be30c7df1fb6a20abc14a83477 Mon Sep 17 00:00:00 2001 From: aarne Date: Fri, 24 Sep 2004 08:46:03 +0000 Subject: [PATCH] bug fixes in parsing etc; improved ImperC --- examples/gfcc/ImperC.gf | 12 ++++----- examples/gfcc/ResImper.gf | 42 ++++++++++++++++++++------------ src/GF/CF/CanonToCF.hs | 13 ++++++---- src/GF/Compile/CheckGrammar.hs | 5 ++++ src/GF/Compile/Optimize.hs | 1 + src/GF/Compile/Rename.hs | 1 + src/GF/Grammar/LookAbs.hs | 9 +++++++ src/GF/Grammar/Macros.hs | 4 +++ src/GF/Source/SourceToGrammar.hs | 5 +++- 9 files changed, 64 insertions(+), 28 deletions(-) diff --git a/examples/gfcc/ImperC.gf b/examples/gfcc/ImperC.gf index a97688529..fd59e16d5 100644 --- a/examples/gfcc/ImperC.gf +++ b/examples/gfcc/ImperC.gf @@ -26,10 +26,10 @@ concrete ImperC of Imper = open ResImper in { } ; Decl typ cont = continues (typ.s ++ cont.$0) cont ; - Assign _ x exp = continues (x.s ++ "=" ++ ex exp) ; - Return _ exp = statement ("return" ++ ex exp) ; - While exp loop = continue ("while" ++ paren (ex exp) ++ loop.s) ; - IfElse exp t f = continue ("if" ++ paren (ex exp) ++ t.s ++ "else" ++ f.s) ; + Assign _ x exp = continues (x.s ++ "=" ++ exp.s) ; + Return _ exp = statement ("return" ++ exp.s) ; + While exp loop = continue ("while" ++ paren exp.s ++ loop.s) ; + IfElse exp t f = continue ("if" ++ paren exp.s ++ t.s ++ "else" ++ f.s) ; Block stm = continue ("{" ++ stm.s ++ "}") ; End = ss [] ; @@ -50,6 +50,6 @@ concrete ImperC of Imper = open ResImper in { ConsTyp = cc2 ; NilExp = ss [] ; - OneExp _ e = ss (ex e) ; - ConsExp _ _ e es = ss (ex e ++ "," ++ es.s) ; + OneExp _ e = e ; + ConsExp _ _ e es = ss (e.s ++ "," ++ es.s) ; } diff --git a/examples/gfcc/ResImper.gf b/examples/gfcc/ResImper.gf index beea5f549..c392f078e 100644 --- a/examples/gfcc/ResImper.gf +++ b/examples/gfcc/ResImper.gf @@ -2,27 +2,37 @@ resource ResImper = open Predef in { -- precedence - oper - Prec : PType = Predef.Ints 4 ; - PrecExp : Type = {s : Prec => Str} ; - ex : PrecExp -> Str = \exp -> exp.s ! 0 ; - constant : Str -> PrecExp = \c -> {s = \\_ => c} ; - infixN : Prec -> Str -> PrecExp -> PrecExp -> PrecExp = \p,f,x,y -> - {s = mkPrec (x.s ! (nextPrec ! p) ++ f ++ y.s ! (nextPrec ! p)) ! p} ; - infixL : Prec -> Str -> PrecExp -> PrecExp -> PrecExp = \p,f,x,y -> - {s = mkPrec (x.s ! p ++ f ++ y.s ! (nextPrec ! p)) ! p} ; + param PAssoc = PN | PL | PR ; - nextPrec : Prec => Prec = table { + oper + Prec : PType = Predef.Ints 4 ; + PrecExp : Type = {s : Str ; p : Prec ; a : PAssoc} ; + + mkPrec : Prec -> PAssoc -> Str -> PrecExp = \p,a,f -> + {s = f ; p = p ; a = a} ; + + usePrec : PrecExp -> Prec -> Str = \x,p -> + case < : Prec * Prec> of { + <3,4> | <2,3> | <2,4> => paren x.s ; + <1,1> | <1,0> | <0,0> => x.s ; + <1,_> | <0,_> => paren x.s ; + _ => x.s + } ; + + constant : Str -> PrecExp = mkPrec 4 PN ; + + infixN : Prec -> Str -> (_,_ : PrecExp) -> PrecExp = \p,f,x,y -> + mkPrec p PN (usePrec x (nextPrec p) ++ f ++ usePrec y (nextPrec p)) ; + infixL : Prec -> Str -> (_,_ : PrecExp) -> PrecExp = \p,f,x,y -> + mkPrec p PL (usePrec x p ++ f ++ usePrec y (nextPrec p)) ; + infixR : Prec -> Str -> (_,_ : PrecExp) -> PrecExp = \p,f,x,y -> + mkPrec p PR (usePrec x (nextPrec p) ++ f ++ usePrec y p) ; + + nextPrec : Prec -> Prec = \p -> case

of { 4 => 4 ; n => Predef.plus n 1 } ; - mkPrec : Str -> Prec => Prec => Str = \str -> - \\p,q => case Predef.lessInt p q of { - Predef.PTrue => paren str ; - _ => str - } ; - -- string operations SS : Type = {s : Str} ; diff --git a/src/GF/CF/CanonToCF.hs b/src/GF/CF/CanonToCF.hs index 915e11db2..58674e189 100644 --- a/src/GF/CF/CanonToCF.hs +++ b/src/GF/CF/CanonToCF.hs @@ -6,6 +6,7 @@ import Operations import Option import Ident import AbsGFC +import LookAbs (allBindCatsOf) import GFC import Values (isPredefCat,cPredefAbs) import PrGrammar @@ -31,9 +32,10 @@ canon2cf opts gr c = tracePrt "#size of CF" (err id (show.length.rulesOfCF)) $ d let cncs = [m | (n, M.ModMod m) <- M.modules gr, elem n ms] let mms = [(a, tree2list (M.jments m)) | m <- cncs] rules0 <- liftM concat $ mapM (uncurry (cnc2cfCond opts)) mms + let bindcats = map snd $ allBindCatsOf gr let rules = filter (not . isCircularCF) rules0 ---- temporarily here let grules = groupCFRules rules - let predef = mkCFPredef opts grules + let predef = mkCFPredef opts bindcats grules return $ CF predef cnc2cfCond :: Options -> Ident -> [(Ident,Info)] -> Err [CFRule] @@ -151,17 +153,18 @@ term2CFItems m t = errIn "forming cf items" $ case t of _ -> prtBad "cannot extract record field from" arg cIQ c = if isPredefCat c then CIQ cPredefAbs c else CIQ m c -mkCFPredef :: Options -> [CFRuleGroup] -> ([CFRuleGroup],CFPredef) -mkCFPredef opts rules = (ruls, \s -> preds0 s ++ look s) where +mkCFPredef :: Options -> [Ident] -> [CFRuleGroup] -> ([CFRuleGroup],CFPredef) +mkCFPredef opts binds rules = (ruls, \s -> preds0 s ++ look s) where (ruls,preds) = if oElem lexerByNeed opts -- option -cflexer then predefLexer rules else (rules,emptyTrie) preds0 s = [(cat, metaCFFun) | TM _ _ <- [s], cat <- cats] ++ - [(cat, varCFFun x) | TV x <- [s], cat <- catVarCF : cats] ++ + [(cat, varCFFun x) | TV x <- [s], cat <- catVarCF : bindcats] ++ [(cfCatString, stringCFFun t) | TL t <- [s]] ++ [(cfCatInt, intCFFun t) | TI t <- [s]] - cats = map fst rules + cats = nub [c | (_,rs) <- rules, (_,(_,its)) <- rs, CFNonterm c <- its] + bindcats = [c | c <- cats, elem (cfCat2Ident c) binds] look = concatMap snd . map (trieLookup preds) . wordsCFTok --- for TC tokens --- TODO: integrate with morphology diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs index 8f152ff17..74256d66b 100644 --- a/src/GF/Compile/CheckGrammar.hs +++ b/src/GF/Compile/CheckGrammar.hs @@ -309,6 +309,11 @@ inferLType gr trm = case trm of Vr ident -> termWith trm $ checkLookup ident + Typed e t -> do + t' <- comp t + check e t' + return (e,t') + App f a -> do (f',fty) <- infer f fty' <- comp fty diff --git a/src/GF/Compile/Optimize.hs b/src/GF/Compile/Optimize.hs index bb54df050..61ff8de32 100644 --- a/src/GF/Compile/Optimize.hs +++ b/src/GF/Compile/Optimize.hs @@ -166,6 +166,7 @@ mkLinDefault gr typ = do let (ls,ts) = unzip r ts' <- mapM mkDefField ts return $ R $ [assign l t | (l,t) <- zip ls ts'] + _ | isTypeInts typ -> return $ EInt 0 -- exists in all as first val _ -> prtBad "linearization type field cannot be" typ -- Form the printname: if given, compute. If not, use the computed diff --git a/src/GF/Compile/Rename.hs b/src/GF/Compile/Rename.hs index 6c3f964df..55708f629 100644 --- a/src/GF/Compile/Rename.hs +++ b/src/GF/Compile/Rename.hs @@ -158,6 +158,7 @@ renameTerm env vars = ren vars where ren vs trm = case trm of Abs x b -> liftM (Abs x) (ren (x:vs) b) Prod x a b -> liftM2 (Prod x) (ren vs a) (ren (x:vs) b) + Typed a b -> liftM2 Typed (ren vs a) (ren vs b) Vr x | elem x vs -> return trm | otherwise -> renid trm diff --git a/src/GF/Grammar/LookAbs.hs b/src/GF/Grammar/LookAbs.hs index 06e3ce3a5..ba809822a 100644 --- a/src/GF/Grammar/LookAbs.hs +++ b/src/GF/Grammar/LookAbs.hs @@ -105,6 +105,15 @@ allCatsOf gr = isModAbs m, (c, C.AbsCat cont _) <- tree2list (jments m)] +allBindCatsOf :: GFCGrammar -> [Cat] +allBindCatsOf gr = + nub [c | (i, ModMod m) <- modules gr, + isModAbs m, + (c, C.AbsFun typ _) <- tree2list (jments m), + Ok (cont,_) <- [firstTypeForm typ], + c <- concatMap fst $ errVal [] $ mapM (catSkeleton . snd) cont + ] + funsForType :: (Val -> Type -> Bool) -> GFCGrammar -> Val -> [(Fun,Type)] funsForType compat gr val = [(fun,typ) | (fun,typ) <- funRulesOf gr, compat val typ] diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs index f11b9bbe9..8b9f825b5 100644 --- a/src/GF/Grammar/Macros.hs +++ b/src/GF/Grammar/Macros.hs @@ -273,6 +273,10 @@ typeString = constPredefRes "String" typeInt = constPredefRes "Int" typeInts i = App (constPredefRes "Ints") (EInt i) +isTypeInts ty = case ty of + App c _ -> c == constPredefRes "Ints" + _ -> False + constPredefRes s = Q (IC "Predef") (zIdent s) isPredefConstant t = case t of diff --git a/src/GF/Source/SourceToGrammar.hs b/src/GF/Source/SourceToGrammar.hs index 436ce4503..38a55e4d5 100644 --- a/src/GF/Source/SourceToGrammar.hs +++ b/src/GF/Source/SourceToGrammar.hs @@ -353,7 +353,10 @@ transExp x = case x of ECase exp cases -> do exp' <- transExp exp cases' <- transCases cases - return $ G.S (G.T G.TRaw cases') exp' + let annot = case exp' of + G.Typed _ t -> G.TTyped t + _ -> G.TRaw + return $ G.S (G.T annot cases') exp' ECTable binds exp -> liftM2 M.mkCTable (mapM transBind binds) (transExp exp) EVariants exps -> liftM G.FV $ mapM transExp exps