1{- 2 SkateBackendHeader: Backend for generating C header files 3 4 Part of Skate: a Schema specification languge 5 6 Copyright (c) 2017, ETH Zurich. 7 All rights reserved. 8 9 This file is distributed under the terms in the attached LICENSE file. 10 If you do not find this file, copies can be found by writing to: 11 ETH Zurich D-INFK, Universit\"atstr. 6, CH-8092 Zurich. Attn: Systems Group. 12-} 13 14module SkateBackendHeader where 15 16import Data.List 17import Data.Char 18 19import Text.ParserCombinators.Parsec.Pos 20 21import qualified CAbsSyntax as C 22import SkateParser 23import SkateSchema 24import SkateTypes 25import SkateBackendCommon 26import qualified SkateTypeTable as TT 27 28 29 30compile :: String -> String -> SchemaRecord -> String 31compile infile outfile s = unlines $ C.pp_unit $ skate_header_file s infile 32 33skate_header_file :: SchemaRecord -> String -> C.Unit 34skate_header_file sr infile = 35 let 36 Schema n d decls imps sp = (schema sr) 37 sym = "SKATE__" ++ (map toUpper n) ++ "_SCHEMA_H_" 38 in 39 C.IfNDef sym ([ C.Define sym [] "1"] ++ (skate_header_body sr infile)) [] 40 41{----------------------------------------------------------------------------- 42- The Header File 43------------------------------------------------------------------------------} 44 45skate_header_body :: SchemaRecord -> String -> [ C.Unit ] 46skate_header_body sr infile = 47 let 48 Schema n d decls imps sp = (schema sr) 49 in 50 [C.Blank, C.Blank] ++ 51 [(skate_c_preamble n d infile)] ++ 52 [C.Blank, C.Blank] ++ 53 skate_c_stdincludes 54 ++ 55 (skate_c_headerfiles imps) ++ 56 [C.Blank, C.Blank] ++ 57 [C.MultiComment [ 58 "====================================================================", 59 "Flags", 60 "====================================================================" 61 ], C.Blank] ++ 62 (skate_c_header_decls (flags sr) (types sr)) ++ 63 [C.Blank, C.Blank] ++ 64 [C.MultiComment [ 65 "====================================================================", 66 "Constants", 67 "====================================================================" 68 ], C.Blank] ++ 69 (skate_c_header_decls (constants sr) (types sr)) ++ 70 [C.Blank, C.Blank] ++ 71 [C.MultiComment [ 72 "====================================================================", 73 "Enumerations", 74 "====================================================================" 75 ], C.Blank] ++ 76 (skate_c_header_decls (enumerations sr) (types sr)) ++ 77 [C.Blank, C.Blank] ++ 78 [C.MultiComment [ 79 "====================================================================", 80 "Facts", 81 "====================================================================" 82 ], C.Blank] ++ 83 (skate_c_header_decls (facts sr) (types sr)) ++ 84 [C.Blank, C.Blank] 85 86 87{----------------------------------------------------------------------------- 88- Premable and Imports 89------------------------------------------------------------------------------} 90 91skate_c_stdincludes :: [ C.Unit ] 92skate_c_stdincludes = [ 93 C.Include C.Standard "stdint.h", 94 C.Include C.Standard "errno.h" ] 95 96-- Header files info 97skate_c_headerfiles :: [String] -> [ C.Unit ] 98skate_c_headerfiles [] = [C.MultiComment ["No Imports"]] 99skate_c_headerfiles imps = [C.MultiComment ["Imports"]] ++ 100 map (C.Include C.Standard) [ skate_c_includepath i | i <- imps ] 101 102{----------------------------------------------------------------------------- 103- Facts 104------------------------------------------------------------------------------} 105 106skate_c_header_one_attrib :: String -> FactAttrib -> [C.Param] 107skate_c_header_one_attrib p e@(FactAttrib i d t sp) = [ 108 C.ParamDoxyComment d, 109 C.Param (typeref_to_ctype t) i] 110 111 112skate_c_header_resolve_types :: TypeRef -> [TT.TTEntry] -> TypeRef 113skate_c_header_resolve_types tr@(TEnum i _) ttbl = TBuiltIn (TT.get_builtin_type i ttbl) 114skate_c_header_resolve_types tr@(TConstant i _) ttbl = TBuiltIn (TT.get_builtin_type i ttbl) 115skate_c_header_resolve_types tr@(TFlags i _) ttbl = TBuiltIn (TT.get_builtin_type i ttbl) 116skate_c_header_resolve_types tr _ = tr 117 118skate_c_header_extract_field :: String -> TypeRef -> String 119skate_c_header_extract_field s tr@(TFact i _) = fext ++ (("(&((_f)->" ++ s ++ "))")) 120 where 121 fext = make_format_name_extract_all (identifier_to_cname i) 122skate_c_header_extract_field s _ = ("(_f)->" ++ s) 123 124 125skate_c_header_fact :: String -> String -> [ FactAttrib ] -> SourcePos -> [TT.TTEntry] -> [C.Unit] 126skate_c_header_fact i d attrib sp ttbl = [ 127 (skate_c_type_comment "fact" d i sp), 128 C.StructDecl ttype $ concat (intersperse [C.ParamBlank] [skate_c_header_one_attrib i a | a <- attrib]), 129 C.TypeDef (C.Struct ttype) ttype, 130 C.Blank] ++ skate_c_fn_decls_facts i attrib 131 ++ [C.Blank, C.Blank, (skate_c_prolog_strings i types), C.Blank, 132 133 C.DoxyComment ("Extract fields from a struct"), 134 C.Define (make_format_name_extract_all tname) ["_f"] (concat (intersperse ", " extractstr)), 135 C.Blank,C.Blank 136 137 ] 138 where 139 tname = (identifier_to_cname i) 140 ttype = (make_type_name tname) 141 types = [skate_c_header_resolve_types t ttbl | e@(FactAttrib i d t sp) <- attrib ] 142 extractstr = [ (skate_c_header_extract_field i t) | e@(FactAttrib i d t sp) <- attrib ] 143 144 145{----------------------------------------------------------------------------- 146- Flags 147------------------------------------------------------------------------------} 148 149 150skate_c_header_one_flag :: String -> FlagDef -> C.TypeSpec -> C.Unit 151skate_c_header_one_flag p f@(FlagDef i d v _) t = C.UnitList [ 152 C.DoxyComment d, 153 C.Define (flagdef) [] (C.pp_expr $ C.Cast t $ 154 C.Binary C.LeftShift (C.NumConstant 1) (C.NumConstant v)) ] 155 where 156 flag = make_qualified_identifer p i 157 flagdef = map toUpper (identifier_to_cname flag) 158 159 160skate_c_header_flags :: String -> String -> Integer ->[ FlagDef ] -> SourcePos -> [C.Unit] 161skate_c_header_flags i d w defs sp = [ 162 (skate_c_type_comment "flags" d i sp), 163 C.TypeDef (C.TypeName ttype) tname, 164 C.Blank] 165 ++ [skate_c_header_one_flag i def (C.TypeName tname) | def <- defs] 166 ++ [C.Blank] 167 where 168 ttype = "uint" ++ show(w) ++ "_t" 169 tname = (make_type_name (identifier_to_cname i)) 170 171 172{----------------------------------------------------------------------------- 173- Constants 174------------------------------------------------------------------------------} 175 176 177skate_c_header_one_const :: String -> ConstantDef -> C.TypeSpec -> C.Unit 178skate_c_header_one_const p f@(ConstantDefInt i d v _) t = C.UnitList [ 179 C.DoxyComment d, 180 C.Define (constdef) [] (C.pp_expr $ C.Cast t $ C.NumConstant v) ] 181 where 182 c = make_qualified_identifer p i 183 constdef = map toUpper (identifier_to_cname c) 184skate_c_header_one_const p f@(ConstantDefStr i d v _) t = C.UnitList [ 185 C.DoxyComment d, 186 C.Define (constdef) [] (C.pp_expr $ C.Cast t $ C.StringConstant v) ] 187 where 188 c = make_qualified_identifer p i 189 constdef = map toUpper (identifier_to_cname c) 190 191skate_c_header_const :: String -> String -> TypeRef ->[ ConstantDef ] -> SourcePos -> [C.Unit] 192skate_c_header_const i d t@(TBuiltIn tref) defs sp = [ 193 (skate_c_type_comment "constants" d i sp), 194 C.TypeDef (typeref_to_ctype t) tname, 195 C.Blank] 196 ++ [skate_c_header_one_const i def (C.TypeName tname) | def <- defs] 197 ++ [C.Blank] 198 where 199 tname = (make_type_name (identifier_to_cname i)) 200 201 202{----------------------------------------------------------------------------- 203- Enumerations 204------------------------------------------------------------------------------} 205 206 207skate_c_header_one_enum :: String -> EnumDef -> C.EnumItem 208skate_c_header_one_enum p e@(EnumDef i d _) = C.EnumItem name d Nothing 209 where 210 enum = make_qualified_identifer p i 211 name = map toUpper (identifier_to_cname enum) 212 213 214skate_c_header_enum :: String -> String -> [ EnumDef ] -> SourcePos -> [C.Unit] 215skate_c_header_enum i d defs sp = [ 216 (skate_c_type_comment "enumeration" d i sp), 217 C.EnumDecl ttype [skate_c_header_one_enum i def | def <- defs], 218 C.Blank] 219 where 220 tname = (identifier_to_cname i) 221 ttype = (make_type_name tname) 222 223 224 225{----------------------------------------------------------------------------- 226- Generic Declarations 227------------------------------------------------------------------------------} 228 229skate_c_header_one_decl :: Declaration -> [TT.TTEntry] -> [ C.Unit ] 230skate_c_header_one_decl de@(Fact i d a sp) tt = skate_c_header_fact i d a sp tt 231skate_c_header_one_decl de@(Flags i d w f sp) _ = skate_c_header_flags i d w f sp 232skate_c_header_one_decl de@(Constants i d t f sp) _ = skate_c_header_const i d t f sp 233skate_c_header_one_decl de@(Enumeration i d f sp) _ = skate_c_header_enum i d f sp 234skate_c_header_one_decl _ _ = [] 235 236 237skate_c_header_decls :: [Declaration] -> [TT.TTEntry] -> [ C.Unit ] 238skate_c_header_decls decls ttbl = [C.UnitList $ skate_c_header_one_decl d ttbl | d <- decls] 239 240 241skate_c_prolog_strings :: String -> [TypeRef] -> C.Unit 242skate_c_prolog_strings i t = C.UnitList [ 243 C.DoxyComment ("Prolog fields format string for " ++ i), 244 C.Define (make_format_name_fields_pr cname) [] (wr_fmt), 245 C.Blank, 246 C.DoxyComment ("Prolog format string for " ++ i), 247 C.Define (make_format_name_pr cname) [] (prolog ++ (make_format_name_fields_pr cname) ++ " \").\""), 248 C.Blank, 249 250 C.DoxyComment ("Prolog fields format string for " ++ i), 251 C.Define (make_format_name_fields_rd cname) [] (rd_fmt), 252 C.Blank, 253 C.DoxyComment ("Prolog format string for " ++ i), 254 C.Define (make_format_name_rd cname) [] (prolog ++ (make_format_name_fields_rd cname) ++ " \").\""), 255 C.Blank] 256 where 257 cname = (identifier_to_cname i) 258 wr_fmt = "\"%\" " ++ concat (intersperse " \", %\" " [fmt_wr a | a <- t]) 259 rd_fmt = "\"%\" " ++ concat (intersperse " \", %\" " [fmt_rd a | a <- t]) 260 prolog = "\"" ++ (identifier_to_prolog i) ++ "(\" " 261 262fmt_wr :: TypeRef -> String 263fmt_wr (TFact t _ ) = (make_format_name_fields_pr (identifier_to_cname t)) 264fmt_wr (TBuiltIn t) = builtin_fmt_wr t 265 266fmt_rd :: TypeRef -> String 267fmt_rd (TFact t _ ) = (make_format_name_fields_rd (identifier_to_cname t)) 268fmt_rd (TBuiltIn t) = builtin_fmt_rd t 269