├── .gitignore ├── .gitmodules ├── LICENSE ├── Makefile ├── README.md ├── doc ├── README.md ├── lua-2.5-refman.pdf └── noweb │ ├── lua.nw │ ├── luaast.nw │ ├── luabaselib.nw │ ├── luacamllib.nw │ ├── luaclient.nw │ ├── luahash.nw │ ├── luaiolib.nw │ ├── lualib.nw │ ├── luamathlib.nw │ ├── luarun.nw │ ├── luasrcmap.nw │ ├── luastdinterp.nw │ ├── luastrlib.nw │ ├── luasyntax.nw │ └── luavalue.nw ├── dune-project ├── example ├── dune └── luaclient.ml ├── lua-ml.opam └── src ├── dune ├── lua-std.mllib ├── lua.ml ├── lua.mli ├── luaast.ml ├── luaast.mli ├── luabaselib.ml ├── luabaselib.mli ├── luacamllib.ml ├── luacamllib.mli ├── luafloat.mll ├── luainterp.ml ├── luainterp.mli ├── luaiolib.ml ├── luaiolib.mli ├── lualib.ml ├── lualib.mli ├── luamathlib.ml ├── luamathlib.mli ├── luaparser.ml ├── luaparser.mli ├── luaparser_impl.mly ├── luaparser_tokens.mly ├── luarun.ml ├── luarun.mli ├── luascanner.mll ├── luasrcmap.ml ├── luasrcmap.mli ├── luastrlib.ml ├── luastrlib.mli ├── luavalue.ml └── luavalue.mli /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | _opam 3 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "lipsum"] 2 | path = lipsum 3 | url = https://github.com/lindig/lipsum.git 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019 Lua-ML contributors. 2 | Portions copyright 2000-2007 Norman Ramsey et al. 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | 1. Redistributions of source code must retain the above copyright notice, this 9 | list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright notice, 12 | this list of conditions and the following disclaimer in the documentation 13 | and/or other materials provided with the distribution. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 16 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 17 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 19 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 20 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 21 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 22 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 23 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 24 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all 2 | all: lib example 3 | 4 | .PHONY: lib 5 | lib: 6 | dune build @all 7 | 8 | .PHONY: example 9 | example: 10 | dune build example/luaclient.exe 11 | 12 | .PHONY: clean 13 | clean: 14 | dune clean 15 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Lua-ML 2 | 3 | Lua-ML is an implementation of the [Lua](https://www.lua.org) 2.5 programming 4 | language written in [OCaml](https://ocaml.org) and designed for extending 5 | OCaml programs. 6 | 7 | Highly configurable programs like games, text editors, or test generators 8 | require extensibility since it's not possible to include functionality for every possible 9 | use case. 10 | 11 | For many such programs, embedding a small general purpose language can be a better option than implementing their own DSL, and definitely better than creating an accidentally Turing-complete configuration file format. 12 | 13 | ## Overview 14 | 15 | Lua-ML is **not** a set of bindings for the PUC-Rio implementation written in C. 16 | It's a complete implementation of a Lua 2.5 interpreter and runtime in OCaml. 17 | 18 | This has a number of advantages: 19 | 20 | ### Modular runtime library 21 | 22 | The Lua library is not a single module, but a set of OCaml modules and functors. 23 | That allows you to exclude some modules from the runtime, add your own modules, or even completely replace the default standard library with your own modules. 24 | 25 | ### Type and memory safety 26 | 27 | Registering functions and passing (embedding) values to Lua is as type safe as 28 | everything else in OCaml, so errors in interfacing with Lua are caught at compile time. 29 | 30 | Since there is no unmanaged code involved, Lua code cannot crash its host program 31 | or access memory it's not supposed to access (assuming there are no memory safety bugs 32 | in the OCaml runtime of course). 33 | 34 | It *should* be safe to use it even for untrusted scripts, if you don't include 35 | modules like `Luaiolib` into the runtime. Of course, you still should exercise 36 | extreme caution if you actually choose to run untrusted scripts. 37 | 38 | ### Resistance to bit rot 39 | 40 | Bindings usually require a specific version of the PUC-Rio implementation (e.g. 5.1) 41 | and may stop working with newer versions, which makes software harder to build 42 | and introduces new maintenance costs. 43 | 44 | A pure OCaml implementation doesn't have that problem. The fact that this project 45 | was revived with minimal effort after more than a decade of dormancy is telling. 46 | 47 | ### Disadvantages 48 | 49 | * Incompatible with existing Lua libraries. 50 | * Impelements, at this time, only antiquated Lua 2.5. 51 | 52 | ## Project status 53 | 54 | Lua-ML is usable and works quite well, but there's still room for improvement, 55 | especially in error reporting. 56 | 57 | It doesn't make an API stability promise _yet_, which is why the versions are 58 | 0.9.x. I do promise to keep breaking changes to the minimum, 59 | but there's a chance they will be necessary. 60 | 61 | One problem with backporting improvements from post-2.5 Lua specifications 62 | is that PUC-Rio Lua itself made a bunch of incompatible change on the way, 63 | so future direction requires a discussion with the user community. 64 | 65 | ## Installation 66 | 67 | ``` 68 | opam install lua-ml 69 | ``` 70 | 71 | ## Usage 72 | 73 | There isn't much documentation now. Any help is welcome! 74 | 75 | For an example application, take a look at `example/luaclient.ml`. It shows how to provide 76 | a custom type (2-tuple) as userdata, register your own module, and run Lua code. 77 | 78 | ```sh 79 | dune exec example/luaclient.exe 80 | ``` 81 | 82 | You can also read the original papers by Norman Ramsey: 83 | * [Embedding an Interpreted Language Using Higher-Order Functions and Types](https://www.cs.tufts.edu/~nr/pubs/embedj-abstract.html) 84 | * [ML Module Mania: A Type-Safe, 85 | Separately Compiled, Extensible Interpreter](https://www.cs.tufts.edu/~nr/pubs/maniaws-abstract.html) 86 | 87 | Lua-ML once was a literate program and a snapshot of the last pre-revival NoWeb version 88 | is kept in `docs/noweb`. There's no easy way to make a PDF out of it, but reading the NoWeb 89 | source can give a good insight into the internals. 90 | 91 | A real life example of a project using Lua-ML is [soupault](https://github.com/dmbaturin/soupault), 92 | a native but extensible static site generator/HTML processor. 93 | It exposes the element tree of the page as an abstract type (userdata) and makes HTML manipulation 94 | functions from [lambdasoup](https://github.com/aantron/lambdasoup) available to plugins. 95 | 96 | Historical examples that used older Lua-ML versions include: 97 | * [Quest Test Code Generator](http://code.google.com/p/quest-tester/) 98 | * [C-- Compiler](http://web.archive.org/web/20150501125322/http://www.cminusminus.org/) 99 | 100 | 101 | ## History and Authors 102 | 103 | Lua-ML was developed as part of the [C-- compiler](http://web.archive.org/web/20150501125322/http://www.cminusminus.org/) 104 | project developed by [Norman Ramsey](https://www.cs.tufts.edu/~nr/) and was part of its source code. 105 | The complicated build process of C-- made it hard to build and use in other programs. 106 | 107 | Then Christian Lindig, who also worked on C-- from 2000 to 2002, extracted it from C-- and reworked it into a standalone library to preserve it and make easier to use. 108 | 109 | In 2018-2019, effort of Gabriel Radanne and Daniil Baturin allowed Lua-ML to build with modern OCaml and become an OPAM package. 110 | 111 | The current maintainer is Daniil Baturin . 112 | 113 | ## Copyright 114 | 115 | Lua-ML is distributed under the two-clause BSD license. 116 | See the LICENSE file for details. 117 | -------------------------------------------------------------------------------- /doc/README.md: -------------------------------------------------------------------------------- 1 | 2 | # README 3 | 4 | This directory contains documentation 5 | 6 | ## Lua 2.5 Reference Manual 7 | 8 | This is the original Lua 2.5 reference manual and is copyrighted by its 9 | authors. You can find it also online at the [Lua home 10 | page](http://www.lua.org/ftp/). 11 | 12 | ## Lua - an extensible extension language 13 | 14 | Published in Software: Practice & Experience 26 #6 (1996) 635–652 by Roberto 15 | Ierusalimschy, Luiz Henrique de Figueiredo, Waldemar Celes Filho. 16 | 17 | Abstract. This paper describes Lua, a language for extending applications. Lua 18 | combines procedural features with powerful data description facilities, by 19 | using a simple, yet powerful, mechanism of tables. This mechanism implements 20 | the concepts of records, arrays, and recursive data types (pointers), and adds 21 | some object-oriented facilities, such as methods with dynamic dispatching. Lua 22 | presents a mechanism of fallbacks that allows programmers to extend the 23 | semantics of the language in some unconventional ways. As a noteworthy 24 | example, fallbacks allow the user to add different kinds of inheritance to the 25 | language. Currently, Lua is being extensively used in production for several 26 | tasks, including user configuration, general-purpose data-entry, description 27 | of user interfaces, storage of structured graphical metafiles, and generic 28 | attribute configuration for finite element meshes. 29 | 30 | [Lua - an extensible extension language](http://www.lua.org/spe.html) is 31 | available from the Lua home page. 32 | 33 | 34 | 35 | 36 | 37 | -------------------------------------------------------------------------------- /doc/lua-2.5-refman.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lindig/lua-ml/3e1024011ae6cf89fb86d049759360021ec2656b/doc/lua-2.5-refman.pdf -------------------------------------------------------------------------------- /doc/noweb/luaast.nw: -------------------------------------------------------------------------------- 1 | % -*- mode: Noweb; noweb-code-mode: caml-mode -*- 2 | 3 | % Grades ::= "%%Grades:" Quality Importance Urgency 4 | % Quality ::= A|B|C|D|E 5 | % Importance ::= Central|Subsystem|Peripheral 6 | % Urgency ::= Immediate|Soon|Later 7 | % 8 | % Example (at beginning of line): %%Grades: B Central Soon 9 | \section{Abstract syntax for Lua} 10 | 11 | <>= 12 | module type S = sig 13 | module Value : Luavalue.S 14 | type value = Value.value 15 | <> 16 | end 17 | @ 18 | <>= 19 | <> 20 | module Make (V : Luavalue.S) : S with module Value = V 21 | @ 22 | <>= 23 | <> 24 | module Make (V : Luavalue.S) : S with module Value = V = struct 25 | module Value = V 26 | type value = Value.value 27 | <> 28 | end 29 | @ 30 | <>= 31 | type name = string 32 | type location = int (* character position *) 33 | type stmt = 34 | | Stmt' of location * stmt 35 | | Assign of lval list * exp list 36 | | WhileDo of exp * block 37 | | RepeatUntil of block * exp 38 | | If of exp * block * (exp * block) list * block option 39 | | Return of exp list 40 | | Callstmt of call 41 | | Local of name list * exp list 42 | and block = stmt list 43 | and lval = 44 | | Lvar of name 45 | | Lindex of exp * exp 46 | and exp = 47 | | Var of name 48 | | Lit of value 49 | | Binop of exp * op * exp 50 | | Unop of op * exp 51 | | Index of exp * exp 52 | | Table of exp list * (name * exp) list 53 | | Call of call 54 | and call = 55 | | Funcall of exp * exp list 56 | | Methcall of exp * name * exp list 57 | and op = And | Or | Lt | Le | Gt | Ge | Eq | Ne | Concat 58 | | Plus | Minus | Times | Div | Not | Pow 59 | 60 | type chunk = 61 | | Debug of bool (* turn debugging on/off *) 62 | | Statement of stmt 63 | | Fundef of location * lval * name list * varargs * block 64 | | Methdef of location * exp * name * name list * varargs * block 65 | and varargs = bool 66 | @ 67 | -------------------------------------------------------------------------------- /doc/noweb/luabaselib.nw: -------------------------------------------------------------------------------- 1 | % -*- mode: Noweb; noweb-code-mode: caml-mode -*- 2 | % Grades ::= "%%Grades:" Quality Importance Urgency 3 | % Quality ::= A|B|C|D|E 4 | % Importance ::= Central|Subsystem|Peripheral 5 | % Urgency ::= Immediate|Soon|Later 6 | % 7 | % Example (at beginning of line): %%Grades: B Central Soon 8 | 9 | <>= 10 | module Add (MakeParser : Luaparser.MAKER) (I : Luainterp.S) : sig 11 | include Luainterp.S 12 | module Parser : Luaparser.S with type chunk = Ast.chunk 13 | val do_lexbuf : sourcename:string -> state -> Lexing.lexbuf -> value list 14 | val dostring : state -> string -> value list 15 | val dofile : state -> string -> value list 16 | val mk : unit -> state (* builds state and runs startup code *) 17 | end with module Value = I.Value 18 | <>= 19 | module Add (MakeParser : Luaparser.MAKER) (I : Luainterp.S) = struct 20 | module Parser = MakeParser (I.Ast) 21 | module P = Parser 22 | module V = I.Value 23 | <> 24 | let ( **-> ) = V.( **-> ) 25 | let ( **->> ) x y = x **-> V.result y 26 | 27 | let next t key = 28 | let k, v = 29 | try match key with 30 | | V.Nil -> Luahash.first t 31 | | _ -> Luahash.next t key 32 | with Not_found -> V.Nil, V.Nil 33 | in [k; v] 34 | 35 | let objname g v = 36 | let tail = [] in 37 | let ss = match V.objname g v with 38 | | Some (V.Fallback n) -> "`" :: n :: "' fallback" :: tail 39 | | Some (V.Global n) -> "function " :: n :: tail 40 | | Some (V.Element (t, V.String n)) -> "function " :: t :: "." :: n :: tail 41 | | Some (V.Element (t, v)) -> "function " :: t :: "[" :: V.to_string v :: "]" :: tail 42 | | None -> "unnamed " :: V.to_string v :: tail in 43 | String.concat "" ss 44 | 45 | 46 | 47 | let luabaselib g = 48 | [ "dofile", V.efunc (V.string **-> V.resultvs) (dofile g) 49 | ; "dostring", V.efunc (V.string **-> V.resultvs) (dostring g) 50 | (* should catch Sys_error and turn into an error fallback... *) 51 | ; "size", V.efunc (V.table **->> V.int) Luahash.population 52 | ; "next", V.efunc (V.table **-> V.value **-> V.resultvs) next 53 | ; "nextvar", V.efunc (V.value **-> V.resultvs) (fun x -> next g.V.globals x) 54 | ; "tostring", V.efunc (V.value **->> V.string) V.to_string 55 | ; "objname", V.efunc (V.value **->> V.string) (objname g) 56 | ; "print", V.caml_func 57 | (fun args -> 58 | List.iter (fun x -> print_endline (V.to_string x)) args; 59 | flush stdout; 60 | []) 61 | ; "tonumber", V.efunc (V.float **->> V.float) (fun x -> x) 62 | ; "type", V.efunc (V.value **->> V.string) 63 | (function 64 | | V.Nil -> "nil" 65 | | V.Number _ -> "number" 66 | | V.String _ -> "string" 67 | | V.Table _ -> "table" 68 | | V.Function (_,_) -> "function" 69 | | V.Userdata _ -> "userdata") 70 | ; "assert", V.efunc (V.value **-> V.default "" V.string **->> V.unit) 71 | (fun c msg -> match c with 72 | | V.Nil -> I.error ("assertion failed: " ^ msg) 73 | | _ -> ()) 74 | ; "error", V.efunc (V.string **->> V.unit) I.error 75 | ; "setglobal", V.efunc (V.value **-> V.value **->> V.unit) 76 | (fun k v -> V.Table.bind g.V.globals k v) 77 | ; "getglobal", V.efunc (V.value **->> V.value) (I.getglobal g) 78 | ; "setfallback", V.efunc (V.string **-> V.value **->> V.value) (I.setfallback g) 79 | ] 80 | 81 | include I 82 | let mk () = 83 | let g, init = I.pre_mk () in 84 | I.register_globals (luabaselib g) g; 85 | init (fun s -> ignore (dostring g s)); 86 | g 87 | end 88 | <>= 89 | let lex map buf = Luascanner.token buf map 90 | let do_lexbuf ~sourcename:filename g buf = 91 | let map = Luasrcmap.mk () in 92 | let _ = Luasrcmap.sync map 0 (filename, 1, 1) in 93 | try 94 | let chunks = P.chunks (lex map) buf in 95 | let pgm = I.compile ~srcdbg:(map, false) chunks g in 96 | match pgm () with 97 | | [] -> [I.Value.String "executed without errors"] 98 | | answers -> answers 99 | with 100 | | Parsing.Parse_error -> 101 | let file, line, _ = Luasrcmap.last map in begin 102 | prerr_string file; 103 | prerr_string ", line "; 104 | prerr_int line; 105 | prerr_endline ": syntax error"; 106 | [] 107 | end 108 | | I.Error s -> (prerr_endline "Lua interpreter halted with error"; []) 109 | | I.Value.Projection (v, w) -> (prerr_endline ("error projecting to " ^ w); []) 110 | 111 | 112 | let dostring g s = 113 | let abbreviate s = 114 | if String.length s < 200 then s 115 | else String.sub s 0 60 ^ "..." in 116 | I.with_stack (V.srcloc ("dostring('" ^ abbreviate s ^ "')") 0) g 117 | (do_lexbuf ~sourcename:"" g) (Lexing.from_string s) 118 | 119 | let dofile g infile = 120 | try 121 | let f = match infile with "-" -> stdin | _ -> open_in infile in 122 | let close () = if infile <> "-" then close_in f else () in 123 | try 124 | let answer = I.with_stack (V.srcloc ("dofile('" ^ infile ^ "')") 0) g 125 | (do_lexbuf ~sourcename:infile g) (Lexing.from_channel f) 126 | in (close(); answer) 127 | with e -> (close (); raise e) 128 | with Sys_error msg -> [V.Nil; V.String ("System error: " ^ msg)] 129 | @ 130 | -------------------------------------------------------------------------------- /doc/noweb/luacamllib.nw: -------------------------------------------------------------------------------- 1 | % -*- mode: Noweb; noweb-code-mode: caml-mode -*- 2 | 3 | % Grades ::= "%%Grades:" Quality Importance Urgency 4 | % Quality ::= A|B|C|D|E 5 | % Importance ::= Central|Subsystem|Peripheral 6 | % Urgency ::= Immediate|Soon|Later 7 | % 8 | % Example (at beginning of line): %%Grades: B Central Soon 9 | 10 | \section{Excerpts from the Caml library, imported into Lua} 11 | 12 | <>= 13 | module Make (TV : Lua.Lib.TYPEVIEW with type 'a t = 'a Luaiolib.t) 14 | : Lua.Lib.USERCODE with type 'a userdata' = 'a TV.combined 15 | @ 16 | <>= 17 | module IO = Luaiolib 18 | @ 19 | <>= 20 | let file = T.makemap V.userdata V.projection in 21 | let infile = IO.in' file V.projection in 22 | let outfile = IO.out file V.projection in 23 | let ( **->> ) x y = x **-> V.result y in 24 | let a = V.value in 25 | let b = V.value in 26 | let list = V.list in 27 | let string = V.string in 28 | let int = V.int in 29 | let bool = V.bool in 30 | let ef = V.efunc in 31 | let caml_modules = 32 | let swap (x, y) = (y, x) in 33 | List.map (fun (m, vs) -> (m, V.Table (V.Table.of_list (List.map swap vs)))) 34 | ["Filename", 35 | (let extension s = 36 | try 37 | let without = Filename.chop_extension s in 38 | let n = String.length without in 39 | String.sub s n (String.length s - n) 40 | with Invalid_argument _ -> "" in 41 | let chop s = try Filename.chop_extension s with Invalid_argument _ -> s in 42 | [ ef (string **-> string **->> V.bool) Filename.check_suffix, "check_suffix" 43 | ; ef (string **->> string) chop, "chop_extension" 44 | ; ef (string **->> string) extension, "extension" 45 | ; ef (string **-> string **->> string) Filename.concat, "concat" 46 | ; ef (string **->> string) Filename.basename, "basename" 47 | ; ef (string **->> string) Filename.dirname, "dirname" 48 | ; ef (string **-> string **->> string) Filename.temp_file, "temp_file" 49 | ; ef (string **->> string) Filename.quote, "quote" 50 | ]) 51 | ; "List", 52 | [ ef (list a **->> int) List.length, "length" 53 | ; ef (list a **->> list a) List.rev, "rev" 54 | ; ef (list a **-> list a **->> list a) List.append, "append" 55 | ; ef (list a **-> list a **->> list a) List.rev_append, "rev_append" 56 | ; ef (list (list a) **->> list a) List.concat, "concat" 57 | ; ef ((a --> b) **-> list a **->> list b) List.map, "map" 58 | ; ef ((a --> V.unit) **-> list a **->> V.unit) List.iter, "iter" 59 | ; ef ((a --> b) **-> list a **->> list b) List.rev_map, "rev_map" 60 | ; ef ((a --> bool) **-> list a **->> bool) List.for_all, "for_all" 61 | ; ef ((a --> bool) **-> list a **->> bool) List.exists, "exists" 62 | ; ef ((a --> bool) **-> list a **->> list a) List.filter, "filter" 63 | ; ef (V.func (a **-> a **->> int) **-> list a **->> list a) List.sort, "sort" 64 | ; ef (V.func (a **-> a **->> int) **-> list a **->> list a) List.stable_sort, 65 | "stable_sort" 66 | ] 67 | ] in 68 | @ 69 | <>= 70 | module Make (T : Lua.Lib.TYPEVIEW with type 'a t = 'a Luaiolib.t) 71 | : Lua.Lib.USERCODE with type 'a userdata' = 'a T.combined = 72 | struct 73 | type 'a userdata' = 'a T.combined 74 | module M (C : Lua.Lib.CORE with type 'a V.userdata' = 'a userdata') = 75 | struct 76 | module V = C.V 77 | let ( **-> ) = V.( **-> ) 78 | let ( --> ) = V.( --> ) 79 | let init = 80 | <> 81 | C.register_module "Caml" caml_modules 82 | end (*M*) 83 | end (*Make*) 84 | @ 85 | -------------------------------------------------------------------------------- /doc/noweb/luaclient.nw: -------------------------------------------------------------------------------- 1 | % -*- mode: Noweb; noweb-code-mode: caml-mode -*- 2 | 3 | \documentclass[11pt]{article} 4 | \usepackage{noweb} 5 | \usepackage{alltt} 6 | \usepackage{path} 7 | 8 | \newcommand\ocaml{{\small OCAML}} 9 | 10 | \noweboptions{smallcode,breakcode} 11 | 12 | \title{A Sample Client for Lua-ML} 13 | \author{Christian Lindig \\ \texttt{lindig@eecs.harvard.edu}} 14 | 15 | % ------------------------------------------------------------------ 16 | \begin{document} 17 | \maketitle 18 | % ------------------------------------------------------------------ 19 | 20 | This document demonstrates how to extend and embed a Lua interpreter 21 | into an {\ocaml} application. We regard this document as a 22 | complement to the more detailed documents [[lua.nw]] and [[newlib.nw]] 23 | that document the general case while we focus on the simpler common 24 | case. 25 | 26 | \section{Prerequisites} 27 | 28 | The Lua interpreter comes as a library [[lua-std.cma]] and many 29 | interface files [[lua*.cmi]]. All must be found by the {\ocaml} 30 | compiler; the compiler can be directed to the library using the [[-I]] 31 | flag. When compiling for native code, the Lua interpreter comes as the 32 | additional files [[lua-std.cmxa]] and [[lua-std.a]]. 33 | 34 | When we assume that our application is implemented by a module 35 | [[Luaclient]] whose source code resides in [[luaclient.ml]], our [[Makefile]] 36 | looks like this: 37 | 38 | <>= 39 | INTERP = std 40 | OCAMLC = ocamlc 41 | OCAMLC_FLAGS = 42 | 43 | luaclient: lua-$(INTERP).cma luaclient.cmo 44 | $(OCAMLC) $(OCAMLC_FLAGS) -o $@ unix.cma lua-$(INTERP).cma luaclient.cmo 45 | @ 46 | 47 | The [[Makefile]] links together the [[luaclient]] binary from the library, 48 | the application code, and the Unix module that is required by the Lua 49 | code. 50 | 51 | \section{The Big Picture} 52 | 53 | The Lua interpreter is highly functorized and must be linked together 54 | before it can be used. Since we want to use Lua to control our 55 | application, we have to extend the Lua interpreter with new primitives 56 | that our application implements. These extensions, too, have to be 57 | linked into the interpreter. At run time, finally, we have to pass 58 | control to the newly created interpreter. 59 | 60 | <>= 61 | <> 62 | 63 | let main () = 64 | let argv = Array.to_list Sys.argv in 65 | let args = List.tl argv in 66 | let state = I.mk () in (* fresh Lua interpreter *) 67 | let eval e = ignore (I.dostring state e) in 68 | ( List.iter eval args 69 | ; exit 0 70 | ) 71 | 72 | let _ = main () (* alternatively use: module G = Lua.Run(I) *) 73 | @ 74 | 75 | The interpreter implementation resides in module [[I]]. Several active 76 | interpreters can co-exist because the global state for an interpreter is 77 | kept as an explicit value. In our simple [[main]] function we create a 78 | new interpreter (state) and evaluate all command line arguments inside. 79 | In a more realistic application we probably would evaluate some startup 80 | code from a file. In any case, the code we evaluate can use new 81 | primitives that we have added to the interpreter and therefore controls 82 | our application. 83 | 84 | If we just want to type in Lua code interactively we don't even need to 85 | write our own [[main]]. Instead, we can use 86 | 87 | $$[[module G = Lua.Run(I)]]$$ 88 | 89 | which adds a [[main]] function with a read-eval-print loop. 90 | 91 | As an example for application-specific data types, we add two new Lua 92 | types to the interpreter. A character type (Lua only knows strings), and 93 | a polymorphic pair type. Both come with functions to create and observe 94 | them. 95 | 96 | From a Lua user's point of view the two new types are so-called [[userdata]] 97 | types whose values are accessed from funtions in the tables [[Char]] and 98 | [[Pair]] that act as modules. For example, [[x=Pair.mk("one",2)]] creates a pair 99 | value of a string and a number. Each component can be observed by 100 | [[Pair.fst(x)]] and [[Pair.snd(x)]], respectively. 101 | 102 | \section{Linking together the interpreter} 103 | 104 | An interpreter is linked together from a parser and a core, which in 105 | turn takes our user-defined types [[T]] and a library module [[L]] that 106 | depends on them. We will almost always use the standard parser such that 107 | the main task is to construct new types and code that uses them. 108 | 109 | <>= 110 | <> 111 | <> 112 | 113 | module I = (* interpreter *) 114 | Lua.MakeInterp 115 | (Lua.Parser.MakeStandard) 116 | (Lua.MakeEval (T) (C)) 117 | @ 118 | 119 | Each user-supplied Lua type is implemented in a module of its own. We link 120 | all of them together into one module [[T]] that we pass into the 121 | [[MakeCore]] functor. The [[T]] module contains sub-modules, one for each 122 | argument, that we name for convenience. 123 | 124 | <>= 125 | <> 126 | <> 127 | 128 | module T = (* new types *) 129 | Lua.Lib.Combine.T3 (* T3 == link 3 modules *) 130 | (LuaChar) (* TV1 *) 131 | (Pair) (* TV2 *) 132 | (Luaiolib.T) (* TV3 *) 133 | 134 | module LuaCharT = T.TV1 135 | module PairT = T.TV2 136 | module LuaioT = T.TV3 137 | @ 138 | 139 | The primitive types and functions supplied by the standard interpreter 140 | are themselves split across several modules. Thus, we could build an 141 | extra-small interpreter by omitting what we don't use. Usually we want 142 | all we can get and link [[L]] together like here: 143 | 144 | <>= 145 | <> 146 | module W = Lua.Lib.WithType (T) 147 | module C = 148 | Lua.Lib.Combine.C5 (* C5 == combine 4 code modules *) 149 | (Luaiolib.Make(LuaioT)) 150 | (Luacamllib.Make(LuaioT)) 151 | (W (Luastrlib.M)) 152 | (W (Luamathlib.M)) 153 | (MakeLib (LuaCharT) (PairT)) 154 | @ 155 | 156 | The IO, math, and string library are standard; our own code resides in 157 | [[MakeLib]] and is parametrized over the new Lua types ([[LuaCharT]], 158 | [[PairT]]) that we have introduced. Because the string and math 159 | libraries have signature [[Lua.BARE]] they need to be extended with a 160 | type (any will do), before they can be combined with others. 161 | 162 | \section{New primitive types and functions} 163 | 164 | Most of the code above provides necessary infrastructure. The real work 165 | is implementing new primitive Lua types and functions. 166 | 167 | Most often we want to add not just new functionality but add also an 168 | application-specific type to the Lua interpreter. Each type is 169 | represented by a module of module type [[Lua.USERDATA]]. As an example, 170 | we add a new type that represent characters. The [[LuaChar]] module 171 | provides: an {\ocaml} representation for the new type, a name of the 172 | type, an equality predicate, and a function to represent a datum as a 173 | string. 174 | 175 | <>= 176 | module LuaChar = struct 177 | type 'a t = char 178 | let tname = "char" 179 | let eq _ = fun x y -> x = y 180 | let to_string = fun _ c -> String.make 1 c 181 | end 182 | @ 183 | 184 | As a somewhat more complicated example we also add a polymorphic pair 185 | that works with all Lua values. Although we don't know the 186 | representation of Lua values here, we do know that the type parameter 187 | [['a]] of [[t]] represents the actual value data type of the 188 | interpreter. Therefore, our representation is simply a polymorphic pair. 189 | The foresight of the interpreter's designer also helps us with the 190 | problem of printing values in the [[to_string]] function: the first 191 | parameter [[f]] to [[to_string]] is a function that prints any value, 192 | such that [[(f x)]] gives us the string of value [[x]]. 193 | 194 | Usually we have functions to work with the new types. We can implement 195 | them outside or inside the module that provides the type. In the case of 196 | [[Pair]], we added [[mk]], [[fst]], and [[snd]]. 197 | 198 | <>= 199 | module Pair = struct 200 | type 'a t = 'a * 'a 201 | let tname = "pair" 202 | let eq _ = fun x y -> x = y 203 | let to_string = fun f (x,y) -> Printf.sprintf "(%s,%s)" (f x) (f y) 204 | let mk x y = (x,y) 205 | let fst = fst 206 | let snd = snd 207 | end 208 | @ 209 | 210 | The approved way to link together the modules that extend an interpreter 211 | is to write a [[MakeLib]] functor. It has an argument for each new type, where 212 | each but the first one comes with a sharing constraint for the 213 | [[combined]] type. Intuitively, these constraints ensure that all 214 | modules use the same representation for values in the interpreter. 215 | 216 | Note, that the arguments to [[MakeLib]] are \emph{not} the modules 217 | [[LuaChar]] and [[Pair]] that we just have defined, but the ones 218 | re-exported by the \path|Lua.Lib.Combine.T|$n$ functor. 219 | 220 | <>= 221 | module MakeLib 222 | (CharV: Lua.Lib.TYPEVIEW with type 'a t = 'a LuaChar.t) 223 | (PairV: Lua.Lib.TYPEVIEW with type 'a t = 'a Pair.t 224 | and type 'a combined = 'a CharV.combined) 225 | : Lua.Lib.USERCODE with type 'a userdata' = 'a CharV.combined = struct 226 | 227 | type 'a userdata' = 'a PairV.combined 228 | module M (C: Lua.Lib.CORE with type 'a V.userdata' = 'a userdata') = struct 229 | module V = C.V 230 | let ( **-> ) = V.( **-> ) 231 | let ( **->> ) x y = x **-> V.result y 232 | <> 233 | end (* M *) 234 | end (* MakeLib *) 235 | @ 236 | 237 | Finally we have to register the new functions in the interpreter. The 238 | most important aspect is the conversion back and forth between the value 239 | representation in the interpreter, and our (much simpler) representation 240 | that we have provided in [[LuaChar]] and [[Pair]]. It is good practice 241 | to collect these conversion functions into one module [[Map]] with a 242 | function for each type. 243 | 244 | <>= 245 | module Map = struct 246 | let pair = PairV.makemap V.userdata V.projection 247 | let char = CharV.makemap V.userdata V.projection 248 | end 249 | 250 | let init g = 251 | <> 252 | <> 253 | <> 254 | @ 255 | 256 | Once we have [[Map]], we can provide a mapping between a Lua name like 257 | [[Pair.mk]] and its {\ocaml} implementation. The [[register_module]] 258 | function takes a list of (name, value) pairs, where a value can be a 259 | function. The conversion between the interpreter's internal 260 | representation and our's is provided by a clever infix function [[**->]] 261 | that makes the conversion function look like a function type. The 262 | [[Map]] module is here essential to name the user-defined argument 263 | types. 264 | 265 | <>= 266 | C.register_module "Pair" 267 | [ "mk", V.efunc (V.value **-> V.value **->> Map.pair) Pair.mk 268 | ; "fst",V.efunc (Map.pair **->> V.value) Pair.fst 269 | ; "snd",V.efunc (Map.pair **->> V.value) Pair.snd 270 | ] g; 271 | @ 272 | 273 | The registration of the [[Char]] module shows how to deal with errors in 274 | conversions. [[Char.mk]] expects a string whose first character is used 275 | to create the new character value. But what if this string is empty? We 276 | catch this problem here where we have the core interpreters's [[error]] 277 | function available, rather in [[LuaChar]], where we don't. The argument 278 | [[g]] is the global interpreter state that must be passed to [[error]]. 279 | State [[g]] is an argument to [[init]] inside whose body we are. Error 280 | reporting isn't a problem for [[Pair]] because all functions in [[Pair]] 281 | are total. 282 | 283 | <>= 284 | C.register_module "Char" 285 | [ "mk", V.efunc (V.string **->> Map.char) 286 | (function 287 | | "" -> C.error "Char.mk: empty string" 288 | | s -> s.[0] 289 | ) 290 | ] g; 291 | @ 292 | 293 | Sometimes we want to add functionality for existing types without adding 294 | a new type. This case is easy because we simply can add the new 295 | functions without having to define extra modules for types. As an 296 | example, we provide some functions from the {\ocaml} standard 297 | library. To avoid name space pollution we introduce an extra layer 298 | [[Example]]. 299 | <>= 300 | C.register_module "Example" 301 | ["argv", (V.list V.string).V.embed (Array.to_list Sys.argv); 302 | "getenv", V.efunc (V.string **->> V.string) Sys.getenv; 303 | ] g; 304 | @ 305 | 306 | With all explanations the client of our interpreter looks quite big. In fact, 307 | it is just about 100 lines long. Taking a look at the [[luaclient.ml]] 308 | gives us the more linear perspective of the compiler which is also 309 | instructive to understand this code. 310 | 311 | \section{Running the interpreter} 312 | 313 | After we have compiled and linked our client with the [[lua-std.cma]] 314 | library we can run it. Our [[main]] function simply evaluates all 315 | command line arguments from left to right. The example below shows, that 316 | our extensions are indeed part of the interpreter. 317 | 318 | <>= 319 | % ./luaclient 'c=Char.mk("x")' 'print(c)' 320 | x 321 | 322 | % ./luaclient 'x=Pair.mk("one",2)' 'print(x)' 'print(Pair.fst(x))' 323 | (one,2) 324 | one 325 | 326 | % ./luaclient 'print(Caml.Filename.chop_extension("foo.bar"))' 327 | foo 328 | @ 329 | 330 | If your Lua code is in a file, a [[dofile("file.lua")]] will make the 331 | interpreter read and execute it. This is useful for repetitive testing. 332 | 333 | \section{Further reading} 334 | 335 | This document provides a first recipe to embed the Lua interpreter into 336 | an application but it cannot explain every detail. The next document you 337 | should try to understand is Section 1.1 Values in [[lua.nw]] that 338 | documents the Lua {\small API}. In particular, Section 1.1 lists all 339 | conversion functions that are available to map values between their 340 | {\ocaml} and Lua representation. The rest of [[lua.nw]] explains the 341 | multiple ways libraries can be combined and is important when you want 342 | to combine more than 10 libraries or types, or you want to go to the 343 | limits in other ways. 344 | 345 | % ------------------------------------------------------------------ 346 | \end{document} 347 | % ------------------------------------------------------------------ 348 | -------------------------------------------------------------------------------- /doc/noweb/luahash.nw: -------------------------------------------------------------------------------- 1 | % -*- mode: Noweb; noweb-code-mode: caml-mode -*- 2 | 3 | % Grades ::= "%%Grades:" Quality Importance Urgency 4 | % Quality ::= A|B|C|D|E 5 | % Importance ::= Central|Subsystem|Peripheral 6 | % Urgency ::= Immediate|Soon|Later 7 | % 8 | % Example (at beginning of line): %%Grades: B Central Soon 9 | This is the standard OCaml hash table, except I've added [[first]] and 10 | [[next]] functions to support Lua's table-enumeration primitive, plus 11 | I've added a [[population]] function. 12 | 13 | <>= 14 | (***********************************************************************) 15 | (* *) 16 | (* Objective Caml *) 17 | (* *) 18 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 19 | (* *) 20 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 21 | (* en Automatique. All rights reserved. This file is distributed *) 22 | (* under the terms of the GNU Library General Public License. *) 23 | (* *) 24 | (***********************************************************************) 25 | 26 | (* modified by Norman Ramsey to provide threading via a `next' function *) 27 | 28 | (* $Id: luahash.nw,v 1.8 2004-08-03 22:13:33 nr Exp $ *) 29 | 30 | (* Hash tables are hashed association tables, with in-place modification. *) 31 | 32 | (*** Generic interface *) 33 | 34 | type ('a, 'b) t 35 | (* The type of hash tables from type ['a] to type ['b]. *) 36 | 37 | val create : ('a -> 'a -> bool) -> int -> ('a,'b) t 38 | (* [Luahash.create eq n] creates a new, empty hash table, with 39 | initial size [n]. Function eq is used to compare equality of keys 40 | For best results, [n] should be on the 41 | order of the expected number of elements that will be in 42 | the table. The table grows as needed, so [n] is just an 43 | initial guess. *) 44 | 45 | val population : ('a, 'b) t -> int 46 | (* number of key-value pairs in a table (as distinct from its size) *) 47 | 48 | val clear : ('a, 'b) t -> unit 49 | (* Empty a hash table. *) 50 | 51 | val find : ('a, 'b) t -> 'a -> 'b 52 | (* [Luahash.find tbl x] returns the current binding of [x] in [tbl], 53 | or raises [Not_found] if no such binding exists. *) 54 | 55 | val find_all : ('a, 'b) t -> 'a -> 'b list 56 | (* [Luahash.find_all tbl x] returns the list of all data 57 | associated with [x] in [tbl]. 58 | The current binding is returned first, then the previous 59 | bindings, in reverse order of introduction in the table. *) 60 | 61 | val mem : ('a, 'b) t -> 'a -> bool 62 | (* [Luahash.mem tbl x] checks if [x] is bound in [tbl]. *) 63 | 64 | val remove : ('a, 'b) t -> 'a -> unit 65 | (* [Luahash.remove tbl x] removes the current binding of [x] in [tbl], 66 | restoring the previous binding if it exists. 67 | It does nothing if [x] is not bound in [tbl]. *) 68 | 69 | val replace : ('a, 'b) t -> key:'a -> data:'b -> unit 70 | (* [Luahash.replace tbl x y] replaces the current binding of [x] 71 | in [tbl] by a binding of [x] to [y]. If [x] is unbound in [tbl], 72 | a binding of [x] to [y] is added to [tbl]. 73 | This is functionally equivalent to [Luahash.remove tbl x] 74 | followed by [Luahash.add tbl x y], except that Luahash has no [add]. *) 75 | 76 | val iter : ('a -> 'b -> unit) -> ('a, 'b) t -> unit 77 | (* [Luahash.iter f tbl] applies [f] to all bindings in table [tbl]. 78 | [f] receives the key as first argument, and the associated value 79 | as second argument. The order in which the bindings are passed to 80 | [f] is unspecified. Each binding is presented exactly once 81 | to [f]. *) 82 | 83 | val first : ('a, 'b) t -> 'a * 'b 84 | val next : ('a, 'b) t -> 'a -> 'a * 'b 85 | (* Used to iterate over the contents of the table, Lua style. 86 | Raises Not_found when the contents are exhausted *) 87 | 88 | 89 | (*** The polymorphic hash primitive *) 90 | 91 | val hash : 'a -> int 92 | (* [Luahash.hash x] associates a positive integer to any value of 93 | any type. It is guaranteed that 94 | if [x = y], then [hash x = hash y]. 95 | Moreover, [hash] always terminates, even on cyclic 96 | structures. *) 97 | 98 | @ 99 | <>= 100 | (***********************************************************************) 101 | (* *) 102 | (* Objective Caml *) 103 | (* *) 104 | (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 105 | (* *) 106 | (* Copyright 1996 Institut National de Recherche en Informatique et *) 107 | (* en Automatique. All rights reserved. This file is distributed *) 108 | (* under the terms of the GNU Library General Public License. *) 109 | (* *) 110 | (***********************************************************************) 111 | 112 | (* $Id: luahash.nw,v 1.8 2004-08-03 22:13:33 nr Exp $ *) 113 | 114 | (* Hash tables *) 115 | 116 | let hash_param = Hashtbl.hash_param 117 | 118 | let hash x = hash_param 10 100 x 119 | 120 | (* We do dynamic hashing, and resize the table and rehash the elements 121 | when buckets become too long. *) 122 | 123 | type ('a, 'b) t = 124 | { eq : 'a -> 'a -> bool; 125 | mutable population : int; 126 | mutable max_len: int; (* max length of a bucket *) 127 | mutable data: ('a, 'b) bucketlist array } (* the buckets *) 128 | 129 | and ('a, 'b) bucketlist = 130 | Empty 131 | | Cons of 'a * 'b * ('a, 'b) bucketlist 132 | 133 | let bucket_length l = 134 | let rec len k = function 135 | | Empty -> k 136 | | Cons(_, _, l) -> len (k+1) l 137 | in len 0 l 138 | 139 | let dump_buckets h k i l = 140 | let nsize = Array.length h.data in 141 | let int = string_of_int in 142 | let hmod k = int (hash k mod nsize) in 143 | let rec dump = function 144 | | Empty -> () 145 | | Cons (k', i', l) -> 146 | List.iter prerr_string ["New bucket hash = "; int (hash k'); " [mod="; 147 | hmod k'; "]"; 148 | if h.eq k k' then " (identical " else " (different "; 149 | "keys)\n"]; 150 | dump l 151 | in List.iter prerr_string ["First bucket hash = "; string_of_int (hash k); 152 | " [mod="; hmod k; "]\n"]; 153 | dump l 154 | 155 | let create eq initial_size = 156 | let s = if initial_size < 1 then 1 else initial_size in 157 | let s = if s > Sys.max_array_length then Sys.max_array_length else s in 158 | { eq = eq; max_len = 3; data = Array.make s Empty; population = 0 } 159 | 160 | let clear h = 161 | h.population <- 0; 162 | for i = 0 to Array.length h.data - 1 do 163 | h.data.(i) <- Empty 164 | done 165 | 166 | let dump_table_stats h = 167 | let flt x = Printf.sprintf "%4.2f" x in 168 | let int = string_of_int in 169 | let sum = ref 0 in 170 | let sumsq = ref 0 in 171 | let n = ref 0 in 172 | let zs = ref 0 in 173 | let ratio n m = float n /. float m in 174 | let inc r n = r := !r + n in 175 | let stats l = 176 | let k = bucket_length l in 177 | if k = 0 then inc zs 1 178 | else (inc sum k; inc sumsq (k*k); inc n 1) in 179 | for i = 0 to Array.length h.data - 1 do 180 | stats h.data.(i) 181 | done; 182 | let mean = ratio (!sum) (!n) in 183 | let variance = 184 | if !n > 1 then (* concrete math p 378 *) 185 | (float (!sumsq) -. float (!sum) *. mean) /. (float (!n - 1)) 186 | else 187 | 0.0 in 188 | let variance = if variance < 0.0 then 0.0 else variance in 189 | let stddev = sqrt variance in 190 | let stderr = stddev /. sqrt (float (!n)) in 191 | List.iter prerr_string ["Table has "; int (!zs); " empy buckets; "; 192 | "avg nonzero length is "; flt (ratio (!sum) (!n)); 193 | " +/- "; flt stderr; " \n"] 194 | 195 | 196 | let resize hashfun tbl = 197 | let odata = tbl.data in 198 | let osize = Array.length odata in 199 | let nsize = min (2 * osize + 1) Sys.max_array_length in 200 | if nsize <> osize then begin 201 | let ndata = Array.create nsize Empty in 202 | let rec insert_bucket = function 203 | Empty -> () 204 | | Cons(key, data, rest) -> 205 | insert_bucket rest; (* preserve original order of elements *) 206 | let nidx = (hashfun key) mod nsize in 207 | ndata.(nidx) <- Cons(key, data, ndata.(nidx)) in 208 | for i = 0 to osize - 1 do 209 | insert_bucket odata.(i) 210 | done; 211 | tbl.data <- ndata; 212 | end; 213 | tbl.max_len <- 2 * tbl.max_len 214 | (* if tbl.max_len >= 48 then dump_table_stats tbl *) 215 | 216 | let rec bucket_too_long n bucket = 217 | if n < 0 then true else 218 | match bucket with 219 | Empty -> false 220 | | Cons(_,_,rest) -> bucket_too_long (n - 1) rest 221 | 222 | let remove h key = 223 | let rec remove_bucket = function 224 | Empty -> 225 | Empty 226 | | Cons(k, i, next) -> 227 | if h.eq k key then 228 | begin 229 | h.population <- h.population - 1; 230 | next 231 | end 232 | else 233 | Cons(k, i, remove_bucket next) in 234 | let i = (hash key) mod (Array.length h.data) in 235 | h.data.(i) <- remove_bucket h.data.(i) 236 | 237 | let rec find_rec eq key = function 238 | Empty -> 239 | raise Not_found 240 | | Cons(k, d, rest) -> 241 | if eq key k then d else find_rec eq key rest 242 | 243 | let find h key = 244 | match h.data.((hash key) mod (Array.length h.data)) with 245 | Empty -> raise Not_found 246 | | Cons(k1, d1, rest1) -> 247 | if h.eq key k1 then d1 else 248 | match rest1 with 249 | Empty -> raise Not_found 250 | | Cons(k2, d2, rest2) -> 251 | if h.eq key k2 then d2 else 252 | match rest2 with 253 | Empty -> raise Not_found 254 | | Cons(k3, d3, rest3) -> 255 | if h.eq key k3 then d3 else find_rec h.eq key rest3 256 | 257 | (* next element in table starting in bucket [index] *) 258 | let rec next_at h index = 259 | if index = Array.length h.data then 260 | raise Not_found 261 | else 262 | match h.data.(index) with 263 | | Empty -> next_at h (index+1) 264 | | Cons(k1, d1, _) -> (k1, d1) 265 | 266 | let rec following eq key fail = 267 | let finish = function 268 | | Empty -> fail () 269 | | Cons (k, d, _) -> (k, d) 270 | in function 271 | | Empty -> assert false 272 | | Cons(k1, d1, rest1) -> 273 | if eq key k1 then finish rest1 else 274 | following eq key fail rest1 275 | 276 | let next h key = 277 | let index = (hash key) mod (Array.length h.data) in 278 | let finish = function 279 | | Empty -> next_at h (index+1) 280 | | Cons (k, d, _) -> (k, d) 281 | in 282 | match h.data.(index) with 283 | Empty -> next_at h (index+1) 284 | | Cons(k1, _, rest1) -> 285 | if h.eq key k1 then finish rest1 else 286 | match rest1 with 287 | Empty -> raise Not_found 288 | | Cons(k2, _, rest2) -> 289 | if h.eq key k2 then finish rest2 else 290 | match rest2 with 291 | Empty -> raise Not_found 292 | | Cons(k3, _, rest3) -> 293 | if h.eq key k3 then finish rest3 294 | else following h.eq key (fun () -> finish Empty) rest3 295 | 296 | let rec first_at h index = 297 | if index = Array.length h.data then 298 | raise Not_found 299 | else 300 | match h.data.(index) with 301 | | Empty -> first_at h (index+1) 302 | | Cons(k, d, _) -> (k, d) 303 | 304 | let first h = first_at h 0 305 | 306 | let find_all h key = 307 | let rec find_in_bucket = function 308 | Empty -> 309 | [] 310 | | Cons(k, d, rest) -> 311 | if k = key then d :: find_in_bucket rest else find_in_bucket rest in 312 | find_in_bucket h.data.((hash key) mod (Array.length h.data)) 313 | 314 | let replace h ~key ~data:info = 315 | let rec replace_bucket = function 316 | Empty -> 317 | raise Not_found 318 | | Cons(k, i, next) -> 319 | if k = key 320 | then Cons(k, info, next) 321 | else Cons(k, i, replace_bucket next) in 322 | let i = (hash key) mod (Array.length h.data) in 323 | let l = h.data.(i) in 324 | (* 325 | Log.bucket_length (bucket_length l); 326 | if bucket_length l > 5 then 327 | begin 328 | (match l with Cons (k, i, l) -> dump_buckets h k i l | _ -> ()); 329 | prerr_string 330 | (if bucket_too_long h.max_len l then "bucket too long (> " 331 | else "bucket length OK (<= "); 332 | prerr_int h.max_len; 333 | prerr_string ")\n\n" 334 | end; 335 | *) 336 | try 337 | h.data.(i) <- replace_bucket l 338 | with Not_found -> 339 | begin 340 | let bucket = Cons(key, info, l) in 341 | h.data.(i) <- bucket; 342 | h.population <- h.population + 1; 343 | (*if bucket_too_long h.max_len bucket then resize hash h*) 344 | if h.population > Array.length h.data then resize hash h 345 | end 346 | 347 | let mem h key = 348 | let rec mem_in_bucket = function 349 | | Empty -> 350 | false 351 | | Cons(k, d, rest) -> 352 | k = key || mem_in_bucket rest in 353 | mem_in_bucket h.data.((hash key) mod (Array.length h.data)) 354 | 355 | let iter f h = 356 | let rec do_bucket = function 357 | Empty -> 358 | () 359 | | Cons(k, d, rest) -> 360 | f k d; do_bucket rest in 361 | let d = h.data in 362 | for i = 0 to Array.length d - 1 do 363 | do_bucket d.(i) 364 | done 365 | 366 | let population h = 367 | h.population 368 | -------------------------------------------------------------------------------- /doc/noweb/luaiolib.nw: -------------------------------------------------------------------------------- 1 | % -*- mode: Noweb; noweb-code-mode: caml-mode -*- 2 | 3 | % Grades ::= "%%Grades:" Quality Importance Urgency 4 | % Quality ::= A|B|C|D|E 5 | % Importance ::= Central|Subsystem|Peripheral 6 | % Urgency ::= Immediate|Soon|Later 7 | % 8 | % Example (at beginning of line): %%Grades: B Central Soon 9 | \section{Lua I/O library} 10 | 11 | <>= 12 | type 'a t = In of in_channel | Out of out_channel 13 | val out : 14 | ('a t, 'b, 'b) Luavalue.ep -> 15 | ('b -> string -> out_channel) -> 16 | (out_channel, 'b, 'b) Luavalue.ep 17 | val in' : 18 | ('a t, 'b, 'b) Luavalue.ep -> 19 | ('b -> string -> in_channel) -> 20 | (in_channel, 'b, 'b) Luavalue.ep 21 | 22 | module T : Lua.Lib.USERTYPE with type 'a t = 'a t 23 | module Make (TV : Lua.Lib.TYPEVIEW with type 'a t = 'a t) 24 | : Lua.Lib.USERCODE with type 'a userdata' = 'a TV.combined 25 | @ 26 | <>= 27 | type 'a t = In of in_channel | Out of out_channel 28 | type 'a state = { mutable currentin : in_channel 29 | ; mutable currentout : out_channel 30 | } 31 | type 'a alias_for_t = 'a t 32 | type 'a alias_for_state = 'a state 33 | @ 34 | <>= 35 | let file = T.makemap V.userdata V.projection in 36 | let infile = in' file V.projection in 37 | let outfile = out file V.projection in 38 | 39 | let wrap_err = function 40 | | V.Function (l, f) -> 41 | V.Function(l, fun args -> try f args with Sys_error s -> [V.Nil; V.String s]) 42 | | v -> raise (V.Projection (v, "function")) in 43 | 44 | (* errfunc -- a function that returns nil, string on error *) 45 | let errfunc ty f = wrap_err (V.efunc ty f) in 46 | let errchoose alts = wrap_err (V.choose alts) in 47 | 48 | (* succeed, succeed2: return non-nil on success *) 49 | let succeed (f : 'a -> unit) (x : 'a) = (f x; "OK") in 50 | let succeed2 f x y = ((f x y : unit); "OK") in 51 | 52 | let setglobal s v = V.Table.bind g.V.globals (V.String s) v in 53 | 54 | let readfrom = 55 | let setinput file = 56 | (io.currentin <- file; setglobal "_INPUT" (infile.V.embed file); file) in 57 | let from_string s = 58 | if String.get s 0 = '|' then 59 | setinput (Unix.open_process_in (String.sub s 1 (String.length s - 1))) 60 | else 61 | setinput (open_in s) in 62 | let from_other _ = C.error "bad args to readfrom" in 63 | [ V.alt (V.string **->> infile) from_string 64 | ; V.alt (V.unit **->> infile) (fun () -> (close_in io.currentin; setinput stdin)) 65 | ; V.alt (infile **->> infile) setinput 66 | ; V.alt (V.value **->> infile) from_other 67 | ] in 68 | 69 | let open_out_append s = 70 | open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_text] 0o666 s in 71 | 72 | let open_out_string append s = 73 | match String.get s 0 with 74 | | '|' -> if append then raise (Sys_error "tried to appendto() a pipe") 75 | else Unix.open_process_out (String.sub s 1 (String.length s - 1)) 76 | | _ -> if append then open_out_append s else open_out s in 77 | 78 | let writeto' append = 79 | let setoutput file = 80 | (io.currentout <- file; setglobal "_OUTPUT" (outfile.V.embed file); file) in 81 | let to_nil () = (close_out io.currentout; setoutput stdout) in 82 | let to_other _ = 83 | let funname = if append then "appendto" else "writeto" in 84 | C.error ("bad args to " ^ funname) in 85 | [ V.alt (V.string **->> outfile) (fun s -> setoutput (open_out_string append s)) 86 | ; V.alt (V.unit **->> outfile) to_nil 87 | ; V.alt (outfile **->> outfile) setoutput 88 | ; V.alt (V.value **->> V.value) to_other 89 | ] in 90 | 91 | let read = function 92 | | None -> (try Some (input_line io.currentin) with End_of_file -> None) 93 | | Some _ -> C.error ("I/O library does not implement read patterns") in 94 | 95 | let getopt x d = match x with Some v -> v | None -> d in 96 | 97 | let date = function 98 | | Some _ -> C.error ("I/O library does not implement read patterns") 99 | | None -> 100 | let t = Unix.localtime (Unix.time ()) in 101 | let s = string_of_int in 102 | let mm = t.Unix.tm_mon + 1 in 103 | let yyyy = t.Unix.tm_year + 1900 in 104 | let dd = t.Unix.tm_mday in 105 | s mm ^ "/" ^ s dd ^ "/" ^ s yyyy in 106 | 107 | let tmpname () = Filename.temp_file "lua" "" in 108 | 109 | let write_strings file l = (List.iter (output_string file) l; flush file; 1) in 110 | 111 | let io_builtins = 112 | [ "readfrom", errchoose readfrom 113 | ; "open_out", V.efunc (V.string **->> outfile) (open_out_string false) 114 | ; "close_out", V.efunc (outfile **->> V.unit) close_out 115 | ; "open_in", V.efunc (V.string **->> infile) open_in 116 | ; "close_in", V.efunc (infile **->> V.unit) close_in 117 | ; "writeto", errchoose (writeto' false) 118 | ; "appendto", errchoose (writeto' true) 119 | ; "remove", errfunc (V.string **->> V.string) (succeed Sys.remove) 120 | ; "rename", errfunc (V.string **-> V.string **->> V.string) (succeed2 Sys.rename) 121 | ; "tmpname", V.efunc (V.unit **->> V.string) tmpname 122 | ; "read", V.efunc (V.option V.string **->> V.option V.string) read 123 | ; "write", errchoose 124 | [ V.alt (V.string *****->> V.int) (* eta-expand to delay eval *) 125 | (fun l -> write_strings io.currentout l) 126 | ; V.alt (outfile **-> V.string *****->> V.int) write_strings 127 | ] 128 | ; "date", V.efunc (V.option V.string **->> V.string) date 129 | ; "exit", V.efunc (V.option V.int **->> V.unit) (fun n -> exit (getopt n 0)) 130 | ; "getenv", V.efunc (V.string **->> V.option V.string) 131 | (fun s -> try Some (Sys.getenv s) with Not_found -> None) 132 | ; "execute", V.efunc (V.string **->> V.int) Sys.command 133 | ; "_STDIN", infile.V.embed stdin 134 | ; "_STDOUT", outfile.V.embed stdout 135 | ; "_STDERR", outfile.V.embed stderr 136 | ; "_INPUT", infile.V.embed io.currentin 137 | ; "_OUTPUT", outfile.V.embed io.currentout 138 | ] in 139 | @ 140 | <>= 141 | module T = struct 142 | type 'a t = 'a alias_for_t 143 | let tname = "I/O channel" 144 | let eq _ x y = match x, y with 145 | | In x, In y -> x = y 146 | | Out x, Out y -> x = y 147 | | _, _ -> false 148 | let to_string vs = function 149 | | In _ -> "" 150 | | Out _ -> "" 151 | end 152 | <>= 153 | module V = Luavalue 154 | let out upper fail = 155 | { V.embed = (fun x -> upper.V.embed (Out x)) 156 | ; V.project = (fun x -> match upper.V.project x with 157 | | Out x -> x 158 | | _ -> fail x "output file") 159 | ; V.is = (fun x -> upper.V.is x && match upper.V.project x with 160 | | Out x -> true | _ -> false) 161 | } 162 | let in' upper fail = 163 | { V.embed = (fun x -> upper.V.embed (In x)) 164 | ; V.project = (fun x -> match upper.V.project x with 165 | | In x -> x 166 | | _ -> fail x "input file") 167 | ; V.is = (fun x -> upper.V.is x && match upper.V.project x with 168 | | In x -> true | _ -> false) 169 | } 170 | <>= 171 | module Make (T : Lua.Lib.TYPEVIEW with type 'a t = 'a t) 172 | : Lua.Lib.USERCODE with type 'a userdata' = 'a T.combined = 173 | struct 174 | type 'a userdata' = 'a T.combined 175 | module M (C : Lua.Lib.CORE with type 'a V.userdata' = 'a userdata') = 176 | struct 177 | module V = C.V 178 | let ( **-> ) = V.( **-> ) 179 | let ( **->> ) x y = x **-> V.result y 180 | let ( *****->> ) = V.dots_arrow 181 | let init g = (* g needed for readfrom, writeto, appendto *) 182 | let io = {currentin = stdin; currentout = stdout} in 183 | <> 184 | C.register_globals io_builtins g 185 | end (*M*) 186 | end (*Make*) 187 | @ 188 | -------------------------------------------------------------------------------- /doc/noweb/luamathlib.nw: -------------------------------------------------------------------------------- 1 | % -*- mode: Noweb; noweb-code-mode: caml-mode -*- 2 | % Grades ::= "%%Grades:" Quality Importance Urgency 3 | % Quality ::= A|B|C|D|E 4 | % Importance ::= Central|Subsystem|Peripheral 5 | % Urgency ::= Immediate|Soon|Later 6 | % 7 | % Example (at beginning of line): %%Grades: B Central Soon 8 | 9 | <>= 10 | module M : Lua.Lib.BARECODE 11 | <>= 12 | let float = V.float 13 | let math_builtins = 14 | [ "abs", V.efunc (float **->> float) abs_float 15 | ; "acos", V.efunc (float **->> float) acos 16 | ; "asin", V.efunc (float **->> float) asin 17 | ; "atan", V.efunc (float **->> float) atan 18 | ; "atan2", V.efunc (float **-> float **->> float) atan2 19 | ; "ceil", V.efunc (float **->> float) ceil 20 | ; "cos", V.efunc (float **->> float) cos 21 | ; "floor", V.efunc (float **->> float) floor 22 | ; "log", V.efunc (float **->> float) log 23 | ; "log10", V.efunc (float **->> float) log10 24 | ; "max", V.efunc (float **-> float **->> float) max 25 | ; "min", V.efunc (float **-> float **->> float) min 26 | ; "mod", V.efunc (float **-> float **->> float) mod_float 27 | ; "sin", V.efunc (float **->> float) sin 28 | ; "sqrt", V.efunc (float **->> float) sqrt 29 | ; "tan", V.efunc (float **->> float) tan 30 | ; "random", V.efunc (V.value **->> float) (fun _ -> Random.float 1.0) 31 | ; "randomseed", V.efunc (V.int **->> V.unit) Random.init 32 | ] 33 | @ 34 | <>= 35 | module M (I : Lua.Lib.CORE) = struct 36 | module V = I.V 37 | let ( **-> ) = V.( **-> ) 38 | let ( **->> ) x y = x **-> V.result y 39 | <> 40 | let init = I.register_globals math_builtins 41 | end 42 | -------------------------------------------------------------------------------- /doc/noweb/luarun.nw: -------------------------------------------------------------------------------- 1 | % -*- mode: Noweb; noweb-code-mode: caml-mode -*- 2 | 3 | % Grades ::= "%%Grades:" Quality Importance Urgency 4 | % Quality ::= A|B|C|D|E 5 | % Importance ::= Central|Subsystem|Peripheral 6 | % Urgency ::= Immediate|Soon|Later 7 | % 8 | % Example (at beginning of line): %%Grades: B Central Soon 9 | \section{Standalone Lua interpreters} 10 | 11 | Runs the given interpreter at startup, using [[Sys.argv]] to decide 12 | what to do. 13 | <>= 14 | module type INTERP = sig 15 | module Value : Luavalue.S 16 | type value = Value.value 17 | type state = Value.state 18 | val mk : unit -> state 19 | val dostring : state -> string -> value list 20 | val dofile : state -> string -> value list 21 | end 22 | module Make (I : INTERP) : sig end 23 | <>= 24 | module type INTERP = sig 25 | module Value : Luavalue.S 26 | type value = Value.value 27 | type state = Value.state 28 | val mk : unit -> state 29 | val dostring : state -> string -> value list 30 | val dofile : state -> string -> value list 31 | end 32 | module Make (I : INTERP) = struct 33 | module V = I.Value 34 | let state = I.mk() 35 | let dumpstate = ref false 36 | let showresults = 37 | let rec loop n = function 38 | | h :: t -> print_string "Result "; print_int n; print_string " = "; 39 | print_endline (V.to_string h); loop (n+1) t 40 | | [] -> () 41 | in loop 1 42 | let run infile = ignore (I.dofile state infile) 43 | let run_interactive infile = 44 | let rec loop n pfx = 45 | let line = input_line infile in 46 | if String.length line > 0 && String.get line (String.length line - 1) = '\\' then 47 | loop n (pfx ^ String.sub line 0 (String.length line - 1) ^ "\n") 48 | else 49 | begin 50 | ignore (I.dostring state (pfx ^ line ^ "\n")); 51 | flush stdout; flush stderr; 52 | loop (n+1) "" 53 | end 54 | in try loop 1 "" with End_of_file -> () 55 | let rec args = function 56 | | "-dump" :: a's -> (dumpstate := true; args a's) 57 | | "-new" :: a's -> args a's 58 | | [] -> run_interactive stdin 59 | | files -> List.iter run files 60 | 61 | let _ = args (List.tl (Array.to_list (Sys.argv))) 62 | 63 | let _ = if !dumpstate then 64 | begin 65 | print_endline "final state: "; 66 | Luahash.iter (fun k v -> print_string " "; 67 | print_string (V.to_string k); print_string " |-> "; 68 | print_endline (V.to_string v)) state.V.globals 69 | end 70 | end 71 | 72 | -------------------------------------------------------------------------------- /doc/noweb/luasrcmap.nw: -------------------------------------------------------------------------------- 1 | % -*- mode: Noweb; noweb-code-mode: caml-mode -*- 2 | 3 | % l2h substitution C C-- 4 | % Grades ::= "%%Grades:" Quality Importance Urgency 5 | % Quality ::= A|B|C|D|E 6 | % Importance ::= Central|Subsystem|Peripheral 7 | % Urgency ::= Immediate|Soon|Later 8 | % 9 | % Example (at beginning of line): %%Grades: B Central Soon 10 | % l2h substitution asdl ASDL 11 | % l2h substitution ocaml OCaml 12 | 13 | \input{../config/macros.tex} 14 | 15 | % ------------------------------------------------------------------ 16 | \section{Source Code Locations}\label{srcmap} 17 | % ------------------------------------------------------------------ 18 | 19 | The scanner (section \ref{sec:scanner}) operates on a character 20 | stream. An offset from the beginning of the stream marks a 21 | \textit{position} inside the stream; the first character in the stream 22 | has position 0. The parser (section \ref{sec:parser}) takes positions 23 | reported by the scanner to mark nodes in the abstract syntax with 24 | regions. A region is a pair of two positions and defines the span a 25 | node covers in the source code. 26 | 27 | Positions are easy to manipulate by a program but less useful for a 28 | programmer who likes to think in terms of line numbers and columns in 29 | a file. A \textit{source map} translates source code 30 | \textit{positions} into source code \textit{locations} that are made 31 | up from 32 | 33 | \begin{itemize} 34 | \item a file name, 35 | \item a line number in that file (first line has number 1), 36 | \item and a column (first column is 1). There seems to be no 37 | convention whether the first column in a line is considered 0 or 38 | 1. The Emacs editor adheres to the first, the Vi editor to the 39 | latter perspective. 40 | \end{itemize} 41 | 42 | To establish the connection between simple positions and complex 43 | locations these two views must be \textit{synchronized}. The result 44 | of all synchronizations is a source map. The views must synchronize 45 | whenever advancing in the stream of characters is different from 46 | moving to the next column in the position's view. This happens 47 | typically at the following points in a source file: 48 | 49 | \begin{itemize} 50 | \item Start of a new source file. 51 | \item Beginning of a new line. 52 | \item A tab character that skips some columns. 53 | \item Some directive like [[#line]] from the C pre-processor 54 | indicates a non-linearity in the source code. 55 | \end{itemize} 56 | 57 | A synchronization establishes a connection between a source code 58 | position and a (filename, line, column) location. The point of 59 | synchronization is called a synchronization point or sync point. 60 | 61 | In principle, synchronization points can be placed in any order into a 62 | stream of characters. The following restriction usually does not harm 63 | and helps to to build efficient source maps: source code positions 64 | increase in the order synchronization points are established. This 65 | means, that never a position to the left of an existing 66 | synchronization point is synchronized. 67 | 68 | Building and using a source map involves the following key operations: 69 | 70 | \begin{itemize} 71 | \item Create an initially empty source map. 72 | \item Enter synchronization points into the map. 73 | \item Return the location of a given position. 74 | \end{itemize} 75 | 76 | To make any position meaningful, position 0 should be a 77 | synchronization point. So whenever a source map is created a sync 78 | point for position 0 should be placed into it. 79 | 80 | % ------------------------------------------------------------------ 81 | \subsection{Interface} 82 | % ------------------------------------------------------------------ 83 | 84 | Position are non negative characters counts in the input stream. They 85 | are represented by [[pos]]. A continuous region in the input 86 | stream consists of the first character in the span and the first one 87 | following it. 88 | 89 | <>= 90 | type pos = int 91 | type rgn = pos * pos 92 | @ 93 | The [[null]] region is sometimes used a special value when no real 94 | region information is available. 95 | 96 | <>= 97 | val null : rgn 98 | @ 99 | 100 | Programmers think in terms of locations, describing a line and 101 | column in a file; they have type [[loc]]. I have chosen to use a 102 | tuple to represent a location instead of a record type. There is some 103 | danger of confusing lines and columns because they share the same 104 | type. Records avoid this but have other drawbacks: labels must be 105 | unique which leads to long names and ugly pattern matching. 106 | 107 | <>= 108 | type location = string (* file *) 109 | * int (* line *) 110 | * int (* column *) 111 | @ 112 | A source map is a mutable data structure with an undisclosed 113 | representation. A source map should never be empty but should contain 114 | a synchronization point for [[pos]] 0. The [[mk]] function returns an 115 | empty source map for a file. 116 | 117 | <>= 118 | type map 119 | val mk: unit -> map (* empty map *) 120 | @ 121 | 122 | A synchronization is announced with [[sync]]. It synchronizes a 123 | position [[pos]] with a [[location]]. A common case is the 124 | synchronization for a new line trough [[nl]]. A new line stays in the 125 | same file as the previous sync point and advances one line. The 126 | [[pos]] passed to [[nl]] is that of the first character on the new 127 | line. Another common case are tab characters which we currently 128 | ignore. 129 | 130 | <>= 131 | val sync : map -> pos -> location -> unit 132 | val nl : map -> pos -> unit 133 | @ 134 | [[last]] returns the location of the last sync point. It is useful 135 | to get the current file name and line number. 136 | 137 | <>= 138 | val last : map -> location 139 | @ 140 | The corresponding location for a position can be obtained with 141 | [[location]]. For debugging a source map can be dumped to stdout 142 | using [[dump]]. 143 | 144 | <>= 145 | val location : map -> pos -> location 146 | val dump: map -> unit 147 | @ 148 | To make positions meaningful they can be bundled with a source map 149 | that keeps track of their origins. 150 | 151 | <>= 152 | type point = map * pos 153 | type region = map * rgn 154 | @ 155 | The [[Str]] module provides string representations for points and regions. 156 | 157 | <>= 158 | module Str: 159 | sig 160 | val point : point -> string 161 | val region : region -> string 162 | end 163 | @ 164 | 165 | % ------------------------------------------------------------------ 166 | \subsection{Implementation} 167 | % ------------------------------------------------------------------ 168 | 169 | A single compilation unit can easily contain some thousand lines of 170 | code and at least as many synchronization points. An implementation 171 | should thus pay attention to memory requirements and run time 172 | performance. 173 | 174 | <>= 175 | type pos = int 176 | type rgn = pos * pos 177 | type location = string (* file *) 178 | * int (* line *) 179 | * int (* column *) 180 | <>= 181 | let null = (0,0) 182 | @ 183 | 184 | A [[syncpoint]] associates a [[pos]] with a [[location]]. To 185 | lower memory requirements a bit this could be also defined as a 186 | quadruple. 187 | 188 | <>= 189 | type syncpoint = pos * location 190 | @ 191 | 192 | We have chosen to use an array to implement a source map. Binary 193 | search can be used to implement the lookup operation and an array 194 | is compact in memory. When an array fills up it is copied 195 | into a new one twice of the size of the old. 196 | 197 | Using an array also requires the restriction mentioned above: sync 198 | point positions must have an increasing order. This could be dropped 199 | when the array is sorted before it is first used for the lookup 200 | operation. 201 | 202 | Storing the file name for every sync point requires lots of memory, 203 | especially when long path names are involved. The number of different 204 | files referenced by all sync point is probably small. Storing every 205 | name only once thus can help to save memory. For this purpose a hash 206 | table is established. A file name is never stored directly in the 207 | array but looked up first in the hash table. The instance found there 208 | goes into the array. Although it looks like the one from the location 209 | it is a different one that is shared among all sync points using this 210 | name. 211 | 212 | <>= 213 | type map = { mutable points: syncpoint array 214 | ; mutable top: int 215 | ; files : (string, string) Hashtbl.t 216 | } 217 | type point = map * pos 218 | type region = map * rgn 219 | @ 220 | 221 | The [[top]] component maintains the index of the first free position 222 | in the [[points]] array. In \ocaml~every array cell must be 223 | initialized upon creation. We use [[undefined]] for this. The 224 | initial size of the array is [[size]]. 225 | 226 | <>= 227 | let size = 2 (* small to test alloc *) 228 | let undefined = (0, ("undefined", -1, -1)) 229 | 230 | <>= 231 | let mk () = 232 | { points = Array.create size undefined 233 | ; top = 0 234 | ; files = Hashtbl.create 17 235 | } 236 | @ 237 | 238 | To prevent that the array fills up [[alloc]] makes sure there is at 239 | least space for the next sync point. In case the array is full it 240 | copies the existing array into a new one, twice of the size of the 241 | old. 242 | 243 | <>= 244 | 245 | let alloc srcmap = 246 | let length = Array.length srcmap.points in 247 | if srcmap.top < length then 248 | () 249 | else 250 | let points' = Array.create length undefined in 251 | srcmap.points <- Array.append srcmap.points points' 252 | @ 253 | 254 | Synchronizing means simply to enter the position and the 255 | corresponding location into the array. The file name in the location 256 | is replaced by an instance that comes from the hash table and is 257 | shared by many sync points. We check also for the increasing order of 258 | positions. 259 | 260 | <>= 261 | let sync srcmap pos (file,line,col) = 262 | let _ = alloc srcmap in 263 | let file' = try Hashtbl.find srcmap.files file 264 | with Not_found -> ( Hashtbl.add srcmap.files file file 265 | ; file 266 | ) 267 | in 268 | let location' = (file', line, col) in 269 | let top = srcmap.top in 270 | ( assert ((pos = 0) || (fst srcmap.points.(top-1) < pos)) 271 | ; srcmap.points.(top) <- (pos,location') 272 | ; srcmap.top <- srcmap.top + 1 273 | ) 274 | @ 275 | 276 | [[last]] returns the location of the last sync point. It is useful 277 | to get the current file name and line number. 278 | 279 | <>= 280 | let last map = 281 | ( assert (map.top > 0 && map.top <= Array.length map.points) 282 | ; snd map.points.(map.top-1) 283 | ) 284 | @ 285 | 286 | Entering a sync point for a new line is so common that it deserves 287 | its own function. The sync point is actually at the position 288 | following the newline character because we know that this will be at the 289 | beginning of the next line; thus [[position]] must point to this first 290 | character of the new line. The new line is in the same file as the 291 | last sync point. 292 | 293 | Since [[last]] already returns the shared instance of the file name, the 294 | hash table lookup in [[sync]] is superficial. Because [[nl]] is the most 295 | frequently called sync function it is worth implementing it as a 296 | specialed version of [[sync]] instead of calling [[sync]]: 297 | 298 | <>= 299 | let nl map pos = 300 | let (file, line, _) = last map in 301 | sync map pos (file, line+1, 1) 302 | @ 303 | 304 | <>= 305 | let nl srcmap pos = 306 | let _ = alloc srcmap in 307 | let (file, line, _) = last srcmap in 308 | let location' = (file, line+1,1) in 309 | let top = srcmap.top in 310 | ( assert ((pos = 0) || (fst srcmap.points.(top-1) < pos)) 311 | ; srcmap.points.(top) <- (pos,location') 312 | ; srcmap.top <- srcmap.top + 1 313 | ) 314 | @ 315 | 316 | Function [[cmp]] compares a [[pos]] with a [[(pos,location)]] 317 | pair; the [[pos]] is the one we like to find in the array. 318 | 319 | <>= 320 | let cmp x (y,_) = compare x y 321 | @ 322 | 323 | We want to find the element in the array with the position we are 324 | looking for, or, if it is not there, the element to the left of it. 325 | We expect that the array is not empty when it is used and secure this 326 | by an assertion. Only the first [[length]] entries are searched in 327 | the array. 328 | 329 | <>= 330 | let search x array length cmp = 331 | let rec loop left right = 332 | if left > right then 333 | ( assert (0 <= right && right < Array.length array) 334 | ; array.(right) 335 | ) 336 | else 337 | let pivot = (left + right)/2 in 338 | let res = cmp x array.(pivot) in 339 | let _ = assert (0 <= pivot && pivot < Array.length array) in 340 | 341 | if res = 0 then 342 | array.(pivot) 343 | else if res < 0 then 344 | loop left (pivot-1) 345 | else 346 | loop (pivot+1) right 347 | in 348 | ( assert (length > 0) 349 | ; loop 0 (length-1) 350 | ) 351 | @ 352 | 353 | To calculate the location of a position we have to find the sync 354 | point to its left. We do a binary search for this point in the map 355 | which gives us a location. The actual location is possibly to the 356 | right of this point: we simply have to add the missing columns to go 357 | there. 358 | 359 | <>= 360 | let location map pos = 361 | let pos',(file,line,col) = search pos map.points map.top cmp in 362 | (file,line,pos - pos' + col) 363 | @ 364 | 365 | To aid debugging we provide a function [[dump]] to write the 366 | contents of a [[srcmap]] to stdout. 367 | 368 | <>= 369 | let dump map = 370 | let point (pos,(file,line,col)) = 371 | Printf.printf "%5d: %-32s %4d %3d\n" pos file line col 372 | in 373 | for i=0 to map.top-1 do 374 | point map.points.(i) 375 | done 376 | @ 377 | 378 | For reporting locations to the user they must be available as 379 | strings. The [[Str]] module provides conversions. 380 | 381 | <>= 382 | module Str = struct 383 | let point (map,pos) = 384 | let (file,line,column) = location map pos in 385 | Printf.sprintf "File \"%s\", line %d, character %d" file line column 386 | 387 | 388 | let region (map,rgn) = 389 | match rgn with 390 | | (0,0) -> Printf.sprintf "" 391 | | (left,right) -> 392 | let (file1,l1,col1) = location map left in 393 | let (file2,l2,col2) = location map right in 394 | let (=$=) : string -> string -> bool = Pervasives.(=) in 395 | if file1 =$= file2 && l1 = l2 then 396 | Printf.sprintf 397 | "File \"%s\", line %d, characters %d-%d" file1 l1 col1 col2 398 | else if file1 =$= file2 then 399 | Printf.sprintf 400 | "File \"%s\", line %d, character %d - line %d, character %d" 401 | file1 l1 col1 l2 col2 402 | else 403 | Printf.sprintf 404 | "File \"%s\", line %d, character %d - file %s, line %d, character %d" 405 | file1 l1 col2 file2 l2 col2 406 | end 407 | @ 408 | -------------------------------------------------------------------------------- /doc/noweb/luastrlib.nw: -------------------------------------------------------------------------------- 1 | % -*- mode: Noweb; noweb-code-mode: caml-mode -*- 2 | % Grades ::= "%%Grades:" Quality Importance Urgency 3 | % Quality ::= A|B|C|D|E 4 | % Importance ::= Central|Subsystem|Peripheral 5 | % Urgency ::= Immediate|Soon|Later 6 | % 7 | % Example (at beginning of line): %%Grades: B Central Soon 8 | 9 | <>= 10 | module M : Lua.Lib.BARECODE 11 | <>= 12 | <> 13 | type 'a parse = int -> (int -> (unit -> 'a) -> 'a) -> (unit -> 'a) -> 'a 14 | 15 | let strindex = { V.embed = (fun n -> V.int.V.embed (n+1)) 16 | ; V.project = (fun v -> V.int.V.project v - 1) 17 | ; V.is = V.int.V.is 18 | } 19 | 20 | let string_builtins = 21 | let invalid f x = 22 | try f x with Invalid_argument m -> I.error ("Invalid argument: " ^ m) in 23 | let wrap_inv = function 24 | | V.Function (l, f) -> V.Function(l, invalid f) 25 | | v -> raise (V.Projection (v, "function")) in 26 | let ifunc ty f = wrap_inv (V.efunc ty f) in 27 | <> 28 | let quote_char c t = if alnum c then c :: t else '%' :: c :: t in 29 | let quote_pat p = List.fold_right quote_char (explode p) [] in 30 | let strfind s pat init plain = 31 | let int i = V.int.V.embed i in 32 | let string s = V.string.V.embed s in 33 | let pat = match plain with Some _ -> quote_pat pat | None -> explode pat in 34 | find pat s init 35 | (fun caps i j _ -> int (i+1) :: int j :: List.map string caps) 36 | (fun () -> [V.Nil]) in 37 | [ "strfind", V.efunc (V.string **-> V.string **-> V.default 0 strindex **-> 38 | V.option V.int **-> V.resultvs) strfind 39 | ; "strlen", V.efunc (V.string **->> V.int) String.length 40 | ; "strsub", 41 | (V.efunc (V.string **-> strindex **-> V.option strindex **->> V.string)) 42 | (fun s start last -> 43 | let maxlast = String.length s - 1 in 44 | let last = match last with None -> maxlast 45 | | Some n -> min n maxlast in 46 | let len = last - start + 1 in 47 | invalid (String.sub s start) len) 48 | ; "strlower", V.efunc (V.string **->> V.string) String.lowercase 49 | ; "strupper", V.efunc (V.string **->> V.string) String.uppercase 50 | ; "strrep", V.efunc (V.string **-> V.int **->> V.string) 51 | (fun s n -> 52 | if n < 0 then 53 | raise (Invalid_argument ("number of replicas " ^ string_of_int n ^ 54 | " is negative")) 55 | else 56 | let rec list l = function 0 -> l | n -> list (s::l) (n-1) in 57 | String.concat "" (list [] n)) 58 | ; "ascii", V.efunc (V.string **-> V.default 0 strindex **->> V.int) 59 | (fun s i -> Char.code (String.get s i)) 60 | ; "format", ifunc (V.string **-> V.value *****->> V.string) format 61 | ; "gsub", V.caml_func (fun _ -> I.error "string library does not implement gsub") 62 | ] 63 | @ 64 | <>= 65 | module M (I : Lua.Lib.CORE) = struct 66 | module V = I.V 67 | let ( **-> ) = V.( **-> ) 68 | let ( **->> ) x y = x **-> V.result y 69 | let ( *****->> ) = V.dots_arrow 70 | <> 71 | let init = I.register_globals string_builtins 72 | end 73 | @ 74 | Code for [[format]] borrowed from standard [[Printf]] library. 75 | <>= 76 | external format_int: string -> int -> string = "caml_format_int" 77 | external format_float: string -> float -> string = "caml_format_float" 78 | let add_quoted_string buf s = 79 | let escape delim c = c == delim || c == '\n' || c == '\\' in 80 | let delim = if String.contains s '\'' then '"' else '\'' in 81 | let add c = 82 | if escape delim c then (Buffer.add_char buf '\\'); Buffer.add_char buf c in 83 | Buffer.add_char buf delim; 84 | String.iter add s; 85 | Buffer.add_char buf delim 86 | 87 | let bprintf_internal buf format = 88 | let rec doprn i args = 89 | if i >= String.length format then 90 | begin 91 | let res = Buffer.contents buf in 92 | Buffer.clear buf; (* just in case [bs]printf is partially applied *) 93 | res 94 | end 95 | else begin 96 | let c = String.get format i in 97 | if c <> '%' then begin 98 | Buffer.add_char buf c; 99 | doprn (succ i) args 100 | end else begin 101 | let j = skip_args (succ i) in 102 | (* Lua conversions: d i o u x X e E f g c s p % q *) 103 | (* ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ *) 104 | match String.get format j with 105 | | '%' -> 106 | Buffer.add_char buf '%'; 107 | doprn (succ j) args 108 | | c -> 109 | let arg, args = 110 | match args with h :: t -> h, t 111 | | [] -> I.error 112 | "Not enough arguments to string-library function `format'" in 113 | match c with 114 | | 's' -> 115 | let s = V.string.V.project arg in 116 | if j <= i+1 then 117 | Buffer.add_string buf s 118 | else begin 119 | let p = 120 | try 121 | int_of_string (String.sub format (i+1) (j-i-1)) 122 | with _ -> 123 | invalid_arg 124 | ("format: bad %s format `" ^ String.sub format i (j-i) ^ "'")in 125 | if p > 0 && String.length s < p then begin 126 | Buffer.add_string buf (String.make (p - String.length s) ' '); 127 | Buffer.add_string buf s 128 | end else if p < 0 && String.length s < -p then begin 129 | Buffer.add_string buf s; 130 | Buffer.add_string buf (String.make (-p - String.length s) ' ') 131 | end else 132 | Buffer.add_string buf s 133 | end; 134 | doprn (succ j) args 135 | | 'c' -> 136 | let c = 137 | try Char.chr (V.int.V.project arg) 138 | with Invalid_argument _ -> V.projection arg "Character code" in 139 | Buffer.add_char buf c; 140 | doprn (succ j) args 141 | | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' -> 142 | let n = V.int.V.project arg in 143 | Buffer.add_string buf (format_int (String.sub format i (j-i+1)) n); 144 | doprn (succ j) args 145 | | 'f' | 'e' | 'E' | 'g' | 'G' -> 146 | let f = V.float.V.project arg in 147 | Buffer.add_string buf (format_float (String.sub format i (j-i+1)) f); 148 | doprn (succ j) args 149 | | 'p' -> 150 | I.error ("string library does not implement format specifier '%" ^ 151 | String.make 1 c ^ "'") 152 | | 'q' -> 153 | if j <= i+1 then 154 | add_quoted_string buf (V.string.V.project arg) 155 | else 156 | I.error "length not permitted with format specifier '%q'"; 157 | doprn (succ j) args 158 | | c -> 159 | I.error ("bad format specifier '%" ^ String.make 1 c ^ "'") 160 | end 161 | end 162 | 163 | and skip_args j = 164 | match String.get format j with 165 | '0' .. '9' | ' ' | '.' | '-' -> skip_args (succ j) 166 | | c -> j 167 | 168 | in doprn 0 169 | 170 | let format fmt args = bprintf_internal (Buffer.create 16) fmt args 171 | @ 172 | A recognizer takes as arguments a position and success and failure continuations. 173 | The implementation is based on standard parser combinators. 174 | <>= 175 | let explode s = 176 | let rec add n cs = if n = 0 then cs else add (n-1) (s.[n-1] :: cs) in 177 | add (String.length s) [] in 178 | <> 179 | let find pat s = 180 | let prerr_string s = () in 181 | let length = String.length s in 182 | let () = prerr_string "=========\n" in 183 | let lefts = ref [] in 184 | let pairs = ref [] in 185 | let push l x = l := x :: !l in 186 | let pop l = 187 | match !l with n :: ns -> (l := ns; n) | [] -> I.error "unmatched )" in 188 | let lparen lp i succ fail = 189 | push lefts (lp, i); succ i (fun () -> ignore (pop lefts); fail()) in 190 | let rparen i succ fail = 191 | let lp, start = pop lefts in 192 | push pairs (lp, start, i); 193 | succ i (fun () -> ignore (pop pairs); push lefts (lp, start); fail()) in 194 | let captures () = 195 | let rec insert ((i, l, r) as p) = function 196 | | [] -> [p] 197 | | (i', _, _) as p' :: ps -> if i < i' then p :: p' :: ps else p' :: insert p ps 198 | in let pairs = List.fold_right insert (!pairs) [] in 199 | List.map (fun (_, l, r) -> String.sub s l (r-l)) pairs in 200 | let atend i succ fail = if i = length then succ i fail else fail () in 201 | let atstart i succ fail = if i = 0 then succ i fail else fail () in 202 | let opt r i succ fail = r i succ (fun () -> succ i fail) in 203 | let (||) r r' i succ fail = 204 | r i succ (fun () -> r' i succ fail) in 205 | let (>>) r r' i succ fail = 206 | r i (fun i' resume -> r' i' succ resume) fail in 207 | let atzero r i succ fail = r i (succ 0) fail in 208 | let rec anywhere r i succ fail = 209 | r i (succ i) (fun () -> if i = length then fail () 210 | else anywhere r (i+1) succ fail) in 211 | let nonempty (r:'a parse) i succ fail = 212 | r i (fun i' resume -> if i = i' then resume () else succ i' resume) fail in 213 | let empty i succ fail = succ i fail in 214 | let rec star (r : 'a parse) = ((fun i -> ((nonempty r >> star r) || empty) i) : 'a parse) in 215 | let char p i succ fail = 216 | if (try p s.[i] with _ -> false) then succ (i+1) fail else fail () in 217 | let comp pat = 218 | let rec comp lps c cs = 219 | let rec finish (p, cs) = 220 | match cs with 221 | | '*' :: cs -> finish (star p, cs) 222 | | '?' :: cs -> finish (opt p, cs) 223 | | [] -> p 224 | | c :: cs -> p >> comp lps c cs in 225 | match c, cs with 226 | | '%', c :: cs -> finish (char (percent c), cs) 227 | | '$', [] -> atend 228 | | '.', cs -> finish (char (fun _ -> true), cs) 229 | | '[', cs -> let p, cs = cclass cs in finish(char p, cs) 230 | | '(', c :: cs -> lparen lps >> comp (lps+1) c cs 231 | | ')', c :: cs -> rparen >> comp lps c cs 232 | | ')', [] -> rparen 233 | | c , cs -> finish (char ((=) c), cs) in 234 | match pat with 235 | | [] -> fun i succ fail -> if i <= length then succ i i fail else fail () 236 | | '^' :: [] -> atzero atstart 237 | | '^' :: c :: cs -> atzero (atstart >> comp 0 c cs) 238 | | c :: cs -> anywhere (comp 0 c cs) in 239 | let with_caps p i succ fail = p i (fun i res -> succ (captures()) i res) fail in 240 | with_caps (comp pat) in 241 | <>= 242 | let andp p1 p2 c = p1 c && p2 c in 243 | let orp p1 p2 c = p1 c || p2 c in 244 | let range l h c = l <= c && c <= h in 245 | let lower = range 'a' 'z' in 246 | let upper = range 'A' 'Z' in 247 | let digit = range '0' '9' in 248 | let space c = c = ' ' || c = '\t' || c = '\r' || c = '\n' in 249 | let letter = orp lower upper in 250 | let alnum = orp letter digit in 251 | let non p c = not (p c) in 252 | let percent = function 253 | | 'a' -> letter | 'A' -> non letter 254 | | 'd' -> digit | 'D' -> non digit 255 | | 'l' -> lower | 'L' -> non lower 256 | | 's' -> space | 'S' -> non space 257 | | 'u' -> upper | 'U' -> non upper 258 | | 'w' -> alnum | 'W' -> non alnum 259 | | c when non alnum c -> (=) c 260 | | _ -> I.error "bad % escape in pattern" in 261 | @ 262 | <>= 263 | let cclass cs = 264 | let orr p (p', cs) = orp p p', cs in 265 | let rec pos cs = match cs with 266 | | ']' :: cs -> orr ((=) ']') (pos2 cs) 267 | | cs -> pos2 cs 268 | and pos2 cs = match cs with 269 | | '-' :: cs -> orr ((=) '-') (pos3 cs) 270 | | ']' :: cs -> (fun _ -> false), cs 271 | | _ -> pos3 cs 272 | and pos3 cs = match cs with 273 | | '%' :: c :: cs -> orr (percent c) (pos3 cs) 274 | | ']' :: cs -> (fun _ -> false), cs 275 | | c :: '-' :: ']' :: cs -> orp ((=) c) ((=) '-'), cs 276 | | c :: '-' :: c' :: cs -> orr (range c c') (pos3 cs) 277 | | c :: cs -> orr ((=) c) (pos3 cs) 278 | | [] -> I.error "bad character class in pattern" in 279 | match cs with 280 | | '^' :: cs -> let p, cs = pos cs in non p, cs 281 | | _ -> pos cs in 282 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.9) 2 | (name lua-ml) 3 | (version 0.9.5) 4 | (generate_opam_files true) 5 | (using menhir 2.0) 6 | 7 | (maintainers "Daniil Baturin ") 8 | 9 | (authors 10 | "Norman Ramsey " 11 | "Christian Lindig " 12 | "Daniil Baturin ") 13 | 14 | (source (github lindig/lua-ml)) 15 | (license "BSD-2-Clause") 16 | 17 | (package 18 | (name lua-ml) 19 | (synopsis "An embeddable Lua 2.5 interpreter implemented in OCaml") 20 | (depends 21 | (ocaml (>= "4.07.0")) menhir)) 22 | -------------------------------------------------------------------------------- /example/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name luaclient) 3 | (libraries lua)) 4 | -------------------------------------------------------------------------------- /example/luaclient.ml: -------------------------------------------------------------------------------- 1 | module LuaChar = struct 2 | type 'a t = char 3 | let tname = "char" 4 | let eq _ = fun x y -> x = y 5 | let to_string = fun _ c -> String.make 1 c 6 | end 7 | 8 | module Pair = struct 9 | type 'a t = 'a * 'a 10 | let tname = "pair" 11 | let eq _ = fun x y -> x = y 12 | let to_string = fun f (x,y) -> Printf.sprintf "(%s,%s)" (f x) (f y) 13 | let mk x y = (x,y) 14 | let fst = fst 15 | let snd = snd 16 | end 17 | 18 | 19 | module T = (* new types *) 20 | Lua.Lib.Combine.T3 (* T3 == link 3 modules *) 21 | (LuaChar) (* TV1 *) 22 | (Pair) (* TV2 *) 23 | (Luaiolib.T) (* TV3 *) 24 | 25 | module LuaCharT = T.TV1 26 | module PairT = T.TV2 27 | module LuaioT = T.TV3 28 | 29 | module MakeLib 30 | (CharV: Lua.Lib.TYPEVIEW with type 'a t = 'a LuaChar.t) 31 | (PairV: Lua.Lib.TYPEVIEW with type 'a t = 'a Pair.t 32 | and type 'a combined = 'a CharV.combined) 33 | : Lua.Lib.USERCODE with type 'a userdata' = 'a CharV.combined = struct 34 | 35 | type 'a userdata' = 'a PairV.combined 36 | module M (C: Lua.Lib.CORE with type 'a V.userdata' = 'a userdata') = struct 37 | module V = C.V 38 | let ( **-> ) = V.( **-> ) 39 | let ( **->> ) x y = x **-> V.result y 40 | module Map = struct 41 | let pair = PairV.makemap V.userdata V.projection 42 | let char = CharV.makemap V.userdata V.projection 43 | end 44 | 45 | let init g = 46 | 47 | C.register_module "Pair" 48 | [ "mk", V.efunc (V.value **-> V.value **->> Map.pair) Pair.mk 49 | ; "fst",V.efunc (Map.pair **->> V.value) Pair.fst 50 | ; "snd",V.efunc (Map.pair **->> V.value) Pair.snd 51 | ] g; 52 | 53 | C.register_module "Char" 54 | [ "mk", V.efunc (V.string **->> Map.char) 55 | (function 56 | | "" -> C.error "Char.mk: empty string" 57 | | s -> s.[0] 58 | ) 59 | ] g; 60 | 61 | C.register_module "Example" 62 | ["argv", (V.list V.string).V.embed (Array.to_list Sys.argv); 63 | "getenv", V.efunc (V.string **->> V.string) Sys.getenv; 64 | ] g; 65 | 66 | 67 | end (* M *) 68 | end (* MakeLib *) 69 | 70 | module W = Lua.Lib.WithType (T) 71 | module C = 72 | Lua.Lib.Combine.C5 (* C5 == combine 4 code modules *) 73 | (Luaiolib.Make(LuaioT)) 74 | (Luacamllib.Make(LuaioT)) 75 | (W (Luastrlib.M)) 76 | (W (Luamathlib.M)) 77 | (MakeLib (LuaCharT) (PairT)) 78 | 79 | 80 | module I = (* interpreter *) 81 | Lua.MakeInterp 82 | (Lua.Parser.MakeStandard) 83 | (Lua.MakeEval (T) (C)) 84 | 85 | 86 | let main () = 87 | let argv = Array.to_list Sys.argv in 88 | let args = List.tl argv in 89 | let state = I.mk () in (* fresh Lua interpreter *) 90 | let eval e = ignore (I.dostring state e) in 91 | ( List.iter eval args 92 | ; exit 0 93 | ) 94 | 95 | let _ = 96 | try main () (* alternatively use: module G = Lua.Run(I) *) 97 | with Failure msg -> print_endline msg 98 | -------------------------------------------------------------------------------- /lua-ml.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "0.9.5" 4 | synopsis: "An embeddable Lua 2.5 interpreter implemented in OCaml" 5 | maintainer: ["Daniil Baturin "] 6 | authors: [ 7 | "Norman Ramsey " 8 | "Christian Lindig " 9 | "Daniil Baturin " 10 | ] 11 | license: "BSD-2-Clause" 12 | homepage: "https://github.com/lindig/lua-ml" 13 | bug-reports: "https://github.com/lindig/lua-ml/issues" 14 | depends: [ 15 | "dune" {>= "2.9"} 16 | "ocaml" {>= "4.07.0"} 17 | "menhir" 18 | "odoc" {with-doc} 19 | ] 20 | build: [ 21 | ["dune" "subst"] {dev} 22 | [ 23 | "dune" 24 | "build" 25 | "-p" 26 | name 27 | "-j" 28 | jobs 29 | "--promote-install-files=false" 30 | "@install" 31 | "@runtest" {with-test} 32 | "@doc" {with-doc} 33 | ] 34 | ["dune" "install" "-p" name "--create-install-files" name] 35 | ] 36 | dev-repo: "git+https://github.com/lindig/lua-ml.git" 37 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (ocamllex luafloat luascanner) 2 | 3 | (menhir 4 | (modules luaparser_tokens) 5 | (flags --only-tokens)) 6 | 7 | (menhir 8 | (modules luaparser_tokens luaparser_impl) 9 | (merge_into luaparser_impl) 10 | (flags --external-tokens Luaparser_tokens)) 11 | 12 | (library 13 | (name lua) 14 | (libraries unix) 15 | ; sadness 16 | (wrapped false) 17 | (public_name lua-ml)) 18 | -------------------------------------------------------------------------------- /src/lua-std.mllib: -------------------------------------------------------------------------------- 1 | Lua 2 | Luaast 3 | Luabaselib 4 | Luacamllib 5 | Luainterp 6 | Luaiolib 7 | Lualib 8 | Luamathlib 9 | Luaparser 10 | Luarun 11 | Luasrcmap 12 | Luastrlib 13 | Luavalue 14 | Luafloat 15 | Luascanner 16 | 17 | -------------------------------------------------------------------------------- /src/lua.ml: -------------------------------------------------------------------------------- 1 | module type VALUE = Luavalue.S 2 | module type USERDATA = Luavalue.USERDATA 3 | 4 | module Lib = Lualib 5 | module Parser = Luaparser 6 | module type AST = Luaast.S 7 | 8 | module type EVALUATOR = Luainterp.S 9 | module type INTERP = sig 10 | include EVALUATOR 11 | module Parser : Luaparser.S with type chunk = Ast.chunk 12 | val do_lexbuf : sourcename:string -> state -> Lexing.lexbuf -> value list 13 | val dostring : ?file:string -> state -> string -> value list 14 | val dofile : state -> string -> value list 15 | val mk : unit -> state 16 | end 17 | module Run (I : INTERP) = Luarun.Make (I) 18 | module MakeEval = Luainterp.Make 19 | module MakeInterp = Luabaselib.Add 20 | 21 | module Empty = Lualib.Empty 22 | -------------------------------------------------------------------------------- /src/lua.mli: -------------------------------------------------------------------------------- 1 | module type VALUE = sig 2 | type 'a userdata' 3 | type srcloc 4 | type initstate 5 | 6 | module rec LuaValueBase : sig 7 | type value = 8 | Nil 9 | | Number of float 10 | | String of string 11 | | Function of srcloc * func 12 | | Userdata of userdata 13 | | Table of table 14 | and func = value list -> value list 15 | and table = value Luahash.t 16 | and userdata = value userdata' 17 | 18 | val eq : value -> value -> bool 19 | end and LuahashKey : sig 20 | type t 21 | val hash : t -> int 22 | val equal : t -> t -> bool 23 | end 24 | and Luahash : Hashtbl.S with type key = LuaValueBase.value 25 | 26 | type value = LuaValueBase.value 27 | and func = value list -> value list 28 | and table = value Luahash.t 29 | and userdata = value userdata' 30 | 31 | 32 | type state = { globals : table 33 | ; fallbacks : (string, value) Hashtbl.t 34 | ; mutable callstack : activation list 35 | ; mutable currentloc : Luasrcmap.location option (* supersedes top of stack *) 36 | ; startup : initstate 37 | } 38 | and activation = srcloc * Luasrcmap.location option 39 | 40 | val caml_func : func -> value (* each result unique *) 41 | val lua_func : file:string -> linedefined:int -> func -> value 42 | val srcloc : file:string -> linedefined:int -> srcloc (* must NOT be reused *) 43 | val eq : value -> value -> bool 44 | val to_string : value -> string 45 | val activation_strings : state -> activation -> string list 46 | type objname = Fallback of string | Global of string | Element of string * value 47 | val objname : state -> value -> objname option 48 | (* 'fallback', 'global', or 'element', name *) 49 | 50 | val state : unit -> state (* empty state, without even fallbacks *) 51 | val at_init : state -> string list -> unit (* run code at startup time *) 52 | val initcode : state -> (string -> unit) -> unit (* for the implementation only *) 53 | module Table : sig 54 | val create : int -> table 55 | val find : table -> key:value -> value 56 | val bind : table -> key:value -> data:value -> unit 57 | val of_list : (string * value) list -> table 58 | val next : value Luahash.t -> value -> (value * value) 59 | val first : value Luahash.t -> value * value 60 | end 61 | exception Projection of value * string 62 | val projection : value -> string -> 'a 63 | type ('a, 'b, 'c) ep = ('a, 'b, 'c) Luavalue.ep 64 | = { embed : 'a -> 'b; project : 'b -> 'a; is : 'c -> bool } 65 | type 'a map = ('a, value, value) ep 66 | type 'a mapf (* used to build function maps that curry/uncurry *) 67 | val float : float map 68 | val int : int map 69 | val bool : bool map 70 | val string : string map 71 | val userdata : userdata map 72 | val unit : unit map 73 | val option : 'a map -> 'a option map 74 | val default : 'a -> 'a map -> 'a map 75 | val list : 'a map -> 'a list map (* does not project nil *) 76 | val optlist : 'a map -> 'a list map (* projects nil to empty list *) 77 | val value : value map 78 | val table : table map 79 | val record : 'a map -> (string * 'a) list map 80 | val enum : string -> (string * 'a) list -> 'a map 81 | val ( --> ) : 'a map -> 'b map -> ('a -> 'b) map 82 | val ( **-> ) : 'a map -> 'b mapf -> ('a -> 'b) mapf 83 | val result : 'a map -> 'a mapf 84 | val resultvs : value list mapf (* functions returning value lists*) 85 | val resultpair:'a map -> 'b map -> ('a * 'b) mapf 86 | val dots_arrow:'a map -> 'b map -> ('a list -> 'b) mapf (* varargs functions *) 87 | val results : ('a -> value list) -> (value list -> 'a) -> 'a mapf 88 | (* 'a represents multiple results (general case) *) 89 | val func : 'a mapf -> 'a map (* function *) 90 | val closure : 'a mapf -> 'a map (* function or table+apply method *) 91 | val efunc : 'a mapf -> 'a -> value (* efunc f = (closure f).embed *) 92 | type alt (* an alternative *) 93 | val alt : 'a mapf -> 'a -> alt (* create an alternative *) 94 | val choose : alt list -> value (* dispatch on type/number of args *) 95 | val ( <|> ) : 'a map -> 'a map -> 'a map 96 | val ( <@ ) : 'a map -> ('a -> 'b) -> 'b map (* apply continuation after project *) 97 | end 98 | module type USERDATA = sig 99 | type 'a t (* type parameter will be Lua value *) 100 | val tname : string (* name of this type, for projection errors *) 101 | val eq : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool 102 | val to_string : ('a -> string) -> 'a t -> string 103 | end 104 | module type AST = Luaast.S 105 | module Parser : sig 106 | module type S = 107 | sig 108 | type chunk 109 | val chunks : (Lexing.lexbuf -> Luaparser_tokens.token) -> Lexing.lexbuf -> chunk list 110 | end 111 | module type MAKER = functor (Ast : AST) -> S with type chunk = Ast.chunk 112 | module MakeStandard : MAKER 113 | end 114 | module Lib : sig 115 | module type USERTYPE = sig 116 | type 'a t (* type parameter will be Lua value *) 117 | val tname : string (* name of this type, for projection errors *) 118 | val eq : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool 119 | val to_string : ('a -> string) -> 'a t -> string 120 | end 121 | module type TYPEVIEW = sig 122 | type 'a combined 123 | type 'a t (* the individual type of which this is a view *) 124 | val makemap : ('a combined, 'b, 'b) Luavalue.ep -> ('b -> string -> 'a t) 125 | -> ('a t, 'b, 'b) Luavalue.ep 126 | end 127 | module type COMBINED_CORE = sig 128 | type 'a also_t 129 | module type VIEW = TYPEVIEW with type 'a combined = 'a also_t 130 | module TV1 : VIEW 131 | module TV2 : VIEW 132 | module TV3 : VIEW 133 | module TV4 : VIEW 134 | module TV5 : VIEW 135 | module TV6 : VIEW 136 | module TV7 : VIEW 137 | module TV8 : VIEW 138 | module TV9 : VIEW 139 | module TV10 : VIEW 140 | end 141 | module type COMBINED_VIEWS = sig 142 | type 'a t 143 | include COMBINED_CORE with type 'a also_t = 'a t 144 | end 145 | module type COMBINED_TYPE = sig 146 | include USERTYPE 147 | include COMBINED_CORE with type 'a also_t = 'a t 148 | end 149 | module type CORE = sig 150 | module V : Luavalue.S 151 | val error : string -> 'a (* error fallback *) 152 | val getglobal : V.state -> V.value -> V.value 153 | val fallback : string -> V.state -> V.value list -> V.value list 154 | (* invoke named fallback on given state and arguments *) 155 | val setfallback : V.state -> string -> V.value -> V.value 156 | (* sets fallback, returns previous one *) 157 | val apply : V.value -> V.state -> V.value list -> V.value list 158 | 159 | val register_globals : (string * V.value) list -> V.state -> unit 160 | (* registers values as named global variables *) 161 | val register_module : string -> (string * V.value) list -> V.state -> unit 162 | (* register_module t l inserts members of l into global table t, 163 | creating t if needed *) 164 | end 165 | module type BARECODE = 166 | functor (C : CORE) -> sig 167 | val init : C.V.state -> unit 168 | end 169 | module type USERCODE = sig 170 | type 'a userdata' (* the userdata' tycon of the core on which lib depends *) 171 | module M : functor (C : CORE with type 'a V.userdata' = 'a userdata') -> sig 172 | val init : C.V.state -> unit 173 | end 174 | end 175 | module WithType 176 | (T : USERTYPE) (L : BARECODE) : USERCODE with type 'a userdata' = 'a T.t 177 | module Combine : sig 178 | module T10 (T1 : USERTYPE) (T2 : USERTYPE) (T3 : USERTYPE) (T4 : USERTYPE) 179 | (T5 : USERTYPE) (T6 : USERTYPE) (T7 : USERTYPE) (T8 : USERTYPE) 180 | (T9 : USERTYPE) (T10 : USERTYPE) 181 | : COMBINED_TYPE with type 'a TV1.t = 'a T1.t with type 'a TV2.t = 'a T2.t 182 | with type 'a TV3.t = 'a T3.t with type 'a TV4.t = 'a T4.t 183 | with type 'a TV5.t = 'a T5.t with type 'a TV6.t = 'a T6.t 184 | with type 'a TV7.t = 'a T7.t with type 'a TV8.t = 'a T8.t 185 | with type 'a TV9.t = 'a T9.t with type 'a TV10.t = 'a T10.t 186 | module T1 (T1 : USERTYPE) : COMBINED_TYPE 187 | with type 'a TV1.t = 'a T1.t 188 | module T2 (T1 : USERTYPE) (T2 : USERTYPE) : COMBINED_TYPE 189 | with type 'a TV1.t = 'a T1.t with type 'a TV2.t = 'a T2.t 190 | module T3 (T1 : USERTYPE) (T2 : USERTYPE) (T3 : USERTYPE) : COMBINED_TYPE 191 | with type 'a TV1.t = 'a T1.t with type 'a TV2.t = 'a T2.t with type 'a TV3.t = 'a T3.t 192 | module T4 (T1 : USERTYPE) (T2 : USERTYPE) (T3 : USERTYPE) (T4 : USERTYPE) : COMBINED_TYPE 193 | with type 'a TV1.t = 'a T1.t with type 'a TV2.t = 'a T2.t with type 'a TV3.t = 'a T3.t with type 'a TV4.t = 'a T4.t 194 | module T5 (T1 : USERTYPE) (T2 : USERTYPE) (T3 : USERTYPE) (T4 : USERTYPE) (T5 : USERTYPE) : COMBINED_TYPE 195 | with type 'a TV1.t = 'a T1.t with type 'a TV2.t = 'a T2.t with type 'a TV3.t = 'a T3.t with type 'a TV4.t = 'a T4.t with type 'a TV5.t = 'a T5.t 196 | module T6 (T1 : USERTYPE) (T2 : USERTYPE) (T3 : USERTYPE) (T4 : USERTYPE) (T5 : USERTYPE) (T6 : USERTYPE) : COMBINED_TYPE 197 | with type 'a TV1.t = 'a T1.t with type 'a TV2.t = 'a T2.t with type 'a TV3.t = 'a T3.t with type 'a TV4.t = 'a T4.t with type 'a TV5.t = 'a T5.t with type 'a TV6.t = 'a T6.t 198 | module T7 (T1 : USERTYPE) (T2 : USERTYPE) (T3 : USERTYPE) (T4 : USERTYPE) (T5 : USERTYPE) (T6 : USERTYPE) (T7 : USERTYPE) : COMBINED_TYPE 199 | with type 'a TV1.t = 'a T1.t with type 'a TV2.t = 'a T2.t with type 'a TV3.t = 'a T3.t with type 'a TV4.t = 'a T4.t with type 'a TV5.t = 'a T5.t with type 'a TV6.t = 'a T6.t with type 'a TV7.t = 'a T7.t 200 | module T8 (T1 : USERTYPE) (T2 : USERTYPE) (T3 : USERTYPE) (T4 : USERTYPE) (T5 : USERTYPE) (T6 : USERTYPE) (T7 : USERTYPE) (T8 : USERTYPE) : COMBINED_TYPE 201 | with type 'a TV1.t = 'a T1.t with type 'a TV2.t = 'a T2.t with type 'a TV3.t = 'a T3.t with type 'a TV4.t = 'a T4.t with type 'a TV5.t = 'a T5.t with type 'a TV6.t = 'a T6.t with type 'a TV7.t = 'a T7.t with type 'a TV8.t = 'a T8.t 202 | module T9 (T1 : USERTYPE) (T2 : USERTYPE) (T3 : USERTYPE) (T4 : USERTYPE) (T5 : USERTYPE) (T6 : USERTYPE) (T7 : USERTYPE) (T8 : USERTYPE) (T9 : USERTYPE) : COMBINED_TYPE 203 | with type 'a TV1.t = 'a T1.t with type 'a TV2.t = 'a T2.t with type 'a TV3.t = 'a T3.t with type 'a TV4.t = 'a T4.t with type 'a TV5.t = 'a T5.t with type 'a TV6.t = 'a T6.t with type 'a TV7.t = 'a T7.t with type 'a TV8.t = 'a T8.t with type 'a TV9.t = 'a T9.t 204 | 205 | module C10 (C1 : USERCODE) 206 | (C2 : USERCODE with type 'a userdata' = 'a C1.userdata') 207 | (C3 : USERCODE with type 'a userdata' = 'a C1.userdata') 208 | (C4 : USERCODE with type 'a userdata' = 'a C1.userdata') 209 | (C5 : USERCODE with type 'a userdata' = 'a C1.userdata') 210 | (C6 : USERCODE with type 'a userdata' = 'a C1.userdata') 211 | (C7 : USERCODE with type 'a userdata' = 'a C1.userdata') 212 | (C8 : USERCODE with type 'a userdata' = 'a C1.userdata') 213 | (C9 : USERCODE with type 'a userdata' = 'a C1.userdata') 214 | (C10 : USERCODE with type 'a userdata' = 'a C1.userdata') : 215 | USERCODE with type 'a userdata' = 'a C1.userdata' 216 | module C1 (C1 : USERCODE) 217 | : USERCODE with type 'a userdata' = 'a C1.userdata' 218 | module C2 (C1 : USERCODE) 219 | (C2 : USERCODE with type 'a userdata' = 'a C1.userdata') 220 | : USERCODE with type 'a userdata' = 'a C1.userdata' 221 | module C3 (C1 : USERCODE) 222 | (C2 : USERCODE with type 'a userdata' = 'a C1.userdata') 223 | (C3 : USERCODE with type 'a userdata' = 'a C1.userdata') 224 | : USERCODE with type 'a userdata' = 'a C1.userdata' 225 | module C4 (C1 : USERCODE) 226 | (C2 : USERCODE with type 'a userdata' = 'a C1.userdata') 227 | (C3 : USERCODE with type 'a userdata' = 'a C1.userdata') 228 | (C4 : USERCODE with type 'a userdata' = 'a C1.userdata') 229 | : USERCODE with type 'a userdata' = 'a C1.userdata' 230 | module C5 (C1 : USERCODE) 231 | (C2 : USERCODE with type 'a userdata' = 'a C1.userdata') 232 | (C3 : USERCODE with type 'a userdata' = 'a C1.userdata') 233 | (C4 : USERCODE with type 'a userdata' = 'a C1.userdata') 234 | (C5 : USERCODE with type 'a userdata' = 'a C1.userdata') 235 | : USERCODE with type 'a userdata' = 'a C1.userdata' 236 | module C6 (C1 : USERCODE) 237 | (C2 : USERCODE with type 'a userdata' = 'a C1.userdata') 238 | (C3 : USERCODE with type 'a userdata' = 'a C1.userdata') 239 | (C4 : USERCODE with type 'a userdata' = 'a C1.userdata') 240 | (C5 : USERCODE with type 'a userdata' = 'a C1.userdata') 241 | (C6 : USERCODE with type 'a userdata' = 'a C1.userdata') 242 | : USERCODE with type 'a userdata' = 'a C1.userdata' 243 | module C7 (C1 : USERCODE) 244 | (C2 : USERCODE with type 'a userdata' = 'a C1.userdata') 245 | (C3 : USERCODE with type 'a userdata' = 'a C1.userdata') 246 | (C4 : USERCODE with type 'a userdata' = 'a C1.userdata') 247 | (C5 : USERCODE with type 'a userdata' = 'a C1.userdata') 248 | (C6 : USERCODE with type 'a userdata' = 'a C1.userdata') 249 | (C7 : USERCODE with type 'a userdata' = 'a C1.userdata') 250 | : USERCODE with type 'a userdata' = 'a C1.userdata' 251 | module C8 (C1 : USERCODE) 252 | (C2 : USERCODE with type 'a userdata' = 'a C1.userdata') 253 | (C3 : USERCODE with type 'a userdata' = 'a C1.userdata') 254 | (C4 : USERCODE with type 'a userdata' = 'a C1.userdata') 255 | (C5 : USERCODE with type 'a userdata' = 'a C1.userdata') 256 | (C6 : USERCODE with type 'a userdata' = 'a C1.userdata') 257 | (C7 : USERCODE with type 'a userdata' = 'a C1.userdata') 258 | (C8 : USERCODE with type 'a userdata' = 'a C1.userdata') 259 | : USERCODE with type 'a userdata' = 'a C1.userdata' 260 | module C9 (C1 : USERCODE) 261 | (C2 : USERCODE with type 'a userdata' = 'a C1.userdata') 262 | (C3 : USERCODE with type 'a userdata' = 'a C1.userdata') 263 | (C4 : USERCODE with type 'a userdata' = 'a C1.userdata') 264 | (C5 : USERCODE with type 'a userdata' = 'a C1.userdata') 265 | (C6 : USERCODE with type 'a userdata' = 'a C1.userdata') 266 | (C7 : USERCODE with type 'a userdata' = 'a C1.userdata') 267 | (C8 : USERCODE with type 'a userdata' = 'a C1.userdata') 268 | (C9 : USERCODE with type 'a userdata' = 'a C1.userdata') 269 | : USERCODE with type 'a userdata' = 'a C1.userdata' 270 | 271 | end 272 | module Lift (T : COMBINED_TYPE) (View : TYPEVIEW with type 'a t = 'a T.t) : 273 | COMBINED_VIEWS with type 'a t = 'a View.combined 274 | with type 'a TV1.t = 'a T.TV1.t 275 | with type 'a TV2.t = 'a T.TV2.t 276 | with type 'a TV3.t = 'a T.TV3.t 277 | with type 'a TV4.t = 'a T.TV4.t 278 | with type 'a TV5.t = 'a T.TV5.t 279 | with type 'a TV6.t = 'a T.TV6.t 280 | with type 'a TV7.t = 'a T.TV7.t 281 | with type 'a TV8.t = 'a T.TV8.t 282 | with type 'a TV9.t = 'a T.TV9.t 283 | with type 'a TV10.t = 'a T.TV10.t 284 | 285 | end 286 | module type EVALUATOR = sig 287 | module Value : VALUE 288 | module Ast : AST with module Value = Value 289 | type state = Value.state 290 | type value = Value.value 291 | exception Error of string 292 | type compiled = unit -> value list 293 | val compile : srcdbg:(Luasrcmap.map * bool) -> Ast.chunk list -> state -> compiled 294 | type startup_code = (string -> unit) -> unit 295 | val pre_mk : unit -> state * startup_code (* produce a fresh, initialized state *) 296 | val error : string -> 'a (* error fallback *) 297 | 298 | val getglobal : state -> value -> value 299 | (* get the named global variable *) 300 | val fallback : string -> state -> value list -> value list 301 | (* invoke named fallback on given state and arguments *) 302 | val with_stack : Value.srcloc -> state -> ('a -> 'b) -> 'a -> 'b 303 | (* evaluate function with given srcloc on activation stack *) 304 | 305 | val setfallback : state -> string -> value -> value 306 | (* sets fallback, returns previous one *) 307 | val register_globals : (string * value) list -> state -> unit 308 | (* registers values as named global variables *) 309 | val register_module : string -> (string * value) list -> state -> unit 310 | (* register_module t l inserts members of l into global table t, 311 | creating t if needed *) 312 | end 313 | 314 | module MakeEval 315 | (T : Lib.USERTYPE) 316 | (L : Lib.USERCODE with type 'a userdata' = 'a T.t) 317 | : EVALUATOR with type 'a Value.userdata' = 'a T.t 318 | module Empty : sig 319 | module Type : Lib.USERTYPE 320 | module Library : Lib.USERCODE 321 | end 322 | module type INTERP = sig 323 | include EVALUATOR 324 | module Parser : Luaparser.S with type chunk = Ast.chunk 325 | val do_lexbuf : sourcename:string -> state -> Lexing.lexbuf -> value list 326 | val dostring : ?file:string -> state -> string -> value list 327 | val dofile : state -> string -> value list 328 | val mk : unit -> state 329 | end 330 | module MakeInterp (MakeParser : Parser.MAKER) (I : EVALUATOR) 331 | : INTERP with module Value = I.Value 332 | module Run (I : INTERP) : sig end (* runs interpreter on Sys.argv *) 333 | -------------------------------------------------------------------------------- /src/luaast.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | module Value : Luavalue.S 3 | type value = Value.value 4 | type name = string 5 | 6 | type varargs = bool 7 | type funcargs = name list * varargs 8 | type location = int (* character position *) 9 | type stmt = 10 | | Stmt' of location * stmt 11 | | Assign of lval list * exp list 12 | | WhileDo of exp * block 13 | | RepeatUntil of block * exp 14 | | If of exp * block * (exp * block) list * block option 15 | | Return of exp list 16 | | Callstmt of call 17 | | Local of name list * exp list 18 | and block = stmt list 19 | and lval = 20 | | Lvar of name 21 | | Lindex of exp * exp 22 | and exp = 23 | | Var of name 24 | | Lit of value 25 | | Binop of exp * op * exp 26 | | Unop of op * exp 27 | | Index of exp * exp 28 | | Table of exp list * (name * exp) list 29 | | Call of call 30 | and call = 31 | | Funcall of exp * exp list 32 | | Methcall of exp * name * exp list 33 | and op = And | Or | Lt | Le | Gt | Ge | Eq | Ne | Concat 34 | | Plus | Minus | Times | Div | Mod | Not | Pow 35 | 36 | type chunk = 37 | | Debug of bool (* turn debugging on/off *) 38 | | Statement of stmt 39 | | Fundef of location * lval * funcargs * block 40 | | Methdef of location * exp * name * funcargs * block 41 | 42 | end 43 | 44 | module Make (V : Luavalue.S) : S with module Value = V = struct 45 | module Value = V 46 | type value = Value.value 47 | type name = string 48 | 49 | type varargs = bool 50 | type funcargs = name list * varargs 51 | type location = int (* character position *) 52 | type stmt = 53 | | Stmt' of location * stmt 54 | | Assign of lval list * exp list 55 | | WhileDo of exp * block 56 | | RepeatUntil of block * exp 57 | | If of exp * block * (exp * block) list * block option 58 | | Return of exp list 59 | | Callstmt of call 60 | | Local of name list * exp list 61 | and block = stmt list 62 | and lval = 63 | | Lvar of name 64 | | Lindex of exp * exp 65 | and exp = 66 | | Var of name 67 | | Lit of value 68 | | Binop of exp * op * exp 69 | | Unop of op * exp 70 | | Index of exp * exp 71 | | Table of exp list * (name * exp) list 72 | | Call of call 73 | and call = 74 | | Funcall of exp * exp list 75 | | Methcall of exp * name * exp list 76 | and op = And | Or | Lt | Le | Gt | Ge | Eq | Ne | Concat 77 | | Plus | Minus | Times | Div | Mod | Not | Pow 78 | 79 | type chunk = 80 | | Debug of bool (* turn debugging on/off *) 81 | | Statement of stmt 82 | | Fundef of location * lval * funcargs * block 83 | | Methdef of location * exp * name * funcargs * block 84 | 85 | end 86 | -------------------------------------------------------------------------------- /src/luaast.mli: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | module Value : Luavalue.S 3 | type value = Value.value 4 | type name = string 5 | 6 | type varargs = bool 7 | type funcargs = name list * varargs 8 | type location = int (* character position *) 9 | type stmt = 10 | | Stmt' of location * stmt 11 | | Assign of lval list * exp list 12 | | WhileDo of exp * block 13 | | RepeatUntil of block * exp 14 | | If of exp * block * (exp * block) list * block option 15 | | Return of exp list 16 | | Callstmt of call 17 | | Local of name list * exp list 18 | and block = stmt list 19 | and lval = 20 | | Lvar of name 21 | | Lindex of exp * exp 22 | and exp = 23 | | Var of name 24 | | Lit of value 25 | | Binop of exp * op * exp 26 | | Unop of op * exp 27 | | Index of exp * exp 28 | | Table of exp list * (name * exp) list 29 | | Call of call 30 | and call = 31 | | Funcall of exp * exp list 32 | | Methcall of exp * name * exp list 33 | and op = And | Or | Lt | Le | Gt | Ge | Eq | Ne | Concat 34 | | Plus | Minus | Times | Div | Mod | Not | Pow 35 | 36 | type chunk = 37 | | Debug of bool (* turn debugging on/off *) 38 | | Statement of stmt 39 | | Fundef of location * lval * funcargs * block 40 | | Methdef of location * exp * name * funcargs * block 41 | 42 | end 43 | 44 | module Make (V : Luavalue.S) : S with module Value = V 45 | -------------------------------------------------------------------------------- /src/luabaselib.ml: -------------------------------------------------------------------------------- 1 | module Add (MakeParser : Luaparser.MAKER) (I : Luainterp.S) = struct 2 | module Parser = MakeParser (I.Ast) 3 | module P = Parser 4 | module V = I.Value 5 | let lex map buf = Luascanner.token buf map 6 | let do_lexbuf ~sourcename:filename g buf = 7 | let map = Luasrcmap.mk () in 8 | let _ = Luasrcmap.sync map 0 (filename, 1, 1) in 9 | try 10 | let chunks = P.chunks (lex map) buf in 11 | let pgm = I.compile ~srcdbg:(map, false) chunks g in 12 | match pgm () with 13 | | [] -> [I.Value.LuaValueBase.String "executed without errors"] 14 | | answers -> answers 15 | with 16 | | Parsing.Parse_error -> 17 | let file, line, _ = Luasrcmap.last map in 18 | let errmsg = Printf.sprintf "%s: Syntax error on line %d" file line in 19 | failwith errmsg 20 | | I.Error s -> failwith (Printf.sprintf "Runtime error: %s" s) 21 | | I.Value.Projection (_v, w) -> (failwith ("Error projecting to " ^ w)) 22 | 23 | 24 | let dostring ?(file="") g s = 25 | let abbreviate s = 26 | if String.length s < 200 then s 27 | else String.sub s 0 60 ^ "..." in 28 | I.with_stack (V.srcloc ~file:("dostring('" ^ abbreviate s ^ "')") ~linedefined:0) g 29 | (do_lexbuf ~sourcename:file g) (Lexing.from_string s) 30 | 31 | let dofile g infile = 32 | try 33 | let f = match infile with "-" -> stdin | _ -> open_in infile in 34 | let close () = if infile <> "-" then close_in f else () in 35 | try 36 | let answer = I.with_stack (V.srcloc ~file:("dofile('" ^ infile ^ "')") ~linedefined:0) g 37 | (do_lexbuf ~sourcename:infile g) (Lexing.from_channel f) 38 | in (close(); answer) 39 | with e -> (close (); raise e) 40 | with Sys_error msg -> [V.LuaValueBase.Nil; V.LuaValueBase.String ("System error: " ^ msg)] 41 | 42 | let ( **-> ) = V.( **-> ) 43 | let ( **->> ) x y = x **-> V.result y 44 | 45 | let next t key = 46 | let k, v = 47 | try match key with 48 | | V.LuaValueBase.Nil -> V.Table.first t 49 | | _ -> V.Table.next t key 50 | with Not_found -> V.LuaValueBase.Nil, V.LuaValueBase.Nil 51 | in [k; v] 52 | 53 | let objname g v = 54 | let tail = [] in 55 | let ss = match V.objname g v with 56 | | Some (V.Fallback n) -> "`" :: n :: "' fallback" :: tail 57 | | Some (V.Global n) -> "function " :: n :: tail 58 | | Some (V.Element (t, V.LuaValueBase.String n)) -> "function " :: t :: "." :: n :: tail 59 | | Some (V.Element (t, v)) -> "function " :: t :: "[" :: V.to_string v :: "]" :: tail 60 | | None -> "unnamed " :: V.to_string v :: tail in 61 | String.concat "" ss 62 | 63 | 64 | 65 | let luabaselib g = 66 | [ "dofile", V.efunc (V.string **-> V.resultvs) (dofile g) 67 | ; "dostring", V.efunc (V.string **-> V.resultvs) (dostring g) 68 | (* should catch Sys_error and turn into an error fallback... *) 69 | ; "size", V.efunc (V.table **->> V.int) V.Luahash.length 70 | ; "next", V.efunc (V.table **-> V.value **-> V.resultvs) next 71 | ; "nextvar", V.efunc (V.value **-> V.resultvs) (fun x -> next g.V.globals x) 72 | ; "tostring", V.efunc (V.value **->> V.string) V.to_string 73 | ; "objname", V.efunc (V.value **->> V.string) (objname g) 74 | ; "print", V.caml_func 75 | (fun args -> 76 | List.iter (fun x -> print_endline (V.to_string x)) args; 77 | flush stdout; 78 | []) 79 | ; "tonumber", V.efunc (V.float **->> V.float) (fun x -> x) 80 | ; "type", V.efunc (V.value **->> V.string) 81 | (function 82 | | V.LuaValueBase.Nil -> "nil" 83 | | V.LuaValueBase.Number _ -> "number" 84 | | V.LuaValueBase.String _ -> "string" 85 | | V.LuaValueBase.Table _ -> "table" 86 | | V.LuaValueBase.Function (_,_) -> "function" 87 | | V.LuaValueBase.Userdata _ -> "userdata") 88 | ; "assert", V.efunc (V.value **-> V.default "" V.string **->> V.unit) 89 | (fun c msg -> match c with 90 | | V.LuaValueBase.Nil -> I.error ("assertion failed: " ^ msg) 91 | | _ -> ()) 92 | ; "error", V.efunc (V.string **->> V.unit) I.error 93 | ; "setglobal", V.efunc (V.value **-> V.value **->> V.unit) 94 | (fun k v -> V.Table.bind g.V.globals ~key:k ~data:v) 95 | ; "getglobal", V.efunc (V.value **->> V.value) (I.getglobal g) 96 | ; "setfallback", V.efunc (V.string **-> V.value **->> V.value) (I.setfallback g) 97 | ] 98 | 99 | include I 100 | let mk () = 101 | let g, init = I.pre_mk () in 102 | I.register_globals (luabaselib g) g; 103 | init (fun s -> ignore (dostring g s)); 104 | g 105 | end 106 | -------------------------------------------------------------------------------- /src/luabaselib.mli: -------------------------------------------------------------------------------- 1 | module Add (MakeParser : Luaparser.MAKER) (I : Luainterp.S) : sig 2 | include Luainterp.S 3 | module Parser : Luaparser.S with type chunk = Ast.chunk 4 | val do_lexbuf : sourcename:string -> state -> Lexing.lexbuf -> value list 5 | val dostring : ?file:string -> state -> string -> value list 6 | val dofile : state -> string -> value list 7 | val mk : unit -> state (* builds state and runs startup code *) 8 | end with module Value = I.Value 9 | -------------------------------------------------------------------------------- /src/luacamllib.ml: -------------------------------------------------------------------------------- 1 | module IO = Luaiolib 2 | module Make (T : Lua.Lib.TYPEVIEW with type 'a t = 'a Luaiolib.t) 3 | : Lua.Lib.USERCODE with type 'a userdata' = 'a T.combined = 4 | struct 5 | type 'a userdata' = 'a T.combined 6 | module M (C : Lua.Lib.CORE with type 'a V.userdata' = 'a userdata') = 7 | struct 8 | module V = C.V 9 | let ( **-> ) = V.( **-> ) 10 | let ( --> ) = V.( --> ) 11 | let init = 12 | let ( **->> ) x y = x **-> V.result y in 13 | let a = V.value in 14 | let b = V.value in 15 | let list = V.list in 16 | let string = V.string in 17 | let int = V.int in 18 | let bool = V.bool in 19 | let ef = V.efunc in 20 | let caml_modules = 21 | let swap (x, y) = (y, x) in 22 | List.map (fun (m, vs) -> (m, V.LuaValueBase.Table (V.Table.of_list (List.map swap vs)))) 23 | ["Filename", 24 | (let extension s = 25 | try 26 | let without = Filename.chop_extension s in 27 | let n = String.length without in 28 | String.sub s n (String.length s - n) 29 | with Invalid_argument _ -> "" in 30 | let chop s = try Filename.chop_extension s with Invalid_argument _ -> s in 31 | [ ef (string **-> string **->> V.bool) Filename.check_suffix, "check_suffix" 32 | ; ef (string **->> string) chop, "chop_extension" 33 | ; ef (string **->> string) extension, "extension" 34 | ; ef (string **-> string **->> string) Filename.concat, "concat" 35 | ; ef (string **->> string) Filename.basename, "basename" 36 | ; ef (string **->> string) Filename.dirname, "dirname" 37 | ; ef (string **-> string **->> string) Filename.temp_file, "temp_file" 38 | ; ef (string **->> string) Filename.quote, "quote" 39 | ]) 40 | ; "List", 41 | [ ef (list a **->> int) List.length, "length" 42 | ; ef (list a **->> list a) List.rev, "rev" 43 | ; ef (list a **-> list a **->> list a) List.append, "append" 44 | ; ef (list a **-> list a **->> list a) List.rev_append, "rev_append" 45 | ; ef (list (list a) **->> list a) List.concat, "concat" 46 | ; ef ((a --> b) **-> list a **->> list b) List.map, "map" 47 | ; ef ((a --> V.unit) **-> list a **->> V.unit) List.iter, "iter" 48 | ; ef ((a --> b) **-> list a **->> list b) List.rev_map, "rev_map" 49 | ; ef ((a --> bool) **-> list a **->> bool) List.for_all, "for_all" 50 | ; ef ((a --> bool) **-> list a **->> bool) List.exists, "exists" 51 | ; ef ((a --> bool) **-> list a **->> list a) List.filter, "filter" 52 | ; ef (V.func (a **-> a **->> int) **-> list a **->> list a) List.sort, "sort" 53 | ; ef (V.func (a **-> a **->> int) **-> list a **->> list a) List.stable_sort, 54 | "stable_sort" 55 | ] 56 | ] in 57 | 58 | C.register_module "Caml" caml_modules 59 | end (*M*) 60 | end (*Make*) 61 | -------------------------------------------------------------------------------- /src/luacamllib.mli: -------------------------------------------------------------------------------- 1 | module Make (TV : Lua.Lib.TYPEVIEW with type 'a t = 'a Luaiolib.t) 2 | : Lua.Lib.USERCODE with type 'a userdata' = 'a TV.combined 3 | -------------------------------------------------------------------------------- /src/luafloat.mll: -------------------------------------------------------------------------------- 1 | let digit = ['0'-'9'] 2 | let sign = ['+' '-'] 3 | let exp = ['e''E'] sign? digit+ 4 | let number = sign? digit+ exp? 5 | | sign? digit+ '.' digit+ exp? 6 | rule length = parse number { Lexing.lexeme_end lexbuf } | _ { -1 } 7 | -------------------------------------------------------------------------------- /src/luainterp.mli: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | module Value : Luavalue.S 3 | module Ast : Luaast.S with module Value = Value 4 | type state = Value.state 5 | type value = Value.value 6 | exception Error of string 7 | type compiled = unit -> value list 8 | val compile : srcdbg:(Luasrcmap.map * bool) -> Ast.chunk list -> state -> compiled 9 | type startup_code = (string -> unit) -> unit 10 | val pre_mk : unit -> state * startup_code (* produce a fresh, initialized state *) 11 | val error : string -> 'a (* error fallback *) 12 | 13 | val getglobal : state -> value -> value 14 | (* get the named global variable *) 15 | val fallback : string -> state -> value list -> value list 16 | (* invoke named fallback on given state and arguments *) 17 | val with_stack : Value.srcloc -> state -> ('a -> 'b) -> 'a -> 'b 18 | (* evaluates function with given srcloc on activation stack *) 19 | 20 | val setfallback : state -> string -> value -> value 21 | (* sets fallback, returns previous one *) 22 | val register_globals : (string * value) list -> state -> unit 23 | (* registers values as named global variables *) 24 | val register_module : string -> (string * value) list -> state -> unit 25 | (* register_module t l inserts members of l into global table t, 26 | creating t if needed *) 27 | end 28 | 29 | module Make (T : Luavalue.USERDATA) 30 | (L : Lualib.USERCODE with type 'a userdata' = 'a T.t) : 31 | S with type 'a Value.userdata' = 'a T.t 32 | -------------------------------------------------------------------------------- /src/luaiolib.ml: -------------------------------------------------------------------------------- 1 | type 'a t = In of in_channel | Out of out_channel 2 | type 'a state = { mutable currentin : in_channel 3 | ; mutable currentout : out_channel 4 | } 5 | type 'a alias_for_t = 'a t 6 | module T = struct 7 | type 'a t = 'a alias_for_t 8 | let tname = "I/O channel" 9 | let eq _ x y = match x, y with 10 | | In x, In y -> x = y 11 | | Out x, Out y -> x = y 12 | | _, _ -> false 13 | let to_string _ = function 14 | | In _ -> "