├── examples └── ex1 │ ├── some_code.ml │ ├── .gitignore │ ├── somecode.h │ ├── somecode.cc │ ├── Makefile │ ├── somecode_tests.ml │ └── somecode-ffi.idl ├── META ├── .gitignore ├── CHANGES ├── include_ml ├── cppffigen.opam ├── Makefile ├── cppffigen_main.ml ├── README.md ├── cppffi.h ├── cppffigen_example.ml ├── cppffi.inc ├── LICENSE └── cppffigen.ml /examples/ex1/some_code.ml: -------------------------------------------------------------------------------- 1 | 2 | let x = 1 3 | -------------------------------------------------------------------------------- /examples/ex1/.gitignore: -------------------------------------------------------------------------------- 1 | ocaml_somecode.ml 2 | ocaml_somecode.mli 3 | ocaml_somecode_stubs.cc 4 | -------------------------------------------------------------------------------- /META: -------------------------------------------------------------------------------- 1 | version = "2022-01-22" 2 | description = "C++ FFI generator" 3 | requires = "pa_ppx.deriving_plugins.std sexplib cmdliner" 4 | 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | setup.log 2 | setup.data 3 | *.ml*lib 4 | _build 5 | *.byte 6 | *.opt 7 | *.a 8 | *.o 9 | *.cm* 10 | *.so 11 | cppffigen 12 | cppffigen_example 13 | -------------------------------------------------------------------------------- /CHANGES: -------------------------------------------------------------------------------- 1 | ocaml-cppffigen Version 0.003 2 | ----------------------------- 3 | 4 | * [13 Feb 2025] a bunch of changs 5 | * added a bunch more static typing to the generatd C++ code, in order to sure better automatic conversions 6 | 7 | * switched from ppx_sexp_conv to pa_ppx.deriving_plugins.sexp 8 | 9 | * switched to using pa_ppx_fmtformat for generating code 10 | 11 | * removed dependency on pcre (why was it ever needed?) 12 | 13 | ocaml-cppffigen Version 0.002 14 | ----------------------------- 15 | 16 | * [not sure of the date] 17 | * First release 18 | -------------------------------------------------------------------------------- /include_ml: -------------------------------------------------------------------------------- 1 | (* Copyright 2016 Chetan Murthy *) 2 | #use "topfind.camlp5";; 3 | #camlp5o ;; 4 | 5 | 6 | #require "pa_ppx.deriving_plugins.std";; 7 | #require "sexplib";; 8 | #require "cmdliner";; 9 | #require "bos";; 10 | #require "result";; 11 | #load "cppffigen.cmo";; 12 | #load "cppffigen_main.cmo";; 13 | 14 | open Cppffigen ;; 15 | open Cppffigen_main ;; 16 | 17 | #trace concretetype_to_sentineltype ;; 18 | #trace CPP.gen_stanza_bodies ;; 19 | #trace ctype2concretetype ;; 20 | 21 | "examples/ex1/somecode-ffi.idl" |> Fpath.v |> Bos.OS.File.read |> Result.get_ok |> Sexplib.Sexp.of_string |> Cppffigen.t_of_sexp;; 22 | 23 | gen_f (open_in "examples/ex1/somecode-ffi.idl") Format.std_formatter `CPP ;; 24 | 25 | (* 26 | ;;; Local Variables: *** 27 | ;;; mode:tuareg *** 28 | ;;; End: *** 29 | 30 | *) 31 | -------------------------------------------------------------------------------- /cppffigen.opam: -------------------------------------------------------------------------------- 1 | version: "0.003" 2 | name: "cppffigen" 3 | opam-version: "2.0" 4 | synopsis: "A C++ foreign-function-interface generator for Ocaml based on C++ STL Containers" 5 | license: "Apache-2.0" 6 | maintainer: "Chet Murthy " 7 | authors: "Chet Murthy " 8 | homepage: "https://github.com/chetmurthy/ocaml-cppffigen" 9 | bug-reports: "Chet Murthy " 10 | depends: [ 11 | "ppx_deriving" { >= "5.2.1" } 12 | "pa_ppx" { >= "0.17" } 13 | "sexplib" { >= "v0.14.0" } 14 | "cmdliner" { >= "1.0.4" } 15 | "pa_ppx_fmtformat" 16 | ] 17 | build: [ 18 | [make "all"] 19 | [make "test"] { with-test } 20 | ] 21 | install: [make "install"] 22 | dev-repo: "git+https://github.com/chetmurthy/ocaml-cppffigen" 23 | url { 24 | src: "" 25 | checksum: [ 26 | "sha512=" 27 | ] 28 | } 29 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | PACKAGES=camlp5,pa_ppx.deriving_plugins.sexp,sexplib,cmdliner,pa_ppx.utils,pa_ppx.located_sexp,pa_ppx.runtime_fat 3 | SYNTAX=camlp5o 4 | 5 | OCAMLCFLAGS= -package $(PACKAGES) -syntax $(SYNTAX) -g 6 | YAWRAP=ocamlfind camlp5-buildscripts/ya-wrap-ocamlfind 7 | OCAMLC=$(YAWRAP) ocamlfind ocamlc 8 | 9 | all: cppffigen cppffigen_example 10 | 11 | cppffigen: cppffigen.cmo cppffigen_main.cmo 12 | $(OCAMLC) $(OCAMLCFLAGS) -linkall -linkpkg -o cppffigen $^ 13 | 14 | cppffigen_example: cppffigen.cmo cppffigen_example.cmo 15 | $(OCAMLC) $(OCAMLCFLAGS) -linkall -linkpkg -o cppffigen_example $^ 16 | 17 | .ml.cmo: 18 | $(OCAMLC) $(OCAMLCFLAGS) -c $< 19 | 20 | test: all 21 | make -C examples/ex1 clean all test 22 | 23 | clean:: 24 | rm -f *.cm* cppffigen cppffigen_example 25 | make -C examples/ex1 clean 26 | 27 | install: all 28 | ocamlfind install cppffigen META cppffigen cppffi.inc cppffi.h 29 | 30 | uninstall:: 31 | ocamlfind remove cppffigen 32 | 33 | .SUFFIXES: .cmo .cmi .ml .mll .mly .mli .cmx .cma .cmxa .cmt .cmti 34 | 35 | cppffigen_main.cmo: cppffigen.cmi 36 | cppffigen_example.cmo: cppffigen.cmi 37 | -------------------------------------------------------------------------------- /examples/ex1/somecode.h: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | 8 | #ifndef somecode_h_included 9 | #define somecode_h_included 10 | 11 | namespace somecode { 12 | 13 | std::string 14 | foo(int n) ; 15 | 16 | int32_t 17 | int_to_int32(int n) ; 18 | 19 | int 20 | int32_to_int(int32_t n) ; 21 | 22 | std::optional 23 | int32_option_to_int_option(const std::optional& n) ; 24 | 25 | std::optional 26 | roundtrip_int_option(const std::optional& n) ; 27 | 28 | std::optional 29 | roundtrip_string_option(const std::optional& n) ; 30 | 31 | std::tuple< std::string, int > 32 | bar(std::string s, int n); 33 | 34 | std::string 35 | size_t_to_string(size_t n); 36 | 37 | enum class WALRecoveryMode : char { 38 | kTolerateCorruptedTailRecords = 0x00, 39 | kAbsoluteConsistency = 0x01, 40 | kPointInTimeRecovery = 0x02, 41 | kSkipAnyCorruptedRecords = 0x03, 42 | }; 43 | 44 | WALRecoveryMode 45 | wal_recovery_mode_from_int(int n); 46 | 47 | struct something { 48 | int n; 49 | std::string s ; 50 | something(int n, std::string s) : n(n), s(s) { } 51 | something() {} 52 | } ; 53 | 54 | } // namespace somecode 55 | 56 | #endif 57 | -------------------------------------------------------------------------------- /cppffigen_main.ml: -------------------------------------------------------------------------------- 1 | (**pp -syntax camlp5o -package pa_ppx.located_sexp,pa_ppx_fmtformat*) 2 | open Cppffigen 3 | open Cmdliner 4 | open Pa_ppx_located_sexp 5 | 6 | Pa_ppx_runtime.Exceptions.Ploc.pp_loc_verbose := true ;; 7 | Pa_ppx_runtime_fat.Exceptions.Ploc.pp_loc_verbose := true ;; 8 | 9 | let expand_composite tmap t = 10 | let expand1 = function 11 | | ATTRIBUTE t -> expand_attribute t 12 | | STRUCT t -> expand_struct tmap t 13 | | t -> [t] in 14 | { stanzas = List.concat (List.map expand1 t.stanzas) } 15 | 16 | let gen_f ic pps mode = 17 | let t = t_of_located_sexp (Sexp.input_sexp ic) in 18 | let tmap = TMAP.mk t.stanzas in 19 | let t = expand_composite tmap t in 20 | match mode with 21 | | `CPP -> CPP.gen tmap pps t 22 | | `ML -> ML.gen tmap pps t 23 | | `MLI -> MLI.gen tmap pps t 24 | | `SEXP -> Sexp.pp_hum pps (located_sexp_of_t t) 25 | 26 | let opts_sect = "OPTIONS" 27 | 28 | let gen_cmd = 29 | let doc = "C++ FFI generator" in 30 | let man = [] in 31 | let ftype = 32 | let doc = "output file type (cpp or ml)" in 33 | let docs = opts_sect in 34 | Arg.(value & opt (enum ["cpp",`CPP; "ml", `ML; "mli", `MLI; "sexp", `SEXP]) `CPP & info ["output"] ~docs ~docv:"OUTPUT-FILE-TYPE" ~doc) in 35 | Term.(const (gen_f stdin Format.std_formatter) $ ftype), 36 | Term.info "cppffigen" ~version ~sdocs:opts_sect ~doc ~man 37 | 38 | let main () = 39 | match Term.eval ~catch:true gen_cmd with 40 | | `Error _ -> exit 1 | _ -> exit 0 41 | ;; 42 | 43 | if not !Sys.interactive then 44 | main() 45 | ;; 46 | -------------------------------------------------------------------------------- /examples/ex1/somecode.cc: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | 8 | #include "somecode.h" 9 | 10 | namespace somecode { 11 | 12 | std::string 13 | foo(int n) { 14 | std::string rv = std::to_string(n) ; 15 | return rv ; 16 | } 17 | 18 | int32_t 19 | int_to_int32(int n) { 20 | return n ; 21 | } 22 | 23 | int 24 | int32_to_int(int32_t n) { 25 | return n ; 26 | } 27 | 28 | std::optional 29 | int32_option_to_int_option(const std::optional& n) { 30 | if (n.has_value()) { 31 | return std::optional(n.value()) ; 32 | } 33 | else { 34 | return std::optional() ; 35 | } 36 | } 37 | 38 | std::optional 39 | roundtrip_int_option(const std::optional& n) { 40 | return n ; 41 | } 42 | 43 | std::optional 44 | roundtrip_string_option(const std::optional& n) { 45 | return n ; 46 | } 47 | 48 | std::tuple< std::string, int > 49 | bar(std::string s, int n) { 50 | return std::tuple< std::string, int>{ s, n } ; 51 | } 52 | 53 | std::string 54 | size_t_to_string(size_t n) { 55 | // std::string rv = std::to_string(n) ; 56 | 57 | std::stringstream sstream; 58 | sstream << std::hex << n; 59 | std::string rv = sstream.str(); 60 | 61 | return rv ; 62 | } 63 | 64 | WALRecoveryMode 65 | wal_recovery_mode_from_int(int n) { 66 | switch (n) { 67 | case 0: return WALRecoveryMode::kTolerateCorruptedTailRecords ; 68 | case 1: return WALRecoveryMode::kAbsoluteConsistency; 69 | case 2: return WALRecoveryMode::kPointInTimeRecovery; 70 | case 3: return WALRecoveryMode::kSkipAnyCorruptedRecords; 71 | default: 72 | assert(false); 73 | } 74 | } 75 | 76 | } // namespace somecode 77 | -------------------------------------------------------------------------------- /examples/ex1/Makefile: -------------------------------------------------------------------------------- 1 | 2 | OCAMLLIB := $(shell ocamlc -where) 3 | OCAMLMKLIB_FLAGS= -lstdc++ 4 | 5 | RESULT=ocaml_somecode 6 | 7 | CXXFLAGS += -g2 -I. -I../.. -I$(OCAMLLIB) -std=gnu++20 -fno-rtti 8 | 9 | PACKS = result,threads,oUnit 10 | 11 | MLI= $(RESULT).mli 12 | ML= $(RESULT).ml some_code.ml 13 | CMO= $(patsubst %.ml,%.cmo, $(ML)) 14 | CMX= $(patsubst %.ml,%.cmx, $(ML)) 15 | CMI= $(patsubst %.ml,%.cmi, $(ML)) 16 | OBJECTS = $(CMO) $(CMX) $(CMI) 17 | 18 | all: $(RESULT).cma $(RESULT).cmxa dll$(RESULT).so somecode_tests.byte somecode_tests.opt 19 | 20 | test: somecode_tests.byte 21 | mkdir -p _build 22 | ./somecode_tests.byte 23 | 24 | somecode_tests.byte: $(RESULT).cma somecode_tests.cmo 25 | ocamlfind ocamlc -custom -thread -package $(PACKS) -linkpkg -linkall -o somecode_tests.byte $(RESULT).cma -cclib -L. somecode_tests.cmo 26 | 27 | somecode_tests.opt: $(RESULT).cmxa somecode_tests.cmx 28 | ocamlfind ocamlopt -thread -package $(PACKS) -linkpkg -linkall -o somecode_tests.opt $(RESULT).cmxa -cclib -L. somecode_tests.cmx 29 | 30 | $(RESULT).cma $(RESULT).cmxa dll$(RESULT).so: $(OBJECTS) $(RESULT)_stubs.o somecode.o 31 | ocamlmklib -verbose -o $(RESULT) $(CMO) $(CMX) $(RESULT)_stubs.o somecode.o $(OCAMLMKLIB_FLAGS) 32 | 33 | somecode_tests.cmo : somecode_tests.ml 34 | ocamlfind ocamlc -thread -package $(PACKS) -c somecode_tests.ml 35 | 36 | somecode_tests.cmx : somecode_tests.ml 37 | ocamlfind ocamlopt -thread -package $(PACKS) -c somecode_tests.ml 38 | 39 | $(CMO) $(CMI): $(ML) 40 | ocamlfind ocamlc -thread -package $(PACKS) -c $(MLI) 41 | ocamlfind ocamlc -thread -package $(PACKS) -c $(ML) 42 | 43 | $(CMX): $(ML) $(CMI) 44 | ocamlfind ocamlopt -thread -package $(PACKS) -c $(ML) 45 | 46 | $(RESULT).ml $(RESULT).mli $(RESULT)_stubs.cc: somecode-ffi.idl 47 | ../../cppffigen --output ml < somecode-ffi.idl > $(RESULT).ml 48 | ../../cppffigen --output mli < somecode-ffi.idl > $(RESULT).mli 49 | ../../cppffigen --output cpp < somecode-ffi.idl > $(RESULT)_stubs.cc 50 | 51 | $(RESULT)_stubs.o: $(RESULT)_stubs.cc 52 | g++ -c -fPIC ${CXXFLAGS} -DPIC -o $(RESULT)_stubs.o $(RESULT)_stubs.cc 53 | 54 | somecode.o: somecode.cc 55 | g++ -c -fPIC ${CXXFLAGS} -DPIC -o $@ $< 56 | 57 | clean:: 58 | rm -rf somecode_tests.byte somecode_tests.opt \ 59 | META *.a *.cma *.cmi *.cmo *.cmx *.cmxa *.o *.so *.log *.cache _build \ 60 | $(RESULT).ml $(RESULT).mli $(RESULT).top \ 61 | $(RESULT)_stubs.c $(RESULT)_stubs.c.ORIG $(RESULT)_stubs.cc 62 | -------------------------------------------------------------------------------- /examples/ex1/somecode_tests.ml: -------------------------------------------------------------------------------- 1 | (* Copyright 2016 Chetan Murthy *) 2 | 3 | open OUnit2 4 | 5 | let all = "all_tests" >::: 6 | [ 7 | "somecode_foo" >:: 8 | (fun ctxt -> 9 | assert_equal "45" (Ocaml_somecode.somecode_foo 45)) 10 | ; "somecode_int32_to_int" >:: 11 | (fun ctxt -> 12 | assert_equal ~printer:string_of_int 45 (Ocaml_somecode.somecode_int32_to_int 45l)) 13 | ; "somecode_int_to_int32" >:: 14 | (fun ctxt -> 15 | assert_equal ~printer:Int32.to_string 45l (Ocaml_somecode.somecode_int_to_int32 45)) 16 | ; "somecode_bar" >:: 17 | (fun ctxt -> 18 | assert_equal ("foo", 42) (Ocaml_somecode.somecode_bar "foo" 42)) 19 | ; "somecode_size_t_to_string" >:: 20 | (fun ctxt -> 21 | assert_equal ~printer:(fun x -> x) "deadbeef" (Ocaml_somecode.somecode_size_t_to_string 0xdeadbeefL) 22 | ; assert_equal ~printer:(fun x -> x) "deadbeefdeadbeef" (Ocaml_somecode.somecode_size_t_to_string 0xdeadbeefdeadbeefL) 23 | ) 24 | ; "somecode_wal_recovery_mode_from_int" >:: 25 | (fun ctxt -> 26 | assert_equal '\000' (Ocaml_somecode.somecode_wal_recovery_mode_from_int 0) 27 | ; assert_equal '\003' (Ocaml_somecode.somecode_wal_recovery_mode_from_int 3) 28 | ) 29 | ; "somecode_option_1" >:: 30 | (fun ctxt -> 31 | assert_equal None (Ocaml_somecode.somecode_int32_option_to_int_option None) 32 | ; assert_equal (Some 1) (Ocaml_somecode.somecode_int32_option_to_int_option (Some 1l)) 33 | ) 34 | ; "somecode_roundtrip" >:: 35 | (fun ctxt -> 36 | let open Ocaml_somecode in 37 | assert_equal None (somecode_roundtrip_int_option None) 38 | ; assert_equal (Some 1) (somecode_roundtrip_int_option (Some 1)) 39 | ; assert_equal None (somecode_roundtrip_string_option None) 40 | ; assert_equal (Some "foo") (somecode_roundtrip_string_option (Some "foo")) 41 | ; assert_equal ST0.{b=true;uc='a'} (somecode_roundtrip_ST0_t ST0.{b=true;uc='a'}) 42 | ; (let st = ST.{ b = true ; uc = 'a' ; n = 1 ; nL = 1L ; s = "foo" ; sz = 0xdeadbeefdeadbeefL } in 43 | assert_equal st (somecode_roundtrip_ST_t st)) 44 | ; assert_equal 1L (somecode_roundtrip_short_t 1L) 45 | ; assert_equal 0L (somecode_roundtrip_short_t 65536L) 46 | ) 47 | ; "somecode_ST.t" >:: 48 | (fun ctxt -> 49 | let open Ocaml_somecode in 50 | let sth_opt = somecode_stt_make() in 51 | assert_bool "was None" (None <> sth_opt) ; 52 | let (Some sth) = sth_opt in 53 | assert_equal false (somecode_stt_id_get_b sth) 54 | ; assert_equal () (somecode_stt_id_set_b sth true) 55 | ; assert_equal true (somecode_stt_id_get_b sth) 56 | ) 57 | ; "something" >:: 58 | (fun ctxt -> 59 | let open Ocaml_somecode in 60 | assert_equal (10,"foo") (somecode_via_something 10 "foo") 61 | ) 62 | ] 63 | 64 | (* Run the tests in test suite *) 65 | let _ = 66 | run_test_tt_main all 67 | ;; 68 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # OCaml C++ FFI Generator 2 | 3 | This project is a pre-pre-pre-pre alpha release of a C++ 4 | foreign-function-interface generator for Ocaml. Please use at your own risk. 5 | 6 | ## Installation 7 | 8 | This library requires pa_ppx.deriving_plugins.sexp, 9 | sexplib, cmdliner packages. The easiest way to build is to have 10 | installed the opam package manager; then it suffices to run: 11 | 12 | ``` 13 | opam install ppx_deriving pa_ppx.deriving_plugins.sexp sexplib cmdliner ounit 14 | make all install 15 | ``` 16 | 17 | An example of the use of this tool can be found in the 18 | [ocaml-rocksdb library][ocaml-rocksdb]. 19 | 20 | ## Why do we need another FFI generator? 21 | 22 | The first and most important question you ought to be asking yourself as a reader is 23 | 24 | ``` 25 | Why do we need another FFI Generator for Ocaml? Isn't Camlidl enough? What about Ctypes? 26 | ``` 27 | 28 | This is a very fair question, and I can only answer it by telling you 29 | my reasons for writing this tool. YMMV, and I surely would suggest 30 | that you strongly consider using one of the above-mentioned tools, 31 | before considering this one. 32 | 33 | ### Reasons for using this tool instead of others. 34 | 35 | 1. __What about CamlIDL?__ I've been a longtime user of CamlIDL. It's 36 | great for C code, when the types are pretty well-behaved and don't 37 | have complex structures requiring a lot of allocation/deallocation. 38 | And it doesn't deal at all with C++. 39 | 40 | 2. __What about CTypes?__ This tool's genesis is in my frustration 41 | with Ctypes. Ctypes doesn't deal with C++ either. But originally, 42 | I was using the [orocksdb][orocksdb] library, and while it worked 43 | well, I needed to extend it. `orocksdb` uses Ctypes to interface 44 | to the Rocksdb C API, and the new operations I wanted to add were 45 | complex. Ctypes is complex to understand, and while I'm a 46 | long-time Caml-Light/Ocaml programmer, I didn't relish the thought 47 | of figuring out how to allocate/manage/free C memory from Ocaml 48 | code. It seemed really complicated. 49 | 50 | 3. __C++'s STL is a great fit for Ocaml__ This is the real reason for 51 | this project: I've been programming C++ for a number of years, and 52 | the STL types (`std::string`, `std::vector`, etc) are a great fit 53 | for Ocaml's type-constructors, and the memory-ownership semantics 54 | of those types match well with Ocaml. So it seemed to me that one 55 | could easily generate the type-directed translation code needed to 56 | convert complex data-types in C++ to/from ML. 57 | 58 | ### Reasons to NOT use this tool 59 | 60 | 1. The code to which you wish to interface is _not_ in C++. This 61 | should be obvious. This tool only works for C++. 62 | 63 | 2. The C++ code you wish to interface to does not follow the 64 | [Google C++ Style Guide][Google C++ Style Guide], or uses a lot of 65 | types that do not follow C++ STL conventions. This tool leverages 66 | the memory-ownership rules and semantics of the C++ STL, as 67 | codified in Google's style guide. 68 | 69 | #### License 70 | 71 | This code is released under an Apache 2.0 license . 72 | 73 | 74 | [Google C++ Style Guide]: https://google.github.io/styleguide/cppguide.html 75 | [orocksdb]: https://github.com/domsj/orocksdb 76 | [/LICENSE]: /LICENSE 77 | [ocaml-rocksdb]: https://github.com/chetmurthy/ocaml-rocksdb/ 78 | -------------------------------------------------------------------------------- /cppffi.h: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | 7 | #ifndef cppffigen_h_included 8 | #define cppffigen_h_included 9 | 10 | struct sentinel_GENERIC { } ; 11 | struct sentinel_INT { } ; 12 | struct sentinel_INT32 { } ; 13 | struct sentinel_INT64 { } ; 14 | 15 | template 16 | struct sentinel_TUPLE2 { T t ; U u; } ; 17 | 18 | template 19 | struct sentinel_TUPLE3 { T t ; U u; V v; } ; 20 | 21 | template 22 | struct sentinel_ARRAY { T t; } ; 23 | 24 | template 25 | struct sentinel_OPTION { T t; } ; 26 | 27 | template 28 | value c2ml_owned_pointer(const T & p) ; 29 | 30 | template 31 | void ml2c_owned_pointer(const value v, T *cv) ; 32 | 33 | template 34 | void ml2c_set_owned_pointer(value v, T cv) ; 35 | 36 | value c2ml(sentinel_INT unused, int v) ; 37 | value c2ml(sentinel_INT unused, unsigned int v) ; 38 | value c2ml(sentinel_INT unused, bool v) ; 39 | value c2ml(sentinel_INT unused, char v) ; 40 | value c2ml(sentinel_INT unused, unsigned char v) ; 41 | 42 | value c2ml(sentinel_INT32 unused, int32_t v) ; 43 | value c2ml(sentinel_INT32 unused, uint32_t v) ; 44 | value c2ml(sentinel_INT64 unused, int64_t v) ; 45 | value c2ml(sentinel_INT64 unused, uint64_t v) ; 46 | 47 | void ml2c(sentinel_INT unused, value v, int *cv) ; 48 | void ml2c(sentinel_INT unused, value v, unsigned int *cv) ; 49 | void ml2c(sentinel_INT unused, value v, bool *cv) ; 50 | void ml2c(sentinel_INT unused, value v, char *cv) ; 51 | void ml2c(sentinel_INT unused, value v, unsigned char *cv) ; 52 | 53 | void ml2c(sentinel_INT32 unused, value v, int32_t *cv) ; 54 | void ml2c(sentinel_INT32 unused, value v, uint32_t *cv) ; 55 | void ml2c(sentinel_INT64 unused, value v, int64_t *cv) ; 56 | void ml2c(sentinel_INT64 unused, value v, uint64_t *cv) ; 57 | 58 | value c2ml(sentinel_GENERIC unused, const std::string& v) ; 59 | 60 | void ml2c(sentinel_GENERIC unused, value v, std::string *cv) ; 61 | 62 | template 63 | value c2ml(ML_T unused1, ML_U unused2, T& t, U& u) ; 64 | template 65 | value c2ml(sentinel_TUPLE2 unused, std::tuple& v) ; 66 | 67 | template 68 | void ml2c(sentinel_TUPLE2 unused, value v, std::tuple* cv) ; 69 | 70 | template 75 | value c2ml(ML_T unusedt, ML_U unusedu, ML_V unusedv, T& t, U& u, V& v); 76 | 77 | template 82 | value c2ml(sentinel_TUPLE3 unused, std::tuple& v) ; 83 | 84 | template 89 | void ml2c(sentinel_TUPLE3 unused, value v, std::tuple* cv) ; 90 | 91 | template 92 | value c2ml(sentinel_ARRAY unused, std::vector& v) ; 93 | 94 | template 95 | void ml2c(sentinel_ARRAY unused, value v, std::vector* cv) ; 96 | 97 | template 98 | value c2ml(sentinel_OPTION unused, std::optional& ssp) ; 99 | 100 | #endif // cppffigen_h_included 101 | -------------------------------------------------------------------------------- /examples/ex1/somecode-ffi.idl: -------------------------------------------------------------------------------- 1 | ( 2 | (stanzas 3 | ( 4 | (CPP PROLOGUE 5 | " 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include 12 | 13 | #include \"somecode.h\" 14 | #include \"cppffi.h\" 15 | ") 16 | 17 | (TYPEDEF 18 | ((mltype (CONCRETE INT64)) 19 | (cpptype (ID size_t)) 20 | (name size_t))) 21 | 22 | (FOREIGN 23 | ((ID std::string)) 24 | somecode_foo 25 | (((PRIM INT) n)) 26 | "_res0 = somecode::foo(n); ") 27 | 28 | (FOREIGN 29 | ((PRIM INT)) 30 | somecode_int32_to_int 31 | (((PRIM INT32) n)) 32 | "_res0 = somecode::int32_to_int(n); ") 33 | 34 | (FOREIGN 35 | ((TYCON std::optional ((PRIM INT)))) 36 | somecode_int32_option_to_int_option 37 | (((TYCON std::optional ((PRIM INT32))) n)) 38 | "_res0 = somecode::int32_option_to_int_option(n); ") 39 | 40 | (FOREIGN 41 | ((TYCON std::optional ((PRIM INT)))) 42 | somecode_roundtrip_int_option 43 | (((TYCON std::optional ((PRIM INT))) n)) 44 | "_res0 = somecode::roundtrip_int_option(n); ") 45 | 46 | (FOREIGN 47 | ((TYCON std::optional ((ID std::string)))) 48 | somecode_roundtrip_string_option 49 | (((TYCON std::optional ((ID std::string))) n)) 50 | "_res0 = somecode::roundtrip_string_option(n); ") 51 | 52 | (FOREIGN 53 | ((PRIM INT32)) 54 | somecode_int_to_int32 55 | (((PRIM INT) n)) 56 | "_res0 = somecode::int_to_int32(n); ") 57 | 58 | (FOREIGN 59 | ((TYCON "std::tuple" ((ID std::string) (PRIM INT)))) 60 | somecode_bar 61 | (((ID std::string) s) ((PRIM INT) n)) 62 | "_res0 = somecode::bar(s, n); ") 63 | 64 | (FOREIGN 65 | ((ID std::string)) 66 | somecode_size_t_to_string 67 | (((ID size_t) n)) 68 | "_res0 = somecode::size_t_to_string(n); ") 69 | 70 | 71 | (TYPEDEF 72 | ((mltype (CONCRETE CHAR)) (cpptype (ID somecode::WALRecoveryMode)) (name wal_recovery_mode_t))) 73 | 74 | (CPP2ML (ID wal_recovery_mode_t) 75 | "_mlvalue = c2ml(sentinel_INT(),static_cast(_cvalue));") 76 | (ML2CPP (ID wal_recovery_mode_t) 77 | "{ char xx ; ml2c(sentinel_INT(), _mlvalue, &xx); *_cvaluep = static_cast(xx) ; }") 78 | 79 | (FOREIGN 80 | ((ID wal_recovery_mode_t)) 81 | somecode_wal_recovery_mode_from_int 82 | (((PRIM INT) n)) 83 | "_res0 = somecode::wal_recovery_mode_from_int(n); ") 84 | 85 | (STRUCT 86 | ((modname ST0) 87 | (name t) 88 | (members 89 | ( 90 | ((PRIM BOOL) b) 91 | ((PRIM UCHAR) uc) 92 | )) 93 | (code "") 94 | )) 95 | 96 | (FOREIGN ((ID ST0_t)) 97 | somecode_roundtrip_ST0_t 98 | (((ID ST0_t) st)) 99 | " _res0 = st ;" 100 | ) 101 | 102 | 103 | (STRUCT 104 | ((modname ST) 105 | (name t) 106 | (members 107 | ( 108 | ((PRIM BOOL) b) 109 | ((PRIM UCHAR) uc) 110 | ((PRIM INT) n) 111 | ((PRIM UINT64) nL) 112 | ((ID std::string) s) 113 | ((ID size_t) sz) 114 | )) 115 | (code "ST_t() {}") 116 | )) 117 | 118 | (FOREIGN ((ID ST_t)) 119 | somecode_roundtrip_ST_t 120 | (((ID ST_t) st)) 121 | " _res0 = st ;" 122 | ) 123 | 124 | (TYPEDEF 125 | ((mltype (CONCRETE INT64)) 126 | (cpptype (ID short)) 127 | (name short_t))) 128 | 129 | (CPP2ML (ID short_t) 130 | "_mlvalue = c2ml(sentinel_INT64(),static_cast(_cvalue));") 131 | (ML2CPP (ID short_t) 132 | "{ int64_t xx ; ml2c(sentinel_INT64(), _mlvalue, &xx); *_cvaluep = static_cast(xx) ; }") 133 | 134 | (FOREIGN 135 | ((ID short_t)) 136 | somecode_roundtrip_short_t 137 | (((ID short_t) n)) 138 | "_res0 = n; ") 139 | 140 | (TYPEDEF 141 | ((mltype (ABSTRACT stt_id)) 142 | (cpptype (PTR (ID ST_t))) 143 | (name stt_id))) 144 | (ML2CPP (ID stt_id) "ml2c_owned_pointer(_mlvalue, _cvaluep);") 145 | 146 | (TYPEDEF 147 | ((mltype (CONCRETE (OPTION (OTHER stt_id)))) 148 | (cpptype (TYCON std::optional ((ID stt_id)))) 149 | (name stt_id_opt))) 150 | 151 | (FOREIGN 152 | ((TYCON std::optional ((ID stt_id)))) 153 | somecode_stt_make 154 | () 155 | "_res0 = std::optional(new ST_t()); ") 156 | 157 | (FOREIGN 158 | ((ID stt_id_opt)) 159 | somecode_stt_make_2 160 | () 161 | "_res0 = std::optional(new ST_t()); ") 162 | 163 | (ATTRIBUTE 164 | ((target stt_id) (aname nL) (fprefix somecode_) (cpptype (PRIM UINT64)))) 165 | (ATTRIBUTE 166 | ((target stt_id) (aname b) (fprefix somecode_) (cpptype (PRIM BOOL)))) 167 | 168 | (TYPEDEF 169 | ((mltype (CONCRETE (TUPLE (INT STRING)))) 170 | (cpptype (ID somecode::something)) 171 | (name something))) 172 | 173 | (CPP2ML (ID something) 174 | "int n = _cvalue.n; 175 | std::string s = _cvalue.s ; 176 | _mlvalue = c2ml(sentinel_INT(), sentinel_GENERIC(), n, s) ;") 177 | 178 | (FOREIGN 179 | ((ID something)) 180 | somecode_via_something 181 | (((PRIM INT) n) ((ID std::string) s)) 182 | "somecode::something st(n, s); 183 | _res0 = st; 184 | ") 185 | ) 186 | ) 187 | ) 188 | -------------------------------------------------------------------------------- /cppffigen_example.ml: -------------------------------------------------------------------------------- 1 | open Pa_ppx_located_sexp 2 | open Cppffigen 3 | 4 | let t = { 5 | stanzas = [ 6 | CPP(PROLOGUE," 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include 12 | #include 13 | 14 | #include \"rocksdb/comparator.h\" 15 | #include \"rocksdb/db.h\" 16 | #include \"ocaml_rocksdb.inc\" 17 | #include \"cppffi.h\" 18 | ") ; 19 | 20 | ML(PROLOGUE," 21 | type status_t = {code : int ; subcode : int ; msg : string option } 22 | let print_status st = 23 | Printf.printf \"<%d, %d, %s>\\n\" st.code st.subcode 24 | (match st.msg with None -> \"<>\" 25 | | Some s -> Printf.sprintf \"\\\"%s\\\"\" (String.escaped s)) ;; 26 | ") ; 27 | STRUCT Struct.{ 28 | modname = "Triple" ; 29 | name = "triple" ; 30 | members = [ 31 | (PRIM INT, "a") ; 32 | (ID (CPPID.mk "std::string"), "b") ; 33 | (TYCON("std::vector", [PRIM BOOL]), "c") ; 34 | ]; 35 | code = "" 36 | }; 37 | TYPEDEF{ 38 | name="status"; 39 | cpptype=ID(CPPID.mk "rocksdb::Status"); 40 | mltype=MLTYPE.CONCRETE (OTHER (MLID.mk "status_t")); 41 | }; 42 | TYPEDEF{ 43 | name="cfhandle_id"; 44 | cpptype=PTR(ID(CPPID.mk "rocksdb::ColumnFamilyHandle")) ; 45 | mltype= MLTYPE.ABSTRACT "cfhandle_id"; 46 | } ; 47 | CPP2ML(ID(CPPID.mk "cfhandle_id"), 48 | "_mlvalue = c2ml_owned_pointer(_cvalue);") ; 49 | ML2CPP(ID(CPPID.mk "cfhandle_id"), 50 | "ml2c_owned_pointer(_mlvalue, _cvaluep);"); 51 | 52 | TYPEDEF{ 53 | name="db_id"; 54 | cpptype=PTR(ID(CPPID.mk "rocksdb::DB")) ; 55 | mltype= MLTYPE.ABSTRACT "db_id"; 56 | } ; 57 | CPP2ML(ID(CPPID.mk "db_id"), 58 | "_mlvalue = c2ml_owned_pointer(_cvalue);") ; 59 | ML2CPP(ID(CPPID.mk "db_id"), 60 | "ml2c_owned_pointer(_mlvalue, _cvaluep);") ; 61 | 62 | TYPEDEF{ 63 | name="dboptions_id"; 64 | cpptype=PTR(ID(CPPID.mk "rocksdb::DBOptions")) ; 65 | mltype= MLTYPE.ABSTRACT "dboptions_id"; 66 | } ; 67 | CPP2ML(ID(CPPID.mk "dboptions_id"), 68 | "_mlvalue = c2ml_owned_pointer(_cvalue);") ; 69 | ML2CPP(ID(CPPID.mk "dboptions_id"), 70 | "ml2c_owned_pointer(_mlvalue, _cvaluep);") ; 71 | 72 | ATTRIBUTE Attribute.{ 73 | target = "dbooptions_id" ; 74 | aname = "create_if_missing" ; 75 | fprefix = "rocksdb_" ; 76 | cpptype = ID (CPPID.mk "bool") ; 77 | } ; 78 | TYPEDEF{ 79 | name="cfoptions_id"; 80 | cpptype=PTR(ID(CPPID.mk "rocksdb::ColumnFamilyOptions")) ; 81 | mltype= MLTYPE.ABSTRACT "cfoptions_id"; 82 | } ; 83 | CPP2ML(ID(CPPID.mk "cfoptions_id"), 84 | "_mlvalue = c2ml_owned_pointer(_cvalue);") ; 85 | ML2CPP(ID(CPPID.mk "cfoptions_id"), 86 | "ml2c_owned_pointer(_mlvalue, _cvaluep);") ; 87 | 88 | TYPEDEF{ 89 | name="cfdescriptor_id"; 90 | cpptype=PTR(ID(CPPID.mk "rocksdb::ColumnFamilyDescriptor")) ; 91 | mltype= MLTYPE.ABSTRACT "cfdescriptor_id"; 92 | } ; 93 | CPP2ML(ID(CPPID.mk "cfdescriptor_id"), 94 | "_mlvalue = c2ml_owned_pointer(_cvalue);") ; 95 | ML2CPP(ID(CPPID.mk "cfdescriptor_id"), 96 | "ml2c_owned_pointer(_mlvalue, _cvaluep);") ; 97 | 98 | TYPEDEF{ 99 | name="comparator_id"; 100 | cpptype=PTR(ID(CPPID.mk "rocksdb::Comparator")) ; 101 | mltype=MLTYPE.ABSTRACT "comparator_id"; 102 | } ; 103 | CPP2ML(ID(CPPID.mk "comparator_id"), 104 | "_mlvalue = c2ml_owned_pointer(_cvalue);") ; 105 | ML2CPP(ID(CPPID.mk "comparator_id"), 106 | "ml2c_owned_pointer(_mlvalue, _cvaluep);") ; 107 | 108 | ML2CPP(ID(CPPID.mk "rocksdb::ColumnFamilyDescriptor"), 109 | "cfdescriptor_id cfd_id ; 110 | ml2c(_mlvalue, &cfd_id) ; 111 | *_cvaluep = *cfd_id ;") ; 112 | 113 | CPP(HERE, " 114 | std::string demarsh_state(const char *state) { 115 | assert(NULL != state) ; 116 | uint32_t size; 117 | memcpy(&size, state, sizeof(size)); 118 | const char* body = &(state[4]); 119 | return std::string(body, size) ; 120 | } 121 | ") ; 122 | CPP2ML(TYCON("Opt",[PRIM CHAR]), 123 | " 124 | assert(NULL != _cvalue.it) ; 125 | _mlvalue = c2ml(demarsh_state(_cvalue.it)) ; 126 | ") ; 127 | CPP2ML(ID(CPPID.mk "rocksdb::Status"), 128 | " 129 | OptWrap w(_cvalue.getState()) ; 130 | _mlvalue = c2ml(_cvalue.code(), _cvalue.subcode(), w.p()) ; 131 | ") ; 132 | 133 | FOREIGN([ID(CPPID.mk "cfoptions_id")], 134 | "rocksdb_cfoptions_create", 135 | [], 136 | " 137 | _res0 = new rocksdb::ColumnFamilyOptions() ; 138 | ") ; 139 | 140 | FOREIGN([], 141 | "rocksdb_cfoptions_destroy", 142 | [ID(CPPID.mk "cfoptions_id"),"opth"], 143 | " 144 | delete opth ; 145 | ") ; 146 | 147 | FOREIGN([ID(CPPID.mk "dboptions_id")], 148 | "rocksdb_dboptions_create", 149 | [], 150 | " 151 | _res0 = new rocksdb::DBOptions() ; 152 | ") ; 153 | 154 | FOREIGN([], 155 | "rocksdb_dboptions_destroy", 156 | [ID(CPPID.mk "dboptions_id"),"opth"], 157 | " 158 | delete opth ; 159 | ") ; 160 | 161 | FOREIGN([ID(CPPID.mk "status"); TYCON("std::vector", [ID(CPPID.mk "std::string")])], 162 | "rocksdb_list_column_families", 163 | [ID(CPPID.mk "dboptions_id"), "opth"; 164 | ID(CPPID.mk "std::string"),"name"], 165 | " 166 | _res0 = rocksdb::DB::ListColumnFamilies(*opth, name, &_res1); 167 | if (!_res0.ok()) _res1.clear() ; 168 | ") ; 169 | ] 170 | } 171 | 172 | let _ = 173 | Printexc.catch (fun () -> 174 | if Sys.argv.(1) = "-dump-sexp" then 175 | Fmt.(pf stdout "%a@." Sexp.pp_hum (located_sexp_of_t t)) 176 | else failwith "unrecognized argument") 177 | () 178 | -------------------------------------------------------------------------------- /cppffi.inc: -------------------------------------------------------------------------------- 1 | /* these definitions probably need to go, but I'll leave them here 2 | until I have more tests/examples */ 3 | 4 | template 5 | value c2ml_owned_pointer(const T & p) { 6 | assert (NULL != p) ; 7 | value _v1; 8 | _v1 = caml_alloc_small((sizeof(T) + sizeof(value) - 1) / sizeof(value), Abstract_tag); 9 | *((T *) Bp_val(_v1)) = p; 10 | return _v1; 11 | } 12 | 13 | template 14 | void ml2c_owned_pointer(value v, T *cv) { 15 | *cv = *((T *) Bp_val(v)); 16 | } 17 | 18 | template 19 | void ml2c_set_owned_pointer(value v, T cv) { 20 | *((T *) Bp_val(v)) = cv ; 21 | } 22 | 23 | value c2ml(sentinel_INT unused, int v) { return Val_int(v) ; } 24 | value c2ml(sentinel_INT unused, unsigned int v) { return Val_int(v) ; } 25 | value c2ml(sentinel_INT unused, bool v) { return Val_bool(v) ; } 26 | value c2ml(sentinel_INT unused, char v) { return Val_int((int)v) ; } 27 | value c2ml(sentinel_INT unused, unsigned char v) { return Val_int((int)v) ; } 28 | 29 | value c2ml(sentinel_INT32 unused, int32_t v) { return caml_copy_int32(v) ; } 30 | value c2ml(sentinel_INT32 unused, uint32_t v) { return caml_copy_int32(v) ; } 31 | value c2ml(sentinel_INT64 unused, int64_t v) { return caml_copy_int64(v) ; } 32 | value c2ml(sentinel_INT64 unused, uint64_t v) { return caml_copy_int64(v) ; } 33 | 34 | void ml2c(sentinel_INT unused, value v, int *cv) { *cv = Int_val(v) ; } 35 | void ml2c(sentinel_INT unused, value v, unsigned int *cv) { *cv = Int_val(v) ; } 36 | void ml2c(sentinel_INT unused, value v, bool *cv) { *cv = Bool_val(v) ; } 37 | void ml2c(sentinel_INT unused, value v, char *cv) { *cv = (char)Int_val(v) ; } 38 | void ml2c(sentinel_INT unused, value v, unsigned char *cv) { *cv = (char)Int_val(v) ; } 39 | 40 | void ml2c(sentinel_INT32 unused, value v, int32_t *cv) { *cv = Int32_val(v) ; } 41 | void ml2c(sentinel_INT32 unused, value v, uint32_t *cv) { *cv = Int32_val(v) ; } 42 | void ml2c(sentinel_INT64 unused, value v, int64_t *cv) { *cv = Int64_val(v) ; } 43 | void ml2c(sentinel_INT64 unused, value v, uint64_t *cv) { *cv = Int64_val(v) ; } 44 | 45 | value c2ml(sentinel_GENERIC unused, const std::string& v) { 46 | uint32_t size = v.size() ; 47 | value res = caml_alloc_string(size); 48 | memmove((void *)String_val(res), (const void *)v.c_str(), size); 49 | return res ; 50 | } 51 | 52 | void ml2c(sentinel_GENERIC unused, value v, std::string *cv) { 53 | CAMLparam1(v) ; 54 | int size = caml_string_length(v) ; 55 | *cv = std::string(String_val(v), size) ; 56 | CAMLreturn0; 57 | } 58 | 59 | template 60 | value c2ml(ML_T unused1, ML_U unused2, T& t, U& u) { 61 | CAMLparam0() ; 62 | CAMLlocal1(mlv) ; 63 | mlv = caml_alloc_tuple(2) ; 64 | Store_field(mlv, 0, c2ml(ML_T(), t)) ; 65 | Store_field(mlv, 1, c2ml(ML_U(), u)) ; 66 | CAMLreturn(mlv) ; 67 | } 68 | template 69 | value c2ml(sentinel_TUPLE2 unused, std::tuple& v) { 70 | return c2ml(ML_T(), ML_U(), std::get<0>(v), std::get<1>(v)) ; 71 | } 72 | 73 | template 74 | void ml2c(sentinel_TUPLE2 unused, value v, std::tuple* cv) { 75 | CAMLparam1(v) ; 76 | ml2c(ML_T(), Field(v, 0), &(std::get<0>(*cv))) ; 77 | ml2c(ML_U(), Field(v, 1), &(std::get<1>(*cv))) ; 78 | CAMLreturn0; 79 | } 80 | 81 | template 86 | value c2ml(ML_T unusedt, ML_U unusedu, ML_V unusedv, T& t, U& u, V& v) { 87 | CAMLparam0() ; 88 | CAMLlocal1(mlv) ; 89 | mlv = caml_alloc_tuple(3) ; 90 | Store_field(mlv, 0, c2ml(ML_T(), t)) ; 91 | Store_field(mlv, 1, c2ml(ML_U(), u)) ; 92 | Store_field(mlv, 2, c2ml(ML_V(), v)) ; 93 | CAMLreturn(mlv) ; 94 | } 95 | template 100 | value c2ml(sentinel_TUPLE3 unused, std::tuple& v) { 101 | return c2ml(ML_T(), ML_U(), ML_V(), std::get<0>(v), std::get<1>(v), std::get<2>(v)) ; 102 | } 103 | 104 | template 109 | void ml2c(sentinel_TUPLE3 unused, value v, std::tuple* cv) { 110 | CAMLparam1(v); 111 | ml2c(ML_T(), Field(v, 0), &(std::get<0>(*cv))) ; 112 | ml2c(ML_U(), Field(v, 1), &(std::get<1>(*cv))) ; 113 | ml2c(ML_V(), Field(v, 2), &(std::get<2>(*cv))) ; 114 | CAMLreturn0; 115 | } 116 | 117 | template 118 | value c2ml(sentinel_ARRAY unused, std::vector& v) { 119 | CAMLparam0() ; 120 | CAMLlocal1(mlv) ; 121 | mlv = caml_alloc(v.size(), 0) ; 122 | for(int i = 0 ; i < v.size(); i++) { 123 | Store_field(mlv, i, c2ml(ML_T(), v[i])) ; 124 | } 125 | CAMLreturn(mlv) ; 126 | } 127 | 128 | template 129 | void ml2c(sentinel_ARRAY unused, value v, std::vector* cv) { 130 | CAMLparam1(v) ; 131 | int n = caml_array_length(v) ; 132 | cv->clear(); 133 | cv->resize(n) ; 134 | for(int i = 0 ; i < n ; i++) { 135 | T tmp ; 136 | ml2c(ML_T(), Field(v, i), &tmp) ; 137 | (*cv)[i] = tmp ; 138 | } 139 | CAMLreturn0; 140 | } 141 | 142 | template 143 | value c2ml(sentinel_OPTION unused, std::optional& ssp) { 144 | CAMLparam0() ; 145 | CAMLlocal1 (v) ; 146 | if (! ssp.has_value()) { 147 | CAMLreturn(Val_int(0)) ; 148 | } 149 | v = caml_alloc_small(1, 0) ; 150 | Field(v, 0) = c2ml(ML_T(), ssp.value()) ; 151 | CAMLreturn(v) ; 152 | } 153 | 154 | template 155 | void ml2c(sentinel_OPTION unused, value v, std::optional* cv) { 156 | CAMLparam1(v) ; 157 | if (Is_long(v) && Long_val(v) == 0) { 158 | cv->reset() ; 159 | } 160 | else { 161 | T sub_cv; 162 | ml2c(ML_T(), Field(v,0), &sub_cv) ; 163 | *cv = std::optional(sub_cv) ; 164 | } 165 | CAMLreturn0; 166 | } 167 | 168 | 169 | template 170 | value c2ml(sentinel_OPTION unused, std::optional& ssp) { 171 | CAMLparam0() ; 172 | CAMLlocal1(v) ; 173 | if (!ssp.has_value() || NULL == ssp.value()) { 174 | CAMLreturn(Val_int(0)) ; 175 | } 176 | v = caml_alloc_small(1, 0) ; 177 | Field(v, 0) = c2ml_owned_pointer(ssp.value()) ; 178 | CAMLreturn(v) ; 179 | } 180 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS 177 | 178 | APPENDIX: How to apply the Apache License to your work. 179 | 180 | To apply the Apache License to your work, attach the following 181 | boilerplate notice, with the fields enclosed by brackets "{}" 182 | replaced with your own identifying information. (Don't include 183 | the brackets!) The text should be enclosed in the appropriate 184 | comment syntax for the file format. We also recommend that a 185 | file or class name and description of purpose be included on the 186 | same "printed page" as the copyright notice for easier 187 | identification within third-party archives. 188 | 189 | Copyright {yyyy} {name of copyright owner} 190 | 191 | Licensed under the Apache License, Version 2.0 (the "License"); 192 | you may not use this file except in compliance with the License. 193 | You may obtain a copy of the License at 194 | 195 | http://www.apache.org/licenses/LICENSE-2.0 196 | 197 | Unless required by applicable law or agreed to in writing, software 198 | distributed under the License is distributed on an "AS IS" BASIS, 199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 200 | See the License for the specific language governing permissions and 201 | limitations under the License. 202 | -------------------------------------------------------------------------------- /cppffigen.ml: -------------------------------------------------------------------------------- 1 | (**pp -syntax camlp5o -package pa_ppx_fmtformat,pa_ppx.located_sexp,pa_ppx.deriving_plugins.std,pa_ppx.deriving_plugins.located_sexp *) 2 | open Pa_ppx_utils 3 | open Pa_ppx_located_sexp 4 | 5 | let version = "0.003" 6 | 7 | let fst3 (a,b,c) = a 8 | let snd3 (a,b,c) = b 9 | let third3 (a,b,c) = c 10 | let push l x = (l := x :: !l) 11 | 12 | let fmt_list_i ~sep pp1 pps l = 13 | let pairs = List.mapi (fun i x -> (i,x)) l in 14 | Fmt.list ~sep pp1 pps pairs 15 | 16 | let prepend firstpp secondpp pps arg = 17 | Fmt.(pf pps "%a%a" firstpp () secondpp arg) 18 | 19 | let append firstpp secondpp pps arg = 20 | Fmt.(pf pps "%a%a" firstpp arg secondpp ()) 21 | 22 | let if_nil ~nil ~list (pps : Format.formatter) l : unit = 23 | if l = [] then 24 | nil pps () 25 | else list pps l 26 | 27 | module CPPID = struct 28 | type t = CPPID of string [@@deriving show] 29 | let pp pps (CPPID s) = Fmt.(pf pps "%s" s) 30 | let show cppid = Fmt.(str "%a" pp cppid) 31 | let mk s = CPPID s 32 | 33 | let t_of_located_sexp = function 34 | Sexp.Atom(_, s) -> CPPID s 35 | | _ -> failwith "CPPID.t_of_sexp" 36 | 37 | let located_sexp_of_t (CPPID s) = Sexp.Atom(Ploc.dummy, s) 38 | end 39 | 40 | module CPPTYPE = struct 41 | 42 | type primtype = 43 | | INT | UINT 44 | | INT64 | UINT64 45 | | INT32 | UINT32 46 | | CHAR | UCHAR 47 | | BOOL 48 | [@@deriving located_sexp, show] 49 | 50 | type t = 51 | PTR of t 52 | | ID of CPPID.t 53 | | TYCON of string * t list 54 | | PRIM of primtype [@@deriving located_sexp, show] 55 | end 56 | 57 | module MLID = struct 58 | type t = MLID of string [@@deriving show] 59 | let pp pps (MLID s) = Fmt.(pf pps "%s" s) 60 | let show mlid = Fmt.(str "%a" pp mlid) 61 | let mk s = MLID s 62 | 63 | let t_of_located_sexp = function 64 | Sexp.Atom(_, s) -> MLID s 65 | | _ -> failwith "MLID.t_of_sexp" 66 | 67 | let located_sexp_of_t (MLID s) = Sexp.Atom(Ploc.dummy, s) 68 | end 69 | 70 | module MLTYPE = struct 71 | 72 | type concrete_type = 73 | INT 74 | | INT32 75 | | INT64 76 | | CHAR 77 | | BOOL 78 | | NATIVEINT 79 | | STRING 80 | | ARRAY of concrete_type 81 | | TUPLE of concrete_type list 82 | | OPTION of concrete_type 83 | | OTHER of MLID.t [@@deriving located_sexp, show] 84 | 85 | let tuple_type pp1 pps l = Fmt.(pf pps "%a" (list ~sep:(const string " * ") pp1) l) 86 | 87 | let rec ppml_concrete pps cty = 88 | let rec crec pps = function 89 | INT -> {%fmt_pf|int|} pps () 90 | | INT32 -> {%fmt_pf|int32|} pps () 91 | | INT64 -> {%fmt_pf|int64|} pps () 92 | | CHAR -> {%fmt_pf|char|} pps () 93 | | BOOL -> {%fmt_pf|bool|} pps () 94 | | NATIVEINT -> {%fmt_pf|nativeint|} pps () 95 | | STRING -> {%fmt_pf|string|} pps () 96 | | ARRAY ty -> {%fmt_pf|(${ty | crec} array)|} pps () 97 | | TUPLE l -> {%fmt_pf|(${l | tuple_type crec})|} pps () 98 | | OPTION ty -> {%fmt_pf|(${ty | crec} option)|} pps () 99 | | OTHER s -> {%fmt_pf|(${s | MLID.pp})|} pps () 100 | in {%fmt_pf|$(cty | crec)|} pps () 101 | 102 | type t = 103 | | ABSTRACT of string 104 | | CONCRETE of concrete_type [@@deriving located_sexp, show] 105 | 106 | let ppml = function 107 | ABSTRACT s -> s 108 | | CONCRETE cty -> {%fmt_str|$(cty | ppml_concrete)|} 109 | 110 | end 111 | 112 | type def_t = 113 | { name : string ; 114 | mltype : MLTYPE.t ; 115 | cpptype : CPPTYPE.t ; 116 | } [@@deriving located_sexp, show] 117 | 118 | module Attribute = struct 119 | type t = 120 | { 121 | target : string ; 122 | aname : string ; 123 | fprefix : string ; 124 | cpptype : CPPTYPE.t ; 125 | } [@@deriving located_sexp, show] 126 | end 127 | 128 | module Struct = struct 129 | type t = 130 | { 131 | modname : string ; 132 | name : string ; 133 | members : (CPPTYPE.t * string) list ; 134 | code : string 135 | } [@@deriving located_sexp, show] 136 | end 137 | 138 | type loc = PROLOGUE | EPILOGUE | HERE [@@deriving located_sexp,show] 139 | 140 | type stanza_t = 141 | | TYPEDEF of def_t 142 | | STRUCT of Struct.t 143 | | ATTRIBUTE of Attribute.t 144 | | CPP2ML of CPPTYPE.t * string 145 | | ML2CPP of CPPTYPE.t * string 146 | | CPP of loc * string 147 | | ML of loc * string 148 | | MLI of loc * string 149 | | FOREIGN of CPPTYPE.t list * string * (CPPTYPE.t * string) list * string [@@deriving located_sexp, show] 150 | 151 | let expand_attribute {Attribute.target ; aname ; fprefix ; cpptype } = 152 | [FOREIGN([], {%fmt_str|$(fprefix)$(target)_set_$(aname)|}, 153 | [(ID (CPPID.mk target)), "rcvr"; cpptype, aname], 154 | {%fmt_str|rcvr->${aname} = ${aname};|}) ; 155 | FOREIGN([cpptype], {%fmt_str|${fprefix}${target}_get_${aname}|}, 156 | [(ID (CPPID.mk target)), "rcvr"], {%fmt_str|_res0 = rcvr->$(aname);|}) 157 | ] 158 | 159 | let prim2mltype = function 160 | | (CPPTYPE.INT | UINT) -> MLTYPE. INT 161 | | (INT64 | UINT64) -> MLTYPE.INT64 162 | | (INT32 | UINT32) -> MLTYPE.INT32 163 | | (CHAR | UCHAR) -> MLTYPE.CHAR 164 | | BOOL -> MLTYPE.BOOL 165 | 166 | module TMAP = struct 167 | type entry_t = { 168 | stanza : stanza_t 169 | ; mlid : MLID.t 170 | ; cppid : CPPID.t 171 | ; cpptype : CPPTYPE.t 172 | ; mltype : MLTYPE.t 173 | ; concretetype : MLTYPE.concrete_type 174 | } 175 | type t = { 176 | mlid_map : (MLID.t * entry_t) list 177 | ; cppid_map : (CPPID.t * entry_t) list 178 | ; entries : entry_t list 179 | } 180 | 181 | let typedef_to_entry = function 182 | (TYPEDEF t) as stanza -> 183 | { mlid = MLID.mk t.name 184 | ; cppid = CPPID.mk t.name 185 | ; cpptype = t.cpptype 186 | ; mltype = t.mltype 187 | ; stanza 188 | ; concretetype = 189 | match t.mltype with 190 | MLTYPE.CONCRETE t -> t 191 | | ABSTRACT s -> MLTYPE.OTHER (MLID.mk s) 192 | } 193 | 194 | let struct_to_entry = function 195 | (STRUCT t) as stanza -> 196 | let mlid = MLID.mk {%fmt_str|$(t.Struct.modname).$(t.Struct.name)|} in 197 | let cppid = CPPID.mk {%fmt_str|$(t.Struct.modname)_$(t.Struct.name)|} in 198 | let concretetype = MLTYPE.OTHER mlid in 199 | { 200 | mlid 201 | ; cppid 202 | ; cpptype = CPPTYPE.ID cppid 203 | ; mltype = MLTYPE.CONCRETE concretetype 204 | ; concretetype 205 | ; stanza 206 | } 207 | 208 | let mk t = 209 | let entries = 210 | t 211 | |> List.filter_map (function 212 | STRUCT _ as h -> Some(struct_to_entry h) 213 | | TYPEDEF _ as h -> Some(typedef_to_entry h) 214 | | _ -> None 215 | ) in 216 | let mlid_map = List.map (fun e -> (e.mlid, e)) entries in 217 | let cppid_map = List.map (fun e -> (e.cppid, e)) entries in 218 | 219 | let mlids = List.map (fun e -> e.mlid) entries in 220 | let cppids = List.map (fun e -> e.cppid) entries in 221 | let repeated_mlids = Std2.hash_list_repeats mlids in 222 | if [] <> repeated_mlids then 223 | failwith {%fmt_str|TMAP.mk: repeated ML typeids (in structs/typedefs): [$(|repeated_mlids | list ~sep:(const string " ") MLID.pp|)]|} ; 224 | let repeated_cppids = Std2.hash_list_repeats cppids in 225 | if [] <> repeated_mlids then 226 | failwith {%fmt_str|TMAP.mk: repeated C++ typeids (in structs/typedefs): [$(|repeated_cppids | list ~sep:(const string " ") CPPID.pp|)]|} ; 227 | 228 | { mlid_map ; cppid_map ; entries } 229 | 230 | let lookup_mlid tmap s = 231 | match List.assoc s tmap.mlid_map with 232 | e -> e 233 | | exception Not_found -> 234 | failwith {%fmt_str|ML id $(s|MLID.pp) not found in type-map|} 235 | 236 | let lookup_cppid tmap s = 237 | match List.assoc s tmap.cppid_map with 238 | e -> e 239 | | exception Not_found -> 240 | failwith {%fmt_str|++ id $(s|CPPID.pp) not found in type-map|} 241 | 242 | let mem_mlid tmap s = List.mem_assoc s tmap.mlid_map 243 | let mem_cppid tmap s = List.mem_assoc s tmap.cppid_map 244 | 245 | let entries tmap = tmap.entries 246 | 247 | let typedefs tmap = 248 | tmap.entries |> List.filter_map (function 249 | {stanza=TYPEDEF _} as e -> Some e 250 | | _ -> None) 251 | 252 | let structs tmap = 253 | tmap.entries |> List.filter_map (function 254 | {stanza=STRUCT _} as e -> Some e 255 | | _ -> None) 256 | 257 | end 258 | 259 | let ctype2concretetype (tmap : TMAP.t) cty : MLTYPE.concrete_type = 260 | let rec crec = function 261 | | CPPTYPE.PRIM t -> prim2mltype t 262 | | ID (CPPID.CPPID "std::string") -> MLTYPE.STRING 263 | | ID s -> begin 264 | if not (TMAP.mem_cppid tmap s) then 265 | failwith {%fmt_str|typename $(s|CPPID.pp) not found in map|} ; 266 | (TMAP.lookup_cppid tmap s).TMAP.concretetype 267 | end 268 | | TYCON("std::vector",[cty]) -> MLTYPE.(ARRAY (crec cty)) 269 | | TYCON("std::tuple",[a;b]) -> MLTYPE.(TUPLE [crec a; crec b]) 270 | | TYCON("std::tuple",l) -> MLTYPE.(TUPLE (List.map crec l)) 271 | | TYCON("std::optional",[cty]) -> MLTYPE.(OPTION (crec cty)) 272 | | TYCON _ as t -> failwith {%fmt_str|unrecognized C++ type-constructor: ${ t | CPPTYPE.pp }|} 273 | | PTR _ -> failwith "cannot map a PTR type to an ML type (should use typedef)" 274 | in crec cty 275 | 276 | let fmt_primcpptype = function 277 | | CPPTYPE.INT -> "int" 278 | | UINT -> "unsigned int" 279 | | INT64 -> "int64_t" 280 | | UINT64 -> "uint64_t" 281 | | INT32 -> "int32_t" 282 | | UINT32 -> "uint32_t" 283 | | CHAR -> "char" 284 | | UCHAR -> "unsigned char" 285 | | BOOL -> "bool" 286 | 287 | let comma_separated pp1 pps l = Fmt.(pf pps "%a" (list ~sep:(const string ", ") pp1) l) 288 | 289 | let ppcpp_cpptype pps ty = 290 | let rec frec pps = function 291 | | CPPTYPE.ID s -> {%fmt_pf|$(s|CPPID.pp)|} pps () 292 | | PTR t -> {%fmt_pf|$(t | frec)*|} pps () 293 | | TYCON (s, l) -> 294 | {%fmt_pf|$(s)< $(l | comma_separated frec) >|} pps () 295 | | PRIM t -> {%fmt_pf|${fmt_primcpptype t}|} pps () 296 | in {%fmt_pf|$(ty | frec)|} pps () 297 | 298 | let concretetype_to_sentineltype tmap mlty = 299 | let rec convrec pps = function 300 | MLTYPE.INT -> {%fmt_pf|sentinel_INT|} pps () 301 | | INT32 -> {%fmt_pf|sentinel_INT32|} pps () 302 | | INT64 -> {%fmt_pf|sentinel_INT64|} pps () 303 | | CHAR -> {%fmt_pf|sentinel_INT|} pps () 304 | | BOOL -> {%fmt_pf|sentinel_INT|} pps () 305 | | NATIVEINT -> {%fmt_pf|sentinel_NATIVEINT|} pps () 306 | | STRING -> {%fmt_pf|sentinel_GENERIC|} pps () 307 | | ARRAY ty -> {%fmt_pf|sentinel_ARRAY<$(ty | convrec)>|} pps () 308 | | TUPLE [t1;t2] -> {%fmt_pf|sentinel_TUPLE2<$(t1 | convrec),$(t2 | convrec)>|} pps () 309 | | TUPLE [t1;t2;t3] -> {%fmt_pf|sentinel_TUPLE3<$(t1 | convrec),$(t2 | convrec),$(t3 | convrec)>|} pps () 310 | | TUPLE _ -> failwith "mltype_to_sentineltype(tuple length > 2): unimplemented" 311 | | OPTION ty -> {%fmt_pf|sentinel_OPTION<$(ty | convrec)>|} pps () 312 | | OTHER id -> 313 | let e = TMAP.lookup_mlid tmap id in 314 | match e.TMAP.stanza with 315 | STRUCT _ -> {%fmt_pf|sentinel_GENERIC|} pps () 316 | | TYPEDEF { mltype = ABSTRACT _ } -> {%fmt_pf|sentinel_GENERIC|} pps () 317 | | TYPEDEF _ -> convrec pps e.TMAP.concretetype 318 | in 319 | {%fmt_str|$(mlty | convrec)|} 320 | 321 | let pp_ml_field_decl tmap pps (cty,n) = {%fmt_pf|$(n) : $(ctype2concretetype tmap cty | MLTYPE.ppml_concrete) ;|} pps () 322 | 323 | let pp_cpp_field_decl pps (cty, n) = {%fmt_pf| $(cty | ppcpp_cpptype) $(n) ;|} pps () 324 | 325 | let expand_struct tmap { Struct.modname; name ; members ; code } = 326 | let cppid = CPPID.mk {%fmt_str|$(modname)_$(name)|} in 327 | let mlid = MLID.mk {%fmt_str|$(modname).$(name)|} in 328 | [ 329 | ML(PROLOGUE, 330 | {%fmt_str| 331 | module $(modname) = struct 332 | type t = { ${members | list ~sep:(const string "\n\t") (pp_ml_field_decl tmap)} 333 | } 334 | end 335 | |} 336 | ) ; 337 | MLI(PROLOGUE, 338 | {%fmt_str| 339 | module $(modname) : sig 340 | type t = { ${members | list ~sep:(const string "\n\t") (pp_ml_field_decl tmap)} 341 | } 342 | end 343 | |} 344 | ) ; 345 | CPP(PROLOGUE, 346 | {%fmt_str| 347 | #ifndef $(modname)_$(name)_DEFINED 348 | #define $(modname)_$(name)_DEFINED 349 | struct $(modname)_$(name) { 350 | ${ members | list ~sep:(const string "\n\t") pp_cpp_field_decl } 351 | ${ code } 352 | } ; 353 | #endif 354 | |} 355 | ) ; 356 | (let ml2c_field pps (i, (cty, n)) = 357 | let mlty = ctype2concretetype tmap cty in 358 | let sentinel_type = concretetype_to_sentineltype tmap mlty in 359 | {%fmt_pf|ml2c(${sentinel_type}(), Field(_mlvalue,${ i|%d }), &(_cvaluep->${n}));|} pps () in 360 | ML2CPP(ID cppid, 361 | {%fmt_str|${members | fmt_list_i ~sep:(const string "\n ") ml2c_field}|} 362 | )) ; 363 | (let c2ml_field pps (i, (cty, n)) = 364 | let mlty = ctype2concretetype tmap cty in 365 | let sentinel_type = concretetype_to_sentineltype tmap mlty in 366 | {%fmt_pf|Store_field(_mlvalue, ${ i|%d }, c2ml(${sentinel_type}(), _cvalue.${n}));|} pps () in 367 | CPP2ML(ID cppid, 368 | {%fmt_str| 369 | _mlvalue = caml_alloc(${List.length members|%d}, 0) ; 370 | ${ members| fmt_list_i ~sep:(const string "\n ") c2ml_field }|} 371 | )) ; 372 | ] 373 | 374 | type t = { 375 | stanzas : stanza_t list; 376 | } [@@deriving located_sexp, show] 377 | 378 | 379 | module CPP = struct 380 | 381 | let prologues t = 382 | List.concat (List.map (function 383 | | CPP(PROLOGUE, s) -> [s] 384 | | _ -> []) t.stanzas) 385 | 386 | let epilogues t = 387 | List.concat (List.map (function 388 | | CPP(EPILOGUE, s) -> [s] 389 | | _ -> []) t.stanzas) 390 | 391 | let gen_stanza_forwards tmap pps = function 392 | | (CPP _| ML _ | MLI _| FOREIGN _) -> () 393 | | TYPEDEF t -> 394 | {%fmt_pf|typedef $(t.cpptype | ppcpp_cpptype) $(t.name); 395 | |} pps () 396 | 397 | | CPP2ML(cty, _) -> 398 | let mlty = ctype2concretetype tmap cty in 399 | let sentinel_type = concretetype_to_sentineltype tmap mlty in 400 | {%fmt_pf|value c2ml(const $(sentinel_type)& _s0, const $(cty | ppcpp_cpptype)& _cvalue); 401 | |} pps () 402 | | ML2CPP(cty, _) -> 403 | let mlty = ctype2concretetype tmap cty in 404 | let sentinel_type = concretetype_to_sentineltype tmap mlty in 405 | {%fmt_pf|void ml2c(const $(sentinel_type)& _s0, const value _mlvalue, $(cty | ppcpp_cpptype) *_cvaluep); 406 | |} pps () 407 | 408 | 409 | let arg_snippets tmap (cty, cid) = 410 | let ml_cty = ctype2concretetype tmap cty in 411 | let formal_varname = Printf.sprintf "_mlv_%s" cid in 412 | let argdecl = Printf.sprintf "value %s" formal_varname in 413 | (argdecl, formal_varname) 414 | 415 | let gen_stanza_bodies tmap pps = function 416 | | (ML _ | MLI _| TYPEDEF _) -> () 417 | | CPP(HERE, s) -> Fmt.(pf pps "%s" s) 418 | | CPP _ -> () 419 | | CPP2ML(cty, body) -> 420 | let mlty = ctype2concretetype tmap cty in 421 | let sentinel_type = concretetype_to_sentineltype tmap mlty in 422 | {%fmt_pf|value c2ml(const $(sentinel_type)& _s0, const $(cty | ppcpp_cpptype)& _cvalue) { 423 | CAMLparam0(); 424 | CAMLlocal1(_mlvalue); 425 | $(body) ; 426 | CAMLreturn(_mlvalue); 427 | } 428 | |} pps () 429 | 430 | | ML2CPP(cty, body) -> 431 | let mlty = ctype2concretetype tmap cty in 432 | let sentinel_type = concretetype_to_sentineltype tmap mlty in 433 | {%fmt_pf|void ml2c(const $(sentinel_type)& _s0, const value _mlvalue, $(cty | ppcpp_cpptype) *_cvaluep) { 434 | $(body) ; 435 | } 436 | |} pps () 437 | 438 | | FOREIGN(rtys, fname, argformals, body) -> 439 | let ml_rtyl = List.map (ctype2concretetype tmap) rtys in 440 | let converted_l = List.map (arg_snippets tmap) argformals in 441 | let argdecl_l = List.map fst converted_l in 442 | let param_l = List.map snd converted_l in 443 | let args = List.map (fun (cty,cid) -> 444 | (cty, cid, Printf.sprintf "_mlv_%s" cid) 445 | ) argformals in 446 | let pp_arg_conversion pps (cty, cid, mlid) = 447 | {%fmt_pf|$(cty | ppcpp_cpptype) $(cid); 448 | ml2c(${concretetype_to_sentineltype tmap (ctype2concretetype tmap cty)}(), $(mlid), &$(cid));|} pps () in 449 | 450 | let pp_rty_decls_i pps (i, cty) = 451 | {%fmt_pf|$(cty | ppcpp_cpptype) _res$(i | %d);|} pps () in 452 | 453 | let res_var (i,rty) = {%fmt_str|_res$(i|%d)|} in 454 | 455 | let res_vars = List.mapi (fun i _ -> Printf.sprintf "_res%d" i) ml_rtyl in 456 | let sentinel_exprs = List.map (fun rty -> Printf.sprintf "%s()" (concretetype_to_sentineltype tmap rty)) ml_rtyl in 457 | let res_assignment = 458 | if ml_rtyl = [] then 459 | Fmt.(const string "") 460 | else 461 | {%fmt_pf|_mlv_res = c2ml(${sentinel_exprs@res_vars | list ~sep:(const string ", ") string});|} in 462 | 463 | 464 | {%fmt_pf|extern \"C\" value $(fname)(${argdecl_l | list ~sep:(const string ", ") string}) { 465 | CAMLparam${List.length argformals | %d}(${param_l | list ~sep:(const string ", ") string}); 466 | CAMLlocal1 (_mlv_res) ; 467 | /* ML->C*/ 468 | ${args | list ~sep:(const string "\n\t") pp_arg_conversion} 469 | ${rtys | fmt_list_i ~sep:(const string "\n\t") pp_rty_decls_i} 470 | /* BODY */ 471 | ${body} 472 | /* C->ML*/ 473 | ${ () | res_assignment } 474 | CAMLreturn(_mlv_res) ; 475 | } 476 | |} pps () 477 | 478 | let gen tmap pps t = 479 | {%fmt_pf| 480 | #include 481 | #include 482 | #include 483 | #include 484 | #include 485 | #include 486 | #include 487 | #include 488 | #include 489 | ${ prologues t | list ~sep:(const string "") string } 490 | ${ t.stanzas | list ~sep:(const string "") (gen_stanza_forwards tmap) } 491 | #include "cppffi.inc" 492 | ${ t.stanzas | list ~sep:(const string "") (append (gen_stanza_bodies tmap) (const string "\n")) } 493 | ${ epilogues t | list ~sep:(const string "") string } 494 | |} pps () 495 | 496 | end 497 | 498 | module ML = struct 499 | 500 | let prologues t = 501 | List.concat (List.map (function 502 | | ML(PROLOGUE, s) -> [s] 503 | | _ -> []) t.stanzas) 504 | 505 | let epilogues t = 506 | List.concat (List.map (function 507 | | ML(EPILOGUE, s) -> [s] 508 | | _ -> []) t.stanzas) 509 | 510 | let pp_typedecl pps e = 511 | let open TMAP in 512 | match e.mltype with 513 | | MLTYPE.CONCRETE s -> {%fmt_pf|$(e.mlid | MLID.pp) = $(s | MLTYPE.ppml_concrete)|} pps () 514 | | ABSTRACT s -> {%fmt_pf|$(s)|} pps () 515 | 516 | let gen_typedecls ~ml pps tmap = 517 | {%fmt_pf| ${ if ml then "module Types = struct\n" else "module Types : sig\n" } 518 | type ${TMAP.typedefs tmap | list ~sep:(const string "\nand ") pp_typedecl} 519 | end 520 | |} pps () 521 | 522 | let pp_argformals tmap pps argformals = 523 | match argformals with 524 | | [] -> {%fmt_pf|unit|} pps () 525 | | l -> 526 | let l = List.map fst l in 527 | {%fmt_pf|${List.map (ctype2concretetype tmap) l | list ~sep:(const string " -> ") MLTYPE.ppml_concrete}|} pps () 528 | 529 | let pp_rtys tmap pps rtys = 530 | match rtys with 531 | [] -> {%fmt_pf|unit|} pps () 532 | | l -> 533 | {%fmt_pf|${List.map (ctype2concretetype tmap) l | list ~sep:(const string " * ") MLTYPE.ppml_concrete}|} pps () 534 | 535 | let gen_stanza tmap pps = function 536 | | (CPP _|CPP2ML _|ML2CPP _|MLI _) -> () 537 | | TYPEDEF _ -> () 538 | | ML(HERE, s) -> Fmt.(pf pps "%s" s) 539 | | ML _ -> () 540 | | FOREIGN(rtys, name, argformals, _) -> 541 | {%fmt_pf|external $(name) : $(argformals | pp_argformals tmap) -> $(rtys | pp_rtys tmap) 542 | ="$(name)" 543 | |} pps () 544 | 545 | let gen (tmap : TMAP.t) pps t = 546 | {%fmt_pf| 547 | ${ prologues t | list ~sep:(const string "") string } 548 | ${ tmap | gen_typedecls ~ml:true } 549 | open Types 550 | ${ t.stanzas | list ~sep:(const string "") (gen_stanza tmap) } 551 | ${ epilogues t | list ~sep:(const string "") string } 552 | |} pps () 553 | end 554 | 555 | module MLI = struct 556 | let prologues t = 557 | List.concat (List.map (function 558 | | MLI(PROLOGUE, s) -> [s] 559 | | _ -> []) t.stanzas) 560 | 561 | let epilogues t = 562 | List.concat (List.map (function 563 | | MLI(EPILOGUE, s) -> [s] 564 | | _ -> []) t.stanzas) 565 | 566 | let gen_typedecls = ML.gen_typedecls ~ml:false 567 | let gen_stanza = ML.gen_stanza 568 | 569 | let gen tmap pps t = 570 | {%fmt_pf| 571 | ${ prologues t | list ~sep:(const string "") string } 572 | ${ tmap | gen_typedecls } 573 | open Types 574 | ${ t.stanzas | list ~sep:(const string "") (gen_stanza tmap) } 575 | ${ epilogues t | list ~sep:(const string "") string } 576 | |} pps () 577 | 578 | end 579 | --------------------------------------------------------------------------------