Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 65 lines (59 sloc) 2.826 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 let prototypeC type_path_map current_path name args t =
19 sprintf "%s %s(%s)" (BslTypes.to_c_coercion ~type_path_map ~current_path t) (String.concat_map "_" String.lowercase (current_path@[name])) (String.concat_map ~nil:"void" ", " (fun (name, typ) -> sprintf "%s %s" (BslTypes.to_c_coercion ~type_path_map ~current_path typ) name) args)
20
21 let ext = "c"
22 let lang = Language.of_string ext
23 let give_pointer = false
24 let string_of_directive ~type_path_map extra (_(*tags*), d) =
25 let current_path = extra.ordered_path in
26 let s1, s2_opt = match d with
27 | ExternDef (name, _, _) -> sprintf "// ##extern-type %s" name, None
28 | RecordDef (name, _, _) -> sprintf "// ##record %s" name, None
29 | Module (bslkey, name, _) -> sprintf "// ##module %s \\ %s" bslkey name, None
30 | Property -> "", None
31 | EndModule -> "// ##endmodule", None
32 | Register ((bslkey, s, _protected), ty) ->
33 let ml = sprintf "// ##register %s \\ %s" bslkey s in
34 let mli =
35 let args, ret = BslTypes.TypeList.to_list ty in
36 let args = let x = ref (-1) in List.map (fun ty -> incr(x); sprintf "x%d" !x, ty) args in
37 let s = prototypeC type_path_map current_path s args ret in
38 sprintf "extern %s ;" s
39 in
40 ml, Some mli
41 | Args (name, args, t) ->
42 let s = prototypeC type_path_map current_path name args t in
43 s, Some "// args"
44 in s1, default s1 s2_opt
45 let line_pointer filename = sprintf "#line 1 \"%s\"" filename
46 let impl_name_of_path_name ?runtime:_ _ name = name
47 let extra_header = "
48 /* representation of bsl-standard type */
49 typedef char unit; /* warning unit is different from {} in C libbsl (TODO: is it OK?) */
50 typedef char bool;
51 typedef void *ty_alphaval;
52 typedef void *ty_qmlval;
53 "
54 let extra_code = "
55 #define UNIT return(0)
56 "
57 let init_extra_code = extra_code, extra_header
58 let extra_static_checker _ _ = ()
59 let extra_static_validator _ _ _ = () (* no need an extra check with C : it is compiled with gcc *)
60 let module_dirtags () = None
61 let source_preprocess () = None
62 let introduction (buf_js, buf_jsi) =
63 let buf_js = FBuffer.addln buf_js "/** Concatenation of all cbsl code */" in
64 (buf_js, buf_jsi)
Something went wrong with that request. Please try again.