Add code generation for functions to add facts to the SKB
authorReto Achermann <reto.achermann@inf.ethz.ch>
Sat, 27 May 2017 10:46:32 +0000 (12:46 +0200)
committerReto Achermann <reto.achermann@inf.ethz.ch>
Sat, 27 May 2017 10:46:32 +0000 (12:46 +0200)
Signed-off-by: Reto Achermann <reto.achermann@inf.ethz.ch>

tools/skate/CAbsSyntax.hs
tools/skate/SkateBackendCode.hs
tools/skate/SkateBackendCommon.hs
tools/skate/SkateBackendHeader.hs

index 665cbd8..58270fc 100644 (file)
@@ -56,6 +56,7 @@ data Expr = NumConstant Integer         -- 123
           | PreInc Expr                 -- ++(foo)
           | PreDec Expr                 -- --(foo)
           | Parens Expr                 -- (e)
+          | DefineExpr String               -- DEF
           | StructConstant String [(String, Expr)] -- (struct foo){ .field = val, }
           | ArrayConstant [Expr]        -- { val, }
             deriving (Show, Eq)
@@ -93,6 +94,7 @@ pp_expr (Parens e) = "(" ++ (pp_expr e) ++ ")"
 pp_expr (StructConstant n il) = "(struct " ++ n ++ "){ " ++ inits ++ " }"
   where inits = concat $ intersperse ", " [ " ." ++ f ++ " = " ++ pp_expr v | (f,v) <- il ]
 pp_expr (ArrayConstant vl) = "{ " ++ (concat $ intersperse ", " (map pp_expr vl)) ++ " }"
+pp_expr (DefineExpr str) = str
 
 pp_par_expr :: Expr -> String
 pp_par_expr (Variable s) = s
index cd02563..845939a 100644 (file)
@@ -24,6 +24,7 @@ import SkateParser
 import SkateSchema
 import SkateTypes
 import SkateBackendCommon
+import qualified SkateTypeTable as TT
 
 
 
@@ -38,8 +39,100 @@ skate_c_body sr infile =
     C.UnitList [
         (skate_c_preamble n d infile),
         C.Blank, C.Blank,
-        skate_c_includes n
-    ]
+        skate_c_includes n,
+        C.Blank, C.Blank,
+        C.MultiComment [
+            "====================================================================",
+            "Flags",
+            "===================================================================="
+        ], C.Blank,
+        C.UnitList $ (skate_c_code_defs (flags sr) (types sr)),
+        C.Blank, C.Blank,
+        C.MultiComment [
+            "====================================================================",
+            "Constants",
+            "===================================================================="
+        ], C.Blank,
+        C.UnitList $ (skate_c_code_defs (constants sr) (types sr)),
+        C.Blank, C.Blank,
+        C.MultiComment [
+            "====================================================================",
+            "Enumerations",
+            "===================================================================="
+        ], C.Blank,
+        C.UnitList $ (skate_c_code_defs (enumerations sr) (types sr)),
+        C.Blank, C.Blank,
+        C.MultiComment [
+            "====================================================================",
+            "Facts",
+            "===================================================================="
+        ], C.Blank,
+        C.UnitList $ (skate_c_code_defs (facts sr) (types sr)),
+        C.Blank, C.Blank]
+
 
 skate_c_includes :: String -> C.Unit
-skate_c_includes sr = C.Include C.Standard (skate_c_includepath sr)
+skate_c_includes sr = C.UnitList [
+    C.Include C.Standard (skate_c_includepath sr),
+    C.Include C.Standard "skb/skb.h"]
+
+
+{------------------------------------------------------------------------------
+Function Add
+------------------------------------------------------------------------------}
+
+skate_c_vardecl :: C.TypeSpec -> String -> Maybe C.Expr -> C.Stmt
+skate_c_vardecl t s e = C.VarDecl C.NoScope C.NonConst  t s e
+
+skate_c_vardecl_err :: C.Stmt
+skate_c_vardecl_err = skate_c_vardecl (C.TypeName "errval") "err" Nothing
+
+skate_c_errvar :: C.Expr
+skate_c_errvar = C.Variable "err"
+
+skate_c_code_add :: Declaration -> [TT.TTEntry] -> [C.Unit]
+skate_c_code_add def@(Fact i d attrib sp) ttbl =
+    skate_c_fn_defs_facts i attrib [
+        skate_c_vardecl_err,
+        C.SBlank,
+        C.SComment "TODO: Add some checks.",
+        C.SBlank,
+        C.Ex $ C.Assignment skate_c_errvar (C.Call "skb_add_fact" [
+            C.DefineExpr fmt,
+            C.Call (make_format_name_extract_all cname) [C.Variable "fact"]
+            ]
+            ),
+        C.If (C.Call "err_is_fail" [skate_c_errvar]) [
+            C.SComment "TODO: Add some good error message",
+            C.Return skate_c_errvar]
+            [],
+        C.SBlank,
+        C.Return skate_c_errvar
+        ]
+    where
+        cname = identifier_to_cname i
+        fmt = make_format_name_fields_pr cname
+
+
+
+{-----------------------------------------------------------------------------
+- Facts
+------------------------------------------------------------------------------}
+
+skate_c_code_fact :: Declaration -> [TT.TTEntry] -> [C.Unit]
+skate_c_code_fact def@(Fact i d attrib sp) ttbl = [
+    (skate_c_type_comment "fact" d i sp),
+    C.Blank] ++
+    (skate_c_code_add def ttbl)
+
+
+skate_c_header_one_def :: Declaration -> [TT.TTEntry] -> [ C.Unit ]
+skate_c_header_one_def de@(Fact i d a sp) tt = skate_c_code_fact de tt
+skate_c_header_one_def de@(Flags i d w f sp) _ = [] --skate_c_header_flags i d w f sp
+skate_c_header_one_def de@(Constants i d t f sp) _ = [] --skate_c_header_const i d t f sp
+skate_c_header_one_def de@(Enumeration i d f sp) _ = [] --skate_c_header_enum i d f sp
+skate_c_header_one_def _  _ = []
+
+
+skate_c_code_defs :: [Declaration] -> [TT.TTEntry] -> [ C.Unit ]
+skate_c_code_defs decls ttbl = [C.UnitList $ skate_c_header_one_def d ttbl | d <- decls]
index 35d472d..9f1d86a 100644 (file)
@@ -14,7 +14,7 @@
 
 module SkateBackendCommon where
 
-
+import Text.ParserCombinators.Parsec.Pos
 import SkateParser
 import SkateTypes
 import qualified CAbsSyntax as C
@@ -69,6 +69,16 @@ make_format_name_pr s =  map toUpper (s ++ "_pri")
 make_format_name_rd :: String -> String
 make_format_name_rd s =  map toUpper (s ++ "_scn")
 
+make_format_name_extract_all :: String -> String
+make_format_name_extract_all s =  map toUpper (s ++ "_extract_all")
+
+make_format_name_fields_pr :: String -> String
+make_format_name_fields_pr s =  map toUpper (s ++ "_fields_pri")
+
+make_format_name_fields_rd :: String -> String
+make_format_name_fields_rd s =  map toUpper (s ++ "_fields_scn")
+
+
 {--}
 identifier_to_prolog :: [Char] -> [Char]
 identifier_to_prolog [] = []
@@ -131,6 +141,14 @@ skate_c_fn_def rt n c p st = C.UnitList [
 
 
 
+
+skate_c_type_comment :: String -> String -> String -> SourcePos -> C.Unit
+skate_c_type_comment t desc defined sp = C.MultiDoxy [
+    "@brief " ++ desc,
+    "",
+    "Type: " ++ t ++ " " ++ defined,
+    "Defined: " ++ (show sp)]
+
 {-----------------------------------------------------------------------------
 - schema.namespace.decl.describe()
 ------------------------------------------------------------------------------}
@@ -148,7 +166,7 @@ skate_c_fn_decl_describe fn = skate_c_fn_decl skate_c_void_t fn_name doxy []
 skate_c_fn_def_describe :: String -> [ C.Stmt ] -> C.Unit
 skate_c_fn_def_describe fn = C.FunctionDef C.NoScope skate_c_errval_t fn_name params
     where
-        fn_name = (skate_c_fn_name_describe fn)
+        fn_name = identifier_to_cname ((skate_c_fn_name_describe fn))
         params = []
 
 
@@ -175,17 +193,18 @@ skate_c_fn_name_add :: String -> String
 skate_c_fn_name_add fn = (make_qualified_identifer fn "add")
 
 skate_c_fn_decl_add :: String -> ([String], [C.Param])-> C.Unit
-skate_c_fn_decl_add fn (d, p) = skate_c_fn_decl skate_c_void_t fn_name doxy p
+skate_c_fn_decl_add fn (d, p) = skate_c_fn_decl skate_c_errval_t fn_name doxy p
     where
         fn_name = (skate_c_fn_name_add fn)
         doxy = ["@brief Adds the " ++ fn, ""] ++ d
 
 
 
-skate_c_fn_def_add :: String -> [C.Param] -> [ C.Stmt ] -> C.Unit
-skate_c_fn_def_add fn p s = C.FunctionDef C.NoScope skate_c_errval_t fn_name p s
+skate_c_fn_def_add :: String -> ([String], [C.Param]) -> [ C.Stmt ] -> C.Unit
+skate_c_fn_def_add fn (d, p) s = skate_c_fn_def skate_c_errval_t fn_name  doxy p s
     where
         fn_name = (skate_c_fn_name_add fn)
+        doxy = ["@brief Adds the " ++ fn, ""] ++ d
 
 {-----------------------------------------------------------------------------
 - schema.namespace.decl.delete()
@@ -206,14 +225,10 @@ skate_c_fn_name_list fn = (make_qualified_identifer fn "list")
 - Function signatures
 ------------------------------------------------------------------------------}
 
-skate_c_fn_one_param :: FactAttrib -> C.Param
-skate_c_fn_one_param a@(FactAttrib i d t _) = C.Param (typeref_to_ctype t) i
-
-
-skate_c_fn_params_fact :: [FactAttrib] -> ([String], [C.Param])
-skate_c_fn_params_fact attribs = (
-    ["@param " ++ i ++ " " ++ d | FactAttrib i d _ _ <- attribs],
-    [skate_c_fn_one_param a | a <- attribs])
+skate_c_fn_params_fact :: String -> ([String], [C.Param])
+skate_c_fn_params_fact fact = (
+    ["@param fact  Pointer to a struct " ++ fact],
+    [C.Param  (C.Ptr $ C.Struct ( identifier_to_cname fact)) "fact" ])
 
 skate_c_fn_params :: C.TypeSpec -> String -> [C.Param]
 skate_c_fn_params t var = [C.Param t var]
@@ -225,7 +240,14 @@ skate_c_fn_decls_facts fn attribs = [
     skate_c_fn_decl_describe fn,
     skate_c_fn_decl_add fn p]
         where
-            p = skate_c_fn_params_fact attribs
+            p = skate_c_fn_params_fact fn
+
+skate_c_fn_defs_facts :: String -> [FactAttrib] -> [C.Stmt] -> [C.Unit]
+skate_c_fn_defs_facts fn attribs stmt = [
+    skate_c_fn_def_describe fn stmt,
+    skate_c_fn_def_add fn p stmt]
+        where
+            p = skate_c_fn_params_fact fn
 
 
 
index 400e388..6e9e451 100644 (file)
@@ -113,6 +113,12 @@ skate_c_header_resolve_types tr@(TConstant i _) ttbl = TBuiltIn (TT.get_builtin_
 skate_c_header_resolve_types tr@(TFlags i _) ttbl = TBuiltIn (TT.get_builtin_type i ttbl)
 skate_c_header_resolve_types tr _ = tr
 
+skate_c_header_extract_field :: String -> TypeRef -> String
+skate_c_header_extract_field s tr@(TFact i _) = fext ++ (("(&((_f)->" ++ s ++ "))"))
+    where
+        fext = make_format_name_extract_all (identifier_to_cname i)
+skate_c_header_extract_field s _ = ("(_f)->" ++ s)
+
 
 skate_c_header_fact :: String -> String -> [ FactAttrib ] -> SourcePos -> [TT.TTEntry] -> [C.Unit]
 skate_c_header_fact i d attrib sp ttbl = [
@@ -120,12 +126,18 @@ skate_c_header_fact i d attrib sp ttbl = [
     C.StructDecl ttype $ concat (intersperse [C.ParamBlank] [skate_c_header_one_attrib i a | a <- attrib]),
     C.TypeDef (C.Struct ttype) ttype,
     C.Blank] ++ skate_c_fn_decls_facts i attrib
-    ++ [C.Blank, C.Blank, (skate_c_prolog_strings i types), C.Blank, C.Blank]
+    ++ [C.Blank, C.Blank, (skate_c_prolog_strings i types), C.Blank,
+
+    C.DoxyComment ("Extract fields from a struct"),
+    C.Define (make_format_name_extract_all tname) ["_f"] (concat (intersperse ", " extractstr)),
+    C.Blank,C.Blank
+
+    ]
     where
         tname = (identifier_to_cname i)
         ttype = (make_type_name tname)
         types = [skate_c_header_resolve_types t ttbl | e@(FactAttrib i d t sp) <- attrib ]
-
+        extractstr = [ (skate_c_header_extract_field i t) | e@(FactAttrib i d t sp) <- attrib ]
 
 
 {-----------------------------------------------------------------------------
@@ -223,20 +235,21 @@ skate_c_header_one_decl _  _ = []
 skate_c_header_decls :: [Declaration] -> [TT.TTEntry] -> [ C.Unit ]
 skate_c_header_decls decls ttbl = [C.UnitList $ skate_c_header_one_decl d ttbl | d <- decls]
 
-skate_c_type_comment :: String -> String -> String -> SourcePos -> C.Unit
-skate_c_type_comment t desc defined sp = C.MultiDoxy [
-    "@brief " ++ desc,
-    "",
-    "Type: " ++ t ++ " " ++ defined,
-    "Defined: " ++ (show sp)]
 
 skate_c_prolog_strings :: String -> [TypeRef] -> C.Unit
 skate_c_prolog_strings i t = C.UnitList [
+    C.DoxyComment ("Prolog fields format string for " ++ i),
+    C.Define (make_format_name_fields_pr cname) []  (wr_fmt),
+    C.Blank,
     C.DoxyComment ("Prolog format string for " ++ i),
-    C.Define (make_format_name_pr cname) []  (prolog ++  wr_fmt ++ "\").\""),
+    C.Define (make_format_name_pr cname) []  (prolog ++  (make_format_name_fields_pr cname) ++ " \").\""),
+    C.Blank,
+
+    C.DoxyComment ("Prolog fields format string for " ++ i),
+    C.Define (make_format_name_fields_rd cname) [] (rd_fmt),
     C.Blank,
     C.DoxyComment ("Prolog format string for " ++ i),
-    C.Define (make_format_name_rd cname) [] (prolog ++  rd_fmt ++ "\").\""),
+    C.Define (make_format_name_rd cname) [] (prolog ++  (make_format_name_fields_rd cname) ++ " \").\""),
     C.Blank]
     where
         cname = (identifier_to_cname i)
@@ -245,9 +258,9 @@ skate_c_prolog_strings i t = C.UnitList [
         prolog = "\"" ++ (identifier_to_prolog i) ++ "(\" "
 
 fmt_wr :: TypeRef -> String
-fmt_wr (TFact t _ ) = (make_format_name_pr (identifier_to_cname t))
+fmt_wr (TFact t _ ) = (make_format_name_fields_pr (identifier_to_cname t))
 fmt_wr (TBuiltIn t) = builtin_fmt_wr t
 
 fmt_rd :: TypeRef -> String
-fmt_rd (TFact t _ ) = (make_format_name_rd (identifier_to_cname t))
+fmt_rd (TFact t _ ) = (make_format_name_fields_rd (identifier_to_cname t))
 fmt_rd (TBuiltIn t) = builtin_fmt_rd t