1 (* C++ code generation *)
13 module Values
= struct
15 let names = List.map fst
16 let join = String.concat
", "
17 let inline = join & names
18 let to_string = join & (List.map
(fun (n
,t
) -> t ^
" " ^ n
))
22 let rec freshname name scope
=
23 match List.find_all
((=) name
) scope
with
25 | _
-> freshname (name ^
"_") scope
27 let quote = String.replace_chars
(function '
\n'
-> "\\n\\\n" | '
\r'
-> "" | '
"' -> "\\\"" | c -> String.make 1 c)
28 let quote s = "\"" ^ quote s ^ "\""
30 let quote_comment_inline = String.replace_chars (function '\n' -> "\n// " | c -> String.make 1 c)
31 let comment () fmt = Printf.kprintf (indent_endline & quote_comment_inline & (^) "// ") fmt
32 let empty_line () = print_newline ()
33 let open_curly () = output "{"; inc_indent ()
34 let close_curly fmt = dec_indent (); indent "}"; print fmt
35 let start_struct name =
36 output "struct %s
" name;
39 close_curly "; // struct %s
" name;
41 let out_public () = dec_indent(); output "public
:"; inc_indent()
42 let out_private () = dec_indent(); output "private:"; inc_indent()
45 let as_api_type = Type.to_string
46 let as_lang_type t = "typename Traits
::" ^ (as_api_type t)
49 module T = Translate(L)
54 let column_action action attr index =
55 let typ = as_api_type attr.RA.domain in
56 let name = name_of attr index in
57 output "Traits
::%s_column_%s
(row
, %u
, %s
);" action typ index name
59 let func head name args ?tail k =
60 let tail = match tail with
64 let head = match head with "" -> "" | s -> s ^ " " in
65 output "%s%s
(%s
)%s
" head name (Values.to_string args) tail;
70 let set_param arg index param =
72 output "Traits
::set_param(%s
, %s
, %u
);"
73 (* (param_type_to_string t) *)
75 (param_name_to_string id index)
78 let output_value_defs vals =
79 vals >> List.iter (fun (name,t) -> output "%s %s
;" t name)
81 let output_schema_binder index schema =
83 let name = "output
" in
84 output "template
<class T
>";
87 let vals = schema_to_values schema in
88 output_value_defs vals;
91 output "enum
{ count
= %u
};" (List.length schema);
94 let mthd action active =
96 (["row
","typename Traits
::row
"] @ (if active then ["result
","T
"] else []))
98 List.iteri (fun index attr -> column_action action attr index) schema;
99 if active then output "result
(%s
);" (Values.inline vals)
109 let output_schema_binder index schema =
112 | _ -> Some (output_schema_binder index schema)
114 let make_const_values = List.map (fun (name,t) -> name, sprintf "%s const
&" t)
117 let output_schema_data index schema =
121 schema >> schema_to_values >> output_value_defs;
125 let value_inits vals =
128 | _ -> sprintf ": %s
" (String.concat "," (List.map (fun (name,_) -> sprintf "%s
(%s
)" name name) vals))
130 let struct_params name values k =
132 output_value_defs values;
137 let struct_ctor name values k =
138 struct_params name values (fun () ->
139 func "" name values ~tail:(value_inits values) Apply.id;
143 let output_params_binder index params =
145 let name = "params
" in
146 let values = params_to_values params in
147 struct_ctor name (make_const_values values) (fun () ->
148 comment () "binding slots
in a query
(one param may be bound several times
)";
149 output "enum
{ count
= %u
};" (List.length params);
151 let arg = freshname "target
" (name :: Values.names values) in
152 output "template
<class T
>";
153 func "void
" "set_params
" [arg,"T
&"] (fun () -> List.iteri (set_param arg) params);
158 let output_params_binder index params =
160 | [] -> "typename Traits
::no_params
"
161 | _ -> output_params_binder index params
167 let make_stmt index stmt =
168 let name = choose_name stmt.props stmt.kind index in
169 let sql = quote (get_sql stmt) in
170 struct_params name ["stmt
","typename Traits
::statement
"] (fun () ->
171 func "" name ["db
","typename Traits
::connection
"] ~tail:(sprintf ": stmt
(db
,SQLGG_STR
(%s
))" sql) Apply.id;
172 let schema_binder_name = output_schema_binder index stmt.schema in
173 let params_binder_name = output_params_binder index stmt.params in
174 (* if (Option.is_some schema_binder_name) then output_schema_data index stmt.schema; *)
176 if (Option.is_some schema_binder_name) then output "template
<class T
>";
177 let values = params_to_values stmt.params in
178 let result = match schema_binder_name with None -> [] | Some _ -> ["result","T
"] in
179 let all_params = (make_const_values values) @ result in
180 let inline_params = Values.inline (make_const_values values) in
181 func "bool" "operator
()" all_params (fun () ->
182 begin match schema_binder_name with
183 | None -> output "return stmt
.execute
(%s
(%s
));" params_binder_name inline_params
184 | Some schema_name -> output "return stmt
.select
(result,%s
<T
>(),%s
(%s
));"
185 schema_name params_binder_name inline_params
190 let make_all name names =
191 List.iter (fun name -> output "%s %s
;" name name) names;
193 let tail = match names with
195 | _ -> ": " ^ (String.concat ", " (List.map (fun name -> sprintf "%s
(db
)" name) names))
197 func "" name ["db
","typename Traits
::connection
"] ~tail Apply.id
199 let generate () name stmts =
200 output "#pragma once
";
202 output "template
<class Traits
>";
204 let stmts = List.of_enum stmts in
205 let names = List.mapi make_stmt stmts in