BNFC-2.8.3: src/BNFC/Backend/C/CFtoCSkel.hs
{-# LANGUAGE NoImplicitPrelude #-}
{-
BNF Converter: C Skeleton 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 C Skeleton functions.
The generated files follow Appel's case method.
Author : Michael Pellauer (pellauer@cs.chalmers.se)
License : GPL (GNU General Public License)
Created : 9 August, 2003
Modified : 12 August, 2003
**************************************************************
-}
module BNFC.Backend.C.CFtoCSkel (cf2CSkel) where
import Prelude'
import BNFC.CF
import BNFC.Utils ( (+++) )
import BNFC.Backend.Common.NamedVariables
import Data.Char ( toLower, toUpper )
import Data.Either (lefts)
import Text.PrettyPrint
--Produces (.H file, .C file)
cf2CSkel :: CF -> (String, String)
cf2CSkel cf = (mkHFile cf groups, mkCFile cf groups)
where
groups = fixCoercions (ruleGroups cf)
{- **** Header (.H) File Functions **** -}
--Generates the Header File
mkHFile :: CF -> [(Cat,[Rule])] -> String
mkHFile cf groups = unlines
[
header,
concatMap prDataH groups,
concatMap prUserH user,
footer
]
where
user = map fst $ tokenPragmas cf
header = unlines
[
"#ifndef SKELETON_HEADER",
"#define SKELETON_HEADER",
"/* You might want to change the above name. */",
"",
"#include \"Absyn.h\"",
""
]
prUserH u = "void visit" ++ basicFunNameS u ++ "(" ++ u ++ " p);"
footer = unlines
[
"void visitIdent(Ident i);",
"void visitInteger(Integer i);",
"void visitDouble(Double d);",
"void visitChar(Char c);",
"void visitString(String s);",
"",
"#endif"
]
--Prints out visit functions for a category
prDataH :: (Cat, [Rule]) -> String
prDataH (cat, _rules) =
if isList cat
then concat ["void visit", cl, "(", cl, " p);\n"]
else "void visit" ++ cl ++ "(" ++ cl ++ " p);\n"
where cl = identCat $ normCat cat
{- **** Implementation (.C) File Functions **** -}
-- | Makes the skeleton's .c File
mkCFile :: CF -> [(Cat,[Rule])] -> String
mkCFile cf groups = concat
[ header
, concatMap prData groups
, concatMap prUser user
, footer
]
where
user = map fst $ tokenPragmas cf
header = unlines [
"/*** BNFC-Generated Visitor Traversal Skeleton. ***/",
"/* This traverses the abstract syntax tree.",
" To use, copy Skeleton.h and Skeleton.c to",
" new files. */",
"",
"#include <stdlib.h>",
"#include <stdio.h>",
"",
"#include \"Skeleton.h\"",
""
]
prUser u = unlines
[
"void visit" ++ basicFunNameS u ++ "(" ++ u ++ " p)",
"{",
" /* Code for " ++ u ++ " Goes Here */",
"}"
]
footer = unlines
[
"void visitIdent(Ident i)",
"{",
" /* Code for Ident Goes Here */",
"}",
"void visitInteger(Integer i)",
"{",
" /* Code for Integer Goes Here */",
"}",
"void visitDouble(Double d)",
"{",
" /* Code for Double Goes Here */",
"}",
"void visitChar(Char c)",
"{",
" /* Code for Char Goes Here */",
"}",
"void visitString(String s)",
"{",
" /* Code for String Goes Here */",
"}",
""
]
--Visit functions for a category.
prData :: (Cat, [Rule]) -> String
prData (cat, rules)
| isList cat = unlines
[
"void visit" ++ cl ++ "("++ cl +++ vname ++ ")",
"{",
" while(" ++ vname +++ " != 0)",
" {",
" /* Code For " ++ cl ++ " Goes Here */",
" visit" ++ ecl ++ "(" ++ vname ++ "->" ++ member ++ "_);",
" " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;",
" }",
"}",
""
]
-- Not a list:
| otherwise = unlines
[
"void visit" ++ cl ++ "(" ++ cl ++ " p)",
"{",
" switch(p->kind)",
" {",
concatMap (render . prPrintRule) rules,
" default:",
" fprintf(stderr, \"Error: bad kind field when printing " ++ cl ++ "!\\n\");",
" exit(1);",
" }",
"}\n"
]
where cl = identCat $ normCat cat
ecl = identCat $ normCatOfList cat
vname = map toLower cl
member = map toLower ecl
-- | Visits all the instance variables of a category.
-- >>> let ab = Cat "ab"
-- >>> prPrintRule (Rule "abc" undefined [Left ab, Left ab])
-- case is_abc:
-- /* Code for abc Goes Here */
-- visitab(p->u.abc_.ab_1);
-- visitab(p->u.abc_.ab_2);
-- break;
-- <BLANKLINE>
-- >>> let ab = TokenCat "ab"
-- >>> prPrintRule (Rule "abc" undefined [Left ab])
-- case is_abc:
-- /* Code for abc Goes Here */
-- visitAb(p->u.abc_.ab_);
-- break;
-- <BLANKLINE>
-- >>> prPrintRule (Rule "abc" undefined [Left ab, Left ab])
-- case is_abc:
-- /* Code for abc Goes Here */
-- visitAb(p->u.abc_.ab_1);
-- visitAb(p->u.abc_.ab_2);
-- break;
-- <BLANKLINE>
prPrintRule :: Rule -> Doc
prPrintRule (Rule fun _c cats) | not (isCoercion fun) = nest 2 $ vcat
[ text $ "case is_" ++ fun ++ ":"
, nest 2 (vcat
[ "/* Code for " <> text fun <> " Goes Here */"
, cats'
, "break;\n"
])
]
where
cats' = vcat $ map (prCat fun) (lefts (numVars cats))
prPrintRule (Rule _fun _ _) = ""
-- Prints the actual instance-variable visiting.
prCat :: Fun -> (Cat, Doc) -> Doc
prCat fnm (cat, vname) =
let visitf = "visit" <> if isTokenCat cat
then basicFunName cat
else text (identCat (normCat cat))
in visitf <> parens ("p->u." <> text v <> "_." <> vname ) <> ";"
where v = map toLower $ normFun fnm
-- | The visit-function name of a basic type
basicFunName :: Cat -> Doc
basicFunName = text . basicFunNameS . catToStr
basicFunNameS :: String -> String
basicFunNameS (c:cs) = toUpper c : cs
basicFunNameS [] = error "impossible: empty string in CFtoCSkel.basicFunNameS"