BNFC-2.5.0: src/formats/java1.5/CFtoCup15.hs
{-
BNF Converter: Java 1.5 Cup Generator
Copyright (C) 2004 Author: Markus Forsberg, Michael Pellauer,
Bjorn Bringert
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
{-
**************************************************************
BNF Converter Module
Description : This module generates the CUP input file. It
follows the same basic structure of CFtoHappy.
Author : Michael Pellauer (pellauer@cs.chalmers.se),
Bjorn Bringert (bringert@cs.chalmers.se)
License : GPL (GNU General Public License)
Created : 26 April, 2003
Modified : 5 Aug, 2004
**************************************************************
-}
module CFtoCup15 ( cf2Cup ) where
import CF
import Data.List (intersperse, isPrefixOf)
import NamedVariables
import Utils ( (+++) )
import TypeChecker -- We need to (re-)typecheck to figure out list instances in
-- defined rules.
import ErrM
import Data.Char
-- Type declarations
type Rules = [(NonTerminal,[(Pattern,Action)])]
type NonTerminal = String
type Pattern = String
type Action = String
type MetaVar = String
--The environment comes from the CFtoJLex
cf2Cup :: String -> String -> CF -> SymEnv -> String
cf2Cup packageBase packageAbsyn cf env = unlines
[
header,
declarations packageAbsyn (allCats cf),
tokens env,
specialToks cf,
specialRules cf,
prEntryPoint cf,
prRules (rulesForCup packageAbsyn cf env)
]
where
header :: String
header = unlines
["// -*- Java -*- This Cup file was machine-generated by BNFC",
"package" +++ packageBase ++ ";",
"",
"parser code {:",
parseMethod packageAbsyn (firstEntry cf),
"public <B,A extends java.util.LinkedList<? super B>> A cons_(B x, A xs) { xs.addFirst(x); return xs; }",
definedRules packageAbsyn cf,
-- unlines $ map (parseMethod packageAbsyn) (allEntryPoints cf),
"public void syntax_error(java_cup.runtime.Symbol cur_token)",
"{",
"\treport_error(\"Syntax Error, trying to recover and continue parse...\", cur_token);",
"}",
"",
"public void unrecovered_syntax_error(java_cup.runtime.Symbol cur_token) throws java.lang.Exception",
"{",
"\tthrow new Exception(\"Unrecoverable Syntax Error\");",
"}",
"",
":}"
]
definedRules :: String -> CF -> String
definedRules packageAbsyn cf =
unlines [ rule f xs e | FunDef f xs e <- pragmasOfCF cf ]
where
ctx = buildContext cf
list = LC (\t -> "List" ++ unBase t) (const "cons")
where
unBase (ListT t) = unBase t
unBase (BaseT x) = normCat x
rule f xs e =
case checkDefinition' list ctx f xs e of
Bad err -> error $ "Panic! This should have been caught already:\n" ++ err
Ok (args,(e',t)) -> unlines
[ "public " ++ javaType t ++ " " ++ f ++ "_ (" ++
concat (intersperse ", " $ map javaArg args) ++ ") {"
, " return " ++ javaExp e' ++ ";"
, "}"
]
where
javaType :: Base -> String
javaType (ListT (BaseT x)) = packageAbsyn ++ ".List" ++ normCat x
javaType (ListT t) = javaType t
javaType (BaseT x)
| isToken x ctx = "String"
| otherwise = packageAbsyn ++ "." ++ normCat x
javaArg :: (String, Base) -> String
javaArg (x,t) = javaType t ++ " " ++ x ++ "_"
javaExp :: Exp -> String
javaExp (App "null" []) = "null"
javaExp (App x [])
| elem x xs = x ++ "_" -- argument
javaExp (App t [e])
| isToken t ctx = call ("new String") [e]
javaExp (App x es)
| isUpper (head x) = call ("new " ++ packageAbsyn ++ "." ++ x) es
| otherwise = call (x ++ "_") es
javaExp (LitInt n) = "new Integer(" ++ show n ++ ")"
javaExp (LitDouble x) = "new Double(" ++ show x ++ ")"
javaExp (LitChar c) = "new Character(" ++ show c ++ ")"
javaExp (LitString s) = "new String(" ++ show s ++ ")"
call x es = x ++ "(" ++ concat (intersperse ", " $ map javaExp es) ++ ")"
-- peteg: FIXME JavaCUP can only cope with one entry point AFAIK.
prEntryPoint :: CF -> String
prEntryPoint cf = unlines ["", "start with " ++ firstEntry cf ++ ";", ""]
-- [ep] -> unlines ["", "start with " ++ ep ++ ";", ""]
-- eps -> error $ "FIXME multiple entry points." ++ show eps
--This generates a parser method for each entry point.
parseMethod :: String -> Cat -> String
parseMethod packageAbsyn cat =
if normCat cat /= cat
then ""
else unlines
[
" public" +++ packageAbsyn ++ "." ++ cat' +++ "p" ++ cat' ++ "()"
++ " throws Exception",
" {",
"\tjava_cup.runtime.Symbol res = parse();",
"\treturn (" ++ packageAbsyn ++ "." ++ cat' ++ ") res.value;",
" }"
]
where cat' = identCat (normCat cat)
--non-terminal types
declarations :: String -> [NonTerminal] -> String
declarations packageAbsyn ns = unlines (map (typeNT packageAbsyn) ns)
where
typeNT _nm nt = "nonterminal" +++ packageAbsyn ++ "."
++ identCat (normCat nt) +++ identCat nt ++ ";"
--terminal types
tokens :: SymEnv -> String
tokens ts = unlines (map declTok ts)
where
declTok (s,r) = "terminal" +++ r ++ "; // " ++ s
specialToks :: CF -> String
specialToks cf = unlines [
ifC "String" "terminal String _STRING_;",
ifC "Char" "terminal Character _CHAR_;",
ifC "Integer" "terminal Integer _INTEGER_;",
ifC "Double" "terminal Double _DOUBLE_;",
ifC "Ident" "terminal String _IDENT_;"
]
where
ifC cat s = if isUsedCat cf cat then s else ""
-- This handles user defined tokens
-- FIXME
specialRules:: CF -> String
specialRules cf =
unlines ["terminal String " ++ name ++ ";" | (name, _) <- tokenPragmas cf]
--The following functions are a (relatively) straightforward translation
--of the ones in CFtoHappy.hs
rulesForCup :: String -> CF -> SymEnv -> Rules
rulesForCup packageAbsyn cf env = map mkOne $ ruleGroups cf where
mkOne (cat,rules) = constructRule packageAbsyn cf env rules cat
-- For every non-terminal, we construct a set of rules. A rule is a sequence of
-- terminals and non-terminals, and an action to be performed.
constructRule :: String -> CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])
constructRule packageAbsyn cf env rules nt =
(nt, [(p,generateAction packageAbsyn nt (funRule r) (revM b m) b)
| r0 <- rules,
let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs
then (True, revSepListRule r0)
else (False, r0)
(p,m) = generatePatterns cf env r])
where
revM False m = m
revM True [h,t] = [t,h]
revs = reversibleCats cf
-- Generates a string containing the semantic action.
generateAction :: String -> NonTerminal -> Fun -> [MetaVar]
-> Bool -- ^ Whether the list should be reversed or not.
-- Only used if this is a list rule.
-> Action
generateAction packageAbsyn nt f ms rev
| isNilFun f = "RESULT = new " ++ c ++ "();"
| isOneFun f = "RESULT = new " ++ c ++ "(); RESULT.addLast(" ++ p_1 ++ ");"
| isConsFun f = "RESULT = " ++ p_2 ++ "; "
++ p_2 ++ "." ++ add ++ "(" ++ p_1 ++ ");"
| isCoercion f = "RESULT = " ++ p_1 ++ ";"
| isDefinedRule f = "RESULT = parser." ++ f ++ "_"
++ "(" ++ concat (intersperse "," ms) ++ ");"
| otherwise = "RESULT = new " ++ c
++ "(" ++ concat (intersperse "," ms) ++ ");"
where
c = packageAbsyn ++ "." ++
if isNilFun f || isOneFun f || isConsFun f
then identCat (normCat nt) else f
p_1 = ms!!0
p_2 = ms!!1
add = if rev then "addLast" else "addFirst"
-- Generate patterns and a set of metavariables indicating
-- where in the pattern the non-terminal
generatePatterns :: CF -> SymEnv -> Rule -> (Pattern,[MetaVar])
generatePatterns cf env r = case rhsRule r of
[] -> (" /* empty */ ",[])
its -> (mkIt env 1 its, metas its)
where
mkIt _env _n [] = []
mkIt env n (i:is) = case i of
Left c -> c' ++ ":p_" ++ (show (n :: Int)) +++ (mkIt env (n+1) is)
where
c' = case c of
"Ident" -> "_IDENT_"
"Integer" -> "_INTEGER_"
"Char" -> "_CHAR_"
"Double" -> "_DOUBLE_"
"String" -> "_STRING_"
_ -> identCat c
Right s -> case (lookup s env) of
(Just x) -> x +++ (mkIt env (n+1) is)
(Nothing) -> (mkIt env n is)
metas its = ["p_" ++ show i | (i,Left c) <- zip [1 :: Int ..] its]
-- We have now constructed the patterns and actions,
-- so the only thing left is to merge them into one string.
prRules :: Rules -> String
prRules [] = []
prRules ((nt, []):rs) = prRules rs --internal rule
prRules ((nt,((p,a):ls)):rs) =
(unwords [nt', "::=", p, "{:", a, ":}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs
where
nt' = identCat nt
pr [] = []
pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{:", a , ":}"])]) ++ pr ls