1{- 
2   CSyntax: functions for rendering C syntactic structures.
3
4  Part of Mackerel: a strawman device definition DSL for Barrelfish
5
6  Copyright (c) 2007, 2008, 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 CSyntax where
15
16import Data.List
17import Text.Printf
18
19infixr 9 >:
20(>:) :: String -> [String] -> [String]
21s >: [] = [s]
22s >: (x:xs) = (s ++ " " ++ x) : xs
23
24infixr 9 <:
25(<:) :: [String] -> String -> [String]
26[] <: s = [s]
27(h:t) <: s = let (x:xs) = reverse (h:t) in
28             reverse ((x ++ " " ++ s):xs )
29
30header_file :: String -> String -> String
31header_file name body =
32    let sym = "__" ++ name ++ "_H"
33    in unlines [ "#ifndef " ++ sym,
34                 "#define " ++ sym,
35                 "",
36                 body,
37                 "",
38                 "#endif // " ++ sym
39                 ]
40
41undef :: String -> String
42undef n = "#undef " ++ n
43
44include :: String -> String
45include f = "#include <" ++ f ++ ".h>"
46
47include_local :: String -> String
48include_local f = "#include \"" ++ f ++ ".h\""
49
50block :: [String] -> [String]
51block lines =
52    ["{"] ++ (indent lines) ++ ["}"]
53
54typedef :: String -> String -> String
55typedef name typestr = "typedef " ++ typestr ++ " " ++ name ++ ";"
56
57constint :: String -> Integer -> String
58constint name val = printf "static const int %s = 0x%0x;" name val
59
60struct :: String -> [ String ] -> [ String ]
61struct name fields =  structunion "struct" name fields
62
63struct_field n v = printf "%s\t%s;" n v
64
65union :: String -> [ String ] -> [ String ]
66union name fields =  structunion "union" name fields
67
68union_field n v = struct_field n v
69
70structunion :: String -> String -> [ String ] -> [ String ]
71structunion su name fields =
72    (su ++ " " ++ name) >: (block fields)
73
74bitfields name fields =
75    ("struct " ++ name) >: (block fields) <: "__attribute__ ((packed))"
76
77bitfield n w t = printf "%s\t%s\t:%d;" t n w
78
79
80enum :: String -> [ (String, String) ] -> String
81enum name vals =
82    let tname = name -- ++ "_t"
83    in
84      unlines ( ((printf "typedef enum %s" tname)
85                >: block [ printf "%s = %s," n v | (n, v) <- vals] )
86                <: (printf "%s;" tname) )
87
88enum_anon :: String -> [ (String, String) ] -> [String]
89enum_anon tag vals = ("enum " ++ tag) >: block [ printf "%s = %s," n v | (n, v) <- vals]
90
91
92function_proto :: String -> String -> String -> [(String,String)] -> String
93function_proto attr rtype name args =
94    printf "%s %s %s( %s )" attr rtype name (func_args args)
95
96function1 :: String -> String -> String -> [(String,String)] -> [String] -> [String ]
97function1 attr rtype name args body
98    = (function_proto attr rtype name args ):(block body)
99
100static :: String -> String -> [(String,String)] -> [String] -> [ String ]
101static rtype name args body = function1 "static" rtype name args body
102
103inline :: String -> String -> [(String,String)] -> [String] -> [String]
104inline rtype name args body =
105    function1 "static inline" rtype name args body
106
107
108func_args:: [(String,String)] -> String
109func_args alist =
110    concat (intersperse ", " [ (n ++ " " ++ v) | (n,v) <- alist ])
111
112multi_comment1 str = [ "", "/*" ] ++ [" * " ++ l | l <- lines str] ++ [ " */"]
113
114comment s = "// " ++ s
115
116indent :: [String] -> [String]
117indent l = [ "    " ++ line | line <- l ]
118
119switch :: String -> [ (String, String) ] -> String -> [String]
120switch disc alts dflt =
121    (printf "switch (%s)" disc)
122    >: block ( concat [ [ printf "case %s:" a, printf "%s" l ]
123                            | (a,l) <- alts ]
124               ++ [ "default:", printf "%s" dflt ] )
125
126switch1 :: String -> [ (String,[String]) ] -> [String] -> [String]
127switch1 disc alts dflt =
128    (printf "switch (%s)" disc)
129    >: (block (concat [ (printf "case %s:" a):l | (a,l) <- alts ] ++ ("default:"):dflt ))
130
131if_stmt :: String -> [String] -> [String]
132if_stmt cond thenclause =
133    (printf "if (%s) " cond):block thenclause
134
135if_else :: String -> [String] -> [String] -> [String]
136if_else cond thenclause elseclause =
137    (if_stmt cond thenclause) ++ ("else":(block elseclause))
138
139forloop :: String -> String -> String -> [String] -> [String]
140forloop init iter term body =
141    (printf "for( %s; %s; %s )" init iter term)
142    >: block body
143
144--
145-- Accumulating strings to print: much of the debugging code we
146-- generate consists of successive calls to snprintf.
147--
148
149snprintf :: String -> [ String ]
150snprintf s = snlike "snprintf" s
151
152snlike fn arg = [ "_avail = (r > sz) ? 0 : sz-r;",
153                  printf "_rc = %s(s+r, _avail, %s);" fn arg,
154                  "if ( _rc > 0 && _rc < _avail) { r += _rc; }"
155                ]
156
157snputs :: String -> [ String ]
158snputs s = snprintf (printf "\"%%s\", %s" s)
159
160snputsq :: String -> [ String ]
161snputsq s = snprintf (printf "\"%%s\", \"%s\"" s)
162