├── .github └── workflows │ └── main.yml ├── .gitignore ├── .ocamlinit ├── AUTHORS.txt ├── COPYING.txt ├── README.markdown ├── docs ├── diagrams │ ├── luaL_newstate__stub.dia │ ├── luaL_newstate__stub.png │ └── luaL_newstate__stub.svg └── style.css ├── dune-project ├── examples ├── ci │ ├── ci.ml │ └── script.lua └── lua_book │ ├── dir.lua │ └── dir.ml ├── ocaml-lua.opam ├── src ├── dune ├── lua_api.ml ├── lua_api_lib.ml ├── lua_api_lib.mli ├── lua_api_lib_stubs.c ├── lua_aux_lib.ml ├── lua_aux_lib.mli ├── lua_aux_lib_stubs.c ├── lua_c │ ├── dune │ ├── jbuild-ignore │ ├── lua-5.1.5.tar.gz │ └── lua.patch └── stub.h └── tests ├── atpanic.ml ├── cpcall.ml ├── dune ├── fasta_threads.ml ├── test_common.ml └── userdata.ml /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | name: Main workflow 2 | 3 | on: 4 | push: 5 | 6 | jobs: 7 | build: 8 | strategy: 9 | fail-fast: false 10 | matrix: 11 | os: 12 | - macos-latest 13 | - ubuntu-latest 14 | ocaml-compiler: 15 | - "4.08" 16 | - "4.09" 17 | - "4.10" 18 | - "4.11" 19 | - "4.12" 20 | - "4.13" 21 | - "4.14" 22 | - "5.0" 23 | 24 | runs-on: ${{ matrix.os }} 25 | 26 | steps: 27 | - name: Checkout tree 28 | uses: actions/checkout@v3 29 | 30 | - name: Set-up OCaml ${{ matrix.ocaml-compiler }} 31 | uses: ocaml/setup-ocaml@v2 32 | with: 33 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 34 | 35 | - run: opam install . --deps-only --with-doc 36 | 37 | - run: cd src/lua_c ; tar xf lua-5.1.5.tar.gz 38 | 39 | - run: cd src/lua_c/lua-5.1.5 ; patch -p1 -i ../lua.patch 40 | 41 | - run: cd src/lua_c ; mv lua-5.1.5 lua515 42 | 43 | - run: opam exec -- dune build @install @doc 44 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | src/lua_c/lua515/ 2 | 3 | _build 4 | _opam 5 | 6 | *.code-workspace 7 | -------------------------------------------------------------------------------- /.ocamlinit: -------------------------------------------------------------------------------- 1 | #directory "+compiler-libs";; 2 | 3 | (* Added by OPAM. *) 4 | let () = 5 | try Topdirs.dir_directory (Sys.getenv "OCAML_TOPLEVEL_PATH") 6 | with Not_found -> () 7 | ;; 8 | 9 | let interactive = !Sys.interactive;; 10 | Sys.interactive := false;; (* Pretend to be in non-interactive mode *) 11 | #use "topfind";; 12 | Sys.interactive := interactive;; (* Return to regular interactive mode *) 13 | -------------------------------------------------------------------------------- /AUTHORS.txt: -------------------------------------------------------------------------------- 1 | Authors of ocaml-lua: 2 | 3 | Paolo Donadeo 4 | Sylvain Le Gall 5 | 6 | Special thank to Sylvain for giving us OCaml Forge and OASIS. 7 | -------------------------------------------------------------------------------- /COPYING.txt: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013 Paolo Donadeo, Sylvain Le Gall 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to 5 | deal in the Software without restriction, including without limitation the 6 | rights to use, copy, modify, merge, publish, distribute, sublicense, and/or 7 | sell copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 18 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 19 | IN THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | [![Main workflow](https://github.com/pdonadeo/ocaml-lua/actions/workflows/main.yml/badge.svg)](https://github.com/pdonadeo/ocaml-lua/actions/workflows/main.yml) 2 | 3 | ## What is ocaml-lua 4 | 5 | OCaml-lua provides bindings to the Lua programming language. Lua is a scripting 6 | language particularly useful when you need to embed a language in your 7 | application. 8 | 9 | This project provides the bindings required to embed Lua. 10 | 11 | [More information about Lua](http://www.lua.org/) 12 | 13 |

14 | Lua logo 15 |

16 | 17 | ## Introduction 18 | 19 | Lua is a powerful, light-weight programming language designed for extending 20 | applications. It provides a good general purpose programming language to replace 21 | DSL that don't really need to be specific. 22 | 23 | This library provides bindings to Lua API which allows the application to 24 | exchange data with Lua programs and also to extend Lua with OCaml functions. 25 | 26 | This is the OCaml complete binding of the Lua Application Program Interface as 27 | described in the official documentation. 28 | 29 | In this moment only the version 5.1.x is supported. 30 | 31 | ## Intended audience 32 | 33 | This library is intended to be useful to OCaml developers needing a dynamic 34 | language to be included in their projects, for configuration or customization 35 | purposes. Instead of reinventing yet another DSL, one should consider using an 36 | existing programming language and Lua is in my opinion the perfect companion of 37 | a statically typed language like OCaml. 38 | 39 | In a few lines of code you can create a Lua interpreter and run a Lua program 40 | inside it. You can provide the Lua state with library functions written in OCaml 41 | and available to the Lua program. 42 | 43 | More informations about Lua can be found on the 44 | [documentation page](http://www.lua.org/docs.html). 45 | 46 | My advice is to read the book ["Programming in Lua"](http://www.lua.org/pil/), 47 | written by the author of the language, Roberto Ierusalimschy. 48 | 49 | ## Where to find everything 50 | 51 | The homepage of the project is hosted on 52 | [GitHub](https://pdonadeo.github.io/ocaml-lua/). 53 | 54 | The complete library reference (ocamldoc generated) is 55 | [here](https://pdonadeo.github.io/ocaml-lua/ocamldoc/). 56 | 57 | The official GIT repository is 58 | [here](https://github.com/pdonadeo/ocaml-lua). 59 | 60 | Bug reports and feature requests are on my page on 61 | [GitHub](https://github.com/pdonadeo/ocaml-lua/issues). 62 | 63 | See the file COPYING.txt for copying conditions. See the file AUTHORS.txt for 64 | credits. 65 | 66 | ## Building and installing the library 67 | 68 | ### Installing with OPAM 69 | 70 | Installing the library with OPAM should be as sismple as: 71 | `opam install ocaml-lua` 72 | 73 | ### Compiling and installing from source 74 | 75 | To build the library you need dune and odoc (for documentation). 76 | 77 | To compile: 78 | 79 | 1. cd src/lua_c ; tar xf lua-5.1.5.tar.gz 80 | 2. cd lua-5.1.5 ; patch -p1 -i ../lua.patch 81 | 3. cd .. ; mv lua-5.1.5 lua515 82 | 4. cd ../.. ; dune build @install 83 | 5. dune build @doc 84 | -------------------------------------------------------------------------------- /docs/diagrams/luaL_newstate__stub.dia: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pdonadeo/ocaml-lua/f44ad50c88bf999f48a13af663051493c89d7d02/docs/diagrams/luaL_newstate__stub.dia -------------------------------------------------------------------------------- /docs/diagrams/luaL_newstate__stub.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pdonadeo/ocaml-lua/f44ad50c88bf999f48a13af663051493c89d7d02/docs/diagrams/luaL_newstate__stub.png -------------------------------------------------------------------------------- /docs/diagrams/luaL_newstate__stub.svg: -------------------------------------------------------------------------------- 1 | 2 | 17 | 19 | 20 | 22 | image/svg+xml 23 | 25 | 26 | 27 | 28 | 30 | 55 | 58 | 67 | 76 | 77 | 82 | Situation after luaL_newstate___stub() has been called 86 | 87 | 90 | 99 | 108 | 109 | 114 | The OCaml "main" program 118 | 119 | 122 | 127 | 132 | 137 | 141 | 142 | 143 | 146 | 153 | 160 | value 165 | This value is returned to OCaml via the 170 | CAMLreturn macro 175 | 176 | 181 | The new state returned by 185 | LuaL.newstate () 189 | 190 | 195 | Outside OCaml Heap 199 | (malloc) 203 | 204 | 207 | 214 | 221 | lua_State 226 | This lua_State contains a pointer to a 231 | block of ocaml_data, which contains two 236 | OCaml value 241 | 248 | 255 | +private_data: ocaml_data 260 | This is not a real "attribute", the 265 | referense is kept inside the Lua state 270 | registry 275 | 276 | 279 | 284 | 289 | 294 | 298 | 299 | 300 | 305 | OCaml Heap 309 | 310 | 313 | 320 | 327 | ocaml_data 332 | 339 | 346 | +state_value: value 351 | state_value is registered as global 356 | root! 361 | +panic_callback: value 366 | panic_callback is registered as global 371 | root! 376 | 377 | 380 | 387 | 394 | value 399 | this value comes from OCaml, and is 404 | made available in C via 409 | caml_named_value() 414 | 421 | 428 | +Data_custom_val: user data 433 | Default panic callback, it's an OCaml 438 | functional value provided by the 443 | library 448 | 449 | 452 | 459 | 466 | value 471 | This value HAS a finalizer! 476 | 483 | 490 | +Data_custom_val: user data 495 | The custom block contains a 500 | "lua_State*" pointing to the actual 505 | lua_State 510 | 511 | 514 | 521 | 528 | value 533 | This value HAS NOT a finalizer! 538 | 545 | 552 | +Data_custom_val: user data 557 | The custom block contains a 562 | "lua_State*" pointing to the actual 567 | lua_State 572 | 573 | 576 | 581 | 585 | 589 | 590 | 593 | 598 | 602 | 606 | 607 | 610 | 615 | 619 | 623 | 624 | 627 | 632 | 636 | 640 | 641 | 644 | 649 | 653 | 657 | 658 | 661 | 666 | 670 | 674 | 675 | 676 | -------------------------------------------------------------------------------- /docs/style.css: -------------------------------------------------------------------------------- 1 | /* 2 | YUI 3.6.0 (build 5521) 3 | Copyright 2012 Yahoo! Inc. All rights reserved. 4 | Licensed under the BSD License. 5 | http://yuilibrary.com/license/ 6 | */ 7 | html{color:#000;background:#FFF}body,div,dl,dt,dd,ul,ol,li,h1,h2,h3,h4,h5,h6,pre,code,form,fieldset,legend,input,textarea,p,blockquote,th,td{margin:0;padding:0}table{border-collapse:collapse;border-spacing:0}fieldset,img{border:0}address,caption,cite,code,dfn,em,strong,th,var{font-style:normal;font-weight:normal}ol,ul{list-style:none}caption,th{text-align:left}h1,h2,h3,h4,h5,h6{font-size:100%;font-weight:normal}q:before,q:after{content:''}abbr,acronym{border:0;font-variant:normal}sup{vertical-align:text-top}sub{vertical-align:text-bottom}input,textarea,select{font-family:inherit;font-size:inherit;font-weight:inherit}input,textarea,select{*font-size:100%}legend{color:#000}#yui3-css-stamp.cssreset{display:none} 8 | 9 | /* A style for ocamldoc. Daniel C. Buenzli */ 10 | 11 | table { border-collapse: collapse; border-spacing: 0; } 12 | 13 | /* Basic page layout using the user's preferred font sizes */ 14 | 15 | body { font: normal 1em/1.375em helvetica, arial, sans-serif; text-align:left; 16 | margin: 1.375em 10%; min-width: 40ex; max-width: 72ex; 17 | color: black; background: transparent /* url(line-height-22.gif) */; } 18 | 19 | b { font-weight: bold } 20 | em { font-style: italic } 21 | 22 | tt, code, pre { font-family: WorkAroundWebKitAndMozilla, monospace; 23 | font-size: 1em; } 24 | pre code { font-size : inherit; } 25 | .codepre { margin-bottom:1.375em /* after code example we introduce space. */ } 26 | 27 | .superscript,.subscript 28 | { font-size : 0.813em; line-height:0; margin-left:0.4ex;} 29 | .superscript { vertical-align: super; } 30 | .subscript { vertical-align: sub; } 31 | 32 | /* ocamldoc markup workaround hacks */ 33 | 34 | code br { display: inline } /* because of the above span + br rule */ 35 | h1 + pre { margin-bottom:1.375em} /* Toplevel module description */ 36 | 37 | /* Sections and document divisions */ 38 | 39 | /* .navbar { margin-bottom: -1.375em } */ 40 | h1 { font-weight: bold; font-size: 1.5em; /* margin-top:1.833em; */ 41 | margin-top:0.917em; padding-top:0.875em; 42 | border-top-style:solid; border-width:1px; border-color:#AAA; } 43 | h2 { font-weight: bold; font-size: 1.313em; margin-top: 1.048em } 44 | h3 { font-weight: bold; font-size: 1.125em; margin-top: 1.222em } 45 | h3 { font-weight: bold; font-size: 1em; margin-top: 1.375em} 46 | h4 { font-style: italic; } 47 | 48 | /* Used by OCaml's own library documentation. */ 49 | h6 { font-weight: bold; font-size: 1.125em; margin-top: 1.222em } 50 | .h7 { font-weight: bold; font-size: 1em; margin-top: 1.375em } 51 | 52 | p { margin-top: 1.375em } 53 | pre { margin-top: 1.375em } 54 | .info { margin: 0.458em 0em -0.458em 2em;}/* Description of types values etc. */ 55 | td .info { margin:0; padding:0; margin-left: 2em;} /* Description in indexes */ 56 | 57 | ul, ol { margin-top:0.688em; padding-bottom:0.687em; 58 | list-style-position:outside} 59 | ul + p, ol + p { margin-top: 0em } 60 | ul { list-style-type: square } 61 | 62 | 63 | /* h2 + ul, h3 + ul, p + ul { } */ 64 | ul > li { margin-left: 1.375em; } 65 | ol > li { margin-left: 1.7em; } 66 | /* Links */ 67 | 68 | a, a:link, a:visited, a:active, a:hover { color : #00B; text-decoration: none } 69 | a:hover { text-decoration : underline } 70 | *:target {background-color: #FFFF99;} /* anchor highlight */ 71 | 72 | /* Code */ 73 | 74 | .keyword { font-weight: bold; } 75 | .comment { color : red } 76 | .constructor { color : green } 77 | .string { color : brown } 78 | .warning { color : red ; font-weight : bold } 79 | 80 | /* Functors */ 81 | 82 | .paramstable { border-style : hidden ; padding-bottom:1.375em} 83 | .paramstable code { margin-left: 1ex; margin-right: 1ex } 84 | .sig_block {margin-left: 1em} 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.11) 2 | (name ocaml-lua) 3 | (version 1.8) 4 | -------------------------------------------------------------------------------- /examples/ci/ci.ml: -------------------------------------------------------------------------------- 1 | 2 | let () = 3 | print_endline "Bonjour" 4 | -------------------------------------------------------------------------------- /examples/ci/script.lua: -------------------------------------------------------------------------------- 1 | 2 | function fetch () 3 | ci.log('I', 'Starting to fetch') 4 | if ci.exec('darcs', {'pull'}) ~= 0 then 5 | ci.log('E', 'darcs pull failed') 6 | return false 7 | end 8 | ci.log('I', 'darcs pull succeed') 9 | return true 10 | end 11 | 12 | function build () 13 | ci.log('I', 'Starting to build') 14 | ci.putenv('VERSION', '0.1') 15 | if ci.exec("make", {}) ~= 0 then 16 | ci.log('E', 'make failed') 17 | return false 18 | end 19 | ci.log('I', 'make succeed') 20 | return true 21 | end 22 | -------------------------------------------------------------------------------- /examples/lua_book/dir.lua: -------------------------------------------------------------------------------- 1 | abs_count = 0 2 | 3 | function traverse(start, lvl) 4 | lvl = lvl or 0 5 | local d = opendir(start) -- opendir is provided by OCaml 6 | if d ~= nil then 7 | dir = readdir(d) -- readdir is provided by OCaml 8 | while dir ~= nil do 9 | local abs_path = start .. dir 10 | if dir ~= "." and dir ~= ".." then 11 | local indent = string.rep(" ", lvl) 12 | abs_count = abs_count + 1 13 | io.write(string.format("entry %07d is: %s%s\n", abs_count, indent, abs_path)) 14 | io.stdout:flush() 15 | local is_link = is_symlink(abs_path) -- is_symlink is provided by OCaml 16 | if is_link ~= nil and not is_link then 17 | traverse(abs_path .. "/", lvl + 1) 18 | end 19 | end 20 | dir = readdir(d) 21 | end 22 | end 23 | end 24 | 25 | traverse("/") 26 | -------------------------------------------------------------------------------- /examples/lua_book/dir.ml: -------------------------------------------------------------------------------- 1 | open Lua_api;; 2 | 3 | let (|>) x f = f x;; 4 | 5 | let getopt o = 6 | match o with 7 | | Some v -> v 8 | | None -> raise Not_found 9 | ;; 10 | 11 | module LuaBookDir = 12 | struct 13 | let readdir ls = 14 | let open Unix in 15 | let handle : dir_handle = 16 | let w = Lua.touserdata ls 1 in 17 | match w with 18 | | Some `Userdata h -> h 19 | | _ -> failwith "Dir handle expected!" in 20 | try Lua.pushstring ls (readdir handle); 1 21 | with End_of_file -> 0 22 | 23 | let dir_gc ls = 24 | let open Unix in 25 | let handle : dir_handle = 26 | let w = Lua.touserdata ls 1 in 27 | match w with 28 | | Some `Userdata h -> h 29 | | _ -> failwith "Dir handle expected!" in 30 | closedir handle; 31 | 0 32 | 33 | let is_symlink ls = 34 | let open Unix in 35 | let path = LuaL.checkstring ls 1 in 36 | try 37 | let stat = lstat path in 38 | match stat.st_kind with 39 | | S_LNK -> (Lua.pushboolean ls true; 1) 40 | | _ -> (Lua.pushboolean ls false; 1) 41 | with Unix_error (err, _, _) -> 0 42 | 43 | let opendir ls = 44 | let open Unix in 45 | let path = LuaL.checkstring ls 1 in 46 | try 47 | let handle = opendir path in 48 | Lua.newuserdata ls handle; 49 | LuaL.getmetatable ls "LuaBook.dir"; 50 | Lua.setmetatable ls (-2) |> ignore; 51 | 1 52 | with Unix_error (err, _, _) -> 0 53 | 54 | let luaopen_dir ls = 55 | (* metatable for "dir" *) 56 | LuaL.newmetatable ls "LuaBook.dir" |> ignore; 57 | Lua.pushstring ls "__gc"; 58 | Lua.pushocamlfunction ls (Lua.make_gc_function dir_gc); 59 | Lua.settable ls (-3) |> ignore; 60 | 61 | Lua.pushocamlfunction ls opendir; 62 | Lua.setglobal ls "opendir"; 63 | 64 | Lua.pushocamlfunction ls readdir; 65 | Lua.setglobal ls "readdir"; 66 | 67 | Lua.pushocamlfunction ls is_symlink; 68 | Lua.setglobal ls "is_symlink"; 69 | end;; 70 | 71 | let main () = 72 | let ls = LuaL.newstate () in 73 | LuaL.openlibs ls; 74 | LuaBookDir.luaopen_dir ls; 75 | let () = 76 | try 77 | LuaL.loadfile ls Sys.argv.(1) |> ignore 78 | with Invalid_argument _ -> begin 79 | Printf.eprintf "Usage: %s examples/lua_book/dir.lua\n%!" Sys.argv.(0); 80 | exit 1 |> ignore 81 | end in 82 | match Lua.pcall ls 0 0 0 with 83 | | Lua.LUA_OK -> () 84 | | err -> begin 85 | let err_msg = (Lua.tostring ls (-1) |> getopt) in 86 | Lua.pop ls 1; 87 | failwith err_msg 88 | end 89 | ;; 90 | 91 | main ();; 92 | -------------------------------------------------------------------------------- /ocaml-lua.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "p.donadeo@gmail.com" 3 | authors: [ 4 | "Paolo Donadeo" 5 | "Sylvain Le Gall" 6 | ] 7 | homepage: "https://pdonadeo.github.io/ocaml-lua/" 8 | bug-reports: "https://github.com/pdonadeo/ocaml-lua/issues" 9 | dev-repo: "git+https://github.com/pdonadeo/ocaml-lua.git" 10 | license: "MIT" 11 | build: [ 12 | [ "sh" "-c" "cd src/lua_c ; tar xf lua-5.1.5.tar.gz" ] 13 | [ "sh" "-c" "cd src/lua_c/lua-5.1.5 ; patch -p1 -i ../lua.patch" ] 14 | [ "sh" "-c" "cd src/lua_c ; mv lua-5.1.5 lua515" ] 15 | [ "dune" "build" "-p" name "-j" jobs "@install" ] 16 | [ "dune" "build" "-p" name "-j" jobs "@doc" ] {with-doc} 17 | ] 18 | depends: [ 19 | "ocaml" {>= "4.08.0"} 20 | "dune" {>= "1.11"} 21 | "odoc" {with-doc} 22 | ] 23 | synopsis: "Lua bindings" 24 | description: """ 25 | Lua is a powerful, light-weight programming language designed for 26 | extending applications. It provides a good general purpose programming 27 | language to replace DSL that don't really need to be specific. 28 | 29 | This library provides bindings to Lua API which allows the application 30 | to exchange data with Lua programs and also to extend Lua with OCaml 31 | functions. 32 | 33 | [Lua homepage](http://www.lua.org)""" 34 | url { 35 | src: "https://github.com/pdonadeo/ocaml-lua/archive/v1.8.tar.gz" 36 | checksum: "md5=f5fd56bd53f8e87818cb18137304e415" 37 | } 38 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name lua) 3 | (wrapped false) 4 | (public_name ocaml-lua) 5 | (modules lua_api lua_api_lib lua_aux_lib) 6 | (c_names lua_api_lib_stubs lua_aux_lib_stubs) 7 | (c_flags -O3 -Ilua_c/lua515/src -Wno-discarded-qualifiers) 8 | (libraries unix threads lua_c)) 9 | -------------------------------------------------------------------------------- /src/lua_api.ml: -------------------------------------------------------------------------------- 1 | (*******************************************************************) 2 | (** {1 The Lua API library binding in OCaml {b (read this first)}} *) 3 | (*******************************************************************) 4 | 5 | (*********************) 6 | (** {2 Introduction} *) 7 | (*********************) 8 | 9 | (** This is the OCaml complete binding of the Lua Application Program Interface 10 | as described in the {{:http://www.lua.org/manual/5.1/manual.html#3}official 11 | documentation}. The version of the library is the 5.1.5, the source code is 12 | available {{:http://www.lua.org/versions.html#5.1}here} but, since it's a bug 13 | fix release, any version 5.1.x should be fine. On the other side, previous 14 | releases and the new Lua 5.2 is not supported. 15 | 16 | The Lua API library is composed by two parts: the 17 | {{:http://www.lua.org/manual/5.1/manual.html#3}low level API}, providing all 18 | the functions you need to interact with the Lua runtime, and the 19 | {{:http://www.lua.org/manual/5.1/manual.html#4}auxiliary library}, described 20 | in the original documentation as follow: 21 | 22 | {i The auxiliary library provides several convenient functions to interface 23 | C with Lua. While the basic API provides the primitive functions for all 24 | interactions between C and Lua, the auxiliary library provides higher-level 25 | functions for some common tasks. ... All functions in the auxiliary 26 | library are built on top of the basic API, and so they provide nothing that 27 | cannot be done with this API. } 28 | 29 | I included all the functions in the two libraries, with the exception of the 30 | {{:http://www.lua.org/manual/5.1/manual.html#3.8} debug interface}, which is 31 | not planned because it's out of the intended scope of the OCaml binding. It 32 | could be added if anyone really needs it. 33 | 34 | The signatures of the OCaml counterparts of the Lua functions where kept as 35 | close as possible to the original ones, to reduce at the minimum the mismatch 36 | between the two. This guideline lead to a very "imperative" OCaml library, but 37 | I think this is a minor issue. 38 | 39 | Two "low level" modules are provided, {!Lua_api_lib} and {!Lua_aux_lib}. 40 | Ideally you should start your program opening [Lua_api], and then call 41 | functions like this: 42 | 43 | {[ 44 | open Lua_api;; 45 | 46 | let push_hello () = 47 | let ls = LuaL.newstate () in 48 | Lua.pushstring ls "hello"; 49 | ls 50 | ;; 51 | ]} 52 | which is very close to what you would do in C: 53 | {[ 54 | #include 55 | #include 56 | #include 57 | 58 | lua_State* push_hello () { 59 | lua_State *L = luaL_newstate(); 60 | lua_pushstring(L, "hello"); 61 | return L; 62 | } 63 | ]} 64 | 65 | Many functions, expecially in the [LuaL] module, are not real bindings, 66 | because sometimes it was faster to rewrite the function in OCaml than 67 | creating the binding. Every time this happens, it's clearly stated in the 68 | documentation. Other functions have different signatures or special notes, 69 | but all these differences are documented. At the top of the pages 70 | documenting the {! Lua_api_lib} and {! Lua_aux_lib} modules there is a list 71 | of important differences. 72 | *) 73 | 74 | 75 | (******************************) 76 | (** {3 Note on thread safety} *) 77 | (******************************) 78 | 79 | (** 80 | This binding is to be considered "thread safe". This means that you can use 81 | the library in a threaded setup, but keep in mind that you {b cannot} share 82 | a Lua state [Lua_api_lib.state] between threads, because Lua itself doesn't 83 | allow this. *) 84 | 85 | 86 | (**************************) 87 | (** {2 Low level modules} *) 88 | (**************************) 89 | 90 | module Lua = Lua_api_lib 91 | (** For reference see {! Lua_api_lib} *) 92 | 93 | module LuaL = Lua_aux_lib 94 | (** For reference see {! Lua_aux_lib} *) 95 | -------------------------------------------------------------------------------- /src/lua_api_lib.ml: -------------------------------------------------------------------------------- 1 | (*******************************) 2 | (* COMMON FUNCTIONAL OPERATORS *) 3 | (*******************************) 4 | let (|>) x f = f x 5 | 6 | type state 7 | 8 | type oCamlFunction = state -> int 9 | 10 | type thread_status = 11 | | LUA_OK 12 | | LUA_YIELD 13 | | LUA_ERRRUN 14 | | LUA_ERRSYNTAX 15 | | LUA_ERRMEM 16 | | LUA_ERRERR 17 | | LUA_ERRFILE 18 | 19 | type gc_command = 20 | | GCSTOP 21 | | GCRESTART 22 | | GCCOLLECT 23 | | GCCOUNT 24 | | GCCOUNTB 25 | | GCSTEP 26 | | GCSETPAUSE 27 | | GCSETSTEPMUL 28 | 29 | type lua_type = 30 | | LUA_TNONE 31 | | LUA_TNIL 32 | | LUA_TBOOLEAN 33 | | LUA_TLIGHTUSERDATA 34 | | LUA_TNUMBER 35 | | LUA_TSTRING 36 | | LUA_TTABLE 37 | | LUA_TFUNCTION 38 | | LUA_TUSERDATA 39 | | LUA_TTHREAD 40 | 41 | type 'a lua_Reader = state -> 'a -> string option 42 | 43 | type writer_status = 44 | | NO_WRITING_ERROR (** No errors, go on writing *) 45 | | WRITING_ERROR (** An error occurred, stop writing *) 46 | 47 | type 'a lua_Writer = state -> string -> 'a -> writer_status 48 | 49 | let thread_status_of_int = function 50 | | 0 -> LUA_OK 51 | | 1 -> LUA_YIELD 52 | | 2 -> LUA_ERRRUN 53 | | 3 -> LUA_ERRSYNTAX 54 | | 4 -> LUA_ERRMEM 55 | | 5 -> LUA_ERRERR 56 | | 6 -> LUA_ERRFILE 57 | | _ -> failwith "thread_status_of_int: unknown status value" 58 | 59 | let int_of_thread_status = function 60 | | LUA_OK -> 0 61 | | LUA_YIELD -> 1 62 | | LUA_ERRRUN -> 2 63 | | LUA_ERRSYNTAX -> 3 64 | | LUA_ERRMEM -> 4 65 | | LUA_ERRERR -> 5 66 | | LUA_ERRFILE -> 6 67 | 68 | let int_of_gc_command = function 69 | | GCSTOP -> 0 70 | | GCRESTART -> 1 71 | | GCCOLLECT -> 2 72 | | GCCOUNT -> 3 73 | | GCCOUNTB -> 4 74 | | GCSTEP -> 5 75 | | GCSETPAUSE -> 6 76 | | GCSETSTEPMUL -> 7 77 | 78 | let lua_type_of_int = function 79 | | -1 -> LUA_TNONE 80 | | 0 -> LUA_TNIL 81 | | 1 -> LUA_TBOOLEAN 82 | | 2 -> LUA_TLIGHTUSERDATA 83 | | 3 -> LUA_TNUMBER 84 | | 4 -> LUA_TSTRING 85 | | 5 -> LUA_TTABLE 86 | | 6 -> LUA_TFUNCTION 87 | | 7 -> LUA_TUSERDATA 88 | | 8 -> LUA_TTHREAD 89 | | _ -> failwith "lua_type_of_int: unknown type" 90 | 91 | let int_of_lua_type = function 92 | | LUA_TNONE -> -1 93 | | LUA_TNIL -> 0 94 | | LUA_TBOOLEAN -> 1 95 | | LUA_TLIGHTUSERDATA -> 2 96 | | LUA_TNUMBER -> 3 97 | | LUA_TSTRING -> 4 98 | | LUA_TTABLE -> 5 99 | | LUA_TFUNCTION -> 6 100 | | LUA_TUSERDATA -> 7 101 | | LUA_TTHREAD -> 8 102 | 103 | let multret = -1 104 | let registryindex = -10000 105 | let environindex = -10001 106 | let globalsindex = -10002 107 | 108 | 109 | (**************) 110 | (* EXCEPTIONS *) 111 | (**************) 112 | exception Error of thread_status 113 | exception Type_error of string 114 | exception Not_a_C_function 115 | exception Not_a_Lua_thread 116 | exception Not_a_block_value 117 | 118 | 119 | (*************) 120 | (* FUNCTIONS *) 121 | (*************) 122 | external tolstring__wrapper : state -> int -> string = "lua_tolstring__stub" 123 | (** Raises [Type_error] *) 124 | 125 | let tolstring ls index = 126 | try Some (tolstring__wrapper ls index) 127 | with Type_error _ -> None 128 | 129 | let tostring = tolstring 130 | 131 | external pushlstring : state -> string -> unit = "lua_pushlstring__stub" 132 | 133 | let pushstring = pushlstring 134 | 135 | (* This is the "porting" of the standard panic function from Lua source: 136 | lua-5.1.5/src/lauxlib.c line 639 *) 137 | let default_panic (ls : state) = 138 | let msg = tostring ls (-1) in 139 | let () = 140 | match msg with 141 | | Some msg -> Printf.fprintf stderr "PANIC: unprotected error in call to Lua API (%s)\n%!" msg; 142 | | None -> failwith "default_panic: impossible pattern: this error shoud never be raised" in 143 | 0 144 | 145 | external atpanic : state -> oCamlFunction -> oCamlFunction = "lua_atpanic__stub" 146 | 147 | external call : state -> int -> int -> unit = "lua_call__stub" 148 | 149 | external checkstack : state -> int -> bool = "lua_checkstack__stub" 150 | 151 | external concat : state -> int -> unit = "lua_concat__stub" 152 | 153 | external pushcfunction : state -> oCamlFunction -> unit = "lua_pushcfunction__stub" 154 | 155 | external pushlightuserdata : state -> 'a -> unit = "lua_pushlightuserdata__stub" 156 | 157 | external lua_pcall__wrapper : state -> int -> int -> int -> int = "lua_pcall__stub" 158 | 159 | let pcall ls nargs nresults errfunc = 160 | lua_pcall__wrapper ls nargs nresults errfunc |> thread_status_of_int 161 | 162 | exception Memory_allocation_error 163 | 164 | let cpcall ls func ud = 165 | let cpcall_panic (_ls : state) : int = raise Memory_allocation_error in 166 | let old_panic = atpanic ls cpcall_panic in 167 | try 168 | match checkstack ls 2 with (* ALLOCATES MEMORY, COULD FAIL! *) 169 | | true -> begin 170 | pushcfunction ls func; 171 | pushlightuserdata ls ud; (* ALLOCATES MEMORY, COULD FAIL! *) 172 | let _unused = atpanic ls old_panic in 173 | pcall ls 1 0 0 174 | end 175 | | false -> 176 | let _unused = atpanic ls old_panic in 177 | LUA_ERRMEM 178 | with 179 | | Memory_allocation_error -> 180 | let _unused = atpanic ls old_panic in 181 | LUA_ERRMEM 182 | | e -> 183 | let _unused = atpanic ls old_panic in 184 | raise e 185 | 186 | external createtable : state -> int -> int -> unit = "lua_createtable__stub" 187 | 188 | external dump : state -> 'a lua_Writer -> 'a -> writer_status = "lua_dump__stub" 189 | 190 | external equal : state -> int -> int -> bool = "lua_equal__stub" 191 | 192 | external error : state -> 'a = "lua_error__stub" 193 | 194 | external gc_wrapper : state -> int -> int -> int = "lua_gc__stub" 195 | let gc ls what data = 196 | let what = int_of_gc_command what in 197 | gc_wrapper ls what data 198 | 199 | external getfenv : state -> int -> unit = "lua_getfenv__stub" 200 | 201 | external getfield : state -> int -> string -> unit = "lua_getfield__stub" 202 | 203 | let getglobal ls name = getfield ls globalsindex name 204 | 205 | external getmetatable : state -> int -> bool = "lua_getmetatable__stub" 206 | 207 | external gettable : state -> int -> unit = "lua_gettable__stub" 208 | 209 | external gettop : state -> int = "lua_gettop__stub" 210 | 211 | external insert : state -> int -> unit = "lua_insert__stub" 212 | 213 | external isboolean : state -> int -> bool = "lua_isboolean__stub" 214 | 215 | external iscfunction : state -> int -> bool = "lua_iscfunction__stub" 216 | 217 | external isfunction : state -> int -> bool = "lua_isfunction__stub" 218 | 219 | external islightuserdata : state -> int -> bool = "lua_islightuserdata__stub" 220 | 221 | external isnil : state -> int -> bool = "lua_isnil__stub" 222 | 223 | external isnone : state -> int -> bool = "lua_isnone__stub" 224 | 225 | external isnoneornil : state -> int -> bool = "lua_isnoneornil__stub" 226 | 227 | external isnumber : state -> int -> bool = "lua_isnumber__stub" 228 | 229 | external isstring : state -> int -> bool = "lua_isstring__stub" 230 | 231 | external istable : state -> int -> bool = "lua_istable__stub" 232 | 233 | external isthread : state -> int -> bool = "lua_isthread__stub" 234 | 235 | external isuserdata : state -> int -> bool = "lua_isuserdata__stub" 236 | 237 | external lessthan : state -> int -> int -> bool = "lua_lessthan__stub" 238 | 239 | external lua_load__wrapper : state -> 'a lua_Reader -> 'a -> string -> int = "lua_load__stub" 240 | 241 | let load ls reader data chunkname = 242 | lua_load__wrapper ls reader data chunkname |> thread_status_of_int 243 | 244 | external newtable: state -> unit = "lua_newtable__stub" 245 | 246 | external newthread : state -> state = "lua_newthread__stub" 247 | 248 | external default_gc : state -> int = "default_gc__stub" 249 | 250 | let make_gc_function user_gc_function = 251 | let new_gc ls = 252 | let res = user_gc_function ls in 253 | let _ = default_gc ls in 254 | res in 255 | new_gc 256 | 257 | external newuserdata : state -> 'a -> unit = "lua_newuserdata__stub" 258 | 259 | external next : state -> int -> int = "lua_next__stub" 260 | 261 | external objlen : state -> int -> int = "lua_objlen__stub" 262 | 263 | external pop : state -> int -> unit = "lua_pop__stub" 264 | 265 | external pushboolean : state -> bool -> unit = "lua_pushboolean__stub" 266 | 267 | let pushocamlfunction = pushcfunction 268 | 269 | let pushfstring (state : state) = 270 | let k s = pushstring state s; s in 271 | Printf.ksprintf k 272 | 273 | external pushinteger : state -> int -> unit = "lua_pushinteger__stub" 274 | 275 | external pushliteral : state -> string -> unit = "lua_pushlstring__stub" 276 | 277 | external pushnil : state -> unit = "lua_pushnil__stub" 278 | 279 | external pushnumber : state -> float -> unit = "lua_pushnumber__stub" 280 | 281 | external pushthread : state -> bool = "lua_pushthread__stub" 282 | 283 | external pushvalue : state -> int -> unit = "lua_pushvalue__stub" 284 | 285 | let pushvfstring = pushfstring 286 | 287 | external rawequal : state -> int -> int -> bool = "lua_rawequal__stub" 288 | 289 | external rawget : state -> int -> unit = "lua_rawget__stub" 290 | 291 | external rawgeti : state -> int -> int -> unit = "lua_rawgeti__stub" 292 | 293 | external rawset : state -> int -> unit = "lua_rawset__stub" 294 | 295 | external rawseti : state -> int -> int -> unit = "lua_rawseti__stub" 296 | 297 | external setglobal : state -> string -> unit = "lua_setglobal__stub" 298 | 299 | let register ls name f = 300 | pushcfunction ls f; 301 | setglobal ls name 302 | 303 | external remove : state -> int -> unit = "lua_remove__stub" 304 | 305 | external replace : state -> int -> unit = "lua_replace__stub" 306 | 307 | external lua_resume__wrapper : state -> int -> int = "lua_resume__stub" 308 | 309 | let resume ls narg = 310 | lua_resume__wrapper ls narg |> thread_status_of_int 311 | 312 | external setfenv : state -> int -> bool = "lua_setfenv__stub" 313 | 314 | external setfield : state -> int -> string -> unit = "lua_setfield__stub" 315 | 316 | external setmetatable : state -> int -> int = "lua_setmetatable__stub" 317 | 318 | external settable : state -> int -> unit = "lua_settable__stub" 319 | 320 | external settop : state -> int -> unit = "lua_settop__stub" 321 | 322 | external status_aux : state -> int = "lua_status__stub" 323 | 324 | let status ls = ls |> status_aux |> thread_status_of_int 325 | 326 | external toboolean : state -> int -> bool = "lua_toboolean__stub" 327 | 328 | external tocfunction_aux : state -> int -> oCamlFunction = "lua_tocfunction__stub" 329 | 330 | let tocfunction ls index = 331 | try Some (tocfunction_aux ls index) 332 | with Not_a_C_function -> None 333 | 334 | let toocamlfunction = tocfunction 335 | 336 | external tointeger : state -> int -> int = "lua_tointeger__stub" 337 | 338 | external tonumber : state -> int -> float = "lua_tonumber__stub" 339 | 340 | external tothread_aux : state -> int -> state = "lua_tothread__stub" 341 | 342 | let tothread ls index = 343 | try Some (tothread_aux ls index) 344 | with Not_a_Lua_thread -> None 345 | 346 | external touserdata_aux : state -> int -> 'a = "lua_touserdata__stub" 347 | 348 | let touserdata ls index = 349 | if islightuserdata ls index then (Some (`Light_userdata (touserdata_aux ls index))) 350 | else if isuserdata ls index then (Some (`Userdata (touserdata_aux ls index))) 351 | else None 352 | 353 | external lua_type_wrapper : state -> int -> int = "lua_type__stub" 354 | 355 | let type_ state index = 356 | lua_type_wrapper state index |> lua_type_of_int 357 | 358 | let typename _ = function 359 | | LUA_TNONE -> "no value" 360 | | LUA_TNIL -> "nil" 361 | | LUA_TBOOLEAN -> "boolean" 362 | | LUA_TLIGHTUSERDATA -> "userdata" 363 | | LUA_TNUMBER -> "number" 364 | | LUA_TSTRING -> "string" 365 | | LUA_TTABLE -> "table" 366 | | LUA_TFUNCTION -> "function" 367 | | LUA_TUSERDATA -> "userdata" 368 | | LUA_TTHREAD -> "thread" 369 | 370 | external xmove : state -> state -> int -> unit = "lua_xmove__stub" 371 | 372 | external yield : state -> int -> int = "lua_yield__stub" 373 | 374 | let init = 375 | lazy ( 376 | Callback.register_exception "Lua_type_error" (Type_error ""); 377 | Callback.register_exception "Not_a_C_function" Not_a_C_function; 378 | Callback.register_exception "Not_a_Lua_thread" Not_a_Lua_thread; 379 | Callback.register_exception "Not_a_block_value" Not_a_block_value; 380 | Callback.register "default_panic" default_panic; 381 | ) 382 | ;; 383 | -------------------------------------------------------------------------------- /src/lua_api_lib.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************) 2 | (** {1 The Lua Application Program Interface (OCaml binding)} *) 3 | (**************************************************************) 4 | 5 | (*********************************************) 6 | (** {2 Difference with the original Lua API} *) 7 | (*********************************************) 8 | 9 | (** Here is a list of functions of which you should read documentation: 10 | - {b Missing functions}: [lua_close], [lua_getallocf], [lua_newstate] 11 | (see below {{:#VALload}here}), [lua_pushcclosure] (see below {{:#VALpushboolean}here}), 12 | [lua_setallocf], [lua_topointer]. 13 | - {b Notably different functions}: {!newuserdata}, {!pushfstring}, {!pushlightuserdata}, 14 | {!touserdata} 15 | - {b Special remarks}: {!cpcall}, {!newthread}, {!default_gc}, {!make_gc_function}. 16 | {!tolstring} 17 | *) 18 | 19 | (**************************) 20 | (** {2 Types definitions} *) 21 | (**************************) 22 | 23 | (** See {{:http://www.lua.org/manual/5.1/manual.html#lua_State}lua_State} 24 | documentation. *) 25 | type state 26 | 27 | (** This type corresponds to lua_CFunction. See 28 | {{:http://www.lua.org/manual/5.1/manual.html#lua_CFunction}lua_CFunction} 29 | documentation. *) 30 | type oCamlFunction = state -> int 31 | 32 | (** See {{:http://www.lua.org/manual/5.1/manual.html#pdf-LUA_YIELD}lua_status} 33 | documentation. *) 34 | type thread_status = 35 | | LUA_OK 36 | | LUA_YIELD 37 | | LUA_ERRRUN 38 | | LUA_ERRSYNTAX 39 | | LUA_ERRMEM 40 | | LUA_ERRERR 41 | | LUA_ERRFILE 42 | 43 | (** This type is not present in the official API and is used by the function 44 | [gc] *) 45 | type gc_command = 46 | | GCSTOP 47 | | GCRESTART 48 | | GCCOLLECT 49 | | GCCOUNT 50 | | GCCOUNTB 51 | | GCSTEP 52 | | GCSETPAUSE 53 | | GCSETSTEPMUL 54 | 55 | (** This type is a collection of the possible types of a Lua value, as defined 56 | by the macros in lua.h. As a reference, see the documentation of the 57 | {{:http://www.lua.org/manual/5.1/manual.html#lua_type}lua_type function}, 58 | and the corresponding OCaml {!Lua_api_lib.type_}. *) 59 | type lua_type = 60 | | LUA_TNONE 61 | | LUA_TNIL 62 | | LUA_TBOOLEAN 63 | | LUA_TLIGHTUSERDATA 64 | | LUA_TNUMBER 65 | | LUA_TSTRING 66 | | LUA_TTABLE 67 | | LUA_TFUNCTION 68 | | LUA_TUSERDATA 69 | | LUA_TTHREAD 70 | 71 | (** See 72 | {{:http://www.lua.org/manual/5.1/manual.html#lua_Reader}lua_Reader} 73 | documentation. *) 74 | type 'a lua_Reader = state -> 'a -> string option 75 | 76 | type writer_status = 77 | | NO_WRITING_ERROR (** No errors, go on writing *) 78 | | WRITING_ERROR (** An error occurred, stop writing *) 79 | 80 | (** See 81 | {{:http://www.lua.org/manual/5.1/manual.html#lua_Writer}lua_Writer} 82 | documentation. *) 83 | type 'a lua_Writer = state -> string -> 'a -> writer_status 84 | 85 | (************************) 86 | (** {2 Constant values} *) 87 | (************************) 88 | 89 | val multret : int 90 | (** Option for multiple returns in `Lua.pcall' and `Lua.call'. 91 | See {{:http://www.lua.org/manual/5.1/manual.html#lua_call}lua_call} 92 | documentation. *) 93 | 94 | val registryindex : int 95 | (** Pseudo-index to access the registry. 96 | See {{:http://www.lua.org/manual/5.1/manual.html#3.5}Registry} documentation. *) 97 | 98 | val environindex : int 99 | (** Pseudo-index to access the environment of the running C function. 100 | See {{:http://www.lua.org/manual/5.1/manual.html#3.3}Registry} documentation. *) 101 | 102 | val globalsindex : int 103 | (** Pseudo-index to access the thread environment (where global variables live). 104 | See {{:http://www.lua.org/manual/5.1/manual.html#3.3}Registry} documentation. *) 105 | 106 | 107 | (*******************) 108 | (** {2 Exceptions} *) 109 | (*******************) 110 | 111 | exception Error of thread_status 112 | exception Type_error of string 113 | 114 | (*********************************************) 115 | (** {2 Functions not present in the Lua API} *) 116 | (*********************************************) 117 | 118 | val thread_status_of_int : int -> thread_status 119 | (** Convert an integer into a [thread_status]. Raises [failure] on 120 | invalid parameter. *) 121 | 122 | val int_of_thread_status : thread_status -> int 123 | (** Convert a [thread_status] into an integer. *) 124 | 125 | val lua_type_of_int : int -> lua_type 126 | (** Convert an integer into a [lua_type]. Raises [failure] on 127 | invalid parameter. *) 128 | 129 | val int_of_lua_type : lua_type -> int 130 | (** Convert a [lua_type] into an integer. *) 131 | 132 | (**************************) 133 | (** {2 Lua API functions} *) 134 | (**************************) 135 | 136 | external atpanic : state -> oCamlFunction -> oCamlFunction = "lua_atpanic__stub" 137 | (** See {{:http://www.lua.org/manual/5.1/manual.html#lua_atpanic}lua_atpanic} 138 | documentation. *) 139 | 140 | external call : state -> int -> int -> unit = "lua_call__stub" 141 | (** See {{:http://www.lua.org/manual/5.1/manual.html#lua_call}lua_call} 142 | documentation. *) 143 | 144 | external checkstack : state -> int -> bool = "lua_checkstack__stub" 145 | (** See {{:http://www.lua.org/manual/5.1/manual.html#lua_checkstack}lua_checkstack} 146 | documentation. *) 147 | 148 | (** The function 149 | {{:http://www.lua.org/manual/5.1/manual.html#lua_close}lua_close} is not 150 | present because all the data structures of a Lua state are managed by the 151 | OCaml garbage collector. *) 152 | 153 | external concat : state -> int -> unit = "lua_concat__stub" 154 | (** See {{:http://www.lua.org/manual/5.1/manual.html#lua_concat}lua_concat} 155 | documentation. *) 156 | 157 | val cpcall : state -> oCamlFunction -> 'a -> thread_status 158 | (** See 159 | {{:http://www.lua.org/manual/5.1/manual.html#lua_cpcall}lua_cpcall} 160 | documentation. 161 | 162 | {b NOTE}: this function is {b not} a binding of the original lua_cpcall, 163 | it's rather an OCaml function with the same semantics. 164 | 165 | {b WARNING}: the OCaml function you want to execute in a protected 166 | environment is actually protected againt {b Lua} errors, even memory errors, 167 | but {b not} against OCaml errors, i.e. exceptions. If for example you run: 168 | {[ 169 | let ls = LuaL.newstate ();; 170 | let my_func ls = failwith "Sorry, my fault..."; 0;; 171 | let cpcall_result = Lua.cpcall ls my_func 42;; 172 | ]} 173 | cpcall {b will actually raise} a failure, because that exception is not 174 | generated by Lua but by OCaml. 175 | *) 176 | 177 | external createtable : state -> int -> int -> unit = "lua_createtable__stub" 178 | (** See 179 | {{:http://www.lua.org/manual/5.1/manual.html#lua_createtable}lua_createtable} 180 | documentation. *) 181 | 182 | val dump : state -> 'a lua_Writer -> 'a -> writer_status 183 | (** See 184 | {{:http://www.lua.org/manual/5.1/manual.html#lua_dump}lua_dump} 185 | documentation. *) 186 | 187 | external equal : state -> int -> int -> bool = "lua_equal__stub" 188 | (** See 189 | {{:http://www.lua.org/manual/5.1/manual.html#lua_equal}lua_equal} 190 | documentation. *) 191 | 192 | external error : state -> 'a = "lua_error__stub" 193 | (** See 194 | {{:http://www.lua.org/manual/5.1/manual.html#lua_error}lua_error} 195 | documentation. *) 196 | 197 | val gc : state -> gc_command -> int -> int 198 | (** See 199 | {{:http://www.lua.org/manual/5.1/manual.html#lua_gc}lua_gc} 200 | documentation. *) 201 | 202 | (** {{:http://www.lua.org/manual/5.1/manual.html#lua_getallocf}lua_getallocf} 203 | not implemented in this binding *) 204 | 205 | external getfenv : state -> int -> unit = "lua_getfenv__stub" 206 | (** See 207 | {{:http://www.lua.org/manual/5.1/manual.html#lua_getfenv}lua_getfenv} 208 | documentation. *) 209 | 210 | external getfield : state -> int -> string -> unit = "lua_getfield__stub" 211 | (** See 212 | {{:http://www.lua.org/manual/5.1/manual.html#lua_getfield}lua_getfield} 213 | documentation. *) 214 | 215 | val getglobal : state -> string -> unit 216 | (** See 217 | {{:http://www.lua.org/manual/5.1/manual.html#lua_getglobal}lua_getglobal} 218 | documentation. Like in the original Lua source code this function is 219 | implemented in OCaml using [getfield]. *) 220 | 221 | external getmetatable : state -> int -> bool = "lua_getmetatable__stub" 222 | (** See 223 | {{:http://www.lua.org/manual/5.1/manual.html#lua_getmetatable}lua_getmetatable} 224 | documentation. *) 225 | 226 | external gettable : state -> int -> unit = "lua_gettable__stub" 227 | (** See 228 | {{:http://www.lua.org/manual/5.1/manual.html#lua_gettable}lua_gettable} 229 | documentation. *) 230 | 231 | external gettop : state -> int = "lua_gettop__stub" 232 | (** See 233 | {{:http://www.lua.org/manual/5.1/manual.html#lua_gettop}lua_gettop} 234 | documentation. *) 235 | 236 | external insert : state -> int -> unit = "lua_insert__stub" 237 | (** See 238 | {{:http://www.lua.org/manual/5.1/manual.html#lua_insert}lua_insert} 239 | documentation. *) 240 | 241 | external isboolean : state -> int -> bool = "lua_isboolean__stub" 242 | (** See 243 | {{:http://www.lua.org/manual/5.1/manual.html#lua_isboolean}lua_isboolean} 244 | documentation. *) 245 | 246 | external iscfunction : state -> int -> bool = "lua_iscfunction__stub" 247 | (** See 248 | {{:http://www.lua.org/manual/5.1/manual.html#lua_iscfunction}lua_iscfunction} 249 | documentation. *) 250 | 251 | external isfunction : state -> int -> bool = "lua_isfunction__stub" 252 | (** See 253 | {{:http://www.lua.org/manual/5.1/manual.html#lua_isfunction}lua_isfunction} 254 | documentation. *) 255 | 256 | external islightuserdata : state -> int -> bool = "lua_islightuserdata__stub" 257 | (** See 258 | {{:http://www.lua.org/manual/5.1/manual.html#lua_islightuserdata}lua_islightuserdata} 259 | documentation. *) 260 | 261 | external isnil : state -> int -> bool = "lua_isnil__stub" 262 | (** See 263 | {{:http://www.lua.org/manual/5.1/manual.html#lua_isnil}lua_isnil} 264 | documentation. *) 265 | 266 | external isnone : state -> int -> bool = "lua_isnone__stub" 267 | (** See 268 | {{:http://www.lua.org/manual/5.1/manual.html#lua_isnone}lua_isnone} 269 | documentation. *) 270 | 271 | external isnoneornil : state -> int -> bool = "lua_isnoneornil__stub" 272 | (** See 273 | {{:http://www.lua.org/manual/5.1/manual.html#lua_isnoneornil}lua_isnoneornil} 274 | documentation. *) 275 | 276 | external isnumber : state -> int -> bool = "lua_isnumber__stub" 277 | (** See 278 | {{:http://www.lua.org/manual/5.1/manual.html#lua_isnumber}lua_isnumber} 279 | documentation. *) 280 | 281 | external isstring : state -> int -> bool = "lua_isstring__stub" 282 | (** See 283 | {{:http://www.lua.org/manual/5.1/manual.html#lua_isstring}lua_isstring} 284 | documentation. *) 285 | 286 | external istable : state -> int -> bool = "lua_istable__stub" 287 | (** See 288 | {{:http://www.lua.org/manual/5.1/manual.html#lua_istable}lua_istable} 289 | documentation. *) 290 | 291 | external isthread : state -> int -> bool = "lua_isthread__stub" 292 | (** See 293 | {{:http://www.lua.org/manual/5.1/manual.html#lua_isthread}lua_isthread} 294 | documentation. *) 295 | 296 | external isuserdata : state -> int -> bool = "lua_isuserdata__stub" 297 | (** See 298 | {{:http://www.lua.org/manual/5.1/manual.html#lua_isuserdata}lua_isuserdata} 299 | documentation. *) 300 | 301 | external lessthan : state -> int -> int -> bool = "lua_lessthan__stub" 302 | (** See 303 | {{:http://www.lua.org/manual/5.1/manual.html#lua_lessthan}lua_lessthan} 304 | documentation. *) 305 | 306 | val load : state -> 'a lua_Reader -> 'a -> string -> thread_status 307 | (** See 308 | {{:http://www.lua.org/manual/5.1/manual.html#lua_load}lua_load} 309 | documentation. *) 310 | 311 | (** The function 312 | {{:http://www.lua.org/manual/5.1/manual.html#lua_newstate}lua_newstate} is 313 | not present because it makes very little sense to specify a custom allocator 314 | written in OCaml. To create a new Lua state, use the function 315 | {!Lua_aux_lib.newstate}. *) 316 | 317 | external newtable: state -> unit = "lua_newtable__stub" 318 | (** See 319 | {{:http://www.lua.org/manual/5.1/manual.html#lua_newtable}lua_newtable} 320 | documentation. *) 321 | 322 | val newthread : state -> state 323 | (** See 324 | {{:http://www.lua.org/manual/5.1/manual.html#lua_newthread}lua_newthread} 325 | documentation. 326 | 327 | When you create a new thread, this binding guaranties that the Lua object 328 | will remain "living" (protected from both the Lua and the OCaml garbage 329 | collectors) until a valid copy exists in at least one of the two contexts. 330 | 331 | Remember that all the threads obtained by [newthread] and 332 | {!Lua_api_lib.tothread} are shared copies, for example: 333 | {[ 334 | let state = LuaL.newstate ();; 335 | let th = Lua.newthread state;; 336 | let th' = match Lua.tothread state 1 with Some s -> s | None -> failwith "not an option!";; 337 | Lua.settop state 0;; 338 | ]} 339 | Now the stack of [state] is empty and you have two threads, [th] and [th'], 340 | but they are actually the {e very same data structure} and operations performed 341 | on the first will be visible on the second! 342 | 343 | Another important issue regarding the scope of a state object representing a 344 | thread (coroutine): this binding don't prevent you from accessing invalid 345 | memory in case of misuse of the library. Please, carefully consider this 346 | fragment: 347 | {[ 348 | let f () = 349 | let state = LuaL.newstate () in 350 | let th = Lua.newthread state in 351 | th;; 352 | 353 | let th' = f ();; 354 | Gc.compact ();; (* This will collect [state] inside [f] *) 355 | (* Here something using [th'] *) 356 | ]} 357 | After [Gc.compact] the value inside [th'] has lost any possible meaning, 358 | because it's a thread (a coroutine) of a state object that has been already 359 | collected. Using [th'] will lead to a {e segmentation fault}, at best, and 360 | to an {e undefined behaviour} if you are unlucky. *) 361 | 362 | external default_gc : state -> int = "default_gc__stub" 363 | (** This is the default "__gc" function attached to any new userdatum created 364 | with [newuserdata]. See documentation of {! newuserdata} below. *) 365 | 366 | val make_gc_function : oCamlFunction -> oCamlFunction 367 | (** This function takes an {! oCamlFunction} you have created to be executed 368 | as "__gc" metamethod and "decorates" it with some default actions needed 369 | to deallocate all the memory. 370 | 371 | If you want to create a "__gc" method for your userdata, you {b must} register 372 | the value from [make_gc_function]. *) 373 | 374 | external newuserdata : state -> 'a -> unit = "lua_newuserdata__stub" 375 | (** [newuserdata] is the binding of 376 | {{:http://www.lua.org/manual/5.1/manual.html#lua_newuserdata}lua_newuserdata} 377 | but it works in a different way if compared to the original function, and the 378 | signature is slightly different. 379 | 380 | In C [lua_newuserdata] allocates an area for you, returns a [void*] and you 381 | cast it as needed. Moreover, it pushes the new userdata on the stack. 382 | 383 | In OCaml, however, you never allocates a value and so the resulting signature 384 | provides you a way to push an already created value on the top of the Lua stack. 385 | 386 | {b Very important remark, read carefully.} The original Lua [lua_newuserdata] 387 | doesn't associate to the new userdatum any metatable, it's up to you to define 388 | a metatable with metamethods, if you need it. On the other hand, this binding 389 | {b silently} creates a metatable with only one metamethod ("__gc") and associates 390 | the function {! default_gc } defined above. This function takes care of managing 391 | the memory between the two garbage collectors when needed. This is transparent 392 | to you, unless you want to attach to the userdatum a metatable of your, which is 393 | very likely to happen. 394 | 395 | In case you want to attach a metatable to your userdatum you {b must} include 396 | the "__gc" metamethod, and you {b must} create the function using 397 | {! make_gc_function } described above.If you want a metatable for your 398 | userdatum but you don't need a "__gc", use in any case the {! default_gc }. 399 | {b Don't create a userdatum with a metatable and without "__gc" or your 400 | program will leak memory!} 401 | 402 | {b WARNING}: using this function could be harmful because it actually breaks 403 | the type system. It has the same semantics of [Obj.magic], allowing the 404 | programmer to push an OCaml value into the Lua state, and then retrieve it 405 | with a different type. Be very careful! *) 406 | 407 | external next : state -> int -> int = "lua_next__stub" 408 | (** See 409 | {{:http://www.lua.org/manual/5.1/manual.html#lua_next}lua_next} 410 | documentation. *) 411 | 412 | external objlen : state -> int -> int = "lua_objlen__stub" 413 | (** See 414 | {{:http://www.lua.org/manual/5.1/manual.html#lua_objlen}lua_objlen} 415 | documentation. *) 416 | 417 | val pcall : state -> int -> int -> int -> thread_status 418 | (** See 419 | {{:http://www.lua.org/manual/5.1/manual.html#lua_pcall}lua_pcall} 420 | documentation. *) 421 | 422 | external pop : state -> int -> unit = "lua_pop__stub" 423 | (** See 424 | {{:http://www.lua.org/manual/5.1/manual.html#lua_pop}lua_pop} 425 | documentation. *) 426 | 427 | external pushboolean : state -> bool -> unit = "lua_pushboolean__stub" 428 | (** See 429 | {{:http://www.lua.org/manual/5.1/manual.html#lua_pushboolean}lua_pushboolean} 430 | documentation. *) 431 | 432 | (** The function 433 | {{:http://www.lua.org/manual/5.1/manual.html#lua_pushcclosure}lua_pushcclosure} 434 | is not present because it makes very little sense to specify a "closure" 435 | written in OCaml, using the Lua 436 | {{:http://www.lua.org/pil/27.3.3.html}upvalues} machinery. Use instead 437 | {!Lua_api_lib.pushcfunction} *) 438 | 439 | external pushcfunction : state -> oCamlFunction -> unit = "lua_pushcfunction__stub" 440 | (** See 441 | {{:http://www.lua.org/manual/5.1/manual.html#lua_pushcfunction}lua_pushcfunction} 442 | documentation. *) 443 | 444 | val pushocamlfunction : state -> oCamlFunction -> unit 445 | (** Alias of {!Lua_api_lib.pushcfunction} *) 446 | 447 | val pushfstring : state -> ('a, unit, string, string) format4 -> 'a 448 | (** Pushes onto the stack a formatted string and returns the string itself. 449 | It is similar to the standard library function sprintf. 450 | 451 | Warning: this function has a different behavior with respect to the original 452 | {{:http://www.lua.org/manual/5.1/manual.html#lua_pushfstring}lua_pushfstring} 453 | because the conversion specifiers are not restricted as specified in the Lua 454 | documentation, but you can use all the conversions of the 455 | {{:http://caml.inria.fr/pub/docs/manual-ocaml/libref/Printf.html}Printf module}. *) 456 | 457 | external pushinteger : state -> int -> unit = "lua_pushinteger__stub" 458 | (** See 459 | {{:http://www.lua.org/manual/5.1/manual.html#lua_pushinteger}lua_pushinteger} 460 | documentation. *) 461 | 462 | val pushlightuserdata : state -> 'a -> unit 463 | (** See 464 | {{:http://www.lua.org/manual/5.1/manual.html#lua_pushlightuserdata}lua_pushlightuserdata} 465 | documentation. Raises [Not_a_block_value] if you try to push a non-block value 466 | (e.g. an immediate integer) as a light userdata. 467 | 468 | In Lua a light userdata is a way to store inside the Lua state a C pointer. 469 | It's up the programmer to carefully check for the lifetime of the data 470 | structures passed to Lua via a light userdata. If you malloc a pointer and 471 | pass it to Lua, then you free it from C and then you retrieve the same pointer 472 | from Lua (using lua_touserdata), you are most probably shooting yourself 473 | in the foot. 474 | 475 | To avoid this class of problems I decided to implement some logic in the binding 476 | of this function. When you push an OCaml value as a Lua light userdata, a 477 | global reference to that (OCaml) value is kept inside the Lua state L. So, if 478 | the original value goes out of scope it is {e not} collected by the garbage 479 | collector. In this scenario: 480 | {[ 481 | let push_something state = 482 | let ocaml_value = get_some_complex_value () in 483 | pushlightuserdata state ocaml_value; 484 | state 485 | ;; 486 | ]} 487 | when the [push_something] function returns the Lua state, the [ocaml_value] 488 | is {e not} collected and can be retrieved at a later time from [state]. 489 | 490 | This behaviour has a major drawback: while ensuring the lifetime of objects, 491 | it wastes memory. All the OCaml values pushed as light userdata will in fact 492 | be collected when the garbage collector decide to collect the Lua state itself. 493 | This means that if you have a long running task (e.g. a server) with a Lua 494 | state and you use [pushlightuserdata], the values pushed will be {e never} 495 | collected! 496 | 497 | Moreover, if you push a value that have some resources associated with it 498 | (e.g. a channel, a socket or a DB handler) the resources will be released 499 | only when the Lua state goes out of scope. *) 500 | 501 | external pushliteral : state -> string -> unit = "lua_pushlstring__stub" 502 | (** See 503 | {{:http://www.lua.org/manual/5.1/manual.html#lua_pushliteral}lua_pushliteral} 504 | documentation. *) 505 | 506 | external pushlstring : state -> string -> unit = "lua_pushlstring__stub" 507 | (** See 508 | {{:http://www.lua.org/manual/5.1/manual.html#lua_pushlstring}lua_pushlstring} 509 | documentation. *) 510 | 511 | external pushnil : state -> unit = "lua_pushnil__stub" 512 | (** See 513 | {{:http://www.lua.org/manual/5.1/manual.html#lua_pushnil}lua_pushnil} 514 | documentation. *) 515 | 516 | external pushnumber : state -> float -> unit = "lua_pushnumber__stub" 517 | (** See 518 | {{:http://www.lua.org/manual/5.1/manual.html#lua_pushnumber}lua_pushnumber} 519 | documentation. *) 520 | 521 | val pushstring : state -> string -> unit 522 | (** See 523 | {{:http://www.lua.org/manual/5.1/manual.html#lua_pushstring}lua_pushstring} 524 | documentation. *) 525 | 526 | val pushthread : state -> bool 527 | (** See 528 | {{:http://www.lua.org/manual/5.1/manual.html#lua_pushthread}lua_pushthread} 529 | documentation. *) 530 | 531 | external pushvalue : state -> int -> unit = "lua_pushvalue__stub" 532 | (** See 533 | {{:http://www.lua.org/manual/5.1/manual.html#lua_pushvalue}lua_pushvalue} 534 | documentation. *) 535 | 536 | val pushvfstring : state -> ('a, unit, string, string) format4 -> 'a 537 | (** Alias of {!Lua_api_lib.pushfstring} *) 538 | 539 | external rawequal : state -> int -> int -> bool = "lua_rawequal__stub" 540 | (** See 541 | {{:http://www.lua.org/manual/5.1/manual.html#lua_rawequal}lua_rawequal} 542 | documentation. *) 543 | 544 | external rawget : state -> int -> unit = "lua_rawget__stub" 545 | (** See 546 | {{:http://www.lua.org/manual/5.1/manual.html#lua_rawget}lua_rawget} 547 | documentation. *) 548 | 549 | external rawgeti : state -> int -> int -> unit = "lua_rawgeti__stub" 550 | (** See 551 | {{:http://www.lua.org/manual/5.1/manual.html#lua_rawgeti}lua_rawgeti} 552 | documentation. *) 553 | 554 | external rawset : state -> int -> unit = "lua_rawset__stub" 555 | (** See 556 | {{:http://www.lua.org/manual/5.1/manual.html#lua_rawset}lua_rawset} 557 | documentation. *) 558 | 559 | external rawseti : state -> int -> int -> unit = "lua_rawseti__stub" 560 | (** See 561 | {{:http://www.lua.org/manual/5.1/manual.html#lua_rawseti}lua_rawseti} 562 | documentation. *) 563 | 564 | val register : state -> string -> oCamlFunction -> unit 565 | (** See 566 | {{:http://www.lua.org/manual/5.1/manual.html#lua_register}lua_register} 567 | documentation. The function is implemented in OCaml using pushcfunction 568 | and setglobal. *) 569 | 570 | external remove : state -> int -> unit = "lua_remove__stub" 571 | (** See 572 | {{:http://www.lua.org/manual/5.1/manual.html#lua_remove}lua_remove} 573 | documentation. *) 574 | 575 | external replace : state -> int -> unit = "lua_replace__stub" 576 | (** See 577 | {{:http://www.lua.org/manual/5.1/manual.html#lua_replace}lua_replace} 578 | documentation. *) 579 | 580 | val resume : state -> int -> thread_status 581 | (** See 582 | {{:http://www.lua.org/manual/5.1/manual.html#lua_resume}lua_resume} 583 | documentation. *) 584 | 585 | (** {{:http://www.lua.org/manual/5.1/manual.html#lua_setallocf}lua_setallocf} 586 | not implemented in this binding *) 587 | 588 | external setfenv : state -> int -> bool = "lua_setfenv__stub" 589 | (** See 590 | {{:http://www.lua.org/manual/5.1/manual.html#lua_setfenv}lua_setfenv} 591 | documentation. *) 592 | 593 | external setfield : state -> int -> string -> unit = "lua_setfield__stub" 594 | (** See 595 | {{:http://www.lua.org/manual/5.1/manual.html#lua_setfield}lua_setfield} 596 | documentation. *) 597 | 598 | external setglobal : state -> string -> unit = "lua_setglobal__stub" 599 | (** See 600 | {{:http://www.lua.org/manual/5.1/manual.html#lua_setglobal}lua_setglobal} 601 | documentation. *) 602 | 603 | external setmetatable : state -> int -> int = "lua_setmetatable__stub" 604 | (** See 605 | {{:http://www.lua.org/manual/5.1/manual.html#lua_setmetatable}lua_setmetatable} 606 | documentation. *) 607 | 608 | external settable : state -> int -> unit = "lua_settable__stub" 609 | (** See 610 | {{:http://www.lua.org/manual/5.1/manual.html#lua_settable}lua_settable} 611 | documentation. *) 612 | 613 | external settop : state -> int -> unit = "lua_settop__stub" 614 | (** See 615 | {{:http://www.lua.org/manual/5.1/manual.html#lua_settop}lua_settop} 616 | documentation. *) 617 | 618 | val status : state -> thread_status 619 | (** See 620 | {{:http://www.lua.org/manual/5.1/manual.html#lua_status}lua_status} 621 | documentation. *) 622 | 623 | external toboolean : state -> int -> bool = "lua_toboolean__stub" 624 | (** See 625 | {{:http://www.lua.org/manual/5.1/manual.html#lua_toboolean}lua_toboolean} 626 | documentation. *) 627 | 628 | val tocfunction : state -> int -> oCamlFunction option 629 | (** See 630 | {{:http://www.lua.org/manual/5.1/manual.html#lua_tocfunction}lua_tocfunction} 631 | documentation. *) 632 | 633 | val toocamlfunction : state -> int -> oCamlFunction option 634 | (** Alias of {!Lua_api_lib.tocfunction} *) 635 | 636 | val tointeger : state -> int -> int 637 | (** See 638 | {{:http://www.lua.org/manual/5.1/manual.html#lua_tointeger}lua_tointeger} 639 | documentation. *) 640 | 641 | val tolstring : state -> int -> string option 642 | (** See 643 | {{:http://www.lua.org/manual/5.1/manual.html#lua_tolstring}lua_tolstring} 644 | documentation. 645 | 646 | {b NOTE}: The original [len] argument is missing because, unlike in C, 647 | there is no impedance mismatch between OCaml and Lua strings *) 648 | 649 | val tonumber : state -> int -> float 650 | (** See 651 | {{:http://www.lua.org/manual/5.1/manual.html#lua_tonumber}lua_tonumber} 652 | documentation. *) 653 | 654 | (** The function 655 | {{:http://www.lua.org/manual/5.1/manual.html#lua_topointer}lua_topointer} 656 | is not available *) 657 | 658 | val tostring : state -> int -> string option 659 | (** Alias of {!Lua_api_lib.tolstring} *) 660 | 661 | val tothread : state -> int -> state option 662 | (** See 663 | {{:http://www.lua.org/manual/5.1/manual.html#lua_tothread}lua_tothread} 664 | documentation. *) 665 | 666 | val touserdata : state -> int -> [> `Userdata of 'a | `Light_userdata of 'a ] option 667 | (** If the value at the given acceptable index is a full userdata, returns its 668 | value as [Some `Userdata v]. If the value is a light userdata, returns its 669 | value as [Some `Light_userdata v]. 670 | Otherwise, returns [None]. 671 | 672 | {b WARNING}: using this function could be harmful because it actually breaks 673 | the type system. It has the same semantics of [Obj.magic], allowing the 674 | programmer to push an OCaml value into the Lua state, and then retrieve it 675 | with a different type. Be very careful! *) 676 | 677 | val type_ : state -> int -> lua_type 678 | (** See 679 | {{:http://www.lua.org/manual/5.1/manual.html#lua_type}lua_type} 680 | documentation. *) 681 | 682 | val typename : state -> lua_type -> string 683 | (** See 684 | {{:http://www.lua.org/manual/5.1/manual.html#lua_typename}lua_typename} 685 | documentation. *) 686 | 687 | val xmove : state -> state -> int -> unit 688 | (** See 689 | {{:http://www.lua.org/manual/5.1/manual.html#lua_xmove}lua_xmove} 690 | documentation. *) 691 | 692 | val yield : state -> int -> int 693 | (** See 694 | {{:http://www.lua.org/manual/5.1/manual.html#lua_yield}lua_yield} 695 | documentation. *) 696 | 697 | (**/**) 698 | 699 | val init : unit lazy_t 700 | -------------------------------------------------------------------------------- /src/lua_api_lib_stubs.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | #include 6 | #include 7 | #include 8 | 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | #include 15 | #include 16 | 17 | #include "stub.h" 18 | 19 | 20 | /******************************************************************************/ 21 | /***** DEBUG FUNCTION *****/ 22 | /******************************************************************************/ 23 | #ifdef ENABLE_DEBUG 24 | static int msglevel = 10; /* the higher, the more messages... */ 25 | #endif 26 | 27 | #if defined(ENABLE_DEBUG) 28 | void debug(int level, char* format, ...) 29 | { 30 | va_list args; 31 | 32 | if (level > msglevel) 33 | return; 34 | 35 | va_start(args, format); 36 | vfprintf(stderr, format, args); 37 | fflush(stderr); 38 | va_end(args); 39 | #ifdef ENABLE_DEBUG 40 | #else 41 | /* Empty body, so a good compiler will optimise calls 42 | to debug away */ 43 | #endif /* ENABLE_DEBUG */ 44 | } 45 | #else 46 | /* Nothing */ 47 | #endif /* ENABLE_DEBUG */ 48 | 49 | 50 | /******************************************************************************/ 51 | /***** DATA STRUCTURES *****/ 52 | /******************************************************************************/ 53 | typedef struct reader_data 54 | { 55 | value state_value; 56 | value reader_function; 57 | value reader_data; 58 | } reader_data; 59 | 60 | typedef struct writer_data 61 | { 62 | value writer_function; 63 | value state_value; 64 | value writer_data; 65 | } writer_data; 66 | 67 | static void finalize_thread(value L); /* Forward declaration */ 68 | 69 | static struct custom_operations thread_lua_State_ops = 70 | { 71 | THREADS_OPS_UUID, 72 | finalize_thread, 73 | custom_compare_default, 74 | custom_hash_default, 75 | custom_serialize_default, 76 | custom_deserialize_default 77 | }; 78 | 79 | 80 | /******************************************************************************/ 81 | /***** UTILITY FUNCTIONS *****/ 82 | /******************************************************************************/ 83 | /* 84 | * Pushes on the stack of L the array used to track the threads created via 85 | * lua_newthread 86 | */ 87 | static void push_threads_array(lua_State *L) 88 | { 89 | debug(3, "push_threads_array(%p)\n", (void*)L); 90 | 91 | lua_pushstring(L, UUID); 92 | lua_gettable(L, LUA_REGISTRYINDEX); 93 | lua_pushstring(L, "threads_array"); 94 | lua_gettable(L, -2); 95 | lua_insert(L, -2); 96 | lua_pop(L, 1); 97 | 98 | debug(4, "push_threads_array: RETURN\n"); 99 | } 100 | 101 | 102 | /* 103 | * Pushes on the stack of L the array used to track the light userdata created via 104 | * lua_pushlightuserdata 105 | */ 106 | void push_lud_array(lua_State *L) 107 | { 108 | debug(3, "push_lud_array(%p)\n", (void*)L); 109 | 110 | lua_pushstring(L, UUID); 111 | lua_gettable(L, LUA_REGISTRYINDEX); 112 | lua_pushstring(L, "light_userdata_array"); 113 | lua_gettable(L, -2); 114 | lua_insert(L, -2); 115 | lua_pop(L, 1); 116 | 117 | debug(4, "push_lud_array: RETURN\n"); 118 | } 119 | 120 | 121 | ocaml_data * get_ocaml_data(lua_State *L) 122 | { 123 | lua_pushstring(L, UUID); 124 | lua_gettable(L, LUA_REGISTRYINDEX); 125 | lua_pushstring(L, "ocaml_data"); 126 | lua_gettable(L, -2); 127 | ocaml_data *info = (ocaml_data*)lua_touserdata(L, -1); 128 | lua_pop(L, 2); 129 | return info; 130 | } 131 | 132 | 133 | static int panic_wrapper(lua_State *L) 134 | { 135 | ocaml_data *data = get_ocaml_data(L); 136 | return Int_val(caml_callback(data->panic_callback, // callback 137 | data->state_value)); // Lua state 138 | } 139 | 140 | /* This function is taken from the Lua source code, file ltablib.c line 118 */ 141 | static int tremove (lua_State *L) 142 | { 143 | int e = aux_getn(L, 1); 144 | int pos = luaL_optint(L, 2, e); 145 | if (!(1 <= pos && pos <= e)) /* position is outside bounds? */ 146 | return 0; /* nothing to remove */ 147 | luaL_setn(L, 1, e - 1); /* t.n = n-1 */ 148 | lua_rawgeti(L, 1, pos); /* result = t[pos] */ 149 | for ( ;posstate_value)); 202 | } 203 | 204 | /******************************************************************************/ 205 | /***** LUA API STUBS *****/ 206 | /******************************************************************************/ 207 | CAMLprim 208 | value lua_atpanic__stub(value L, value panicf) 209 | { 210 | CAMLparam2(L, panicf); 211 | CAMLlocal1(old_panicf); 212 | 213 | lua_State *state = lua_State_val(L); 214 | 215 | ocaml_data *data = get_ocaml_data(state); 216 | 217 | old_panicf = data->panic_callback; 218 | caml_remove_global_root(&(data->panic_callback)); 219 | caml_register_global_root(&(data->panic_callback)); 220 | data->panic_callback = panicf; 221 | lua_atpanic(state, panic_wrapper); 222 | 223 | CAMLreturn(old_panicf); 224 | } 225 | 226 | STUB_STATE_INT_INT_VOID(lua_call, nargs, nresults) 227 | 228 | STUB_STATE_INT_BOOL(lua_checkstack, extra) 229 | 230 | STUB_STATE_INT_VOID(lua_concat, n) 231 | 232 | STUB_STATE_INT_INT_VOID(lua_createtable, narr, nrec) 233 | 234 | static int writer_function(lua_State *L, const void *p, size_t sz, void* ud) 235 | { 236 | value writer_status_value, buffer; 237 | 238 | debug(3, "writer_function(%p, %p, %d, %p)\n", L, p, sz, ud); 239 | 240 | writer_data *internal_data = (writer_data*)ud; 241 | buffer = caml_alloc_string(sz); 242 | memcpy(String_val(buffer), p, sz); 243 | 244 | writer_status_value = 245 | caml_callback3( internal_data->writer_function, 246 | internal_data->state_value, 247 | buffer, 248 | internal_data->writer_data ); 249 | 250 | if (writer_status_value == Val_int(0)) 251 | { 252 | debug(4, "writer_function: RETURN 0\n"); 253 | return 0; 254 | } 255 | else 256 | { 257 | debug(4, "writer_function: RETURN 1\n"); 258 | return 1; 259 | } 260 | } 261 | 262 | CAMLprim 263 | value lua_dump__stub(value L, value writer, value data) 264 | { 265 | CAMLparam3(L, writer, data); 266 | 267 | debug(3, "lua_dump__stub(value L, value writer, value data)\n"); 268 | 269 | writer_data *internal_data = (writer_data*)caml_stat_alloc(sizeof(writer_data)); 270 | 271 | caml_register_global_root(&(internal_data->writer_function)); 272 | caml_register_global_root(&(internal_data->state_value)); 273 | caml_register_global_root(&(internal_data->writer_data)); 274 | 275 | internal_data->writer_function = writer; 276 | internal_data->state_value = L; 277 | internal_data->writer_data = data; 278 | 279 | int result = lua_dump( lua_State_val(L), 280 | writer_function, 281 | (void*)internal_data ); 282 | 283 | caml_remove_global_root(&(internal_data->writer_function)); 284 | caml_remove_global_root(&(internal_data->state_value)); 285 | caml_remove_global_root(&(internal_data->writer_data)); 286 | 287 | caml_stat_free(internal_data); 288 | 289 | debug(4, "lua_dump__stub: RETURN %d\n", result); 290 | CAMLreturn(Val_int(result)); 291 | } 292 | 293 | STUB_STATE_INT_INT_BOOL(lua_equal, index1, index2) 294 | 295 | STUB_STATE_VOID(lua_error) 296 | 297 | STUB_STATE_INT_INT_INT(lua_gc, what, data) 298 | 299 | STUB_STATE_INT_VOID(lua_getfenv, index) 300 | 301 | CAMLprim 302 | value lua_getfield__stub(value L, value index, value k) 303 | { 304 | CAMLparam3(L, index, k); 305 | lua_getfield(lua_State_val(L), Int_val(index), String_val(k)); 306 | CAMLreturn(Val_unit); 307 | } 308 | 309 | STUB_STATE_INT_BOOL(lua_getmetatable, index) 310 | 311 | STUB_STATE_INT_VOID(lua_gettable, index) 312 | 313 | STUB_STATE_INT(lua_gettop) 314 | 315 | STUB_STATE_INT_VOID(lua_insert, index) 316 | 317 | STUB_STATE_INT_BOOL(lua_isboolean, index) 318 | 319 | STUB_STATE_INT_BOOL(lua_iscfunction, index) 320 | 321 | STUB_STATE_INT_BOOL(lua_isfunction, index) 322 | 323 | STUB_STATE_INT_BOOL(lua_islightuserdata, index) 324 | 325 | STUB_STATE_INT_BOOL(lua_isnil, index) 326 | 327 | STUB_STATE_INT_BOOL(lua_isnone, index) 328 | 329 | STUB_STATE_INT_BOOL(lua_isnoneornil, index) 330 | 331 | STUB_STATE_INT_BOOL(lua_isnumber, index) 332 | 333 | STUB_STATE_INT_BOOL(lua_isstring, index) 334 | 335 | STUB_STATE_INT_BOOL(lua_istable, index) 336 | 337 | STUB_STATE_INT_BOOL(lua_isthread, index) 338 | 339 | STUB_STATE_INT_BOOL(lua_isuserdata, index) 340 | 341 | STUB_STATE_INT_INT_BOOL(lua_lessthan, index1, index2) 342 | 343 | static const char* reader_function(lua_State *L, void *data, size_t *size) 344 | { 345 | value string_option_res; 346 | 347 | debug(3, "reader_function(%p, %p, %p)\n", L, data, size); 348 | 349 | reader_data *internal_data = (reader_data*)data; 350 | string_option_res = caml_callback2( internal_data->reader_function, 351 | internal_data->state_value, 352 | internal_data->reader_data ); 353 | if (string_option_res == Val_int(0)) 354 | { 355 | // string_option_res = None 356 | *size = 0; 357 | debug(4, "reader_function: RETURN NULL\n"); 358 | return NULL; 359 | } 360 | else 361 | { 362 | // string_option_res = (Some "string") 363 | value str = Field(string_option_res, 0); 364 | *size = caml_string_length(str); 365 | debug(4, "reader_function: RETURN \"%s\", len = %d\n", String_val(str), *size); 366 | return String_val(str); 367 | } 368 | } 369 | 370 | CAMLprim 371 | value lua_load__stub(value L, value reader, value data, value chunkname) 372 | { 373 | CAMLparam4(L, reader, data, chunkname); 374 | 375 | reader_data *internal_data = (reader_data*)caml_stat_alloc(sizeof(reader_data)); 376 | 377 | caml_register_global_root(&(internal_data->state_value)); 378 | caml_register_global_root(&(internal_data->reader_function)); 379 | caml_register_global_root(&(internal_data->reader_data)); 380 | 381 | internal_data->state_value = L; 382 | internal_data->reader_function = reader; 383 | internal_data->reader_data = data; 384 | 385 | int result = lua_load( lua_State_val(L), 386 | reader_function, 387 | (void*)internal_data, 388 | String_val(chunkname) ); 389 | 390 | caml_remove_global_root(&(internal_data->state_value)); 391 | caml_remove_global_root(&(internal_data->reader_function)); 392 | caml_remove_global_root(&(internal_data->reader_data)); 393 | 394 | caml_stat_free(internal_data); 395 | 396 | CAMLreturn(Val_int(result)); 397 | } 398 | 399 | STUB_STATE_VOID(lua_newtable) 400 | 401 | CAMLprim 402 | value lua_newthread__stub(value L) 403 | { 404 | CAMLparam1(L); 405 | CAMLlocal1(thread_value); 406 | lua_State *LL = lua_State_val(L); 407 | 408 | push_threads_array(LL); 409 | lua_State *thread = lua_newthread(LL); 410 | lua_pushvalue(LL, -1); 411 | 412 | /* The stack here is: 413 | * -----+------------------------------------- 414 | * | -1 | the new thread just created (COPY) | 415 | * -----+------------------------------------- 416 | * | -2 | the new thread just created | 417 | * -----+------------------------------------| 418 | * | -3 | the threads array (n elements) | 419 | * -----+------------------------------------- 420 | */ 421 | int n = lua_objlen(LL, -3); 422 | lua_pushinteger(LL, n + 1); 423 | lua_insert(LL, -2); 424 | lua_settable(LL, -4); /* a copy of the thread inserted in our registry */ 425 | lua_insert(LL, -2); 426 | lua_pop(LL, 1); 427 | 428 | /* Here the stack contains only the new thread on its top */ 429 | 430 | /* wrap the new thread lua_State *thread in a custom object */ 431 | thread_value = caml_alloc_custom(&thread_lua_State_ops, sizeof(lua_State *), 1, 10); 432 | lua_State_val(thread_value) = thread; 433 | 434 | /* Return the thread value */ 435 | CAMLreturn(thread_value); 436 | } 437 | 438 | CAMLprim 439 | value lua_newuserdata__stub(value L, value ud) 440 | { 441 | debug(3, "lua_newuserdata__stub(%p, %p)\n", (void*)L, (void*)ud); 442 | CAMLparam2(L, ud); 443 | 444 | lua_State *LL = lua_State_val(L); 445 | 446 | /* Create the new userdatum containing the OCaml value ud */ 447 | value *lua_ud = (value*)lua_newuserdata(LL, sizeof(value)); 448 | debug(5, "lua_newuserdata__stub: calling lua_newuserdata(%p, %d) -> %p\n", 449 | (void*)LL, sizeof(value), (void*)lua_ud); 450 | caml_register_global_root(lua_ud); 451 | *lua_ud = ud; 452 | 453 | /* retrieve the metatable for this kind of userdata */ 454 | lua_pushstring(LL, UUID); 455 | lua_gettable(LL, LUA_REGISTRYINDEX); 456 | lua_pushstring(LL, "userdata_metatable"); 457 | lua_gettable(LL, -2); 458 | lua_setmetatable(LL, -3); 459 | lua_pop(LL, 1); 460 | 461 | debug(4, "lua_newuserdata__stub: RETURNS\n"); 462 | CAMLreturn(Val_unit); 463 | } 464 | 465 | STUB_STATE_INT_INT(lua_next, index) 466 | 467 | STUB_STATE_INT_INT(lua_objlen, index) 468 | 469 | CAMLprim 470 | value lua_pcall__stub(value L, value nargs, value nresults, value errfunc) 471 | { 472 | CAMLparam4(L, nargs, nresults, errfunc); 473 | CAMLlocal1(status); 474 | 475 | status = Val_int(lua_pcall( lua_State_val(L), 476 | Int_val(nargs), 477 | Int_val(nresults), 478 | Int_val(errfunc)) ); 479 | CAMLreturn(status); 480 | } 481 | 482 | STUB_STATE_INT_VOID(lua_pop, n) 483 | 484 | STUB_STATE_BOOL_VOID(lua_pushboolean, b) 485 | 486 | CAMLprim 487 | value lua_pushcfunction__stub(value L, value f) 488 | { 489 | CAMLparam2(L, f); 490 | 491 | debug(3, "lua_pushcfunction__stub(%p, %p)\n", (void*)L, (void*)f); 492 | 493 | /* Create the new userdatum containing the OCaml value of the closure */ 494 | lua_State *LL = lua_State_val(L); 495 | value *ocaml_closure = (value*)lua_newuserdata(LL, sizeof(value)); 496 | debug(5, "lua_pushcfunction__stub: calling lua_newuserdata(%p, %d) -> %p\n", 497 | (void*)LL, sizeof(value), (void*)ocaml_closure); 498 | 499 | caml_register_global_root(ocaml_closure); 500 | *ocaml_closure = f; 501 | 502 | /* retrieve the metatable for this kind of userdata */ 503 | lua_pushstring(LL, UUID); 504 | lua_gettable(LL, LUA_REGISTRYINDEX); 505 | lua_pushstring(LL, "closure_metatable"); 506 | lua_gettable(LL, -2); 507 | lua_setmetatable(LL, -3); 508 | lua_pop(LL, 1); 509 | 510 | /* at this point the stack has a userdatum on its top, with the correct metatable */ 511 | 512 | lua_pushcclosure(LL, execute_ocaml_closure, 1); 513 | 514 | debug(4, "lua_pushcfunction__stub: RETURN\n"); 515 | CAMLreturn(Val_unit); 516 | } 517 | 518 | STUB_STATE_INT_VOID(lua_pushinteger, n) 519 | 520 | CAMLprim 521 | value lua_pushlightuserdata__stub(value L, value p) 522 | { 523 | debug(3, "lua_pushlightuserdata__stub(%p, %p)\n", (void*)L, (void*)p); 524 | 525 | CAMLparam2(L, p); 526 | 527 | lua_State *LL = lua_State_val(L); 528 | 529 | if (Is_block(p)) 530 | { 531 | /* the p value is an OCaml block */ 532 | 533 | /* Create the new userdatum containing the OCaml value ud */ 534 | value *lua_light_ud = (value*)caml_stat_alloc(sizeof(value)); 535 | debug(5, "lua_pushlightuserdata__stub: caml_stat_alloc -> %p\n", (void*)(lua_light_ud)); 536 | caml_register_global_root(lua_light_ud); 537 | *lua_light_ud = p; 538 | 539 | push_lud_array(LL); 540 | lua_pushlightuserdata(LL, (void *)lua_light_ud); 541 | lua_pushvalue(LL, -1); 542 | int n = lua_objlen(LL, -3); 543 | lua_pushinteger(LL, n + 1); 544 | lua_insert(LL, -2); 545 | lua_settable(LL, -4); /* the light user data inserted in our registry */ 546 | lua_insert(LL, -2); 547 | lua_pop(LL, 1); 548 | } 549 | else 550 | { 551 | /* the p value is an immediate integer: in this case calling 552 | * pushlightuserdata is a nonsense, I prefer to raise an exception */ 553 | caml_raise_constant(*caml_named_value("Not_a_block_value")); 554 | } 555 | 556 | debug(4, "lua_pushlightuserdata__stub: RETURN\n"); 557 | CAMLreturn(Val_unit); 558 | } 559 | 560 | CAMLprim 561 | value lua_pushlstring__stub(value L, value s) 562 | { 563 | CAMLparam2(L, s); 564 | lua_pushlstring(lua_State_val(L), String_val(s), caml_string_length(s)); 565 | CAMLreturn(Val_unit); 566 | } 567 | 568 | STUB_STATE_VOID(lua_pushnil) 569 | 570 | STUB_STATE_DOUBLE_VOID(lua_pushnumber, n) 571 | 572 | STUB_STATE_BOOL(lua_pushthread) 573 | 574 | STUB_STATE_INT_VOID(lua_pushvalue, index) 575 | 576 | STUB_STATE_INT_INT_BOOL(lua_rawequal, index1, index2) 577 | 578 | STUB_STATE_INT_VOID(lua_rawget, index) 579 | 580 | STUB_STATE_INT_INT_VOID(lua_rawgeti, index, n) 581 | 582 | STUB_STATE_INT_VOID(lua_rawset, index) 583 | 584 | STUB_STATE_INT_INT_VOID(lua_rawseti, index, n) 585 | 586 | STUB_STATE_INT_VOID(lua_remove, index) 587 | 588 | STUB_STATE_INT_VOID(lua_replace, index) 589 | 590 | STUB_STATE_INT_INT(lua_resume, narg) 591 | 592 | STUB_STATE_INT_BOOL(lua_setfenv, index) 593 | 594 | CAMLprim 595 | value lua_setfield__stub(value L, value index, value k) 596 | { 597 | CAMLparam3(L, index, k); 598 | lua_setfield(lua_State_val(L), Int_val(index), String_val(k)); 599 | CAMLreturn(Val_unit); 600 | } 601 | 602 | CAMLprim 603 | value lua_setglobal__stub(value L, value name) 604 | { 605 | CAMLparam2(L, name); 606 | lua_setglobal(lua_State_val(L), String_val(name)); 607 | CAMLreturn(Val_unit); 608 | } 609 | 610 | STUB_STATE_INT_INT(lua_setmetatable, index) 611 | 612 | STUB_STATE_INT_VOID(lua_settable, index) 613 | 614 | STUB_STATE_INT_VOID(lua_settop, index) 615 | 616 | STUB_STATE_INT(lua_status) 617 | 618 | STUB_STATE_INT_BOOL(lua_toboolean, index) 619 | 620 | CAMLprim 621 | value lua_tocfunction__stub(value L, value index) 622 | { 623 | CAMLparam2(L, index); 624 | 625 | lua_State *LL = lua_State_val(L); 626 | 627 | /* 1ST: get the C function pointer */ 628 | lua_CFunction f = lua_tocfunction(LL, Int_val(index)); 629 | 630 | /* If the Lua object at position "index" of the stack is not a C function, 631 | raise an exception (will be catched on the OCaml side */ 632 | if (f == NULL) caml_raise_constant(*caml_named_value("Not_a_C_function")); 633 | 634 | /* 2ND: if the function is an OCaml closure, pushed in the Lua world using 635 | Lua.pushcfunction, the pointer returned here is actually 636 | execute_ocaml_closure. This is a static function defined in this file and 637 | without a context it's useless. Instead of returning a "value" version of 638 | execute_ocaml_closure we get the upvalue, which is the original value of 639 | the OCaml closure, and return it. */ 640 | 641 | /* lua_getupvalue (from the Lua debugging interface) pushes the upvalue on 642 | the stack (+1) */ 643 | const char *name = lua_getupvalue(LL, Int_val(index), 1); 644 | if (name == NULL) 645 | { 646 | /* In case of error, raise an exception */ 647 | caml_raise_constant(*caml_named_value("Not_a_C_function")); 648 | } 649 | else 650 | { 651 | /* Convert the userdatum to an OCaml value */ 652 | value *ocaml_closure = (value*)lua_touserdata(LL, -1); 653 | 654 | /* remove the userdatum from the stack (-1) */ 655 | lua_pop(LL, 1); 656 | 657 | /* return it */ 658 | CAMLreturn (*ocaml_closure); 659 | } 660 | } 661 | 662 | STUB_STATE_INT_INT(lua_tointeger, index) 663 | 664 | void raise_type_error(char *msg) 665 | { 666 | caml_raise_with_string(*caml_named_value("Lua_type_error"), msg); 667 | } 668 | 669 | CAMLprim 670 | value lua_tolstring__stub(value L, value index) 671 | { 672 | size_t len = 0; 673 | const char *value_from_lua; 674 | CAMLparam2(L, index); 675 | CAMLlocal1(ret_val); 676 | 677 | value_from_lua = lua_tolstring( lua_State_val(L), 678 | Int_val(index), 679 | &len ); 680 | if (value_from_lua != NULL) 681 | { 682 | ret_val = caml_alloc_string(len); 683 | char *s = String_val(ret_val); 684 | memcpy(s, value_from_lua, len); 685 | } 686 | else 687 | { 688 | raise_type_error("lua_tolstring: not a string value!"); 689 | } 690 | 691 | CAMLreturn(ret_val); 692 | } 693 | 694 | STUB_STATE_INT_DOUBLE(lua_tonumber, index) 695 | 696 | CAMLprim 697 | value lua_tothread__stub(value L, value index) 698 | { 699 | CAMLparam2(L, index); 700 | CAMLlocal1(thread_value); 701 | 702 | lua_State *LL = lua_State_val(L); 703 | int int_index = Int_val(index); 704 | 705 | lua_State *thread = lua_tothread(LL, int_index); 706 | if (thread != NULL) 707 | { 708 | push_threads_array(LL); 709 | lua_pushvalue(LL, int_index); 710 | 711 | int n = lua_objlen(LL, -2); 712 | lua_pushinteger(LL, n + 1); 713 | lua_insert(LL, -2); 714 | lua_settable(LL, -3); /* a copy of the thread inserted in our registry */ 715 | lua_pop(LL, 1); 716 | 717 | thread_value = caml_alloc_custom(&thread_lua_State_ops, sizeof(lua_State *), 1, 10); 718 | lua_State_val(thread_value) = thread; 719 | } 720 | else 721 | { 722 | caml_raise_constant(*caml_named_value("Not_a_Lua_thread")); 723 | } 724 | 725 | CAMLreturn(thread_value); 726 | } 727 | 728 | CAMLprim 729 | value lua_touserdata__stub(value L, value index) 730 | { 731 | CAMLparam2(L, index); 732 | CAMLlocal1(ret_val); 733 | 734 | debug(3, "lua_touserdata__stub(%p, %p)\n", (void*)L, (void*)index); 735 | 736 | lua_State *LL = lua_State_val(L); 737 | int int_index = Int_val(index); 738 | 739 | value *lua_ud = (value*)lua_touserdata(LL, int_index); 740 | debug(5, "lua_touserdata__stub: calling lua_touserdata(%p, %d) -> %p\n", 741 | (void*)LL, int_index, (void*)lua_ud); 742 | ret_val = *lua_ud; 743 | 744 | debug(4, "lua_touserdata__stub: RETURN %p\n", (void*)ret_val); 745 | CAMLreturn(ret_val); 746 | } 747 | 748 | STUB_STATE_INT_INT(lua_type, index) 749 | 750 | CAMLprim 751 | value lua_xmove__stub(value from, value to, value n) 752 | { 753 | CAMLparam3(from, to, n); 754 | lua_xmove(lua_State_val(from), lua_State_val(to), Int_val(n)); 755 | CAMLreturn(Val_unit); 756 | } 757 | 758 | STUB_STATE_INT_INT(lua_yield, nresults) 759 | 760 | -------------------------------------------------------------------------------- /src/lua_aux_lib.ml: -------------------------------------------------------------------------------- 1 | open Lua_api_lib 2 | 3 | let (|>) x f = f x 4 | 5 | type buffer = 6 | { ls : state; 7 | buffer : Buffer.t; } 8 | 9 | type reg = string * oCamlFunction 10 | 11 | let refnil = -1;; 12 | 13 | let noref = -2;; 14 | 15 | let addchar b c = 16 | Buffer.add_char b.buffer c 17 | ;; 18 | 19 | let addlstring b s = 20 | Buffer.add_string b.buffer s 21 | ;; 22 | 23 | let addstring = addlstring;; 24 | 25 | let addvalue b = 26 | match tolstring b.ls (-1) with 27 | | Some s -> Buffer.add_string b.buffer s 28 | | None -> () 29 | ;; 30 | 31 | external argcheck : state -> bool -> int -> string -> unit = "luaL_argcheck__stub" 32 | 33 | external argerror : state -> int -> string -> 'a = "luaL_argerror__stub" 34 | 35 | let buffinit ls = 36 | { ls = ls; 37 | buffer = Buffer.create 8192; } 38 | ;; 39 | 40 | external callmeta : state -> int -> string -> bool = "luaL_callmeta__stub" 41 | 42 | external checkany : state -> int -> unit = "luaL_checkany__stub" 43 | 44 | external checkint : state -> int -> int = "luaL_checkint__stub" 45 | 46 | let checkinteger = checkint;; 47 | 48 | external checklong : state -> int -> int = "luaL_checklong__stub" 49 | 50 | external typerror : state -> int -> string -> 'a = "luaL_typerror__stub" 51 | 52 | let tag_error ls narg tag = 53 | typerror ls narg (typename ls tag) 54 | ;; 55 | 56 | let checklstring ls narg = 57 | match tolstring ls narg with 58 | | Some s -> s 59 | | None -> tag_error ls narg LUA_TSTRING 60 | ;; 61 | 62 | let checknumber ls narg = 63 | let d = tonumber ls narg in 64 | if d = 0.0 && not (isnumber ls narg) 65 | then tag_error ls narg LUA_TNUMBER 66 | else d 67 | ;; 68 | 69 | let optlstring ls narg d = 70 | if isnoneornil ls narg then d 71 | else checklstring ls narg 72 | ;; 73 | 74 | let optstring = optlstring;; 75 | 76 | let checkstring = checklstring;; 77 | 78 | let checkoption ls narg def lst = 79 | let name = 80 | match def with 81 | | Some s -> optstring ls narg s 82 | | None -> checkstring ls narg in 83 | 84 | let rec find ?(i=0) p xs = 85 | match xs with 86 | | [] -> argerror ls narg (pushfstring ls "invalid option '%s'" name) 87 | | hd::tl -> if p hd then i else find ~i:(i+1) p tl in 88 | 89 | find (fun s -> s = name) lst 90 | ;; 91 | 92 | external error_aux : state -> string -> 'a = "luaL_error__stub" 93 | 94 | let error state = 95 | let k s = error_aux state s in 96 | Printf.ksprintf k 97 | ;; 98 | 99 | let checkstack ls space mes = 100 | if not (Lua_api_lib.checkstack ls space) 101 | then error ls "stack overflow (%s)" mes 102 | else () 103 | ;; 104 | 105 | let checktype ls narg t = 106 | if (Lua_api_lib.type_ ls narg <> t) 107 | then tag_error ls narg t 108 | else () 109 | ;; 110 | 111 | let checkudata ls ud tname = 112 | let te = lazy (typerror ls ud tname) in 113 | let p = touserdata ls ud in 114 | match p with 115 | | Some _data -> begin 116 | if (Lua_api_lib.getmetatable ls ud) then begin 117 | getfield ls registryindex tname; 118 | if (rawequal ls (-1) (-2)) 119 | then (pop ls 2; p) 120 | else Lazy.force te 121 | end else Lazy.force te 122 | end 123 | | None -> Lazy.force te 124 | ;; 125 | 126 | external luaL_loadfile__wrapper : state -> string -> int = "luaL_loadfile__stub" 127 | 128 | let loadfile ls filename = 129 | luaL_loadfile__wrapper ls filename |> thread_status_of_int 130 | ;; 131 | 132 | let dofile ls filename = 133 | match loadfile ls filename with 134 | | LUA_OK -> begin 135 | match pcall ls 0 multret 0 with 136 | | LUA_OK -> true 137 | | _ -> false 138 | end 139 | | _ -> false 140 | ;; 141 | 142 | external luaL_loadbuffer__wrapper : 143 | state -> string -> int -> string -> int = "luaL_loadbuffer__stub" 144 | 145 | let loadbuffer ls buff name = 146 | luaL_loadbuffer__wrapper ls buff (String.length buff) name |> thread_status_of_int 147 | ;; 148 | 149 | let loadstring ls s = 150 | loadbuffer ls s s 151 | ;; 152 | 153 | let dostring ls str = 154 | match loadstring ls str with 155 | | LUA_OK -> begin 156 | match pcall ls 0 multret 0 with 157 | | LUA_OK -> true 158 | | _ -> false 159 | end 160 | | _ -> false 161 | ;; 162 | 163 | external getmetafield : state -> int -> string -> bool = "luaL_getmetafield__stub" 164 | 165 | external getmetatable : state -> string -> unit = "luaL_getmetatable__stub" 166 | 167 | external gsub : state -> string -> string -> string -> string = "luaL_gsub__stub" 168 | 169 | external newmetatable : state -> string -> bool = "luaL_newmetatable__stub" 170 | 171 | external newstate__wrapper : int -> unit -> state = "luaL_newstate__stub" 172 | 173 | let newstate ?(max_memory_size) () = 174 | let () = Lazy.force (Lua_api_lib.init) in 175 | let m = match max_memory_size with | Some i -> i | None -> 0 in 176 | newstate__wrapper m () 177 | ;; 178 | 179 | external openlibs : state -> unit = "luaL_openlibs__stub" 180 | 181 | external optinteger : state -> int -> int -> int = "luaL_optinteger__stub" 182 | 183 | let optint = optinteger 184 | 185 | external optlong : state -> int -> int -> int = "luaL_optlong__stub" 186 | 187 | let optnumber ls narg d = 188 | if Lua_api_lib.isnoneornil ls narg 189 | then d 190 | else checknumber ls narg 191 | ;; 192 | 193 | let pushresult b = 194 | let data = Buffer.contents b.buffer in 195 | Lua_api_lib.pushlstring b.ls data; 196 | Buffer.clear b.buffer; 197 | ;; 198 | 199 | external ref_ : state -> int -> int = "luaL_ref__stub" 200 | 201 | external findtable : state -> int -> string -> int -> string option = "luaL_findtable__stub" 202 | 203 | let register ls libname func_list = 204 | let () = 205 | match libname with 206 | | Some libname -> begin 207 | let size = List.length func_list in 208 | (* check whether lib already exists *) 209 | let _ = findtable ls registryindex "_LOADED" 1 in 210 | getfield ls (-1) libname; (* get _LOADED[libname] *) 211 | if not (istable ls (-1)) then begin (* not found? *) 212 | pop ls 1; (* remove previous result *) 213 | (* try global variable (and create one if it does not exist) *) 214 | let () = 215 | match findtable ls globalsindex libname size with 216 | | Some _ -> error ls "name conflict for module '%s'" libname 217 | | None -> () in 218 | pushvalue ls (-1); 219 | setfield ls (-3) libname; (* _LOADED[libname] = new table *) 220 | end; 221 | remove ls (-2); (* remove _LOADED table *) 222 | insert ls (-1); (* move library table to below upvalues *) 223 | end 224 | | None -> () in 225 | 226 | List.iter 227 | (fun reg -> 228 | pushcfunction ls (snd reg); 229 | setfield ls (-2) (fst reg)) 230 | func_list; 231 | ;; 232 | 233 | let typename ls index = 234 | Lua_api_lib.typename ls (Lua_api_lib.type_ ls index) 235 | ;; 236 | 237 | external unref : state -> int -> int -> unit = "luaL_unref__stub" 238 | 239 | external where : state -> int -> unit = "luaL_where__stub" 240 | -------------------------------------------------------------------------------- /src/lua_aux_lib.mli: -------------------------------------------------------------------------------- 1 | (**************************************************) 2 | (** {1 The Lua Auxiliary Library (OCaml binding)} *) 3 | (**************************************************) 4 | 5 | open Lua_api_lib 6 | 7 | (***********************************************************) 8 | (** {2 Difference with the original Lua Auxiliary Library} *) 9 | (***********************************************************) 10 | 11 | (** Here is a list of functions of which you should read documentation: 12 | - {b Missing functions}: [luaL_addsize], [luaL_prepbuffer] 13 | - {b Notably different functions}: {!error}, {!newstate} 14 | - {b Special remarks}: {!checklstring} 15 | *) 16 | 17 | (**************************) 18 | (** {2 Types definitions} *) 19 | (**************************) 20 | 21 | type buffer 22 | (** See {{:http://www.lua.org/manual/5.1/manual.html#luaL_Buffer}luaL_Buffer} 23 | documentation. *) 24 | 25 | type reg = string * oCamlFunction 26 | (** See {{:http://www.lua.org/manual/5.1/manual.html#luaL_reg}luaL_reg} 27 | documentation. *) 28 | 29 | 30 | (************************) 31 | (** {2 Constant values} *) 32 | (************************) 33 | 34 | val refnil : int 35 | (** Value returned by `luaL_ref` and `luaL_unref`. 36 | See {{:http://www.lua.org/manual/5.1/manual.html#luaL_ref}luaL_ref} 37 | and {{:http://www.lua.org/manual/5.1/manual.html#luaL_unref}luaL_unref} 38 | documentation. *) 39 | 40 | val noref : int 41 | (** Value returned by `luaL_ref` and `luaL_unref`. 42 | See {{:http://www.lua.org/manual/5.1/manual.html#luaL_ref}luaL_ref} 43 | and {{:http://www.lua.org/manual/5.1/manual.html#luaL_unref}luaL_unref} 44 | documentation. *) 45 | 46 | (****************************************) 47 | (** {2 The Auxiliary Library functions} *) 48 | (****************************************) 49 | 50 | val addchar : buffer -> char -> unit 51 | (** See {{:http://www.lua.org/manual/5.1/manual.html#luaL_addchar}luaL_addchar} 52 | documentation. 53 | 54 | {b NOTE}: this function is {b not} a binding of the original luaL_addchar, 55 | it's rather an OCaml function with the same semantics. *) 56 | 57 | val addlstring : buffer -> string -> unit 58 | (** See {{:http://www.lua.org/manual/5.1/manual.html#luaL_addlstring}luaL_addlstring} 59 | documentation. 60 | 61 | {b NOTE}: this function is {b not} a binding of the original luaL_addlstring, 62 | it's rather an OCaml function with the same semantics. *) 63 | 64 | (** The function 65 | {{:http://www.lua.org/manual/5.1/manual.html#luaL_addsize}luaL_addsize} is not 66 | present because the type {!Lua_aux_lib.buffer} and related functions have been 67 | reimplemented in OCaml, and luaL_addsize is not needed. *) 68 | 69 | val addstring : buffer -> string -> unit 70 | (** See {{:http://www.lua.org/manual/5.1/manual.html#luaL_addstring}luaL_addstring} 71 | documentation. 72 | 73 | {b NOTE}: this function is an alias of {!Lua_aux_lib.addlstring} *) 74 | 75 | val addvalue : buffer -> unit 76 | (** See {{:http://www.lua.org/manual/5.1/manual.html#luaL_addvalue}luaL_addvalue} 77 | documentation. 78 | 79 | {b NOTE}: this function is {b not} a binding of the original luaL_addvalue, 80 | it's rather an OCaml function with the same semantics. *) 81 | 82 | external argcheck : state -> bool -> int -> string -> unit = "luaL_argcheck__stub" 83 | (** See {{:http://www.lua.org/manual/5.1/manual.html#luaL_argcheck}luaL_argcheck} 84 | documentation. *) 85 | 86 | external argerror : state -> int -> string -> 'a = "luaL_argerror__stub" 87 | (** See {{:http://www.lua.org/manual/5.1/manual.html#luaL_argerror}luaL_argerror} 88 | documentation. *) 89 | 90 | val buffinit : state -> buffer 91 | (** See {{:http://www.lua.org/manual/5.1/manual.html#luaL_buffinit}luaL_buffinit} 92 | documentation. *) 93 | 94 | external callmeta : state -> int -> string -> bool = "luaL_callmeta__stub" 95 | (** See {{:http://www.lua.org/manual/5.1/manual.html#luaL_callmeta}luaL_callmeta} 96 | documentation. *) 97 | 98 | external checkany : state -> int -> unit = "luaL_checkany__stub" 99 | (** See {{:http://www.lua.org/manual/5.1/manual.html#luaL_checkany}luaL_checkany} 100 | documentation. *) 101 | 102 | external checkint : state -> int -> int = "luaL_checkint__stub" 103 | (** See {{:http://www.lua.org/manual/5.1/manual.html#luaL_checkint}luaL_checkint} 104 | documentation. *) 105 | 106 | val checkinteger : state -> int -> int 107 | (** See {{:http://www.lua.org/manual/5.1/manual.html#luaL_checkinteger}luaL_checkinteger} 108 | documentation. 109 | 110 | {b NOTE}: this function is an alias of {!Lua_aux_lib.checkint} *) 111 | 112 | external checklong : state -> int -> int = "luaL_checklong__stub" 113 | (** See {{:http://www.lua.org/manual/5.1/manual.html#luaL_checklong}luaL_checklong} 114 | documentation. *) 115 | 116 | val checklstring : state -> int -> string 117 | (** See 118 | {{:http://www.lua.org/manual/5.1/manual.html#luaL_checklstring}luaL_checklstring} 119 | documentation. 120 | 121 | {b NOTE}:The original [len] argument is missing because, unlike in C, there 122 | is no impedance mismatch between OCaml and Lua strings. 123 | 124 | {b NOTE}: this function is {b not} a binding of the original luaL_checklstring, 125 | it's rather an OCaml function with the same semantics. *) 126 | 127 | val checkstring : state -> int -> string 128 | (** See {{:http://www.lua.org/manual/5.1/manual.html#luaL_checkstring}luaL_checkstring} 129 | documentation. 130 | 131 | {b NOTE}: this function is an alias of {!Lua_aux_lib.checklstring} *) 132 | 133 | val checknumber : state -> int -> float 134 | (** See 135 | {{:http://www.lua.org/manual/5.1/manual.html#luaL_checknumber}luaL_checknumber} 136 | documentation. 137 | 138 | {b NOTE}: this function is {b not} a binding of the original luaL_checknumber, 139 | it's rather an OCaml function with the same semantics. *) 140 | 141 | val checkoption : state -> int -> string option -> string list -> int 142 | (** See 143 | {{:http://www.lua.org/manual/5.1/manual.html#luaL_checkoption}luaL_checkoption} 144 | documentation. 145 | 146 | {b NOTE}: this function is {b not} a binding of the original luaL_checkoption, 147 | it's rather an OCaml function with the same semantics. *) 148 | 149 | val checkstack : state -> int -> string -> unit 150 | (** See 151 | {{:http://www.lua.org/manual/5.1/manual.html#luaL_checkstack}luaL_checkstack} 152 | documentation. 153 | 154 | {b NOTE}: this function is {b not} a binding of the original luaL_checkstack, 155 | it's rather an OCaml function with the same semantics. *) 156 | 157 | val checktype : state -> int -> lua_type -> unit 158 | (** See 159 | {{:http://www.lua.org/manual/5.1/manual.html#luaL_checktype}luaL_checktype} 160 | documentation. 161 | 162 | {b NOTE}: this function is {b not} a binding of the original luaL_checktype, 163 | it's rather an OCaml function with the same semantics. *) 164 | 165 | val checkudata : state -> int -> string -> [> `Userdata of 'a | `Light_userdata of 'a ] option 166 | (** See 167 | {{:http://www.lua.org/manual/5.1/manual.html#luaL_checkudata}luaL_checkudata} 168 | documentation. 169 | 170 | {b NOTE}: this function is {b not} a binding of the original luaL_checkudata, 171 | it's rather an OCaml function with the same semantics. *) 172 | 173 | val dofile : state -> string -> bool 174 | (** See 175 | {{:http://www.lua.org/manual/5.1/manual.html#luaL_dofile}luaL_dofile} 176 | documentation. 177 | 178 | {b NOTE}: this function is {b not} a binding of the original luaL_dofile, 179 | it's rather an OCaml function with the same semantics. *) 180 | 181 | val dostring : state -> string -> bool 182 | (** See 183 | {{:http://www.lua.org/manual/5.1/manual.html#luaL_dostring}luaL_dostring} 184 | documentation. 185 | 186 | {b NOTE}: this function is {b not} a binding of the original luaL_dostring, 187 | it's rather an OCaml function with the same semantics. *) 188 | 189 | val error : state -> ('a, unit, string, 'b) format4 -> 'a 190 | (** See 191 | {{:http://www.lua.org/manual/5.1/manual.html#luaL_error}luaL_error} 192 | documentation. 193 | 194 | {b NOTE}: this function is {b not} a binding of the original luaL_error, 195 | it's rather an OCaml function with the same semantics. 196 | 197 | Warning: this function has a different behavior with respect to the original 198 | {{:http://www.lua.org/manual/5.1/manual.html#luaL_error}luaL_error} 199 | because the conversion specifiers are not restricted as specified in the Lua 200 | documentation, but you can use all the conversions of the 201 | {{:http://caml.inria.fr/pub/docs/manual-ocaml/libref/Printf.html}Printf module}. *) 202 | 203 | external getmetafield : state -> int -> string -> bool = "luaL_getmetafield__stub" 204 | (** See 205 | {{:http://www.lua.org/manual/5.1/manual.html#luaL_getmetafield}luaL_getmetafield} 206 | documentation. *) 207 | 208 | external getmetatable : state -> string -> unit = "luaL_getmetatable__stub" 209 | (** See 210 | {{:http://www.lua.org/manual/5.1/manual.html#luaL_getmetatable}luaL_getmetatable} 211 | documentation. *) 212 | 213 | external gsub : state -> string -> string -> string -> string = "luaL_gsub__stub" 214 | (** See 215 | {{:http://www.lua.org/manual/5.1/manual.html#luaL_gsub}luaL_gsub} 216 | documentation. *) 217 | 218 | val loadbuffer : Lua_api_lib.state -> string -> string -> thread_status 219 | (** See 220 | {{:http://www.lua.org/manual/5.1/manual.html#luaL_loadbuffer}luaL_loadbuffer} 221 | documentation. *) 222 | 223 | val loadfile : state -> string -> thread_status 224 | (** See {{:http://www.lua.org/manual/5.1/manual.html#luaL_loadfile}luaL_loadfile} 225 | documentation. *) 226 | 227 | val loadstring : state -> string -> thread_status 228 | (** See {{:http://www.lua.org/manual/5.1/manual.html#luaL_loadstring}luaL_loadstring} 229 | documentation. *) 230 | 231 | external newmetatable : state -> string -> bool = "luaL_newmetatable__stub" 232 | (** See {{:http://www.lua.org/manual/5.1/manual.html#luaL_newmetatable}luaL_newmetatable} 233 | documentation. *) 234 | 235 | val newstate : ?max_memory_size:int -> unit -> state 236 | (** See {{:http://www.lua.org/manual/5.1/manual.html#luaL_newstate}luaL_newstate} 237 | documentation. 238 | 239 | {b NOTE}: this function is {b not} a binding of the original luaL_newstate, 240 | it's rather an OCaml function with the same semantics. 241 | 242 | An optional parameter, not available in the original luaL_newstate, provide 243 | the user the chance to specify the maximum memory (in byte) that Lua is allowed to 244 | allocate for this state. *) 245 | 246 | external openlibs : Lua_api_lib.state -> unit = "luaL_openlibs__stub" 247 | (** See {{:http://www.lua.org/manual/5.1/manual.html#luaL_openlibs}luaL_openlibs} 248 | documentation. *) 249 | 250 | val optint : state -> int -> int -> int 251 | (** See {{:http://www.lua.org/manual/5.1/manual.html#luaL_optint}luaL_optint} 252 | documentation. 253 | 254 | {b NOTE}: this function is an alias of {!Lua_aux_lib.optinteger} *) 255 | 256 | external optinteger : state -> int -> int -> int = "luaL_optinteger__stub" 257 | (** See {{:http://www.lua.org/manual/5.1/manual.html#luaL_optinteger}luaL_optinteger} 258 | documentation. *) 259 | 260 | external optlong : state -> int -> int -> int = "luaL_optlong__stub" 261 | (** See {{:http://www.lua.org/manual/5.1/manual.html#luaL_optlong}luaL_optlong} 262 | documentation. *) 263 | 264 | val optlstring : state -> int -> string -> string 265 | (** See 266 | {{:http://www.lua.org/manual/5.1/manual.html#luaL_optlstring}luaL_optlstring} 267 | documentation. 268 | 269 | {b NOTE}: this function is {b not} a binding of the original luaL_optlstring, 270 | it's rather an OCaml function with the same semantics. *) 271 | 272 | val optnumber : state -> int -> float -> float 273 | (** See 274 | {{:http://www.lua.org/manual/5.1/manual.html#luaL_optnumber}luaL_optnumber} 275 | documentation. 276 | 277 | {b NOTE}: this function is {b not} a binding of the original luaL_optnumber, 278 | it's rather an OCaml function with the same semantics. *) 279 | 280 | val optstring : state -> int -> string -> string 281 | (** See {{:http://www.lua.org/manual/5.1/manual.html#luaL_optstring}luaL_optstring} 282 | documentation. 283 | 284 | {b NOTE}: this function is an alias of {!Lua_aux_lib.optlstring} *) 285 | 286 | (** The function 287 | {{:http://www.lua.org/manual/5.1/manual.html#luaL_prepbuffer}luaL_prepbuffer} is not 288 | present because the type {!Lua_aux_lib.buffer} and related functions have been 289 | reimplemented in OCaml, and luaL_prepbuffer is not needed. *) 290 | 291 | val pushresult : buffer -> unit 292 | (** See 293 | {{:http://www.lua.org/manual/5.1/manual.html#luaL_pushresult}luaL_pushresult} 294 | documentation. 295 | 296 | {b NOTE}: this function is {b not} a binding of the original luaL_pushresult, 297 | it's rather an OCaml function with the same semantics. *) 298 | 299 | external ref_ : state -> int -> int = "luaL_ref__stub" 300 | (** See {{:http://www.lua.org/manual/5.1/manual.html#luaL_ref}luaL_ref} 301 | documentation. *) 302 | 303 | val register : state -> string option -> reg list -> unit 304 | (** See 305 | {{:http://www.lua.org/manual/5.1/manual.html#luaL_register}luaL_register} 306 | documentation. 307 | 308 | {b NOTE}: this function is {b not} a binding of the original luaL_register, 309 | it's rather an OCaml function with the same semantics. *) 310 | 311 | val typename : state -> int -> string 312 | (** See 313 | {{:http://www.lua.org/manual/5.1/manual.html#luaL_typename}luaL_typename} 314 | documentation. 315 | 316 | {b NOTE}: this function is {b not} a binding of the original luaL_typename, 317 | it's rather an OCaml function with the same semantics. *) 318 | 319 | external typerror : state -> int -> string -> 'a = "luaL_typerror__stub" 320 | (** See {{:http://www.lua.org/manual/5.1/manual.html#luaL_typerror}luaL_typerror} 321 | documentation. *) 322 | 323 | external unref : state -> int -> int -> unit = "luaL_unref__stub" 324 | (** See {{:http://www.lua.org/manual/5.1/manual.html#luaL_unref}luaL_unref} 325 | documentation. *) 326 | 327 | external where : state -> int -> unit = "luaL_where__stub" 328 | (** See {{:http://www.lua.org/manual/5.1/manual.html#luaL_where}luaL_where} 329 | documentation. *) 330 | -------------------------------------------------------------------------------- /src/lua_aux_lib_stubs.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | #include 6 | #include 7 | #include 8 | 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | #include 15 | #include 16 | 17 | #include "stub.h" 18 | 19 | /******************************************************************************/ 20 | /***** DATA STRUCTURES *****/ 21 | /******************************************************************************/ 22 | static void finalize_lua_State(value L); /* Forward declaration */ 23 | 24 | static struct custom_operations lua_State_ops = 25 | { 26 | UUID, 27 | finalize_lua_State, 28 | custom_compare_default, 29 | custom_hash_default, 30 | custom_serialize_default, 31 | custom_deserialize_default 32 | }; 33 | 34 | static struct custom_operations default_lua_State_ops = 35 | { 36 | DEFAULT_OPS_UUID, 37 | custom_finalize_default, 38 | custom_compare_default, 39 | custom_hash_default, 40 | custom_serialize_default, 41 | custom_deserialize_default 42 | }; 43 | 44 | /******************************************************************************/ 45 | /***** GLOBAL LOCKS *****/ 46 | /******************************************************************************/ 47 | static pthread_mutex_t alloc_lock = PTHREAD_MUTEX_INITIALIZER; 48 | 49 | 50 | /******************************************************************************/ 51 | /***** UTILITY FUNCTIONS *****/ 52 | /******************************************************************************/ 53 | static void *custom_alloc ( void *ud, 54 | void *ptr, 55 | size_t osize, 56 | size_t nsize ) 57 | { 58 | void *realloc_result = NULL; 59 | 60 | allocator_data *ad = (allocator_data *)ud; 61 | debug(6, "custom_alloc: max_memory = %d\n", ad->max_memory); 62 | debug(6, "custom_alloc: used_memory = %d\n", ad->used_memory); 63 | 64 | pthread_mutex_lock(&alloc_lock); 65 | 66 | debug(5, "custom_alloc(%p, %p, %d, %d)\n", ud, ptr, osize, nsize); 67 | 68 | if (nsize == 0) 69 | { 70 | debug(6, "custom_alloc: calling free(%p)\n", ptr); 71 | free(ptr); 72 | debug(7, "custom_alloc: OLD value of used_memory = %d\n", ad->used_memory); 73 | ad->used_memory -= osize; /* substract old size from used memory */ 74 | debug(7, "custom_alloc: NEW value of used_memory = %d\n", ad->used_memory); 75 | debug(6, "custom_alloc: returning NULL\n"); 76 | 77 | pthread_mutex_unlock(&alloc_lock); 78 | return NULL; 79 | } 80 | else 81 | { 82 | if (ad->max_memory > 0 && 83 | ad->used_memory + (nsize - osize) > ad->max_memory) 84 | { 85 | /* too much memory in use */ 86 | debug(6, "custom_alloc: TOO MUCH MEMORY ALLOCATED, returning NULL\n"); 87 | pthread_mutex_unlock(&alloc_lock); 88 | return NULL; 89 | } 90 | debug(6, "custom_alloc: calling caml_stat_resize(%p, %d)\n", ptr, nsize); 91 | realloc_result = caml_stat_resize(ptr, nsize); 92 | if (realloc_result) 93 | { 94 | /* reallocation successful? */ 95 | debug(7, "custom_alloc: OLD value of used_memory = %d\n", ad->used_memory); 96 | ad->used_memory += (nsize - osize); 97 | debug(7, "custom_alloc: NEW value of used_memory = %d\n", ad->used_memory); 98 | } 99 | debug(6, "custom_alloc: returning %p\n", realloc_result); 100 | 101 | pthread_mutex_unlock(&alloc_lock); 102 | return realloc_result; 103 | } 104 | } 105 | 106 | 107 | /* While "closure_data_gc" and "default_gc" are the same function (see the 108 | * code), I still decided to keep them separate and copy&paste the code, to 109 | * leave me open to possible future differentiations. 110 | */ 111 | static int closure_data_gc(lua_State *L) 112 | { 113 | debug(3, "closure_data_gc(%p)\n", (void*)L); 114 | value *ocaml_closure = (value*)lua_touserdata(L, 1); 115 | debug(5, "closure_data_gc: ocaml_closure == %p\n", (void*)ocaml_closure); 116 | caml_remove_global_root(ocaml_closure); 117 | debug(4, "closure_data_gc: RETURN 0\n"); 118 | return 0; 119 | } 120 | 121 | static int default_gc(lua_State *L) 122 | { 123 | debug(3, "default_gc(%p)\n", (void*)L); 124 | value *lua_ud = (value*)lua_touserdata(L, 1); 125 | debug(5, "default_gc: lua_ud == %p\n", (void*)lua_ud); 126 | caml_remove_global_root(lua_ud); 127 | debug(4, "default_gc: RETURN 0\n"); 128 | return 0; 129 | } 130 | 131 | CAMLprim 132 | value default_gc__stub(value L) 133 | { 134 | debug(3, "default_gc__stub(%p)\n", (void*)L); 135 | CAMLparam1(L); 136 | int retval = default_gc(lua_State_val(L)); 137 | debug(4, "default_gc__stub: RETURN %d\n", retval); 138 | CAMLreturn(Val_int(retval)); 139 | } 140 | 141 | static void create_private_data(lua_State *L, ocaml_data* data) 142 | { 143 | lua_newtable(L); /* Table (t) for our private data */ 144 | lua_pushstring(L, "ocaml_data"); 145 | lua_pushlightuserdata(L, (void *)data); 146 | lua_settable(L, -3); /* t["ocaml_data"] = our_private_data */ 147 | 148 | lua_newtable(L); /* metatable for userdata used by lua_pushcfunction__stub */ 149 | lua_pushstring(L, "__gc"); 150 | lua_pushcfunction(L, closure_data_gc); 151 | lua_settable(L, -3); 152 | 153 | lua_pushstring(L, "closure_metatable"); 154 | lua_insert(L, -2); 155 | lua_settable(L, -3); /* t["closure_metatable"] = metatable_for_closures */ 156 | 157 | /* Here the stack contains only 1 element, at index -1, the table t */ 158 | 159 | lua_pushstring(L, "threads_array"); 160 | lua_newtable(L); /* a table for copies of threads */ 161 | lua_settable(L, -3); /* t["threads_array"] = table_for_threads */ 162 | 163 | /* Here the stack contains only 1 element, at index -1, the table t */ 164 | 165 | lua_pushstring(L, "light_userdata_array"); 166 | lua_newtable(L); /* a table for copies of all light userdata */ 167 | lua_settable(L, -3); /* t["light_userdata_array"] = table_for_l_ud */ 168 | 169 | /* Here the stack contains only 1 element, at index -1, the table t */ 170 | 171 | lua_newtable(L); /* metatable for userdata used by lua_newuserdata and companion */ 172 | lua_pushstring(L, "__gc"); 173 | lua_pushcfunction(L, default_gc); 174 | lua_settable(L, -3); 175 | lua_pushstring(L, "userdata_metatable"); 176 | lua_insert(L, -2); 177 | lua_settable(L, -3); /* t["userdata_metatable"] = metatable_for_userdata */ 178 | 179 | /* Here the stack contains only 1 element, at index -1, the table t */ 180 | 181 | lua_pushstring(L, UUID); 182 | lua_insert(L, -2); 183 | lua_settable(L, LUA_REGISTRYINDEX); /* registry[UUID] = t */ 184 | } 185 | 186 | static void finalize_lua_State(value L) 187 | { 188 | debug(3, "finalize_lua_State(%p)\n", (void*)L); 189 | 190 | lua_State *state = lua_State_val(L); 191 | 192 | push_lud_array(state); 193 | int table_pos = lua_gettop(state); 194 | lua_pushnil(state); /* first key */ 195 | while (lua_next(state, table_pos) != 0) 196 | { 197 | /* key at -2, value (light userdata) at -1 */ 198 | value *ocaml_lud_value = (value*)lua_touserdata(state, -1); 199 | caml_remove_global_root(ocaml_lud_value); 200 | debug(5, "finalize_lua_State: caml_stat_free(%p)\n", (void*)ocaml_lud_value); 201 | caml_stat_free(ocaml_lud_value); 202 | lua_pop(state, 1); 203 | } 204 | 205 | ocaml_data *data = get_ocaml_data(state); 206 | lua_close(state); 207 | caml_remove_global_root(&(data->panic_callback)); 208 | caml_remove_global_root(&(data->state_value)); 209 | caml_stat_free(data); 210 | debug(4, "finalize_lua_State: RETURN\n"); 211 | } 212 | 213 | static int default_panic(lua_State *L) 214 | { 215 | value *default_panic_v = caml_named_value("default_panic"); 216 | ocaml_data *data = get_ocaml_data(L); 217 | return Int_val(caml_callback(*default_panic_v, data->state_value)); 218 | } 219 | 220 | 221 | /******************************************************************************/ 222 | /***** LUA AUX API STUBS *****/ 223 | /******************************************************************************/ 224 | 225 | CAMLprim 226 | value luaL_argcheck__stub (value L, value cond, value narg, value extramsg) 227 | { 228 | CAMLparam4(L, cond, narg, extramsg); 229 | luaL_argcheck( lua_State_val(L), 230 | Bool_val(cond), 231 | Int_val(narg), 232 | String_val(extramsg) ); 233 | CAMLreturn(Val_unit); 234 | } 235 | 236 | CAMLprim 237 | value luaL_argerror__stub (value L, value narg, value extramsg) 238 | { 239 | CAMLparam3(L, narg, extramsg); 240 | luaL_argerror(lua_State_val(L), Int_val(narg), String_val(extramsg)); 241 | CAMLreturn(Val_unit); 242 | } 243 | 244 | CAMLprim 245 | value luaL_callmeta__stub (value L, value obj, value e) 246 | { 247 | CAMLparam3(L, obj, e); 248 | int retval = luaL_callmeta(lua_State_val(L), Int_val(obj), String_val(e)); 249 | if (retval == 0) 250 | CAMLreturn(Val_false); 251 | else 252 | CAMLreturn(Val_true); 253 | } 254 | 255 | STUB_STATE_INT_VOID(luaL_checkany, narg) 256 | 257 | STUB_STATE_INT_INT(luaL_checkint, narg) 258 | 259 | CAMLprim 260 | value luaL_checklong__stub(value L, value narg) 261 | { 262 | CAMLparam2(L, narg); 263 | long int retval = luaL_checklong(lua_State_val(L), Long_val(narg)); 264 | CAMLreturn(Val_long(retval)); 265 | } 266 | 267 | CAMLprim 268 | value luaL_newstate__stub (value max_memory_size, value unit) 269 | { 270 | CAMLparam2(max_memory_size, unit); 271 | CAMLlocal2(v_L, v_L_mirror); 272 | 273 | debug(3, "luaL_newstate__stub: BEGIN\n"); 274 | 275 | value *default_panic_v = caml_named_value("default_panic"); 276 | 277 | /* alloc space for the register entry */ 278 | ocaml_data *data = (ocaml_data*)caml_stat_alloc(sizeof(ocaml_data)); 279 | 280 | /* protect the panic_callback portion and assign with the default value */ 281 | caml_register_global_root(&(data->panic_callback)); 282 | data->panic_callback = *default_panic_v; 283 | 284 | /* create a fresh new Lua state */ 285 | int max_memory = Int_val(max_memory_size); 286 | 287 | /* init the allocator data */ 288 | data->ad.max_memory = max_memory; 289 | data->ad.used_memory = 0; 290 | 291 | lua_State *L = lua_newstate(custom_alloc, (void*)&(data->ad)); 292 | debug(5, "luaL_newstate__stub: lua_newstate returned %p\n", (void*)L); 293 | debug(6, " luaL_newstate__stub: calling lua_atpanic..."); 294 | lua_atpanic(L, &default_panic); 295 | debug(6, " done!\n"); 296 | 297 | /* wrap the lua_State* in a custom object */ 298 | v_L = caml_alloc_custom(&lua_State_ops, sizeof(lua_State *), 1, 10); 299 | lua_State_val(v_L) = L; 300 | 301 | /* another value wrapping L for internal purposes */ 302 | v_L_mirror = caml_alloc_custom(&default_lua_State_ops, sizeof(lua_State *), 1, 10); 303 | lua_State_val(v_L_mirror) = L; 304 | caml_register_global_root(&(data->state_value)); 305 | data->state_value = v_L_mirror; 306 | 307 | /* create a new Lua table for binding informations */ 308 | create_private_data(L, data); 309 | 310 | debug(4, "luaL_newstate__stub: RETURN %p\n", (void*)v_L); 311 | /* return the lua_State value */ 312 | CAMLreturn(v_L); 313 | } 314 | 315 | CAMLprim 316 | value luaL_loadbuffer__stub(value L, value buff, value sz, value name) 317 | { 318 | CAMLparam4(L, buff, sz, name); 319 | CAMLlocal1(status); 320 | 321 | status = Val_int(luaL_loadbuffer( lua_State_val(L), 322 | String_val(buff), 323 | Int_val(sz), 324 | String_val(name)) ); 325 | CAMLreturn(status); 326 | } 327 | 328 | 329 | CAMLprim 330 | value luaL_loadfile__stub(value L, value filename) 331 | { 332 | CAMLparam2(L, filename); 333 | CAMLlocal1(status); 334 | 335 | status = Val_int(luaL_loadfile( lua_State_val(L), 336 | String_val(filename) )); 337 | CAMLreturn(status); 338 | } 339 | 340 | 341 | CAMLprim 342 | value luaL_openlibs__stub(value L) 343 | { 344 | CAMLparam1(L); 345 | luaL_openlibs(lua_State_val(L)); 346 | CAMLreturn(Val_unit); 347 | } 348 | 349 | CAMLprim 350 | value luaL_newmetatable__stub(value L, value tname) 351 | { 352 | CAMLparam2(L, tname); 353 | CAMLlocal1(retval); 354 | 355 | retval = Val_int(luaL_newmetatable( lua_State_val(L), String_val(tname) )); 356 | if (retval == 0) 357 | CAMLreturn(Val_false); 358 | else 359 | CAMLreturn(Val_true); 360 | } 361 | 362 | CAMLprim 363 | value luaL_getmetatable__stub(value L, value tname) 364 | { 365 | CAMLparam2(L, tname); 366 | luaL_getmetatable(lua_State_val(L), String_val(tname)); 367 | CAMLreturn(Val_unit); 368 | } 369 | 370 | CAMLprim 371 | value luaL_gsub__stub(value L, value s, value p, value r) 372 | { 373 | size_t len = 0; 374 | const char *value_from_lua; 375 | CAMLparam4(L, s, p, r); 376 | CAMLlocal1(ret_val); 377 | 378 | value_from_lua = luaL_gsub(lua_State_val(L), String_val(s), String_val(p), String_val(r)); 379 | len = strlen(value_from_lua); 380 | 381 | ret_val = caml_alloc_string(len); 382 | char *retval_str = String_val(ret_val); 383 | memcpy(retval_str, value_from_lua, len); 384 | 385 | CAMLreturn(ret_val); 386 | } 387 | 388 | CAMLprim 389 | value luaL_typerror__stub(value L, value narg, value tname) 390 | { 391 | CAMLparam3(L, narg, tname); 392 | CAMLlocal1(retval); 393 | 394 | retval = Val_int(luaL_typerror(lua_State_val(L), Int_val(narg), String_val(tname))); 395 | 396 | CAMLreturn(retval); 397 | } 398 | 399 | CAMLprim 400 | value luaL_checkstring__stub(value L, value narg) 401 | { 402 | size_t len = 0; 403 | const char *value_from_lua; 404 | 405 | CAMLparam2(L, narg); 406 | CAMLlocal1(ret_val); 407 | 408 | value_from_lua = luaL_checkstring(lua_State_val(L), Int_val(narg)); 409 | len = strlen(value_from_lua); 410 | ret_val = caml_alloc_string(len); 411 | char *s = String_val(ret_val); 412 | memcpy(s, value_from_lua, len); 413 | 414 | CAMLreturn(ret_val); 415 | } 416 | 417 | CAMLprim 418 | value luaL_error__stub(value L, value message) 419 | { 420 | CAMLparam2(L, message); 421 | luaL_error(lua_State_val(L), String_val(message)); 422 | CAMLreturn(Val_unit); 423 | } 424 | 425 | CAMLprim 426 | value luaL_getmetafield__stub(value L, value obj, value e) 427 | { 428 | CAMLparam3(L, obj, e); 429 | CAMLlocal1(retval); 430 | 431 | retval = Val_int(luaL_getmetafield(lua_State_val(L), Int_val(obj), String_val(e))); 432 | 433 | if (retval == 0) 434 | CAMLreturn(Val_false); 435 | else 436 | CAMLreturn(Val_true); 437 | } 438 | 439 | STUB_STATE_INT_INT_INT(luaL_optinteger, narg, d) 440 | 441 | CAMLprim 442 | value luaL_optlong__stub(value L, value narg, value d) 443 | { 444 | CAMLparam3(L, narg, d); 445 | long int retval = luaL_optlong(lua_State_val(L), Long_val(narg), Long_val(d)); 446 | CAMLreturn(Val_long(retval)); 447 | } 448 | 449 | STUB_STATE_INT_INT(luaL_ref, t) 450 | 451 | CAMLprim 452 | value luaL_findtable__stub(value L, value idx, value fname, value szhint) 453 | { 454 | size_t len = 0; 455 | const char *value_from_lua; 456 | 457 | CAMLparam4(L, idx, fname, szhint); 458 | CAMLlocal2(ret_string, ret_option); 459 | 460 | value_from_lua = luaL_findtable(lua_State_val(L), Int_val(idx), String_val(fname), Int_val(szhint)); 461 | if (value_from_lua == NULL) 462 | { 463 | return Val_int(0); 464 | } 465 | else 466 | { 467 | len = strlen(value_from_lua); 468 | ret_string = caml_alloc_string(len); 469 | char *retval_str = String_val(ret_string); 470 | memcpy(retval_str, value_from_lua, len); 471 | 472 | ret_option = caml_alloc(1, 0); 473 | Store_field(ret_option, 0, ret_string); 474 | 475 | CAMLreturn(ret_option); 476 | } 477 | } 478 | 479 | STUB_STATE_INT_INT_VOID(luaL_unref, t, ref) 480 | 481 | STUB_STATE_INT_VOID(luaL_where, lvl) 482 | -------------------------------------------------------------------------------- /src/lua_c/dune: -------------------------------------------------------------------------------- 1 | (library (name lua_c) (public_name ocaml-lua.c) (preprocess no_preprocessing) 2 | (self_build_stubs_archive (lua_c))) 3 | 4 | (rule 5 | (targets liblua_c_stubs.a dlllua_c_stubs.so) 6 | (deps (source_tree lua515)) 7 | (action (progn 8 | (chdir lua515 (run make %{system})) 9 | (run cp lua515/src/liblua.a liblua_c_stubs.a) 10 | (run cp lua515/src/liblua.so dlllua_c_stubs.so)))) 11 | -------------------------------------------------------------------------------- /src/lua_c/jbuild-ignore: -------------------------------------------------------------------------------- 1 | dune 2 | lua-5.1.5.tar.gz 3 | lua.patch 4 | lua515 5 | -------------------------------------------------------------------------------- /src/lua_c/lua-5.1.5.tar.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pdonadeo/ocaml-lua/f44ad50c88bf999f48a13af663051493c89d7d02/src/lua_c/lua-5.1.5.tar.gz -------------------------------------------------------------------------------- /src/lua_c/lua.patch: -------------------------------------------------------------------------------- 1 | diff -Naur lua-5.1.5__LUA_ORG/src/Makefile lua-5.1.5/src/Makefile 2 | --- lua-5.1.5__LUA_ORG/src/Makefile 2012-02-13 21:41:22.000000000 +0100 3 | +++ lua-5.1.5/src/Makefile 2019-10-26 23:04:29.523750046 +0200 4 | @@ -8,7 +8,7 @@ 5 | PLAT= none 6 | 7 | CC= gcc 8 | -CFLAGS= -O2 -Wall $(MYCFLAGS) 9 | +CFLAGS= -O2 -Wall $(MYCFLAGS) -fPIC -Wno-misleading-indentation 10 | AR= ar rcu 11 | RANLIB= ranlib 12 | RM= rm -f 13 | @@ -23,6 +23,7 @@ 14 | PLATS= aix ansi bsd freebsd generic linux macosx mingw posix solaris 15 | 16 | LUA_A= liblua.a 17 | +LUA_SO= liblua.so 18 | CORE_O= lapi.o lcode.o ldebug.o ldo.o ldump.o lfunc.o lgc.o llex.o lmem.o \ 19 | lobject.o lopcodes.o lparser.o lstate.o lstring.o ltable.o ltm.o \ 20 | lundump.o lvm.o lzio.o 21 | @@ -36,12 +37,16 @@ 22 | LUAC_O= luac.o print.o 23 | 24 | ALL_O= $(CORE_O) $(LIB_O) $(LUA_O) $(LUAC_O) 25 | -ALL_T= $(LUA_A) $(LUA_T) $(LUAC_T) 26 | +ALL_T= $(LUA_A) $(LUA_SO) $(LUA_T) $(LUAC_T) 27 | ALL_A= $(LUA_A) 28 | 29 | default: $(PLAT) 30 | 31 | -all: $(ALL_T) 32 | +all: $(ALL_A) $(LUA_SO) 33 | + 34 | +all_macosx: $(ALL_A) 35 | + $(CC) -dynamiclib -install_name $(LUA_SO) -compatibility_version 5.1 \ 36 | + -current_version 5.1.5 -o $(LUA_SO) $(CORE_O) $(LIB_O) 37 | 38 | o: $(ALL_O) 39 | 40 | @@ -51,6 +56,9 @@ 41 | $(AR) $@ $(CORE_O) $(LIB_O) # DLL needs all object files 42 | $(RANLIB) $@ 43 | 44 | +$(LUA_SO): $(CORE_O) $(LIB_O) 45 | + $(CC) -shared -ldl -Wl,-soname,$(LUA_SO) -o $@ $? -lm $(MYLDFLAGS) 46 | + 47 | $(LUA_T): $(LUA_O) $(LUA_A) 48 | $(CC) -o $@ $(MYLDFLAGS) $(LUA_O) $(LUA_A) $(LIBS) 49 | 50 | @@ -96,10 +104,10 @@ 51 | $(MAKE) all MYCFLAGS= 52 | 53 | linux: 54 | - $(MAKE) all MYCFLAGS=-DLUA_USE_LINUX MYLIBS="-Wl,-E -ldl -lreadline -lhistory -lncurses" 55 | + $(MAKE) all MYCFLAGS=-DLUA_USE_LINUX MYLIBS="-Wl,-E -ldl" 56 | 57 | macosx: 58 | - $(MAKE) all MYCFLAGS=-DLUA_USE_LINUX MYLIBS="-lreadline" 59 | + $(MAKE) all_macosx MYCFLAGS=-DLUA_USE_LINUX MYLIBS="" 60 | # use this on Mac OS X 10.3- 61 | # $(MAKE) all MYCFLAGS=-DLUA_USE_MACOSX 62 | 63 | @@ -116,7 +124,7 @@ 64 | $(MAKE) all MYCFLAGS="-DLUA_USE_POSIX -DLUA_USE_DLOPEN" MYLIBS="-ldl" 65 | 66 | # list targets that do not create files (but not all makes understand .PHONY) 67 | -.PHONY: all $(PLATS) default o a clean depend echo none 68 | +.PHONY: all all_macosx $(PLATS) default o a clean depend echo none 69 | 70 | # DO NOT DELETE 71 | 72 | -------------------------------------------------------------------------------- /src/stub.h: -------------------------------------------------------------------------------- 1 | #ifndef __STUB_H 2 | #define __STUB_H 3 | 4 | /******************************************************************************/ 5 | /***** DEBUG FUNCTION *****/ 6 | /******************************************************************************/ 7 | /* Uncomment the following line to enable debug */ 8 | /* #define ENABLE_DEBUG */ 9 | 10 | #if defined(ENABLE_DEBUG) 11 | void debug(int level, char *format, ...); 12 | #else 13 | #define debug(level, format, args...) ((void)0) 14 | #endif 15 | 16 | 17 | /******************************************************************************/ 18 | /***** UTILITY MACROS *****/ 19 | /******************************************************************************/ 20 | /* Library unique ID */ 21 | #define UUID "551087dd-4133-4097-87c6-79c27cde5c15" 22 | #define DEFAULT_OPS_UUID (UUID "_DEFAULT") 23 | #define THREADS_OPS_UUID (UUID "_THREADS") 24 | 25 | /* Access the lua_State inside an OCaml custom block */ 26 | #define lua_State_val(L) (*((lua_State **) Data_custom_val(L))) /* also l-value */ 27 | 28 | /* This macro is taken from the Lua source code, file ltablib.c line 19 */ 29 | #define aux_getn(L,n) (luaL_checktype(L, n, LUA_TTABLE), luaL_getn(L, n)) 30 | 31 | 32 | /******************************************************************************/ 33 | /***** DATA STRUCTURES *****/ 34 | /******************************************************************************/ 35 | typedef struct allocator_data 36 | { 37 | int max_memory; 38 | int used_memory; 39 | } allocator_data; 40 | 41 | typedef struct ocaml_data 42 | { 43 | value state_value; 44 | value panic_callback; 45 | allocator_data ad; 46 | } ocaml_data; 47 | 48 | 49 | /******************************************************************************/ 50 | /***** COMMON FUNCTIONS DECLARATION *****/ 51 | /******************************************************************************/ 52 | void push_lud_array(lua_State *L); 53 | ocaml_data * get_ocaml_data(lua_State *L); 54 | 55 | 56 | /******************************************************************************/ 57 | /***** MACROS FOR BOILERPLATE CODE *****/ 58 | /******************************************************************************/ 59 | /* For Lua function with signature : lua_State -> void */ 60 | #define STUB_STATE_VOID(lua_function) \ 61 | CAMLprim \ 62 | value lua_function##__stub(value L) \ 63 | { \ 64 | CAMLparam1(L); \ 65 | lua_function(lua_State_val(L)); \ 66 | CAMLreturn(Val_unit); \ 67 | } 68 | 69 | /* For Lua function with signature : lua_State -> int */ 70 | #define STUB_STATE_INT(lua_function) \ 71 | CAMLprim \ 72 | value lua_function##__stub(value L) \ 73 | { \ 74 | CAMLparam1(L); \ 75 | debug(3, #lua_function "__stub(%p)\n", (void*)(lua_State_val(L))); \ 76 | int retval = lua_function(lua_State_val(L)); \ 77 | debug(4, #lua_function ": RETURN %d\n", retval); \ 78 | CAMLreturn(Val_int(retval)); \ 79 | } 80 | 81 | /* For Lua function with signature : lua_State -> int -> int -> int */ 82 | #define STUB_STATE_INT_INT_INT(lua_function, int1_name, int2_name) \ 83 | CAMLprim \ 84 | value lua_function##__stub(value L, value int1_name, value int2_name) \ 85 | { \ 86 | CAMLparam3(L, int1_name, int2_name); \ 87 | int retval = lua_function(lua_State_val(L), Int_val(int1_name), Int_val(int2_name)); \ 88 | CAMLreturn(Val_int(retval)); \ 89 | } 90 | 91 | /* For Lua function with signature : lua_State -> int -> int */ 92 | #define STUB_STATE_INT_INT(lua_function, int_name) \ 93 | CAMLprim \ 94 | value lua_function##__stub(value L, value int_name) \ 95 | { \ 96 | CAMLparam2(L, int_name); \ 97 | int retval = lua_function(lua_State_val(L), Int_val(int_name)); \ 98 | CAMLreturn(Val_int(retval)); \ 99 | } 100 | 101 | /* For Lua function with signature : lua_State -> int -> void */ 102 | #define STUB_STATE_INT_VOID(lua_function, int_name) \ 103 | CAMLprim \ 104 | value lua_function##__stub(value L, value int_name) \ 105 | { \ 106 | CAMLparam2(L, int_name); \ 107 | debug(3, #lua_function "__stub(%p, %d)\n", (void*)(lua_State_val(L)), Int_val(int_name)); \ 108 | lua_function(lua_State_val(L), Int_val(int_name)); \ 109 | debug(4, #lua_function "__stub" ": RETURNS\n"); \ 110 | CAMLreturn(Val_unit); \ 111 | } 112 | 113 | /* For Lua function with signature : lua_State -> double -> void */ 114 | #define STUB_STATE_DOUBLE_VOID(lua_function, double_name) \ 115 | CAMLprim \ 116 | value lua_function##__stub(value L, value double_name) \ 117 | { \ 118 | CAMLparam2(L, double_name); \ 119 | lua_function(lua_State_val(L), Double_val(double_name)); \ 120 | CAMLreturn(Val_unit); \ 121 | } 122 | 123 | /* For Lua function with signature : lua_State -> int -> double */ 124 | #define STUB_STATE_INT_DOUBLE(lua_function, int_name) \ 125 | CAMLprim \ 126 | value lua_function##__stub(value L, value int_name) \ 127 | { \ 128 | CAMLparam2(L, int_name); \ 129 | double retval = lua_function(lua_State_val(L), Int_val(int_name)); \ 130 | CAMLreturn(caml_copy_double(retval)); \ 131 | } 132 | 133 | /* For Lua function with signature : lua_State -> bool -> void */ 134 | #define STUB_STATE_BOOL_VOID(lua_function, bool_name) \ 135 | CAMLprim \ 136 | value lua_function##__stub(value L, value bool_name) \ 137 | { \ 138 | CAMLparam2(L, bool_name); \ 139 | lua_function(lua_State_val(L), Bool_val(bool_name)); \ 140 | CAMLreturn(Val_unit); \ 141 | } 142 | 143 | /* For Lua function with signature : lua_State -> int -> int -> void */ 144 | #define STUB_STATE_INT_INT_VOID(lua_function, int1_name, int2_name) \ 145 | CAMLprim \ 146 | value lua_function##__stub(value L, value int1_name, value int2_name) \ 147 | { \ 148 | CAMLparam3(L, int1_name, int2_name); \ 149 | lua_function(lua_State_val(L), Int_val(int1_name), Int_val(int2_name)); \ 150 | CAMLreturn(Val_unit); \ 151 | } 152 | 153 | /* For Lua function with signature : lua_State -> bool */ 154 | #define STUB_STATE_BOOL(lua_function) \ 155 | CAMLprim \ 156 | value lua_function##__stub(value L) \ 157 | { \ 158 | CAMLparam1(L); \ 159 | int retval = lua_function(lua_State_val(L)); \ 160 | if (retval == 0) \ 161 | CAMLreturn(Val_false); \ 162 | else \ 163 | CAMLreturn(Val_true); \ 164 | } 165 | 166 | /* For Lua function with signature : lua_State -> int -> bool */ 167 | #define STUB_STATE_INT_BOOL(lua_function, int_name) \ 168 | CAMLprim \ 169 | value lua_function##__stub(value L, value int_name) \ 170 | { \ 171 | CAMLparam2(L, int_name); \ 172 | debug(3, #lua_function "__stub(%p, %d)\n", (void*)(lua_State_val(L)), Int_val(int_name)); \ 173 | int retval = lua_function(lua_State_val(L), Int_val(int_name)); \ 174 | if (retval == 0) \ 175 | { \ 176 | debug(4, #lua_function ": RETURN FALSE\n"); \ 177 | CAMLreturn(Val_false); \ 178 | } \ 179 | else \ 180 | { \ 181 | debug(4, #lua_function ": RETURN TRUE\n"); \ 182 | CAMLreturn(Val_true); \ 183 | } \ 184 | } 185 | 186 | /* For Lua function with signature : lua_State -> int -> int -> bool */ 187 | #define STUB_STATE_INT_INT_BOOL(lua_function, int1_name, int2_name) \ 188 | CAMLprim \ 189 | value lua_function##__stub(value L, value int1_name, value int2_name) \ 190 | { \ 191 | CAMLparam3(L, int1_name, int2_name); \ 192 | int retval = lua_function(lua_State_val(L), Int_val(int1_name), Int_val(int2_name)); \ 193 | if (retval == 0) \ 194 | CAMLreturn(Val_false); \ 195 | else \ 196 | CAMLreturn(Val_true); \ 197 | } 198 | 199 | #endif /* __STUB_H */ 200 | 201 | -------------------------------------------------------------------------------- /tests/atpanic.ml: -------------------------------------------------------------------------------- 1 | open Lua_api;; 2 | 3 | let (|>) x f = f x;; 4 | 5 | Random.self_init ();; 6 | 7 | let opt_get o = 8 | match o with 9 | | Some v -> v 10 | | None -> raise Not_found 11 | 12 | exception Test_exception 13 | let counter = ref 0;; 14 | 15 | let panicf1 _ = 16 | Printf.printf "panicf1: %d\n%!" !counter; 17 | raise Test_exception 18 | ;; 19 | 20 | let push_get_call_c_function ls f = 21 | Lua.pushocamlfunction ls f; 22 | let f' = Lua.tocfunction ls (-1) in 23 | Lua.pop ls 1; 24 | match f' with 25 | | None -> failwith "This should be a function, something went wrong!" 26 | | Some f -> 27 | begin 28 | Printf.printf "Calling an OCaml function obtained from Lua: %!"; 29 | f ls |> ignore; 30 | end 31 | ;; 32 | 33 | let test_loop () = 34 | let simple_ocaml_function _ = 35 | let () = Test_common.allocate ~random:false 479 99733 |> ignore in 36 | Printf.printf "OCaml function called from Lua!!!:-)\n%!"; 37 | 0 in 38 | 39 | let l1 = LuaL.newstate () in 40 | let l2 = LuaL.newstate () in 41 | 42 | try 43 | let str_list = Test_common.allocate ~random:false 479 99733 in 44 | let panicf2 ls = 45 | ignore str_list; 46 | 47 | push_get_call_c_function ls simple_ocaml_function; 48 | 49 | Printf.printf "panicf2: %d\n%!" !counter; 50 | raise Test_exception in 51 | let n = Random.int 2 in 52 | let f = match n with | 0 -> panicf1 | 1 -> panicf2 | _ -> failwith "IMPOSSIBILE" in 53 | 54 | (* TODO TODO TODO 55 | * ATTENZIONE, ELIMINARE QUESTI TEST DA QUI E CREARE UN TEST SPECIFICO. 56 | * SONO IMPORTANTI, MA QUI NON C'ENTRANO NULLA! 57 | (* Light userdata test *) 58 | for i = 1 to 50 do 59 | let something = Test_common.allocate_many_small () in 60 | Lua.pushlightuserdata l1 something; 61 | let something' : string list = 62 | match Lua.touserdata l1 (-1) with 63 | | Some `Userdata v -> failwith "USERDATA" 64 | | Some `Light_userdata v -> v 65 | | None -> failwith "NOT A USER DATUM" in 66 | Lua.pop l1 1; 67 | List.iter2 68 | (fun s s' -> if s <> s' then failwith (Printf.sprintf "\"%s\" <> \"%s\"" s s')) 69 | something something' 70 | done; 71 | 72 | (* Userdata test *) 73 | for i = 1 to 50 do 74 | let something = Test_common.allocate_many_small () in 75 | Lua.newuserdata l2 something; 76 | let something' : string list = 77 | match Lua.touserdata l2 (-1) with 78 | | Some `Userdata v -> v 79 | | Some `Light_userdata v -> failwith "LIGHT USERDATA" 80 | | None -> failwith "NOT A USER DATUM" in 81 | Lua.pop l2 1; 82 | List.iter2 83 | (fun s s' -> if s <> s' then failwith (Printf.sprintf "\"%s\" <> \"%s\"" s s')) 84 | something something' 85 | done; 86 | ***************************************************************************) 87 | 88 | let def_panic1 = Lua.atpanic l1 f in 89 | let def_panic2 = Lua.atpanic l2 f in 90 | 91 | Lua.pushfstring l1 "Custom message on %s%d stack" "L" 1 |> ignore; 92 | Lua.pushstring l2 "Custom message on L2 stack"; 93 | let my_panic1 = Lua.atpanic l1 def_panic1 in 94 | let my_panic2 = Lua.atpanic l2 def_panic2 in 95 | 96 | let def_panic1 = Lua.atpanic l1 my_panic1 in 97 | let def_panic2 = Lua.atpanic l2 my_panic2 in 98 | 99 | ignore(def_panic1, def_panic2); 100 | 101 | ignore (Lua.pushocamlfunction l1 simple_ocaml_function); 102 | Lua.setglobal l1 "simple_ocaml_function"; 103 | 104 | LuaL.openlibs l1; 105 | LuaL.openlibs l2; 106 | LuaL.loadbuffer l1 "simple_ocaml_function()\n" "line" |> ignore; 107 | LuaL.loadbuffer l2 "a = 42\nb = 43\nc = a + b\n-- print(c)" "line" |> ignore; 108 | let () = 109 | match Lua.pcall l1 0 0 0 with 110 | | Lua.LUA_OK -> () 111 | | err -> raise (Lua.Error err) in 112 | let () = 113 | match Lua.pcall l2 0 0 0 with 114 | | Lua.LUA_OK -> () 115 | | err -> raise (Lua.Error err) in 116 | let n = Random.int 2 in 117 | match n with 118 | | 0 -> Lua.error l1 119 | | 1 -> Lua.error l2 120 | | _ -> failwith "IMPOSSIBILE" 121 | with 122 | | Lua.Error _ -> 123 | begin 124 | Printf.printf "%s\n%!" ((Lua.tostring l1 (-1)) |> opt_get); 125 | Lua.pop l1 1; 126 | failwith "FATAL ERROR" 127 | end; 128 | ;; 129 | 130 | let main () = 131 | let open Test_common in 132 | let time_start = Unix.gettimeofday () in 133 | while Unix.gettimeofday () < time_start +. 10.0 do 134 | sleep_float 0.1; 135 | Gc.compact (); 136 | done; 137 | 138 | let test_duration = 60.0 *. 1.0 in 139 | let time_start = Unix.gettimeofday () in 140 | 141 | while Unix.gettimeofday () < time_start +. test_duration do 142 | let () = try test_loop () with Test_exception -> () in 143 | counter := !counter + 1; 144 | done; 145 | 146 | Gc.compact (); 147 | let time_start = Unix.gettimeofday () in 148 | 149 | while Unix.gettimeofday () < time_start +. 30.0 do 150 | sleep_float 1.0; 151 | Gc.compact (); 152 | done; 153 | ;; 154 | 155 | Test_common.run main () 156 | -------------------------------------------------------------------------------- /tests/cpcall.ml: -------------------------------------------------------------------------------- 1 | open Lua_api;; 2 | 3 | Random.self_init ();; 4 | 5 | type point = 6 | { 7 | x : float; 8 | y : float; 9 | fluff : bytes list; 10 | } 11 | 12 | let empty = { x = 0.0; y = 0.0; fluff = [] };; 13 | 14 | let equal p1 p2 = 15 | if p1.x = p2.x && p2.y = p2.y && Test_common.string_list_eq p1.fluff p2.fluff 16 | then true 17 | else false 18 | ;; 19 | 20 | let p_alloc = ref 0;; 21 | 22 | let p_finaliser _v = 23 | let open Test_common in 24 | log Debug_only " deallocating..."; 25 | decr p_alloc 26 | ;; 27 | 28 | let test_loop () = 29 | let ls = LuaL.newstate () in 30 | let test_value = ref empty in 31 | let func ls = 32 | let p : point = 33 | match Lua.touserdata ls 1 with 34 | | Some `Light_userdata ud -> ud 35 | | _ -> failwith "A light userdata expected" in 36 | test_value := p; 37 | 0 in 38 | let p = { 39 | x = Random.float 100.0; 40 | y = Random.float 100.0; 41 | fluff = Test_common.allocate 9973 470; 42 | } in 43 | incr p_alloc; 44 | Gc.finalise p_finaliser p; 45 | 46 | let () = 47 | match Lua.cpcall ls func p with 48 | | Lua.LUA_OK -> () 49 | | Lua.LUA_YIELD 50 | | Lua.LUA_ERRRUN 51 | | Lua.LUA_ERRSYNTAX 52 | | Lua.LUA_ERRMEM 53 | | Lua.LUA_ERRERR 54 | | Lua.LUA_ERRFILE as e -> raise (Lua.Error e) in 55 | 56 | if not (equal p !test_value) 57 | then failwith "The lightuserdata inside cpcall is not the expected one!" 58 | ;; 59 | 60 | let main () = 61 | let open Test_common in 62 | let time_start = Unix.gettimeofday () in 63 | while Unix.gettimeofday () < time_start +. 10.0 do 64 | sleep_float 0.1; 65 | Gc.compact (); 66 | done; 67 | 68 | let test_duration = 60.0 *. 1.0 in 69 | let time_start = Unix.gettimeofday ()in 70 | 71 | while Unix.gettimeofday () < time_start +. test_duration do 72 | test_loop (); 73 | log Debug_only "allocated objects: %d" !p_alloc; 74 | done; 75 | 76 | Gc.compact (); 77 | log Debug_only "allocated objects: %d" !p_alloc; 78 | let time_start = Unix.gettimeofday () in 79 | 80 | while Unix.gettimeofday () < time_start +. 30.0 do 81 | sleep_float 0.1; 82 | Gc.compact (); 83 | done; 84 | log User_info "allocated objects: %d" !p_alloc; 85 | ;; 86 | 87 | Test_common.run main ();; 88 | -------------------------------------------------------------------------------- /tests/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_common) 3 | (modules test_common)) 4 | 5 | (executable 6 | (name userdata) 7 | (modules userdata) 8 | (libraries lua)) 9 | 10 | (executable 11 | (name cpcall) 12 | (modules cpcall) 13 | (libraries lua test_common)) 14 | 15 | (executable 16 | (name atpanic) 17 | (modules atpanic) 18 | (libraries lua test_common)) 19 | 20 | (executable 21 | (name fasta_threads) 22 | (modules fasta_threads) 23 | (libraries lua test_common)) 24 | -------------------------------------------------------------------------------- /tests/fasta_threads.ml: -------------------------------------------------------------------------------- 1 | open Lua_api;; 2 | 3 | let lua_program = "-- The Computer Language Benchmarks Game 4 | -- http://shootout.alioth.debian.org/ 5 | -- contributed by Mike Pall 6 | 7 | local Last = 42 8 | local function random(max) 9 | local y = (Last * 3877 + 29573) % 139968 10 | Last = y 11 | return (max * y) / 139968 12 | end 13 | 14 | local function make_repeat_fasta(thread_id, id, desc, s, n) 15 | local output_file_name = string.format(\"OUTPUT/thread_%05d/out.txt\", thread_id) 16 | local output_file = io.open(output_file_name, \"a+b\") 17 | local sub = string.sub 18 | output_file:write(\">\", id, \" \", desc, \"\\n\") 19 | local p, sn, s2 = 1, #s, s..s 20 | for i=60,n,60 do 21 | output_file:write(sub(s2, p, p + 59), \"\\n\") 22 | p = p + 60; if p > sn then p = p - sn end 23 | end 24 | local tail = n % 60 25 | if tail > 0 then output_file:write(sub(s2, p, p + tail-1), \"\\n\") end 26 | output_file:close() 27 | end 28 | 29 | local function make_random_fasta(thread_id, id, desc, bs, n) 30 | local output_file_name = string.format(\"OUTPUT/thread_%05d/out.txt\", thread_id) 31 | local output_file = io.open(output_file_name, \"a+b\") 32 | output_file:write(\">\", id, \" \", desc, \"\\n\") 33 | output_file:close() 34 | 35 | loadstring([=[ 36 | local char, unpack, n, random = string.char, unpack, ... 37 | local output_file_name = string.format(\"OUTPUT/thread_%05d/out.txt\", thread_id) 38 | local output_file = io.open(output_file_name, \"a+b\") 39 | 40 | local buf, p = {}, 1 41 | for i=60,n,60 do 42 | for j=p,p+59 do ]=]..bs..[=[ end 43 | buf[p+60] = 10; p = p + 61 44 | if p >= 2048 then output_file:write(char(unpack(buf, 1, p-1))); p = 1 end 45 | end 46 | local tail = n % 60 47 | if tail > 0 then 48 | for j=p,p+tail-1 do ]=]..bs..[=[ end 49 | p = p + tail; buf[p] = 10; p = p + 1 50 | end 51 | output_file:write(char(unpack(buf, 1, p-1))) 52 | output_file:close() 53 | ]=], desc)(n, random) 54 | end 55 | 56 | local function bisect(c, p, lo, hi) 57 | local n = hi - lo 58 | if n == 0 then return \"buf[j] = \"..c[hi]..\"\\n\" end 59 | local mid = math.floor(n / 2) 60 | return \"if r < \"..p[lo+mid]..\" then\\n\"..bisect(c, p, lo, lo+mid).. 61 | \"else\\n\"..bisect(c, p, lo+mid+1, hi)..\"end\\n\" 62 | end 63 | 64 | local function make_bisect(tab) 65 | local c, p, sum = {}, {}, 0 66 | for i,row in ipairs(tab) do 67 | c[i] = string.byte(row[1]) 68 | sum = sum + row[2] 69 | p[i] = sum 70 | end 71 | return \"local r = random(1)\\n\"..bisect(c, p, 1, #tab) 72 | end 73 | 74 | local alu = 75 | \"GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGG\".. 76 | \"GAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGA\".. 77 | \"CCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAAT\".. 78 | \"ACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCA\".. 79 | \"GCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGG\".. 80 | \"AGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCC\".. 81 | \"AGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA\" 82 | 83 | local iub = make_bisect{ 84 | { \"a\", 0.27 }, 85 | { \"c\", 0.12 }, 86 | { \"g\", 0.12 }, 87 | { \"t\", 0.27 }, 88 | { \"B\", 0.02 }, 89 | { \"D\", 0.02 }, 90 | { \"H\", 0.02 }, 91 | { \"K\", 0.02 }, 92 | { \"M\", 0.02 }, 93 | { \"N\", 0.02 }, 94 | { \"R\", 0.02 }, 95 | { \"S\", 0.02 }, 96 | { \"V\", 0.02 }, 97 | { \"W\", 0.02 }, 98 | { \"Y\", 0.02 }, 99 | } 100 | 101 | local homosapiens = make_bisect{ 102 | { \"a\", 0.3029549426680 }, 103 | { \"c\", 0.1979883004921 }, 104 | { \"g\", 0.1975473066391 }, 105 | { \"t\", 0.3015094502008 }, 106 | } 107 | 108 | local N = param 109 | make_repeat_fasta(thread_id, 'ONE', 'Homo sapiens alu', alu, N*2) 110 | make_random_fasta(thread_id, 'TWO', 'IUB ambiguity codes', iub, N*3) 111 | make_random_fasta(thread_id, 'THREE', 'Homo sapiens frequency', homosapiens, N*5)";; 112 | 113 | let pf = Printf.printf;; 114 | let spf = Printf.sprintf;; 115 | let (|>) x f = f x;; 116 | let opt_get o = 117 | match o with 118 | | Some v -> v 119 | | None -> raise Not_found;; 120 | 121 | let thread thread_id n = 122 | let state = LuaL.newstate () in 123 | LuaL.openlibs state; 124 | Lua.pushinteger state n; 125 | Lua.setglobal state "param"; 126 | Lua.pushinteger state thread_id; 127 | Lua.setglobal state "thread_id"; 128 | LuaL.loadbuffer state lua_program "line" |> ignore; 129 | try 130 | match Lua.pcall state 0 0 0 with 131 | | Lua.LUA_OK -> () 132 | | err -> raise (Lua.Error err); 133 | with 134 | | Lua.Error _ -> 135 | begin 136 | Printf.printf "%s\n%!" ((Lua.tostring state (-1)) |> opt_get); 137 | Lua.pop state 1; 138 | failwith "FATAL ERROR" 139 | end; 140 | ;; 141 | 142 | let rec mkdir ?(parents=true) ?(permissions = 0o755) directory = 143 | let mkdir' ?(perm = 0o755) dir_name = 144 | try Unix.mkdir dir_name perm 145 | with Unix.Unix_error(Unix.EEXIST, _, _) -> () in 146 | 147 | let dir_name = Filename.dirname directory in 148 | try mkdir' ~perm:permissions directory 149 | with 150 | | Unix.Unix_error (Unix.EACCES, _, parameter) -> 151 | raise (Unix.Unix_error (Unix.EACCES, "mkdir", parameter)) 152 | | Unix.Unix_error (Unix.ENOENT, _, _) as e -> 153 | if parents then begin 154 | mkdir ~parents:parents ~permissions:permissions dir_name; 155 | Unix.mkdir directory permissions 156 | end else raise e 157 | ;; 158 | 159 | let main thread_num n = 160 | let thread_num = int_of_string thread_num in 161 | let n = int_of_string n in 162 | let th_list = ref [] in 163 | for i = 1 to thread_num do 164 | mkdir (spf "OUTPUT/thread_%05d" i); 165 | pf "Thread %d/%d starts\n%!" i thread_num; 166 | let t = Thread.create (thread i) n in 167 | th_list := t::!th_list; 168 | done; 169 | List.iter Thread.join !th_list; 170 | ;; 171 | 172 | try main Sys.argv.(1) Sys.argv.(2) 173 | with Invalid_argument _ -> begin 174 | Printf.eprintf "Usage: %s \n%!" (Sys.argv.(0)); 175 | exit 1; 176 | end 177 | -------------------------------------------------------------------------------- /tests/test_common.ml: -------------------------------------------------------------------------------- 1 | type debug_level = 2 | | Debug_only 3 | | User_info 4 | ;; 5 | 6 | let debug = Debug_only;; 7 | (* let debug = User_info;; *) 8 | 9 | let log = 10 | fun level -> 11 | let k m = 12 | match debug, level with 13 | | User_info, Debug_only -> () 14 | | _, _ -> Printf.printf "%s\n%!" m in 15 | Printf.ksprintf k 16 | ;; 17 | 18 | let sleep_float n = 19 | let _ = Unix.select [] [] [] n in () 20 | ;; 21 | 22 | let print_timings start_space start_wtime start_ptime = 23 | let end_ptime = Unix.times () in (* process time *) 24 | let self_u = end_ptime.Unix.tms_utime -. start_ptime.Unix.tms_utime in 25 | let self_s = end_ptime.Unix.tms_stime -. start_ptime.Unix.tms_stime in 26 | let self = self_u +. self_s in 27 | let child_u = end_ptime.Unix.tms_cutime -. start_ptime.Unix.tms_cutime in 28 | let child_s = end_ptime.Unix.tms_cstime -. start_ptime.Unix.tms_cstime in 29 | let child = child_u +. child_s in 30 | let run_time = self +. child in 31 | let real_time = Unix.time () -. start_wtime in (* wall time *) 32 | let real_time_sec = int_of_float real_time in 33 | let real_time_min = real_time_sec / 60 in 34 | let real_time_sec = real_time_sec mod 60 in 35 | let real_time_hrs = real_time_min / 60 in 36 | let real_time_min = real_time_min mod 60 in 37 | (* we would need a compaction if we were reporting memory usage *) 38 | (* Gc.compact (); *) 39 | let end_space = Gc.quick_stat () in 40 | log Debug_only "Run time: %f sec" run_time; 41 | log Debug_only "Self: %f sec" self; 42 | log Debug_only " sys: %f sec" self_u; 43 | log Debug_only " user: %f sec" self_s; 44 | log Debug_only "Children: %f sec" child; 45 | log Debug_only " sys: %f sec" child_u; 46 | log Debug_only " user: %f sec" child_s; 47 | log Debug_only "GC: minor: %d" 48 | (end_space.Gc.minor_collections - start_space.Gc.minor_collections); 49 | log Debug_only " major: %d" 50 | (end_space.Gc.major_collections - start_space.Gc.major_collections); 51 | log Debug_only " compactions: %d" 52 | (end_space.Gc.compactions - start_space.Gc.compactions); 53 | log Debug_only "Allocated: %.1f words" 54 | (end_space.Gc.minor_words +. end_space.Gc.major_words 55 | -. start_space.Gc.minor_words -. start_space.Gc.major_words 56 | -. end_space.Gc.promoted_words +. start_space.Gc.promoted_words); 57 | log Debug_only "Wall clock: %.0f sec (%02d:%02d:%02d)" 58 | real_time real_time_hrs real_time_min real_time_sec; 59 | if real_time > 0. then 60 | log Debug_only "Load: %.2f%%" (run_time *. 100.0 /. real_time) 61 | ;; 62 | 63 | (* Run function, then report time and space usage *) 64 | let run func args = 65 | Gc.compact (); (* so that prior execution does not skew the results *) 66 | let start_space = Gc.quick_stat () in 67 | let start_wtime = Unix.time () in (* wall time *) 68 | let start_ptime = Unix.times () in (* process time *) 69 | let ret = 70 | try func args 71 | with e -> print_timings start_space start_wtime start_ptime; 72 | raise e in 73 | print_timings start_space start_wtime start_ptime; 74 | ret 75 | ;; 76 | 77 | let string_list_eq l1 l2 = 78 | List.fold_left2 79 | (fun eq x1 x2 -> 80 | if eq = false 81 | then false 82 | else if Bytes.compare x1 x2 = 0 83 | then true 84 | else false) true l1 l2 85 | ;; 86 | 87 | let allocate ?(random=true) how_many str_len = 88 | let l = ref [] in 89 | for _i = 1 to how_many 90 | do 91 | let s = Bytes.create str_len in 92 | for j = 0 to (str_len - 1) do 93 | if random 94 | then Bytes.set s j (Char.chr (Random.int 256)) 95 | else Bytes.set s j 'x' 96 | done; 97 | l := s::(!l); 98 | done; 99 | !l 100 | ;; 101 | 102 | let allocate_a_lot () = allocate 47 9973;; 103 | 104 | let allocate_many_small () = allocate 9973 47;; 105 | 106 | -------------------------------------------------------------------------------- /tests/userdata.ml: -------------------------------------------------------------------------------- 1 | open Lua_api 2 | 3 | let (|>) x f = f x;; 4 | 5 | let allocate how_many str_len = 6 | let l = ref [] in 7 | for _i = 1 to how_many 8 | do 9 | let s = Bytes.create str_len in 10 | l := s::(!l); 11 | done; 12 | !l 13 | 14 | let allocate_a_lot () = allocate 499 99991 15 | let allocate_many_small () = allocate 99991 499 16 | 17 | module LuaBookDir = 18 | struct 19 | let readdir ls = 20 | let handle : Unix.dir_handle = 21 | let w = Lua.touserdata ls 1 in 22 | match w with 23 | | Some `Userdata h -> h 24 | | _ -> failwith "Dir handle expected!" in 25 | try Lua.pushstring ls (Unix.readdir handle); 1 26 | with End_of_file -> 0 27 | 28 | let dir_gc ls = 29 | let handle : Unix.dir_handle = 30 | let w = Lua.touserdata ls 1 in 31 | match w with 32 | | Some `Userdata h -> h 33 | | _ -> failwith "Dir handle expected!" in 34 | Unix.closedir handle; 35 | 0 36 | 37 | let ocaml_handle_gc h = 38 | Unix.closedir h 39 | 40 | let opendir ls = 41 | let path = LuaL.checkstring ls 1 in 42 | let handle = 43 | try Unix.opendir path 44 | with Unix.Unix_error (err, _, _) -> 45 | LuaL.error ls "cannot open %s: %s" path (Unix.error_message err) in 46 | Lua.newuserdata ls handle; 47 | LuaL.getmetatable ls "LuaBook.dir"; 48 | Lua.setmetatable ls (-2) |> ignore; 49 | 1 50 | 51 | let allocate_ocaml_data ls = 52 | let data1 = allocate_many_small () in 53 | let data2 = allocate_a_lot () in 54 | Lua.newuserdata ls data1; 55 | Lua.newuserdata ls data2; 56 | 1 57 | 58 | let gc_compact _ls = 59 | Printf.printf "Calling Gc.compact 2 times from Lua... %!"; 60 | Gc.compact (); 61 | Gc.compact (); 62 | Printf.printf "done!\n%!"; 63 | 0 64 | 65 | let luaopen_dir ls = 66 | (* metatable for "dir" *) 67 | LuaL.newmetatable ls "LuaBook.dir" |> ignore; 68 | Lua.pushstring ls "__gc"; 69 | Lua.pushocamlfunction ls (Lua.make_gc_function dir_gc); 70 | Lua.settable ls (-3) |> ignore; 71 | 72 | Lua.pushocamlfunction ls opendir; 73 | Lua.setglobal ls "opendir"; 74 | 75 | Lua.pushocamlfunction ls readdir; 76 | Lua.setglobal ls "readdir"; 77 | 78 | Lua.pushocamlfunction ls gc_compact; 79 | Lua.setglobal ls "gc_compact"; 80 | 81 | Lua.pushocamlfunction ls allocate_ocaml_data; 82 | Lua.setglobal ls "allocate_ocaml_data"; 83 | end;; 84 | 85 | let closure () = 86 | let l1 = LuaL.newstate () in 87 | LuaL.openlibs l1; 88 | LuaBookDir.luaopen_dir l1; 89 | LuaL.loadbuffer l1 "handle = opendir(\"/\") 90 | gc_compact() -- triggers a heap compaction of the OCaml GC 91 | d = readdir(handle) 92 | ocaml_data = allocate_ocaml_data() 93 | while d ~= nul do 94 | -- print(\"dir is: \" .. d) 95 | d = readdir(handle) 96 | end 97 | " "test_program" |> ignore; 98 | match Lua.pcall l1 0 0 0 with 99 | | Lua.LUA_OK -> () 100 | | _err -> begin 101 | Printf.printf "%s\n%!" (Lua.tostring l1 (-1) |> Option.value ~default:""); 102 | Lua.pop l1 1; 103 | failwith "FATAL ERROR" 104 | end 105 | ;; 106 | 107 | let print_timings start_space start_wtime start_ptime = 108 | let end_ptime = Unix.times () in (* process time *) 109 | let self_u = end_ptime.Unix.tms_utime -. start_ptime.Unix.tms_utime in 110 | let self_s = end_ptime.Unix.tms_stime -. start_ptime.Unix.tms_stime in 111 | let self = self_u +. self_s in 112 | let child_u = end_ptime.Unix.tms_cutime -. start_ptime.Unix.tms_cutime in 113 | let child_s = end_ptime.Unix.tms_cstime -. start_ptime.Unix.tms_cstime in 114 | let child = child_u +. child_s in 115 | let run_time = self +. child in 116 | let real_time = Unix.time () -. start_wtime in (* wall time *) 117 | let real_time_sec = int_of_float real_time in 118 | let real_time_min = real_time_sec / 60 in 119 | let real_time_sec = real_time_sec mod 60 in 120 | let real_time_hrs = real_time_min / 60 in 121 | let real_time_min = real_time_min mod 60 in 122 | (* we would need a compaction if we were reporting memory usage *) 123 | (* Gc.compact (); *) 124 | let end_space = Gc.quick_stat () in 125 | Printf.printf "Run time: %f sec\n%!" run_time; 126 | Printf.printf "Self: %f sec\n%!" self; 127 | Printf.printf " sys: %f sec\n%!" self_u; 128 | Printf.printf " user: %f sec\n%!" self_s; 129 | Printf.printf "Children: %f sec\n%!" child; 130 | Printf.printf " sys: %f sec\n%!" child_u; 131 | Printf.printf " user: %f sec\n%!" child_s; 132 | Printf.printf "GC: minor: %d\n%!" 133 | (end_space.Gc.minor_collections - start_space.Gc.minor_collections); 134 | Printf.printf " major: %d\n%!" 135 | (end_space.Gc.major_collections - start_space.Gc.major_collections); 136 | Printf.printf " compactions: %d\n%!" 137 | (end_space.Gc.compactions - start_space.Gc.compactions); 138 | Printf.printf "Allocated: %.1f words\n%!" 139 | (end_space.Gc.minor_words +. end_space.Gc.major_words 140 | -. start_space.Gc.minor_words -. start_space.Gc.major_words 141 | -. end_space.Gc.promoted_words +. start_space.Gc.promoted_words); 142 | Printf.printf "Wall clock: %.0f sec (%02d:%02d:%02d)\n%!" 143 | real_time real_time_hrs real_time_min real_time_sec; 144 | if real_time > 0. then 145 | Printf.printf "Load: %.2f%%\n%!" (run_time *. 100.0 /. real_time) 146 | ;; 147 | 148 | (* Run function, then report time and space usage *) 149 | let run func args = 150 | Gc.compact (); (* so that prior execution does not skew the results *) 151 | let start_space = Gc.quick_stat () in 152 | let start_wtime = Unix.time () in (* wall time *) 153 | let start_ptime = Unix.times () in (* process time *) 154 | let ret = 155 | try func args 156 | with e -> print_timings start_space start_wtime start_ptime; 157 | raise e in 158 | print_timings start_space start_wtime start_ptime; 159 | ret 160 | ;; 161 | 162 | let test_duration = 60.0 *. 10.0;; 163 | let time_start = Unix.gettimeofday ();; 164 | 165 | let main () = 166 | while Unix.gettimeofday () < time_start +. test_duration do 167 | closure () |> ignore; 168 | Printf.printf "Calling Gc.compact from OCaml... %!"; 169 | Gc.compact (); 170 | Printf.printf "done!\n%!"; 171 | done; 172 | Gc.compact (); 173 | ;; 174 | 175 | run main () 176 | 177 | --------------------------------------------------------------------------------