74dccc1418316a8c8a1d3e89bce60824b4574f96
[barrelfish] / tools / sockeye / CSyntax.hs
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
14 module CSyntax where
15
16 import Data.List
17 import Text.Printf
18
19 infixr 9 >:
20 (>:) :: String -> [String] -> [String]
21 s >: [] = [s]
22 s >: (x:xs) = (s ++ " " ++ x) : xs
23
24 infixr 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
30 header_file :: String -> String -> String
31 header_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
41 undef :: String -> String
42 undef n = "#undef " ++ n
43
44 include :: String -> String
45 include f = "#include <" ++ f ++ ".h>"
46
47 include_local :: String -> String
48 include_local f = "#include \"" ++ f ++ ".h\""
49
50 block :: [String] -> [String]
51 block lines = 
52     ["{"] ++ (indent lines) ++ ["}"]
53
54 typedef :: String -> String -> String
55 typedef name typestr = "typedef " ++ typestr ++ " " ++ name ++ ";" 
56
57 constint :: String -> Integer -> String
58 constint name val = printf "static const int %s = 0x%0x;" name val
59
60 struct :: String -> [ String ] -> [ String ]
61 struct name fields =  structunion "struct" name fields 
62
63 struct_field n v = printf "%s\t%s;" n v
64
65 union :: String -> [ String ] -> [ String ]
66 union name fields =  structunion "union" name fields
67
68 union_field n v = struct_field n v
69
70 structunion :: String -> String -> [ String ] -> [ String ]
71 structunion su name fields = 
72     (su ++ " " ++ name) >: (block fields) 
73
74 bitfields name fields = 
75     ("struct " ++ name) >: (block fields) <: "__attribute__ ((packed))" 
76
77 bitfield n w t = printf "%s\t%s\t:%d;" t n w 
78
79
80 enum :: String -> [ (String, String) ] -> String
81 enum 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
88 enum_anon :: String -> [ (String, String) ] -> [String]
89 enum_anon tag vals = ("enum " ++ tag) >: block [ printf "%s = %s," n v | (n, v) <- vals] 
90
91
92 function_proto :: String -> String -> String -> [(String,String)] -> String 
93 function_proto attr rtype name args = 
94     printf "%s %s %s( %s )" attr rtype name (func_args args)
95
96 function1 :: String -> String -> String -> [(String,String)] -> [String] -> [String ]
97 function1 attr rtype name args body 
98     = (function_proto attr rtype name args ):(block body)
99  
100 static :: String -> String -> [(String,String)] -> [String] -> [ String ]
101 static rtype name args body = function1 "static" rtype name args body
102  
103 inline :: String -> String -> [(String,String)] -> [String] -> [String]
104 inline rtype name args body =
105     function1 "static inline" rtype name args body
106
107              
108 func_args:: [(String,String)] -> String
109 func_args alist = 
110     concat (intersperse ", " [ (n ++ " " ++ v) | (n,v) <- alist ])
111
112 multi_comment1 str = [ "", "/*" ] ++ [" * " ++ l | l <- lines str] ++ [ " */"]
113
114 comment s = "// " ++ s
115
116 indent :: [String] -> [String]
117 indent l = [ "    " ++ line | line <- l ]
118
119 switch :: String -> [ (String, String) ] -> String -> [String]
120 switch 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
126 switch1 :: String -> [ (String,[String]) ] -> [String] -> [String]
127 switch1 disc alts dflt = 
128     (printf "switch (%s)" disc) 
129     >: (block (concat [ (printf "case %s:" a):l | (a,l) <- alts ] ++ ("default:"):dflt ))
130
131 if_stmt :: String -> [String] -> [String]
132 if_stmt cond thenclause = 
133     (printf "if (%s) " cond):block thenclause
134
135 if_else :: String -> [String] -> [String] -> [String]
136 if_else cond thenclause elseclause = 
137     (if_stmt cond thenclause) ++ ("else":(block elseclause))
138
139 forloop :: String -> String -> String -> [String] -> [String]
140 forloop 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
149 snprintf :: String -> [ String ]
150 snprintf s = snlike "snprintf" s
151
152 snlike 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                   
157 snputs :: String -> [ String ]
158 snputs s = snprintf (printf "\"%%s\", %s" s)
159
160 snputsq :: String -> [ String ]
161 snputsq s = snprintf (printf "\"%%s\", \"%s\"" s)