[ #363 #287 ] fixed for C++: cons, sanitization of keywords

source/src/BNFC/Backend/C/CFtoBisonC.hs

@@ -1,3 +1,9 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+
 {-
     BNF Converter: C Bison generator
     Copyright (C) 2004  Author:  Michael Pellauer
@@ -11,10 +17,6 @@
     Created       : 6 August, 2003
 -}
 
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TupleSections #-}
-
 module BNFC.Backend.C.CFtoBisonC
   ( cf2Bison
   , resultName, typeName, varName
@@ -35,6 +37,7 @@ import System.FilePath ( (<.>) )
 import BNFC.CF
 import BNFC.Backend.Common.NamedVariables hiding (varName)
 import BNFC.Backend.C.CFtoFlexC (ParserMode(..), cParser, stlParser, parserHExt, parserName, parserPackage)
+import BNFC.Backend.CPP.Naming
 import BNFC.Backend.CPP.STL.STLUtils
 import BNFC.Options (RecordPositions(..), InPackage)
 import BNFC.PrettyPrint
@@ -447,15 +450,15 @@ generateActionC rp cParser nt f b ms
           = ""
   new :: String -> String
   new | cParser   = ("make_" ++)
-      | otherwise = \ s -> if isUpper (head s) then "new " ++ s else s
+      | otherwise = \ s -> if isUpper (head s) then "new " ++ s else sanitizeCpp s
 
 generateActionSTL :: IsFun a => RecordPositions -> InPackage -> String -> a -> Bool -> [(MetaVar,Bool)] -> Action
 generateActionSTL rp inPackage nt f b mbs = reverses ++
   if | isCoercion f    -> concat ["$$ = ", unwords ms, ";", loc]
      | isNilFun f      -> concat ["$$ = ", "new ", scope, nt, "();"]
      | isOneFun f      -> concat ["$$ = ", "new ", scope, nt, "(); $$->push_back(", head ms, ");"]
      | isConsFun f     -> concat [lst, "->push_back(", el, "); $$ = ", lst, ";"]
-     | isDefinedRule f -> concat ["$$ = ", scope, funName f, "(", intercalate ", " ms, ");" ]
+     | isDefinedRule f -> concat ["$$ = ", scope, sanitizeCpp (funName f), "(", intercalate ", " ms, ");" ]
      | otherwise       -> concat ["$$ = ", "new ", scope, funName f, "(", intercalate ", " ms, ");", loc]
  where
   ms        = map fst mbs

source/src/BNFC/Backend/C/CFtoFlexC.hs

@@ -1,4 +1,6 @@
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TupleSections #-}
 
 {-

source/src/BNFC/Backend/CPP/Common.hs

@@ -10,10 +10,13 @@ import Data.List  ( nub, intercalate )
 import BNFC.CF
 import BNFC.TypeChecker
 
--- | C++ code for the @define@d constructors.
+import BNFC.Backend.CPP.Naming
 
-definedRules :: Bool -> CF -> String -> String
-definedRules onlyHeader cf banner
+-- | C++ code for the @define@d constructors.
+--
+-- @definedRules Nothing@ only prints the header.
+definedRules :: Maybe ListConstructors -> CF -> String -> String
+definedRules mlc cf banner
   | null theLines = []
   | otherwise     = unlines $ banner : "" : theLines
   where
@@ -27,49 +30,47 @@ definedRules onlyHeader cf banner
       }
       where
         unBase (ListT t) = unBase t
-        unBase (BaseT x) = norm x
-
-    norm = catToStr . normCat . strToCat
+        unBase (BaseT x) = x
 
     rule (Define f args e t) =
-      case runTypeChecker $ checkDefinition' list ctx f xs e of
-        Left err -> error $ "Panic! This should have been caught already:\n" ++ err
-        Right (args,(e',t))
-          | onlyHeader -> header ++ ";"
-          | otherwise  -> unlines
-            [ header ++ " {"
-            , "  return " ++ cppExp (map fst args) e' ++ ";"
-            , "}"
-            ]
-         where
-         header = cppType t ++ " " ++ funName f ++ "(" ++
-                  intercalate ", " (map cppArg args) ++ ")"
+      case mlc of
+        Nothing -> header ++ ";"
+        Just lc -> unlines
+          [ header ++ " {"
+          , "  return " ++ cppExp lc (map fst args) e ++ ";"
+          , "}"
+          ]
       where
-        xs = map fst args
+        header = cppType t ++ " " ++ sanitizeCpp (funName f) ++ "(" ++
+                  intercalate ", " (map cppArg args) ++ ")"
+
         cppType :: Base -> String
-        cppType (ListT (BaseT x)) = "List" ++ norm x ++ "*"
+        cppType (ListT (BaseT x)) = "List" ++ x ++ "*"
         cppType (ListT t)         = cppType t ++ "*"
         cppType (BaseT x)
             | x `elem` baseTokenCatNames = x
             | isToken x ctx = "String"
-            | otherwise     = norm x ++ "*"
+            | otherwise     = x ++ "*"
 
         cppArg :: (String, Base) -> String
         cppArg (x,t) = cppType t ++ " " ++ x ++ "_"
 
-        cppExp :: [String] -> Exp -> String
-        cppExp args = \case
-            App "[]" _ []    -> "0"
+        cppExp :: ListConstructors -> [String] -> Exp -> String
+        cppExp (LC nil cons) args = loop
+          where
+          loop = \case
+            App "[]"  (FunT [] (ListT t)) [] -> fst $ nil t
+            App "(:)" (FunT _  (ListT t)) es -> call (fst $ cons t) es
             Var x          -> x ++ "_"  -- argument
             App t _ [e]
-              | isToken t ctx    -> cppExp args e
+              | isToken t ctx    -> loop e
             App x _ es
               | isUpper (head x) -> call ("new " ++ x) es
               | x `elem` args    -> call (x ++ "_") es
-              | otherwise        -> call x es
+              | otherwise        -> call (sanitizeCpp x) es
             LitInt n       -> show n
             LitDouble x    -> show x
             LitChar c      -> show c
             LitString s    -> show s
-          where
-          call x es = x ++ "(" ++ intercalate ", " (map (cppExp args) es) ++ ")"
+
+          call x es = x ++ "(" ++ intercalate ", " (map loop es) ++ ")"

source/src/BNFC/Backend/CPP/Naming.hs

@@ -19,3 +19,9 @@ cppReservedWords = cReservedWords ++ [ "asm", "dynamic_cast", "namespace"
 
 mkVariable :: String -> String
 mkVariable = mkName cppReservedWords SnakeCase
+
+sanitizeC :: String -> String
+sanitizeC = mkName cReservedWords OrigCase
+
+sanitizeCpp :: String -> String
+sanitizeCpp = mkName cppReservedWords OrigCase

source/src/BNFC/Backend/CPP/NoSTL/CFtoCPPAbs.hs

@@ -1,4 +1,6 @@
-{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
 
 {-
     BNF Converter: C++ abstract syntax generator
@@ -23,7 +25,9 @@ import Data.Char  ( toLower )
 import Text.PrettyPrint
 
 import BNFC.CF
-import BNFC.Utils ( (+++), (++++) )
+import BNFC.TypeChecker ( ListConstructors(..) )
+import BNFC.Utils       ( (+++), (++++) )
+
 import BNFC.Backend.Common.NamedVariables
 import BNFC.Backend.Common.OOAbstract
 import BNFC.Backend.CPP.Common
@@ -54,7 +58,7 @@ mkHFile cf = unlines
   "/********************   Abstract Syntax Classes    ********************/\n",
   concatMap (prDataH user) (getAbstractSyntax cf),
   "",
-  definedRules True cf
+  definedRules Nothing cf
   "/********************   Defined Constructors    ********************/",
   "",
   "#endif"
@@ -224,11 +228,13 @@ mkCFile cf = unlines
  [
   header,
   concatMap (prDataC user) (getAbstractSyntax cf),
-  definedRules False cf
+  definedRules (Just $ LC nil cons) cf
   "/********************   Defined Constructors    ********************/"
  ]
  where
-  user = fst (unzip (tokenPragmas cf))
+  nil _  = (,dummyType) $ "NULL"
+  cons t = (,dummyType) $ "new List" ++ identType t
+  user   = map fst (tokenPragmas cf)
   header = unlines
    [
     "//C++ Abstract Syntax Implementation generated by the BNF Converter.",

source/src/BNFC/Backend/CPP/STL/CFtoSTLAbs.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE TupleSections #-}
+
 {-
     BNF Converter: C++ abstract syntax generator
     Copyright (C) 2004  Author:  Michael Pellauer
@@ -16,11 +18,14 @@
 
 module BNFC.Backend.CPP.STL.CFtoSTLAbs (cf2CPPAbs) where
 
+import Data.List        ( intercalate, intersperse )
+
 import BNFC.Backend.Common.OOAbstract
 import BNFC.CF
-import BNFC.Options (RecordPositions(..))
-import BNFC.Utils((+++))
-import Data.List
+import BNFC.Options     ( RecordPositions(..) )
+import BNFC.TypeChecker ( ListConstructors(..) )
+import BNFC.Utils       ( (+++), applyWhen )
+
 import BNFC.Backend.CPP.Common
 import BNFC.Backend.CPP.STL.STLUtils
 
@@ -69,7 +74,7 @@ mkHFile rp inPackage cabs cf = unlines
   "",
   unlines [prList c | c <- listtypes cabs],
   "",
-  definedRules True cf
+  definedRules Nothing cf
   "/********************   Defined Constructors    ********************/",
   nsEnd inPackage,
   "#endif"
@@ -137,17 +142,20 @@ prCon (c,(f,cs)) = unlines [
    conargs = concat $ intersperse ", "
      [x +++ pointerIf st ("p" ++ show i) | ((x,st,_),i) <- zip cs [1..]]
 
-prList :: (String,Bool) -> String
-prList (c,b) = unlines [
-  "class " ++c++ " : public Visitable, public std::vector<" ++bas++ ">",
-  "{",
-  "public:",
-  "  virtual void accept(Visitor *v);",
-  "  virtual " ++ c ++ " *clone() const;",
-  "};"
+prList :: (String, Bool) -> String
+prList (c, b) = unlines
+  [ "class " ++c++ " : public Visitable, public std::vector<" ++bas++ ">"
+  , "{"
+  , "public:"
+  , "  virtual void accept(Visitor *v);"
+  , "  virtual " ++ c ++ " *clone() const;"
+  , "};"
+  , ""
+    -- cons for this list type
+  , concat [ c, "* ", "cons", c, "(", bas, " x, ", c, "* xs);" ]
   ]
- where
-   bas = drop 4 c {- drop "List" -} ++ if b then "*" else ""
+  where
+  bas = applyWhen b (++ "*") $ drop 4 c {- drop "List" -}
 
 
 -- **** Implementation (.C) File Functions **** --
@@ -161,11 +169,15 @@ mkCFile inPackage cabs cf = unlines $ [
   "#include \"Absyn.H\"",
   nsStart inPackage,
   unlines [prConC  r | (_,rs) <- signatures cabs, r <- rs],
-  unlines [prListC c | (c,_) <- listtypes cabs],
-  definedRules False cf
+  unlines [prListC l | l <- listtypes cabs],
+  definedRules (Just $ LC nil cons) cf
   "/********************   Defined Constructors    ********************/",
   nsEnd inPackage
   ]
+  where
+  nil  t = (,dummyType) $ concat [ "new List", identType t, "()" ]
+  cons t = (,dummyType) $ concat [ "consList", identType t ]
+
 
 prConC :: CAbsRule -> String
 prConC fcs@(f,_) = unlines [
@@ -178,14 +190,14 @@ prConC fcs@(f,_) = unlines [
   ""
  ]
 
-prListC :: String -> String
-prListC c = unlines [
-  "/********************   " ++ c ++ "    ********************/",
-  "",
-  prAcceptC c,
-  "",
-  prCloneC c
- ]
+prListC :: (String,Bool) -> String
+prListC (c,b) = unlines
+  [ "/********************   " ++ c ++ "    ********************/"
+  , ""
+  , prAcceptC c
+  , prCloneC c
+  , prConsC c b
+  ]
 
 
 --The standard accept function for the Visitor pattern
@@ -206,6 +218,17 @@ prCloneC c = unlines [
   "}"
   ]
 
+-- | Make a list constructor definition.
+prConsC :: String -> Bool -> String
+prConsC c b = unlines
+  [ concat [ c, "* ", "cons", c, "(", bas, " x, ", c, "* xs) {" ]
+  , "  xs->insert(xs->begin(), x);"
+  , "  return xs;"
+  , "}"
+  ]
+  where
+  bas = applyWhen b (++ "*") $ drop 4 c {- drop "List" -}
+
 --The constructor assigns the parameters to the corresponding instance variables.
 prConstructorC :: CAbsRule -> String
 prConstructorC (f,cs) = unlines [

source/src/BNFC/Utils.hs

@@ -326,6 +326,7 @@ data NameStyle
   | SnakeCase  -- ^ e.g. @snake_case@
   | CamelCase  -- ^ e.g. @CamelCase@
   | MixedCase  -- ^ e.g. @mixedCase@
+  | OrigCase   -- ^ Keep original capitalization and form.
   deriving (Show, Eq)
 
 -- | Generate a name in the given case style taking into account the reserved
@@ -375,6 +376,7 @@ mkName reserved style s = notReserved name'
                          "" -> ""
                          c:cs -> toLower c:cs
         SnakeCase -> map toLower (intercalate "_" tokens)
+        OrigCase  -> s
     capitalize [] = []
     capitalize (c:cs) = toUpper c:cs