├── .gitignore ├── .ocamlformat ├── CHANGES.md ├── LICENSE.txt ├── Makefile ├── README.md ├── docs ├── _config.yml ├── constants.md ├── enums.md ├── foreign_value.md ├── functions.md ├── header.md ├── index.md ├── opaque.md ├── scope.md ├── static_callbacks.md └── structures.md ├── dune ├── dune-project ├── examples ├── Makefile ├── dune-project │ ├── Makefile │ ├── README.md │ ├── cstubs-demo.opam │ ├── dune-project │ └── src │ │ ├── bin │ │ ├── dune │ │ └── main.ml │ │ └── lib │ │ ├── config │ │ ├── discover.ml │ │ └── dune │ │ ├── dune │ │ └── namelib.c.ml ├── ftw.c.ml ├── getpwent.c.ml ├── inline.c.ml └── time.c.ml ├── ppx_cstubs.opam └── src ├── bin ├── config │ ├── config.ml │ └── dune ├── dune ├── exec.ml └── exec.mli ├── custom ├── dune ├── ppx_cstubs_custom.cppo.ml └── ppx_cstubs_custom.mli ├── internal ├── attributes.ml ├── attributes.mli ├── c_compile.ml ├── c_compile.mli ├── ctypes_type_printing_fake.ml ├── ctypes_type_printing_fake.mli ├── dune ├── evil_hack.ml ├── extract_c.ml ├── extract_c.mli ├── extract_c_ml.ml ├── extract_c_ml.mli ├── gen_c.ml ├── gen_c.mli ├── gen_ml.ml ├── gen_ml.mli ├── inline_lexer.mli ├── inline_lexer.mll ├── keywords.ml ├── lconst.ml ├── lconst.mli ├── main.ml ├── main.mli ├── marshal_types.ml ├── merlin_state.ml ├── merlin_state.mli ├── mparsetree.ml ├── myconst.ml ├── ocaml_config.ml ├── ocaml_config.mli ├── options.ml ├── options.mli ├── ppx_main.ml ├── ppx_main.mli ├── ppxc__script.ml ├── ppxc__script_real.ml ├── ppxc__script_real.mli ├── ptree.ml ├── ptree.mli ├── run.ml ├── run.mli ├── script_result.ml ├── script_result.mli ├── std.ml ├── std.mli ├── toplevel.cppo.ml ├── toplevel.mli ├── uniq_ids.ml ├── uniq_ids.mli ├── uniq_ref.ml └── uniq_ref.mli ├── merlin ├── dune └── ppx_cstubs_merlin.ml └── runtime ├── dune ├── ppx_cstubs.ml ├── ppx_cstubs_internals.ml └── ppx_cstubs_internals.mli /.gitignore: -------------------------------------------------------------------------------- 1 | \#*\# 2 | .\#* 3 | *~ 4 | *.a 5 | *.o 6 | *.dll 7 | *.so 8 | *.cmi 9 | *.cmx 10 | *.cmxs 11 | *.cmxa 12 | *.cmo 13 | *.cma 14 | *.cmt 15 | *.opt 16 | *.run 17 | *.cmti 18 | *.annot 19 | *.exe 20 | *.dll 21 | *.lib 22 | *.obj 23 | *.log 24 | *.cache 25 | *.status 26 | *.omc 27 | *.out 28 | *.tar.gz 29 | *.tar.xz 30 | *.tar 31 | *.idoc 32 | .merlin 33 | ppx_cstubs.install 34 | /.omakedb* 35 | _build/ 36 | src/inline_lexer.ml 37 | src/toplevel.ml 38 | src/ppx_cstubs 39 | test/generated_* 40 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | margin=80 2 | break-sequences=true 3 | break-cases=fit 4 | doc-comments=before 5 | field-space=loose 6 | let-and=sparse 7 | infix-precedence=parens 8 | cases-exp-indent=2 9 | type-decl=sparse 10 | wrap-comments=false 11 | break-infix=fit-or-vertical 12 | break-string-literals=never 13 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | 0.7.0 (13/03/2022) 2 | ------------------ 3 | 4 | - support for OCaml 4.14.0 5 | 6 | - better support for ancient C compilers like msvc 7 | 8 | - easier handling when a C++ compiler must be used, see the new `-cxx` 9 | command-line flag. Compatibility with varios C++ compilers has also 10 | been improved. 11 | 12 | 13 | 0.6.1.2 (10/08/2021) 14 | ------------------ 15 | 16 | - compatibility fix for integers 0.5.0 17 | 18 | 19 | 0.6.1.1 (19/02/2021) 20 | ------------------ 21 | 22 | - small compatibility fix for ctypes 0.18.0 23 | 24 | 25 | 0.6.1 (07/02/2021) 26 | ------------------ 27 | 28 | - support for ppxlib >= 0.22.0 29 | 30 | 31 | 0.6.0 (07/02/2021) 32 | ------------------ 33 | 34 | - first version that depends on ppxlib 35 | 36 | 37 | 0.5.0 (07/02/2021) 38 | ------------------ 39 | 40 | - support for OCaml 4.12.0+beta1 41 | 42 | - minor changes in order to be compatible with the upcoming 0.6.0 43 | version that is based on ppxlib instead of 44 | ocaml-migrate-parstree.1.x 45 | 46 | 47 | 0.4.3 (26/07/2020) 48 | ------------------ 49 | 50 | - support for OCaml 4.11.0+beta 51 | 52 | - better dune support for ppx_cstubs.merlin 53 | 54 | 55 | 0.4.1 (13/05/2020) 56 | ------------------ 57 | 58 | - bump internally used AST version to 4.11 59 | 60 | - fix linking for older OCaml versions 61 | 62 | 63 | 0.4.0 (30/04/2020) 64 | ------------------ 65 | 66 | - [Generalized open 67 | statements](https://ocaml.org/releases/4.10/htmlman/generalizedopens.html) 68 | are now used to hide ppx_cstubs's boilerplate code from the 69 | interface, if OCaml 4.08 or later is used. Autogenerated interface 70 | files (`ocamlc -i`/`cmitomli`) that are created with these versions 71 | of OCaml are also valid for previous OCaml versions, but not vice 72 | versa. 73 | 74 | - bump internally used AST version to 4.10 75 | 76 | 77 | 0.3.0 (26/01/2020) 78 | ------------------ 79 | 80 | - support for OCaml 4.10.0+beta1 81 | 82 | - fix merlin mode 83 | 84 | - bump internally used AST version to 4.09 85 | 86 | - let-bound constants 87 | 88 | 89 | 0.2.1 (12/08/2019) 90 | ------------------ 91 | 92 | - support OCaml 4.09.0+beta1 93 | 94 | - bump internally used AST version from 4.06 to 4.08 95 | 96 | 97 | 0.2.0 (13/07/2019) 98 | ------------------ 99 | 100 | - ppx_cstubs now compiles with OCaml 4.08.0. 101 | 102 | - Add support for static callbacks as an alternative to the libffi 103 | based `Foreign.funptr`. 104 | 105 | - Allow to use abstract values (similar to `Ctypes.abstract`) and 106 | integers of unknown size and signedness. 107 | 108 | 109 | 0.1.0 (24/04/2019) 110 | ------------------ 111 | 112 | - First initial release 113 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: default build clean install uninstall #test 2 | 3 | default: build 4 | 5 | build: 6 | @dune build 7 | 8 | clean: 9 | @dune clean 10 | 11 | install: build 12 | @dune install 13 | 14 | uninstall: 15 | @dune uninstall 16 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ppx_cstubs 2 | 3 | a ppx-based preprocessor for quick and dirty stub generation with 4 | [ctypes](https://github.com/ocamllabs/ocaml-ctypes). 5 | 6 | ppx_cstubs creates two files from a single ml file: a file with c stub 7 | code and a ml file with all additional boilerplate code. 8 | 9 | The preprocessor abuses `external` declarations that are not used in 10 | regular code. Instead of OCaml types, values of type 11 | [Ctypes.typ](https://github.com/ocamllabs/ocaml-ctypes/blob/066cf8fa0039fa03287fcf784533e7c0e460fc54/src/ctypes/ctypes_types.mli#L17) 12 | are used inside the declarations: 13 | 14 | ```c 15 | /* function prototypes */ 16 | int puts(const char *s); 17 | char *getenv(const char *name); 18 | ``` 19 | 20 | To access these functions from OCaml, you simply repeat the prototype in 21 | OCaml syntax and with appropriate `Ctypes.typ` values: 22 | 23 | ```ocaml 24 | external puts: string -> int = "puts" 25 | external getenv: string -> string_opt = "getenv" 26 | 27 | let () = (* regular code *) 28 | match getenv "HOME" with 29 | | None -> () 30 | | Some s -> 31 | let i = puts s in 32 | ... 33 | ``` 34 | 35 | To generate your stub and ml file: 36 | 37 | ```bash 38 | ppx_cstubs myfile.c.ml -o-c myfile_stubs.c -o-ml myfile.ml 39 | ``` 40 | 41 | 42 | ## user guide 43 | 44 | There is now also [user guide](https://fdopen.github.io/ppx_cstubs/) (work in progress). 45 | 46 | 47 | ## inline code 48 | 49 | As a slight extension of the scheme above, you can also label your 50 | parameters, annotate external (`%c`) and write a few lines of C code: 51 | 52 | ```ocaml 53 | external%c puts_flush : str:string -> bool = {| 54 | int r = puts($str); 55 | if ( r < 0 ){ 56 | return false; 57 | } 58 | r = fflush(stdout); 59 | return (r == 0); /* `return` is mandatory, unless your function is void */ 60 | |} [@@ release_runtime_lock] 61 | 62 | let _ : bool = puts_flush ~str:"Hello World" 63 | ``` 64 | 65 | This way several switches between the OCaml runtime and C are 66 | avoided. Intermediate results can be stored on the C stack instead of 67 | the heap; constant parameters don't need to allocated inside OCaml, 68 | just to pass them to the C function, and so forth. 69 | 70 | 71 | ## scope and custom types 72 | 73 | The types inside external declarations have their own environment. 74 | Normal let-bindings or statements like `open` won't have any affect on 75 | them. (Ppx rewriters don't have access to types and similar 76 | information). 77 | 78 | By default only types referenced in 79 | [Ctypes_types.TYPE](http://ocamllabs.io/ocaml-ctypes/Ctypes_types.TYPE.html) 80 | are accessible. It's however possible to create new types that are 81 | then available inside your regular program and inside external 82 | declarations: 83 | 84 | ```ocaml 85 | let%c int_as_bool = (* all bindings must be of type Ctypes.typ *) 86 | view 87 | int (* no access to your regular scope inside the expression *) 88 | ~read:(fun x -> if x = 0 then false else true) 89 | ~write:(fun x -> if x = false then 0 else 1) 90 | 91 | (* int_as_bool is available in the regular scope *) 92 | let ibptr = Ctypes.allocate int_as_bool true 93 | 94 | (* function prototype in c: 95 | void *bsearch(const void *key, const void *base, 96 | size_t nmemb, size_t size, 97 | int (*compar)(const void *, const void *)); 98 | *) 99 | let%c compar = funptr (ptr void @-> ptr void @-> returning int) 100 | let%c ptr_void = ptr void; 101 | external bsearch: 102 | key: ptr_void 103 | -> base: ptr_void 104 | -> nmemb: size_t 105 | -> size: size_t 106 | -> compar 107 | -> ptr_void = "bsearch" 108 | 109 | (* alternative syntax: *) 110 | external bsearch: 111 | key:void ptr 112 | -> base: void ptr 113 | -> nmemb: size_t 114 | -> size: size_t 115 | -> (void ptr -> void ptr -> int) funptr 116 | -> void ptr = "bsearch" 117 | (* other pseudo types: ptr_opt, funptr_opt, static_funptr *) 118 | ``` 119 | 120 | ## compiling 121 | 122 | The generated code must be linked against the findlib package `ppx_cstubs`. 123 | 124 | 125 | ## merlin 126 | 127 | `ppx_cstubs.merlin` can be used to inform merlin about the special 128 | syntax. It produces a correctly typed syntax tree faster than the real 129 | preprocessor. (The generated code is however semantically incorrect 130 | and would quit the program with an exception at runtime.) 131 | 132 | ## details 133 | 134 | ### enums 135 | 136 | Enumerations can be written as sum types with only constants - with 137 | special annotations, if it's required by the OCaml syntax: 138 | 139 | ```c 140 | enum day {Mon, Tue, Wed, Thur, Fri, Sat, Sun}; 141 | typedef enum {working = 1, failed = 0} State; 142 | ``` 143 | 144 | ```ocaml 145 | type%c day = 146 | | Mon 147 | | Tue 148 | | Wed 149 | | Thur 150 | | Fri 151 | | Sat 152 | | Sun 153 | 154 | type%c state = 155 | | Working [@cname "working"] 156 | | Failed [@cname "failed"] 157 | [@@ cname "State"] [@@ typedef] 158 | ``` 159 | 160 | ### structs 161 | 162 | There is also a special syntax for creating and accessing c structs: 163 | 164 | ```c 165 | struct point { 166 | int x; 167 | int y; 168 | }; 169 | 170 | /* example functions */ 171 | struct point add (struct point a, struct point b) { 172 | struct point res; 173 | res.x = a.x + b.x ; 174 | res.y = a.y + b.y ; 175 | return res; 176 | } 177 | 178 | void add_ptr(struct point *a, struct point *b, struct point *res){ 179 | res->x = a->x + b->x; 180 | res->y = a->y + b->y; 181 | } 182 | ``` 183 | 184 | ```ocaml 185 | 186 | type%c point = { 187 | x: int; 188 | y: int; 189 | } 190 | 191 | (* syntax for something along the following lines: 192 | let point = Ctypes.structure "point" 193 | let x = Ctypes.field point "x" Ctypes.int 194 | let y = Ctypes.field point "y" Ctypes.int 195 | let () = Ctypes.seal point *) 196 | 197 | let () = 198 | let p1 = Ctypes.make point in 199 | Ctypes.setf p1 x 1; 200 | Ctypes.setf p1 y 2; 201 | let p2 = Ctypes.make point in 202 | Ctypes.setf p2 x 3; 203 | Ctypes.setf p2 y 4; 204 | let p3 = add p1 p2 in 205 | Printf.printf "add (simple): %d;%d\n" (getf p3 x) (getf p3 y); 206 | let res = Ctypes.make point in 207 | let () = add_ptr (Ctypes.addr p1) (Ctypes.addr p2) (Ctypes.addr res) in 208 | Printf.printf 209 | "add_ptr (simple): %d;%d\n" 210 | (Ctypes.getf res x) 211 | (Ctypes.getf res y) 212 | ``` 213 | 214 | It's also possible to convert OCaml records to c structs on the fly by 215 | annotating the type declaration with `[@@ as_record]`: 216 | 217 | ```ocaml 218 | 219 | type%c point = { 220 | x: int; 221 | y: int; 222 | } [@@ as_record] 223 | (* [@@ with_record] will create two types: point and point_record *) 224 | 225 | external add: point -> point -> point = "add" 226 | external add_ptr: point ptr -> point ptr -> point ptr -> void = "add_ptr" 227 | 228 | let () = 229 | let p1 = { x = 1 ; y = 3} in 230 | let p2 = { x = 2 ; y = 4} in 231 | let p3 = add p1 p2 in 232 | Printf.printf "add (record): %d;%d\n" p3.x p3.y; 233 | let p1_ptr = allocate point p1 in 234 | let p2_ptr = allocate point p2 in 235 | let res_ptr = allocate_n point ~count:1 in 236 | let () = add_ptr p1_ptr p2_ptr res_ptr in 237 | let res = !@ res_ptr in 238 | Printf.printf "add_ptr (record) %d;%d\n" res.x res.y 239 | ``` 240 | 241 | If the struct contains pointers, you have to be careful that the 242 | garbage collector doesn't free the memory behind your back. The 243 | generated code for automatic boxing and unboxing can't handle 244 | such subtle issues for you. 245 | 246 | 247 | ### unions 248 | 249 | unions can declared in a similar way: 250 | 251 | ```c 252 | typedef union { 253 | long l; 254 | double d; 255 | } data; 256 | ``` 257 | 258 | ```ocaml 259 | type%c_union data = { 260 | l: long; 261 | d: double; 262 | } [@@ typedef] 263 | ``` 264 | 265 | 266 | ### constants 267 | 268 | Compile-time constants can be retrieved from C code and inserted it 269 | into your OCaml code at an arbitrary location: 270 | 271 | ```c 272 | #define FOOBAR 30 273 | ``` 274 | 275 | ```ocaml 276 | let _FOOBAR = [%c constant "FOOBAR" camlint] 277 | let () = 278 | let _FOOBAR_X3 = 3 * [%c constant "FOOBAR" camlint] in 279 | ... 280 | ``` 281 | 282 | Note: Const-qualified objects (of any type) are not constants. It only 283 | works for enums and constant expressions that are usually exposed through 284 | macros. 285 | 286 | Only integer and string literals can be retrieved. Integer values are 287 | checked for overflows that will trigger an error at compile time. Try 288 | to compile your code on a 32-bit system and under a different platform 289 | before you release it 😉 290 | 291 | Values of any other kinds can be imported at runtime with `[%c 292 | foreign_value ... ]`, as explained below. 293 | 294 | 295 | ### c headers 296 | 297 | The necessary C headers files can be included through the `header` 298 | pseudo-function. The code will be removed from the generated ml file 299 | and only appear in the c file: 300 | 301 | ```ocaml 302 | let%c () = header {| 303 | #include 304 | |} 305 | external puts: string -> int = "puts" 306 | 307 | (* You can also add arbitrary c code there: *) 308 | let%c () = header {| 309 | #define put_own(s) \ 310 | ... 311 | |} 312 | 313 | external puts_own: string -> int = "puts_own" 314 | ``` 315 | 316 | The generated c file is of course flat and without any scope. It might be 317 | good idea to only add a single `let%c () header {| ... |}` statement 318 | at the top of your file and don't spread several statements across 319 | your file or in different modules. Otherwise a casual reader of your 320 | code might draw a wrong conclusion ... 321 | 322 | ### pointers to C objects 323 | 324 | Pointers to C objects can be retrieved with a function similar to 325 | [Foreign.foreign_value](https://github.com/ocamllabs/ocaml-ctypes/blob/e192f74421c2755c51ba90dfac19b9593fa72df9/src/ctypes-foreign-unthreaded/foreign.mli#L44): 326 | 327 | ```c 328 | extern char **environ; /* see `man 7 environ` */ 329 | ``` 330 | 331 | ```ocaml 332 | let () = 333 | let environ = [%c foreign_value "environ" (ptr string_opt)] in 334 | let rec iter env = 335 | match !@env with 336 | | None -> (); 337 | | Some s -> 338 | print_endline s; 339 | iter (env +@ 1) 340 | in 341 | iter !@environ 342 | ``` 343 | 344 | This feature can also be used to import const qualified objects or 345 | double literals at runtime: 346 | 347 | ```ocaml 348 | let%c () = header {| 349 | #include 350 | static const double m_2_sqrtpi = M_2_SQRTPI; 351 | |} 352 | 353 | let _M_2_SQRTPI = !@ [%c foreign_value "m_2_sqrtpi" double] 354 | ``` 355 | 356 | ### attributes for external declarations 357 | 358 | External declarations can be annotated with three different 359 | attributes: 360 | 361 | ```ocaml 362 | external foo : void -> bar = "cfoo" [@@ release_runtime_lock] [@@ return_errno] [@@ noalloc] 363 | ``` 364 | 365 | - **release_runtime_lock**: If `[@@ release_runtime_lock]` is 366 | specified, the OCaml runtime lock should be released during the call 367 | to the C function, allowing other threads to run. You can't pass 368 | arguments, that point to the OCaml heap (like `Ctypes.ocaml_string`) 369 | to such functions. 370 | - **return_errno**: If `[@@ return_errno]` is given, the function 371 | returns a pair as result. The first value is the regular result, the 372 | second value is the errno code of type `Signed.sint`. 373 | - **noalloc**: If the C function doesn't interact with the OCaml 374 | runtime, e.g. by calling a callback you have provided, you can add 375 | `[@@ noalloc]` to the declaration. The generated code will be 376 | slightly faster. Note: `noalloc` is here intended as an attribute 377 | for your c function, not for the generated stub code and the c 378 | function. You can add it, even if you (believe to) know, that the 379 | generated stub code must allocated memory in the OCaml heap. The 380 | generated code will still differ. 381 | -------------------------------------------------------------------------------- /docs/_config.yml: -------------------------------------------------------------------------------- 1 | remote_theme: fdopen/just-the-docs 2 | search_enabled: true 3 | 4 | plugins: 5 | - jekyll-remote-theme 6 | - jekyll-relative-links 7 | 8 | aux_links: 9 | "ppx_cstubs on github": 10 | - "//github.com/fdopen/ppx_cstubs" 11 | 12 | relative_links: 13 | enabled: true 14 | 15 | permalink: pretty 16 | 17 | sass: 18 | style: compressed 19 | 20 | compress_html: 21 | clippings: all 22 | comments: all 23 | endings: all 24 | startings: [] 25 | blank_lines: false 26 | profile: false 27 | -------------------------------------------------------------------------------- /docs/constants.md: -------------------------------------------------------------------------------- 1 | --- 2 | layout: default 3 | title: Constants 4 | nav_order: 6 5 | --- 6 | 7 | # Constants 8 | 9 | Compile-time constants can be retrieved from C code and inserted it 10 | into your OCaml code at an arbitrary location: 11 | 12 | ```c 13 | #define FOOBAR 30 14 | ``` 15 | 16 | ```ocaml 17 | let _FOOBAR = [%c constant "FOOBAR" camlint] 18 | let () = 19 | let _FOOBAR_X3 = 3 * [%c constant "FOOBAR" camlint] in 20 | ... 21 | ``` 22 | 23 | Note: Const-qualified objects (of any type) are not constants. It only 24 | works across all compilers for enums and constant expressions that are 25 | usually exposed through macros. 26 | 27 | Only integers and string literals can be retrieved. Integer values are 28 | checked for over- and underflows that trigger failures at compile 29 | time. Try to compile your code on a 32-bit system and under a 30 | different platform before you release it 😉. If you don't care about 31 | overflows, you can just cast the value to the appropriate type: `[%c 32 | constant "(int)BAR" int]`. 33 | 34 | Values of any other type can be imported at runtime with [`[%c foreign_value ...]`](./foreign_value.md). 35 | 36 | ## Let-bound Constants 37 | 38 | Sometimes it is necessary to use constants already for defining ctypes expression, e.g. 39 | 40 | ```c 41 | struct ms { 42 | int x; 43 | char y[YLENGTH]; 44 | }; 45 | ``` 46 | 47 | Therefore, another syntax is also supported: 48 | 49 | ```ocaml 50 | let%c _YLENGTH = constant "YLENGTH" camlint 51 | let%c char_y_ar = array _YLENGTH char 52 | type%c ms = { 53 | x : int; 54 | y : char_y_ar; 55 | } 56 | ``` 57 | 58 | There are however several disadvantages associated with this syntax: 59 | * it only works for integers and not for string literals 60 | * When you are cross-compiling, you can only extract integers that are 61 | representable in the build and target platform. Normally only the 62 | target platform matters 63 | * code generation is slower and the error messages are less accurate 64 | -------------------------------------------------------------------------------- /docs/enums.md: -------------------------------------------------------------------------------- 1 | --- 2 | layout: default 3 | title: Enum Types 4 | nav_order: 3 5 | --- 6 | 7 | # Enum Types 8 | 9 | Enumerations can be written as sum types with only constants: 10 | 11 | ```c 12 | enum day {Mon, Tue, Wed, Thur, Fri, Sat, Sun}; 13 | ``` 14 | 15 | ```ocaml 16 | type%c day = 17 | | Mon 18 | | Tue 19 | | Wed 20 | | Thur 21 | | Fri 22 | | Sat 23 | | Sun 24 | ``` 25 | 26 | In the above case an ordinary OCaml sum type named `day` will be created 27 | as well as a value `day` of type `day Ctypes.typ`. 28 | 29 | 30 | In some cases, further annotations are required due to the different 31 | syntax rules of OCaml and C: 32 | 33 | ```c 34 | typedef enum {working = 1, failed = 0} State; 35 | ``` 36 | 37 | ```ocaml 38 | type%c state = 39 | | Working [@cname "working"] 40 | | Failed [@cname "failed"] 41 | [@@cname "State"] [@@typedef] 42 | ``` 43 | 44 | If your function returns something else, e.g. `3` instead of `working` or 45 | `failed`, an exception would be thrown. You can suppress this 46 | behaviour by providing a custom "unexpected" function of type `int64 47 | -> your_type`: 48 | 49 | ```ocaml 50 | type%c state = 51 | | Working 52 | | Failed 53 | [@@unexpected fun x -> Printf.printf "oops, %Ld returned\n%!" x; Failed] 54 | ``` 55 | 56 | ## Bit Masks 57 | 58 | `[@@as_bitmask]` can be added to the type definition for functions that 59 | expect a bitwise-inclusive OR of enumeration constants (similar to 60 | [open](https://pubs.opengroup.org/onlinepubs/009695399/functions/open.html)): 61 | 62 | ```c 63 | enum foo { 64 | F1 = (1u << 0), 65 | F2 = (1u << 1), 66 | F3 = (1u << 2) 67 | }; 68 | ``` 69 | 70 | ```ocaml 71 | type%c foo = 72 | | F1 73 | | F2 74 | | F3 [@@as_bitmask] 75 | [@@ unexpected_bits fun (matched:foo list) (remainig_bits:int64) -> ... ] 76 | ``` 77 | 78 | In this case `foo` will be of type `foo list Ctypes.typ`. 79 | `[@@with_bitmask]` would create two values: `foo` of type `foo 80 | Ctypes.typ` and `foo_bitmask` of type `foo Ctypes.typ`. 81 | -------------------------------------------------------------------------------- /docs/foreign_value.md: -------------------------------------------------------------------------------- 1 | --- 2 | layout: default 3 | title: Pointers to C Objects 4 | nav_order: 8 5 | --- 6 | 7 | # Pointers to C Objects 8 | 9 | Pointers to C objects can be retrieved with a function similar to 10 | [Foreign.foreign_value](https://github.com/ocamllabs/ocaml-ctypes/blob/e192f74421c2755c51ba90dfac19b9593fa72df9/src/ctypes-foreign-unthreaded/foreign.mli#L44): 11 | 12 | ```c 13 | extern char **environ; /* see `man 7 environ` */ 14 | ``` 15 | 16 | ```ocaml 17 | let () = 18 | let environ = [%c foreign_value "environ" (ptr string_opt)] in 19 | let rec iter env = 20 | match !@env with 21 | | None -> (); 22 | | Some s -> 23 | print_endline s; 24 | iter (env +@ 1) 25 | in 26 | iter !@environ 27 | ``` 28 | 29 | This feature can also be used to import const qualified objects or 30 | double literals at runtime: 31 | 32 | ```ocaml 33 | let%c () = header {| 34 | #include 35 | static const double m_2_sqrtpi = M_2_SQRTPI; 36 | |} 37 | 38 | let _M_2_SQRTPI = !@ [%c foreign_value "m_2_sqrtpi" double] 39 | ``` 40 | -------------------------------------------------------------------------------- /docs/functions.md: -------------------------------------------------------------------------------- 1 | --- 2 | layout: default 3 | title: Calling C Functions 4 | nav_order: 2 5 | --- 6 | 7 | # Calling C Functions 8 | 9 | ppx\_cstubs abuses `external` declarations that are not used in regular 10 | code. Instead of OCaml types, values of type 11 | [Ctypes.typ](https://github.com/ocamllabs/ocaml-ctypes/blob/066cf8fa0039fa03287fcf784533e7c0e460fc54/src/ctypes/ctypes_types.mli#L17) 12 | are used inside the declarations: 13 | 14 | ```c 15 | /* function prototypes */ 16 | int puts(const char *s); 17 | char *getenv(const char *name); 18 | ``` 19 | 20 | To access these functions from OCaml, you simply repeat the prototypes in 21 | OCaml syntax with appropriate `Ctypes.typ` values: 22 | 23 | ```ocaml 24 | external puts: string -> int = "puts" 25 | external getenv: string -> string_opt = "getenv" 26 | 27 | let () = (* regular code *) 28 | match getenv "HOME" with 29 | | None -> () 30 | | Some s -> 31 | let i = puts s in 32 | ... 33 | ``` 34 | 35 | ## Attributes for External Declarations 36 | 37 | External declarations can be annotated with three different 38 | attributes: 39 | 40 | ```ocaml 41 | external foo : void -> bar = "cfoo" [@@ release_runtime_lock] [@@ return_errno] [@@ noalloc] 42 | ``` 43 | 44 | - **release_runtime_lock**: If `[@@ release_runtime_lock]` is 45 | specified, the OCaml runtime lock will be released during the call 46 | to the C function, allowing other threads to run. You can't pass 47 | arguments that point to the OCaml heap (like `Ctypes.ocaml_string`) 48 | to such functions. 49 | 50 | - **return_errno**: If `[@@ return_errno]` is given, the function 51 | returns a pair as result. The first value is the regular result, the 52 | second value is the errno code of type `Signed.sint`. 53 | 54 | - **noalloc**: If the C function doesn't interact with the OCaml 55 | runtime, e.g. by calling a function you have passed to C, you can 56 | add `[@@ noalloc]` to the declaration. The generated code will be 57 | slightly faster. Note: `noalloc` is here intended as an attribute 58 | for your C function, not for the generated stub code and the C 59 | function together. You can add it, even if you (believe to) know 60 | that the generated stub code has to allocate memory in the OCaml 61 | heap. The generated code will still differ. 62 | 63 | ## Pseudo-Types 64 | 65 | Inside external declarations (and similar locations like [struct 66 | definitions](./structures.md)) the following parameterized 67 | (pseudo)types can be used: 68 | 69 | * [ptr](https://github.com/ocamllabs/ocaml-ctypes/blob/b19b190ad5083d03130dd67508705da77c1c5089/src/ctypes/ctypes_types.mli#L177) 70 | * [ptr\_opt](https://github.com/ocamllabs/ocaml-ctypes/blob/b19b190ad5083d03130dd67508705da77c1c5089/src/ctypes/ctypes_types.mli#L181) 71 | * [funptr](https://github.com/ocamllabs/ocaml-ctypes/blob/b19b190ad5083d03130dd67508705da77c1c5089/src/ctypes-foreign-threaded/foreign.mli#L49) 72 | * [funptr\_opt](https://github.com/ocamllabs/ocaml-ctypes/blob/b19b190ad5083d03130dd67508705da77c1c5089/src/ctypes-foreign-threaded/foreign.mli#L80) 73 | * [static\_funptr](https://github.com/ocamllabs/ocaml-ctypes/blob/b19b190ad5083d03130dd67508705da77c1c5089/src/ctypes/ctypes_types.mli#L374) 74 | 75 | So instead of ... 76 | ```ocaml 77 | (* function prototype in c: 78 | void *bsearch(const void *key, const void *base, 79 | size_t nmemb, size_t size, 80 | int (*compar)(const void *, const void *)); 81 | *) 82 | let%c compar = funptr (ptr void @-> ptr void @-> returning int) 83 | let%c ptr_void = ptr void; 84 | external bsearch: 85 | key: ptr_void 86 | -> base: ptr_void 87 | -> nmemb: size_t 88 | -> size: size_t 89 | -> compar 90 | -> ptr_void = "bsearch" 91 | ``` 92 | ... one can also write: 93 | ```ocaml 94 | external bsearch: 95 | key:void ptr 96 | -> base: void ptr 97 | -> nmemb: size_t 98 | -> size: size_t 99 | -> (void ptr -> void ptr -> int) funptr 100 | -> void ptr = "bsearch" 101 | ``` 102 | 103 | ## Inline Code 104 | 105 | As a slight extension of the scheme above, you can also label your 106 | parameters, annotate external (`%c`) and write a few lines of C code: 107 | 108 | ```ocaml 109 | external%c puts_flush : str:string -> bool = {| 110 | int r = puts($str); /* to escape a regular dollar sign: $$ */ 111 | if ( r < 0 ){ 112 | return false; 113 | } 114 | r = fflush(stdout); 115 | return (r == 0); /* `return` is mandatory, unless your function is void */ 116 | |} [@@ release_runtime_lock] 117 | 118 | let _ : int = puts_flush ~str:"Hello World" 119 | ``` 120 | 121 | This way several switches between the OCaml runtime and C are avoided, 122 | which has various advantages: 123 | 124 | - Intermediate results can be stored on the C stack. They don't need 125 | to be allocated on the heap and wrapped in a way to appease the 126 | OCaml runtime. 127 | 128 | - The C compiler can better optimise your code. 129 | 130 | - Constant parameters don't need to be exposed to OCaml, just to pass 131 | them to the C function. 132 | 133 | - You often have to write (and generate) less code, if you don't 134 | create wrappers for every c function and type, but just wrap 135 | snippets of C code. 136 | 137 | ### Implicit Removal of Labels 138 | 139 | Labels that end with an underscore will be removed from the generated 140 | OCaml function: 141 | 142 | ```ocaml 143 | external%c puts_flush : str_:string -> bool = {| 144 | int r = puts($str_); 145 | ... 146 | |} 147 | 148 | let _ : int = puts_flush "Hello World" (* no warning about a missing label ever *) 149 | ``` 150 | 151 | Labels are always removed, when an operator is defined through inline code. 152 | -------------------------------------------------------------------------------- /docs/header.md: -------------------------------------------------------------------------------- 1 | --- 2 | layout: default 3 | title: Headers 4 | nav_order: 7 5 | --- 6 | 7 | # C Headers 8 | 9 | The necessary C headers files can be included through the `header` 10 | pseudo-function. The code will be removed from the generated ml file 11 | and only appear in the c file: 12 | 13 | ```ocaml 14 | let%c () = header {| 15 | #include 16 | |} 17 | external puts: string -> int = "puts" 18 | 19 | (* You can also add arbitrary c code there: *) 20 | let%c () = header {| 21 | #define put_own(s) \ 22 | ... 23 | |} 24 | 25 | external puts_own: string -> int = "puts_own" 26 | ``` 27 | 28 | The generated c file is of course flat and without any scope. It might be 29 | good idea to only add a single `let%c () header {| ... |}` statement 30 | at the top of your file and don't spread several statements across 31 | your file or in different modules. Otherwise a casual reader of your 32 | code might draw a wrong conclusion ... 33 | -------------------------------------------------------------------------------- /docs/index.md: -------------------------------------------------------------------------------- 1 | --- 2 | layout: default 3 | title: Overview 4 | nav_order: 1 5 | --- 6 | 7 | # Overview 8 | 9 | ppx_cstubs is a ppx-based preprocessor for stub generation with 10 | [ctypes](https://github.com/ocamllabs/ocaml-ctypes). 11 | 12 | ppx_cstubs creates two files from a single ml file: a file with c stub 13 | code and a ml file with all additional boilerplate code. 14 | 15 | ## Contents 16 | 17 | * [Calling C functions from OCaml](./functions.md) 18 | * [Enum Types](./enums.md) 19 | * [Struct and Union Types](./structures.md) 20 | * [Dealing with Opaque Types and Integers](./opaque.md) 21 | * [Retrieving Constants](./constants.md) 22 | * [C #include Guards](./header.md) 23 | * [Static OCaml Callbacks](./static_callbacks.md) 24 | * [Pointers to C Objects](./foreign_value.md) 25 | * [Scoping Rules](./scope.md) 26 | 27 | ## not yet documented 28 | 29 | Consult the 30 | [README.md](https://github.com/fdopen/ppx_cstubs/blob/master/README.md) 31 | in the meanwhile... 32 | 33 | * merlin (how to configure your editor? `ppx_cstubs.merlin` can only 34 | be used inside your editor, not inside build rules) 35 | * compilation 36 | * dune integration - see also this [example](https://github.com/fdopen/ppx_cstubs/tree/master/examples/dune-project) 37 | * cross package dependencies with `ppx_cstubs -pkg ...` 38 | -------------------------------------------------------------------------------- /docs/opaque.md: -------------------------------------------------------------------------------- 1 | --- 2 | layout: default 3 | title: Opaque Types 4 | nav_order: 5 5 | --- 6 | 7 | # Opaque Types 8 | 9 | ppx_cstubs provides various helper to deal with values whose types 10 | differ from platform to platform or that are kept opaque. 11 | 12 | ## Abstract 13 | 14 | ```ocaml 15 | let%c myabstract = abstract "foo" 16 | ``` 17 | 18 | The statement above will be translated to something along the 19 | following lines - with `size` and `alignment` determined 20 | automatically: 21 | 22 | ```ocaml 23 | type myabstract 24 | let myabstract : myabstract Ctypes.abstract Ctypes.typ = 25 | Ctypes.abstract ~size ~alignment ~name:"foo" 26 | ``` 27 | 28 | 29 | `abstract` is most suitable for structs and unions, whose members are 30 | private or don't need to be accessed from OCaml. `abstract` guarantees 31 | an uniform representation of the values inside the OCaml heap and 32 | functions like 33 | [Ctypes.addr](https://github.com/ocamllabs/ocaml-ctypes/blob/b19b190ad5083d03130dd67508705da77c1c5089/src/ctypes/ctypes.mli#L435) 34 | can be applied to its values. 35 | 36 | References: 37 | * [ctypes.mli](https://github.com/ocamllabs/ocaml-ctypes/blob/b19b190ad5083d03130dd67508705da77c1c5089/src/ctypes/ctypes.mli#L101) 38 | * [ctypes\_types.mli](https://github.com/ocamllabs/ocaml-ctypes/blob/b19b190ad5083d03130dd67508705da77c1c5089/src/ctypes/ctypes_types.mli#L330) 39 | 40 | ## Opaque 41 | 42 | ```ocaml 43 | let%c myopaque = opaque "foo" 44 | (* 'myopaque' will be of type 'myopaque Ctypes.typ' *) 45 | ``` 46 | 47 | `opaque` is similar to `abstract`, but will choose the best memory 48 | representation available for the type. If `foo` turns out to be an 49 | integer type, it will be an integer inside OCaml. If it is a pointer, 50 | it will be of type `Ctypes.ptr` - or `Ctypes.abstract` 51 | otherwise. `opaque` is preferable to `abstract`, if values of the 52 | corresponding type are usually passed by value. 53 | 54 | 55 | ## Integers of Unknown Size and Signedness 56 | 57 | ```ocaml 58 | module Signed_t = [%c int "foo"] 59 | module Unsigned_t = [%c uint "foo"] 60 | module Unknown_signed = [%c aint "foo"] 61 | external foo : Signed_t.t -> void 62 | let f t = Signed.add (Signed_t.of_int (-42)) t 63 | ``` 64 | 65 | `module Signed_t = [%c int "foo"]` creates an module `Signed_t` with 66 | the signature of 67 | [Signed.S](https://github.com/ocamllabs/ocaml-integers/blob/41846f424b13af552200939228492d29bd06a495/src/signed.mli#L10), 68 | and also include an additional value `t` of type `t Ctypes.typ` that 69 | can be used inside `external` declarations. 70 | 71 | `[%c uint "foo"]` will create an analogous module with a signature of 72 | [Unsigned.S](https://github.com/ocamllabs/ocaml-integers/blob/41846f424b13af552200939228492d29bd06a495/src/unsigned.mli#L10). 73 | 74 | `[%c aint "foo"]` will also be of type `Unsigned.S`, but with an 75 | additional value `min_int` that can be used to easily determine, if the 76 | type is signed or not. `[%c int "foo"]` and `[%c uint "foo"]` will 77 | throw an error during preprocessing, if the underlying type differs in 78 | signedness. 79 | 80 | Integer types larger than 8 bytes are not supported. 81 | -------------------------------------------------------------------------------- /docs/scope.md: -------------------------------------------------------------------------------- 1 | --- 2 | layout: default 3 | title: Scope 4 | nav_order: 9 5 | --- 6 | 7 | # Scope 8 | 9 | The types inside external declarations have their own environment. 10 | Normal let-bindings or statements like `open` won't have any effect on 11 | them. (Ppx rewriters don't have access to types and similar 12 | information). 13 | 14 | By default only `Ctypes.typ` values of 15 | [Ctypes_types.TYPE](http://ocamllabs.io/ocaml-ctypes/Ctypes_types.TYPE.html) 16 | are accessible (the corresponding module is opened by default). It's 17 | however possible to create new types that are then available inside 18 | your regular program and inside external declarations: 19 | 20 | ```ocaml 21 | let%c int_as_bool = (* all bindings must be of type Ctypes.typ *) 22 | view 23 | int (* no access to your regular scope inside the expression *) 24 | ~read:(fun x -> if x = 0 then false else true) 25 | ~write:(fun x -> if x = false then 0 else 1) 26 | 27 | (* int_as_bool is available in the regular scope *) 28 | let ibptr = Ctypes.allocate int_as_bool true 29 | 30 | (* function prototype in c: 31 | void *bsearch(const void *key, const void *base, 32 | size_t nmemb, size_t size, 33 | int (*compar)(const void *, const void *)); 34 | *) 35 | let%c compar = funptr (ptr void @-> ptr void @-> returning int) 36 | let%c ptr_void = ptr void; 37 | let compar = 3 (* has no effect on the following external declaration *) 38 | external bsearch: 39 | key: ptr_void 40 | -> base: ptr_void 41 | -> nmemb: size_t 42 | -> size: size_t 43 | -> compar 44 | -> ptr_void = "bsearch" 45 | ``` 46 | 47 | This also means that you can't reference any `Ctypes.typ`s that you've 48 | created in other files of your current project. 49 | 50 | ## Cross Package Dependencies 51 | 52 | Types from other libraries can however be made accessible: `ppx_cstubs 53 | -pkg foo ...` will make the types of the findlib library `foo` 54 | available to the preprocessor (it also works for plain `.cma` or 55 | `.cmo` files). You just have to ensure that your regular build 56 | instructions and the flags that are passed do `ppx_cstubs` are 57 | consistent. 58 | -------------------------------------------------------------------------------- /docs/static_callbacks.md: -------------------------------------------------------------------------------- 1 | --- 2 | layout: default 3 | title: Static Callbacks 4 | nav_order: 7 5 | --- 6 | 7 | # Static OCaml callbacks 8 | 9 | The usual way of passing callbacks to C is through 10 | [Foreign.funptr](https://github.com/ocamllabs/ocaml-ctypes/blob/b19b190ad5083d03130dd67508705da77c1c5089/src/ctypes-foreign-threaded/foreign.mli#L49). 11 | 12 | `Foreign` internally relies on `libffi`, that dynamically generates 13 | code at runtime, and `Foreign` will hide all the ugly details from the 14 | OCaml coder. While it is very convenient, it also has its drawbacks: 15 | 16 | - It is slow. 17 | 18 | - libffi won't work, if security measures like PaX's MPROTECT are 19 | active - or becomes even slower, when it tries to work around such 20 | limitations. 21 | 22 | Static callbacks are an alternative way to pass OCaml functions to 23 | C. They are particular useful, if the callbacks are short and get 24 | called in a high frequency. Then the overhead introduced by libffi and 25 | `ctypes.foreign's` generic wrapper around it might be too costly. If 26 | the callbacks do more expensive computations or only get called a few 27 | times, `ctypes.foreign` is usually the better choice because of its 28 | easier interface. 29 | 30 | With static callbacks it is not possible to pass closures to C 31 | directly. You have to store the context manually and restore it again 32 | inside the callback. 33 | 34 | ___ 35 | 36 | The following example code will demonstrate the usage and syntax of 37 | static callbacks through a generic binding to glibc's `qsort_r`: 38 | 39 | ```c 40 | void qsort_r(void *base, size_t nmemb, size_t size, 41 | int (*compar)(const void *, const void *, void *), 42 | void *arg); 43 | ``` 44 | 45 | The `qsort_r()` function sorts an array with `nmemb` elements of size 46 | `size`. The `base` argument points to the start of the array. The 47 | contents of the array are sorted according to a comparison function 48 | pointed to by `compar`. The parameter `arg` can be used to manually 49 | pass user data (e.g. a closure) to the callback (the third parameter 50 | of the comparison function). 51 | 52 | We first define a module for the type of the callback function: 53 | 54 | ```ocaml 55 | module Compar = [%cb ptr void @-> ptr void @-> ptr void @-> returning int] 56 | ``` 57 | 58 | The only public value of the generated module is `Compar.t`, which is 59 | of type [\_abstract Compar.t Ctypes.static_funptr 60 | Ctypes.typ](https://github.com/ocamllabs/ocaml-ctypes/blob/master/src/ctypes/ctypes_types.mli#L371) 61 | 62 | `Compar.t` can be used to create values of type `_abstract 63 | Compar.t Ctypes.static_funptr`: 64 | 65 | ```ocaml 66 | let%cb qsort_callback p1 p2 arg : Compar.t = 67 | let f = get_closure arg in (* get_closure described later *) 68 | f p1 p2 69 | ``` 70 | 71 | At this time, everything has normal scope - except the 72 | pseudo-type-constrain. The only restriction is that you must define it 73 | at the "top-level", i.e. not inside functors or local modules. The 74 | preprocessor tries to detect unsafe contexts and will abort code 75 | generation in such cases. If you hit a loophole, an exception will be 76 | thrown at runtime. 77 | 78 | We will also use `Compar.t` as regular `Ctypes.typ` inside external 79 | declarations: 80 | 81 | ```ocaml 82 | external qsort : 83 | base:void ptr 84 | -> nmemb:size_t 85 | -> size:size_t 86 | -> Compar.t 87 | -> arg:void ptr 88 | -> void 89 | = "qsort_r" 90 | 91 | let qsort ~cmp ar = 92 | let nmemb = CArray.length ar |> Unsigned.Size_t.of_int in 93 | let size = CArray.element_type ar |> sizeof |> Unsigned.Size_t.of_int in 94 | let base = CArray.start ar |> to_voidp in 95 | let arg = store_closure cmp in 96 | Fun.protect ~finally:(fun () -> remove_closure arg) (fun () -> 97 | qsort ~base ~nmemb ~size qsort_callback ~arg) 98 | ``` 99 | 100 | To implement `get_closure`, `store_closure`, and `remove_closure`, you 101 | can use 102 | [Ctypes.ptr\_of\_raw\_address](https://github.com/ocamllabs/ocaml-ctypes/blob/b19b190ad5083d03130dd67508705da77c1c5089/src/ctypes/ctypes.mli#L213), 103 | e.g: 104 | 105 | ```ocaml 106 | let htl_closure = Hashtbl.create 16 107 | 108 | let store_closure = 109 | let cnt = ref 0 in 110 | let rec iter n = 111 | let next = succ n in 112 | if Hashtbl.mem htl_closure n then 113 | iter next 114 | else 115 | let () = cnt := next in 116 | n 117 | in 118 | fun f -> 119 | let n = iter !cnt in 120 | Hashtbl.replace htl_closure n f; 121 | Nativeint.of_int n |> ptr_of_raw_address 122 | 123 | let get_closure ptr = 124 | raw_address_of_ptr ptr |> Nativeint.to_int |> Hashtbl.find htl_closure 125 | 126 | let remove_closure ptr = 127 | raw_address_of_ptr ptr |> Nativeint.to_int |> Hashtbl.remove htl_closure 128 | ``` 129 | 130 | ## Caveat 131 | 132 | In less trivial use cases additional precautions are necessary: 133 | 134 | - You can usually not throw exceptions inside callbacks. The C code 135 | does not expect such a jump, its internal state would become 136 | invalid. If multiple threads are used, it's also possible that you 137 | are not able to add a handler that could catch your exception in the 138 | first place. You have to capture all exceptions, save them for later 139 | and return an appropriate default value. 140 | 141 | - The lifetime management of your closures is often complicated. If 142 | you forget to remove them from your hash table or similar data 143 | structure, you will leak memory. If you remove them too early, it's 144 | even more fatal... 145 | 146 | ## Annotations for Callbacks 147 | 148 | Static callbacks can be annotated further: 149 | 150 | ```ocaml 151 | let%cb your_callback : Callback.t = foo [@@ acquire_runtime_lock] 152 | ``` 153 | 154 | `[@@ acquire_runtime_lock]` must be used, if your callback is called 155 | from a context, where OCaml's runtime lock was released, e.g. via the 156 | `[@@ release_runtime_lock]` annotation of `external` declarations. 157 | 158 | ```ocaml 159 | let%cb your_callback x : Callback.t = 160 | let res = foo x in 161 | res [@@ thread_registration] 162 | ``` 163 | 164 | `[@@ thread_registration]` must be used, if the C library creates new 165 | threads and might execute your callbacks inside those threads. In 166 | order to use `[@@ thread_registration]`, you have to link 167 | `ctypes.foreign` to your program, even if you don't use `Foreign` 168 | otherwise. 169 | -------------------------------------------------------------------------------- /docs/structures.md: -------------------------------------------------------------------------------- 1 | --- 2 | layout: default 3 | title: Structs and Unions 4 | nav_order: 4 5 | --- 6 | 7 | # Structs 8 | 9 | There is a special syntax for creating and accessing C structs: 10 | 11 | ```c 12 | struct point { 13 | int x; 14 | int y; 15 | }; 16 | 17 | /* example functions */ 18 | struct point add (struct point a, struct point b) { 19 | struct point res; 20 | res.x = a.x + b.x ; 21 | res.y = a.y + b.y ; 22 | return res; 23 | } 24 | 25 | void add_ptr(struct point *a, struct point *b, struct point *res){ 26 | res->x = a->x + b->x; 27 | res->y = a->y + b->y; 28 | } 29 | ``` 30 | 31 | ```ocaml 32 | type%c point = { 33 | x: int; (* int here refers to the value Ctypes.int, not the type int *) 34 | y: int; 35 | } 36 | ``` 37 | 38 | The above code will be translated to something along the following lines: 39 | ```ocaml 40 | type point 41 | let point : point Ctypes.structure Ctypes.typ = Ctypes.structure "point" 42 | let x = Ctypes.field point "x" Ctypes.int 43 | let y = Ctypes.field point "y" Ctypes.int 44 | let () = Ctypes.seal point 45 | ``` 46 | 47 | Example usage: 48 | ```ocaml 49 | let () = 50 | let p1 = Ctypes.make point in 51 | Ctypes.setf p1 x 1; 52 | Ctypes.setf p1 y 2; 53 | let p2 = Ctypes.make point in 54 | Ctypes.setf p2 x 3; 55 | Ctypes.setf p2 y 4; 56 | let p3 = add p1 p2 in 57 | Printf.printf "add (simple): %d;%d\n" (getf p3 x) (getf p3 y); 58 | let res = Ctypes.make point in 59 | let () = add_ptr (Ctypes.addr p1) (Ctypes.addr p2) (Ctypes.addr res) in 60 | Printf.printf 61 | "add_ptr (simple): %d;%d\n" 62 | (Ctypes.getf res x) 63 | (Ctypes.getf res y) 64 | ``` 65 | 66 | It's also possible to convert OCaml records to C structs on the fly by 67 | annotating the type declaration with `[@@ as_record]`: 68 | 69 | ```ocaml 70 | type%c point = { 71 | x: int; 72 | y: int; 73 | } [@@ as_record] 74 | (* [@@ with_record] will create two values: point and point_record *) 75 | 76 | external add: point -> point -> point = "add" 77 | external add_ptr: point ptr -> point ptr -> point ptr -> void = "add_ptr" 78 | 79 | let () = 80 | let p1 = { x = 1 ; y = 3} in 81 | let p2 = { x = 2 ; y = 4} in 82 | let p3 = add p1 p2 in 83 | Printf.printf "add (record): %d;%d\n" p3.x p3.y; 84 | let p1_ptr = allocate point p1 in 85 | let p2_ptr = allocate point p2 in 86 | let res_ptr = allocate_n point ~count:1 in 87 | let () = add_ptr p1_ptr p2_ptr res_ptr in 88 | let res = !@ res_ptr in 89 | Printf.printf "add_ptr (record) %d;%d\n" res.x res.y 90 | ``` 91 | 92 | If the struct contains pointers, you have to be careful that the 93 | garbage collector doesn't free the memory behind your back. The 94 | generated code for automatic boxing and unboxing can't handle 95 | such subtle issues for you. 96 | 97 | `[@@ with_record]` is useful, when easier access to the 98 | fields is only temporary needed for debugging. 99 | [Ctypes.coerce](https://github.com/ocamllabs/ocaml-ctypes/blob/b19b190ad5083d03130dd67508705da77c1c5089/src/ctypes/ctypes.mli#L440) 100 | can be used to convert between the different pointer representations: 101 | 102 | ```ocaml 103 | let {x,y} = !@(coerce (ptr point) (ptr point_record) t) 104 | ``` 105 | 106 | ## Unions 107 | 108 | Unions can be declared in a similar way: 109 | 110 | ```c 111 | typedef union { 112 | long l; 113 | double d; 114 | } data; 115 | ``` 116 | 117 | ```ocaml 118 | type%c_union data = { 119 | l: long; 120 | d: double; 121 | } [@@ typedef] 122 | ``` 123 | 124 | ## Nested Structs and Unions 125 | 126 | Structs that contain other structs or unions are best accessed by 127 | creating a "flat" OCaml record: 128 | 129 | ```c 130 | struct s { 131 | int tag; 132 | union { 133 | int i; 134 | unsigned int u; 135 | } d; 136 | }; 137 | ``` 138 | 139 | ```ocaml 140 | type%c s = { 141 | tag : int; 142 | d_i : sint [@cname "d.i"]; 143 | d_u : uint [@cname "d.u"]; 144 | } 145 | ``` 146 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (dirs :standard \ examples) ; 2 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.6) 2 | (version 0.6.1) 3 | (name ppx_cstubs) 4 | -------------------------------------------------------------------------------- /examples/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: clean default 2 | 3 | OCAML_VERSION:=$(shell ocamlfind c -config | awk -F '[\t\r ]+' '/^version/ {print $$2}') 4 | OCAML_VERSION_MAJOR=$(word 1, $(subst ., ,$(OCAML_VERSION))) 5 | OCAML_VERSION_MINOR=$(word 2, $(subst ., ,$(OCAML_VERSION))) 6 | ifeq ($(OCAML_VERSION_MAJOR).$(OCAML_VERSION_MINOR),4.02) 7 | EXAMPLES= 8 | else 9 | OCAML_SYSTEM:=$(shell ocamlfind c -config | awk -F '[\t\r ]+' '/^system/ {print $$2}') 10 | ifeq ($(OCAML_SYSTEM),linux) 11 | EXAMPLES=inline.exe time.exe getpwent.exe 12 | else 13 | EXAMPLES=inline.exe time.exe 14 | endif 15 | endif 16 | 17 | default: ftw.exe $(EXAMPLES) 18 | 19 | .SECONDARY: 20 | %.ml %_stubs.c: %.c.ml 21 | @dune exec --no-print-directory --display=quiet -- ppx_cstubs $< -pretty -o-ml $(basename $@).ml -o-c $(basename $@)_stubs.c 22 | 23 | %.exe: %_stubs.c %.ml 24 | @dune exec --no-print-directory --display=quiet -- ocamlfind opt -thread -package ctypes,ctypes.foreign,ppx_cstubs -linkpkg $^ -o $@ 25 | 26 | clean: 27 | rm -f *.obj *.o *.cm* *.exe *_stubs.c ftw.ml inline.ml time.ml getpwent.ml 28 | -------------------------------------------------------------------------------- /examples/dune-project/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: default build test clean 2 | 3 | default: build 4 | 5 | build: 6 | @dune build -p cstubs-demo 7 | 8 | test: 9 | @dune exec -p cstubs-demo hello 10 | 11 | clean: 12 | @dune clean -p cstubs-demo 13 | -------------------------------------------------------------------------------- /examples/dune-project/README.md: -------------------------------------------------------------------------------- 1 | # cstubs-demo 2 | 3 | Example project, how to use ppx_cstubs with dune. 4 | 5 | pkg-config is used to query the compilation and link flags. 6 | -------------------------------------------------------------------------------- /examples/dune-project/cstubs-demo.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "my@mail.postbox" 3 | authors: ["me"] 4 | homepage: "https://github.com/user/cstubs-demo" 5 | bug-reports: "https://github.com/user/cstubs-demo/issues" 6 | dev-repo: "git+https://github.com/user/cstubs-demo.git" 7 | 8 | build: [ 9 | ["dune" "build" "-p" name "-j" jobs] 10 | ] 11 | 12 | depends: [ 13 | "dune" {build} 14 | "ppx_cstubs" 15 | "ctypes" 16 | ] 17 | 18 | synopsis: """ 19 | Dummy project for ppx_cstubs usage 20 | """ 21 | 22 | description: """ 23 | This example shows how to use ppx_cstubs with dune 24 | """ 25 | -------------------------------------------------------------------------------- /examples/dune-project/dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.0) 2 | (name cstubs-demo) 3 | 4 | -------------------------------------------------------------------------------- /examples/dune-project/src/bin/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names main) 3 | (public_names hello) 4 | (libraries namelib unix) 5 | (package cstubs-demo)) 6 | -------------------------------------------------------------------------------- /examples/dune-project/src/bin/main.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | let name = 3 | match Namelib.real_name () with None -> "unknown person" | Some s -> s 4 | in 5 | Printf.printf "Hello, %s!\n" name ; 6 | exit 0 7 | -------------------------------------------------------------------------------- /examples/dune-project/src/lib/config/discover.ml: -------------------------------------------------------------------------------- 1 | module C = Configurator.V1 2 | let () = 3 | C.main ~name:"glib" (fun c -> 4 | let default = { C.Pkg_config.libs = ["-lglib-2.0"]; cflags = [] } in 5 | let conf = match C.Pkg_config.get c with 6 | | None -> default 7 | | Some pc -> 8 | match C.Pkg_config.query pc ~package:"glib-2.0" with 9 | | None -> default 10 | | Some deps -> deps in 11 | 12 | (* this file is used by dune for compiling c cstubs *) 13 | C.Flags.write_sexp "c_flags.sexp" conf.cflags; 14 | 15 | (* this file is used by dune during linking *) 16 | C.Flags.write_sexp "c_library_flags.sexp" conf.libs; 17 | 18 | (* ppx_cstubs only needs $CFLAGS, it doesn't link anything *) 19 | C.Flags.write_lines "c_flags.lines" conf.cflags; 20 | ) 21 | -------------------------------------------------------------------------------- /examples/dune-project/src/lib/config/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name discover) 3 | (libraries dune.configurator)) 4 | -------------------------------------------------------------------------------- /examples/dune-project/src/lib/dune: -------------------------------------------------------------------------------- 1 | ; dune.configurator is used to query compilation and link flags 2 | (rule 3 | (targets c_flags.sexp c_library_flags.sexp c_flags.lines) 4 | (deps (:discover config/discover.exe)) 5 | (action (run %{discover}))) 6 | 7 | ; rule to create namelib.ml and namelib_stubs.c from namelib.c.ml 8 | ; c_flags.lines from the rule above is used 9 | (rule 10 | (targets namelib.ml namelib_stubs.c) 11 | (deps (:first-dep namelib.c.ml) c_flags.lines) 12 | (action (chdir %{workspace_root} (run %{bin:ppx_cstubs} %{first-dep} -o %{targets} -- %{read-lines:c_flags.lines})))) 13 | 14 | ; normal instructions for creating a library with c stub files 15 | ; c_flags.sexp and c_library_flags.sexp are created above 16 | (library 17 | (name namelib) 18 | (c_names namelib_stubs) 19 | (c_flags (:include c_flags.sexp)) 20 | ; the following preprocess step is only for merlin support in your 21 | ; editor. You can conditionally enable it during development. It will 22 | ; do nothing during the "real" compilation step, except checking that 23 | ; the file was already preprocessed earlier. 24 | (preprocess (pps ppx_cstubs.merlin)) 25 | (c_library_flags (:include c_library_flags.sexp)) 26 | (libraries unix ctypes ppx_cstubs) 27 | (synopsis "dummy lib")) 28 | -------------------------------------------------------------------------------- /examples/dune-project/src/lib/namelib.c.ml: -------------------------------------------------------------------------------- 1 | let%c () = header "#include " 2 | 3 | external real_name : void -> string_opt = "g_get_real_name" 4 | -------------------------------------------------------------------------------- /examples/ftw.c.ml: -------------------------------------------------------------------------------- 1 | let%c () = header {| 2 | #include 3 | |} 4 | 5 | (* 6 | c prototype: 7 | int ftw(const char *dirpath, 8 | int ( *fn ) (const char *fpath, const struct stat *sb, int typeflag), 9 | int nopenfd); 10 | *) 11 | 12 | external ftw: 13 | string -> (string -> void ptr -> int -> int) funptr -> int -> int = "ftw" 14 | 15 | 16 | let _FTW_F = [%c constant "FTW_F" camlint] 17 | let _FTW_D = [%c constant "FTW_D" camlint] 18 | 19 | let show path _ typ = 20 | let info = 21 | if typ = _FTW_F then 22 | "regular file" 23 | else if typ = _FTW_D then 24 | "directory" 25 | else 26 | "something else" in 27 | Printf.printf "%S (%s)\n" path info; 28 | 0 29 | 30 | let () = 31 | let path = match Sys.argv with 32 | | [| _ ; b |] -> b 33 | | _ -> "." in 34 | let res = ftw path show 32 in 35 | if res = 0 then 36 | exit 0 37 | else 38 | exit 1 39 | -------------------------------------------------------------------------------- /examples/getpwent.c.ml: -------------------------------------------------------------------------------- 1 | let%c () = header {| 2 | #include 3 | #include 4 | #include 5 | |} 6 | 7 | open Ctypes 8 | 9 | (* 10 | type declaration in C: 11 | struct passwd { 12 | char *pw_name; /* username */ 13 | char *pw_passwd; /* user password */ 14 | uid_t pw_uid; /* user ID */ 15 | gid_t pw_gid; /* group ID */ 16 | char *pw_gecos; /* user information */ 17 | char *pw_dir; /* home directory */ 18 | char *pw_shell; /* shell program */ 19 | }; 20 | *) 21 | 22 | (* uid_t must be an integer type, but its size and 23 | signedness can differ from platform to platform. *) 24 | 25 | module Uid_t = [%c aint "uid_t"] 26 | module Gid_t = [%c aint "gid_t"] 27 | 28 | type%c passwd = { 29 | pw_name: string; 30 | (* note: `string` works, because the fields are only set, but never read 31 | by c code in the following expamle. If you would create such a value 32 | from OCaml and pass it to C, you have to ensure manually, that the garbage 33 | collector doesn't free the memory referenced, eg. from 34 | pw_name. That's not possible, if you use `string` instead of 35 | `char ptr`. *) 36 | pw_passwd: string; 37 | pw_uid: Uid_t.t; 38 | pw_gid: Gid_t.t; 39 | pw_gecos: string; 40 | pw_dir: string; 41 | pw_shell: string } [@@ as_record] 42 | 43 | external getpwent : void -> passwd ptr_opt = "getpwent" 44 | external setpwent : void -> void = "setpwent" 45 | external endpwent : void -> void = "endpwent" 46 | 47 | let print_entry r = 48 | Printf.printf 49 | "name:%S, dir:%S, uid:%s, git:%s, shell:%S\n" 50 | r.pw_name 51 | r.pw_dir 52 | (Uid_t.to_string r.pw_uid) 53 | (Gid_t.to_string r.pw_gid) 54 | r.pw_shell 55 | 56 | let demo_getpwent () = 57 | let rec iter () = 58 | match getpwent () with 59 | | None -> () 60 | | Some r -> 61 | print_entry (!@ r); 62 | iter () in 63 | setpwent (); 64 | iter (); 65 | endpwent () 66 | 67 | let%c size_t' = 68 | view size_t ~read:Unsigned.Size_t.to_int ~write:Unsigned.Size_t.of_int 69 | 70 | (* c prototype: 71 | int getpwent_r(struct passwd *pwbuf, char *buf, 72 | size_t buflen, struct passwd **pwbufp); 73 | *) 74 | external getpwent_r : 75 | passwd ptr -> char ptr -> size_t' -> passwd ptr ptr -> int = "getpwent_r" 76 | [@@ release_runtime_lock] 77 | 78 | let _ENOENT = [%c constant "ENOENT" camlint] 79 | 80 | let demo_getpwent_r () = 81 | let pptr = allocate_n (ptr passwd) ~count:1 in 82 | let ptr = allocate_n passwd ~count:1 in 83 | let len = 8192 in 84 | let buf = CArray.make char len |> CArray.start in 85 | let rec iter () = 86 | let r = getpwent_r ptr buf len pptr in 87 | if r = _ENOENT then 88 | () 89 | else if r <> 0 then 90 | let () = Printf.eprintf "unexpected errno:%d\n" r in 91 | exit 1 92 | else 93 | let r = !@ pptr in 94 | if Ctypes.is_null r then 95 | let () = prerr_endline "misbehaving getpwent_r implementation" in 96 | exit 1 97 | else 98 | print_entry ( !@ r ); 99 | iter () in 100 | setpwent (); 101 | iter (); 102 | endpwent () 103 | 104 | 105 | let () = 106 | print_endline "getpwent:"; 107 | demo_getpwent (); 108 | print_endline "\ngetpwent_r:"; 109 | demo_getpwent_r () 110 | -------------------------------------------------------------------------------- /examples/inline.c.ml: -------------------------------------------------------------------------------- 1 | let%c () = header {| 2 | #include 3 | |} 4 | 5 | external%c print: str:string -> d:int -> void = {| 6 | printf("%s (%d)\n",$str,$d); 7 | fflush(stdout); 8 | |} 9 | 10 | (* labels that end with an underscore, will disappear 11 | in the generated OCaml function. They are always removed, 12 | if an operator is defined. *) 13 | external%c printnl: str_:string -> d_:int -> void = {| 14 | fprintf(stderr,"%s (%d)\n",$str_,$d_); 15 | /* $$ to write one regular dollar sign */ 16 | 17 | fflush(stderr); 18 | |} 19 | 20 | let () = 21 | print ~str:"Hello World" ~d:3; 22 | printnl "Hello World (nl)" 9 23 | -------------------------------------------------------------------------------- /examples/time.c.ml: -------------------------------------------------------------------------------- 1 | let%c () = header {| 2 | #include 3 | #include 4 | |} 5 | 6 | (* Note: OCaml 4.02.3 doesn't understand 7 | 8 | type%c x = ... 9 | external%c x : .... 10 | 11 | Only the following syntax is supported by OCaml 4.02.3 as well: 12 | [%%c type x = ... ] 13 | [%%c external x : ... ] 14 | 15 | *) 16 | type%c tm = { 17 | tm_sec: int; 18 | tm_min: int; 19 | tm_hour: int; 20 | tm_mday: int; 21 | tm_mon: int; 22 | tm_year: int; 23 | tm_wday: int; 24 | tm_yday: int; 25 | tm_isdst: int } [@@ as_record] 26 | 27 | open Ctypes 28 | open PosixTypes 29 | 30 | (* PosixTypes not open in the declarations below :D *) 31 | external time : PosixTypes.time_t ptr -> PosixTypes.time_t = "time" 32 | external asctime: tm ptr -> string_opt = "asctime" [@@ return_errno] 33 | external localtime: PosixTypes.time_t ptr -> tm ptr_opt = "localtime" 34 | 35 | let _EOVERFLOW = [%c constant "EOVERFLOW" sint] 36 | 37 | let () = 38 | let timep = allocate_n ~count:1 time_t in 39 | let time = time timep in 40 | assert (time = !@timep); 41 | let ptm = match localtime timep with 42 | | None -> prerr_endline "localtime failure"; exit 1 43 | | Some s -> s in 44 | let tm = !@ptm in 45 | Printf.printf "tm.tm_mon = %d\n" tm.tm_mon; 46 | Printf.printf "tm.tm_year = %d\n" tm.tm_year; 47 | let strt,errno = asctime ptm in 48 | match strt with 49 | | Some s -> print_endline s 50 | | None -> 51 | if errno = _EOVERFLOW then 52 | prerr_endline "overflow" 53 | else 54 | Printf.eprintf "unknown error:%s\n" (Signed.SInt.to_string errno); 55 | exit 1 56 | -------------------------------------------------------------------------------- /ppx_cstubs.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "andreashauptmann@t-online.de" 3 | authors: [ "andreashauptmann@t-online.de" ] 4 | license: "LGPL-2.1-or-later WITH OCaml-LGPL-linking-exception" 5 | homepage: "https://fdopen.github.io/ppx_cstubs/" 6 | dev-repo: "git+https://github.com/fdopen/ppx_cstubs.git" 7 | doc: "https://fdopen.github.io/ppx_cstubs/" 8 | bug-reports: "https://github.com/fdopen/ppx_cstubs/issues" 9 | build: [ 10 | ["dune" "build" "-p" name "-j" jobs] 11 | ] 12 | depends: [ 13 | "bigarray-compat" 14 | "ctypes" {>= "0.13.0"} 15 | "integers" 16 | "num" 17 | "result" 18 | "containers" {>= "2.2"} 19 | "cppo" {build & >= "1.3"} 20 | "ocaml" {>= "4.04.2"} 21 | "ppxlib" {>= "0.22.0"} 22 | "ocamlfind" {>= "1.7.2"} # not only a build dependency, it depends on findlib.top 23 | "dune" {>= "1.6"} 24 | "re" {>= "1.7.2"} 25 | ] 26 | 27 | synopsis: "Preprocessor for easier stub generation with ctypes" 28 | description: """ 29 | ppx_cstubs is a ppx-based preprocessor for stub generation with 30 | ctypes. ppx_cstubs creates two files from a single ml file: a file 31 | with c stub code and an OCaml file with all additional boilerplate 32 | code. 33 | """ 34 | -------------------------------------------------------------------------------- /src/bin/config/config.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | let ocaml_where = Sys.argv.(1) in 3 | let output = Sys.argv.(2) in 4 | let ocaml_version = Sys.argv.(3) in 5 | let old_caml = 6 | Scanf.sscanf ocaml_version "%u.%u" (fun major minor -> 7 | (major, minor) < (4, 6)) 8 | in 9 | let ch_out = open_out_bin output in 10 | output_char ch_out '('; 11 | Printf.fprintf ch_out "%S" "-linkall"; 12 | (if old_caml then 13 | let pre = "BYTECCLINKOPTS=" in 14 | let makefile = Filename.concat ocaml_where "Makefile.config" in 15 | CCIO.with_in makefile @@ fun ch -> 16 | let rec iter () = 17 | match CCIO.read_line ch with 18 | | None -> () 19 | | Some s -> 20 | if CCString.prefix ~pre s = false then iter () 21 | else 22 | let len_pre = String.length pre in 23 | let s = String.sub s len_pre (String.length s - len_pre) in 24 | let s = String.trim s in 25 | if s <> "" then 26 | CCString.split_on_char ' ' s 27 | |> List.iter (fun x -> Printf.fprintf ch_out " %S %S" "-cclib" x) 28 | in 29 | iter ()); 30 | output_char ch_out ')'; 31 | close_out ch_out 32 | -------------------------------------------------------------------------------- /src/bin/config/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name config) 3 | (libraries containers) 4 | ) 5 | -------------------------------------------------------------------------------- /src/bin/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (targets link_flags.sexp) 3 | (deps (:config config/config.exe)) 4 | (action (run %{config} %{ocaml_where} link_flags.sexp %{ocaml_version}))) 5 | 6 | (executable 7 | (name exec) 8 | (modes byte) 9 | (link_flags (:include link_flags.sexp)) 10 | (libraries ppx_cstubs.custom) 11 | ) 12 | (install 13 | (section bin) 14 | (files (exec.exe as ppx_cstubs))) 15 | -------------------------------------------------------------------------------- /src/bin/exec.ml: -------------------------------------------------------------------------------- 1 | let () = Ppx_cstubs_custom.init () 2 | -------------------------------------------------------------------------------- /src/bin/exec.mli: -------------------------------------------------------------------------------- 1 | (* empty *) 2 | -------------------------------------------------------------------------------- /src/custom/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (targets ppx_cstubs_custom.ml) 3 | (deps (:f ppx_cstubs_custom.cppo.ml)) 4 | (action 5 | (chdir %%{project_root} 6 | (run %{bin:cppo} -V OCAML:%{ocaml_version} %{f} -o %{targets})))) 7 | 8 | 9 | (library 10 | (name ppx_cstubs_custom) 11 | (synopsis "custom ppx_cstubs preprocessors") 12 | (public_name ppx_cstubs.custom) 13 | (libraries ppx_cstubs.internal compiler-libs.bytecomp compiler-libs.toplevel findlib.top) 14 | (modes byte) 15 | ) 16 | -------------------------------------------------------------------------------- /src/custom/ppx_cstubs_custom.cppo.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | let toplevel_env = ref Env.empty 20 | 21 | let flib_protect f a = 22 | try f a with Fl_package_base.No_such_package (s, s') -> 23 | if s' = "" then Printf.eprintf "error: findlib package %s not found\n%!" s 24 | else Printf.eprintf "error: findlib package %s (%S) not found\n%!" s s' ; 25 | exit 2 26 | 27 | let initialized = ref false 28 | 29 | let init ~nopervasives ~pkgs ~use_threads ~cma_files () = 30 | match !initialized with 31 | | true -> () 32 | | false -> 33 | if nopervasives then Clflags.nopervasives := true ; 34 | Toploop.set_paths (); 35 | toplevel_env := Compmisc.initial_env () ; 36 | Topfind.log := ignore ; 37 | let l = 38 | flib_protect 39 | (Findlib.package_deep_ancestors ["byte"]) 40 | ["bigarray-compat"; "ctypes"] 41 | in 42 | let l = l @ [ "ppx_cstubs" ; "ppx_cstubs.internal" ] in 43 | CCListLabels.fold_left ~init:[] l ~f:(fun ac el -> 44 | (flib_protect Findlib.package_directory el)::ac) |> 45 | CCListLabels.uniq ~eq:CCString.equal |> List.rev |> 46 | CCListLabels.iter ~f:Topdirs.dir_directory; 47 | if pkgs <> [] then ( 48 | Topfind.add_predicates ["byte"]; 49 | flib_protect Topfind.don't_load_deeply ["ppx_cstubs.internal"]; 50 | if use_threads then ( 51 | Topfind.add_predicates ["mt";"mt_posix"]; 52 | flib_protect Topfind.load_deeply ["threads"]); 53 | flib_protect Topfind.load_deeply pkgs ); 54 | ListLabels.iter cma_files ~f:(fun s -> 55 | let dir = Filename.dirname s in 56 | if dir <> "." then Topdirs.dir_directory dir ; 57 | #if OCAML_VERSION < (4, 13, 0) 58 | let b = Topdirs.load_file Format.str_formatter s in 59 | #else 60 | let b = Toploop.load_file Format.str_formatter s in 61 | #endif 62 | let msg = Format.flush_str_formatter () in 63 | if not b then ( 64 | Printf.eprintf "fatal:failed to load %s (%s)\n%!" s msg ; 65 | exit 2 ) ) ; 66 | initialized := true; 67 | () 68 | 69 | let eval st = 70 | #if OCAML_VERSION < (4, 12, 0) 71 | let loc = 72 | match st with 73 | | a::_ -> a.Parsetree.pstr_loc 74 | | [] -> ! Ast_helper.default_loc 75 | in 76 | #endif 77 | Typecore.reset_delayed_checks () ; 78 | #if OCAML_VERSION >= (4, 14, 0) 79 | let (str, _sg, _sn, _shape, newenv) = Typemod.type_structure !toplevel_env st in 80 | #elif OCAML_VERSION >= (4, 12, 0) 81 | let (str, _sg, _sn, newenv) = Typemod.type_structure !toplevel_env st in 82 | #elif OCAML_VERSION >= (4, 8, 0) 83 | let (str, _sg, _sn, newenv) = Typemod.type_structure !toplevel_env st loc in 84 | #else 85 | let str, _sg, newenv = Typemod.type_structure !toplevel_env st loc in 86 | #endif 87 | let lam = Translmod.transl_toplevel_definition str in 88 | Warnings.check_fatal () ; 89 | let init_code, fun_code = Bytegen.compile_phrase lam in 90 | #if OCAML_VERSION >= (4, 8, 0) 91 | let code, reloc, events = 92 | Emitcode.to_memory init_code fun_code 93 | in 94 | #elif OCAML_VERSION >= (4, 3, 0) 95 | let code, code_size, reloc, events = 96 | Emitcode.to_memory init_code fun_code 97 | in 98 | Meta.add_debug_info code code_size [|events|] ; 99 | #else 100 | let code,code_size,reloc = Emitcode.to_memory init_code fun_code in 101 | #endif 102 | let can_free = fun_code = [] in 103 | let initial_symtable = Symtable.current_state () in 104 | Symtable.patch_object code reloc ; 105 | Symtable.check_global_initialized reloc ; 106 | Symtable.update_global_table () ; 107 | #if OCAML_VERSION >= (4, 8, 0) 108 | let bytecode, closure = Meta.reify_bytecode code [| events |] None in 109 | try 110 | let retval = closure () in 111 | if can_free then Meta.release_bytecode bytecode; 112 | toplevel_env := newenv ; 113 | ignore ( retval : Obj.t ); 114 | () 115 | with 116 | | x -> 117 | if can_free then Meta.release_bytecode bytecode; 118 | Symtable.restore_state initial_symtable ; 119 | raise x 120 | #else 121 | let free = 122 | let called = ref false in 123 | fun () -> 124 | if can_free && !called = false then ( 125 | called := true ; 126 | #if OCAML_VERSION >= (4, 3, 0) 127 | Meta.remove_debug_info code; 128 | #endif 129 | Meta.static_release_bytecode code code_size ; 130 | Meta.static_free code ) 131 | in 132 | try 133 | let res = (Meta.reify_bytecode code code_size) () in 134 | free () ; 135 | toplevel_env := newenv ; 136 | ignore ( res : Obj.t ); 137 | () 138 | with x -> 139 | free () ; 140 | Symtable.restore_state initial_symtable ; 141 | raise x 142 | #endif 143 | 144 | let get_top () = 145 | object 146 | method init ~nopervasives ~pkgs ~use_threads ~cma_files () = 147 | init ~nopervasives ~pkgs ~use_threads ~cma_files () 148 | method eval st = eval st 149 | method is_merlin_ppx = false 150 | end 151 | 152 | let init () = 153 | let top = get_top () in 154 | Ppxc__script._init (Some top) 155 | 156 | #if OCAML_VERSION < (4, 9, 0) 157 | (* FIXME: remove this ugly code, once ppxlib supports passing argv to 158 | Ppxlib.Driver.standalone *) 159 | let init () = 160 | let good_args = [| "-version"; "--help"; "-help"; "--run-merlin-top" |] in 161 | let min_len = 5 in 162 | let argv_len = Array.length Sys.argv in 163 | if 164 | argv_len >= min_len 165 | || CCArray.exists 166 | (fun a -> CCArray.exists (fun a' -> a = a') good_args) 167 | Sys.argv 168 | then init () 169 | else 170 | match Array.to_list Sys.argv with 171 | | [] -> init () 172 | | hd :: tl -> 173 | let dummy = "\002--ignore-ppx_cstubs\003" in 174 | let x = Array.make (min_len - argv_len) dummy |> Array.to_list in 175 | let argv = Array.of_list (hd :: (x @ tl)) in 176 | if not Sys.win32 then Unix.execv Sys.executable_name argv 177 | else 178 | let pid = 179 | Unix.create_process Sys.executable_name argv Unix.stdin Unix.stdout 180 | Unix.stderr 181 | in 182 | let _, process_status = Unix.waitpid [] pid in 183 | exit (match process_status with 184 | | Unix.WEXITED n -> n 185 | | Unix.WSIGNALED _ -> 2 186 | | Unix.WSTOPPED _ -> 3) 187 | #endif 188 | -------------------------------------------------------------------------------- /src/custom/ppx_cstubs_custom.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | val init : unit -> unit 20 | -------------------------------------------------------------------------------- /src/internal/attributes.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | let h s = 20 | let x = Location.mkloc s Location.none in 21 | let pl = Mparsetree.Ast_cur.Parsetree.PStr [] in 22 | Mparsetree.Ast_cur.Ast_helper.Attr.mk x pl 23 | 24 | let replace_expr_string = "ppxc__replace_expr" 25 | 26 | let replace_expr_attrib = h replace_expr_string 27 | 28 | let tdl_string = "ppxc__tdl" 29 | 30 | let tdl_attrib = h tdl_string 31 | 32 | let remove_string = "ppxc__remove" 33 | 34 | let remove_attrib = h remove_string 35 | 36 | let replace_attr_string = "ppxc__replace_attr" 37 | 38 | let replace_typ_string = "ppxc__replace_typ" 39 | 40 | let open_struct_type_mod_string = "ppxc__open_struct_type_mod_string" 41 | 42 | let open_struct_type_mod_attrib = h open_struct_type_mod_string 43 | 44 | let open_struct_body_string = "ppxc__open_struct_body_string" 45 | 46 | let open_struct_body_attrib = h open_struct_body_string 47 | 48 | let open_struct_ifthenelse_string = "ppxc__ open_struct_ifthenelse_string" 49 | 50 | let open_struct_ifthenelse_attrib = h open_struct_ifthenelse_string 51 | 52 | let open_struct_openmod_string = "ppxc__open_struct_openmod_string" 53 | 54 | let open_struct_openmod_attrib = h open_struct_openmod_string 55 | 56 | let manifest_replace_string = "ppxc__manifest_replace_string" 57 | 58 | let manifest_replace_attrib = h manifest_replace_string 59 | -------------------------------------------------------------------------------- /src/internal/attributes.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | open Mparsetree.Ast_cur 20 | 21 | val replace_expr_string : string 22 | 23 | val replace_expr_attrib : Parsetree.attribute 24 | 25 | val tdl_string : string 26 | 27 | val tdl_attrib : Parsetree.attribute 28 | 29 | val remove_string : string 30 | 31 | val remove_attrib : Parsetree.attribute 32 | 33 | val replace_attr_string : string 34 | 35 | val replace_typ_string : string 36 | 37 | val open_struct_type_mod_string : string 38 | 39 | val open_struct_type_mod_attrib : Parsetree.attribute 40 | 41 | val open_struct_body_string : string 42 | 43 | val open_struct_body_attrib : Parsetree.attribute 44 | 45 | val open_struct_ifthenelse_string : string 46 | 47 | val open_struct_ifthenelse_attrib : Parsetree.attribute 48 | 49 | val open_struct_openmod_string : string 50 | 51 | val open_struct_openmod_attrib : Parsetree.attribute 52 | 53 | val manifest_replace_string : string 54 | 55 | val manifest_replace_attrib : Parsetree.attribute 56 | -------------------------------------------------------------------------------- /src/internal/c_compile.ml: -------------------------------------------------------------------------------- 1 | module List = CCListLabels 2 | 3 | let uniq l = List.uniq ~eq:CCString.equal l 4 | 5 | let pkgs () = uniq ("ctypes" :: !Options.findlib_pkgs) 6 | 7 | let get_include_dirs_cross () = 8 | let args = uniq ("ctypes" :: !Options.findlib_pkgs) in 9 | let args = "query" :: "-recursive" :: args in 10 | let args = 11 | match !Options.toolchain with 12 | | None -> args 13 | | Some s -> "-toolchain" :: s :: args 14 | in 15 | let buf = Buffer.create 128 in 16 | let stdout = `Buffer buf in 17 | let prog = Options.ocamlfind in 18 | if !Options.verbosity > 2 then Run.cmd_to_string prog args |> prerr_endline; 19 | (match Run.run prog args ~stdout with 20 | | exception Unix.Unix_error (e, s, _) -> 21 | let cmd = Run.cmd_to_string prog args in 22 | Std.Util.error "Process creation \"%s\" failed with %s (%S)" cmd 23 | (Unix.error_message e) s 24 | | 0 -> () 25 | | ec -> Std.Util.error "`ocamlfind query` failed with %d" ec); 26 | let re = Re.Perl.re "[\n]+" |> Re.compile in 27 | let l = Buffer.contents buf |> Re.split re in 28 | Ocaml_config.standard_library () :: l 29 | 30 | let get_include_dirs_live () = 31 | let pkgs = pkgs () in 32 | try 33 | let l = 34 | Findlib.package_deep_ancestors [ "bytes" ] pkgs 35 | |> List.map ~f:Findlib.package_directory 36 | in 37 | Findlib.ocaml_stdlib () :: l 38 | with Fl_package_base.No_such_package (s, s') -> 39 | if s' = "" then Std.Util.error "error: findlib package %s not found\n%!" s 40 | else Std.Util.error "error: findlib package %s (%S) not found\n%!" s s' 41 | 42 | let get_include_dirs () = 43 | let l = 44 | if Options.toolchain_used () then get_include_dirs_cross () 45 | else get_include_dirs_live () 46 | in 47 | let dir = 48 | match !Options.ml_input_file with 49 | | None -> failwith "ml_input_file not set" 50 | | Some s -> Filename.dirname s 51 | in 52 | uniq (l @ !Options.ocaml_include_dirs @ [ dir ]) 53 | 54 | let remove_file f = try Sys.remove f with Sys_error _ -> () 55 | 56 | let compile ?stdout ~stderr c_prog f = 57 | let pre_suf = 58 | match Std.Util.unsuffixed_file_name () with "" -> "" | x -> x ^ "_" 59 | in 60 | let pre = "ppxc_extract_" ^ pre_suf in 61 | let idirs = get_include_dirs () in 62 | let idirs = List.map idirs ~f:(fun c -> [ "-I"; c ]) |> List.flatten in 63 | let default_cc, default_cflags = Ocaml_config.c_compiler_flags () in 64 | let use_cxx = !Options.use_cxx in 65 | let suf = if use_cxx then ".cpp" else ".c" in 66 | let msvc = 67 | match Ocaml_config.system () |> CCString.lowercase_ascii with 68 | | "win32" | "win64" -> true 69 | | _ -> false 70 | in 71 | let default_cflags = 72 | if use_cxx = false then default_cflags 73 | else 74 | let re = if msvc then "^(/|-)std:c[0-9]" else "^-std=(gnu|c)[0-9]" in 75 | let re = Re.Perl.re re |> Re.compile in 76 | List.filter ~f:(fun s -> Re.execp re s = false) default_cflags 77 | in 78 | let cfln = Filename.temp_file pre suf in 79 | Std.finally ~h:(fun () -> if not !Options.keep_tmp then remove_file cfln) 80 | @@ fun () -> 81 | CCIO.with_out ?mode:None ~flags:[ Open_creat; Open_trunc; Open_binary ] cfln 82 | (fun ch -> output_string ch c_prog); 83 | let obj = Filename.chop_suffix cfln suf ^ Ocaml_config.ext_obj () in 84 | let args = if msvc then [ "-Fo:" ^ obj ] else [ "-o"; obj ] in 85 | let args = "-c" :: cfln :: args in 86 | let args = 87 | if use_cxx = false || !Options.cc <> None then args 88 | else if msvc then "-TP" :: args 89 | else "-x" :: "c++" :: args 90 | in 91 | let args = default_cflags @ !Options.c_flags @ idirs @ args in 92 | let prog = match !Options.cc with None -> default_cc | Some s -> s in 93 | let stdout = 94 | match stdout with 95 | | Some x -> x 96 | | None -> if !Options.verbosity > 0 then `Stdout else `Null 97 | in 98 | Std.finally ~h:(fun () -> if not !Options.keep_tmp then remove_file obj) 99 | @@ fun () -> 100 | if !Options.verbosity > 1 then Run.cmd_to_string prog args |> prerr_endline; 101 | match Run.run prog args ~stdout ~stderr with 102 | | exception Unix.Unix_error (e, s, _) -> 103 | let cmd = Run.cmd_to_string prog args in 104 | Std.Util.error "Process creation \"%s\" failed with %s (%S)" cmd 105 | (Unix.error_message e) s 106 | | n -> f n obj 107 | -------------------------------------------------------------------------------- /src/internal/c_compile.mli: -------------------------------------------------------------------------------- 1 | val compile : 2 | ?stdout:Run.io_out -> 3 | stderr:Run.io_out -> 4 | string -> 5 | (int -> string -> 'a) -> 6 | 'a 7 | -------------------------------------------------------------------------------- /src/internal/ctypes_type_printing_fake.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* fdopen: FIXME upstream. The cmi is not installed and the lines below are 9 | stripped, because they would otherwise depend on other interface files that 10 | are not installed ... *) 11 | 12 | open Ctypes_static 13 | 14 | (* See type_printing.mli for the documentation of [format context]. *) 15 | type format_context = 16 | [ `toplevel 17 | | `array 18 | | `nonarray 19 | ] 20 | 21 | let rec format_typ' : 22 | type a. 23 | a typ -> 24 | (format_context -> Format.formatter -> unit) -> 25 | format_context -> 26 | Format.formatter -> 27 | unit = 28 | let fprintf = Format.fprintf in 29 | fun t k context fmt -> 30 | match t with 31 | | Void -> fprintf fmt "void%t" (k `nonarray) 32 | | Primitive _ -> 33 | let name = Ctypes.string_of_typ t in 34 | fprintf fmt "%s%t" name (k `nonarray) 35 | | View { format_typ = Some format; _ } -> format (k `nonarray) fmt 36 | | View { ty; _ } -> format_typ' ty k context fmt 37 | | Abstract { aname; _ } -> fprintf fmt "%s%t" aname (k `nonarray) 38 | | Struct { tag = ""; fields; _ } -> 39 | fprintf fmt "struct {@;<1 2>@["; 40 | format_fields fields fmt; 41 | fprintf fmt "@]@;}%t" (k `nonarray) 42 | | Struct { tag; spec; fields } -> ( 43 | match (spec, context) with 44 | | Complete _, `toplevel -> 45 | fprintf fmt "struct %s {@;<1 2>@[" tag; 46 | format_fields fields fmt; 47 | fprintf fmt "@]@;}%t" (k `nonarray) 48 | | _ -> fprintf fmt "struct %s%t" tag (k `nonarray)) 49 | | Union { utag = ""; ufields; _ } -> 50 | fprintf fmt "union {@;<1 2>@["; 51 | format_fields ufields fmt; 52 | fprintf fmt "@]@;}%t" (k `nonarray) 53 | | Union { utag; uspec; ufields } -> ( 54 | match (uspec, context) with 55 | | Some _, `toplevel -> 56 | fprintf fmt "union %s {@;<1 2>@[" utag; 57 | format_fields ufields fmt; 58 | fprintf fmt "@]@;}%t" (k `nonarray) 59 | | _ -> fprintf fmt "union %s%t" utag (k `nonarray)) 60 | | Pointer ty -> 61 | format_typ' ty 62 | (fun context fmt -> 63 | match context with 64 | | `array -> fprintf fmt "(*%t)" (k `nonarray) 65 | | _ -> fprintf fmt "*%t" (k `nonarray)) 66 | `nonarray fmt 67 | | Funptr fn -> 68 | format_fn' fn (fun fmt -> Format.fprintf fmt "(*%t)" (k `nonarray)) fmt 69 | | Array (ty, n) -> 70 | format_typ' ty 71 | (fun _ fmt -> fprintf fmt "%t[%d]" (k `array) n) 72 | `nonarray fmt 73 | | Bigarray _ -> () 74 | | OCaml String -> format_typ' (ptr char) k context fmt 75 | | OCaml Bytes -> format_typ' (ptr uchar) k context fmt 76 | | OCaml FloatArray -> format_typ' (ptr double) k context fmt 77 | 78 | and format_fields : type a. a boxed_field list -> Format.formatter -> unit = 79 | fun fields fmt -> 80 | let open Format in 81 | List.iteri 82 | (fun _i (BoxedField { ftype = t; fname; _ }) -> 83 | fprintf fmt "@["; 84 | format_typ' t (fun _ fmt -> fprintf fmt " %s" fname) `nonarray fmt; 85 | fprintf fmt "@];@;") 86 | fields 87 | 88 | and format_parameter_list parameters k fmt = 89 | Format.fprintf fmt "%t(@[@[" k; 90 | if parameters = [] then Format.fprintf fmt "void" 91 | else 92 | List.iteri 93 | (fun i (BoxedType t) -> 94 | if i <> 0 then Format.fprintf fmt "@], @["; 95 | format_typ' t (fun _ _ -> ()) `nonarray fmt) 96 | parameters; 97 | Format.fprintf fmt "@]@])" 98 | 99 | and format_fn' : 100 | 'a. 'a fn -> (Format.formatter -> unit) -> Format.formatter -> unit = 101 | let rec gather : type a. a fn -> boxed_typ list * boxed_typ = function 102 | | Returns ty -> ([], BoxedType ty) 103 | | Function (Void, fn) -> gather fn 104 | | Function (p, fn) -> 105 | let ps, r = gather fn in 106 | (BoxedType p :: ps, r) 107 | in 108 | fun fn k fmt -> 109 | let ps, BoxedType r = gather fn in 110 | format_typ' r 111 | (fun _context fmt -> format_parameter_list ps k fmt) 112 | `nonarray fmt 113 | 114 | let format_name ?name fmt = 115 | match name with Some name -> Format.fprintf fmt " %s" name | None -> () 116 | 117 | let format_typ : ?name:string -> Format.formatter -> 'a typ -> unit = 118 | fun ?name fmt typ -> 119 | Format.fprintf fmt "@["; 120 | format_typ' typ (fun _context -> format_name ?name) `nonarray fmt; 121 | Format.fprintf fmt "@]" 122 | 123 | let string_of_typ ?name ty = Format.asprintf "%a" (format_typ ?name) ty 124 | -------------------------------------------------------------------------------- /src/internal/ctypes_type_printing_fake.mli: -------------------------------------------------------------------------------- 1 | val string_of_typ : ?name:string -> 'a Ctypes_static.typ -> string 2 | -------------------------------------------------------------------------------- /src/internal/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (targets toplevel.ml) 3 | (deps (:f toplevel.cppo.ml)) 4 | (action 5 | (chdir %{project_root} 6 | (run %{bin:cppo} -V OCAML:%{ocaml_version} %{f} -o %{targets})))) 7 | 8 | (rule 9 | (targets ppx_cstubs_version.ml) 10 | (action 11 | (with-stdout-to 12 | %{targets} 13 | (echo "let version = \"%{version:ppx_cstubs}\"")))) 14 | 15 | (rule 16 | (targets ppxc__script.mli) 17 | (deps ppxc__script_real.mli) 18 | (action (copy %{deps} %{targets}))) 19 | 20 | (ocamllex 21 | (modules inline_lexer)) 22 | 23 | (library 24 | (name ppxc__script) 25 | (synopsis "just ignore it") 26 | (public_name ppx_cstubs.internal) 27 | (private_modules attributes ctypes_type_printing_fake evil_hack extract_c extract_c_ml gen_c gen_ml inline_lexer keywords lconst main marshal_types mparsetree myconst ocaml_config options ppxc__script_real ppx_main ptree run script_result std toplevel uniq_ref ppx_cstubs_version c_compile) 28 | (libraries bigarray-compat re.perl unix integers containers num findlib ctypes ppxlib ppx_cstubs) 29 | (preprocess (pps ppxlib.metaquot)) 30 | ; broken .merlin generation .... 31 | ; (preprocess (per_module 32 | ; ((pps ppxlib.metaquot) extract_c_ml ppxc__script_real ppx_cstubs gen_ml uniq_ref))) 33 | ) 34 | -------------------------------------------------------------------------------- /src/internal/evil_hack.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | (* I should extend Ctypes_primitives_types ... *) 20 | let format_typ k fmt = Format.fprintf fmt "value%t" k 21 | -------------------------------------------------------------------------------- /src/internal/extract_c.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | type extract_info 20 | 21 | val prologue : string 22 | 23 | type extract_int = 24 | [ `Unchecked_U8 25 | | `Unchecked_U32 26 | | `Any_int 27 | | `Int_type of string 28 | ] 29 | 30 | val prepare_extract_int : 31 | loc:Mparsetree.Ast_cur.Ast_helper.loc -> 32 | extract_int -> 33 | string -> 34 | extract_info * string * string 35 | 36 | val prepare_extract_string : 37 | loc:Mparsetree.Ast_cur.Ast_helper.loc -> 38 | string -> 39 | extract_info * string * string 40 | 41 | type obj 42 | 43 | val compile : ebuf:Buffer.t -> string -> (obj, string) CCResult.t 44 | 45 | type extract_error = 46 | | Info_not_found 47 | | Overflow of string 48 | | Underflow of string 49 | | Not_an_integer 50 | 51 | val extract : extract_info -> obj -> (string, extract_error) CCResult.t 52 | -------------------------------------------------------------------------------- /src/internal/extract_c_ml.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | open Ppxlib 20 | 21 | type extr_info = 22 | | Extr_char 23 | | Extr_schar 24 | | Extr_short 25 | | Extr_int 26 | | Extr_int8_t 27 | | Extr_int16_t 28 | | Extr_camlint 29 | | Extr_uchar 30 | | Extr_bool 31 | | Extr_long 32 | | Extr_llong 33 | | Extr_ushort 34 | | Extr_sint 35 | | Extr_uint 36 | | Extr_ulong 37 | | Extr_ullong 38 | | Extr_size_t 39 | | Extr_int32_t 40 | | Extr_int64_t 41 | | Extr_uint8_t 42 | | Extr_uint16_t 43 | | Extr_uint32_t 44 | | Extr_uint64_t 45 | | Extr_nativeint 46 | 47 | type info = { 48 | ctype : string; 49 | info : extr_info; 50 | } 51 | 52 | let rec prepare : type a. a Ctypes_static.typ -> info option = 53 | let open Ctypes_primitive_types in 54 | let module C = Ctypes_static in 55 | function 56 | | C.Void -> None 57 | | C.Struct _ -> None 58 | | C.Union _ -> None 59 | | C.Array _ -> None 60 | | C.Bigarray _ -> None 61 | | C.Abstract _ -> None 62 | | C.Pointer _ -> None 63 | | C.Funptr _ -> None 64 | | C.OCaml _ -> None 65 | | C.View { ty; _ } as t -> ( 66 | match prepare ty with 67 | | None -> None 68 | | Some x -> Some { x with ctype = Gen_c.string_of_typ_exn t }) 69 | | C.Primitive p as t -> ( 70 | let f info = 71 | (* bool/_Bool leads to ugly compiler warnings. 72 | And _Bool is undefined in C++. Limits are still checked below. *) 73 | let ctype = 74 | if info = Extr_bool then "int" else Gen_c.string_of_typ_exn t 75 | in 76 | Some { ctype; info } 77 | in 78 | match p with 79 | | Char -> f Extr_char 80 | | Schar -> f Extr_schar 81 | | Uchar -> f Extr_uchar 82 | | Bool -> f Extr_bool 83 | | Short -> f Extr_short 84 | | Int -> f Extr_int 85 | | Long -> f Extr_long 86 | | Llong -> f Extr_llong 87 | | Ushort -> f Extr_ushort 88 | | Sint -> f Extr_sint 89 | | Uint -> f Extr_uint 90 | | Ulong -> f Extr_ulong 91 | | Ullong -> f Extr_ullong 92 | | Size_t -> f Extr_size_t 93 | | Int8_t -> f Extr_int8_t 94 | | Int16_t -> f Extr_int16_t 95 | | Int32_t -> f Extr_int32_t 96 | | Int64_t -> f Extr_int64_t 97 | | Uint8_t -> f Extr_uint8_t 98 | | Uint16_t -> f Extr_uint16_t 99 | | Uint32_t -> f Extr_uint32_t 100 | | Uint64_t -> f Extr_uint64_t 101 | | Camlint -> f Extr_camlint 102 | | Nativeint -> f Extr_nativeint 103 | | Float -> None 104 | | Double -> None 105 | | LDouble -> None 106 | | Complex32 -> None 107 | | Complex64 -> None 108 | | Complexld -> None) 109 | 110 | let int8_max = Big_int.big_int_of_int 127 111 | 112 | let int8_min = Big_int.big_int_of_int (-128) 113 | 114 | let int16_max = Big_int.big_int_of_int 32767 115 | 116 | let int16_min = Big_int.big_int_of_int (-32768) 117 | 118 | let int32_max = Big_int.big_int_of_int32 Int32.max_int 119 | 120 | let int32_min = Big_int.big_int_of_int32 Int32.min_int 121 | 122 | let int64_min = Big_int.big_int_of_int64 Int64.min_int 123 | 124 | let int64_max = Big_int.big_int_of_int64 Int64.max_int 125 | 126 | let uint8_max = Big_int.big_int_of_int 255 127 | 128 | let uint16_max = Big_int.big_int_of_int 65535 129 | 130 | let uint32_max = Big_int.big_int_of_int64 4294967295L 131 | 132 | let uint64_max = Big_int.big_int_of_string "18446744073709551615" 133 | 134 | module X = struct 135 | open Mparsetree.Ast_cur.Ast_helper 136 | 137 | let string x = Exp.constant (Const.string x) 138 | 139 | let char x = Exp.constant (Const.char x) 140 | 141 | let int x = Exp.constant (Const.int x) 142 | 143 | let int32 x = Exp.constant (Const.int32 x) 144 | 145 | let int64 x = Exp.constant (Const.int64 x) 146 | 147 | let nativeint x = Exp.constant (Const.nativeint x) 148 | end 149 | 150 | type result = 151 | | Expr of expression 152 | | Underflow 153 | | Overflow 154 | 155 | exception Eunderflow 156 | 157 | exception Eoverflow 158 | 159 | let gen t str = 160 | let loc = !Ast_helper.default_loc in 161 | let w32 = Ocaml_config.word_size () = 32 in 162 | let camlint_max = 163 | if w32 then Big_int.big_int_of_int 1073741823 164 | else Big_int.big_int_of_int64 4611686018427387903L 165 | in 166 | let camlint_min = 167 | if w32 then Big_int.big_int_of_int (-1073741824) 168 | else Big_int.big_int_of_int64 (-4611686018427387904L) 169 | in 170 | let intnative_max = 171 | if w32 then Big_int.big_int_of_int32 2147483647l 172 | else Big_int.big_int_of_int64 9223372036854775807L 173 | in 174 | let intnative_min = 175 | if w32 then Big_int.big_int_of_int32 (-2147483648l) 176 | else Big_int.big_int_of_int64 (-9223372036854775808L) 177 | in 178 | let ( < ) a b = Big_int.compare_big_int a b < 0 in 179 | let ( <= ) a b = Big_int.compare_big_int a b <= 0 in 180 | let ( > ) a b = Big_int.compare_big_int a b > 0 in 181 | let ( >= ) a b = Big_int.compare_big_int a b >= 0 in 182 | let ( = ) a b = Big_int.compare_big_int a b = 0 in 183 | let xint r = X.int (Big_int.int_of_big_int r) in 184 | let xint64 r = X.int64 (Big_int.int64_of_big_int r) in 185 | let xnative r = X.nativeint (Big_int.nativeint_of_big_int r) in 186 | let xstr r = Big_int.string_of_big_int r |> X.string in 187 | let check_limits r min max = 188 | if r < min then raise_notrace Eunderflow; 189 | if r > max then raise_notrace Eoverflow 190 | in 191 | let check_unsigned r = 192 | if r < Big_int.zero_big_int then raise_notrace Eunderflow 193 | in 194 | let normal_int r min max = 195 | check_limits r min max; 196 | xint r 197 | in 198 | let rec as_sum ~add ~of_int ~of_int64 r = 199 | if r <= camlint_max then [%expr [%e of_int] [%e xint r]] 200 | else if r <= int64_max then [%expr [%e of_int64] [%e xint64 r]] 201 | else 202 | let ( - ) = Big_int.sub_big_int in 203 | let e = as_sum ~add ~of_int ~of_int64 (r - int64_max) in 204 | [%expr [%e add] [%e e] ([%e of_int64] [%e xint64 int64_max])] 205 | in 206 | let r = Big_int.big_int_of_string str in 207 | match t.info with 208 | | Extr_char -> 209 | check_limits r int8_min uint8_max; 210 | Char.chr ((Big_int.int_of_big_int r + 256) mod 256) |> X.char 211 | | Extr_schar -> normal_int r int8_min int8_max 212 | | Extr_short -> Big_int.int_of_big_int r |> X.int 213 | | Extr_int -> normal_int r camlint_min camlint_max 214 | | Extr_int8_t -> normal_int r int8_min int8_max 215 | | Extr_int16_t -> normal_int r int16_min int16_max 216 | | Extr_camlint -> normal_int r camlint_min camlint_max 217 | | Extr_bool -> 218 | check_limits r Big_int.zero_big_int Big_int.unit_big_int; 219 | if r = Big_int.zero_big_int then [%expr false] else [%expr true] 220 | | Extr_sint -> 221 | if r >= camlint_min && r <= camlint_max then 222 | [%expr Signed.SInt.of_int [%e xint r]] 223 | else if w32 && r >= intnative_min && r <= intnative_max then 224 | [%expr Signed.SInt.of_nativeint [%e xnative r]] 225 | else if r >= int64_min && r <= int64_max then 226 | [%expr Signed.SInt.of_int64 [%e xint64 r]] 227 | else [%expr Signed.SInt.of_string [%e xstr r]] 228 | | Extr_long -> 229 | if r >= camlint_min && r <= camlint_max then 230 | [%expr Signed.Long.of_int [%e xint r]] 231 | else if w32 && r >= intnative_min && r <= intnative_max then 232 | [%expr Signed.Long.of_nativeint [%e xnative r]] 233 | else if r >= int64_min && r <= int64_max then 234 | [%expr Signed.Long.of_int64 [%e xint64 r]] 235 | else [%expr Signed.Long.of_string [%e xstr r]] 236 | | Extr_llong -> 237 | if r >= camlint_min && r <= camlint_max then 238 | [%expr Signed.LLong.of_int [%e xint r]] 239 | else if w32 && r >= intnative_min && r <= intnative_max then 240 | [%expr Signed.LLong.of_nativeint [%e xnative r]] 241 | else if r >= int64_min && r <= int64_max then 242 | [%expr Signed.LLong.of_int64 [%e xint64 r]] 243 | else [%expr Signed.LLong.of_string [%e xstr r]] 244 | | Extr_int32_t -> 245 | check_limits r int32_min int32_max; 246 | Big_int.int32_of_big_int r |> X.int32 247 | | Extr_nativeint -> 248 | check_limits r intnative_min intnative_max; 249 | xnative r 250 | | Extr_int64_t -> 251 | check_limits r int64_min int64_max; 252 | xint64 r 253 | | Extr_uchar -> 254 | check_limits r Big_int.zero_big_int uint8_max; 255 | [%expr Unsigned.UChar.of_int [%e xint r]] 256 | | Extr_ushort -> 257 | check_unsigned r; 258 | if r <= camlint_max then [%expr Unsigned.UShort.of_int [%e xint r]] 259 | else if r <= int64_max then [%expr Unsigned.UShort.of_int64 [%e xint64 r]] 260 | else [%expr Unsigned.UShort.of_string [%e xstr r]] 261 | | Extr_uint -> 262 | check_unsigned r; 263 | if r <= camlint_max then [%expr Unsigned.UInt.of_int [%e xint r]] 264 | else if r <= int64_max then [%expr Unsigned.UInt.of_int64 [%e xint64 r]] 265 | else [%expr Unsigned.UInt.of_string [%e xstr r]] 266 | | Extr_ulong -> 267 | check_unsigned r; 268 | as_sum r ~add:[%expr Unsigned.ULong.add] 269 | ~of_int:[%expr Unsigned.ULong.of_int] 270 | ~of_int64:[%expr Unsigned.ULong.of_int64] 271 | | Extr_ullong -> 272 | check_unsigned r; 273 | as_sum r ~add:[%expr Unsigned.ULLong.add] 274 | ~of_int:[%expr Unsigned.ULLong.of_int] 275 | ~of_int64:[%expr Unsigned.ULLong.of_int64] 276 | | Extr_size_t -> 277 | check_unsigned r; 278 | as_sum r ~add:[%expr Unsigned.Size_t.add] 279 | ~of_int:[%expr Unsigned.Size_t.of_int] 280 | ~of_int64:[%expr Unsigned.Size_t.of_int64] 281 | | Extr_uint8_t -> 282 | check_limits r Big_int.zero_big_int uint8_max; 283 | [%expr Unsigned.UInt8.of_int [%e xint r]] 284 | | Extr_uint16_t -> 285 | check_limits r Big_int.zero_big_int uint16_max; 286 | [%expr Unsigned.UInt16.of_int [%e xint r]] 287 | | Extr_uint32_t -> 288 | check_limits r Big_int.zero_big_int uint32_max; 289 | if r <= camlint_max then [%expr Unsigned.UInt32.of_int [%e xint r]] 290 | else [%expr Unsigned.UInt32.of_int64 [%e xint64 r]] 291 | | Extr_uint64_t -> 292 | check_limits r Big_int.zero_big_int uint64_max; 293 | if r = uint64_max then [%expr Unsigned.UInt64.max_int] 294 | else 295 | as_sum r ~add:[%expr Unsigned.UInt64.add] 296 | ~of_int:[%expr Unsigned.UInt64.of_int] 297 | ~of_int64:[%expr Unsigned.UInt64.of_int64] 298 | 299 | exception Unsupported 300 | 301 | let gen_ext = 302 | let open Mparsetree.Ast_cur in 303 | let module U = Std.Util in 304 | let module C = Ctypes_static in 305 | fun t res expr -> 306 | let rec iter : 307 | type a. bool -> a Ctypes_static.typ -> expression * pattern option = 308 | fun inside_view x -> 309 | let loc = !Ast_helper.default_loc in 310 | match x with 311 | | C.Void -> raise_notrace Unsupported 312 | | C.Struct _ -> raise_notrace Unsupported 313 | | C.Union _ -> raise_notrace Unsupported 314 | | C.Array _ -> raise_notrace Unsupported 315 | | C.Bigarray _ -> raise_notrace Unsupported 316 | | C.Abstract _ -> raise_notrace Unsupported 317 | | C.Pointer _ -> raise_notrace Unsupported 318 | | C.Funptr _ -> raise_notrace Unsupported 319 | | C.OCaml _ -> raise_notrace Unsupported 320 | | C.View { ty; _ } -> 321 | let e, pat = iter true ty in 322 | let rvar = U.safe_mlname ~prefix:"read" () in 323 | let pread = U.mk_pat rvar in 324 | let eread = U.mk_ident rvar in 325 | let pat = 326 | match pat with 327 | | None -> 328 | [%pat? Ctypes_static.View { Ctypes_static.read = [%p pread]; _ }] 329 | | Some x -> 330 | [%pat? 331 | Ctypes_static.View 332 | { 333 | Ctypes_static.read = [%p pread]; 334 | Ctypes_static.ty = [%p x]; 335 | _; 336 | }] 337 | in 338 | let expr = [%expr [%e eread] [%e e]] in 339 | (expr, Some pat) 340 | | C.Primitive p as t -> 341 | let einfo = 342 | match prepare t with None -> raise_notrace Unsupported | Some x -> x 343 | in 344 | let expr = gen einfo res in 345 | let pat = 346 | match inside_view with 347 | | false -> None 348 | | true -> 349 | let p = Gen_ml.pat_expand_prim p in 350 | Some [%pat? Ctypes_static.Primitive [%p p]] 351 | in 352 | (expr, pat) 353 | in 354 | let e, p = iter false t in 355 | match p with 356 | | None -> e 357 | | Some p -> Gen_ml.match_nw expr (Ast_helper.Exp.case p e) 358 | 359 | let gen t str = 360 | try Expr (gen t str) with Eunderflow -> Underflow | Eoverflow -> Overflow 361 | 362 | let gen_ext t res expr = 363 | try Some (Expr (gen_ext t res expr)) with 364 | | Eunderflow -> Some Underflow 365 | | Eoverflow -> Some Overflow 366 | | Unsupported -> None 367 | -------------------------------------------------------------------------------- /src/internal/extract_c_ml.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | type extr_info 20 | 21 | type info = { 22 | ctype : string; 23 | info : extr_info; 24 | } 25 | 26 | type result = 27 | | Expr of Mparsetree.Ast_cur.Parsetree.expression 28 | | Underflow 29 | | Overflow 30 | 31 | val prepare : 'a Ctypes_static.typ -> info option 32 | 33 | val gen : info -> string -> result 34 | 35 | val gen_ext : 36 | 'a Ctypes_static.typ -> 37 | string -> 38 | Mparsetree.Ast_cur.Parsetree.expression -> 39 | result option 40 | -------------------------------------------------------------------------------- /src/internal/gen_c.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | type info = { 20 | stub_source : string; 21 | stub_name : string; 22 | stub_name_byte : string option; 23 | noalloc : bool; 24 | float : bool; 25 | return_errno : bool; 26 | } 27 | 28 | val gen_fun : 29 | 'a Ctypes.fn -> 30 | locs:Location.t list -> 31 | stubname:string -> 32 | cfunc:string -> 33 | release_runtime_lock:bool -> 34 | noalloc:bool -> 35 | return_errno:bool -> 36 | info 37 | 38 | val gen_value : 'a Ctypes.fn -> stubname:string -> value:string -> info 39 | 40 | val string_of_typ_exn : ?name:string -> 'a Ctypes.typ -> string 41 | 42 | val build_inline_fun : 43 | 'a Ctypes.fn -> 44 | c_name:string -> 45 | c_body:string -> 46 | locs:Location.t list -> 47 | noalloc:bool -> 48 | (Mparsetree.Ast_cur.Asttypes.arg_label * Marshal_types.expr) list -> 49 | string 50 | 51 | val gen_callback_fun : 'a Ctypes.fn -> Marshal_types.ocaml_funptr -> string 52 | 53 | (* fixme: MOVE*) 54 | val is_void : 'a Ctypes.typ -> bool 55 | -------------------------------------------------------------------------------- /src/internal/gen_ml.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | open Mparsetree.Ast_cur 20 | open Parsetree 21 | 22 | type result = { 23 | extern : structure_item; 24 | intern : structure_item; 25 | } 26 | 27 | val external' : 28 | 'a Ctypes.fn -> 29 | string -> 30 | (Asttypes.arg_label * expression) list -> 31 | expression -> 32 | Gen_c.info -> 33 | result 34 | 35 | val foreign : 'a Ctypes.fn -> string -> Gen_c.info -> expression -> result 36 | 37 | val foreign_value : 'a Ctypes.fn -> string -> expression -> Gen_c.info -> result 38 | 39 | val ocaml_funptr : Marshal_types.ocaml_funptr -> 'a Ctypes.fn -> unit 40 | 41 | (* move me somewhere else ... *) 42 | val stdlib_fun : string -> expression 43 | 44 | type record_stris = { 45 | r_stri_top : structure_item list; 46 | r_stri_bottom : structure_item list; 47 | r_stri_type_mod : structure_item list; 48 | } 49 | 50 | val gen_record_stris : 51 | mod_path:string list -> 52 | type_name:string -> 53 | (string * Mparsetree.Ast_cur.Ast_helper.loc * expression) list -> 54 | record_stris 55 | 56 | val pat_expand_prim : 'a Ctypes_primitive_types.prim -> pattern 57 | 58 | val match_nw : expression -> case -> expression 59 | -------------------------------------------------------------------------------- /src/internal/inline_lexer.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | type t = 20 | | Literal of string 21 | | Variable of (string * Lexing.position * Lexing.position) 22 | | Textend 23 | 24 | val token : Lexing.lexbuf -> t 25 | 26 | exception Bad_expander 27 | -------------------------------------------------------------------------------- /src/internal/inline_lexer.mll: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | { 20 | exception Bad_expander 21 | type t = 22 | | Literal of string 23 | | Variable of (string * Lexing.position * Lexing.position) 24 | | Textend 25 | 26 | let help id lb = 27 | Variable(id, Lexing.lexeme_start_p lb, Lexing.lexeme_end_p lb) 28 | } 29 | 30 | let upcase = [ 'A' - 'Z' ] 31 | let downcase = [ 'a' - 'z' '_' ] 32 | let number = [ '0' - '9' ] 33 | let id_suffix = upcase | downcase | number | '\'' 34 | let identifier = downcase id_suffix * 35 | 36 | rule token = parse 37 | | '$' (identifier as id) {help id lexbuf} 38 | | '$' '{' (identifier as id) '}' {help id lexbuf} 39 | | '$' '$' {Literal("$")} 40 | | '$' {raise_notrace Bad_expander} 41 | | [^ '$' ]+ {Literal(Lexing.lexeme lexbuf)} 42 | | eof { Textend } 43 | | _ {Literal(Lexing.lexeme lexbuf)} 44 | -------------------------------------------------------------------------------- /src/internal/keywords.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | let htl = Hashtbl.create 8 20 | 21 | let () = 22 | List.iter 23 | (fun k -> Hashtbl.replace htl k ()) 24 | [ 25 | "abstract"; 26 | "aint"; 27 | "constant"; 28 | "field"; 29 | "foreign"; 30 | "foreign_value"; 31 | "funptr"; 32 | "funptr_opt"; 33 | "header"; 34 | "int"; 35 | "opaque"; 36 | "ptr"; 37 | "ptr_opt"; 38 | "returning"; 39 | "seal"; 40 | "static_funptr"; 41 | "structure"; 42 | "uint"; 43 | "union"; 44 | "@->"; 45 | ] 46 | 47 | (* cmitomli ctypes.cmi | awk '/val [^\(]/ {print $2}' | ...*) 48 | 49 | let htl_modules = Hashtbl.create 16 50 | 51 | let () = 52 | List.iter 53 | (fun k -> Hashtbl.replace htl_modules k ()) 54 | [ 55 | "Complex"; 56 | "ComplexL"; 57 | "Cstubs_internals"; 58 | "Ctypes"; 59 | "Ctypes_static"; 60 | "LDouble"; 61 | "Ppx_cstubs"; 62 | "Signed"; 63 | "Unsigned"; 64 | ] 65 | 66 | let htl_types = Hashtbl.create 16 67 | 68 | let () = 69 | List.iter 70 | (fun k -> Hashtbl.replace htl_types k ()) 71 | [ 72 | "bool"; 73 | "char"; 74 | "float"; 75 | "int"; 76 | "int32"; 77 | "int64"; 78 | "list"; 79 | "nativeint"; 80 | "option"; 81 | "string"; 82 | "unit"; 83 | ] 84 | -------------------------------------------------------------------------------- /src/internal/lconst.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2020 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | let type_mod_name = ref "" 20 | 21 | let impl_mod_name = ref "" 22 | 23 | let type_modtype_name = ref "" 24 | 25 | let clear () = 26 | impl_mod_name := "Ppxc_private_impl"; 27 | type_mod_name := "Ppxc_private_types"; 28 | type_modtype_name := "__ppxc_private" 29 | 30 | let () = clear () 31 | 32 | let init usf = 33 | let use_open_struct = Ocaml_config.use_open_struct () in 34 | (type_modtype_name := 35 | match usf with "" -> "__ppxc_private_types" | s -> "__ppxc_" ^ s); 36 | let name = match usf with "" -> "Ppxc_private" | s -> "Ppxc_" ^ s in 37 | if use_open_struct then ( 38 | (impl_mod_name := match usf with "" -> "Ppxc__private" | s -> "Ppxc__" ^ s); 39 | type_mod_name := name) 40 | else ( 41 | impl_mod_name := name; 42 | type_mod_name := 43 | match usf with 44 | | "" -> "Ppxc_private_types" 45 | | s -> String.concat "_" [ "Ppxc"; s; "types" ]) 46 | 47 | type merlin_state = { 48 | ximpl_mod_name : string; 49 | xtype_mod_name : string; 50 | xtype_modtype_name : string; 51 | } 52 | 53 | let merlin_save () = 54 | { 55 | ximpl_mod_name = !impl_mod_name; 56 | xtype_mod_name = !type_mod_name; 57 | xtype_modtype_name = !type_modtype_name; 58 | } 59 | 60 | let merlin_restore { ximpl_mod_name; xtype_mod_name; xtype_modtype_name } = 61 | impl_mod_name := ximpl_mod_name; 62 | type_mod_name := xtype_mod_name; 63 | type_modtype_name := xtype_modtype_name 64 | -------------------------------------------------------------------------------- /src/internal/lconst.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | val type_mod_name : string ref 20 | 21 | val impl_mod_name : string ref 22 | 23 | val type_modtype_name : string ref 24 | 25 | val clear : unit -> unit 26 | 27 | val init : string -> unit 28 | 29 | type merlin_state 30 | 31 | val merlin_save : unit -> merlin_state 32 | 33 | val merlin_restore : merlin_state -> unit 34 | -------------------------------------------------------------------------------- /src/internal/main.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | open Std.Result 20 | 21 | let executable = Filename.basename Sys.executable_name 22 | 23 | let error_exit s = 24 | Printf.eprintf "%s: %s Try %s --help\n" executable s executable; 25 | exit 1 26 | 27 | let set_binary () = 28 | set_binary_mode_out stdout true; 29 | set_binary_mode_out stderr true; 30 | set_binary_mode_in stdin true 31 | 32 | let common_main top mode = 33 | set_binary (); 34 | Ppx_main.init top; 35 | match mode with 36 | | `Merlin -> () 37 | | `Main argv -> 38 | Toplevel.set_argv argv; 39 | Ppxlib.Driver.standalone () 40 | 41 | let cpp_main top = 42 | let usage = 43 | Printf.sprintf "%s [] -o-ml my_module.ml -o-c my_module_stubs.c" 44 | executable 45 | in 46 | let anon_is_target = ref false in 47 | let na f p = 48 | anon_is_target := false; 49 | f p 50 | in 51 | let arg_set_string v = Arg.String (na (fun s -> v := s)) in 52 | let arg_set v = Arg.Unit (na (fun () -> v := true)) in 53 | let arg_string f = Arg.String (na f) in 54 | let arg_set_int v = Arg.Int (na (fun a -> v := a)) in 55 | let ml_output = ref "" in 56 | let c_output = ref "" in 57 | let use_cxx = ref false in 58 | let pretty = ref false in 59 | let cflags = ref [] in 60 | let cflags_rest = ref [] in 61 | let oflags = ref (List.rev Options.ocaml_include_dirs_default) in 62 | let include_dirs = ref [] in 63 | let keep_tmp = ref false in 64 | let toolchain = ref None in 65 | let cc = ref None in 66 | let findlib_pkgs = ref [] in 67 | let cma_files = ref [] in 68 | let verbose = ref 1 in 69 | let absname = ref false in 70 | let nopervasives = ref false in 71 | let no_openstruct = ref false in 72 | let set_output_by_suffix s = 73 | match CCString.Split.right ~by:"." s with 74 | | None -> 75 | if CCString.lowercase_ascii s = "none" then c_output := s 76 | else raise (Arg.Bad s) 77 | | Some (_, suf) -> ( 78 | if String.length suf = 0 then raise (Arg.Bad s); 79 | match CCChar.lowercase_ascii suf.[0] with 80 | | 'r' | 'm' -> ml_output := s 81 | | 'c' -> c_output := s 82 | | _ -> raise (Arg.Bad s)) 83 | in 84 | let spec = 85 | Arg.align 86 | [ 87 | ( "-o-ml", 88 | arg_set_string ml_output, 89 | " write generated OCaml file to " ); 90 | ( "-o-c", 91 | arg_set_string c_output, 92 | " write generated C file to " ); 93 | ( "-o", 94 | Arg.String 95 | (fun s -> 96 | anon_is_target := true; 97 | set_output_by_suffix s), 98 | "\xC2\xA0 \xC2\xA0write generated files to and . The files must have proper suffixes" 99 | ); 100 | ( "-cflag", 101 | arg_string (fun s -> cflags := s :: !cflags), 102 | " Pass option to the C compiler" ); 103 | ( "-I", 104 | arg_string (fun s -> 105 | include_dirs := s :: !include_dirs; 106 | oflags := s :: !oflags; 107 | anon_is_target := false), 108 | " Add to the list of include directories" ); 109 | ( "-pkg", 110 | arg_string (fun s -> 111 | findlib_pkgs := Std.Various.split_findlib_pkgs s @ !findlib_pkgs), 112 | " import types from findlib package " ); 113 | ( "-toolchain", 114 | arg_string (fun s -> toolchain := Some s), 115 | " use ocamlfind toolchain " ); 116 | ("-keep-tmp", arg_set keep_tmp, " Don't delete temporary files"); 117 | ( "-pretty", 118 | arg_set pretty, 119 | " Print a human readable ml file instead of the binary ast" ); 120 | ( "-verbose", 121 | arg_set_int verbose, 122 | " Set the level of verbosity. By default, it is set to 1" ); 123 | ( "-quiet", 124 | Arg.Unit (na (fun () -> verbose := 0)), 125 | " Make ppx_cstubs silent. Same as -verbose 0" ); 126 | ( "-absname", 127 | arg_set absname, 128 | " Show absolute filenames in error messages" ); 129 | ( "-no-openstruct", 130 | arg_set no_openstruct, 131 | " Disable hiding through 'open struct'." ); 132 | ("-nopervasives", arg_set nopervasives, " (undocumented)"); 133 | ( "-cc", 134 | arg_string (fun s -> cc := Some s), 135 | " Use as the C/C++ compiler" ); 136 | ( "-cxx", 137 | arg_set use_cxx, 138 | " use the default compiler in c++ mode to extract constants" ); 139 | ( "-version", 140 | Arg.Unit 141 | (fun () -> 142 | print_endline Ppx_cstubs_version.version; 143 | exit 0), 144 | " Print the version of the program and exit" ); 145 | ( "--", 146 | Arg.Rest (fun a -> cflags_rest := a :: !cflags_rest), 147 | " Pass all following parameters verbatim to the c compiler" ); 148 | ] 149 | in 150 | let add_cma_file a = 151 | if Sys.file_exists a then cma_files := a :: !cma_files 152 | else 153 | let c = 154 | ListLabels.exists !include_dirs ~f:(fun d -> 155 | let a = Filename.concat d a in 156 | if Sys.file_exists a then ( 157 | cma_files := a :: !cma_files; 158 | true) 159 | else false) 160 | in 161 | if c = false then Printf.sprintf "%S doesn't exist\n" a |> error_exit 162 | in 163 | let source = ref None in 164 | let argv = 165 | Array.fold_left 166 | (fun (ac, b) el -> 167 | let nac = el :: ac in 168 | if b then (nac, b) 169 | else 170 | match el with 171 | | "--" -> (nac, true) 172 | | "\002--ignore-ppx_cstubs\003" -> (ac, false) 173 | | _ -> (nac, false)) 174 | ([], false) Sys.argv 175 | |> fst 176 | |> List.rev 177 | |> Array.of_list 178 | in 179 | let arg_fun a = 180 | if a = "" then raise (Arg.Bad a); 181 | let la = CCString.lowercase_ascii a in 182 | if Filename.check_suffix la ".cma" || Filename.check_suffix la ".cmo" then ( 183 | anon_is_target := false; 184 | add_cma_file a) 185 | else if !anon_is_target then ( 186 | anon_is_target := false; 187 | set_output_by_suffix a) 188 | else ( 189 | if !source <> None then raise (Arg.Bad a); 190 | source := Some a) 191 | in 192 | (match Arg.parse_argv argv spec arg_fun usage with 193 | | () -> () 194 | | exception Arg.Bad message -> 195 | prerr_string message; 196 | exit 2 197 | | exception Arg.Help message -> 198 | print_string message; 199 | exit 0); 200 | let source = 201 | match !source with 202 | | None -> error_exit "no source file specified" 203 | | Some s -> s 204 | in 205 | let ml_output = 206 | match !ml_output with "" -> error_exit "ml output file missing" | c -> c 207 | in 208 | let c_output = match !c_output with "" -> "none" | s -> s in 209 | if ml_output = c_output then error_exit "use different output files"; 210 | if !absname then Toplevel.set_absname true; 211 | let h s = 212 | let s = CCString.lowercase_ascii s in 213 | let s = Filename.basename s in 214 | try Filename.chop_extension s with Invalid_argument _ -> s 215 | in 216 | if CCString.lowercase_ascii c_output <> "none" then ( 217 | if h ml_output = h c_output then 218 | error_exit "filenames must differ, not only their suffix"; 219 | Options.c_output_file := Some c_output); 220 | Options.ocaml_include_dirs := List.rev !oflags; 221 | Options.c_flags := List.rev !cflags @ List.rev !cflags_rest; 222 | Options.keep_tmp := !keep_tmp; 223 | Options.nopervasives := !nopervasives; 224 | Options.mode := Options.Regular; 225 | Options.ml_input_file := Some source; 226 | Options.ml_output_file := Some ml_output; 227 | Options.toolchain := !toolchain; 228 | Options.cma_files := List.rev !cma_files; 229 | Options.findlib_pkgs := List.rev !findlib_pkgs; 230 | Options.use_open_struct := not !no_openstruct; 231 | Options.verbosity := !verbose; 232 | Options.cc := !cc; 233 | Options.pretty := !pretty; 234 | Options.use_cxx := !use_cxx; 235 | (* trigger exceptions *) 236 | Ocaml_config.init (); 237 | (* use native Findlib.init () *) 238 | let stc = 239 | match Sys.getenv "OCAMLFIND_TOOLCHAIN" with 240 | | exception Not_found -> None 241 | | "" -> None 242 | | tc -> 243 | Unix.putenv "OCAMLFIND_TOOLCHAIN" ""; 244 | Some tc 245 | in 246 | Toplevel.init top; 247 | (match stc with None -> () | Some x -> Unix.putenv "OCAMLFIND_TOOLCHAIN" x); 248 | let l = if ml_output = "-" then [] else [ "-o"; ml_output ] in 249 | let l = source :: l in 250 | let l = if !pretty then l else "--dump-ast" :: l in 251 | let l = Sys.argv.(0) :: l in 252 | common_main top (`Main (Array.of_list l)) 253 | 254 | let merlin_main top = 255 | Options.mode := Options.Emulate; 256 | common_main top `Merlin 257 | 258 | let merlin_run_top top = 259 | set_binary (); 260 | let p1, script = Marshal.from_channel stdin in 261 | close_in stdin; 262 | Merlin_state.from_parent p1; 263 | Options.mode := Emulate; 264 | Toplevel.init top; 265 | top#eval script; 266 | Merlin_state.to_parent () 267 | 268 | let merlin_run_top top = 269 | let r = 270 | try Ok (Std.Util.convert_ctypes_exeptions (fun () -> merlin_run_top top)) 271 | with x -> Error (Merlin_state.to_error x) 272 | in 273 | Marshal.to_channel stdout r []; 274 | flush stdout; 275 | exit 0 276 | 277 | let init top = 278 | if top#is_merlin_ppx then merlin_main top 279 | else if CCArray.exists (( = ) "--run-merlin-top") Sys.argv then 280 | merlin_run_top top 281 | else cpp_main top 282 | -------------------------------------------------------------------------------- /src/internal/main.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | val init : Ppxc__script_real.top_run -> unit 20 | -------------------------------------------------------------------------------- /src/internal/marshal_types.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | open Mparsetree.Ast_cur 20 | 21 | type fun_params = { 22 | el : (arg_label * expression) list; 23 | ret : expression; 24 | release_runtime_lock : bool; 25 | noalloc : bool; 26 | is_inline : bool; 27 | return_errno : bool; 28 | remove_labels : bool; 29 | c_name : string; 30 | (* external xyz : .... = "c_name" *) 31 | prim_name : string; 32 | (* external prim_name : ..... *) 33 | uniq_ref_id : Uniq_ref.t; 34 | } 35 | 36 | type id = int 37 | 38 | type loc = Ast_helper.loc 39 | 40 | type id_loc_param = id * loc 41 | 42 | type expr = expression 43 | 44 | type enum_type = 45 | | E_normal of id 46 | | E_bitmask of id 47 | | E_normal_bitmask of id * id 48 | 49 | type enum_entry = { 50 | ee_int_id : int; 51 | ee_type_check : int; 52 | ee_loc : Location.t; 53 | ee_expr : expr; 54 | ee_cname : string; 55 | } 56 | 57 | type enum = { 58 | enum_l : enum_entry list; 59 | enum_name : string; 60 | enum_is_typedef : bool; 61 | enum_type_id : enum_type; 62 | enum_is_int_bitmask : bool; 63 | enum_loc : loc; 64 | enum_unexpected : expr; 65 | enum_unexpected_bits : expr; 66 | } 67 | 68 | type struct_record_params = { 69 | sr_mod_path : string list; 70 | sr_type_name : string; 71 | sr_field_names : string list; 72 | sr_locs : loc list; 73 | } 74 | 75 | type opaque_params = { 76 | o_binding_name : string; 77 | o_uniq_ref_id : Uniq_ref.t; 78 | } 79 | 80 | type ocaml_funptr = { 81 | cb_mod_path : string list; 82 | cb_binding_name : string; 83 | cb_bottom : id; 84 | cb_top_mod : string; 85 | cb_acquire_runtime : bool; 86 | cb_thread_registration : bool; 87 | cb_user_fun : expression; 88 | cb_init_fun : string; 89 | } 90 | -------------------------------------------------------------------------------- /src/internal/merlin_state.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | type to_child = { 20 | opt : Options.merlin_state; 21 | sr : Script_result.merlin_state; 22 | ur : Uniq_ref.merlin_state; 23 | lc : Lconst.merlin_state; 24 | ui : Uniq_ids.merlin_state; 25 | } 26 | 27 | type from_child = { 28 | fsr : Script_result.merlin_state; 29 | fur : Uniq_ref.merlin_state; 30 | fui : Uniq_ids.merlin_state; 31 | } 32 | 33 | let to_child () = 34 | { 35 | opt = Options.merlin_save (); 36 | sr = Script_result.merlin_save (); 37 | ur = Uniq_ref.merlin_save (); 38 | lc = Lconst.merlin_save (); 39 | ui = Uniq_ids.merlin_save (); 40 | } 41 | 42 | let from_parent { opt; sr; ur; lc; ui } = 43 | Options.merlin_restore opt; 44 | Script_result.merlin_restore sr; 45 | Uniq_ref.merlin_restore ur; 46 | Lconst.merlin_restore lc; 47 | Uniq_ids.merlin_restore ui 48 | 49 | let to_parent () = 50 | { 51 | fsr = Script_result.merlin_save (); 52 | fur = Uniq_ref.merlin_save (); 53 | fui = Uniq_ids.merlin_save (); 54 | } 55 | 56 | let from_child { fsr; fur; fui } = 57 | Script_result.merlin_restore fsr; 58 | Uniq_ref.merlin_restore fur; 59 | Uniq_ids.merlin_restore fui 60 | 61 | type error = 62 | (* fixme: more errors? *) 63 | | Location of Location.t * string 64 | | Env of Env.error 65 | | Typecore of Location.t * Env.t * Typecore.error 66 | | Typedecl of Location.t * Typedecl.error 67 | 68 | let to_error x = 69 | let er x = 70 | let a, b = Toplevel.serialize_location_error x in 71 | Location (a, b) 72 | in 73 | let common x = 74 | let s = Printexc.to_string x in 75 | try Std.Util.error "%s" s with Location.Error x -> er x 76 | in 77 | let catch e = 78 | match ignore (Marshal.to_string e [] : string) with 79 | | () -> e 80 | | exception Invalid_argument _ -> common x 81 | in 82 | match x with 83 | | Location.Error x -> er x 84 | | Env.Error e -> catch (Env e) 85 | | Typecore.Error (e, f, g) -> catch (Typecore (e, f, g)) 86 | | Typedecl.Error (l, e) -> catch (Typedecl (l, e)) 87 | | x -> common x 88 | 89 | let raise_error = function 90 | | Location (loc, s) -> Std.Util.error ~loc "%s" s 91 | | Env x -> raise (Env.Error x) 92 | | Typecore (a, b, c) -> raise (Typecore.Error (a, b, c)) 93 | | Typedecl (a, b) -> raise (Typedecl.Error (a, b)) 94 | -------------------------------------------------------------------------------- /src/internal/merlin_state.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | type to_child 20 | 21 | type from_child 22 | 23 | val to_child : unit -> to_child 24 | 25 | val from_parent : to_child -> unit 26 | 27 | val to_parent : unit -> from_child 28 | 29 | val from_child : from_child -> unit 30 | 31 | type error 32 | 33 | val to_error : exn -> error 34 | 35 | val raise_error : error -> 'a 36 | -------------------------------------------------------------------------------- /src/internal/mparsetree.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | module Ast_cur = Ppxlib 20 | -------------------------------------------------------------------------------- /src/internal/myconst.ml: -------------------------------------------------------------------------------- 1 | let private_prefix = "ppxc__" 2 | 3 | let private_prefix_capitalized = CCString.capitalize_ascii private_prefix 4 | -------------------------------------------------------------------------------- /src/internal/ocaml_config.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | module StringMap = CCMap.Make (CCString) 20 | 21 | let config = 22 | lazy 23 | (let buffer = Buffer.create 2048 in 24 | let args = [ "c"; "-config" ] in 25 | let args = 26 | match !Options.toolchain with 27 | | None -> args 28 | | Some s -> "-toolchain" :: s :: args 29 | in 30 | let stderr = if !Options.verbosity > 1 then `Stderr else `Null in 31 | let prog = Options.ocamlfind in 32 | (match Run.run prog args ~stdout:(`Buffer buffer) ~stderr with 33 | | exception Unix.Unix_error (e, s, _) -> 34 | let cmd = Run.cmd_to_string prog args in 35 | Printf.sprintf "Process creation \"%s\" failed with %s (%S)" cmd 36 | (Unix.error_message e) s 37 | |> failwith 38 | | 0 -> () 39 | | x -> 40 | Printf.sprintf "`ocamlfind ocamlc -config` failed with %d" x |> failwith); 41 | let r = 42 | Buffer.contents buffer 43 | |> CCString.split_on_char '\n' 44 | |> CCList.filter_map (fun a -> 45 | match CCString.Split.left ~by:":" a with 46 | | None -> None 47 | | Some (a, b) -> 48 | let a = String.trim a 49 | and b = String.trim b in 50 | if a = "" then None else Some (a, b)) 51 | |> StringMap.of_list 52 | in 53 | if r = StringMap.empty then 54 | failwith "invalid output of `ocamlfind ocamlc -config"; 55 | r) 56 | 57 | let ext_obj = 58 | lazy 59 | (if Options.(!mode = Emulate) then ".o" 60 | else 61 | match StringMap.find "ext_obj" (Lazy.force config) with 62 | | exception Not_found -> 63 | failwith "`ocamlc -config` doesn't contain ext_obj" 64 | | "" -> failwith "ext_obj in `ocamlc -config` is empty" 65 | | x -> x) 66 | 67 | let runtime_version = 68 | Scanf.sscanf Sys.ocaml_version "%u.%u.%u" (fun a b c -> (a, b, c)) 69 | 70 | let version = 71 | lazy 72 | (if Options.(!mode = Emulate) then runtime_version 73 | else 74 | match StringMap.find "version" (Lazy.force config) with 75 | | exception Not_found -> 76 | if runtime_version >= (4, 3, 0) then 77 | failwith "`ocamlc -config` doesn't contain 'version'"; 78 | runtime_version 79 | | x -> ( 80 | try Scanf.sscanf x "%u.%u.%u" (fun a b c -> (a, b, c)) 81 | with End_of_file | Scanf.Scan_failure _ | Failure _ -> 82 | failwith "`ocamlc -config` contains a surprising version string")) 83 | 84 | let word_size = 85 | lazy 86 | (if Options.(!mode = Emulate) then Sys.word_size 87 | else 88 | match StringMap.find "word_size" (Lazy.force config) with 89 | | exception Not_found -> 90 | if runtime_version >= (4, 5, 0) then 91 | failwith "`ocamlc -config` doesn't contain word_size" 92 | else Sys.word_size 93 | | x -> ( 94 | match int_of_string x with 95 | | exception Failure _ -> 96 | failwith "word_size in `ocamlc -config` is not a number" 97 | | (32 | 64) as x -> x 98 | | x -> 99 | Printf.sprintf "unusual word_size (%d) reported by `ocamlc -config`" x 100 | |> failwith)) 101 | 102 | let system = 103 | lazy 104 | (if Options.(!mode = Emulate) then "linux" 105 | else 106 | match StringMap.find "system" (Lazy.force config) with 107 | | exception Not_found -> failwith "`ocamlc -config` doesn't report system" 108 | | "" -> failwith "`ocamlc -config` reports an empty system" 109 | | x -> x) 110 | 111 | let re_space = Re.Perl.re "[\r\n\t ]+" |> Re.compile 112 | 113 | let c_compiler_flags = 114 | lazy 115 | (if Options.(!mode = Emulate) then ("gcc", []) 116 | else 117 | let c = Lazy.force config in 118 | match 119 | ( StringMap.find "c_compiler" c, 120 | StringMap.find "ocamlc_cflags" c, 121 | StringMap.find "ocamlc_cppflags" c ) 122 | with 123 | | exception Not_found -> ( 124 | if runtime_version >= (4, 6, 0) then 125 | failwith "`ocamlc -config` doesn't list c_compiler and flags"; 126 | match StringMap.find "bytecomp_c_compiler" c with 127 | | exception Not_found -> 128 | failwith "`ocamlc -config` doesn't report bytecomp_c_compiler" 129 | | s -> ( 130 | match Re.split re_space s with 131 | | [] -> failwith "`ocamlc -config` doesn't report bytecomp_c_compiler" 132 | | hd :: tl -> (hd, tl))) 133 | | "", _, _ -> failwith "`ocamlc -config` does report an empty c compiler" 134 | | a, b, c -> (a, Re.split re_space b @ Re.split re_space c)) 135 | 136 | let standard_library = 137 | lazy 138 | (if Options.(!mode = Emulate) then "/tmp" 139 | else 140 | match StringMap.find "standard_library" (Lazy.force config) with 141 | | exception Not_found -> 142 | failwith "`ocamlc -config` doesn't report standard_library" 143 | | "" -> failwith "`ocamlc -config` standard_library entry is empty" 144 | | x -> x) 145 | 146 | let init () = 147 | (* trigger fatal errors *) 148 | ignore (Lazy.force word_size : int); 149 | ignore (Lazy.force ext_obj : string); 150 | ignore (Lazy.force version : int * int * int); 151 | ignore (Lazy.force system : string); 152 | ignore (Lazy.force c_compiler_flags : string * string list); 153 | ignore (Lazy.force standard_library : string) 154 | 155 | let word_size () = Lazy.force word_size 156 | 157 | let ext_obj () = Lazy.force ext_obj 158 | 159 | let version () = Lazy.force version 160 | 161 | let system () = Lazy.force system 162 | 163 | let use_open_struct () = !Options.use_open_struct && version () >= (4, 8, 0) 164 | 165 | let c_compiler_flags () = Lazy.force c_compiler_flags 166 | 167 | let standard_library () = Lazy.force standard_library 168 | -------------------------------------------------------------------------------- /src/internal/ocaml_config.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | (* not necessary, but triggers all fatal exceptions *) 20 | val init : unit -> unit 21 | 22 | val word_size : unit -> int 23 | 24 | val ext_obj : unit -> string 25 | 26 | val version : unit -> int * int * int 27 | 28 | val system : unit -> string 29 | 30 | val runtime_version : int * int * int 31 | 32 | val use_open_struct : unit -> bool 33 | 34 | val c_compiler_flags : unit -> string * string list 35 | 36 | val standard_library : unit -> string 37 | -------------------------------------------------------------------------------- /src/internal/options.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | let ocaml_include_dirs_default = [] 20 | 21 | let keep_tmp = ref false 22 | 23 | let nopervasives = ref false 24 | 25 | let use_open_struct = ref true 26 | 27 | let verbosity = ref 1 28 | 29 | let c_flags : string list ref = ref [] 30 | 31 | let ocaml_include_dirs : string list ref = ref ocaml_include_dirs_default 32 | 33 | let c_output_file : string option ref = ref None 34 | 35 | let ml_input_file : string option ref = ref None 36 | 37 | let ml_output_file : string option ref = ref None 38 | 39 | let toolchain : string option ref = ref None 40 | 41 | let findlib_pkgs : string list ref = ref [] 42 | 43 | let cma_files : string list ref = ref [] 44 | 45 | let pretty = ref false 46 | 47 | type merlin_state = { 48 | noperv : bool; 49 | uos : bool; 50 | verb : int; 51 | oflags : string list; 52 | tlc : string option; 53 | cmas : string list; 54 | fpkgs : string list; 55 | } 56 | 57 | let merlin_save () = 58 | { 59 | noperv = !nopervasives; 60 | uos = !use_open_struct; 61 | verb = !verbosity; 62 | oflags = !ocaml_include_dirs; 63 | cmas = !cma_files; 64 | tlc = !toolchain; 65 | fpkgs = !findlib_pkgs; 66 | } 67 | 68 | let merlin_restore { noperv; uos; verb; oflags; cmas; tlc; fpkgs } = 69 | nopervasives := noperv; 70 | use_open_struct := uos; 71 | verbosity := verb; 72 | ocaml_include_dirs := oflags; 73 | cma_files := cmas; 74 | toolchain := tlc; 75 | findlib_pkgs := fpkgs 76 | 77 | (* not yet configurable, but maybe in the future ... *) 78 | let ocamlfind = 79 | match Sys.win32 with true -> "ocamlfind.exe" | false -> "ocamlfind" 80 | 81 | type mode = 82 | | Regular 83 | | Emulate 84 | 85 | let mode = ref Regular 86 | 87 | let cc : string option ref = ref None 88 | 89 | let use_cxx = ref false 90 | 91 | let toolchain_used () = 92 | if !toolchain <> None then true 93 | else 94 | match Sys.getenv "OCAMLFIND_TOOLCHAIN" with 95 | | exception Not_found -> false 96 | | "" -> false 97 | | _ -> true 98 | 99 | (*let reset () = 100 | keep_tmp := false; 101 | nopervasives := false; 102 | verbosity := 1; 103 | c_flags := []; 104 | ocaml_include_dirs := ocaml_include_dirs_default; 105 | c_output_file := None; 106 | ml_input_file := None; 107 | ml_output_file := None; 108 | toolchain := None; 109 | use_open_struct := true; 110 | findlib_pkgs := []; 111 | cma_files := []; 112 | mode := Regular; 113 | pretty := false; 114 | cc := None 115 | *) 116 | -------------------------------------------------------------------------------- /src/internal/options.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | val ocaml_include_dirs_default : string list 20 | 21 | val keep_tmp : bool ref 22 | 23 | val nopervasives : bool ref 24 | 25 | val use_open_struct : bool ref 26 | 27 | val verbosity : int ref 28 | 29 | val c_flags : string list ref 30 | 31 | val ocaml_include_dirs : string list ref 32 | 33 | val c_output_file : string option ref 34 | 35 | val ml_input_file : string option ref 36 | 37 | val ml_output_file : string option ref 38 | 39 | val toolchain : string option ref 40 | 41 | val findlib_pkgs : string list ref 42 | 43 | val cma_files : string list ref 44 | 45 | val pretty : bool ref 46 | 47 | val ocamlfind : string 48 | 49 | type mode = 50 | | Regular 51 | | Emulate 52 | 53 | val mode : mode ref 54 | 55 | val cc : string option ref 56 | 57 | val use_cxx : bool ref 58 | 59 | val toolchain_used : unit -> bool 60 | 61 | type merlin_state 62 | 63 | val merlin_save : unit -> merlin_state 64 | 65 | val merlin_restore : merlin_state -> unit 66 | -------------------------------------------------------------------------------- /src/internal/ppx_main.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | val init : Ppxc__script_real.top_run -> unit 20 | -------------------------------------------------------------------------------- /src/internal/ppxc__script.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | open Std.Result 20 | 21 | let real_init top = Main.init top 22 | 23 | include Ppxc__script_real 24 | 25 | let _init top = 26 | let top = 27 | match top with 28 | | Some t -> t 29 | | None -> 30 | object 31 | method eval expr = 32 | let p1 = Merlin_state.to_child () in 33 | let s = Marshal.to_string (p1, expr) [] in 34 | let b = Buffer.create 8192 in 35 | let prog = if Sys.win32 then "ppx_cstubs.exe" else "ppx_cstubs" in 36 | let args = [ "--run-merlin-top" ] in 37 | let eb = Buffer.create 128 in 38 | let ec = 39 | match 40 | Run.run ~stdin:(`String s) ~stdout:(`Buffer b) 41 | ~stderr:(`Buffer eb) prog args 42 | with 43 | | exception (Unix.Unix_error _ as e) -> 44 | Std.Util.error "failed to call ppx_cstubs: %s\n" 45 | (Printexc.to_string e) 46 | | x -> x 47 | in 48 | if ec <> 0 then 49 | Buffer.contents eb 50 | |> Std.Util.error "ipc error: child exit with %d (%S)" ec; 51 | let s = Buffer.contents b in 52 | match Marshal.from_string s 0 with 53 | | exception ((Failure _ | Invalid_argument _) as e) -> 54 | Std.Util.error "ipc error: marshaling from ppx_cstubs failed: %s" 55 | (Printexc.to_string e) 56 | | Ok s -> Merlin_state.from_child s 57 | | Error e -> Merlin_state.raise_error e 58 | 59 | method init ~nopervasives:_ ~pkgs:_ ~use_threads:_ ~cma_files:_ () = () 60 | 61 | method is_merlin_ppx = true 62 | end 63 | in 64 | real_init top 65 | -------------------------------------------------------------------------------- /src/internal/ptree.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2020 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | open Mparsetree.Ast_cur 20 | 21 | module OSTypes : sig 22 | val add_abstract : 23 | ?sub_module:string -> string -> Parsetree.structure_item option 24 | 25 | val add_types_cb : string -> Parsetree.structure_item option 26 | 27 | val add_struct_view : string -> Parsetree.structure_item option 28 | 29 | val types_maybe_used : unit -> unit 30 | 31 | val remove_alias_types : unit -> bool 32 | 33 | val delete_os_inside_type_mod : unit -> bool 34 | end 35 | 36 | module Modules : sig 37 | val pstr_module : 38 | Parsetree.module_binding -> 39 | (unit -> Parsetree.structure_item) -> 40 | Parsetree.structure_item list 41 | 42 | val pstr_recmodule : 43 | Parsetree.module_binding list -> 44 | (Parsetree.module_binding -> Parsetree.module_binding) -> 45 | Parsetree.module_binding list 46 | 47 | val pexp_letmodule : 48 | string option Asttypes.loc -> 49 | mexpr:Parsetree.module_expr -> 50 | fmexpr:(unit -> Parsetree.module_expr) -> 51 | fexpr:(unit -> Parsetree.expression) -> 52 | Parsetree.module_expr * Parsetree.expression 53 | 54 | val pexp_pack : 55 | Parsetree.module_expr -> 56 | (unit -> Parsetree.expression) -> 57 | Parsetree.expression 58 | 59 | val pstr_include : 60 | Parsetree.include_declaration -> 61 | (unit -> Parsetree.structure_item) -> 62 | Parsetree.structure_item list 63 | 64 | val pstr_open : 65 | Parsetree.open_declaration -> 66 | (unit -> Parsetree.structure_item) -> 67 | Parsetree.structure_item list 68 | 69 | val pexp_open : 70 | fodl:(unit -> Parsetree.open_declaration) -> 71 | fexpr:(unit -> Parsetree.expression) -> 72 | Parsetree.open_declaration -> 73 | Parsetree.open_declaration * Parsetree.expression 74 | end 75 | 76 | module Impl_mod : sig 77 | val add_entry : Parsetree.structure_item -> unit 78 | 79 | val get_mod_path : unit -> string list 80 | 81 | val create_ref_lid : string -> Longident.t Location.loc 82 | 83 | val create_type_ref : string -> Parsetree.core_type 84 | 85 | val add_named : 86 | ?constr:Parsetree.core_type -> 87 | ?name_check:bool -> 88 | ?attrs:Parsetree.attribute list -> 89 | retype:bool -> 90 | string -> 91 | Parsetree.expression -> 92 | Parsetree.expression 93 | 94 | val add_external : 95 | name_check:bool -> 96 | Parsetree.structure_item -> 97 | Parsetree.structure_item -> 98 | name:string -> 99 | Uniq_ref.t * Parsetree.expression 100 | 101 | val add_external_anon : 102 | Parsetree.structure_item -> 103 | Parsetree.structure_item -> 104 | string -> 105 | Parsetree.expression 106 | 107 | val add_opaq : 108 | Parsetree.attribute list -> 109 | Parsetree.structure_item -> 110 | string -> 111 | Uniq_ref.t * Parsetree.expression 112 | 113 | val add_unit : Parsetree.expression -> Parsetree.expression 114 | end 115 | 116 | module Type_mod : sig 117 | val add_entry : Parsetree.structure_item -> unit 118 | end 119 | 120 | module Topscript : sig 121 | val add_build_external : Parsetree.structure_item -> unit 122 | 123 | val add_extract : Parsetree.structure_item -> unit 124 | 125 | val add_extract_phase0 : Parsetree.structure_item -> unit 126 | 127 | val run : Ppxc__script_real.top_run -> unit 128 | end 129 | 130 | val all_top_modules : unit -> Parsetree.structure_item list 131 | 132 | val type_mod_is_used : unit -> bool 133 | 134 | val clear : unit -> unit 135 | -------------------------------------------------------------------------------- /src/internal/run.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | type pipe_state = 20 | | Open 21 | | Closed 22 | | Uninit 23 | 24 | type pipe_with_status = { 25 | mutable state : pipe_state; 26 | mutable fd : Unix.file_descr; 27 | } 28 | 29 | let dev_null = if Sys.win32 then "NUL" else "/dev/null" 30 | 31 | let pipe a b = 32 | let tmp1, tmp2 = Unix.pipe () in 33 | a.state <- Open; 34 | a.fd <- tmp1; 35 | b.state <- Open; 36 | b.fd <- tmp2 37 | 38 | let new_pipe () = { state = Uninit; fd = Unix.stderr } 39 | 40 | let rec eintr1 f a = 41 | try f a with Unix.Unix_error (Unix.EINTR, _, _) -> eintr1 f a 42 | 43 | let rec eintr2 f a b = 44 | try f a b with Unix.Unix_error (Unix.EINTR, _, _) -> eintr2 f a b 45 | 46 | let rec eintr3 f a b c = 47 | try f a b c with Unix.Unix_error (Unix.EINTR, _, _) -> eintr3 f a b c 48 | 49 | let rec eintr4 f a b c d = 50 | try f a b c d with Unix.Unix_error (Unix.EINTR, _, _) -> eintr4 f a b c d 51 | 52 | let rec eintr6 f a b c d e g = 53 | try f a b c d e g 54 | with Unix.Unix_error (Unix.EINTR, _, _) -> eintr6 f a b c d e g 55 | 56 | let close_pipe a = 57 | match a.state with 58 | | Closed | Uninit -> () 59 | | Open -> 60 | a.state <- Closed; 61 | (* capturing EINTR Os specific ... *) 62 | Unix.close a.fd 63 | 64 | type io_out = 65 | [ `Fd of Unix.file_descr 66 | | `Null 67 | | `Stdout 68 | | `Stderr 69 | | `Buffer of Buffer.t 70 | | `Fun of string -> unit 71 | ] 72 | 73 | type io_in = 74 | [ `String of string 75 | | `Null 76 | | `Fd of Unix.file_descr 77 | ] 78 | 79 | let close_pipe_ne a = try close_pipe a with Unix.Unix_error _ -> () 80 | 81 | let str_buffer_len = 8192 82 | 83 | let finally ~h f = CCFun.finally ~h ~f 84 | 85 | let run ?(env = Unix.environment ()) ?(stdin = `Null) ?(stderr = `Stderr) 86 | ?(stdout = `Stdout) prog args : int = 87 | let tmp_str = Bytes.create str_buffer_len 88 | and p_stdout_read = new_pipe () 89 | and p_stdout_write = new_pipe () 90 | and p_stderr_read = new_pipe () 91 | and p_stderr_write = new_pipe () 92 | and p_stdin_read = new_pipe () 93 | and p_stdin_write = new_pipe () 94 | and args = Array.of_list (prog :: args) in 95 | finally ~h:(fun () -> 96 | close_pipe_ne p_stdin_read; 97 | close_pipe_ne p_stdin_write; 98 | close_pipe_ne p_stdout_read; 99 | close_pipe_ne p_stdout_write; 100 | close_pipe_ne p_stderr_write; 101 | close_pipe_ne p_stderr_read) 102 | @@ fun () -> 103 | let () = 104 | let comm p fd = 105 | let fd = eintr1 (fun x -> Unix.dup x) fd in 106 | p.fd <- fd; 107 | p.state <- Open 108 | in 109 | let out p_out_write p_out_read out = 110 | (match out with 111 | | `Stdout -> 112 | if Sys.win32 then p_out_write.fd <- Unix.stdout 113 | else comm p_out_write Unix.stdout 114 | | `Stderr -> 115 | if Sys.win32 then p_out_write.fd <- Unix.stderr 116 | else comm p_out_write Unix.stderr 117 | | `Null -> 118 | let fd = eintr3 Unix.openfile dev_null [ Unix.O_WRONLY ] 0o600 in 119 | p_out_write.fd <- fd; 120 | p_out_write.state <- Open 121 | | `Fd fd -> comm p_out_write fd 122 | | _ -> pipe p_out_read p_out_write); 123 | if p_out_read.state = Open then Unix.set_close_on_exec p_out_read.fd 124 | in 125 | out p_stdout_write p_stdout_read stdout; 126 | out p_stderr_write p_stderr_read stderr; 127 | (match stdin with 128 | | `Null -> 129 | let fd = eintr3 Unix.openfile dev_null [ Unix.O_RDONLY ] 0o400 in 130 | p_stdin_read.fd <- fd; 131 | p_stdin_read.state <- Open 132 | | `Fd fd -> comm p_stdin_read fd 133 | | _ -> pipe p_stdin_read p_stdin_write); 134 | if p_stdin_write.state = Open then Unix.set_close_on_exec p_stdin_write.fd 135 | in 136 | let pid = 137 | eintr6 Unix.create_process_env prog args env p_stdin_read.fd 138 | p_stdout_write.fd p_stderr_write.fd 139 | in 140 | close_pipe p_stdout_write; 141 | close_pipe p_stderr_write; 142 | close_pipe p_stdin_read; 143 | let f_read r = 144 | let is_stdout = 145 | if r = p_stderr_read.fd then false 146 | else ( 147 | assert (r = p_stdout_read.fd); 148 | true) 149 | in 150 | let x = try eintr4 Unix.read r tmp_str 0 str_buffer_len with _ -> -1 in 151 | if x <= 0 then 152 | if is_stdout then close_pipe p_stdout_read else close_pipe p_stderr_read 153 | else 154 | match if is_stdout then stdout else stderr with 155 | | `Fd _ | `Null | `Stdout | `Stderr -> () 156 | | `Buffer b -> Buffer.add_substring b (Bytes.unsafe_to_string tmp_str) 0 x 157 | | `Fun (f : string -> unit) -> f (Bytes.sub_string tmp_str 0 x) 158 | in 159 | let to_write = 160 | match stdin with 161 | | `Fd _ | `String "" | `Null -> 162 | close_pipe p_stdin_write; 163 | ref "" 164 | | `String str -> ref str 165 | in 166 | while 167 | p_stdout_read.state = Open 168 | || p_stderr_read.state = Open 169 | || p_stdin_write.state = Open 170 | do 171 | let wl = if p_stdin_write.state = Open then [ p_stdin_write.fd ] else [] in 172 | let rl = if p_stderr_read.state = Open then [ p_stderr_read.fd ] else [] in 173 | let rl = 174 | if p_stdout_read.state = Open then p_stdout_read.fd :: rl else rl 175 | in 176 | let r, w, _ = eintr4 Unix.select rl wl [] 3. in 177 | List.iter f_read r; 178 | match w with 179 | | [] -> () 180 | | [ fd ] -> 181 | assert (p_stdin_write.fd = fd); 182 | let str_len = String.length !to_write in 183 | assert (str_len > 0); 184 | let n_written = eintr4 Unix.write_substring fd !to_write 0 str_len in 185 | if n_written >= str_len then ( 186 | to_write := ""; 187 | close_pipe p_stdin_write) 188 | else to_write := String.sub !to_write n_written (str_len - n_written) 189 | | _ -> assert false 190 | done; 191 | close_pipe p_stdout_read; 192 | close_pipe p_stderr_read; 193 | let _, process_status = eintr2 Unix.waitpid [] pid in 194 | let ret_code = 195 | match process_status with 196 | | Unix.WEXITED n -> n 197 | | Unix.WSIGNALED _ -> 2 (* like OCaml's uncaught exceptions *) 198 | | Unix.WSTOPPED _ -> 199 | (* only possible if the call was done using WUNTRACED or when the child 200 | is being traced *) 201 | 3 202 | in 203 | ret_code 204 | 205 | let cmd_to_string prog args = 206 | let args = List.map Filename.quote args in 207 | String.concat " " (prog :: args) 208 | -------------------------------------------------------------------------------- /src/internal/run.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | type io_out = 20 | [ `Buffer of Buffer.t 21 | | `Fd of Unix.file_descr 22 | | `Fun of string -> unit 23 | | `Null 24 | | `Stderr 25 | | `Stdout 26 | ] 27 | 28 | type io_in = 29 | [ `Fd of Unix.file_descr 30 | | `Null 31 | | `String of string 32 | ] 33 | 34 | val run : 35 | ?env:string array -> 36 | ?stdin:io_in -> 37 | ?stderr:io_out -> 38 | ?stdout:io_out -> 39 | string -> 40 | string list -> 41 | int 42 | 43 | val cmd_to_string : string -> string list -> string 44 | -------------------------------------------------------------------------------- /src/internal/script_result.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | let htl_expr = Hashtbl.create 64 20 | 21 | let htl_used = Hashtbl.create 64 22 | 23 | let htl_stri = Hashtbl.create 16 24 | 25 | let foreign_used = ref false 26 | 27 | let c_source = ref None 28 | 29 | let clear () = 30 | Hashtbl.clear htl_expr; 31 | Hashtbl.clear htl_stri; 32 | Hashtbl.clear htl_used; 33 | foreign_used := false; 34 | c_source := None 35 | 36 | type merlin_state = { 37 | hexpr : (Marshal_types.id * Mparsetree.Ast_cur.Parsetree.expression) list; 38 | hstri : (Marshal_types.id * Mparsetree.Ast_cur.Parsetree.structure_item) list; 39 | hused : (int * unit) list; 40 | fused : bool; 41 | } 42 | 43 | let merlin_save () = 44 | { 45 | hexpr = CCHashtbl.Poly.to_list htl_expr; 46 | hused = CCHashtbl.Poly.to_list htl_used; 47 | hstri = CCHashtbl.Poly.to_list htl_stri; 48 | fused = !foreign_used; 49 | } 50 | 51 | let merlin_restore { hexpr; hused; hstri; fused } = 52 | let set htl l = 53 | Hashtbl.clear htl; 54 | List.iter (fun (a, b) -> Hashtbl.add htl a b) l 55 | in 56 | set htl_expr hexpr; 57 | set htl_used hused; 58 | set htl_stri hstri; 59 | foreign_used := fused 60 | -------------------------------------------------------------------------------- /src/internal/script_result.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | open Mparsetree.Ast_cur.Parsetree 20 | 21 | val htl_expr : (Marshal_types.id, expression) Hashtbl.t 22 | 23 | val htl_stri : (Marshal_types.id, structure_item) Hashtbl.t 24 | 25 | val htl_used : (int, unit) Hashtbl.t 26 | 27 | val foreign_used : bool ref 28 | 29 | val c_source : string option ref 30 | 31 | val clear : unit -> unit 32 | 33 | type merlin_state 34 | 35 | val merlin_save : unit -> merlin_state 36 | 37 | val merlin_restore : merlin_state -> unit 38 | -------------------------------------------------------------------------------- /src/internal/std.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | type 'a return = { return : 'b. 'a -> 'b } 20 | 21 | let with_return (type a) f = 22 | let module E = struct 23 | exception E of a 24 | end in 25 | try f { return = (fun x -> raise_notrace (E.E x)) } with E.E r -> r 26 | 27 | (* Unlike CCFun.finally I want to ensure that h is only called 28 | once.*) 29 | 30 | let finally ~h f = 31 | match f () with 32 | | exception exn -> 33 | h (); 34 | raise exn 35 | | r -> 36 | h (); 37 | r 38 | 39 | external identity : 'a -> 'a = "%identity" 40 | 41 | module Util = struct 42 | module Lo = Location 43 | module Le = Lexing 44 | open Mparsetree.Ast_cur 45 | 46 | let with_loc loc f = 47 | let old_loc = !Ast_helper.default_loc in 48 | Ast_helper.default_loc := loc; 49 | finally ~h:(fun () -> Ast_helper.default_loc := old_loc) f 50 | 51 | let error ?(loc = !Ast_helper.default_loc) fmt = 52 | Format.ksprintf (fun s -> raise (Lo.Error (Lo.error ~loc s))) fmt 53 | 54 | let error_exn ?(loc = !Ast_helper.default_loc) fmt = 55 | Format.ksprintf (fun s -> Lo.Error (Lo.error ~loc s)) fmt 56 | 57 | let str_expr ?loc s = Ast_helper.(Exp.constant ?loc (Const.string s)) 58 | 59 | let int_expr ?loc ?attrs i = 60 | Ast_helper.(Exp.constant ?loc ?attrs (Const.int i)) 61 | 62 | let mk_loc s = Lo.mkloc s !Ast_helper.default_loc 63 | 64 | let mk_oloc s = Lo.mkloc (Some s) !Ast_helper.default_loc 65 | 66 | let mk_lid_c ?(loc = !Ast_helper.default_loc) s = Lo.mkloc s loc 67 | 68 | let mk_lid ?loc s = 69 | let s = 70 | match CCString.split_on_char '.' s with 71 | | [] -> Lident "" 72 | | hd :: tl -> 73 | CCListLabels.fold_left ~f:(fun p s -> Ldot (p, s)) ~init:(Lident hd) tl 74 | in 75 | mk_lid_c ?loc s 76 | 77 | let lid_unflatten = function 78 | | [] -> None 79 | | hd :: tl -> Some (List.fold_left (fun p s -> Ldot (p, s)) (Lident hd) tl) 80 | 81 | let mk_lid_l ?loc l = 82 | match lid_unflatten l with 83 | | None -> invalid_arg "mk_lid_l" 84 | | Some l -> mk_lid_c ?loc l 85 | 86 | let mk_pat s = Ast_helper.Pat.var (mk_loc s) 87 | 88 | let mk_typc_c ?attrs ?(l = []) s = Ast_helper.Typ.constr ?attrs s l 89 | 90 | let mk_typc ?attrs ?l s = mk_typc_c ?attrs ?l (mk_lid s) 91 | 92 | let mk_ident n = Ast_helper.Exp.ident (mk_lid n) 93 | 94 | let mk_typc_l ?attrs ?l s = mk_typc_c ?attrs ?l (mk_lid_l s) 95 | 96 | let mk_ident_l s = Ast_helper.Exp.ident (mk_lid_l s) 97 | 98 | include Uniq_ids 99 | 100 | let empty_stri () = 101 | let vb = 102 | Ast_helper.Vb.mk 103 | ~attrs:[ Attributes.remove_attrib ] 104 | (mk_pat "()") 105 | (Ast_helper.Exp.ident (mk_lid "()")) 106 | in 107 | Ast_helper.Str.value Nonrecursive [ vb ] 108 | 109 | let marshal_to_str_expr a = str_expr (Marshal.to_string a []) 110 | 111 | let ocaml_warning s = 112 | let loc = !Ast_helper.default_loc in 113 | let x = mk_loc "ocaml.warning" in 114 | let pl = PStr [ [%stri [%e str_expr s]] ] in 115 | Ast_helper.Attr.mk x pl 116 | 117 | let no_warn_unused_pre406 = 118 | let open Ast_helper in 119 | fun stri -> 120 | if Ocaml_config.version () >= (4, 6, 0) then stri 121 | else 122 | let loc = stri.pstr_loc in 123 | let a = Str.attribute ~loc (ocaml_warning "-32") in 124 | let mod' = Mod.structure [ a; stri ] in 125 | Str.include_ (Incl.mk ~loc mod') 126 | 127 | let no_warn_unused_post406 = 128 | let open Ast_helper in 129 | fun name expr -> 130 | let pat = Pat.var (mk_loc name) in 131 | let attrs = 132 | if Ocaml_config.version () < (4, 6, 0) then [] 133 | else [ ocaml_warning "-32" ] 134 | in 135 | let vb = Vb.mk ~attrs pat expr in 136 | Str.value Nonrecursive [ vb ] 137 | 138 | let no_warn_unused name expr = 139 | no_warn_unused_post406 name expr |> no_warn_unused_pre406 140 | 141 | let no_warn_unused_module ?(loc = !Ast_helper.default_loc) stri = 142 | [%stri 143 | include struct 144 | [@@@ocaml.warning "-60"] 145 | 146 | [%%i stri] 147 | end] 148 | 149 | let no_c_comments s = 150 | CCString.replace ~which:`All ~sub:"/*" ~by:"/ *" s 151 | |> CCString.replace ~which:`All ~sub:"*/" ~by:"* /" 152 | 153 | let cloc_comment loc = 154 | let b = Buffer.create 128 in 155 | let fmt = Format.formatter_of_buffer b in 156 | Lo.print_loc fmt loc; 157 | Format.pp_print_flush fmt (); 158 | let s = Buffer.contents b |> no_c_comments in 159 | String.concat " " [ "/*"; s; "*/" ] 160 | 161 | let sig_from_mod_type s = 162 | match s.pstr_desc with 163 | | Pstr_modtype { pmtd_type = Some { pmty_desc = Pmty_signature s; _ }; _ } 164 | -> 165 | s 166 | | _ -> assert false 167 | 168 | module A = Ast_helper 169 | 170 | let mk_pat_pconstr t n = 171 | if Ocaml_config.version () = (4, 5, 0) && !Options.pretty then 172 | A.Pat.constraint_ (mk_pat n) t 173 | else A.Pat.constraint_ (mk_pat n) (A.Typ.poly [] t) 174 | 175 | let named_stri ?constr n expr = 176 | let loc = !Ast_helper.default_loc in 177 | let p = 178 | match constr with None -> mk_pat n | Some t -> mk_pat_pconstr t n 179 | in 180 | [%stri let [%p p] = [%e expr]] 181 | 182 | let alias_impl_mod () = 183 | let m = A.Mod.ident (mk_lid_l [ !Lconst.impl_mod_name ]) in 184 | let t = A.Mty.ident (mk_lid_l [ !Lconst.type_modtype_name ]) in 185 | A.Mod.constraint_ m t 186 | 187 | let alias_impl_mod_let e = 188 | let m = alias_impl_mod () in 189 | A.Exp.letmodule (mk_oloc !Lconst.impl_mod_name) m e 190 | 191 | let alias_impl_mod_os ?(alias_name = !Lconst.impl_mod_name) () = 192 | let x = alias_impl_mod () in 193 | let x = A.Mb.mk (mk_oloc alias_name) x in 194 | let x = A.Mod.structure [ A.Str.module_ x ] in 195 | A.Str.open_ (A.Opn.mk ~override:Override x) 196 | 197 | (* native compilation is too slow, when the symbols are always 198 | resolved through constrained alias modules, although it doesn't matter 199 | at runtime. *) 200 | let alias_type ?attrs e = 201 | let res ?attrs e = 202 | match attrs with 203 | | None -> e 204 | | Some a -> { e with pexp_attributes = e.pexp_attributes @ a } 205 | in 206 | if Ocaml_config.use_open_struct () = false then res ?attrs e 207 | else 208 | let e_constr = alias_impl_mod_let e in 209 | let attrs = match attrs with None -> [] | Some l -> l in 210 | let attrs = Attributes.open_struct_ifthenelse_attrib :: attrs in 211 | let loc = !Ast_helper.default_loc in 212 | res ~attrs [%expr if false then [%e e_constr] else [%e e]] 213 | 214 | let convert_ctypes_exeptions f = 215 | try f () with 216 | | Ctypes_static.ModifyingSealedType s -> error "%s is already sealed" s 217 | | Ctypes_static.Unsupported s -> error "ctypes error: %s" s 218 | | Ctypes_static.IncompleteType -> error "Incomplete Type" 219 | end 220 | 221 | module Result = struct 222 | type ('a, 'b) result = ('a, 'b) CCResult.t = 223 | | Ok of 'a 224 | | Error of 'b 225 | end 226 | 227 | module Various = struct 228 | let use_threads () = 229 | match !Options.findlib_pkgs with 230 | | [] -> false 231 | | f_pkgs -> 232 | let pkgs = 233 | match Findlib.package_deep_ancestors [ "byte" ] f_pkgs with 234 | | exception Fl_package_base.No_such_package _ -> f_pkgs 235 | | d -> d 236 | in 237 | List.exists 238 | (function "threads" | "threads.posix" -> true | _ -> false) 239 | pkgs 240 | 241 | let rex = Re.Perl.re "[,\\s]+" |> Re.compile 242 | 243 | let split_findlib_pkgs s = Re.split rex s |> List.filter (( <> ) "") 244 | end 245 | -------------------------------------------------------------------------------- /src/internal/std.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | type 'a return = { return : 'b. 'a -> 'b } 20 | 21 | val with_return : ('a return -> 'a) -> 'a 22 | 23 | val finally : h:(unit -> unit) -> (unit -> 'a) -> 'a 24 | 25 | external identity : 'a -> 'a = "%identity" 26 | 27 | module Util : sig 28 | open Mparsetree.Ast_cur 29 | 30 | val error : ?loc:Ast_helper.loc -> ('a, unit, string, 'b) format4 -> 'a 31 | 32 | val error_exn : ?loc:Ast_helper.loc -> ('a, unit, string, exn) format4 -> 'a 33 | 34 | val safe_ascii_only : string -> string 35 | 36 | val safe_ascii_only_ml : string -> string 37 | 38 | val safe_cname : prefix:string -> string 39 | 40 | val safe_mlname : ?capitalize:bool -> ?prefix:string -> unit -> string 41 | 42 | val with_loc : Ast_helper.loc -> (unit -> 'a) -> 'a 43 | 44 | val str_expr : ?loc:Ast_helper.loc -> string -> Parsetree.expression 45 | 46 | val int_expr : 47 | ?loc:Ast_helper.loc -> 48 | ?attrs:Ast_helper.attrs -> 49 | int -> 50 | Parsetree.expression 51 | 52 | val mk_loc : 'a -> 'a Location.loc 53 | 54 | val mk_oloc : 'a -> 'a option Location.loc 55 | 56 | val mk_lid : ?loc:Ast_helper.loc -> string -> Longident.t Location.loc 57 | 58 | val mk_lid_l : ?loc:Ast_helper.loc -> string list -> Longident.t Location.loc 59 | 60 | val mk_pat : string -> Parsetree.pattern 61 | 62 | val mk_ident : string -> Parsetree.expression 63 | 64 | val mk_ident_l : string list -> Parsetree.expression 65 | 66 | val mk_typc : 67 | ?attrs:Ast_helper.attrs -> 68 | ?l:Parsetree.core_type list -> 69 | string -> 70 | Parsetree.core_type 71 | 72 | val mk_typc_l : 73 | ?attrs:Ast_helper.attrs -> 74 | ?l:Parsetree.core_type list -> 75 | string list -> 76 | Parsetree.core_type 77 | 78 | val empty_stri : unit -> Parsetree.structure_item 79 | 80 | val marshal_to_str_expr : 'a -> Parsetree.expression 81 | 82 | val no_warn_unused_pre406 : 83 | Parsetree.structure_item -> Parsetree.structure_item 84 | 85 | val no_warn_unused : 86 | string -> Parsetree.expression -> Parsetree.structure_item 87 | 88 | val no_warn_unused_module : 89 | ?loc:Ast_helper.loc -> Parsetree.structure_item -> Parsetree.structure_item 90 | 91 | val no_c_comments : string -> string 92 | 93 | val cloc_comment : Ast_helper.loc -> string 94 | 95 | val unsuffixed_file_name : unit -> string 96 | 97 | (* [%sig: ...] [%sigi: ...] broken for some Ocaml versions ... *) 98 | val sig_from_mod_type : Parsetree.structure_item -> Parsetree.signature 99 | 100 | val ocaml_warning : string -> Parsetree.attribute 101 | 102 | val named_stri : 103 | ?constr:Parsetree.core_type -> 104 | string -> 105 | Parsetree.expression -> 106 | Parsetree.structure_item 107 | 108 | val alias_type : 109 | ?attrs:Ast_helper.attrs -> Parsetree.expression -> Parsetree.expression 110 | 111 | val alias_impl_mod_os : ?alias_name:string -> unit -> Parsetree.structure_item 112 | 113 | val alias_impl_mod_let : Parsetree.expression -> Parsetree.expression 114 | 115 | val lid_unflatten : string list -> Longident.t option 116 | 117 | val mk_pat_pconstr : Parsetree.core_type -> string -> Parsetree.pattern 118 | 119 | val convert_ctypes_exeptions : (unit -> 'a) -> 'a 120 | end 121 | 122 | module Result : sig 123 | type ('a, 'b) result = ('a, 'b) CCResult.result = 124 | | Ok of 'a 125 | | Error of 'b 126 | end 127 | 128 | module Various : sig 129 | val use_threads : unit -> bool 130 | 131 | val split_findlib_pkgs : string -> string list 132 | end 133 | -------------------------------------------------------------------------------- /src/internal/toplevel.cppo.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | let init top = 20 | let module O = Options in 21 | top#init 22 | ~nopervasives:!O.nopervasives 23 | ~pkgs:!O.findlib_pkgs 24 | ~use_threads:(Std.Various.use_threads ()) 25 | ~cma_files:!O.cma_files () 26 | 27 | let set_absname x = 28 | #if OCAML_VERSION >= (4, 8, 0) 29 | Clflags.absname := x 30 | #else 31 | Location.absname := x 32 | #endif 33 | 34 | let serialize_location_error x = 35 | #if OCAML_VERSION >= (4, 8, 0) 36 | let main = x.Location.main in 37 | let b = Buffer.create 128 in 38 | let fmt = Format.formatter_of_buffer b in 39 | Format.fprintf fmt "@[%t@]" main.Location.txt; 40 | Format.pp_print_flush fmt (); 41 | (main.Location.loc, Buffer.contents b) 42 | #else 43 | x.Location.loc, x.Location.msg 44 | #endif 45 | 46 | #if OCAML_VERSION >= (4, 9, 0) 47 | external caml_sys_modify_argv : string array -> unit = "caml_sys_modify_argv" 48 | #endif 49 | 50 | let set_argv new_argv = 51 | #if OCAML_VERSION >= (4, 9, 0) 52 | caml_sys_modify_argv new_argv ; 53 | #else 54 | let orig_argv_length = Array.length Sys.argv in 55 | let new_argv_length = Array.length new_argv in 56 | assert (new_argv_length <= orig_argv_length) ; 57 | ArrayLabels.blit ~src:new_argv ~src_pos:0 ~dst:Sys.argv ~dst_pos:0 58 | ~len:new_argv_length ; 59 | if new_argv_length <> orig_argv_length then 60 | Obj.truncate (Obj.repr Sys.argv) new_argv_length ; 61 | #endif 62 | Arg.current := 0 63 | -------------------------------------------------------------------------------- /src/internal/toplevel.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | val init : Ppxc__script_real.top_run -> unit 20 | 21 | (* doesn't belong here, but keep the cppo mess to one file ... *) 22 | val set_absname : bool -> unit 23 | 24 | val serialize_location_error : Location.error -> Location.t * string 25 | 26 | val set_argv : string array -> unit 27 | -------------------------------------------------------------------------------- /src/internal/uniq_ids.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | open Mparsetree.Ast_cur 20 | module Lo = Location 21 | module Le = Lexing 22 | 23 | let safe_ascii c = 24 | (c >= 'a' && c <= 'z') 25 | || (c >= 'A' && c <= 'Z') 26 | || c = '_' 27 | || (c >= '0' && c <= '9') 28 | 29 | let safe_ascii_only s = 30 | CCString.filter_map (fun c -> if safe_ascii c then Some c else None) s 31 | 32 | let safe_ascii_only_ml s = 33 | CCString.filter_map 34 | (fun c -> if safe_ascii c || c = '\'' then Some c else None) 35 | s 36 | 37 | let unsuffixed_file_name () = 38 | let loc = !Ast_helper.default_loc in 39 | let name = Filename.basename loc.Lo.loc_start.Le.pos_fname in 40 | match CCString.split_on_char '.' name with 41 | | [] -> "" 42 | | s :: _ -> safe_ascii_only s 43 | 44 | let make_uniq_cnt htl s = 45 | let i = match Hashtbl.find htl s with exception Not_found -> 0 | n -> n in 46 | Hashtbl.replace htl s (succ i); 47 | i 48 | 49 | let htl_c = Hashtbl.create 128 50 | 51 | let safe_cname = 52 | let cnt = make_uniq_cnt htl_c in 53 | fun ~prefix -> 54 | let loc = !Ast_helper.default_loc in 55 | let name = unsuffixed_file_name () in 56 | let s = safe_ascii_only prefix in 57 | let cutmax s maxlen = 58 | let len = String.length s in 59 | if len > maxlen then String.sub s 0 maxlen else s 60 | in 61 | (* TODO: there seems to be a limit for msvc *) 62 | let s = cutmax s 20 in 63 | let name = cutmax name 40 in 64 | let line = loc.Lo.loc_start.Le.pos_lnum in 65 | let cnum = loc.Lo.loc_start.Le.pos_cnum in 66 | let res = Printf.sprintf "%s_%x_%x_%s" name line cnum s in 67 | match cnt res with 68 | | 0 -> "ppxc_" ^ res 69 | | i -> Printf.sprintf "ppxc%x_%s" i res 70 | 71 | let htl_ml = Hashtbl.create 128 72 | 73 | let safe_mlname = 74 | let cnt = make_uniq_cnt htl_ml in 75 | fun ?(capitalize = false) ?prefix () -> 76 | let s, p = 77 | match prefix with 78 | | None -> ("", "") 79 | | Some s -> (safe_ascii_only_ml s, "_") 80 | in 81 | let loc = !Ast_helper.default_loc in 82 | let line = loc.Lo.loc_start.Le.pos_lnum in 83 | let pre = 84 | if capitalize then Myconst.private_prefix_capitalized 85 | else Myconst.private_prefix 86 | in 87 | let f = pre.[0] in 88 | let pre = String.sub pre 1 (String.length pre - 1) in 89 | let res = Printf.sprintf "%c%s%s%sline%d" f pre s p line in 90 | match cnt res with 0 -> res | i -> Printf.sprintf "%s_%d" res i 91 | 92 | type merlin_state = { 93 | l_c : (string * int) list; 94 | l_ml : (string * int) list; 95 | } 96 | 97 | let merlin_save () : merlin_state = 98 | { l_c = CCHashtbl.Poly.to_list htl_c; l_ml = CCHashtbl.Poly.to_list htl_ml } 99 | 100 | let merlin_restore { l_c; l_ml } = 101 | let f htl l = 102 | Hashtbl.clear htl; 103 | List.iter (fun (a, b) -> Hashtbl.replace htl a b) l 104 | in 105 | f htl_c l_c; 106 | f htl_ml l_ml 107 | -------------------------------------------------------------------------------- /src/internal/uniq_ids.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | val safe_ascii : char -> bool 20 | 21 | val safe_ascii_only : string -> string 22 | 23 | val safe_ascii_only_ml : string -> string 24 | 25 | val unsuffixed_file_name : unit -> string 26 | 27 | val safe_cname : prefix:string -> string 28 | 29 | val safe_mlname : ?capitalize:bool -> ?prefix:string -> unit -> string 30 | 31 | type merlin_state 32 | 33 | val merlin_save : unit -> merlin_state 34 | 35 | val merlin_restore : merlin_state -> unit 36 | -------------------------------------------------------------------------------- /src/internal/uniq_ref.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | open Mparsetree.Ast_cur 20 | open Ast_helper 21 | module U = Std.Util 22 | module List = CCListLabels 23 | 24 | let a_orig_name = "ppxc__orig_name" 25 | 26 | let a_inmod_ref = "ppxc__orig_inmod_reference_string" 27 | 28 | let a_reference_string = "ppxc__orig_reference_string" 29 | 30 | (* 31 | `external foo : ....` is replaced by: 32 | 33 | module Ppx_top_mod = struct 34 | ... 35 | external foo_uniq_name : ... 36 | let foo_uniq_name = .. [@@a_orig_name ... ] 37 | and _ = ... 38 | let foo = foo_uniq_name [@@a_inmod_ref ...] 39 | end 40 | ... 41 | let foo = Ppx_top_mod.foo_uniq_name [@@a_reference_string ...] 42 | 43 | If `foo` turns out to be unique in the current module, the indirection step 44 | is removed again in a later step. 45 | *) 46 | 47 | let htl_ctypes = Hashtbl.create 64 48 | 49 | type t = { 50 | mod_path : string list; 51 | uniq_name : string; 52 | short_name : string; 53 | sref : string; 54 | } 55 | 56 | type make_result = { 57 | id : t; 58 | topmod_vb : structure_item; 59 | topmod_ref : structure_item; 60 | main_ref : expression; 61 | } 62 | 63 | let attr ~attr ~cont = 64 | let loc = !Ast_helper.default_loc in 65 | let x = U.mk_loc attr in 66 | let pl = PStr [ [%stri [%e U.str_expr cont]] ] in 67 | [ Ast_helper.Attr.mk x pl ] 68 | 69 | let vb ?constr ~attrs n expr = 70 | let p = 71 | match constr with None -> U.mk_pat n | Some t -> U.mk_pat_pconstr t n 72 | in 73 | Str.value Nonrecursive [ Vb.mk ~attrs p expr ] 74 | 75 | let make ?constr ?main_ref_attrs ~retype mod_path short_name expr = 76 | let uniq_name = U.safe_mlname ~prefix:short_name () in 77 | let sref = String.concat "." (mod_path @ [ short_name ]) in 78 | Hashtbl.add htl_ctypes sref (); 79 | let id = { mod_path; uniq_name; short_name; sref } in 80 | let attrs = attr ~cont:sref ~attr:a_inmod_ref in 81 | let attrs = 82 | if Ocaml_config.version () < (4, 6, 0) then attrs 83 | else U.ocaml_warning "-32" :: attrs 84 | in 85 | let topmod_ref = vb ~attrs short_name (U.mk_ident_l [ uniq_name ]) in 86 | let cont = sref ^ "|" ^ sref in 87 | let attrs1 = attr ~cont ~attr:a_reference_string in 88 | let attrs2 = 89 | match main_ref_attrs with None -> attrs1 | Some x -> x @ attrs1 90 | in 91 | let n = mod_path @ [ uniq_name ] in 92 | let main_ref = 93 | if retype = false || Ocaml_config.use_open_struct () = false then 94 | Exp.ident ~attrs:attrs2 (U.mk_lid_l n) 95 | else 96 | let e = Exp.ident ~attrs:attrs1 (U.mk_lid_l n) in 97 | U.alias_type ?attrs:main_ref_attrs e 98 | in 99 | let attrs = attr ~cont:sref ~attr:a_orig_name in 100 | let topmod_vb = vb ?constr ~attrs uniq_name expr in 101 | { id; topmod_vb; topmod_ref; main_ref } 102 | 103 | let get_remove_string_exn name attr = 104 | let res = ref None in 105 | let attribs = 106 | List.filter attr ~f:(fun x -> 107 | if x.attr_name.txt <> name then true 108 | else 109 | match x.attr_payload with 110 | | PStr 111 | [ 112 | { 113 | pstr_desc = 114 | Pstr_eval 115 | ( { 116 | pexp_desc = Pexp_constant (Pconst_string (s, _, _)); 117 | _; 118 | }, 119 | _ ); 120 | _; 121 | }; 122 | ] -> 123 | res := Some s; 124 | false 125 | | _ -> failwith "surprising content in attribute") 126 | in 127 | match !res with 128 | | None -> failwith "invalid parsetree generated" 129 | | Some s -> (s, attribs) 130 | 131 | let is_uniq_ctype orig = 132 | (* created let bindings of type Ctypes.typ are not referenced in generated 133 | code (except from user code, where shadowing is intended). 134 | It's therefore enough, if they are unique inside the current module. 135 | *) 136 | match Hashtbl.find_all htl_ctypes orig with 137 | | [ _ ] -> true 138 | | [] -> failwith "invalid parsetree generated" 139 | | _ -> false 140 | 141 | let get_final_name t = 142 | if is_uniq_ctype t.sref then t.short_name else t.uniq_name 143 | 144 | let replace_expr = function 145 | | { pexp_desc = Pexp_ident _ as orig; pexp_attributes = _ :: _ as attribs; _ } 146 | as expr 147 | when List.exists attribs ~f:(fun x -> x.attr_name.txt = a_reference_string) 148 | -> 149 | let s, pexp_attributes = get_remove_string_exn a_reference_string attribs in 150 | let id_ref, single_ref = CCString.Split.left_exn ~by:"|" s in 151 | let pexp_desc = 152 | match is_uniq_ctype id_ref with 153 | | false -> orig 154 | | true -> Pexp_ident (U.mk_lid single_ref) 155 | in 156 | { expr with pexp_desc; pexp_attributes } 157 | | expr -> expr 158 | 159 | let replace_stri = function 160 | | { 161 | pstr_desc = 162 | Pstr_value 163 | (Nonrecursive, [ ({ pvb_attributes = _ :: _ as attribs; _ } as a) ]); 164 | _; 165 | } as stri -> 166 | if List.exists attribs ~f:(fun x -> x.attr_name.txt = a_orig_name) then 167 | let s, pvb_attributes = get_remove_string_exn a_orig_name attribs in 168 | let pvb_pat = 169 | match is_uniq_ctype s with 170 | | false -> a.pvb_pat 171 | | true -> ( 172 | let n = CCString.Split.right_exn ~by:"." s |> snd |> U.mk_pat in 173 | match a.pvb_pat.ppat_desc with 174 | | Ppat_constraint (_, c) -> Pat.constraint_ n c 175 | | _ -> n) 176 | in 177 | let a = { a with pvb_attributes; pvb_pat } in 178 | { stri with pstr_desc = Pstr_value (Nonrecursive, [ a ]) } 179 | else if List.exists attribs ~f:(fun x -> x.attr_name.txt = a_inmod_ref) then 180 | let s, pvb_attributes = get_remove_string_exn a_inmod_ref attribs in 181 | if is_uniq_ctype s then U.empty_stri () 182 | else 183 | let a = { a with pvb_attributes } in 184 | let stri = { stri with pstr_desc = Pstr_value (Nonrecursive, [ a ]) } in 185 | U.no_warn_unused_pre406 stri 186 | else stri 187 | | stri -> stri 188 | 189 | let clear () = Hashtbl.clear htl_ctypes 190 | 191 | type merlin_state = string list 192 | 193 | let merlin_save () = CCHashtbl.Poly.to_list htl_ctypes |> List.split |> fst 194 | 195 | let merlin_restore l = 196 | clear (); 197 | List.iter l ~f:(fun x -> Hashtbl.add htl_ctypes x ()) 198 | -------------------------------------------------------------------------------- /src/internal/uniq_ref.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | open Mparsetree.Ast_cur.Parsetree 20 | 21 | type t 22 | 23 | type make_result = { 24 | id : t; 25 | topmod_vb : structure_item; 26 | topmod_ref : structure_item; 27 | main_ref : expression; 28 | } 29 | 30 | val make : 31 | ?constr:core_type -> 32 | ?main_ref_attrs:attribute list -> 33 | retype:bool -> 34 | string list -> 35 | string -> 36 | expression -> 37 | make_result 38 | 39 | val replace_expr : expression -> expression 40 | 41 | val replace_stri : structure_item -> structure_item 42 | 43 | val get_final_name : t -> string 44 | 45 | val clear : unit -> unit 46 | 47 | type merlin_state 48 | 49 | val merlin_save : unit -> merlin_state 50 | 51 | val merlin_restore : merlin_state -> unit 52 | -------------------------------------------------------------------------------- /src/merlin/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_cstubs_merlin) 3 | (public_name ppx_cstubs.merlin) 4 | (kind ppx_rewriter) 5 | (modules ppx_cstubs_merlin) 6 | (libraries ppx_cstubs.internal) 7 | ) 8 | -------------------------------------------------------------------------------- /src/merlin/ppx_cstubs_merlin.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of ppx_cstubs (https://github.com/fdopen/ppx_cstubs) 2 | * Copyright (c) 2018-2019 fdopen 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published by 6 | * the Free Software Foundation, with linking exception; 7 | * either version 2.1 of the License, or (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | * 14 | * You should have received a copy of the GNU Lesser General Public License 15 | * along with this program; if not, write to the Free Software 16 | * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 17 | *) 18 | 19 | let () = Ppxc__script._init None 20 | -------------------------------------------------------------------------------- /src/runtime/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_cstubs) 3 | (public_name ppx_cstubs) 4 | (libraries ctypes integers) 5 | (synopsis "ppx_cstubs runtime lib")) 6 | -------------------------------------------------------------------------------- /src/runtime/ppx_cstubs.ml: -------------------------------------------------------------------------------- 1 | (* Copyright 2018 fdopen 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any 4 | purpose with or without fee is hereby granted. 5 | 6 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 7 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 8 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 9 | SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 10 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION 11 | OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN 12 | CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) 13 | 14 | module Types = struct 15 | module type Signed = sig 16 | include Signed.S 17 | 18 | val t : t Ctypes.typ 19 | end 20 | 21 | module type Unsigned = sig 22 | include Unsigned.S 23 | 24 | val t : t Ctypes.typ 25 | end 26 | 27 | module type Unkown_signedness = sig 28 | include Unsigned.S 29 | 30 | val t : t Ctypes.typ 31 | 32 | val min_int : t 33 | end 34 | end 35 | 36 | module Ppx_cstubs_internals = Ppx_cstubs_internals 37 | -------------------------------------------------------------------------------- /src/runtime/ppx_cstubs_internals.ml: -------------------------------------------------------------------------------- 1 | (* Copyright 2018 fdopen 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any 4 | purpose with or without fee is hereby granted. 5 | 6 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 7 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 8 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 9 | SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 10 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION 11 | OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN 12 | CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) 13 | 14 | open Ctypes_static 15 | 16 | let rec seal : type a. a Ctypes_static.typ -> size:int -> align:int -> unit = 17 | fun t ~size ~align -> 18 | match t with 19 | | Struct ({ spec = Incomplete _; _ } as s) -> 20 | s.fields <- List.rev s.fields; 21 | s.spec <- Complete { size; align } 22 | | Union ({ uspec = None; _ } as u) -> 23 | u.ufields <- List.rev u.ufields; 24 | u.uspec <- Some { size; align } 25 | | Struct { tag; _ } -> raise (ModifyingSealedType tag) 26 | | Union { utag; _ } -> raise (ModifyingSealedType utag) 27 | | View { ty; _ } -> seal ty ~size ~align 28 | | _ -> raise (Unsupported "Sealing a non-structured type") 29 | 30 | let rec add_field : 31 | type t a. 32 | t Ctypes_static.typ -> 33 | string -> 34 | int -> 35 | a Ctypes_static.typ -> 36 | (a, t) Ctypes_static.field = 37 | fun t fname foffset ftype -> 38 | match t with 39 | | Struct s -> 40 | let r = { fname; foffset; ftype } in 41 | s.fields <- BoxedField r :: s.fields; 42 | r 43 | | Union u -> 44 | let r = { fname; foffset; ftype } in 45 | u.ufields <- BoxedField r :: u.ufields; 46 | r 47 | | View { ty; _ } -> 48 | let ({ fname = _; _ } as r) = add_field ty fname foffset ftype in 49 | r 50 | | _ -> failwith ("Unexpected field " ^ fname) 51 | 52 | external identity : 'a -> 'a = "%identity" 53 | 54 | let build_enum : 55 | type a b. 56 | string -> 57 | a Ctypes.typ -> 58 | typedef:bool -> 59 | ?unexpected:(int64 -> b) -> 60 | (b * a) list -> 61 | b Ctypes.typ = 62 | fun name typ ~typedef ?unexpected alist -> 63 | let fail t = 64 | Printf.ksprintf failwith "Invalid enum type %s" (Ctypes.string_of_typ t) 65 | in 66 | let rlist = List.map (fun (l, r) -> (r, l)) alist in 67 | let unexpected = 68 | match unexpected with 69 | | None -> 70 | let to_string = 71 | match typ with 72 | | Ctypes_static.Primitive p -> 73 | (match p with 74 | | Ctypes_primitive_types.Int8_t -> string_of_int 75 | | Ctypes_primitive_types.Int32_t -> (Int32.to_string : a -> string) 76 | | Ctypes_primitive_types.Int16_t -> string_of_int 77 | | Ctypes_primitive_types.Int -> string_of_int 78 | | Ctypes_primitive_types.Int64_t -> Int64.to_string 79 | | Ctypes_primitive_types.Uint8_t -> Unsigned.UInt8.to_string 80 | | Ctypes_primitive_types.Uint16_t -> Unsigned.UInt16.to_string 81 | | Ctypes_primitive_types.Uint32_t -> Unsigned.UInt32.to_string 82 | | Ctypes_primitive_types.Uint64_t -> Unsigned.UInt64.to_string 83 | | _ -> fail typ 84 | : a -> string) 85 | | _ -> fail typ 86 | in 87 | fun k -> 88 | Printf.ksprintf failwith "Unexpected enum value for %s: %s" name 89 | (to_string k) 90 | | Some f -> 91 | let to_int64 = 92 | match typ with 93 | | Ctypes_static.Primitive p -> 94 | (match p with 95 | | Ctypes_primitive_types.Int8_t -> Int64.of_int 96 | | Ctypes_primitive_types.Int32_t -> Int64.of_int32 97 | | Ctypes_primitive_types.Int16_t -> Int64.of_int 98 | | Ctypes_primitive_types.Int -> Int64.of_int 99 | | Ctypes_primitive_types.Int64_t -> identity 100 | | Ctypes_primitive_types.Uint8_t -> Unsigned.UInt8.to_int64 101 | | Ctypes_primitive_types.Uint16_t -> Unsigned.UInt16.to_int64 102 | | Ctypes_primitive_types.Uint32_t -> Unsigned.UInt32.to_int64 103 | | Ctypes_primitive_types.Uint64_t -> Unsigned.UInt64.to_int64 104 | | _ -> fail typ 105 | : a -> int64) 106 | | _ -> fail typ 107 | in 108 | fun k -> f (to_int64 k) 109 | in 110 | let pname = if typedef then name else "enum " ^ name in 111 | let write k = List.assoc k alist 112 | and read k = try List.assoc k rlist with Not_found -> unexpected k 113 | and format_typ k fmt = Format.fprintf fmt "%s%t" pname k in 114 | Ctypes_static.view ~format_typ ~read ~write typ 115 | 116 | let build_enum_bitmask : 117 | type a b. 118 | string -> 119 | a Ctypes.typ -> 120 | typedef:bool -> 121 | ?unexpected:(b list -> int64 -> b list) -> 122 | (b * a) list -> 123 | b list Ctypes.typ = 124 | fun name typ ~typedef ?unexpected alist -> 125 | let fail t = 126 | Printf.ksprintf failwith "Invalid enum type %s" (Ctypes.string_of_typ t) 127 | in 128 | let lor', land', zero, lnot' = 129 | match typ with 130 | | Ctypes_static.Primitive p -> 131 | (match p with 132 | | Ctypes_primitive_types.Int8_t -> (( lor ), ( land ), 0, lnot) 133 | | Ctypes_primitive_types.Int16_t -> (( lor ), ( land ), 0, lnot) 134 | | Ctypes_primitive_types.Int -> (( lor ), ( land ), 0, lnot) 135 | | Ctypes_primitive_types.Int32_t -> Int32.(logor, logand, zero, lognot) 136 | | Ctypes_primitive_types.Int64_t -> Int64.(logor, logand, zero, lognot) 137 | | Ctypes_primitive_types.Uint8_t -> 138 | Unsigned.UInt8.(logor, logand, zero, lognot) 139 | | Ctypes_primitive_types.Uint16_t -> 140 | Unsigned.UInt16.(logor, logand, zero, lognot) 141 | | Ctypes_primitive_types.Uint32_t -> 142 | Unsigned.UInt32.(logor, logand, zero, lognot) 143 | | Ctypes_primitive_types.Uint64_t -> 144 | Unsigned.UInt64.(logor, logand, zero, lognot) 145 | | _ -> fail typ 146 | : (a -> a -> a) * (a -> a -> a) * a * (a -> a)) 147 | | _ -> fail typ 148 | in 149 | let unexpected = 150 | match unexpected with 151 | | None -> 152 | let to_string = 153 | match typ with 154 | | Ctypes_static.Primitive p -> 155 | (match p with 156 | | Ctypes_primitive_types.Int8_t -> string_of_int 157 | | Ctypes_primitive_types.Int32_t -> (Int32.to_string : a -> string) 158 | | Ctypes_primitive_types.Int16_t -> string_of_int 159 | | Ctypes_primitive_types.Int -> string_of_int 160 | | Ctypes_primitive_types.Int64_t -> Int64.to_string 161 | | Ctypes_primitive_types.Uint8_t -> Unsigned.UInt8.to_string 162 | | Ctypes_primitive_types.Uint16_t -> Unsigned.UInt16.to_string 163 | | Ctypes_primitive_types.Uint32_t -> Unsigned.UInt32.to_string 164 | | Ctypes_primitive_types.Uint64_t -> Unsigned.UInt64.to_string 165 | | _ -> fail typ 166 | : a -> string) 167 | | _ -> fail typ 168 | in 169 | fun _ k -> 170 | Printf.ksprintf failwith "Unexpected enum value for %s: %s" name 171 | (to_string k) 172 | | Some f -> 173 | let to_int64 = 174 | match typ with 175 | | Ctypes_static.Primitive p -> 176 | (match p with 177 | | Ctypes_primitive_types.Int8_t -> Int64.of_int 178 | | Ctypes_primitive_types.Int32_t -> Int64.of_int32 179 | | Ctypes_primitive_types.Int16_t -> Int64.of_int 180 | | Ctypes_primitive_types.Int -> Int64.of_int 181 | | Ctypes_primitive_types.Int64_t -> identity 182 | | Ctypes_primitive_types.Uint8_t -> Unsigned.UInt8.to_int64 183 | | Ctypes_primitive_types.Uint16_t -> Unsigned.UInt16.to_int64 184 | | Ctypes_primitive_types.Uint32_t -> Unsigned.UInt32.to_int64 185 | | Ctypes_primitive_types.Uint64_t -> Unsigned.UInt64.to_int64 186 | | _ -> fail typ 187 | : a -> int64) 188 | | _ -> fail typ 189 | in 190 | fun a k -> f a (to_int64 k) 191 | in 192 | let pname = if typedef then name else "enum " ^ name in 193 | let ralist = List.rev alist in 194 | let (write : b list -> a) = 195 | fun l -> List.fold_left (fun ac k -> lor' (List.assoc k alist) ac) zero l 196 | and (read : a -> b list) = 197 | fun res -> 198 | let rec iter res_orig ac res l = 199 | match l with 200 | | [] -> if res = zero then ac else unexpected ac res 201 | | (a, b) :: tl -> 202 | if land' b res_orig = b then 203 | iter res_orig (a :: ac) (land' res (lnot' b)) tl 204 | else iter res_orig ac res tl 205 | in 206 | iter res [] res ralist 207 | and format_typ k fmt = Format.fprintf fmt "%s%t" pname k in 208 | Ctypes_static.view ~format_typ ~read ~write typ 209 | 210 | external to_voidp : nativeint -> Cstubs_internals.voidp = "%identity" 211 | 212 | let invalid_code () = failwith "ppx_cstub generated invalid code" 213 | 214 | module Signed = struct 215 | module Nativeint = struct 216 | include struct 217 | [@@@ocaml.warning "-32"] 218 | 219 | let equal (x : nativeint) (y : nativeint) = x = y 220 | 221 | let pp fmt x = Format.fprintf fmt "%nd" x 222 | 223 | let pp_hex fmt n = Format.fprintf fmt "%nx" n 224 | end 225 | 226 | include Nativeint 227 | 228 | module Infix = struct 229 | let ( + ) = add 230 | 231 | let ( - ) = sub 232 | 233 | let ( * ) = mul 234 | 235 | let ( / ) = div 236 | 237 | let ( mod ) = rem 238 | 239 | let ( land ) = logand 240 | 241 | let ( lor ) = logor 242 | 243 | let ( lxor ) = logxor 244 | 245 | let ( lsl ) = shift_left 246 | 247 | let ( lsr ) = shift_right_logical 248 | 249 | [@@@ocaml.warning "-32"] 250 | 251 | let ( asr ) = shift_right 252 | end 253 | 254 | external of_nativeint : t -> t = "%identity" 255 | 256 | external to_nativeint : t -> t = "%identity" 257 | 258 | let of_int64 = Int64.to_nativeint 259 | 260 | let to_int64 = Int64.of_nativeint 261 | 262 | [@@@ocaml.warning "-32"] 263 | 264 | let max = max 265 | 266 | let min = min 267 | 268 | let of_string_opt x = try Some (of_string x) with Failure _ -> None 269 | 270 | let to_hexstring n = Format.asprintf "%nx" n 271 | end 272 | 273 | module type Int_size = sig 274 | val int_size : int 275 | end 276 | 277 | external format_int : string -> int -> string = "caml_format_int" 278 | 279 | module Short_int (X : Int_size) = struct 280 | open X 281 | 282 | type t = int 283 | 284 | let max_int = (1 lsl (int_size - 1)) - 1 285 | 286 | let min_int = (1 lsl (int_size - 1)) * -1 287 | 288 | let sfactor = Sys.word_size - 1 - int_size 289 | 290 | let of_int x = (x lsl sfactor) asr sfactor 291 | 292 | let add x y = of_int (x + y) 293 | 294 | let sub x y = of_int (x - y) 295 | 296 | let mul x y = of_int (x * y) 297 | 298 | let div x y = of_int (x / y) 299 | 300 | let rem x y = x mod y 301 | 302 | let logand x y = x land y 303 | 304 | let logor x y = x lor y 305 | 306 | let logxor x y = x lxor y 307 | 308 | let shift_left x y = of_int (x lsl y) 309 | 310 | let shift_right_logical x y = 311 | of_int ((x lsr y) land ((1 lsl (int_size - y)) - 1)) 312 | 313 | let shift_right x y = of_int (x asr y) 314 | 315 | module Infix = struct 316 | let ( + ) = add 317 | 318 | let ( - ) = sub 319 | 320 | let ( * ) = mul 321 | 322 | let ( / ) = div 323 | 324 | let ( mod ) = rem 325 | 326 | let ( land ) = logand 327 | 328 | let ( lor ) = logor 329 | 330 | let ( lxor ) = logxor 331 | 332 | let ( lsl ) = shift_left 333 | 334 | let ( lsr ) = shift_right_logical 335 | 336 | [@@@ocaml.warning "-32"] 337 | 338 | let ( asr ) = shift_right 339 | end 340 | 341 | let lognot x = lnot x 342 | 343 | let compare = compare 344 | 345 | external to_int : t -> t = "%identity" 346 | 347 | let of_string x = 348 | let r = int_of_string x in 349 | if r < min_int || r > max_int then failwith "int_of_string"; 350 | r 351 | 352 | let to_string = string_of_int 353 | 354 | let zero = 0 355 | 356 | let one = 1 357 | 358 | let minus_one = -1 359 | 360 | let succ x = of_int (succ x) 361 | 362 | let pred x = of_int (pred x) 363 | 364 | let to_int64 = Int64.of_int 365 | 366 | let of_int64 x = of_int (Int64.to_int x) 367 | 368 | let to_nativeint = Nativeint.of_int 369 | 370 | let of_nativeint x = of_int (Nativeint.to_int x) 371 | 372 | let abs x = of_int (abs x) 373 | 374 | let neg x = of_int (-x) 375 | 376 | [@@@ocaml.warning "-32"] 377 | 378 | let max = max 379 | 380 | let min = min 381 | 382 | let equal (x : t) (y : t) = x = y 383 | 384 | let of_string_opt x = 385 | match int_of_string x with 386 | | exception Failure _ -> None 387 | | r -> if r < min_int || r > max_int then None else Some r 388 | 389 | let pp fmt n = Format.fprintf fmt "%d" n 390 | 391 | let pp_hex fmt n = Format.fprintf fmt "%x" n 392 | 393 | let to_hexstring = format_int "%x" 394 | end 395 | 396 | module Int8 = Short_int (struct 397 | let int_size = 8 398 | end) 399 | 400 | module Int16 = Short_int (struct 401 | let int_size = 16 402 | end) 403 | 404 | module Int32 = Short_int (struct 405 | let int_size = 32 406 | end) 407 | 408 | module type Short = sig 409 | include Signed.S with type t = int 410 | end 411 | 412 | module Short = (val match Ctypes.sizeof Ctypes.short with 413 | | 1 -> (module Int8) 414 | | 2 -> (module Int16) 415 | | 4 when Ctypes.sizeof Ctypes.int = 4 -> 416 | if Sys.word_size = 64 then (module Int32) 417 | else (module Signed.Int) 418 | | _ -> failwith "invalid size of short" : Short) 419 | 420 | module Schar = Int8 421 | end 422 | 423 | module Callback = struct 424 | module type Info = sig 425 | type real 426 | 427 | val real : real Ctypes.fn 428 | end 429 | 430 | module Make (H : Info) : sig 431 | type fn = H.real 432 | 433 | type 'a t 434 | 435 | type raw_pointer 436 | 437 | val t : H.real t Ctypes.static_funptr Ctypes.typ 438 | 439 | val fn : H.real Ctypes.fn 440 | 441 | val make_pointer : raw_pointer -> H.real t Ctypes.static_funptr 442 | end = struct 443 | open H 444 | 445 | type fn = real 446 | 447 | type 'a t = real 448 | 449 | type raw_pointer = nativeint 450 | 451 | let t = Ctypes.static_funptr real 452 | 453 | let fn = H.real 454 | 455 | let make_pointer p = Cstubs_internals.make_fun_ptr H.real (to_voidp p) 456 | end 457 | 458 | let make (type a) (fn : a Ctypes.fn) = 459 | (module struct 460 | type real = a 461 | 462 | let real = fn 463 | end : Info 464 | with type real = a) 465 | end 466 | 467 | module Shadow = struct 468 | let rec passable : type a. a typ -> bool = function 469 | | Void -> true 470 | | Primitive _ -> true 471 | | Struct { spec = Incomplete _; _ } -> raise IncompleteType 472 | | Struct { spec = Complete _; _ } -> true 473 | | Union { uspec = None; _ } -> raise IncompleteType 474 | | Union { uspec = Some _; _ } -> true 475 | | Array _ -> false 476 | | Bigarray _ -> false 477 | | Pointer _ -> true 478 | | Funptr _ -> true 479 | (* Allow to pass and return abstract types. I don't know why it is 480 | disabled upstream. They are handled like structs and unions *) 481 | | Abstract _ -> true 482 | | OCaml _ -> true 483 | | View { ty; _ } -> passable ty 484 | 485 | let ( @-> ) a b = 486 | if not (passable a) then raise (Unsupported "Unsupported argument type") 487 | else Function (a, b) 488 | 489 | let returning a = 490 | if not (passable a) then raise (Unsupported "Unsupported return type") 491 | else Returns a 492 | end 493 | 494 | external obj_magic : 'a -> 'b = "%identity" 495 | -------------------------------------------------------------------------------- /src/runtime/ppx_cstubs_internals.mli: -------------------------------------------------------------------------------- 1 | (* Copyright 2018 fdopen 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any 4 | purpose with or without fee is hereby granted. 5 | 6 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 7 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 8 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 9 | SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 10 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION 11 | OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN 12 | CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) 13 | 14 | (* These functions are used by generated code, you should NEVER use them 15 | manually. *) 16 | 17 | (**/**) 18 | 19 | val seal : 'a Ctypes_static.typ -> size:int -> align:int -> unit 20 | 21 | val add_field : 22 | 't Ctypes_static.typ -> 23 | string -> 24 | int -> 25 | 'a Ctypes_static.typ -> 26 | ('a, 't) Ctypes_static.field 27 | 28 | external to_voidp : nativeint -> Cstubs_internals.voidp = "%identity" 29 | 30 | external identity : 'a -> 'a = "%identity" 31 | 32 | val invalid_code : unit -> 'a 33 | 34 | val build_enum : 35 | string -> 36 | 'a Ctypes.typ -> 37 | typedef:bool -> 38 | ?unexpected:(int64 -> 'b) -> 39 | ('b * 'a) list -> 40 | 'b Ctypes.typ 41 | 42 | val build_enum_bitmask : 43 | string -> 44 | 'a Ctypes.typ -> 45 | typedef:bool -> 46 | ?unexpected:('b list -> int64 -> 'b list) -> 47 | ('b * 'a) list -> 48 | 'b list Ctypes.typ 49 | 50 | module Signed : sig 51 | module Nativeint : Signed.S with type t = nativeint 52 | 53 | module Int8 : Signed.S with type t = int 54 | 55 | module Int16 : Signed.S with type t = int 56 | 57 | module Int32 : Signed.S with type t = int 58 | 59 | module Schar : Signed.S with type t = int 60 | 61 | module Short : Signed.S with type t = int 62 | end 63 | 64 | module Callback : sig 65 | module type Info = sig 66 | type real 67 | 68 | val real : real Ctypes_static.fn 69 | end 70 | 71 | module Make (H : Info) : sig 72 | type fn = H.real 73 | 74 | type 'a t 75 | 76 | type raw_pointer 77 | 78 | val t : H.real t Ctypes.static_funptr Ctypes.typ 79 | 80 | val fn : H.real Ctypes_static.fn 81 | 82 | val make_pointer : raw_pointer -> H.real t Ctypes.static_funptr 83 | end 84 | 85 | val make : 'a Ctypes.fn -> (module Info with type real = 'a) 86 | 87 | (* 88 | always two hops to prune `real` away for nicer type hints: 89 | 90 | module E = Make ((val make (int @-> returning int))) 91 | *) 92 | end 93 | 94 | module Shadow : sig 95 | val ( @-> ) : 'a Ctypes.typ -> 'b Ctypes.fn -> ('a -> 'b) Ctypes.fn 96 | 97 | val returning : 'a Ctypes.typ -> 'a Ctypes.fn 98 | end 99 | 100 | (* only used inside signatures in order to avoid writing too much dummy 101 | code: `module type of struct let f = .... end ` *) 102 | external obj_magic : 'a -> 'b = "%identity" 103 | 104 | (**/**) 105 | --------------------------------------------------------------------------------