1{- 
2   CAbsSyntax: combinators for generating C99 syntax
3   
4  Part of Mackerel: a strawman device definition DSL for Barrelfish
5   
6  Copyright (c) 2009, 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, Haldeneggsteig 4, CH-8092 Zurich. Attn: Systems Group.
12-}  
13
14module CAbsSyntax where
15
16import Text.Printf
17import Data.Char
18import Data.List
19
20--
21-- Just enough syntax to generate files for Mackerel, etc.
22--
23
24
25tabstop :: String
26tabstop = "    " -- How much to indent
27
28indent_stmts :: [ Stmt ] -> [ String ] 
29indent_stmts sl = [ tabstop ++ l | l <- concat [ pp_stmt s | s <- sl ] ]
30
31-- 
32-- We start with expressions
33--
34data Expr = NumConstant Integer         -- 123
35          | HexConstant Integer         -- 0xFF
36          | StringConstant String       -- "Hello!"
37          | StringCat [ StrElem ]       -- "Value is " PRIu64 " bytes"
38          | CharConstant Char           -- 'c'
39          | Variable String             -- index
40          | AddressOf Expr              -- &foo
41          | DerefPtr Expr               -- *foo
42          | DerefField Expr String      -- (foo)->string
43          | Assignment Expr Expr        -- foo = bar
44          | Unary UnOp Expr             -- -(foo)
45          | Binary BinOp Expr Expr      -- (a) + (b)
46          | Ternary Expr Expr Expr      -- p ? a : b
47          | FieldOf Expr String         -- p.field
48          | SubscriptOf Expr Expr       -- p[q]
49          | Call String [ Expr ]        -- fn(a,b,c)
50          | CallInd Expr [ Expr ]       -- (fn)(a,b,c)
51          | SizeOf Expr                 -- sizeof(expr)
52          | SizeOfT TypeSpec            -- sizeof(int)
53          | Cast TypeSpec Expr          -- (foo_t)(expr)
54          | PostInc Expr                -- (foo)++
55          | PostDec Expr                -- (foo)++
56          | Parens Expr                 -- (e)
57            deriving (Show, Eq)
58
59pp_expr :: Expr -> String
60pp_expr (NumConstant i) = printf "%d" i
61pp_expr (HexConstant i) = printf "0x%x" i
62pp_expr (StringConstant s) = "\"" ++ (concat $ map (\x -> showLitChar x "") s) ++ "\""
63pp_expr (StringCat l) = concat $ intersperse " " $ map pp_strelem l
64pp_expr (CharConstant c) = "'" ++ showLitChar c "'"
65pp_expr (Variable s) = s
66pp_expr (AddressOf e) = "&" ++ (pp_par_expr e)
67pp_expr (DerefPtr e) = "*" ++ (pp_par_expr e)
68pp_expr (DerefField e s) = (pp_par_expr e) ++ "->" ++ s
69pp_expr (Assignment e1 e2) = (pp_expr e1) ++ " = " ++ (pp_par_expr e2)
70pp_expr (Unary o e) = (pp_unop o) ++ (pp_par_expr e)
71pp_expr (Binary o e1 e2) 
72    = (pp_par_expr e1) ++" " ++ (pp_binop o) ++ " "++(pp_par_expr e2)
73pp_expr (Ternary e1 e2 e3) 
74    = (pp_par_expr e1) ++ " ? " ++ (pp_par_expr e2) ++ " : " ++ (pp_par_expr e3)
75pp_expr (FieldOf e s) = (pp_par_expr e) ++ "." ++ s
76pp_expr (SubscriptOf e1 e2) = (pp_par_expr e1) ++ "[" ++ (pp_expr e2) ++ "]"
77pp_expr (Call f al) 
78    = f ++ "(" ++ (concat $ intersperse ", " [ pp_expr e | e <- al ]) ++ ")"
79pp_expr (CallInd f al) 
80    = "(" ++ (pp_expr f) ++ ")(" ++ (concat $ intersperse ", " [ pp_expr e | e <- al ]) ++ ")"
81pp_expr (SizeOf e) = "sizeof(" ++ (pp_expr e) ++ ")"
82pp_expr (SizeOfT t) = "sizeof(" ++ (pp_typespec t "") ++ ")"
83pp_expr (Cast s e) = "(" ++ (pp_typespec s "") ++ ")(" ++ (pp_expr e) ++ ")"
84pp_expr (PostInc e) = (pp_par_expr e) ++ "++"
85pp_expr (PostDec e) = (pp_par_expr e) ++ "--"
86pp_expr (Parens e) = "(" ++ (pp_expr e) ++ ")"
87
88pp_par_expr :: Expr -> String
89pp_par_expr (Variable s) = s
90pp_par_expr e@(NumConstant _) = pp_expr e
91pp_par_expr e@(HexConstant _) = pp_expr e
92pp_par_expr c@(Call _ _) = pp_expr c
93pp_par_expr e = "(" ++ (pp_expr e) ++ ")"
94
95data StrElem = QStr String
96             | NStr String
97               deriving (Show, Eq)
98
99pp_strelem :: StrElem -> String
100pp_strelem (QStr s) = pp_expr (StringConstant s)
101pp_strelem (NStr s) = s
102
103--
104-- Binary operators
105--
106data BinOp = Plus 
107           | Minus 
108           | Times 
109           | Divide 
110           | Modulo 
111           | Equals
112           | NotEquals
113           | GreaterThan
114           | LessThan 
115           | GreaterThanEq
116           | LessThanEq
117           | BitwiseAnd
118           | BitwiseOr
119           | BitwiseXor
120           | And
121           | Or 
122           | LeftShift
123           | RightShift
124             deriving (Show, Eq)
125
126pp_binop :: BinOp -> String
127pp_binop Plus = "+"
128pp_binop Minus = "-"
129pp_binop Times = "*"
130pp_binop Divide = "/"
131pp_binop Modulo = "%"
132pp_binop Equals= "=="
133pp_binop NotEquals= "!="
134pp_binop GreaterThan= ">"
135pp_binop LessThan = "<"
136pp_binop GreaterThanEq= ">="
137pp_binop LessThanEq= "<="
138pp_binop BitwiseAnd= "&"
139pp_binop BitwiseOr= "|"
140pp_binop BitwiseXor= "^"
141pp_binop And= "&&"
142pp_binop Or = "||"
143pp_binop LeftShift= "<<"
144pp_binop RightShift= ">>"
145
146--
147-- Unary operators
148--
149data UnOp = Not | Negate | BitwiseNot 
150             deriving (Show, Eq)
151
152pp_unop :: UnOp -> String
153pp_unop Not = "!"
154pp_unop Negate = "-"
155pp_unop BitwiseNot = "~"
156
157--
158-- Parameters to function definitions
159--
160data Param = Param TypeSpec String
161             deriving (Show, Eq)
162
163pp_param :: Param -> String
164pp_param (Param t s) = (pp_typespec t s)
165
166--
167-- Members of an enumeration definition
168--
169data EnumItem = EnumItem String (Maybe Expr)
170             deriving (Show, Eq)
171
172pp_enumitem :: EnumItem -> String
173pp_enumitem (EnumItem s (Just e)) = s ++ " = " ++( pp_expr e)
174pp_enumitem (EnumItem s Nothing) = s
175
176
177--
178-- Include directives
179--
180data IncludePath = Standard | Local
181                   deriving (Show, Eq)
182pp_include :: IncludePath -> String -> String
183pp_include Standard f = printf "#include <%s>" f
184pp_include Local f = printf "#include \"%s\"" f
185
186--
187-- Scope of a function or variable
188--
189data ScopeSpec = Extern | Static | NoScope
190                 deriving (Show, Eq)
191
192pp_scopespec :: ScopeSpec -> String
193pp_scopespec Extern = "extern "
194pp_scopespec Static = "static "
195pp_scopespec NoScope = ""
196
197--
198-- Constancy
199--
200data ConstSpec = Const | NonConst
201                 deriving (Show, Eq)
202pp_constspec :: ConstSpec -> String
203pp_constspec Const = "const "
204pp_constspec NonConst = ""
205
206--
207-- A Unit is a chunk of source file, i.e. top-level syntactic constructs. 
208--
209-- Note that we treat static inlines as their own construct.  It's easier. 
210--
211data Unit = Comment String
212          | MultiComment [ String ]
213          | TypeDef TypeSpec String
214          | FunctionDef ScopeSpec TypeSpec String [ Param ] [ Stmt ]
215          | StaticInline TypeSpec String [ Param ] [ Stmt ]
216          | StructDecl String [ Param ]
217          | UnionDecl String [ Param ]
218          | EnumDecl String [ EnumItem ]
219          | FunctionDecl TypeSpec String [ Param ]
220          | GVarDecl ScopeSpec ConstSpec TypeSpec String (Maybe Expr)
221          | Define String [ String ] String
222          | Undef String
223          | IfDef String [ Unit ] [ Unit ]
224          | IfNDef String [ Unit ] [ Unit ]
225          | HashIf String [ Unit ] [ Unit ]
226          | NoOp
227          | Blank
228          | Include IncludePath String
229             deriving (Show, Eq)
230
231pp_unit :: Unit -> [ String ] 
232pp_unit (Comment s) = [ "// " ++ s ]
233pp_unit (MultiComment sl) = ["/*"] ++ [ " * " ++ s | s <- sl ] ++ [ " */"] 
234pp_unit (TypeDef ts s) = [ "typedef " ++ (pp_typespec ts s) ++ ";" ]
235pp_unit (FunctionDef sc ts n pl body) =
236    [ (pp_scopespec sc) ++ " " ++ (pp_fnhead ts n pl) ] ++ (pp_fnbody body)
237pp_unit (StaticInline ts n pl body) = 
238    [ hd ++ " __attribute__ ((always_inline));",
239      hd ] ++ (pp_fnbody body)
240    where 
241      hd = "static inline " ++ (pp_fnhead ts n pl)
242pp_unit (StructDecl s pl) = 
243    [ printf "struct %s {" s ] ++ [ tabstop ++ (pp_param p) ++ ";" 
244                                        | p <- pl ] ++ ["};"]
245pp_unit (UnionDecl s pl) = 
246    [ printf "union %s {" s ] ++ [ tabstop ++ (pp_param p) | p <- pl ] ++ ["}"]
247pp_unit (EnumDecl s el) = 
248    [ printf "enum %s {" s ] 
249    ++ 
250    (comma_sep_lines [ tabstop ++ (pp_enumitem e) | e <- el ])
251    ++ 
252    ["};"]
253pp_unit (FunctionDecl ts n pl) =
254    [ (pp_fnhead ts n pl) ++ ";" ]
255pp_unit (GVarDecl sc cs ts s Nothing) = 
256    [ printf "%s%s%s;" (pp_scopespec sc) (pp_constspec cs) (pp_typespec ts s)]
257pp_unit (GVarDecl sc cs ts s (Just e)) = 
258    [ printf "%s%s%s = %s;" 
259                 (pp_scopespec sc) 
260                 (pp_constspec cs) 
261                 (pp_typespec ts s) 
262                 (pp_expr e) ]
263pp_unit (Define n [] v) = [ printf "#define %s %s"  n v ]
264pp_unit (Define n al v) 
265    = [ printf "#define %s(%s) %s" n (concat $ intersperse "," al) v ]
266pp_unit (Undef s) = [ "#undef " ++ s ]
267pp_unit (IfDef s l r) = pp_cppcond "ifdef" s l r 
268pp_unit (IfNDef s l r) = pp_cppcond "ifndef" s l r 
269pp_unit (HashIf s l r) = pp_cppcond "if" s l r 
270pp_unit NoOp = []
271pp_unit Blank = [""]
272pp_unit (Include s p) = [ pp_include s p ]
273
274comma_sep_lines :: [String] -> [String] 
275comma_sep_lines [] = []
276comma_sep_lines [s] = [s]
277comma_sep_lines (s:sl) = (s ++ ","):(comma_sep_lines sl)
278
279pp_cppcond :: String -> String -> [ Unit ] -> [ Unit ] -> [ String ]
280pp_cppcond t e l r = 
281    [ "#" ++ t ++ " " ++ e ] 
282    ++ 
283    (concat [ pp_unit u | u <- l ])
284    ++ 
285    (if r == [] then [] else "#else":concat [ pp_unit u | u <- r ])
286    ++ 
287    [ "#endif // " ++ e ]
288    
289
290pp_fnbody :: [ Stmt ] -> [ String ] 
291pp_fnbody body = [ "{" ] ++ (indent_stmts body) ++ [ "}", ""]
292
293pp_fnhead :: TypeSpec -> String -> [ Param ] -> String
294pp_fnhead ts n pl = 
295    (pp_typespec ts n) ++ "(" ++ parlist ++ ")" 
296    where 
297      parlist = case pl of
298        [] -> "void"
299        xs -> concat $ intersperse ", " [ pp_param p | p <- xs ]
300
301-- 
302-- Branches of a case statement: note that they fall through
303--
304data Case = Case Expr [ Stmt ]
305            deriving (Show, Eq)
306                   
307pp_case :: Case -> [ String ]
308pp_case (Case e s) 
309    = [ "case " ++ (pp_expr e) ++ ":" ] ++ (indent_stmts s)
310
311--
312-- Statements.
313--
314data Stmt = Return Expr 
315          | ReturnVoid
316          | Block [ Stmt ]
317          | StmtList [ Stmt ]
318          | Ex Expr
319          | If Expr [ Stmt ] [ Stmt ]
320          | DoWhile  Expr [ Stmt ]
321          | While Expr [ Stmt ] 
322          | For Expr Expr Expr [ Stmt ]
323          | Switch Expr [ Case ] [ Stmt ]  -- last list is default clause
324          | Break
325          | Continue
326          | Label String
327          | Goto String
328          | VarDecl ScopeSpec ConstSpec TypeSpec String (Maybe Expr)
329          | SComment String
330            deriving (Show, Eq)
331
332pp_stmt :: Stmt -> [ String ]
333pp_stmt (Return e) = [ "return(" ++ (pp_expr e) ++ ");" ]
334pp_stmt ReturnVoid = [ "return;" ]
335pp_stmt (Block sl) = [ "{" ] ++ (indent_stmts sl) ++ ["}"]
336pp_stmt (StmtList sl) = concat $ map pp_stmt sl
337pp_stmt (Ex e) = [ (pp_expr e) ++ ";" ]
338pp_stmt (If e sl []) = 
339    [ "if (" ++ (pp_expr e) ++ ") {" ] ++ (indent_stmts sl) ++ ["}"]
340pp_stmt (If e sl1 sl2) 
341    = [ "if (" ++ (pp_expr e) ++ ") {" ] 
342      ++ (indent_stmts sl1) 
343      ++ ["} else {"] 
344      ++ (indent_stmts sl2) ++ [ "}"]
345pp_stmt (DoWhile e sl) 
346    = [ "do {" ] ++ (indent_stmts sl) ++ [ "} while (" ++ (pp_expr e) ++ ");" ]
347pp_stmt (While e sl) 
348    = [ "while (" ++ (pp_expr e) ++ ") {" ] 
349      ++ (indent_stmts sl) ++ ["}"]
350pp_stmt (For e1 e2 e3 sl) 
351    = ( [ "for( " ++ (pp_expr e1) ++ "; " 
352          ++  (pp_expr e2) ++ "; " 
353          ++ (pp_expr e3) ++ ") {" 
354        ]
355        ++ (indent_stmts sl) 
356        ++ ["}"]
357      )
358pp_stmt (Switch e cl sl) 
359    = ( [ "switch (" ++ (pp_expr e) ++ ") {" ] 
360        ++ concat [ pp_case c | c <- cl ] 
361        ++ [ "default:" ] 
362        ++ (indent_stmts sl)
363        ++ [ "}" ]
364      )
365pp_stmt Break = [ "break;" ]
366pp_stmt Continue = [ "continue;" ]
367pp_stmt (Label s) = [ s ++ ":" ]
368pp_stmt (Goto s) = [ "goto " ++ s ++ ";" ]
369pp_stmt (VarDecl sc cs ts s Nothing) = 
370    [ printf "%s%s%s;" (pp_scopespec sc) (pp_constspec cs) (pp_typespec ts s)]
371pp_stmt (VarDecl sc cs ts s (Just e)) = 
372    [ printf "%s%s%s = %s;" 
373                 (pp_scopespec sc) 
374                 (pp_constspec cs) 
375                 (pp_typespec ts s) 
376                 (pp_expr e) ]
377pp_stmt (SComment s) = [ "// " ++ s ]
378
379--
380-- Type specifiers
381--
382data TypeSpec = Void
383              | Struct String
384              | Union String
385              | Enum String 
386              | Ptr TypeSpec
387              | Array Integer TypeSpec
388              | TypeName String
389              | Function ScopeSpec TypeSpec [ Param ]
390                deriving (Show, Eq)
391
392pp_typespec :: TypeSpec -> String -> String
393pp_typespec Void n = "void " ++ n
394pp_typespec (Struct s) n = printf "struct %s %s" s n
395pp_typespec (Union s) n = printf "union %s %s" s n
396pp_typespec (Enum s) n = printf "enum %s %s" s n
397pp_typespec (Ptr t) n = pp_typespec t ("*" ++n)
398pp_typespec (Array 0 t) n = pp_typespec t (n++"[]")
399pp_typespec (Array i t) n = pp_typespec t $ printf "%s[%d]" n i
400pp_typespec (TypeName s) n = printf "%s %s" s n
401pp_typespec (Function sc ts pl) n 
402    = (pp_scopespec sc) ++ " " ++ (pp_fnhead ts n pl)
403