diff --git a/examples/gfcc/Imper.gf b/examples/gfcc/Imper.gf index 2c1528d59..31ca82f75 100644 --- a/examples/gfcc/Imper.gf +++ b/examples/gfcc/Imper.gf @@ -1,8 +1,9 @@ -abstract Imper = { +abstract Imper = PredefAbs ** { cat Program ; Typ ; + NumTyp ; ListTyp ; Fun ListTyp Typ ; Body ListTyp ; @@ -17,6 +18,7 @@ abstract Imper = { Body AS -> (Fun AS V -> Program) -> Program ; BodyNil : Stm -> Body NilTyp ; + BodyOne : (A : Typ) -> (Var A -> Stm) -> Body (ConsTyp A NilTyp) ; BodyCons : (A : Typ) -> (AS : ListTyp) -> (Var A -> Body AS) -> Body (ConsTyp A AS) ; @@ -29,22 +31,20 @@ abstract Imper = { End : Stm ; EVar : (A : Typ) -> Var A -> Exp A ; - EInt : Int -> Exp TInt ; - EFloat : Int -> Int -> Exp TFloat ; - ELtI : Exp TInt -> Exp TInt -> Exp TInt ; - ELtF : Exp TFloat -> Exp TFloat -> Exp TInt ; + EInt : Int -> Exp (TNum TInt) ; + EFloat : Int -> Int -> Exp (TNum TFloat) ; + ELt : (n : NumTyp) -> let Ex = Exp (TNum n) in Ex -> Ex -> Exp (TNum TInt) ; EApp : (AS : ListTyp) -> (V : Typ) -> Fun AS V -> ListExp AS -> Exp V ; - EAddI, EMulI, ESubI : Exp TInt -> Exp TInt -> Exp TInt ; - EAddF, EMulF, ESubF : Exp TFloat -> Exp TFloat -> Exp TFloat ; - - TInt : Typ ; - TFloat : Typ ; + EAdd, EMul, ESub : (n : NumTyp) -> let Ex = Exp (TNum n) in Ex -> Ex -> Ex ; + + TNum : NumTyp -> Typ ; + TInt, TFloat : NumTyp ; NilTyp : ListTyp ; ConsTyp : Typ -> ListTyp -> ListTyp ; NilExp : ListExp NilTyp ; + OneExp : (A : Typ) -> Exp A -> ListExp (ConsTyp A NilTyp) ; ConsExp : (A : Typ) -> (AS : ListTyp) -> - Exp A -> ListExp AS -> ListExp (ConsExp A AS) ; - + Exp A -> ListExp AS -> ListExp (ConsTyp A AS) ; } diff --git a/examples/gfcc/ImperC.gf b/examples/gfcc/ImperC.gf index b6396456a..28ce65a95 100644 --- a/examples/gfcc/ImperC.gf +++ b/examples/gfcc/ImperC.gf @@ -1,10 +1,10 @@ +--# -path=.:../prelude concrete ImperC of Imper = open ResImper in { flags lexer=codevars ; unlexer=code ; startcat=Stm ; lincat Exp = PrecExp ; - Body = {s,s2 : Str ; size : Size} ; - ListExp = {s : Str ; size : Size} ; + Body = {s,s2 : Str} ; lin Empty = ss [] ; @@ -12,11 +12,13 @@ concrete ImperC of Imper = open ResImper in { val.s ++ cont.$0 ++ paren body.s2 ++ "{" ++ body.s ++ "}" ++ ";" ++ cont.s) ; - BodyNil stm = stm ** {s2 = [] ; size = Zero} ; + BodyNil stm = stm ** {s2 = []} ; + BodyOne typ stm = stm ** { + s2 = typ.s ++ stm.$0 + } ; BodyCons typ _ body = { s = body.s ; - s2 = typ.s ++ body.$0 ++ separator "," body.size ++ body.s2 ; - size = nextSize body.size + s2 = typ.s ++ body.$0 ++ "," ++ body.s2 ; } ; Decl typ cont = continues (typ.s ++ cont.$0) cont ; @@ -27,24 +29,23 @@ concrete ImperC of Imper = open ResImper in { Block stm = continue ("{" ++ stm.s ++ "}") ; End = ss [] ; - EVar _ x = constant x.s ; - EInt n = constant n.s ; - EFloat a b = constant (a.s ++ "." ++ b.s) ; - EMulI, EMulF = infixL P2 "*" ; - EAddI, EAddF = infixL P1 "+" ; - ESubI, ESubF = infixL P1 "-" ; - ELtI, ELtF = infixN P0 "<" ; + EVar _ x = constant x.s ; + EInt n = constant n.s ; + EFloat a b = constant (a.s ++ "." ++ b.s) ; + EMul _ = infixL P2 "*" ; + EAdd _ = infixL P1 "+" ; + ESub _ = infixL P1 "-" ; + ELt _ = infixN P0 "<" ; EApp args val f exps = constant (f.s ++ paren exps.s) ; + TNum t = t ; TInt = ss "int" ; TFloat = ss "float" ; NilTyp = ss [] ; ConsTyp = cc2 ; - NilExp = ss [] ** {size = Zero} ; - ConsExp _ _ e es = { - s = ex e ++ separator "," es.size ++ es.s ; - size = nextSize es.size - } ; + NilExp = ss [] ; + OneExp _ e = ss (ex e) ; + ConsExp _ _ e es = ss (ex e ++ "," ++ es.s) ; } diff --git a/src/GF/CF/PrLBNF.hs b/src/GF/CF/PrLBNF.hs index 59067c39b..701674a52 100644 --- a/src/GF/CF/PrLBNF.hs +++ b/src/GF/CF/PrLBNF.hs @@ -11,14 +11,16 @@ import Char -- Printing CF grammars generated from GF as LBNF grammar for BNFC. -- AR 26/1/2000 -- 9/6/2003 (PPrCF) -- 8/11/2003 --- With a primitive error messaging, by rules and rule tails commented out +-- With primitive error messaging, by rules and rule tails commented out prLBNF :: CF -> String -prLBNF = unlines . (map prCFRule) . rulesOfCF -- hiding the literal recogn function +prLBNF cf = unlines $ (map (prCFRule cs)) $ rulesOfCF cf --- no literal recogn function + where + cs = map IC ["Int","String"] ++ [catId c | (_,(c,_)) <- rulesOfCF cf] -- a hack to hide the LBNF details prBNF :: CF -> String -prBNF = unlines . (map (unwords . unLBNF . drop 1 . words . prCFRule)) . rulesOfCF +prBNF = unlines . (map (unwords . unLBNF . drop 1 . words)) . lines . prLBNF where unLBNF r = case r of "---":ts -> ts @@ -26,25 +28,35 @@ prBNF = unlines . (map (unwords . unLBNF . drop 1 . words . prCFRule)) . rulesOf c:ts -> c : unLBNF ts _ -> r -prCFRule :: CFRule -> String -prCFRule (fun,(cat,its)) = - prCFFun fun ++ "." +++ prCFCat True cat +++ "::=" +++ --- err in cat -> in syntax - unwords (map prCFItem its) +++ ";" +catId ((CFCat ((CIQ _ c),l))) = c -prCFFun :: CFFun -> String -prCFFun (CFFun (t, p)) = case t of - AC (CIQ _ x) -> prId True x - AD (CIQ _ x) -> prId True x +prCFRule :: [Ident] -> CFRule -> String +prCFRule cs (fun,(cat,its)) = + prCFFun cat fun ++ "." +++ prCFCat True cat +++ "::=" +++ --- err in cat -> in syntax + unwords (map (prCFItem cs) its) +++ ";" + +prCFFun :: CFCat -> CFFun -> String +prCFFun (CFCat (_,l)) (CFFun (t, p)) = case t of + AC (CIQ _ x) -> let f = prId True x in (f ++ lab +++ f2 f +++ prP p) + AD (CIQ _ x) -> let f = prId True x in (f ++ lab +++ f2 f +++ prP p) _ -> prErr True $ prt t + where + lab = prLab l + f2 f = if null lab then "" else f + prP = concatMap show prId b i = case i of - IC "Int" -> "Integer" + IC "Int" -> "Integer" + IC "#Var" -> "Ident" + IC "Var" -> "Ident" + IC "id_" -> "_" IC s@(c:_) | isUpper c -> s ++ if isDigit (last s) then "_" else "" _ -> prErr b $ prt i prLab i = case i of L (IC "s") -> "" --- - _ -> "_" ++ prt i + L (IC "_") -> "" --- + _ -> let x = prt i in "_" ++ x ++ if isDigit (last x) then "_" else "" -- just comment out the rest if you cannot interpret the function name in LBNF -- two versions, depending on whether in the beginning of a rule or elsewhere; @@ -55,8 +67,9 @@ prErr b s = (if b then "" else " ;") +++ "---" +++ s prCFCat :: Bool -> CFCat -> String prCFCat b (CFCat ((CIQ _ c),l)) = prId b c ++ prLab l ---- -prCFItem (CFNonterm c) = prCFCat False c -prCFItem (CFTerm a) = prRegExp a +-- if a category does not have a production of its own, we replace it by Ident +prCFItem cs (CFNonterm c) = if elem (catId c) cs then prCFCat False c else "Ident" +prCFItem _ (CFTerm a) = prRegExp a prRegExp (RegAlts tt) = case tt of [t] -> prQuotedString t diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs index 811437f57..3a4706f27 100644 --- a/src/GF/Compile/CheckGrammar.hs +++ b/src/GF/Compile/CheckGrammar.hs @@ -78,15 +78,32 @@ checkAbsInfo st m (c,info) = do case info of AbsCat (Yes cont) _ -> mkCheck "category" $ checkContext st cont ---- also cstrs - AbsFun (Yes typ) (Yes d) -> mkCheck "function" $ - checkTyp st typ ----- ++ - ----- checkEquation st (m,c) d ---- also if there's no def! + AbsFun (Yes typ0) md -> do + typ <- compAbsTyp [] typ0 -- to calculate let definitions + mkCheck "function" $ + checkTyp st typ ++ + case md of + Yes d -> checkEquation st (m,c) d + _ -> [] + return $ (c,AbsFun (Yes typ) md) _ -> return (c,info) where mkCheck cat ss = case ss of [] -> return (c,info) ["[]"] -> return (c,info) ---- _ -> checkErr $ prtBad (unlines ss ++++ "in" +++ cat) c + compAbsTyp g t = case t of + Vr x -> maybe (fail ("no value given to variable" +++ prt x)) return $ lookup x g + Let (x,(_,a)) b -> do + a' <- compAbsTyp g a + compAbsTyp ((x, a'):g) b + Prod x a b -> do + a' <- compAbsTyp g a + b' <- compAbsTyp ((x,Vr x):g) b + return $ Prod x a' b' + Abs _ _ -> return t + _ -> composOp (compAbsTyp g) t + checkCompleteGrammar :: SourceAbs -> SourceCnc -> Check () checkCompleteGrammar abs cnc = mapM_ checkWarn $