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