/
CFtoBison.hs
315 lines (274 loc) · 10.2 KB
/
CFtoBison.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
{-
BNF Converter: Bison generator
Copyright (C) 2004 Author: Michael Pellauer
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, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1335, USA
-}
{-
BNF Converter: C++ Bison generator
Copyright (C) 2004 Author: Michael Pellauer
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, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1335, USA
-}
{-
**************************************************************
BNF Converter Module
Description : This module generates the Bison input file.
Note that because of the way bison stores results
the programmer can increase performance by limiting
the number of entry points in their grammar.
Author : Michael Pellauer (pellauer@cs.chalmers.se)
License : GPL (GNU General Public License)
Created : 6 August, 2003
Modified : 6 August, 2003
**************************************************************
-}
module BNFC.Backend.CPP.NoSTL.CFtoBison (cf2Bison) where
import Data.Char ( toLower, isUpper )
import Data.List ( intersperse, nub )
import Data.Maybe ( fromMaybe )
import BNFC.CF
import BNFC.Backend.Common.NamedVariables hiding (varName)
import BNFC.Backend.C.CFtoBisonC
( resultName, specialToks, startSymbol, typeName, varName )
import BNFC.Backend.CPP.STL.CFtoBisonSTL ( tokens, union )
import BNFC.PrettyPrint
import BNFC.TypeChecker
import BNFC.Utils ( (+++) )
--This follows the basic structure of CFtoHappy.
-- Type declarations
type Rules = [(NonTerminal,[(Pattern,Action)])]
type Pattern = String
type Action = String
type MetaVar = String
--The environment comes from the CFtoFlex
cf2Bison :: String -> CF -> SymEnv -> String
cf2Bison name cf env
= unlines
[header name cf,
render $ union Nothing (allParserCats cf),
"%token _ERROR_",
tokens user env,
declarations cf,
startSymbol cf,
specialToks cf,
"%%",
prRules (rulesForBison name cf env)
]
where
user = fst (unzip (tokenPragmas cf))
header :: String -> CF -> String
header name cf = unlines
[ "/* This Bison file was machine-generated by BNFC */"
, "%{"
, "#include <stdlib.h>"
, "#include <stdio.h>"
, "#include <string.h>"
, "#include \"Absyn.H\""
, ""
, "#define YYMAXDEPTH 10000000" -- default maximum stack size is 10000, but right-recursion needs O(n) stack
, ""
, "int yyparse(void);"
, "int yylex(void);"
, "int yy_mylinenumber;" --- hack to get line number. AR 2006
, "int initialize_lexer(FILE * inp);"
, "int yywrap(void)"
, "{"
, " return 1;"
, "}"
, "void yyerror(const char *str)"
, "{"
, " extern char *yytext;"
, " fprintf(stderr,\"error: line %d: %s at %s\\n\", "
, " yy_mylinenumber + 1, str, yytext);"
, "}"
, ""
, definedRules cf
, concatMap reverseList $ filter isList $ allParserCatsNorm cf
, unlines $ map parseResult dats
, unlines $ map (parseMethod cf name) eps
, "%}"
]
where
eps = allEntryPoints cf
dats = nub $ map normCat eps
definedRules :: CF -> String
definedRules cf = unlines [ rule f xs e | FunDef f xs e <- cfgPragmas cf]
where
ctx = buildContext cf
list = LC (const "[]") (\ t -> "List" ++ unBase t)
where
unBase (ListT t) = unBase t
unBase (BaseT x) = show$normCat$strToCat x
rule f xs e =
case checkDefinition' list ctx f xs e of
Left err -> error $ "Panic! This should have been caught already:\n" ++ err
Right (args,(e',t)) -> unlines
[ cppType t ++ " " ++ f ++ "_ (" ++
concat (intersperse ", " $ map cppArg args) ++ ") {"
, " return " ++ cppExp e' ++ ";"
, "}"
]
where
cppType :: Base -> String
cppType (ListT (BaseT x)) = "List" ++ show (normCat (strToCat x)) ++ " *"
cppType (ListT t) = cppType t ++ " *"
cppType (BaseT x)
| isToken x ctx = "String"
| otherwise = show (normCat (strToCat x)) ++ " *"
cppArg :: (String, Base) -> String
cppArg (x,t) = cppType t ++ " " ++ x ++ "_"
cppExp :: Exp -> String
cppExp (App "[]" []) = "0"
cppExp (App x [])
| elem x xs = x ++ "_" -- argument
cppExp (App t [e])
| isToken t ctx = cppExp e
cppExp (App x es)
| isUpper (head x) = call ("new " ++ x) es
| otherwise = call (x ++ "_") es
cppExp (LitInt n) = show n
cppExp (LitDouble x) = show x
cppExp (LitChar c) = show c
cppExp (LitString s) = show s
call x es = x ++ "(" ++ concat (intersperse ", " $ map cppExp es) ++ ")"
-- | Generates declaration and initialization of the @YY_RESULT@ for a parser.
--
-- Different parsers (for different precedences of the same category)
-- share such a declaration.
--
-- Expects a normalized category.
parseResult :: Cat -> String
parseResult cat =
"static " ++ cat' ++ "*" +++ resultName cat' +++ "= 0;"
where
cat' = identCat cat
--This generates a parser method for each entry point.
parseMethod :: CF -> String -> Cat -> String
parseMethod cf _ cat = unlines
[
dat ++"* p" ++ par ++ "(FILE *inp)",
"{",
" initialize_lexer(inp);",
" if (yyparse())",
" { /* Failure */",
" return 0;",
" }",
" else",
" { /* Success */",
" return" +++ res ++ ";",
" }",
"}"
]
where
dat = identCat (normCat cat)
par = identCat cat
res0 = resultName dat
revRes = "reverse" ++ dat ++ "(" ++ res0 ++ ")"
res = if cat `elem` cfgReversibleCats cf then revRes else res0
--This method generates list reversal functions for each list type.
reverseList :: Cat -> String
reverseList c = unlines
[
c' ++ "* reverse" ++ c' ++ "(" ++ c' +++ "*l)",
"{",
" " ++ c' +++"*prev = 0;",
" " ++ c' +++"*tmp = 0;",
" while (l)",
" {",
" tmp = l->" ++ v ++ ";",
" l->" ++ v +++ "= prev;",
" prev = l;",
" l = tmp;",
" }",
" return prev;",
"}"
]
where
c' = identCat (normCat c)
v = (map toLower c') ++ "_"
--declares non-terminal types.
declarations :: CF -> String
declarations cf = concatMap (typeNT cf) (allParserCats cf)
where --don't define internal rules
typeNT cf nt | rulesForCat cf nt /= [] = "%type <" ++ varName nt ++ "> " ++ identCat nt ++ "\n"
typeNT _ _ = ""
--The following functions are a (relatively) straightforward translation
--of the ones in CFtoHappy.hs
rulesForBison :: String -> CF -> SymEnv -> Rules
rulesForBison _ cf env = map mkOne $ ruleGroups cf where
mkOne (cat,rules) = constructRule cf env rules cat
-- For every non-terminal, we construct a set of rules.
constructRule :: CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])
constructRule cf env rules nt = (nt,[(p,(generateAction (ruleName r) b m) +++ result) |
r0 <- rules,
let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs
then (True,revSepListRule r0)
else (False,r0),
let (p,m) = generatePatterns cf env r])
where
ruleName r = case funRule r of
"(:)" -> identCat (normCat nt)
"(:[])" -> identCat (normCat nt)
z -> z
revs = cfgReversibleCats cf
eps = allEntryPoints cf
isEntry nt = if elem nt eps then True else False
result = if isEntry nt then (resultName (identCat (normCat nt))) ++ "= $$;" else ""
-- Generates a string containing the semantic action.
generateAction :: Fun -> Bool -> [MetaVar] -> Action
generateAction f b ms =
if isCoercion f
then (unwords ms) ++ ";"
else if f == "[]"
then "0;"
else if isDefinedRule f
then concat [ f, "_", "(", concat $ intersperse ", " ms', ");" ]
else concat ["new ", f, "(", (concat (intersperse ", " ms')), ");"]
where
ms' = if b then reverse ms else ms
-- 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 -> (unwords (map mkIt its), metas its)
where
mkIt i = case i of
Left (TokenCat s) -> fromMaybe (typeName s) $ lookup s env
Left c -> identCat c
Right s -> fromMaybe s $ lookup s env
metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 :: Int ..] its]
revIf c m = if (not (isConsFun (funRule r)) && elem c revs)
then ("reverse" ++ (identCat (normCat c)) ++ "(" ++ m ++ ")")
else m -- no reversal in the left-recursive Cons rule itself
revs = cfgReversibleCats cf
-- 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 ((_, []):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