diff --git a/bindgen/c.ml b/bindgen/c.ml index 20b4b41..b7c5bad 100644 --- a/bindgen/c.ml +++ b/bindgen/c.ml @@ -1,7 +1,7 @@ let caml_ = "caml_" type c_type = Prim of string | Struct of string | Ptr of c_type | Void -type c_prim = Int of int | Str of string +type c_prim = Int of int | Float of float | Str of string type t = | C_function of { @@ -23,7 +23,6 @@ type t = type program = t list - let pp_list sep pp_el fmt t = Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "%s" sep) @@ -66,6 +65,7 @@ and pp_type fmt (ctype : c_type) = and pp_prim fmt (prim : c_prim) = match prim with | Int d -> Format.fprintf fmt "%d" d + | Float f -> Format.fprintf fmt "%f" f | Str s -> Format.fprintf fmt "%s" s let decl dcl_type dcl_name dcl_value = C_decl { dcl_name; dcl_type; dcl_value } @@ -73,6 +73,7 @@ let call cc_name cc_args = C_call { cc_name; cc_args } let var x = C_variable x let assign asg_var asg_value = C_assign { asg_var; asg_value } let int x = C_prim (Int x) +let float f = C_prim (Float f) let string x = C_prim (Str x) let ptr_field pfa_name pfa_field = C_ptr_field_access { pfa_name; pfa_field } let typ t = C_type t @@ -90,7 +91,10 @@ let caml_alloc_tuple fields = let store_field var idx value = call "Store_field" [ var; int idx; value ] let val_int var name = call "Val_int" [ ptr_field var name ] -let int_val var idx = call "Int_val" [ call "Field" [ var; int idx] ] +let int_val var idx = call "Int_val" [ call "Field" [ var; int idx ] ] + +let val_float var name = call "caml_copy_double" [ ptr_field var name ] +let float_val var idx = call "Double_val" [ call "Field" [ var; int idx ] ] (* from_ir *) let rec ctype_of_ir (ir_type : Ir.ir_type) = @@ -99,6 +103,7 @@ let rec ctype_of_ir (ir_type : Ir.ir_type) = | Ir.Record { rec_name; _ } -> Prim rec_name | Ir.Enum { enum_name; _ } -> Prim enum_name | Ir.Prim Ir.Int -> Prim "int" + | Ir.Prim Ir.Float -> Prim "float" | Ir.Prim Ir.Bool -> Prim "bool" | Ir.Prim Ir.Char -> Prim "char" | Ir.Prim Ir.Void -> Void @@ -127,9 +132,13 @@ module Shims = struct ] @ Ir.( List.mapi - (fun idx field -> - store_field (var "caml_x") idx - (val_int (var "x") field.fld_name)) + (fun idx fld -> + let fld_caml_value = + match fld.fld_type with + | Prim Float -> val_float (var "x") fld.fld_name + | _ -> val_int (var "x") fld.fld_name + in + store_field (var "caml_x") idx fld_caml_value) fields) @ [ caml_return (var "caml_x") ]; } @@ -148,9 +157,12 @@ module Shims = struct @ Ir.( List.mapi (fun idx fld -> - assign - (ptr_field (var "x") fld.fld_name) - (int_val (var "caml_x") idx)) + let field_c_value = + match fld.fld_type with + | Prim Float -> float_val (var "caml_x") idx + | _ -> int_val (var "caml_x") idx + in + assign (ptr_field (var "x") fld.fld_name) field_c_value) fields) @ [ return (var "x") ]; } @@ -162,7 +174,10 @@ module Shims = struct let fn_body = let declare_params = - [ caml_params (List.map (fun (name, _type) -> var (caml_^name)) fn_params ) ] + [ + caml_params + (List.map (fun (name, _type) -> var (caml_ ^ name)) fn_params); + ] in let maybe_declare_result = match fn_ret with @@ -224,17 +239,16 @@ let from_ir (ir : Ir.t) : program = C_include ""; C_include ""; ] - @ - (List.filter_map - (fun node -> - match node with - | Ir.Ir_fun_decl fun_decl -> Some [ Shims.wrap_fun fun_decl ] - | Ir.Ir_type (Record { rec_name; rec_fields }) -> - Some - [ - Shims.of_value rec_name rec_fields; - Shims.to_value rec_name rec_fields; - ] - | _ -> None) - ir.items - |> List.flatten) + @ (List.filter_map + (fun node -> + match node with + | Ir.Ir_fun_decl fun_decl -> Some [ Shims.wrap_fun fun_decl ] + | Ir.Ir_type (Record { rec_name; rec_fields }) -> + Some + [ + Shims.of_value rec_name rec_fields; + Shims.to_value rec_name rec_fields; + ] + | _ -> None) + ir.items + |> List.flatten) diff --git a/bindgen/caml.ml b/bindgen/caml.ml index 6f8ca97..eb7942b 100644 --- a/bindgen/caml.ml +++ b/bindgen/caml.ml @@ -28,6 +28,7 @@ let rec core_type_from_ir typ = | Ir.Enum { enum_name; _ } -> Typ.constr (lid enum_name) [] | Ir.Record { rec_name; _ } -> Typ.constr (lid rec_name) [] | Ir.Prim Int -> Typ.constr (lid "int") [] + | Ir.Prim Float -> Typ.constr (lid "float") [] | Ir.Prim Bool -> Typ.constr (lid "bool") [] | Ir.Prim Char -> Typ.constr (lid "char") [] | Ir.Prim Void -> Typ.constr (lid "unit") [] diff --git a/bindgen/ir.ml b/bindgen/ir.ml index 13b4b8e..e2b06d9 100644 --- a/bindgen/ir.ml +++ b/bindgen/ir.ml @@ -1,4 +1,4 @@ -type ir_prim_type = Int | Bool | Char | Void +type ir_prim_type = Int | Float | Bool | Char | Void type ir_type = | Abstract of string @@ -23,6 +23,8 @@ module Lift = struct (* Format.printf "lift_type: %S\n" (Clang.Type.show typ); *) match typ.desc with | Clang.Ast.BuiltinType Int -> Prim Int + | Clang.Ast.BuiltinType Float -> Prim Float + | Clang.Ast.BuiltinType Double -> Prim Float | Clang.Ast.BuiltinType Bool -> Prim Bool | Clang.Ast.BuiltinType Char_S -> Prim Char | Clang.Ast.BuiltinType Void -> Prim Void diff --git a/examples/caml_doggo.c b/examples/caml_doggo.c index 73f3e38..468cba1 100644 --- a/examples/caml_doggo.c +++ b/examples/caml_doggo.c @@ -11,16 +11,18 @@ Doggo* caml_Doggo_of_value(value caml_x) { x->many = Int_val(Field(caml_x, 0)); x->breed = Int_val(Field(caml_x, 1)); x->wow = Int_val(Field(caml_x, 2)); + x->weight = Double_val(Field(caml_x, 3)); return x; } value caml_Doggo_to_value(struct Doggo* x) { CAMLparam0(); CAMLlocal1(caml_x); - caml_x = caml_alloc_tuple(3); + caml_x = caml_alloc_tuple(4); Store_field(caml_x, 0, Val_int(x->many)); Store_field(caml_x, 1, Val_int(x->breed)); Store_field(caml_x, 2, Val_int(x->wow)); + Store_field(caml_x, 3, caml_copy_double(x->weight)); CAMLreturn(caml_x); } diff --git a/examples/doggo.c b/examples/doggo.c index 60a4784..6df51ff 100644 --- a/examples/doggo.c +++ b/examples/doggo.c @@ -11,5 +11,5 @@ static const char* BreedToString[4] = { void eleven_out_of_ten_majestic_af(Doggo* pupper) { printf("doggo says %d\n", pupper->many); printf("doggo is a %s\n", BreedToString[pupper->breed]); -} - + printf("doggo weighs %.1fkg\n", pupper->weight); +} \ No newline at end of file diff --git a/examples/doggo.h b/examples/doggo.h index ea8d8dd..6a04634 100644 --- a/examples/doggo.h +++ b/examples/doggo.h @@ -9,6 +9,7 @@ typedef struct Doggo { int many; breed breed; char wow; + float weight; } Doggo; void eleven_out_of_ten_majestic_af(Doggo* pupper); diff --git a/examples/doggo.ml b/examples/doggo.ml index 9b9bbe2..3d21fa7 100644 --- a/examples/doggo.ml +++ b/examples/doggo.ml @@ -7,6 +7,7 @@ type nonrec breed = type nonrec doggo = { many: int ; breed: breed ; - wow: char } + wow: char ; + weight: float } external eleven_out_of_ten_majestic_af : pupper:doggo -> unit = "caml_eleven_out_of_ten_majestic_af" diff --git a/examples/main.ml b/examples/main.ml index 120443f..0398f08 100644 --- a/examples/main.ml +++ b/examples/main.ml @@ -1,5 +1,11 @@ -Doggo.eleven_out_of_ten_majestic_af ~pupper:{ +open Doggo + +let pupper = { many=2112; wow='x'; - breed=C_Labrador + breed=C_Labrador; + weight=18.9; } + +let () = + Doggo.eleven_out_of_ten_majestic_af ~pupper \ No newline at end of file