├── lib ├── OMakefile ├── erlang.bri ├── bitstring.bri └── pervasives.bri ├── src ├── version.ml ├── version.mli ├── with.ml ├── beta.mli ├── console.mli ├── emit.mli ├── beta.ml ├── xstring.mli ├── xstring.ml ├── intRepr.mli ├── alpha.mli ├── compiler.mli ├── erlang.mli ├── log.mli ├── xset.mli ├── position.mli ├── source.mli ├── intRepr.ml ├── xbase.mli ├── xlist.mli ├── naming.mli ├── xset.ml ├── xbase.ml ├── position.ml ├── log.ml ├── utils.mli ├── sig.mli ├── closure.mli ├── id.mli ├── kNormal.mli ├── xmap.mli ├── binding.mli ├── module.mli ├── library.mli ├── config.mli ├── config.ml ├── source.ml ├── id.ml ├── xlist.ml ├── base.ml ├── env.mli ├── type_t.ml ├── type.mli ├── ast.mli ├── tagging.mli ├── bitstring.mli ├── xmap.ml ├── utils.ml ├── module.ml ├── binding.ml ├── location.mli ├── typing.mli ├── library.ml ├── erlang_t.ml ├── kNormal_t.ml ├── env.ml ├── closure_t.ml ├── location.ml ├── ast_t.ml ├── tagging.ml ├── sig.ml ├── bitstring.ml ├── erlang.ml ├── main.ml ├── compiler.ml ├── alpha.ml ├── console.ml ├── naming.ml ├── OMakefile ├── ast.ml ├── type.ml ├── lexer.mll ├── emit.ml ├── kNormal.ml └── closure.ml ├── test ├── typdef │ ├── test_bool.br │ ├── test_char.br │ ├── test_int.br │ ├── test_unit.br │ ├── test_atom.br │ ├── test_binary.br │ ├── test_float.br │ ├── test_int_list.br │ ├── test_poly_list.br │ ├── test_string.br │ ├── test_tuple.br │ ├── test_bitstring.br │ ├── test_poly_tycon.br │ ├── test_simple_tycon.br │ ├── test_record.br │ ├── test_poly_record.br │ └── test_tycon_args.br ├── parsing │ ├── tuple.br │ ├── bool.br │ ├── topvar.br │ ├── def.br │ ├── dollar.br │ ├── sig_var.bri │ ├── sig_def.bri │ ├── float.br │ ├── ref.br │ ├── list.br │ ├── exception.br │ ├── array.br │ ├── monad.br │ ├── int.br │ ├── external.bri │ ├── simple_typdef.br │ ├── field.br │ ├── assert.br │ ├── comment.br │ ├── local_var.br │ ├── circular_ref.br │ ├── message.br │ ├── atom.br │ ├── for.br │ ├── floatop.br │ ├── variant_typdef.br │ ├── local_def.br │ ├── intop.br │ ├── try.br │ ├── record_typdef.br │ ├── string.br │ ├── fun.br │ ├── if.br │ ├── do.br │ ├── pattern.br │ ├── match.br │ ├── char.br │ └── bitstring.br ├── test_typexp.mli ├── typexp │ ├── test_bool.bri │ ├── test_char.bri │ ├── test_float.bri │ ├── test_int.bri │ ├── test_unit.bri │ ├── test_atom.bri │ ├── test_binary.bri │ ├── test_tuple.bri │ ├── test_list.bri │ ├── test_string.bri │ ├── test_bitstring.bri │ ├── test_poly_list.bri │ ├── test_constr_params.bri │ ├── test_fun_of_unit_unit.bri │ ├── test_poly_fun.bri │ ├── test_fun_of_int_float_string.bri │ └── test_fun_of_fun.bri ├── test_literals.mli ├── test_parsing.mli ├── literals │ ├── test_char.br │ ├── test_unit.br │ ├── test_atom.br │ ├── test_true.br │ ├── test_false.br │ ├── test_float.br │ ├── test_int.br │ ├── test_string.br │ ├── test_list.br │ ├── test_tuple.br │ ├── test_atom_quote.br │ ├── test_binary.br │ └── test_bitstring.br ├── variant │ ├── test_args.br │ └── test_noargs.br ├── xounit.mli ├── pattern │ ├── test_var.br │ ├── test_unit.br │ ├── test_as.br │ ├── test_bool.br │ ├── test_empty_list.br │ ├── test_one_list.br │ ├── test_cons.br │ ├── test_int.br │ ├── test_constr.br │ ├── test_list.br │ ├── test_tuple.br │ ├── test_tuple_var.br │ ├── test_float.br │ ├── test_atom.br │ ├── test_string.br │ └── test_constr_args.br ├── run.ml ├── program.mli ├── README.md ├── testlib.erl ├── xounit.ml ├── test_variant.ml ├── OMakefile ├── program.ml ├── test_literals.ml ├── test_pattern.ml ├── test_typdef.ml ├── test_typexp.ml ├── test_parsing.ml ├── sealing.mli └── sealing.ml ├── bran.install ├── examples ├── erleval.br ├── id.br ├── fib.br ├── helloworld.br └── hanoi.br ├── liberl ├── rebar ├── src │ ├── bran.erl │ ├── bran_lib_bitstring.erl │ ├── bran_lib_pervasives.erl │ ├── bran.app.src │ └── bran_lib_erlang.erl ├── test │ └── bran_tests.erl ├── OMakefile ├── Makefile └── rebar.config ├── OMakefile ├── devbuild.sh ├── opam ├── circle ├── install-ocaml.sh ├── install-otp.sh └── install-opam.sh ├── .gitignore ├── circle.yml ├── OMakeroot └── README.md /lib/OMakefile: -------------------------------------------------------------------------------- 1 | .PHONY: all install clean 2 | -------------------------------------------------------------------------------- /src/version.ml: -------------------------------------------------------------------------------- 1 | let version = "0.1.0" 2 | -------------------------------------------------------------------------------- /src/version.mli: -------------------------------------------------------------------------------- 1 | val version : string 2 | -------------------------------------------------------------------------------- /src/with.ml: -------------------------------------------------------------------------------- 1 | module Loc = Location.Tag 2 | -------------------------------------------------------------------------------- /test/typdef/test_bool.br: -------------------------------------------------------------------------------- 1 | type t = bool 2 | -------------------------------------------------------------------------------- /test/typdef/test_char.br: -------------------------------------------------------------------------------- 1 | type t = char 2 | -------------------------------------------------------------------------------- /test/typdef/test_int.br: -------------------------------------------------------------------------------- 1 | type t = int 2 | -------------------------------------------------------------------------------- /test/typdef/test_unit.br: -------------------------------------------------------------------------------- 1 | type t = unit 2 | -------------------------------------------------------------------------------- /src/beta.mli: -------------------------------------------------------------------------------- 1 | val f : KNormal.t -> KNormal.t 2 | -------------------------------------------------------------------------------- /test/parsing/tuple.br: -------------------------------------------------------------------------------- 1 | var t1 = (1, 2, "3") 2 | -------------------------------------------------------------------------------- /test/test_typexp.mli: -------------------------------------------------------------------------------- 1 | val suite : OUnit2.test 2 | -------------------------------------------------------------------------------- /test/typdef/test_atom.br: -------------------------------------------------------------------------------- 1 | type t = atom 2 | 3 | -------------------------------------------------------------------------------- /test/typexp/test_bool.bri: -------------------------------------------------------------------------------- 1 | var dummy : bool 2 | -------------------------------------------------------------------------------- /test/typexp/test_char.bri: -------------------------------------------------------------------------------- 1 | var dummy : char 2 | -------------------------------------------------------------------------------- /test/typexp/test_float.bri: -------------------------------------------------------------------------------- 1 | var dummy : float 2 | -------------------------------------------------------------------------------- /test/typexp/test_int.bri: -------------------------------------------------------------------------------- 1 | var dummy : int 2 | -------------------------------------------------------------------------------- /test/typexp/test_unit.bri: -------------------------------------------------------------------------------- 1 | var dummy : unit 2 | -------------------------------------------------------------------------------- /test/test_literals.mli: -------------------------------------------------------------------------------- 1 | val suite : OUnit2.test 2 | -------------------------------------------------------------------------------- /test/test_parsing.mli: -------------------------------------------------------------------------------- 1 | val suite : OUnit2.test 2 | -------------------------------------------------------------------------------- /test/typdef/test_binary.br: -------------------------------------------------------------------------------- 1 | type t = binary 2 | 3 | -------------------------------------------------------------------------------- /test/typdef/test_float.br: -------------------------------------------------------------------------------- 1 | type t = float 2 | 3 | -------------------------------------------------------------------------------- /test/typdef/test_int_list.br: -------------------------------------------------------------------------------- 1 | type t = int list 2 | -------------------------------------------------------------------------------- /test/typdef/test_poly_list.br: -------------------------------------------------------------------------------- 1 | type t = 'a list 2 | -------------------------------------------------------------------------------- /test/typdef/test_string.br: -------------------------------------------------------------------------------- 1 | type t = string 2 | 3 | -------------------------------------------------------------------------------- /test/typdef/test_tuple.br: -------------------------------------------------------------------------------- 1 | type t = int * float 2 | -------------------------------------------------------------------------------- /test/typexp/test_atom.bri: -------------------------------------------------------------------------------- 1 | var dummy : atom 2 | 3 | -------------------------------------------------------------------------------- /test/typexp/test_binary.bri: -------------------------------------------------------------------------------- 1 | var dummy : binary 2 | -------------------------------------------------------------------------------- /test/typexp/test_tuple.bri: -------------------------------------------------------------------------------- 1 | var dummy : int * int 2 | -------------------------------------------------------------------------------- /src/console.mli: -------------------------------------------------------------------------------- 1 | val print_exc : string -> exn -> unit 2 | -------------------------------------------------------------------------------- /test/typdef/test_bitstring.br: -------------------------------------------------------------------------------- 1 | type t = bitstring 2 | 3 | -------------------------------------------------------------------------------- /test/typdef/test_poly_tycon.br: -------------------------------------------------------------------------------- 1 | type 'a t = A of 'a 2 | -------------------------------------------------------------------------------- /test/typdef/test_simple_tycon.br: -------------------------------------------------------------------------------- 1 | type t = A | B | C 2 | -------------------------------------------------------------------------------- /test/typexp/test_list.bri: -------------------------------------------------------------------------------- 1 | var dummy : string list 2 | 3 | -------------------------------------------------------------------------------- /test/typexp/test_string.bri: -------------------------------------------------------------------------------- 1 | var dummy : string 2 | 3 | -------------------------------------------------------------------------------- /bran.install: -------------------------------------------------------------------------------- 1 | bin: [ 2 | "?src/bran.opt" {"bran"} 3 | ] 4 | -------------------------------------------------------------------------------- /test/typdef/test_record.br: -------------------------------------------------------------------------------- 1 | type t = { a : string, b : int } 2 | -------------------------------------------------------------------------------- /test/typexp/test_bitstring.bri: -------------------------------------------------------------------------------- 1 | var dummy : bitstring 2 | 3 | -------------------------------------------------------------------------------- /test/typexp/test_poly_list.bri: -------------------------------------------------------------------------------- 1 | var dummy : 'a list 2 | 3 | -------------------------------------------------------------------------------- /src/emit.mli: -------------------------------------------------------------------------------- 1 | val f : string -> Buffer.t -> Erlang_t.prog -> unit 2 | -------------------------------------------------------------------------------- /test/parsing/bool.br: -------------------------------------------------------------------------------- 1 | def btrue _ = true 2 | def bfalse _ = false 3 | -------------------------------------------------------------------------------- /test/parsing/topvar.br: -------------------------------------------------------------------------------- 1 | var x = 1 2 | var y = 2 3 | var z = 3 4 | -------------------------------------------------------------------------------- /test/typexp/test_constr_params.bri: -------------------------------------------------------------------------------- 1 | var dummy : (int, float) t 2 | -------------------------------------------------------------------------------- /examples/erleval.br: -------------------------------------------------------------------------------- 1 | def main () = print_string (Erlang.eval "1 + 1.") 2 | -------------------------------------------------------------------------------- /liberl/rebar: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/szktty/bran/HEAD/liberl/rebar -------------------------------------------------------------------------------- /src/beta.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/szktty/bran/HEAD/src/beta.ml -------------------------------------------------------------------------------- /test/parsing/def.br: -------------------------------------------------------------------------------- 1 | def f1 x = 0 2 | def f2 x = 0 3 | def f3 x = 0 4 | -------------------------------------------------------------------------------- /test/typdef/test_poly_record.br: -------------------------------------------------------------------------------- 1 | type ('a, 'b) t = { a : 'a, b : 'b } 2 | -------------------------------------------------------------------------------- /test/typexp/test_fun_of_unit_unit.bri: -------------------------------------------------------------------------------- 1 | var dummy : unit -> unit 2 | 3 | -------------------------------------------------------------------------------- /examples/id.br: -------------------------------------------------------------------------------- 1 | def rec id x = x 2 | 3 | def main () = print_int (id 0) 4 | -------------------------------------------------------------------------------- /lib/erlang.bri: -------------------------------------------------------------------------------- 1 | external eval : string -> string = "bran_lib_erlang:eval" 2 | -------------------------------------------------------------------------------- /test/parsing/dollar.br: -------------------------------------------------------------------------------- 1 | def main _ = print_string $ "hello, " ^ "world!" 2 | -------------------------------------------------------------------------------- /test/parsing/sig_var.bri: -------------------------------------------------------------------------------- 1 | var debug : bool ref 2 | 3 | var f : ('a -> 'b) 4 | -------------------------------------------------------------------------------- /test/typexp/test_poly_fun.bri: -------------------------------------------------------------------------------- 1 | var dummy : ('a -> 'b) -> 'b list -> 'b 2 | 3 | -------------------------------------------------------------------------------- /src/xstring.mli: -------------------------------------------------------------------------------- 1 | val concat_map : string -> ('a -> string) -> 'a list -> string 2 | -------------------------------------------------------------------------------- /test/typexp/test_fun_of_int_float_string.bri: -------------------------------------------------------------------------------- 1 | var dummy : int -> float -> string 2 | 3 | -------------------------------------------------------------------------------- /test/typdef/test_tycon_args.br: -------------------------------------------------------------------------------- 1 | type t = A of int | B of bool * unit | C of string list 2 | -------------------------------------------------------------------------------- /test/typexp/test_fun_of_fun.bri: -------------------------------------------------------------------------------- 1 | var dummy : (char -> bool) -> string -> string list 2 | 3 | -------------------------------------------------------------------------------- /lib/bitstring.bri: -------------------------------------------------------------------------------- 1 | external to_binary : bitstring -> binary = "bran_lib_bitstring:to_binary" 2 | -------------------------------------------------------------------------------- /liberl/src/bran.erl: -------------------------------------------------------------------------------- 1 | -module(bran). 2 | 3 | -export([my_func/0]). 4 | 5 | my_func() -> 6 | ok. 7 | -------------------------------------------------------------------------------- /liberl/test/bran_tests.erl: -------------------------------------------------------------------------------- 1 | -module(bran_tests). 2 | -include_lib("eunit/include/eunit.hrl"). 3 | 4 | -------------------------------------------------------------------------------- /test/parsing/sig_def.bri: -------------------------------------------------------------------------------- 1 | def map : ('a -> 'b) -> 'a list -> 'b 2 | def send : pid -> 'a -> unit 3 | -------------------------------------------------------------------------------- /OMakefile: -------------------------------------------------------------------------------- 1 | .PHONY: all install clean test 2 | 3 | .SUBDIRS: src test lib liberl 4 | 5 | .DEFAULT: all 6 | -------------------------------------------------------------------------------- /test/parsing/float.br: -------------------------------------------------------------------------------- 1 | def f1 _ = 2.3 2 | def f2 _ = 2.3e3 3 | def f3 _ = 2.3e-3 4 | def f4 _ = 7.000e+00 5 | -------------------------------------------------------------------------------- /test/parsing/ref.br: -------------------------------------------------------------------------------- 1 | var xref = ref 0 2 | 3 | def f x = 4 | xref := x + !xref 5 | Modname.xref := 0 6 | -------------------------------------------------------------------------------- /src/xstring.ml: -------------------------------------------------------------------------------- 1 | open Spotlib.Base 2 | 3 | let concat_map sep f es = 4 | String.concat sep & List.map f es 5 | -------------------------------------------------------------------------------- /test/literals/test_char.br: -------------------------------------------------------------------------------- 1 | def test _ = 'a' 2 | def expected_type _ = @char 3 | def expected_value _ = "$a." 4 | -------------------------------------------------------------------------------- /test/literals/test_unit.br: -------------------------------------------------------------------------------- 1 | def test _ = () 2 | def expected_type _ = @tuple 3 | def expected_value _ = "{}." 4 | -------------------------------------------------------------------------------- /test/literals/test_atom.br: -------------------------------------------------------------------------------- 1 | def test _ = @test 2 | def expected_type _ = @atom 3 | def expected_value _ = "test." 4 | -------------------------------------------------------------------------------- /test/literals/test_true.br: -------------------------------------------------------------------------------- 1 | def test _ = true 2 | def expected_type _ = @boolean 3 | def expected_value _ = "true." 4 | -------------------------------------------------------------------------------- /test/parsing/list.br: -------------------------------------------------------------------------------- 1 | var l1 = [] 2 | var l2 = [1] 3 | var l3 = [1,] 4 | var l4 = [1, 2, 3] 5 | var l5 = [1, 2, 3,] 6 | -------------------------------------------------------------------------------- /test/variant/test_args.br: -------------------------------------------------------------------------------- 1 | type t = T of int 2 | def test _ = T 0 3 | def expected_value _ = "{'Test_args.T', 0}." 4 | -------------------------------------------------------------------------------- /examples/fib.br: -------------------------------------------------------------------------------- 1 | def rec fib x = 2 | if x <= 1 then 3 | 1 4 | else 5 | fib (x - 1) + fib (x - 2) 6 | end 7 | -------------------------------------------------------------------------------- /test/literals/test_false.br: -------------------------------------------------------------------------------- 1 | def test _ = false 2 | def expected_type _ = @boolean 3 | def expected_value _ = "false." 4 | -------------------------------------------------------------------------------- /test/literals/test_float.br: -------------------------------------------------------------------------------- 1 | def test _ = 123.45 2 | def expected_type _ = @float 3 | def expected_value _ = "123.45." 4 | -------------------------------------------------------------------------------- /test/literals/test_int.br: -------------------------------------------------------------------------------- 1 | def test _ = 12345 2 | def expected_type _ = @integer 3 | def expected_value _ = "12345." 4 | -------------------------------------------------------------------------------- /test/literals/test_string.br: -------------------------------------------------------------------------------- 1 | def test _ = "test" 2 | def expected_type _ = @list 3 | def expected_value _ = "\"test\"." 4 | -------------------------------------------------------------------------------- /test/xounit.mli: -------------------------------------------------------------------------------- 1 | val assert_success : Sealing.Result.t -> unit 2 | val assert_no_file_changes : Sealing.Result.t -> unit 3 | -------------------------------------------------------------------------------- /src/intRepr.mli: -------------------------------------------------------------------------------- 1 | type t = int * string (* base and value *) 2 | 3 | val to_int : t -> int 4 | val to_string : t -> string 5 | -------------------------------------------------------------------------------- /test/literals/test_list.br: -------------------------------------------------------------------------------- 1 | def test _ = [1, 2, 3] 2 | def expected_type _ = @list 3 | def expected_value _ = "[1, 2, 3]." 4 | -------------------------------------------------------------------------------- /test/literals/test_tuple.br: -------------------------------------------------------------------------------- 1 | def test _ = (1, 2, 3) 2 | def expected_type _ = @tuple 3 | def expected_value _ = "{1, 2, 3}." 4 | -------------------------------------------------------------------------------- /liberl/src/bran_lib_bitstring.erl: -------------------------------------------------------------------------------- 1 | -module(bran_lib_bitstring). 2 | 3 | -export([to_binary/1]). 4 | 5 | to_binary(_Bits) -> nyi. 6 | -------------------------------------------------------------------------------- /test/literals/test_atom_quote.br: -------------------------------------------------------------------------------- 1 | def test _ = @"123abc" 2 | def expected_type _ = @atom 3 | def expected_value _ = "'123abc'." 4 | -------------------------------------------------------------------------------- /test/literals/test_binary.br: -------------------------------------------------------------------------------- 1 | def test _ = <<0:3, 1:3, 2:2>> 2 | def expected_type _ = @binary 3 | def expected_value _ = "<<6>>." 4 | -------------------------------------------------------------------------------- /test/parsing/exception.br: -------------------------------------------------------------------------------- 1 | exception My_error 2 | exception My_error of string 3 | exception My_error of string * int * string 4 | -------------------------------------------------------------------------------- /liberl/OMakefile: -------------------------------------------------------------------------------- 1 | .PHONY: all clean test 2 | 3 | all: 4 | make 5 | 6 | clean: 7 | make clean 8 | 9 | test: 10 | make test 11 | -------------------------------------------------------------------------------- /src/alpha.mli: -------------------------------------------------------------------------------- 1 | val f : KNormal_t.def list -> KNormal_t.def list 2 | val g : Id.t Id.Map.t -> KNormal_t.t -> KNormal_t.t (* for Inline.g *) 3 | -------------------------------------------------------------------------------- /test/parsing/array.br: -------------------------------------------------------------------------------- 1 | var a1 = [||] 2 | var a2 = [|1, 2, 3|] 3 | var a3 = [|1, 2, 3,|] 4 | def get _ = a2.(1) 5 | def set v = a2.(0) <- v 6 | -------------------------------------------------------------------------------- /test/parsing/monad.br: -------------------------------------------------------------------------------- 1 | def m _ = 2 | perform 3 | x1 <- action1 4 | x2 <- action2 5 | action3 x1 x2 6 | return x1 7 | end 8 | -------------------------------------------------------------------------------- /test/pattern/test_var.br: -------------------------------------------------------------------------------- 1 | def test _ = 2 | match 0 with 3 | | 1 -> false 4 | | _ -> true 5 | end 6 | def expected_value _ = "true." 7 | -------------------------------------------------------------------------------- /test/variant/test_noargs.br: -------------------------------------------------------------------------------- 1 | type t = T 2 | def test _ = T 3 | def expected_type _ = @atom 4 | def expected_value _ = "'Test_noargs.T'." 5 | -------------------------------------------------------------------------------- /liberl/src/bran_lib_pervasives.erl: -------------------------------------------------------------------------------- 1 | -module(bran_lib_pervasives). 2 | 3 | -export([print_string/1]). 4 | 5 | print_string(S) -> io:fwrite(S). 6 | -------------------------------------------------------------------------------- /test/parsing/int.br: -------------------------------------------------------------------------------- 1 | def int1 _ = 42 2 | def int2 _ = 042 3 | def int3 _ = 12345678901234567890 4 | def int4 _ = 2r101 5 | def int5 _ = 16r1f 6 | -------------------------------------------------------------------------------- /test/pattern/test_unit.br: -------------------------------------------------------------------------------- 1 | def test _ = 2 | match () with 3 | | () -> true 4 | | _ -> false 5 | end 6 | def expected_value _ = "true." 7 | -------------------------------------------------------------------------------- /test/literals/test_bitstring.br: -------------------------------------------------------------------------------- 1 | def test _ = <<0:1, 1:2, 2:3>> 2 | def expected_type _ = @bitstring 3 | def expected_value _ = "<<0:1, 1:2, 2:3>>." 4 | -------------------------------------------------------------------------------- /test/pattern/test_as.br: -------------------------------------------------------------------------------- 1 | def test _ = 2 | match true with 3 | | false -> false 4 | | true as v -> v 5 | end 6 | def expected_value _ = "true." 7 | -------------------------------------------------------------------------------- /src/compiler.mli: -------------------------------------------------------------------------------- 1 | (* frontend *) 2 | 3 | exception Error of string 4 | 5 | val compile_file : string -> unit 6 | val create_exec_file : string -> unit 7 | -------------------------------------------------------------------------------- /test/pattern/test_bool.br: -------------------------------------------------------------------------------- 1 | def test _ = 2 | match false with 3 | | true -> false 4 | | false -> true 5 | end 6 | def expected_value _ = "true." 7 | -------------------------------------------------------------------------------- /src/erlang.mli: -------------------------------------------------------------------------------- 1 | open Erlang_t 2 | 3 | val literal_of_string : string -> string 4 | val literal_of_float : float -> string 5 | 6 | val f : Closure_t.prog -> prog 7 | -------------------------------------------------------------------------------- /test/parsing/external.bri: -------------------------------------------------------------------------------- 1 | external print_string : string -> unit = "bran_lib_pervasives:print_string" 2 | external foobar : int -> int -> unit = "foobar:foobar" 3 | -------------------------------------------------------------------------------- /src/log.mli: -------------------------------------------------------------------------------- 1 | val debug : ('a, out_channel, unit) format -> 'a 2 | val verbose : ('a, out_channel, unit) format -> 'a 3 | val error : ('a, out_channel, unit) format -> 'a 4 | -------------------------------------------------------------------------------- /src/xset.mli: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | include Spotlib.Xset.S 3 | val of_list : elt list -> t 4 | end 5 | 6 | module Make(O : Set.OrderedType) : S with type elt = O.t 7 | -------------------------------------------------------------------------------- /test/parsing/simple_typdef.br: -------------------------------------------------------------------------------- 1 | type a = int 2 | type b = string 3 | type 'a c = 'a 4 | type d = int * string * 'a 5 | type 'a e = 'a -> unit 6 | type 'a e = ('a -> unit) 7 | -------------------------------------------------------------------------------- /src/position.mli: -------------------------------------------------------------------------------- 1 | type t = { 2 | line : int; 3 | col : int; 4 | offset : int; 5 | } 6 | 7 | val zero : t 8 | 9 | val of_lexing_pos : Lexing.position -> t 10 | -------------------------------------------------------------------------------- /test/parsing/field.br: -------------------------------------------------------------------------------- 1 | def f x = 2 | f x.field 3 | x.f () 4 | x.Modname.field 5 | Modname.field 6 | Modname.(x.field) 7 | x.field <- 0 8 | x.Modname.field <- 0 9 | -------------------------------------------------------------------------------- /test/pattern/test_empty_list.br: -------------------------------------------------------------------------------- 1 | def test _ = 2 | match [] with 3 | | [1, 2] -> false 4 | | [] -> true 5 | | _ -> false 6 | end 7 | def expected_value _ = "true." 8 | -------------------------------------------------------------------------------- /test/pattern/test_one_list.br: -------------------------------------------------------------------------------- 1 | def test _ = 2 | match [true] with 3 | | [] -> false 4 | | [true] -> true 5 | | _ -> false 6 | end 7 | def expected_value _ = "true." 8 | -------------------------------------------------------------------------------- /test/pattern/test_cons.br: -------------------------------------------------------------------------------- 1 | def test _ = 2 | match [true, false] with 3 | | [true] -> false 4 | | x :: _ -> x 5 | | _ -> false 6 | end 7 | def expected_value _ = "true." 8 | -------------------------------------------------------------------------------- /test/pattern/test_int.br: -------------------------------------------------------------------------------- 1 | def test _ = 2 | match 3 with 3 | | 1 -> false 4 | | 2 -> false 5 | | 3 -> true 6 | | _ -> false 7 | end 8 | def expected_value _ = "true." 9 | -------------------------------------------------------------------------------- /test/parsing/assert.br: -------------------------------------------------------------------------------- 1 | def f1 x = 2 | assert x > 0 3 | 4 | def f2 x = 5 | assert true 6 | 7 | def f3 x = 8 | assert false 9 | 10 | def f4 x y = 11 | assert f x y 12 | -------------------------------------------------------------------------------- /test/parsing/comment.br: -------------------------------------------------------------------------------- 1 | # line comment 2 | # 3 | # 4 | 5 | # 6 | 7 | # 8 | 9 | def f x = x # inline comment 10 | # comment 11 | f x 12 | 13 | # comment 14 | f x 15 | -------------------------------------------------------------------------------- /test/parsing/local_var.br: -------------------------------------------------------------------------------- 1 | var x = 1 2 | 3 | def f x = 4 | var y = x + 1 5 | y 6 | 7 | def g x = 8 | def h y = 9 | var z = x + y 10 | z 11 | in 12 | h x 13 | -------------------------------------------------------------------------------- /test/pattern/test_constr.br: -------------------------------------------------------------------------------- 1 | type t = A | B | C 2 | def test _ = 3 | match C with 4 | | A -> false 5 | | B -> false 6 | | C -> true 7 | end 8 | def expected_value _ = "true." 9 | -------------------------------------------------------------------------------- /test/pattern/test_list.br: -------------------------------------------------------------------------------- 1 | def test _ = 2 | match [1, 2, 3] with 3 | | [0, 1, 2] -> false 4 | | [1, 2, 3] -> true 5 | | _ -> false 6 | end 7 | def expected_value _ = "true." 8 | -------------------------------------------------------------------------------- /test/pattern/test_tuple.br: -------------------------------------------------------------------------------- 1 | def test _ = 2 | match (1, 2, 3) with 3 | | (0, 1, 2) -> false 4 | | (1, 2, 3) -> true 5 | | _ -> false 6 | end 7 | def expected_value _ = "true." 8 | -------------------------------------------------------------------------------- /test/pattern/test_tuple_var.br: -------------------------------------------------------------------------------- 1 | def test _ = 2 | match (1, true) with 3 | | (0, true) -> false 4 | | (1, x) -> x 5 | | _ -> false 6 | end 7 | def expected_value _ = "true." 8 | -------------------------------------------------------------------------------- /test/parsing/circular_ref.br: -------------------------------------------------------------------------------- 1 | def f x = g x 2 | and g x = f x 3 | 4 | type t1 = t2 5 | and t2 = t1 6 | 7 | def f x = g x 8 | and g x = f x 9 | 10 | type t1 = t2 11 | and t2 = t1 12 | -------------------------------------------------------------------------------- /test/pattern/test_float.br: -------------------------------------------------------------------------------- 1 | def test _ = 2 | match 3.0 with 3 | | 1.0 -> false 4 | | 2.0 -> false 5 | | 3.0 -> true 6 | | _ -> false 7 | end 8 | def expected_value _ = "true." 9 | -------------------------------------------------------------------------------- /src/source.mli: -------------------------------------------------------------------------------- 1 | type t = { 2 | path : string; 3 | mod_name : string; 4 | erl_name : string; 5 | erl_path : string; 6 | defs : Ast_t.def list; 7 | } 8 | 9 | val parse : string -> t 10 | -------------------------------------------------------------------------------- /test/pattern/test_atom.br: -------------------------------------------------------------------------------- 1 | def test _ = 2 | match @hello with 3 | | @hell -> false 4 | | @Hello -> false 5 | | @hello -> true 6 | | _ -> false 7 | end 8 | def expected_value _ = "true." 9 | -------------------------------------------------------------------------------- /test/parsing/message.br: -------------------------------------------------------------------------------- 1 | def store pid food = 2 | receive n -> n end 3 | 4 | receive 5 | 0 -> 0 6 | | _ -> 1 7 | end 8 | 9 | receive 10 | | 0 -> 0 11 | | _ -> 1 12 | end 13 | -------------------------------------------------------------------------------- /test/pattern/test_string.br: -------------------------------------------------------------------------------- 1 | def test _ = 2 | match "hello" with 3 | | "hell" -> false 4 | | "Hello" -> false 5 | | "hello" -> true 6 | | _ -> false 7 | end 8 | def expected_value _ = "true." 9 | -------------------------------------------------------------------------------- /examples/helloworld.br: -------------------------------------------------------------------------------- 1 | # To create an executable file, use -escript option: 2 | # 3 | # $ bran -escript helloworld.br 4 | # $ ./helloworld 5 | # "Hello, world!" 6 | 7 | def main () = print_string "Hello, world!" 8 | -------------------------------------------------------------------------------- /test/parsing/atom.br: -------------------------------------------------------------------------------- 1 | def lower _ = @atom 2 | def upper _ = @Atom 3 | def lunder _ = @atom_ok 4 | def uunder _ = @Atom_ok 5 | def quotes _ = @"atom" 6 | def space _ = @"a t o m" 7 | def op _ = @"*a+t-o/m!?* :-@" 8 | -------------------------------------------------------------------------------- /liberl/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: compile doc clean test 2 | 3 | all: compile 4 | 5 | compile: 6 | ./rebar compile 7 | 8 | doc: 9 | ./rebar doc 10 | 11 | clean: 12 | ./rebar clean 13 | 14 | test: 15 | ./rebar eunit 16 | 17 | -------------------------------------------------------------------------------- /src/intRepr.ml: -------------------------------------------------------------------------------- 1 | type t = int * string (* base and value *) 2 | 3 | let to_int = function 4 | | 10, s -> int_of_string s 5 | | _ -> failwith "not implemented" 6 | 7 | let to_string (b, v) = 8 | Printf.sprintf "%dr%s" b v 9 | -------------------------------------------------------------------------------- /test/parsing/for.br: -------------------------------------------------------------------------------- 1 | def f x = 2 | for i = 1 to max do 3 | print_int i 4 | print_int i 5 | end 6 | 7 | for i = 1 to 8 | max 9 | do 10 | print_int i 11 | print_int i 12 | end 13 | -------------------------------------------------------------------------------- /test/parsing/floatop.br: -------------------------------------------------------------------------------- 1 | def add x y = x +. y 2 | def sub x y = x -. y 3 | def mul x y = x *. y 4 | def div x y = x /. y 5 | 6 | def add x y = 1 +. 1 7 | def sub x y = 1 -. 1 8 | def mul x y = 1 *. 1 9 | def div x y = 1 /. 1 10 | -------------------------------------------------------------------------------- /src/xbase.mli: -------------------------------------------------------------------------------- 1 | val phys_equal : 'a -> 'a -> bool 2 | val (==) : 'a -> 'a -> [`Consider_using_phys_equal] 3 | val (!=) : 'a -> 'a -> [`Consider_using_phys_equal] 4 | 5 | val opt_of_find : ('a -> 'b) -> 'a -> 'b option 6 | val find_of_opt : 'a option -> 'a 7 | -------------------------------------------------------------------------------- /src/xlist.mli: -------------------------------------------------------------------------------- 1 | val init : 'a list -> 'a list 2 | val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool 3 | val inject : (unit -> unit) -> ('a -> unit) -> 'a list -> unit 4 | val inject2 : (unit -> unit) -> ('a -> 'b -> unit) -> 'a list -> 'b list -> unit 5 | -------------------------------------------------------------------------------- /test/parsing/variant_typdef.br: -------------------------------------------------------------------------------- 1 | type a = A of int 2 | 3 | type b = A of int | B of float | C 4 | 5 | type c = 6 | A of int 7 | | B of float 8 | | C 9 | 10 | type d = 11 | | A of int 12 | | B of float 13 | | C 14 | 15 | type 'a e = A of 'a | B | C 16 | -------------------------------------------------------------------------------- /src/naming.mli: -------------------------------------------------------------------------------- 1 | exception Unbound_value_error of Location.t * Id.t * Id.t list 2 | exception Unbound_constr_error of Location.t * Id.t * Id.t list 3 | exception Unbound_module_error of Location.t * Id.t * Id.t list 4 | 5 | val f : Binding.t -> Ast_t.def list -> Ast_t.def list 6 | -------------------------------------------------------------------------------- /test/parsing/local_def.br: -------------------------------------------------------------------------------- 1 | def f1 x = 2 | def g y = 3 | x + y 4 | in 5 | g x 6 | 7 | def f2 x = 8 | def g y = x + y in 9 | g x 10 | 11 | def f3 x = 12 | def g y = 13 | def h z = 14 | x + y + z 15 | in 16 | h x 17 | in 18 | g x 19 | -------------------------------------------------------------------------------- /test/pattern/test_constr_args.br: -------------------------------------------------------------------------------- 1 | type t = A | B | C of int 2 | def test _ = 3 | match (C 2) with 4 | | A -> false 5 | | B -> false 6 | | C 0 -> false 7 | | C 1 -> false 8 | | C 2 -> true 9 | | C _ -> false 10 | end 11 | def expected_value _ = "true." 12 | -------------------------------------------------------------------------------- /test/parsing/intop.br: -------------------------------------------------------------------------------- 1 | def add x y = x + y 2 | def sub x y = x - y 3 | def mul x y = x * y 4 | def div x y = x / y 5 | def mod_ x y = x mod y 6 | 7 | def add x y = 1 + 1 8 | def sub x y = 1 - 1 9 | def mul x y = 1 * 1 10 | def div x y = 1 / 1 11 | def mod_ x y = 1 mod 1 12 | -------------------------------------------------------------------------------- /test/parsing/try.br: -------------------------------------------------------------------------------- 1 | def f x = 2 | raise g x 3 | 4 | def g x = 5 | try x with e -> e end 6 | 7 | try 8 | x 9 | with 10 | e -> e 11 | end 12 | 13 | try 14 | x 15 | with 16 | | Not_found -> 17 | e 18 | | e -> 19 | e 20 | end 21 | -------------------------------------------------------------------------------- /src/xset.ml: -------------------------------------------------------------------------------- 1 | open Spotlib.Xset 2 | 3 | module type S = sig 4 | include S 5 | val of_list : elt list -> t 6 | end 7 | 8 | module Make(O : Map.OrderedType) = struct 9 | include Make(O) 10 | 11 | let of_list l = List.fold_left (fun s e -> add e s) empty l 12 | 13 | end 14 | -------------------------------------------------------------------------------- /src/xbase.ml: -------------------------------------------------------------------------------- 1 | let phys_equal = (==) 2 | let (==) _ _ = `Consider_using_phys_equal 3 | let (!=) _ _ = `Consider_using_phys_equal 4 | 5 | let opt_of_find f x = try Some (f x) with Not_found -> None 6 | 7 | let find_of_opt = function 8 | | None -> raise Not_found 9 | | Some v -> v 10 | -------------------------------------------------------------------------------- /src/position.ml: -------------------------------------------------------------------------------- 1 | type t = { 2 | line : int; 3 | col : int; 4 | offset : int; 5 | } 6 | 7 | let zero = { line = 0; col = 0; offset = 0 } 8 | 9 | let of_lexing_pos (pos : Lexing.position) = 10 | { line = pos.pos_lnum; 11 | col = pos.pos_bol; 12 | offset = pos.pos_cnum; 13 | } 14 | -------------------------------------------------------------------------------- /test/parsing/record_typdef.br: -------------------------------------------------------------------------------- 1 | type r = { a : int } 2 | type r = { a : int, } 3 | 4 | type r = { a : int, b : float, c : string } 5 | type r = { a : int, b : float, c : string, } 6 | 7 | type r = 8 | { a : int } 9 | 10 | type r = { 11 | a : int, 12 | b : float, 13 | c : string 14 | } 15 | -------------------------------------------------------------------------------- /src/log.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | let printf = function 4 | | true -> flush_all (); Printf.printf 5 | | false -> Printf.zprintf 6 | 7 | let debug f = printf !Config.debug f 8 | let verbose f = printf !Config.verbose f 9 | 10 | let error f = 11 | Printf.printf "Error: "; 12 | Printf.printf f 13 | -------------------------------------------------------------------------------- /test/parsing/string.br: -------------------------------------------------------------------------------- 1 | def s1 _ = "string" 2 | def s2 _ = "42" 3 | def s3 _ = "string 42" 4 | def espace1 _ = "'\'\"\\" 5 | def espace2 _ = "\b\d\e\f\n\r\s\t\v" 6 | def oct _ = "\0 \01 \012" 7 | def hex1 _ = "\x00\xff" 8 | def hex2 _ = "\x{00}\x{ff}\x{0000}\x{fffd}\x{FFFD}" 9 | def ctrl _ = "\^a\^z\^A\^Z" 10 | -------------------------------------------------------------------------------- /liberl/src/bran.app.src: -------------------------------------------------------------------------------- 1 | {application, bran, 2 | [ 3 | {description, ""}, 4 | {vsn, "0.1.0"}, 5 | {registered, []}, 6 | {applications, [ 7 | kernel, 8 | stdlib 9 | ]}, 10 | {modules, [bran, bran_lib_pervasives, bran_lib_erlang]}, 11 | {env, []} 12 | ]}. 13 | -------------------------------------------------------------------------------- /src/utils.mli: -------------------------------------------------------------------------------- 1 | val filepath_of_string : string -> Spotlib.Filepath.t 2 | val dirbase : string -> Spotlib.Filepath.t * string option 3 | val replace_ext : string -> string -> string 4 | val base : string -> string 5 | val module_name : string -> string 6 | val erl_path : string -> string 7 | val escript_path : string -> string 8 | -------------------------------------------------------------------------------- /test/parsing/fun.br: -------------------------------------------------------------------------------- 1 | def f1 x = 2 | fun y -> x + y end 3 | 4 | def f2 x = 5 | fun y z -> x + y + z end 6 | 7 | def f3 x = 8 | fun (y, z) -> x + y + z end 9 | 10 | def f4 x = 11 | fun 12 | y z -> 13 | x + y + z 14 | end 15 | 16 | def f5 x = 17 | fun 18 | | 0 -> 0 19 | | y -> x + y 20 | end 21 | -------------------------------------------------------------------------------- /liberl/src/bran_lib_erlang.erl: -------------------------------------------------------------------------------- 1 | -module(bran_lib_erlang). 2 | 3 | -export([eval/1]). 4 | 5 | eval(S)-> 6 | {ok, Toks, _} = erl_scan:string(S), 7 | {ok, [Exp]} = erl_parse:parse_exprs(Toks), 8 | {value, Ret, _} = erl_eval:expr(Exp, erl_eval:bindings(erl_eval:new_bindings())), 9 | hd(io_lib:fwrite("~p", [Ret])). 10 | -------------------------------------------------------------------------------- /src/sig.mli: -------------------------------------------------------------------------------- 1 | (* signature file *) 2 | 3 | exception Error of Location.t * string 4 | exception Pervasives_not_found 5 | 6 | val find_lib_file : string -> string 7 | 8 | val load : Source.t -> unit 9 | val load_module : Binding.t -> [`Ok | `Error] 10 | val load_file : string -> [`Ok | `Error] 11 | 12 | val create_env : unit -> Env.t 13 | -------------------------------------------------------------------------------- /test/run.ml: -------------------------------------------------------------------------------- 1 | open Spotlib.Base 2 | open OUnit2 3 | 4 | let suites = [ 5 | (* parsing *) 6 | Test_parsing.suite; 7 | Test_typexp.suite; 8 | 9 | (* compiling *) 10 | Test_literals.suite; 11 | Test_typdef.suite; 12 | Test_variant.suite; 13 | Test_pattern.suite; 14 | ] 15 | 16 | let _ = 17 | run_test_tt_main & test_list suites 18 | -------------------------------------------------------------------------------- /src/closure.mli: -------------------------------------------------------------------------------- 1 | open Closure_t 2 | 3 | val string_of_pattern : pattern -> string 4 | val string_of_typed_expr : et -> string 5 | val string_of_expr : expr -> string 6 | val string_of_typed_term : t -> string 7 | val string_of_term : term -> string 8 | val string_of_def : def -> string 9 | val fv : t -> Id.Set.t 10 | val f : KNormal_t.def list -> prog 11 | -------------------------------------------------------------------------------- /src/id.mli: -------------------------------------------------------------------------------- 1 | type t = string (* 変数の名前 (caml2html: id_t) *) 2 | 3 | type l = L of string (* top level functions *) 4 | 5 | val pp_list : string list -> string 6 | 7 | val counter : int ref 8 | val genid : string -> string 9 | 10 | val gentmp : string -> string 11 | 12 | module Map : Xmap.S with type key = t 13 | module Set : Xset.S with type elt = t 14 | -------------------------------------------------------------------------------- /liberl/rebar.config: -------------------------------------------------------------------------------- 1 | {erl_opts, [{i, "include"}, 2 | warnings_as_errors, 3 | {w, all}, 4 | warn_export_all]}. 5 | 6 | {clean_files, [".eunit", 7 | "ebin/*.beam"]}. 8 | 9 | {eunit_opts, [{report,{eunit_surefire,[{dir,"."}]}}]}. 10 | 11 | {xref_checks, [fail_on_warning, undefined_function_calls]}. 12 | 13 | -------------------------------------------------------------------------------- /src/kNormal.mli: -------------------------------------------------------------------------------- 1 | open KNormal_t 2 | 3 | val f : Ast_t.def list -> def list 4 | val string_of_typed_expr : et -> Id.t 5 | val string_of_expr : expr -> Id.t 6 | val string_of_typed_term : t -> Id.t 7 | val string_of_term : term -> Id.t 8 | val fold : ('a * 'b list -> 'c -> 'a * 'b list) -> 'a -> 'c list -> 'b list 9 | val map : (Env.t -> def -> 'a) -> def list -> 'a list 10 | -------------------------------------------------------------------------------- /test/parsing/if.br: -------------------------------------------------------------------------------- 1 | def f x = 2 | if x then 3 | print_string "true" 4 | true 5 | end 6 | 7 | if x then 8 | print_string "true" 9 | true 10 | else 11 | print_string "false" 12 | false 13 | end 14 | 15 | if x then true else false 16 | 17 | if x then true 18 | else false 19 | 20 | if x then 21 | true 22 | else 23 | false 24 | -------------------------------------------------------------------------------- /test/program.mli: -------------------------------------------------------------------------------- 1 | type beam = string 2 | 3 | val prog : string 4 | val flags : string list 5 | val command : string list 6 | 7 | val beam_path : string -> beam 8 | val exec_path : string -> string 9 | 10 | val compile : Sealing.Env.t -> string -> beam 11 | val eval : Sealing.Env.t -> beam -> string -> Sealing.Result.t 12 | val simple_test : Sealing.Env.t -> beam -> unit 13 | -------------------------------------------------------------------------------- /test/parsing/do.br: -------------------------------------------------------------------------------- 1 | def f1 x = List.map x do x -> x end 2 | 3 | def f2 x = 4 | List.map x do x -> 5 | print_int x 6 | x 7 | end 8 | 9 | def f3 x = 10 | List.fold_left 0 x do init x -> 11 | print_int x 12 | x 13 | end 14 | 15 | def f4 x = 16 | List.map x do 17 | | 0 -> print_int 0 18 | | 1 -> print_int 1 19 | | n -> print_int n 20 | end 21 | -------------------------------------------------------------------------------- /examples/hanoi.br: -------------------------------------------------------------------------------- 1 | def print_hanoi (from, to_) = 2 | print_string ("from " ^ from ^ " to " ^ to_ ^ "\n") 3 | 4 | def rec hanoi (n, from, to_, via) = 5 | if n = 1 then 6 | print_hanoi (from, to_) 7 | else 8 | hanoi (n - 1, from, via, to_) 9 | print_hanoi (from, to_) 10 | hanoi (n - 1, via, to_, from) 11 | end 12 | 13 | def main _ = hanoi (3, "A", "B", "C") 14 | -------------------------------------------------------------------------------- /devbuild.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | ZIP=bran-develop-`uname -s`-`uname -m`.tar.gz 4 | 5 | #opam switch 4.02.1 6 | #eval `opam config env` 7 | rm -rf bran $ZIP 8 | git clone https://github.com/szktty/bran.git 9 | cd bran 10 | omake --project 11 | omake --project test && rm -rf .omakedb .omakedb.lock devbuild.sh circle.yml circle src test OMake* lib/OMake* liberl/OMake* && tar czf ../$ZIP . 12 | cd .. 13 | -------------------------------------------------------------------------------- /src/xmap.mli: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | include Map.S 3 | val add_alist : (key * 'a) list -> 'a t -> 'a t 4 | val add_alist2 : key list -> 'a list -> 'a t -> 'a t 5 | val to_alist : 'a t -> (key * 'a) list 6 | val union : 'a t -> 'a t -> 'a t 7 | val to_string : (key -> string) -> ('a -> string) -> 'a t -> string 8 | end 9 | 10 | module Make(O : Map.OrderedType) : S with type key = O.t 11 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | name: "bran" 3 | version: "git" 4 | author: "SUZUKI Tetsuya " 5 | homepage: "https://github.com/szktty/bran" 6 | bug-reports: "https://github.com/szktty/bran/issues" 7 | dev-repo: "git://github.com/szktty/bran.git" 8 | license: "Apache" 9 | build: [ 10 | ["sh" "-c" "cd src && omake"] 11 | ] 12 | depends: ["ocamlfind" {build} "omake" {build} "spotlib" "menhir"] 13 | -------------------------------------------------------------------------------- /test/README.md: -------------------------------------------------------------------------------- 1 | Tests 2 | ===== 3 | 4 | ## Requirements 5 | 6 | - OUnit 2.0.0 7 | 8 | 9 | ## Build 10 | 11 | ``` 12 | $ omake 13 | ``` 14 | 15 | 16 | ## Usage 17 | 18 | ``` 19 | $ ./run 20 | 21 | # Show list of suites 22 | $ ./run -list-test 23 | ... 24 | 0:parsing:0:simple_def 25 | ... 26 | 27 | # Select tests 28 | $ ./run -only-test 0:parsing:0:simple_def 29 | ``` 30 | 31 | For more detail, see `./run -help`. 32 | -------------------------------------------------------------------------------- /test/testlib.erl: -------------------------------------------------------------------------------- 1 | -module(testlib). 2 | 3 | -export([eval/1, simple_test/1]). 4 | 5 | eval(S)-> 6 | {ok, Toks, _} = erl_scan:string(S), 7 | {ok, [Exp]} = erl_parse:parse_exprs(Toks), 8 | {value, Ret, _} = erl_eval:expr(Exp, erl_eval:bindings(erl_eval:new_bindings())), 9 | Ret. 10 | 11 | simple_test(Mod) -> 12 | Res = Mod:test(ok) =:= eval(Mod:expected_value(ok)), 13 | io:format("~p", [Res]). 14 | -------------------------------------------------------------------------------- /src/binding.mli: -------------------------------------------------------------------------------- 1 | exception Invalid_path 2 | 3 | type t 4 | 5 | val pervasives : t 6 | 7 | val of_list : Id.t list -> t 8 | val of_string : Id.t -> t 9 | 10 | val path_name : t -> t option * Id.t 11 | val path : t -> t option 12 | val name : t -> Id.t 13 | 14 | val add : t -> Id.t -> t 15 | 16 | val to_string : t -> string 17 | val to_list : t -> Id.t list 18 | val to_erl_fun : t -> string 19 | val to_erl_atom : t -> string 20 | -------------------------------------------------------------------------------- /test/xounit.ml: -------------------------------------------------------------------------------- 1 | open Spotlib.Base 2 | open Sealing 3 | open OUnit2 4 | 5 | let assert_success res = 6 | assert_bool "not normally terminated" & Result.is_succeeded res 7 | 8 | let assert_no_file_changes res = 9 | assert_bool ("any file changed: " ^ 10 | (String.concat ", " (List.map FileChange.to_string 11 | (Result.changes res)))) 12 | (not & Result.has_file_changes res) 13 | -------------------------------------------------------------------------------- /circle/install-ocaml.sh: -------------------------------------------------------------------------------- 1 | VERSION=4.02.1 2 | DISTDIR=ocaml-4.02 3 | set -x 4 | set -e 5 | if [ ! -e /home/ubuntu/ocaml/$VERSION/bin/ocaml ]; then 6 | curl -O http://caml.inria.fr/pub/distrib/$DISTDIR/ocaml-$VERSION.tar.gz 7 | tar xvfz ocaml-$VERSION.tar.gz 8 | cd ocaml-$VERSION 9 | sed -i -e "s/^prefix=\/usr\/local/prefix=\/home\/ubuntu\/ocaml\/$VERSION/g" configure 10 | ./configure 11 | make world.opt 12 | make install 13 | fi 14 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.annot 2 | *.cmo 3 | *.cma 4 | *.cmi 5 | *.a 6 | *.o 7 | *.opt 8 | *.cmx 9 | *.cmxs 10 | *.cmxa 11 | *.cmt 12 | *.cmti 13 | *.cmo 14 | *.auto.mli 15 | .omakedb 16 | .omakedb.lock 17 | *.omc 18 | parser.automaton 19 | parser.conflicts 20 | 21 | .DS_Store 22 | .*.sw* 23 | 24 | lexer.ml 25 | parser.ml 26 | parser.mli 27 | *.beam 28 | bran 29 | test/*.cache 30 | test/*.log 31 | test/run 32 | test/test_output* 33 | .rebar 34 | ebin 35 | *.auto.bri 36 | -------------------------------------------------------------------------------- /test/parsing/pattern.br: -------------------------------------------------------------------------------- 1 | def f x = 2 | match x with 3 | | foobar -> 0 4 | | _ -> 0 5 | | _ as wildcard -> 0 6 | | (foobar) -> 0 7 | | (foobar:string) -> 0 8 | | None -> 0 9 | | Some v -> v 10 | | (foo, bar, baz) -> 0 11 | | { foo = x, bar = y, baz = z } -> 0 12 | | { foo = x, bar = y, baz = z } -> 0 13 | | [] -> 0 14 | | [0, 1, 2] -> 0 15 | | hd :: tl -> 0 16 | | hd :: tl :: tl -> 0 17 | | [||] -> 0 18 | | [|0, 1, 2|] -> 0 19 | end 20 | -------------------------------------------------------------------------------- /src/module.mli: -------------------------------------------------------------------------------- 1 | type t = { 2 | parent : t option; 3 | name : Id.t; 4 | tycons : (Id.t * Type_t.tycon) list; 5 | vals : (Id.t * Type_t.t) list; 6 | exts : (Id.t * string) list; 7 | } 8 | 9 | val path : t -> Binding.t 10 | val find_tycon_opt : t -> Id.t -> Type_t.tycon option 11 | val find_val_opt : t -> Id.t -> Type_t.t option 12 | val find_val : t -> Id.t -> Type_t.t 13 | val find_ext_opt : t -> Id.t -> string option 14 | 15 | val erl_name : t -> string 16 | val primitive : t -> Id.t -> string 17 | -------------------------------------------------------------------------------- /src/library.mli: -------------------------------------------------------------------------------- 1 | (* managing modules *) 2 | 3 | val modules : Module.t list ref 4 | val register : Module.t -> unit 5 | 6 | val path_name : Binding.t -> Binding.t * Id.t 7 | val mem_module : Binding.t -> bool 8 | val find_module_opt : Binding.t -> Module.t option 9 | val find_module : Binding.t -> Module.t 10 | val find_tycon_opt : Binding.t -> Type_t.tycon option 11 | val find_val_opt : Binding.t -> Type_t.t option 12 | val find_val : Binding.t -> Type_t.t 13 | 14 | val builtin_tycons : (Id.t * Type_t.tycon) list 15 | -------------------------------------------------------------------------------- /src/config.mli: -------------------------------------------------------------------------------- 1 | val debug : bool ref 2 | val verbose : bool ref 3 | 4 | val syntax_only : bool ref 5 | val compile_only : bool ref 6 | val erl_opts : string option ref 7 | val escript : bool ref 8 | val emu_args : string option ref 9 | val load_paths : string list ref 10 | val add_load_path : string -> unit 11 | val gen_sig_file : bool ref 12 | val gen_spec : bool ref 13 | 14 | val get_env_libs : unit -> string option 15 | 16 | (* debug *) 17 | val print_tycon : string option ref 18 | val print_type : string option ref 19 | -------------------------------------------------------------------------------- /src/config.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | let debug = ref false 4 | let verbose = ref false 5 | 6 | let syntax_only = ref false 7 | let compile_only = ref false 8 | let erl_opts = ref None 9 | let escript = ref false 10 | let emu_args = ref None 11 | let load_paths = ref [] 12 | let add_load_path path = load_paths := !load_paths @ [path] 13 | let gen_sig_file = ref false 14 | let gen_spec = ref true 15 | 16 | let get_env_libs () = opt_of_find Sys.getenv "BRAN_LIBS" 17 | 18 | let print_tycon = ref None 19 | let print_type = ref None 20 | -------------------------------------------------------------------------------- /lib/pervasives.bri: -------------------------------------------------------------------------------- 1 | # String conversion functions 2 | external bool_of_string : string -> bool = "bran_lib_pervasives:bool_of_string" 3 | external string_of_int : int -> string = "bran_lib_pervasives:string_of_int" 4 | external int_of_string : string -> int = "bran_lib_pervasives:int_of_string" 5 | 6 | # Output functions 7 | external print_bool : bool -> unit = "bran_lib_pervasives:print_bool" 8 | external print_int : int -> unit = "bran_lib_pervasives:print_int" 9 | external print_string : string -> unit = "bran_lib_pervasives:print_string" 10 | -------------------------------------------------------------------------------- /circle.yml: -------------------------------------------------------------------------------- 1 | dependencies: 2 | pre: 3 | - bash ./circle/install-otp.sh 4 | - bash ./circle/install-ocaml.sh 5 | - cp /home/ubuntu/ocaml/4.02.1/bin/* /home/ubuntu/bin 6 | - bash ./circle/install-opam.sh 7 | - cp /home/ubuntu/.opam/system/bin/* /home/ubuntu/bin 8 | cache_directories: 9 | - /home/ubuntu/otp 10 | - /home/ubuntu/ocaml 11 | - /home/ubuntu/opam 12 | - /home/ubuntu/.opam 13 | 14 | test: 15 | override: 16 | - /home/ubuntu/.opam/system/bin/omake 17 | - /home/ubuntu/.opam/system/bin/omake test 18 | -------------------------------------------------------------------------------- /test/parsing/match.br: -------------------------------------------------------------------------------- 1 | def f1 x = 2 | match x with 3 | 0 -> print_int 0 4 | | 1 -> print_int 1 5 | | n -> print_int n 6 | end 7 | 8 | def f2 x = 9 | match x with 10 | | 0 -> print_int 0 11 | | 1 -> print_int 1 12 | | n -> print_int n 13 | end 14 | 15 | def f4 x = 16 | match x with 17 | | 0 -> print_int 0 18 | | 1 -> print_int 1 19 | | _ -> print_int n 20 | end 21 | 22 | def f5 x = 23 | match x with 24 | 0 -> print_int 0 25 | end 26 | 27 | def f6 x = 28 | match x with 29 | | 0 -> print_int 0 30 | end 31 | -------------------------------------------------------------------------------- /src/source.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | type t = { 4 | path : string; 5 | mod_name : string; 6 | erl_name : string; 7 | erl_path : string; 8 | defs : Ast_t.def list; 9 | } 10 | 11 | let parse path = 12 | Log.verbose "# begin Source.parse\n"; 13 | let inchan = open_in path in 14 | let defs = Parser.prog Lexer.token (Lexing.from_channel inchan) in 15 | Log.debug "# Source.parse: %s\n" 16 | (String.concat_map ";\n " Ast.string_of_def defs); 17 | { path; mod_name = Utils.module_name path; 18 | erl_name = Utils.base path; erl_path = Utils.erl_path path; 19 | defs } 20 | -------------------------------------------------------------------------------- /src/id.ml: -------------------------------------------------------------------------------- 1 | type t = string (* 変数の名前 (caml2html: id_t) *) 2 | type l = L of string (* トップレベル関数やグローバル配列のラベル (caml2html: id_l) *) 3 | 4 | let rec pp_list = function 5 | | [] -> "" 6 | | [x] -> x 7 | | x :: xs -> x ^ " " ^ pp_list xs 8 | 9 | let counter = ref 0 10 | let genid s = 11 | incr counter; 12 | Printf.sprintf "%s%d" s !counter 13 | 14 | let gentmp s = "_" ^ (genid s) 15 | 16 | type _t = t 17 | 18 | module Map = 19 | Xmap.Make(struct 20 | type t = _t 21 | let compare = compare 22 | end) 23 | 24 | module Set = 25 | Xset.Make(struct 26 | type t = _t 27 | let compare = compare 28 | end) 29 | -------------------------------------------------------------------------------- /circle/install-otp.sh: -------------------------------------------------------------------------------- 1 | VERSION=17.3 2 | set -x 3 | set -e 4 | if [ ! -e otp_src_$VERSION/bin/erl ]; then 5 | curl -O http://www.erlang.org/download/otp_src_$VERSION.tar.gz 6 | tar xzf otp_src_$VERSION.tar.gz 7 | cd otp_src_$VERSION 8 | ./configure \ 9 | --prefix=/home/ubuntu/otp/$VERSION \ 10 | --bindir=/home/ubuntu/bin \ 11 | --enable-smp-support \ 12 | --enable-m64-build \ 13 | --disable-native-libs \ 14 | --disable-sctp \ 15 | --enable-threads \ 16 | --enable-kernel-poll \ 17 | --disable-hipe \ 18 | --without-javac 19 | make 20 | make install 21 | fi 22 | -------------------------------------------------------------------------------- /src/xlist.ml: -------------------------------------------------------------------------------- 1 | let rec init = function 2 | | [] -> assert false 3 | | [x] -> [] 4 | | (x::xs) -> x :: (init xs) 5 | 6 | let for_all2 pred xs ys = 7 | try 8 | List.for_all2 pred xs ys 9 | with 10 | Invalid_argument _ -> false 11 | 12 | let rec inject f1 f2 = function 13 | | [] -> () 14 | | [e] -> f2 e 15 | | e :: es -> 16 | f2 e; 17 | f1 (); 18 | inject f1 f2 es 19 | 20 | let rec inject2 f1 f2 xs ys = 21 | match xs, ys with 22 | | [], [] -> () 23 | | [], _ | _, [] -> raise (Invalid_argument "inject2") 24 | | [x], [y] -> f2 x y 25 | | x :: xs, y :: ys -> 26 | f2 x y; 27 | f1 (); 28 | inject2 f1 f2 xs ys 29 | -------------------------------------------------------------------------------- /test/parsing/char.br: -------------------------------------------------------------------------------- 1 | def c1 _ = 'c' 2 | def c2 _ = '4' 3 | def c3 _ = ' ' 4 | def espace1 _ = '\'' 5 | def espace2 _ = '"' 6 | def espace3 _ = '\"' 7 | def espace4 _ = '\b' 8 | def espace5 _ = '\e' 9 | def espace6 _ = '\f' 10 | def espace7 _ = '\n' 11 | def espace8 _ = '\r' 12 | def espace9 _ = '\s' 13 | def espace10 _ = '\t' 14 | def espace11 _ = '\v' 15 | def oct1 _ = '\0' 16 | def oct2 _ = '\01' 17 | def oct3 _ = '\012' 18 | def hex1 _ = '\x00' 19 | def hex2 _ = '\xff' 20 | def hex3 _ = '\xFF' 21 | def hex4 _ = '\x{00}' 22 | def hex5 _ = '\x{ff}' 23 | def hex6 _ = '\x{FF}' 24 | def ctrl1 _ = '\^a' 25 | def ctrl2 _ = '\^z' 26 | def ctrl3 _ = '\^A' 27 | def ctrl4 _ = '\^Z' 28 | -------------------------------------------------------------------------------- /src/base.ml: -------------------------------------------------------------------------------- 1 | include Spotlib.Base 2 | include Xbase 3 | 4 | module String = struct 5 | include String 6 | include Spotlib.Xstring 7 | include Xstring 8 | end 9 | 10 | module List = struct 11 | include List 12 | include Spotlib.Xlist 13 | include Xlist 14 | end 15 | 16 | module Map = Xmap 17 | 18 | module Set = Xset 19 | 20 | module Filename = struct 21 | include Filename 22 | include Spotlib.Xfilename 23 | end 24 | 25 | module Sys = struct 26 | include Sys 27 | include Spotlib.Xsys 28 | end 29 | 30 | module Unix = struct 31 | include Unix 32 | include Spotlib.Xunix 33 | end 34 | 35 | module Printf = struct 36 | include Printf 37 | include Spotlib.Xprintf 38 | end 39 | -------------------------------------------------------------------------------- /test/test_variant.ml: -------------------------------------------------------------------------------- 1 | open Spotlib.Base 2 | open Sealing 3 | open OUnit2 4 | 5 | let setup _test_ctx = () 6 | 7 | let teardown _ctx _test_ctx = () 8 | 9 | let test_file file test_ctx = 10 | let _ctx = bracket setup teardown test_ctx in 11 | run 12 | ~start_clear:true 13 | (fun env -> 14 | let beam = Program.compile env file in 15 | Program.simple_test env beam) 16 | 17 | let test_files = [ 18 | ("noargs", "test_noargs.br"); 19 | ("args", "test_args.br"); 20 | ] 21 | 22 | let suite = 23 | let auto = 24 | List.rev & List.map (fun (name, file) -> 25 | name >:: (test_file ("../variant/" ^ file))) 26 | test_files 27 | in 28 | "variant" >: (test_list auto) 29 | -------------------------------------------------------------------------------- /circle/install-opam.sh: -------------------------------------------------------------------------------- 1 | VERSION=1.2.0 2 | set -x 3 | set -e 4 | if [ ! -e /home/ubuntu/opam/$VERSION/bin/opam ]; then 5 | curl -L -O https://github.com/ocaml/opam/releases/download/$VERSION/opam-full-$VERSION.tar.gz 6 | tar xvfz opam-full-$VERSION.tar.gz 7 | cd opam-full-$VERSION 8 | ./configure --prefix=/home/ubuntu/opam/$VERSION --bindir=/home/ubuntu/bin 9 | make lib-ext 10 | make 11 | make install 12 | 13 | /home/ubuntu/opam/$VERSION/bin/opam init -a 14 | /home/ubuntu/opam/$VERSION/bin/opam install menhir -y -v 15 | /home/ubuntu/opam/$VERSION/bin/opam install omake -y -v 16 | /home/ubuntu/opam/$VERSION/bin/opam install spotlib -y -v 17 | /home/ubuntu/opam/$VERSION/bin/opam install ounit -y -v 18 | fi 19 | -------------------------------------------------------------------------------- /src/env.mli: -------------------------------------------------------------------------------- 1 | type t = { 2 | venv : Type_t.t Id.Map.t; 3 | tenv : Type_t.t Id.Map.t; 4 | tycons : Type_t.tycon Id.Map.t; 5 | mods : Module.t list; 6 | } 7 | 8 | val empty : t ref 9 | val add_tycon : t -> Id.Map.key -> Type_t.tycon -> t 10 | val add_var : t -> Id.Map.key -> Type_t.t -> t 11 | val add_vars : t -> (Id.Map.key * Type_t.t) list -> t 12 | val find_var_opt : t -> Id.Map.key -> Type_t.t option 13 | val find_var : t -> Id.Map.key -> Type_t.t 14 | val exists_tycon : t -> Id.Map.key -> bool 15 | val find_tycon : t -> Id.Map.key -> Type_t.tycon 16 | val import : t -> Module.t -> t 17 | val find_module_of_val_opt : t -> Id.t -> Module.t option 18 | val find_module_of_val : t -> Id.t -> Module.t 19 | val is_module_val : t -> Id.t -> bool 20 | -------------------------------------------------------------------------------- /src/type_t.ml: -------------------------------------------------------------------------------- 1 | type t = desc With.Loc.t 2 | 3 | and desc = 4 | | Var of tyvar 5 | | Field of t * t (* レコードの型 * フィールドの型 *) 6 | | App of tycon * t list 7 | | Poly of tyvar list * t 8 | | Meta of t option ref (* 型推論であとで代入するために ref 型になっている *) 9 | 10 | and tycon = 11 | | Unit 12 | | Bool 13 | | Int 14 | | Float 15 | | Char 16 | | String 17 | | Atom 18 | | Bitstring 19 | | Binary 20 | | Arrow 21 | | List 22 | | Tuple 23 | | Array 24 | | Record of Id.t * Id.t list (* 型名とフィールド識別子のリスト。型名はあとで名前引きやすいようにするため *) 25 | | Variant of Id.t * constr list (* 最初のId.tは型名。理由は同上 *) 26 | | TyFun of tyvar list * t 27 | | Instance of (tyvar * t) list * t 28 | | NameTycon of Id.t * tycon option ref 29 | | Module of Id.t 30 | 31 | and tyvar = Id.t 32 | and metavar = Id.t 33 | and constr = Id.t * t list 34 | 35 | 36 | -------------------------------------------------------------------------------- /src/type.mli: -------------------------------------------------------------------------------- 1 | type t = Type_t.t 2 | 3 | val newtyvar : unit -> Id.t 4 | 5 | val to_string : t -> Id.t 6 | val to_repr : t -> string 7 | 8 | val equal : t -> t -> bool 9 | 10 | val prefix : t -> Id.t 11 | 12 | val app : Location.t -> Type_t.tycon -> t list -> t (* App *) 13 | val void_app : Location.t -> Type_t.tycon -> t (* App (tycon, []) *) 14 | val app_unit : Location.t -> t (* App (Unit, []) *) 15 | 16 | module Tycon : sig 17 | 18 | type t = Type_t.tycon 19 | 20 | val to_string : t -> string 21 | val to_repr : t -> string 22 | 23 | val vars : t -> (Id.t * Type_t.t) list 24 | val types : t -> (Id.t * Type_t.t) list 25 | 26 | end 27 | 28 | module Constr : sig 29 | 30 | type t = Type_t.constr 31 | 32 | val to_string : t -> string 33 | 34 | end 35 | 36 | module Meta : sig 37 | 38 | val create : Location.t -> t 39 | 40 | end 41 | -------------------------------------------------------------------------------- /test/parsing/bitstring.br: -------------------------------------------------------------------------------- 1 | def bit1 _ = <<1, 17, 42>> 2 | def bit2 _ = <<0, "abc">> 3 | def bit3 _ = <<1,17,42:16>> 4 | def bit4 _ = <> 5 | def bit5 _ = <> 6 | 7 | def bit6 _ = <<123/integer>> 8 | def bit7 _ = <<123/float>> 9 | def bit8 _ = <<123/binary>> 10 | def bit9 _ = <<123/bytes>> 11 | def bit10 _ = <<123/bitstring>> 12 | def bit11 _ = <<123/bits>> 13 | def bit12 _ = <<123/utf8>> 14 | def bit13 _ = <<123/utf16>> 15 | def bit14 _ = <<123/utf32>> 16 | 17 | def bit15 _ = <<123/int>> 18 | def bit16 _ = <<123/sint>> 19 | 20 | def bit17 _ = <<123/signed>> 21 | def bit18 _ = <<123/unsigned>> 22 | 23 | def bit19 _ = <<123/big>> 24 | def bit20 _ = <<123/little>> 25 | def bit21 _ = <<123/native>> 26 | def bit22 _ = <<1:8/unit:8>> 27 | 28 | def bit23 _ = <<123/int-native>> 29 | def bit24 _ = <<123/unsigned-big-integer>> 30 | def bit25 _ = <<"abc"/utf8>> 31 | -------------------------------------------------------------------------------- /src/ast.mli: -------------------------------------------------------------------------------- 1 | open Ast_t 2 | 3 | val string_of_typed_expr : t -> string 4 | val string_of_expr : expr -> string 5 | val string_of_fundef : fundef -> string 6 | val string_of_sigdef : sigdef -> string 7 | val string_of_def : def -> string 8 | val fold : (Env.t * 'a list -> def -> 'a list) -> def list -> Env.t -> 'a list 9 | 10 | module Pattern : sig 11 | 12 | type t = pattern 13 | 14 | val to_string : t -> string 15 | 16 | val fold : 17 | ('b list -> 'c) 18 | -> ('env -> 'a -> 'env * 'b) 19 | -> 'env 20 | -> 'a list 21 | -> 'env * 'c 22 | 23 | val fold_bin : 24 | ('b -> 'b -> 'c) 25 | -> ('env -> 'a -> 'env * 'b) 26 | -> 'env 27 | -> 'a 28 | -> 'a 29 | -> 'env * 'c 30 | 31 | val fold_assoc : 32 | (('x * 'b) list -> 'c) 33 | -> ('env -> 'a -> 'env * 'b) 34 | -> 'env 35 | -> ('x * 'a) list 36 | -> 'env * 'c 37 | 38 | end 39 | -------------------------------------------------------------------------------- /src/tagging.mli: -------------------------------------------------------------------------------- 1 | module type Tag = sig 2 | type t 3 | end 4 | 5 | module type S = sig 6 | 7 | type tag 8 | 9 | type +'a t = { 10 | tag : tag; 11 | desc : 'a; 12 | } 13 | 14 | val create : tag -> 'a -> 'a t 15 | val tag : 'a t -> tag 16 | val desc : 'a t -> 'a 17 | val set : 'a t -> 'a -> 'a t 18 | 19 | val tags : 'a t list -> tag list 20 | val descs : 'a t list -> 'a list 21 | val tags_descs: 'a t list -> tag list * 'a list 22 | val bindings : 'a t list -> (tag * 'a) list 23 | val map : (tag -> 'a -> 'b t) -> 'a t list -> 'b t list 24 | val mapi : (int -> tag -> 'a -> 'b t) -> 'a t list -> 'b t list 25 | val iter : (tag -> 'a -> unit) -> 'a t list -> unit 26 | val fold : ('a -> tag -> 'b -> 'a) -> 'a -> 'b t list -> 'a 27 | val concat : (tag -> tag -> tag) -> 'a t list -> 'a list t 28 | 29 | end 30 | 31 | module Make (T : Tag) : S with type tag = T.t 32 | -------------------------------------------------------------------------------- /test/OMakefile: -------------------------------------------------------------------------------- 1 | .PHONY: all clean test 2 | 3 | USE_OCAMLFIND = true 4 | OCAMLFLAGS += -g -thread -w A-4-9-27-40-42-44-45-48 -warn-error A 5 | #OUNITFLAGS = -runner sequential 6 | OUNITFLAGS = -shards 4 7 | 8 | FILES[] = 9 | program 10 | run 11 | sealing 12 | xounit 13 | test_parsing 14 | test_typexp 15 | test_literals 16 | test_typdef 17 | test_variant 18 | test_pattern 19 | 20 | PROGRAM = run 21 | 22 | OCAMLPACKS[] += 23 | oUnit 24 | unix 25 | spotlib 26 | 27 | test: $(OCamlProgram $(PROGRAM), $(FILES)) 28 | if $(not $(test -e ../src/bran)) 29 | println("Error: Compiler is not found. Do `omake'.") 30 | else 31 | erlc testlib.erl 32 | ./$(PROGRAM) $(OUNITFLAGS) 33 | 34 | # omake xxx.auto.mli creates the mli file from xxx.ml automatically 35 | %.auto.mli: %.ml 36 | $(OCamlC) -i -c $< > $@ 37 | 38 | clean: 39 | rm -rf *.cm* *.o *.opt *.log *.cache $(PROGRAM) test_output* 40 | -------------------------------------------------------------------------------- /src/bitstring.mli: -------------------------------------------------------------------------------- 1 | module Bits : sig 2 | 3 | type t = { 4 | value : value; 5 | size : int option; 6 | typ : typ; 7 | sign : sign option; 8 | endian : endian option; 9 | unit : int option; 10 | } 11 | 12 | and value = 13 | | Int of int 14 | | Float of float 15 | | String of string 16 | | Var of Id.t 17 | 18 | and typ = [`Int | `Float | `Binary | `Bitstring | `UTF8 | `UTF16 | `UTF32] 19 | and sign = [`Signed | `Unsigned] 20 | and endian = [`Big | `Little | `Native] 21 | 22 | val create : 23 | ?size:int 24 | -> ?typ:typ 25 | -> ?sign:sign 26 | -> ?endian:endian 27 | -> ?unit:int 28 | -> value 29 | -> t 30 | 31 | val validate : t -> t 32 | 33 | val to_string : t -> string 34 | 35 | end 36 | 37 | 38 | type t = Bits.t list 39 | 40 | val create : Bits.t list -> t 41 | val to_string : t -> string 42 | val length : t -> int 43 | -------------------------------------------------------------------------------- /src/xmap.ml: -------------------------------------------------------------------------------- 1 | open Map 2 | 3 | module type S = sig 4 | include S 5 | val add_alist : (key * 'a) list -> 'a t -> 'a t 6 | val add_alist2 : key list -> 'a list -> 'a t -> 'a t 7 | val to_alist : 'a t -> (key * 'a) list 8 | val union : 'a t -> 'a t -> 'a t 9 | val to_string : (key -> string) -> ('a -> string) -> 'a t -> string 10 | end 11 | 12 | module Make(O : Map.OrderedType) = struct 13 | include Make(O) 14 | 15 | let add_alist xys m = 16 | List.fold_left (fun m (x, y) -> add x y m) m xys 17 | 18 | let add_alist2 xs ys m = 19 | List.fold_left2 (fun m x y -> add x y m) m xs ys 20 | 21 | let to_alist m = 22 | fold (fun k v accu -> (k, v) :: accu) m [] 23 | 24 | let union m1 m2 = 25 | fold (fun k v m -> add k v m) m2 m1 26 | 27 | let to_string fk fv m = 28 | let kvs = fold (fun k v accu -> 29 | Printf.sprintf "%s = %s" (fk k) (fv v) :: accu) m [] 30 | in 31 | "{" ^ (String.concat "; " kvs) ^ "}" 32 | 33 | end 34 | -------------------------------------------------------------------------------- /src/utils.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | let filepath_of_string path = 4 | let open Spotlib.Filepath in 5 | of_string os path 6 | 7 | let dirbase path = 8 | Spotlib.Filepath.dirbase & filepath_of_string path 9 | 10 | let replace_ext path ext = 11 | (fst & Filename.split_extension path) ^ ext 12 | 13 | let base path = 14 | match dirbase path with 15 | | _, None -> failwith "base" 16 | | _, Some base -> fst & Filename.split_extension base 17 | 18 | let module_name path = 19 | String.capitalize & base path 20 | 21 | let erl_path path = 22 | match dirbase path with 23 | | _, None -> failwith "erl_path" 24 | | dir, Some base -> 25 | let open Spotlib.Filepath in 26 | to_string & dir ^/ replace_ext base ".erl" 27 | 28 | let escript_path path = 29 | let open Spotlib.Filepath in 30 | match dirbase & of_string os path with 31 | | _, None -> failwith "modpath" 32 | | dir, Some base -> 33 | to_string & dir ^/ (fst & Filename.split_extension base) 34 | -------------------------------------------------------------------------------- /src/module.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | type t = { 4 | parent : t option; 5 | name : Id.t; 6 | tycons : (Id.t * Type_t.tycon) list; 7 | vals : (Id.t * Type_t.t) list; 8 | exts : (Id.t * string) list; 9 | } 10 | 11 | let path m = 12 | let rec f m accu = 13 | match m.parent with 14 | | None -> m.name :: accu 15 | | Some p -> f p & m.name :: accu 16 | in 17 | Binding.of_list & f m [] 18 | 19 | let find_tycon_opt m x = 20 | List.find_map_opt 21 | (fun (ex, et) -> if x = ex then Some et else None) m.tycons 22 | 23 | let find_val_opt m x = 24 | List.find_map_opt 25 | (fun (ex, et) -> if x = ex then Some et else None) m.vals 26 | 27 | let find_val m x = find_of_opt & find_val_opt m x 28 | 29 | let find_ext_opt m x = 30 | List.find_map_opt 31 | (fun (ex, et) -> if x = ex then Some et else None) m.exts 32 | 33 | let erl_name m = String.uncapitalize m.name 34 | 35 | let primitive m fx = 36 | match find_ext_opt m fx with 37 | | Some x -> x 38 | | None -> erl_name m ^ ":" ^ fx 39 | -------------------------------------------------------------------------------- /src/binding.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | exception Invalid_path 4 | 5 | type t = C of t option * Id.t 6 | 7 | let pervasives = C (None, "Pervasives") 8 | 9 | let of_list = function 10 | | [] -> failwith "Binding.of_list" 11 | | [x] -> C (None, x) 12 | | x :: xs -> 13 | List.fold_left (fun path x -> C (Some path, x)) (C (None, x)) xs 14 | 15 | let of_string s = 16 | of_list & String.split (function '.' -> true | _ -> false) s 17 | 18 | let path_name (C (path, x)) = path, x 19 | let path = fst ** path_name 20 | let name = snd ** path_name 21 | 22 | let add path x = C (Some path, x) 23 | 24 | let to_list path = 25 | let rec f accu = function 26 | | C (None, x) -> x :: accu 27 | | C (Some path, x) -> x :: f accu path 28 | in 29 | List.rev & f [] path 30 | 31 | let to_string = String.concat "." ** to_list 32 | 33 | let to_erl_fun = function 34 | | C (None, x) -> x 35 | | C (Some path, x) -> 36 | Printf.sprintf "'%s':%s" (String.concat "." & to_list path) x 37 | 38 | let to_erl_atom path = 39 | Printf.sprintf "'%s'" (String.concat "." & to_list path) 40 | -------------------------------------------------------------------------------- /test/program.ml: -------------------------------------------------------------------------------- 1 | open Spotlib.Base 2 | open OUnit2 3 | open Xounit 4 | 5 | type beam = string 6 | 7 | let prog = "../../src/bran" 8 | let flags = ["-I"; "../../lib"] 9 | let command = List.concat [[prog]; flags] 10 | 11 | let erl_flags = ["-pa"; "../../liberl/ebin"; "-pa"; ".."] 12 | 13 | let beam_path path = 14 | Sealing.replace_extension path ".beam" 15 | 16 | let exec_path path = 17 | fst & Spotlib.Xfilename.split_extension path 18 | 19 | let compile env file = 20 | let dest = Sealing.Env.install env file in 21 | let res = Sealing.Env.shell env (command @ [dest]) in 22 | assert_success res; 23 | beam_path dest 24 | 25 | let eval env beam code = 26 | let args = 27 | ["erl"; "-boot"; "start_clean"; "-noinput"; 28 | "-s"; "init"; "stop"; "-eval"; code] @ erl_flags 29 | in 30 | Sealing.Env.shell env args 31 | 32 | let simple_test env beam = 33 | let (modname, _) = Spotlib.Xfilename.split_extension beam in 34 | let res = eval env beam & Printf.sprintf "testlib:simple_test(%s)" modname in 35 | assert_success res; 36 | assert_equal "true" res.stdout 37 | -------------------------------------------------------------------------------- /test/test_literals.ml: -------------------------------------------------------------------------------- 1 | open Spotlib.Base 2 | open OUnit2 3 | 4 | let setup _test_ctx = () 5 | 6 | let teardown _ctx _test_ctx = () 7 | 8 | let test_compile file test_ctx = 9 | let _ctx = bracket setup teardown test_ctx in 10 | let env = Sealing.Env.create () in 11 | Sealing.Env.run env 12 | (fun env -> 13 | let beam = Program.compile env file in 14 | Program.simple_test env beam) 15 | 16 | let test_files = [ 17 | ("unit", "test_unit.br"); 18 | ("true", "test_true.br"); 19 | ("false", "test_false.br"); 20 | ("char", "test_char.br"); 21 | ("string", "test_string.br"); 22 | ("atom", "test_atom.br"); 23 | ("atom_quote", "test_atom_quote.br"); 24 | ("int", "test_int.br"); 25 | ("float", "test_float.br"); 26 | ("bitstring", "test_bitstring.br"); 27 | ("binary", "test_binary.br"); 28 | ("tuple", "test_tuple.br"); 29 | ("list", "test_list.br"); 30 | ] 31 | 32 | let suite = 33 | let auto = 34 | List.rev & List.map (fun (name, file) -> 35 | name >:: test_compile ("../literals/" ^ file)) 36 | test_files 37 | in 38 | "literals" >: (test_list auto) 39 | -------------------------------------------------------------------------------- /src/location.mli: -------------------------------------------------------------------------------- 1 | type t = { 2 | start : Position.t; (** 開始位置 *) 3 | end_ : Position.t; (** 終了位置。終端の要素の次の位置。 4 | * start と end_ が同じ位置であれば、 5 | * 空の範囲であることを示す *) 6 | len : int; (** 長さ。 start と end_ が同じ位置であれば 0 *) 7 | } 8 | 9 | val zero : t 10 | 11 | val create : Position.t -> Position.t -> t 12 | 13 | val start_line : t -> int 14 | val start_line1 : t -> int 15 | val start_col : t -> int 16 | val start_col1 : t -> int 17 | val start_offset : t -> int 18 | val end_line : t -> int 19 | val end_line1 : t -> int 20 | val end_col : t -> int 21 | val end_col1 : t -> int 22 | val end_offset : t -> int 23 | 24 | val values : t -> int * int * int * int 25 | val values1 : t -> int * int * int * int 26 | 27 | val union : t -> t -> t 28 | 29 | val contains_pos : t -> Position.t -> bool 30 | val contains_offset : t -> int -> bool 31 | 32 | val to_string : t -> string 33 | 34 | module Tag_base : Tagging.S with type tag = t 35 | 36 | module Tag : sig 37 | include module type of Tag_base 38 | 39 | val from_range : tag -> tag -> 'a -> 'a t 40 | val tag_of_list : 'a t list -> tag 41 | val union : 'a t list -> 'a list t 42 | 43 | end 44 | -------------------------------------------------------------------------------- /test/test_pattern.ml: -------------------------------------------------------------------------------- 1 | open Spotlib.Base 2 | open Sealing 3 | open OUnit2 4 | 5 | let setup _test_ctx = () 6 | 7 | let teardown _ctx _test_ctx = () 8 | 9 | let test_file file test_ctx = 10 | let _ctx = bracket setup teardown test_ctx in 11 | run 12 | ~start_clear:true 13 | (fun env -> 14 | let beam = Program.compile env file in 15 | Program.simple_test env beam) 16 | 17 | let test_files = [ 18 | ("var", "test_var.br"); 19 | ("bool", "test_bool.br"); 20 | ("atom", "test_atom.br"); 21 | ("int", "test_int.br"); 22 | ("float", "test_float.br"); 23 | ("string", "test_string.br"); 24 | ("unit", "test_unit.br"); 25 | ("tuple", "test_tuple.br"); 26 | ("tuple_var", "test_tuple_var.br"); 27 | ("list", "test_list.br"); 28 | ("empty_list", "test_empty_list.br"); 29 | ("one_list", "test_one_list.br"); 30 | ("cons", "test_cons.br"); 31 | ("as", "test_as.br"); 32 | ("constr", "test_constr.br"); 33 | ("constr_args", "test_constr_args.br"); 34 | ] 35 | 36 | let suite = 37 | let auto = 38 | List.rev & List.map (fun (name, file) -> 39 | name >:: (test_file ("../pattern/" ^ file))) 40 | test_files 41 | in 42 | "pattern" >: (test_list auto) 43 | -------------------------------------------------------------------------------- /src/typing.mli: -------------------------------------------------------------------------------- 1 | exception Unify of Type_t.t * Type_t.t 2 | exception Topdef_error of (Id.t * Type_t.t) * Type_t.t * Type_t.t 3 | exception Error of Ast_t.expr With.Loc.t * Type_t.t * Type_t.t 4 | exception Invalid_constr_arguments of Location.t * Binding.t * int * int 5 | 6 | val subst : Env.t -> Type_t.t Id.Map.t -> Type_t.t -> Type_t.t Id.Map.t * Type_t.t 7 | val occur : Type_t.t option ref -> Type_t.t -> bool 8 | val unify : Env.t -> Type_t.t -> Type_t.t -> unit 9 | val test_unify : unit 10 | val generalize : Env.t -> Type_t.t -> Type_t.t 11 | val instantiate : Env.t -> Type_t.t -> Type_t.t 12 | val deref_tycon : Env.t -> Type_t.tycon -> Type_t.tycon 13 | val deref_type : Env.t -> Type_t.t -> Type_t.t 14 | val deref_pattern : Env.t -> Ast_t.pattern -> Ast_t.pattern * Env.t 15 | val deref_id_type : Env.t -> 'a * Type_t.t -> 'a * Type_t.t 16 | val deref_typed_expr : Env.t -> Ast_t.t -> Ast_t.t 17 | val deref_expr : Env.t -> Ast_t.expr -> Ast_t.expr 18 | val deref_def : Env.t -> Ast_t.def -> Ast_t.def 19 | val pattern : Env.t -> Ast_t.pattern -> Env.t * Type_t.t 20 | val g : Env.t -> Ast_t.t -> Ast_t.expr * Type_t.t 21 | val f' : Env.t -> Ast_t.t * Type_t.t -> Ast_t.expr * Type_t.t 22 | val f : Ast_t.def list -> Ast_t.def list 23 | -------------------------------------------------------------------------------- /src/library.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | let modules = ref [] 4 | 5 | let register m = 6 | modules := m :: !modules 7 | 8 | let find_module_opt x = 9 | List.find_opt (fun m -> Module.path m = x) !modules 10 | 11 | let find_module x = find_of_opt & find_module_opt x 12 | 13 | let path_name path = 14 | match Binding.path_name path with 15 | | None, x -> Binding.pervasives, x 16 | | Some path, x -> path, x 17 | 18 | let mem_module x = find_module_opt x <> None 19 | 20 | let find_tycon_opt path = 21 | let path, x = path_name path in 22 | Module.find_tycon_opt (find_module path) x 23 | 24 | let find_val_opt path = 25 | let path, x = path_name path in 26 | Module.find_val_opt (find_module path) x 27 | 28 | let find_val path = find_of_opt & find_val_opt path 29 | 30 | (* builtin types *) 31 | 32 | let predefloc x = 33 | With.Loc.create Location.zero x 34 | 35 | let app tycon ts = 36 | predefloc (Type_t.App (tycon, ts)) 37 | 38 | let void_app tycon = 39 | app tycon [] 40 | 41 | let tyfun vs t = 42 | Type_t.TyFun (vs, t) 43 | 44 | let void_tyfun t = 45 | tyfun [] t 46 | 47 | let tyfun_app t = 48 | void_tyfun & void_app t 49 | 50 | let builtin_tycons = [ 51 | ("unit", tyfun_app Type_t.Unit); 52 | ("bool", tyfun_app Type_t.Bool); 53 | ("int", tyfun_app Type_t.Int); 54 | ("float", tyfun_app Type_t.Float); 55 | ("char", tyfun_app Type_t.Char); 56 | ("string", tyfun_app Type_t.String); 57 | ("atom", tyfun_app Type_t.Atom); 58 | ("bitstring", tyfun_app Type_t.Bitstring); 59 | ("binary", tyfun_app Type_t.Binary); 60 | ("list", tyfun ["a"] & app Type_t.List []); 61 | ] 62 | -------------------------------------------------------------------------------- /src/erlang_t.ml: -------------------------------------------------------------------------------- 1 | type closure = { 2 | entry : Id.l; 3 | actual_fv : Id.t list; 4 | } 5 | 6 | type t = 7 | | Atom of string 8 | | Int of IntRepr.t 9 | | Float of float 10 | | Char of string 11 | | String of string 12 | | Bitstring of Bitstring.t 13 | | Record of (Id.t * t) list 14 | | Field of t * Id.t 15 | | List of t list 16 | | Array of t list 17 | | Tuple of t list 18 | | Not of t 19 | | And of t * t 20 | | Or of t * t 21 | | Neg of t 22 | | Add of t * t 23 | | Sub of t * t 24 | | Mul of t * t 25 | | Div of t * t 26 | | Concat of t * t 27 | | Eq of t * t 28 | | LE of t * t 29 | | Var of [`Local of Id.t | `Module of Binding.t] 30 | | Constr of Binding.t * t list 31 | | AppCls of t * t list 32 | | AppDir of Binding.t * t list 33 | | If of (t * t) list 34 | | Match of Id.t * (pattern * t) list 35 | | Let of Id.t * t * t 36 | | MakeCls of Id.t * closure * t 37 | 38 | and pattern = 39 | | PtAtom of string 40 | | PtBool of bool 41 | | PtInt of IntRepr.t 42 | | PtFloat of float 43 | | PtString of string 44 | | PtVar of Id.t 45 | | PtAlias of pattern * Id.t 46 | | PtList of pattern list 47 | | PtCons of pattern * pattern 48 | | PtTuple of pattern list 49 | | PtRecord of (Id.t * pattern) list 50 | | PtConstr of Binding.t * pattern list 51 | 52 | type fundef = { 53 | name : Id.l * Type_t.t; 54 | args : (Id.t * Type_t.t) list; 55 | formal_fv : (Id.t * Type_t.t) list; 56 | body : t; 57 | } 58 | 59 | and def = 60 | | ModuleDef of Id.t 61 | | Export of Id.t list 62 | | TypeDef of Id.t * Type_t.tycon 63 | | VarDef of (Id.t * Type_t.t) * t 64 | | FunDef of fundef 65 | 66 | type prog = Prog of def list 67 | -------------------------------------------------------------------------------- /src/kNormal_t.ml: -------------------------------------------------------------------------------- 1 | type t = term * Type_t.t 2 | 3 | and term = 4 | | Unit 5 | | Exp of et 6 | | If of et * t * t 7 | | Match of Id.t * (pattern * t) list 8 | | Let of (Id.t * Type_t.t) * t * t 9 | | LetRec of fundef * t 10 | 11 | and et = expr * Type_t.t 12 | 13 | and expr = 14 | | Bool of bool 15 | | Int of IntRepr.t 16 | | Float of float 17 | | Char of string 18 | | String of string 19 | | Atom of string 20 | | Bitstring of Bitstring.t 21 | | Record of (Id.t * et) list 22 | | Field of et * Id.t 23 | | List of et list 24 | | Tuple of et list 25 | | Array of et list 26 | | Not of et 27 | | And of et * et 28 | | Or of et * et 29 | | Neg of et 30 | | Add of et * et 31 | | Sub of et * et 32 | | Mul of et * et 33 | | Div of et * et 34 | | Eq of et * et 35 | | LE of et * et 36 | | Var of [`Local of Id.t | `Module of Binding.t] 37 | | Concat of et * et 38 | | Constr of Binding.t * et list 39 | | App of et * et list 40 | | ExtFunApp of Id.t * et list 41 | | Get of et * et 42 | | Put of et * et * et 43 | 44 | and pattern = 45 | | PtUnit 46 | | PtBool of bool 47 | | PtInt of IntRepr.t 48 | | PtFloat of float 49 | | PtAtom of string 50 | | PtString of string 51 | | PtVar of Id.t * Type_t.t 52 | | PtAlias of pattern * Id.t * Type_t.t 53 | | PtTuple of pattern list 54 | | PtList of pattern list 55 | | PtCons of pattern * pattern 56 | | PtField of (Id.t * pattern) list 57 | | PtConstr of Binding.t * pattern list 58 | 59 | and fundef = { 60 | name : Id.t * Type_t.t; 61 | args : (Id.t * Type_t.t) list; 62 | body : t; 63 | } 64 | 65 | and def = 66 | | TypeDef of (Id.t * Type_t.tycon) 67 | | VarDef of (Id.t * Type_t.t) * t 68 | | RecDef of fundef 69 | -------------------------------------------------------------------------------- /OMakeroot: -------------------------------------------------------------------------------- 1 | ######################################################################## 2 | # Permission is hereby granted, free of charge, to any person 3 | # obtaining a copy of this file, to deal in the File without 4 | # restriction, including without limitation the rights to use, 5 | # copy, modify, merge, publish, distribute, sublicense, and/or 6 | # sell copies of the File, and to permit persons to whom the 7 | # File is furnished to do so, subject to the following condition: 8 | # 9 | # THE FILE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 10 | # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 11 | # OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 12 | # IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, 13 | # DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR 14 | # OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE FILE OR 15 | # THE USE OR OTHER DEALINGS IN THE FILE. 16 | 17 | ######################################################################## 18 | # The standard OMakeroot file. 19 | # You will not normally need to modify this file. 20 | # By default, your changes should be placed in the 21 | # OMakefile in this directory. 22 | # 23 | # If you decide to modify this file, note that it uses exactly 24 | # the same syntax as the OMakefile. 25 | # 26 | 27 | # 28 | # Include the standard installed configuration files. 29 | # Any of these can be deleted if you are not using them, 30 | # but you probably want to keep the Common file. 31 | # 32 | open build/OCaml 33 | 34 | # 35 | # The command-line variables are defined *after* the 36 | # standard configuration has been loaded. 37 | # 38 | DefineCommandVars() 39 | 40 | # 41 | # Include the OMakefile in this directory. 42 | # 43 | .SUBDIRS: . 44 | -------------------------------------------------------------------------------- /test/test_typdef.ml: -------------------------------------------------------------------------------- 1 | open Spotlib.Base 2 | open Sealing 3 | open OUnit2 4 | open Xounit 5 | 6 | let setup _test_ctx = () 7 | 8 | let teardown _ctx _test_ctx = () 9 | 10 | let test_file file expect test_ctx = 11 | let _ctx = bracket setup teardown test_ctx in 12 | let res = 13 | run 14 | ~start_clear:true 15 | (fun env -> 16 | let dest = Env.install env file in 17 | Env.shell env & Program.command @ ["-print-tycon"; "t"; dest]) 18 | in 19 | assert_success res; 20 | assert_equal expect res.stdout 21 | 22 | let test_files = [ 23 | (* monomorphic types *) 24 | ("unit", "test_unit.br", "unit"); 25 | ("bool", "test_bool.br", "bool"); 26 | ("int", "test_int.br", "int"); 27 | ("float", "test_float.br", "float"); 28 | ("atom", "test_atom.br", "atom"); 29 | ("char", "test_char.br", "char"); 30 | ("string", "test_string.br", "string"); 31 | ("bitstring", "test_bitstring.br", "bitstring"); 32 | ("binary", "test_binary.br", "binary"); 33 | ("tuple", "test_tuple.br", "(int * float)"); 34 | 35 | (* polymorphic types *) 36 | ("poly_list", "test_poly_list.br", "'a list"); 37 | ("int_list", "test_int_list.br", "int list"); 38 | 39 | (* type constructor *) 40 | ("simple_tycon", "test_simple_tycon.br", "A | B | C"); 41 | ("tycon_args", "test_tycon_args.br", "A of int | B of bool * unit | C of string list"); 42 | ("poly_tycon", "test_poly_tycon.br", "A of 'a"); 43 | 44 | (* record *) 45 | ("record", "test_record.br", "{ a : string, b : int }"); 46 | ("poly_record", "test_poly_record.br", "{ a : 'a, b : 'b }"); 47 | ] 48 | 49 | let suite = 50 | let auto = 51 | List.rev & List.map (fun (name, file, expect) -> 52 | name >:: (test_file ("../typdef/" ^ file) expect)) 53 | test_files 54 | in 55 | "typdef" >: (test_list auto) 56 | -------------------------------------------------------------------------------- /src/env.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | type t = { 4 | venv : Type_t.t Id.Map.t; 5 | tenv : Type_t.t Id.Map.t; 6 | tycons : Type_t.tycon Id.Map.t; 7 | mods : Module.t list; 8 | } 9 | 10 | let empty = ref { 11 | venv = Id.Map.empty; 12 | tenv = Id.Map.empty; 13 | tycons = Id.Map.empty; 14 | mods = []; 15 | } 16 | 17 | (* create empty environment *) 18 | let () = 19 | empty := List.fold_left 20 | (fun { venv = venv; tenv = tenv; tycons = tycons; mods = mods } (x, t) -> 21 | { venv = Id.Map.add_alist (Type.Tycon.vars t) venv; 22 | tenv = Id.Map.add_alist (Type.Tycon.types t) tenv; 23 | tycons = Id.Map.add x t tycons; 24 | mods = mods }) !empty Library.builtin_tycons 25 | 26 | let add_tycon env x t = { env with tycons = Id.Map.add x t env.tycons } 27 | let add_var env x t = { env with venv = Id.Map.add x t env.venv } 28 | let add_vars env xys = List.fold_left (fun env (x, y) -> add_var env x y) env xys 29 | let find_var { venv = venv } x = Id.Map.find x venv 30 | let exists_tycon { tycons = tycons } x = Id.Map.mem x tycons 31 | let find_tycon { tycons = tycons } x = Id.Map.find x tycons 32 | 33 | let find_var_opt { venv = venv } x = 34 | if Id.Map.mem x venv then 35 | Some (Id.Map.find x venv) 36 | else 37 | None 38 | 39 | let import env m = 40 | let fold f = List.fold_left (fun env (x, t) -> f env x t) in 41 | let env' = fold add_tycon env m.Module.tycons in 42 | let env'' = fold add_var env' m.Module.vals in 43 | { env'' with mods = m :: env''.mods } 44 | 45 | let find_module_of_val_opt env x = 46 | List.find_opt (fun m -> 47 | match Module.find_val_opt m x with 48 | | Some _ -> true 49 | | None -> false) env.mods 50 | 51 | let find_module_of_val env x = 52 | Spotlib.Option.from_Some & find_module_of_val_opt env x 53 | 54 | let is_module_val env x = find_module_of_val_opt env x <> None 55 | -------------------------------------------------------------------------------- /test/test_typexp.ml: -------------------------------------------------------------------------------- 1 | open Spotlib.Base 2 | open Sealing 3 | open OUnit2 4 | open Xounit 5 | 6 | let setup _test_ctx = () 7 | 8 | let teardown _ctx _test_ctx = () 9 | 10 | let test_parsing file expect test_ctx = 11 | let _ctx = bracket setup teardown test_ctx in 12 | let res = 13 | run 14 | ~start_clear:true 15 | (fun env -> 16 | let dest = Env.install env file in 17 | Env.shell env & Program.command @ ["-print-type"; "dummy"; dest]) 18 | in 19 | assert_success res; 20 | assert_equal expect res.stdout 21 | 22 | let parsing_files = [ 23 | (* primitive types *) 24 | ("unit", "test_unit.bri", "unit"); 25 | ("bool", "test_bool.bri", "bool"); 26 | ("char", "test_char.bri", "char"); 27 | ("int", "test_int.bri", "int"); 28 | ("float", "test_float.bri", "float"); 29 | ("atom", "test_atom.bri", "atom"); 30 | ("string", "test_string.bri", "string"); 31 | ("bitstring", "test_bitstring.bri", "bitstring"); 32 | ("binary", "test_binary.bri", "binary"); 33 | ("tuple", "test_tuple.bri", "(int * int)"); 34 | 35 | (* compound types *) 36 | ("list", "test_list.bri", "string list"); 37 | ("constr_params", "test_constr_params.bri", "(int, float) t"); 38 | 39 | (* functions *) 40 | ("fun_of_unit_unit", "test_fun_of_unit_unit.bri", "unit -> unit"); 41 | ("fun_of_int_float_string", "test_fun_of_int_float_string.bri", 42 | "int -> float -> string"); 43 | ("fun_of_fun", "test_fun_of_fun.bri", "(char -> bool) -> string -> string list"); 44 | 45 | (* polymorphic types *) 46 | ("poly_list", "test_poly_list.bri", "'a list"); 47 | ("poly_fun", "test_poly_fun.bri", "('a -> 'b) -> 'b list -> 'b"); 48 | ] 49 | 50 | let suite = 51 | let auto = 52 | List.rev & List.map (fun (name, file, expect) -> 53 | name >:: (test_parsing ("../typexp/" ^ file) expect)) 54 | parsing_files 55 | in 56 | "typexp" >: (test_list auto) 57 | -------------------------------------------------------------------------------- /src/closure_t.ml: -------------------------------------------------------------------------------- 1 | type closure = { 2 | entry : Id.l; 3 | actual_fv : Id.t list; 4 | } 5 | 6 | type t = term * Type_t.t 7 | 8 | and term = 9 | | Unit 10 | | Exp of et 11 | | If of et * t * t 12 | | Match of Id.t * (pattern * t) list 13 | | Let of (Id.t * Type_t.t) * t * t 14 | | MakeCls of (Id.t * Type_t.t) * closure * t 15 | 16 | and et = expr * Type_t.t 17 | 18 | and expr = 19 | | Bool of bool 20 | | Int of IntRepr.t 21 | | Float of float 22 | | Char of string 23 | | String of string 24 | | Atom of string 25 | | Bitstring of Bitstring.t 26 | | Record of (Id.t * et) list 27 | | Field of et * Id.t 28 | | Tuple of et list 29 | | List of et list 30 | | Array of et list 31 | | Not of et 32 | | And of et * et 33 | | Or of et * et 34 | | Neg of et 35 | | Add of et * et 36 | | Sub of et * et 37 | | Mul of et * et 38 | | Div of et * et 39 | | Concat of et * et 40 | | Eq of et * et 41 | | LE of et * et 42 | | Var of [`Local of Id.t | `Module of Binding.t] 43 | | Constr of Binding.t * et list 44 | | AppCls of et * et list 45 | | AppDir of Binding.t * et list 46 | | Get of et * et 47 | | Put of et * et * et 48 | 49 | and pattern = 50 | | PtUnit 51 | | PtBool of bool 52 | | PtInt of IntRepr.t 53 | | PtFloat of float 54 | | PtAtom of string 55 | | PtString of string 56 | | PtVar of Id.t * Type_t.t 57 | | PtAlias of pattern * Id.t * Type_t.t 58 | | PtTuple of pattern list 59 | | PtList of pattern list 60 | | PtCons of pattern * pattern 61 | | PtRecord of (Id.t * pattern) list 62 | | PtConstr of Binding.t * pattern list 63 | 64 | type fundef = { 65 | name : Id.l * Type_t.t; 66 | args : (Id.t * Type_t.t) list; 67 | formal_fv : (Id.t * Type_t.t) list; 68 | body : t; 69 | } 70 | 71 | and def = 72 | | TypeDef of Id.t * Type_t.tycon 73 | | VarDef of (Id.t * Type_t.t) * t 74 | | FunDef of fundef 75 | 76 | type prog = Prog of def list 77 | -------------------------------------------------------------------------------- /src/location.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | type t = { 4 | start : Position.t; 5 | end_ : Position.t; 6 | len : int; 7 | } 8 | 9 | let start_line t = t.start.line 10 | let start_line1 t = t.start.line + 1 11 | let start_col t = t.start.col 12 | let start_col1 t = t.start.col + 1 13 | let start_offset t = t.start.offset 14 | let end_line t = t.end_.line 15 | let end_line1 t = t.end_.line + 1 16 | let end_col t = t.end_.col 17 | let end_col1 t = t.end_.col + 1 18 | let end_offset t = t.end_.offset 19 | 20 | let values loc = 21 | (start_line loc), (start_col loc), (end_line loc), (end_col loc) 22 | 23 | let values1 loc = 24 | (start_line1 loc), (start_col1 loc), (end_line1 loc), (end_col1 loc) 25 | 26 | let create (start : Position.t) (end_ : Position.t) = 27 | let len = end_.offset - start.offset in 28 | if len < 0 then 29 | raise (Invalid_argument 30 | (Printf.sprintf "Location.create: start > end (%d, %d)" 31 | start.offset end_.offset)) 32 | else 33 | { start; end_; len } 34 | 35 | let zero = 36 | create Position.zero Position.zero 37 | 38 | let _union start end_ = 39 | create start.start end_.end_ 40 | 41 | let union = _union 42 | 43 | let contains_pos loc (pos : Position.t) = 44 | loc.start.offset <= pos.offset && pos.offset < loc.end_.offset 45 | 46 | let contains_offset loc offset = 47 | loc.start.offset <= offset && offset < loc.end_.offset 48 | 49 | let to_string loc = 50 | Printf.sprintf "%d:%d:%d-%d:%d:%d" 51 | loc.start.line loc.start.col loc.start.offset 52 | loc.end_.line loc.end_.col loc.end_.offset 53 | 54 | type _t = t 55 | 56 | module Tag_base = Tagging.Make(struct type t = _t end) 57 | 58 | module Tag = struct 59 | include Tag_base 60 | 61 | let from_range start_loc end_loc value = 62 | create (_union start_loc end_loc) value 63 | 64 | let tag_of_list es = 65 | _union (tag & List.hd es) (tag & List.last es) 66 | 67 | let union es = 68 | concat (fun t1 t2 -> _union t1 t2) es 69 | 70 | end 71 | -------------------------------------------------------------------------------- /src/ast_t.ml: -------------------------------------------------------------------------------- 1 | exception Syntax_error of Location.t * string option 2 | exception Unbound_value_error of Location.t * Id.t 3 | exception Unbound_module_error of Location.t * Id.t 4 | 5 | type t = (expr * Type_t.t) With.Loc.t 6 | and expr = 7 | Unit 8 | | Bool of bool 9 | | Int of IntRepr.t 10 | | Float of float 11 | | Char of string 12 | | String of string 13 | | Atom of string 14 | | Bitstring of Bitstring.t 15 | | Record of (Id.t * t) list 16 | | Field of t * Id.t 17 | | List of t list 18 | | Tuple of t list 19 | | Array of t list 20 | | Not of t 21 | | And of t * t 22 | | Or of t * t 23 | | Neg of t 24 | | Add of t * t 25 | | Sub of t * t 26 | | Mul of t * t 27 | | Div of t * t 28 | | Eq of t * t 29 | | LE of t * t 30 | | If of t * t * t 31 | | Match of t * (pattern * t) list 32 | | LetVar of (Id.t * Type_t.t) * t * t 33 | | Var of [`Unbound of Binding.t | `Local of Id.t | `Module of Binding.t] 34 | | Concat of t * t 35 | | Constr of Binding.t * t list 36 | | LetRec of fundef * t 37 | | App of t * t list 38 | | Get of t * t 39 | | Put of t * t * t 40 | | Perform of t 41 | | Bind of (Id.t * Type_t.t) * t 42 | | Return of t 43 | and pattern = pattern_desc With.Loc.t 44 | and pattern_desc = 45 | | PtUnit 46 | | PtBool of bool 47 | | PtInt of IntRepr.t 48 | | PtFloat of float 49 | | PtAtom of string 50 | | PtString of string 51 | | PtVar of Id.t * Type_t.t 52 | | PtAlias of pattern * Id.t * Type_t.t 53 | | PtTuple of pattern list 54 | | PtList of pattern list 55 | | PtCons of pattern * pattern 56 | | PtRecord of (Id.t * pattern) list 57 | | PtConstr of Binding.t * pattern list * Type_t.t 58 | and fundef = { name : Id.t * Type_t.t; args : (Id.t * Type_t.t) list; body : t; } 59 | and sigdef = { 60 | sig_name : Id.t * Type_t.t; 61 | sig_ext : string option; 62 | } 63 | and def = def_desc With.Loc.t 64 | and def_desc = 65 | | Nop 66 | | TypeDef of Id.t * Type_t.tycon 67 | | VarDef of (Id.t * Type_t.t) * t 68 | | RecDef of fundef 69 | | SigDef of sigdef 70 | 71 | -------------------------------------------------------------------------------- /test/test_parsing.ml: -------------------------------------------------------------------------------- 1 | open Spotlib.Base 2 | open Sealing 3 | open OUnit2 4 | open Xounit 5 | 6 | let setup _test_ctx = () 7 | 8 | let teardown _ctx _test_ctx = () 9 | 10 | let test_parsing file test_ctx = 11 | let _ctx = bracket setup teardown test_ctx in 12 | let res = 13 | run 14 | ~start_clear:true 15 | (fun env -> 16 | let dest = Env.install env file in 17 | Env.shell env & Program.command @ ["-s"; dest]) 18 | in 19 | assert_success res; 20 | assert_no_file_changes res 21 | 22 | let parsing_files = [ 23 | ("comment", "comment.br"); 24 | 25 | (* definitions *) 26 | ("top_def", "def.br"); 27 | ("top_var", "topvar.br"); 28 | ("local_def", "local_def.br"); 29 | ("local_var", "local_var.br"); 30 | ("circular_ref", "circular_ref.br"); 31 | 32 | (* signatures *) 33 | ("sig_def", "sig_def.bri"); 34 | ("sig_var", "sig_var.bri"); 35 | ("external", "external.bri"); 36 | 37 | (* literals *) 38 | ("atom", "atom.br"); 39 | ("char", "char.br"); 40 | ("string", "string.br"); 41 | ("bool", "bool.br"); 42 | ("int", "int.br"); 43 | ("float", "float.br"); 44 | ("bitstring", "bitstring.br"); 45 | ("dollar", "dollar.br"); 46 | ("list", "list.br"); 47 | ("tuple", "tuple.br"); 48 | ("array", "array.br"); 49 | ("field", "field.br"); 50 | 51 | (* operators *) 52 | ("intop", "intop.br"); 53 | ("floatop", "floatop.br"); 54 | 55 | (* pattern matching *) 56 | ("match", "match.br"); 57 | ("pattern", "pattern.br"); 58 | ("message", "message.br"); 59 | 60 | (* controls *) 61 | ("if", "if.br"); 62 | ("for", "for.br"); 63 | ("try", "try.br"); 64 | ("fun", "fun.br"); 65 | ("monad", "monad.br"); 66 | ("assert", "assert.br"); 67 | ("exception", "exception.br"); 68 | ("ref", "ref.br"); 69 | 70 | (* type definitions *) 71 | ("simple_typdef", "simple_typdef.br"); 72 | ("variant_typdef", "variant_typdef.br"); 73 | ("record_typdef", "record_typdef.br"); 74 | 75 | ] 76 | 77 | let suite = 78 | let auto = 79 | List.rev & List.map (fun (name, file) -> 80 | name >:: (test_parsing & "../parsing/" ^ file)) 81 | parsing_files 82 | in 83 | "parsing" >: (test_list auto) 84 | -------------------------------------------------------------------------------- /src/tagging.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | module type Tag = sig 4 | type t 5 | end 6 | 7 | module type S = sig 8 | 9 | type tag 10 | 11 | type +'a t = { 12 | tag : tag; 13 | desc : 'a; 14 | } 15 | 16 | val create : tag -> 'a -> 'a t 17 | val tag : 'a t -> tag 18 | val desc : 'a t -> 'a 19 | val set : 'a t -> 'a -> 'a t 20 | 21 | val tags : 'a t list -> tag list 22 | val descs : 'a t list -> 'a list 23 | val tags_descs: 'a t list -> tag list * 'a list 24 | val bindings : 'a t list -> (tag * 'a) list 25 | val map : (tag -> 'a -> 'b t) -> 'a t list -> 'b t list 26 | val mapi : (int -> tag -> 'a -> 'b t) -> 'a t list -> 'b t list 27 | val iter : (tag -> 'a -> unit) -> 'a t list -> unit 28 | val fold : ('a -> tag -> 'b -> 'a) -> 'a -> 'b t list -> 'a 29 | val concat : (tag -> tag -> tag) -> 'a t list -> 'a list t 30 | 31 | end 32 | 33 | module Make (T : Tag) = struct 34 | 35 | type tag = T.t 36 | 37 | type 'a t = { 38 | tag : T.t; 39 | desc : 'a; 40 | } 41 | 42 | let create tag desc = { tag; desc } 43 | 44 | let tag e = e.tag 45 | let desc e = e.desc 46 | let set e x = { e with desc = x } 47 | 48 | let tags es = 49 | List.rev & List.fold_left (fun accu e -> e.tag :: accu) [] es 50 | 51 | let descs es = 52 | List.rev & List.fold_left (fun accu e -> e.desc :: accu) [] es 53 | 54 | let tags_descs es = 55 | List.fold_left 56 | (fun (ts, ds) e -> e.tag :: ts, e.desc :: ds) 57 | ([], []) (List.rev es) 58 | 59 | let bindings es = 60 | List.rev & List.fold_left (fun accu e -> (e.tag, e.desc) :: accu) [] es 61 | 62 | let map f es = 63 | List.map (fun e -> f e.tag e.desc) es 64 | 65 | let mapi f es = 66 | List.mapi (fun i e -> f i e.tag e.desc) es 67 | 68 | let iter f es = 69 | List.iter (fun e -> f e.tag e.desc) es 70 | 71 | let fold f init es = 72 | List.fold_left (fun accu e -> f accu e.tag e.desc) init es 73 | 74 | let concat f es = 75 | match es with 76 | | [] -> failwith "Tagging.S.concat: empty list" 77 | | [e] -> create e.tag [e.desc] 78 | | e' :: es' -> 79 | let es'', t' = List.fold_left 80 | (fun (ds, t) e -> e.desc :: ds, f t e.tag) 81 | ([e'.desc], e'.tag) es' 82 | in 83 | create t' es'' 84 | 85 | end 86 | -------------------------------------------------------------------------------- /src/sig.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | exception Error of Location.t * string 4 | exception Pervasives_not_found 5 | 6 | let find_lib_file path = 7 | let open Spotlib.Filepath in 8 | match List.find_map_opt 9 | (fun dir -> 10 | let dir' = of_string os dir in 11 | let path' = to_string & dir' ^/ path in 12 | Log.verbose "# find %s\n" path'; 13 | if Sys.file_exists path' then 14 | Some path' 15 | else 16 | None) !Config.load_paths 17 | with 18 | | None -> path 19 | | Some p -> p 20 | 21 | let parse src = 22 | let open Ast_t in 23 | let open With.Loc in 24 | let parse' (typs, vals, exts) def = 25 | match def.desc with 26 | | SigDef { sig_name = (x, t); sig_ext = sig_ext } -> 27 | Log.debug "# val %s : %s\n" x (Type.to_string t); 28 | let exts' = 29 | match sig_ext with 30 | | None -> exts 31 | | Some s -> (x, s) :: exts 32 | in 33 | (typs, (x, t) :: vals, exts') 34 | | _ -> 35 | raise (Error (def.tag, "Signature definition only at .bri file")) 36 | in 37 | List.fold_left parse' ([], [], []) src.Source.defs 38 | 39 | let load src = 40 | let name = src.Source.mod_name in 41 | Log.verbose "# begin loading module %s\n" name; 42 | let (tycons, vals, exts) = parse src in 43 | Library.register { Module.parent = None; name; tycons; vals; exts }; 44 | Log.verbose "# end loading module %s\n" name 45 | 46 | let load_file fpath = 47 | Log.verbose "# loading signature file \"%s\"...\n" fpath; 48 | let fpath' = find_lib_file fpath in 49 | Log.verbose "# load %s\n" fpath'; 50 | if Sys.file_exists fpath' then begin 51 | load & Source.parse fpath'; 52 | `Ok 53 | end else 54 | `Error 55 | 56 | let load_module path = 57 | match Binding.path_name path with 58 | | Some _, _ -> failwith "not yet supported" 59 | | None, name -> load_file & String.uncapitalize name ^ ".bri" 60 | 61 | let empty = ref None 62 | 63 | let create_env () = 64 | match !empty with 65 | | Some env -> env 66 | | None -> 67 | let env = !Env.empty in 68 | if load_module Binding.pervasives = `Error then 69 | raise Pervasives_not_found; 70 | let env' = Env.import env & Library.find_module Binding.pervasives in 71 | empty := Some env'; 72 | env' 73 | -------------------------------------------------------------------------------- /src/bitstring.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | module Bits = struct 4 | 5 | type t = { 6 | value : value; 7 | size : int option; 8 | typ : typ; 9 | sign : sign option; 10 | endian : endian option; 11 | unit : int option; 12 | } 13 | 14 | and value = 15 | | Int of int 16 | | Float of float 17 | | String of string 18 | | Var of Id.t 19 | 20 | and typ = [`Int | `Float | `Binary | `Bitstring | `UTF8 | `UTF16 | `UTF32] 21 | and sign = [`Signed | `Unsigned] 22 | and endian = [`Big | `Little | `Native] 23 | 24 | let validate bits = 25 | (* check size *) 26 | let size = 27 | match bits.size with 28 | | None -> 29 | Some (begin match bits.typ with 30 | | `Int -> 8 31 | | `Float -> 64 32 | | `Binary | `Bitstring | _ -> failwith "not implemented" (* TODO *) 33 | end) 34 | | Some v -> Some v (* TODO: validation *) 35 | in 36 | 37 | (* check signedness *) 38 | let sign = 39 | Some (match bits.sign with 40 | | None -> `Unsigned 41 | | Some v -> 42 | match bits.typ with 43 | | `Int -> v 44 | | _ -> failwith "Signedness must be given for int") 45 | in 46 | 47 | (* check endianness and type *) 48 | let endian = 49 | Some (match bits.endian with 50 | | None -> `Big 51 | | Some v -> 52 | match bits.typ with 53 | | `Int | `Float | `UTF16 | `UTF32 -> v 54 | | _ -> failwith "Endianness must be given for int, float, utf16 and utf32") 55 | in 56 | 57 | (* check unit *) 58 | let unit = 59 | Some (match bits.unit with 60 | | None -> 61 | begin match bits.typ with 62 | | `Int | `Float | `Bitstring -> 1 63 | | `Binary -> 8 64 | | _ -> failwith "Unit specifier must be given" 65 | end 66 | | Some v -> 67 | if not (1 <= v && v <= 256) then 68 | failwith "Unit allows range 1..256" 69 | else 70 | v) 71 | in 72 | { bits with size; sign; endian; unit } 73 | 74 | let create ?size ?(typ=`Int) ?sign ?endian ?unit value = 75 | { value; size; typ; sign; endian; unit } 76 | 77 | let to_string bits = 78 | "**" (* TODO *) 79 | 80 | end 81 | 82 | 83 | type t = Bits.t list 84 | 85 | let create l = l 86 | 87 | let to_string l = 88 | "<<" ^ (String.concat_map ", " Bits.to_string l) ^ ">>" 89 | 90 | let length bs = 91 | List.fold_left (fun sum b -> 92 | match b.Bits.size with 93 | | None -> failwith "size is none" 94 | | Some v -> sum + v) 0 bs 95 | -------------------------------------------------------------------------------- /test/sealing.mli: -------------------------------------------------------------------------------- 1 | (* command-line application testing *) 2 | 3 | val debug : bool ref 4 | 5 | module FileChange : sig 6 | 7 | type change = 8 | | Not_changed 9 | | Accessed 10 | | Created 11 | | Modified 12 | | Changed 13 | | Deleted 14 | 15 | type t = { 16 | path : string; 17 | change : change; 18 | time : float; 19 | } 20 | 21 | val path : t -> string 22 | val change : t -> change 23 | val time : t -> float 24 | 25 | val to_string : t -> string 26 | val change_to_string : change -> string 27 | 28 | end 29 | 30 | module Result : sig 31 | 32 | type t = { 33 | stdout : string; 34 | stderr : string; 35 | status : Unix.process_status; 36 | file_changes : FileChange.t list; 37 | predictions : FileChange.t list; 38 | } 39 | 40 | val changes : t -> FileChange.t list 41 | val find_files_changed : t -> FileChange.change -> string list 42 | val files_updated : t -> FileChange.t list 43 | val has_file_changes : t -> bool 44 | val has_files_created_only : t -> string list -> bool 45 | 46 | val return_code : t -> int option 47 | val is_exited : t -> bool 48 | val is_succeeded : t -> bool 49 | 50 | val prediction : t -> [`Success | `Failure] 51 | 52 | end 53 | 54 | module Env : sig 55 | 56 | type t 57 | 58 | val create : 59 | ?env:((string * string) list) 60 | -> ?start_clear:bool 61 | -> ?ignore_files:string list 62 | -> ?ignore_hidden:bool 63 | -> ?parallel:bool 64 | -> ?expect_error:bool 65 | -> ?expect_stderr:bool 66 | -> ?quiet:bool 67 | -> ?basedir:string 68 | -> unit 69 | -> t 70 | (** Create an environment at the base path *) 71 | 72 | val clear : ?force:bool -> t -> unit 73 | (** Delete all the files in the base directory *) 74 | 75 | val run : ?chdir:string -> t -> (t -> 'a) -> 'a 76 | 77 | val shell : t -> string list -> Result.t 78 | 79 | val install : t -> string -> string 80 | (** Copy the file to the base directory *) 81 | 82 | val write : t -> string -> (out_channel -> unit) -> unit 83 | 84 | val predict : t -> string -> FileChange.change -> unit 85 | (** Register the file name will be changed at running. 86 | * The result of prediction can be confirmed with Result.prediction *) 87 | 88 | end 89 | 90 | val run : 91 | ?env:((string * string) list) 92 | -> ?start_clear:bool 93 | -> ?ignore_files:string list 94 | -> ?ignore_hidden:bool 95 | -> ?parallel:bool 96 | -> ?expect_error:bool 97 | -> ?expect_stderr:bool 98 | -> ?quiet:bool 99 | -> ?basedir:string 100 | -> (Env.t -> 'a) 101 | -> 'a 102 | 103 | val replace_extension : string -> string -> string 104 | (** [replace_extension path extension] 105 | * replace extension of [path] with [extension]. 106 | * [replace_extension "hello.world.txt" ".bin" = "hello.world.bin"] 107 | * [replace_extension "hello_world" ".txt" = "hello_world.txt"] 108 | *) 109 | -------------------------------------------------------------------------------- /src/erlang.ml: -------------------------------------------------------------------------------- 1 | open Spotlib.Base 2 | open Erlang_t 3 | 4 | let literal_of_string s = 5 | (* adhoc *) 6 | "\"" ^ s ^ "\"" 7 | 8 | let literal_of_float f = 9 | (* adhoc *) 10 | Printf.sprintf "%f" f 11 | 12 | let true_atom = Atom "true" 13 | let false_atom = Atom "false" 14 | (* let ok_atom = Atom "ok" *) 15 | 16 | let rec gen_exp (e, t) = 17 | Log.debug "# Erlang.gen_exp %s\n" (Closure.string_of_expr e); 18 | match e with 19 | | Closure_t.Bool true -> true_atom 20 | | Closure_t.Bool false -> false_atom 21 | | Closure_t.Int v -> Int v 22 | | Closure_t.Float v -> Float v 23 | | Closure_t.Char s -> Char s 24 | | Closure_t.String s -> String s 25 | | Closure_t.Atom s -> Atom s 26 | | Closure_t.Bitstring s -> Bitstring s 27 | | Closure_t.Tuple ets -> Tuple (List.map gen_exp ets) 28 | | Closure_t.List ets -> List (List.map gen_exp ets) 29 | | Closure_t.Array ets -> Array (List.map gen_exp ets) 30 | | Closure_t.Not et -> Not (gen_exp et) 31 | | Closure_t.And (e1, e2) -> And (gen_exp e1, gen_exp e2) 32 | | Closure_t.Or (e1, e2) -> Or (gen_exp e1, gen_exp e2) 33 | | Closure_t.Neg et -> Neg (gen_exp et) 34 | | Closure_t.Add (e1, e2) -> Add (gen_exp e1, gen_exp e2) 35 | | Closure_t.Sub (e1, e2) -> Sub (gen_exp e1, gen_exp e2) 36 | | Closure_t.Mul (e1, e2) -> Mul (gen_exp e1, gen_exp e2) 37 | | Closure_t.Div (e1, e2) -> Div (gen_exp e1, gen_exp e2) 38 | | Closure_t.Concat (e1, e2) -> Concat (gen_exp e1, gen_exp e2) 39 | | Closure_t.Eq (e1, e2) -> Eq (gen_exp e1, gen_exp e2) 40 | | Closure_t.LE (e1, e2) -> LE (gen_exp e1, gen_exp e2) 41 | | Closure_t.Var x -> Var x 42 | | Closure_t.AppDir (x, ets) -> AppDir (x, List.map gen_exp ets) 43 | | Closure_t.Constr (x, ets) -> Constr (x, List.map gen_exp ets) 44 | | _ -> failwith & "not implemented: " ^ (Closure.string_of_expr e) 45 | 46 | let rec gen_ptn = function 47 | | Closure_t.PtUnit -> PtTuple [] 48 | | Closure_t.PtBool v -> PtBool v 49 | | Closure_t.PtInt v -> PtInt v 50 | | Closure_t.PtFloat v -> PtFloat v 51 | | Closure_t.PtAtom v -> PtAtom v 52 | | Closure_t.PtString v -> PtString v 53 | | Closure_t.PtVar (x, _) -> PtVar x 54 | | Closure_t.PtAlias (p, x, _) -> PtAlias (gen_ptn p, x) 55 | | Closure_t.PtTuple ps -> PtTuple (List.map gen_ptn ps) 56 | | Closure_t.PtList ps -> PtList (List.map gen_ptn ps) 57 | | Closure_t.PtCons (p1, p2) -> PtCons (gen_ptn p1, gen_ptn p2) 58 | | Closure_t.PtRecord xps -> 59 | PtRecord (List.map (fun (x, p) -> (x, gen_ptn p)) xps) 60 | | Closure_t.PtConstr (x, ps) -> PtConstr (x, List.map gen_ptn ps) 61 | 62 | and gen_term (term, t) = 63 | Log.debug "# Erlang.gen_term %s\n" (Closure.string_of_term term); 64 | match term with 65 | | Closure_t.Unit -> Tuple [] 66 | | Closure_t.Exp e -> gen_exp e 67 | | Closure_t.If (e, tr1, tr2) -> 68 | If [(gen_exp e, gen_term tr1); (true_atom, gen_term tr2)] 69 | | Closure_t.Match (x, pts) -> 70 | Match (x, List.map (fun (p, t) -> gen_ptn p, gen_term t) pts) 71 | | Closure_t.Let ((x, _), e1, e2) -> 72 | Let (x, gen_term e1, gen_term e2) 73 | | _ -> assert false 74 | 75 | let gen_def = function 76 | | Closure_t.TypeDef (x, tycon) -> [TypeDef (x, tycon)] 77 | | Closure_t.VarDef _ -> [] 78 | | Closure_t.FunDef def -> 79 | [FunDef { name = def.name; args = def.args; formal_fv = def.formal_fv; 80 | body = gen_term def.body }] 81 | 82 | let f (Closure_t.Prog defs) = 83 | Prog (List.concat & List.map gen_def defs) 84 | -------------------------------------------------------------------------------- /src/main.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | (* entry point *) 4 | let () = 5 | let open Printf in 6 | let files = ref [] in 7 | Arg.parse 8 | [("-c", Arg.Unit (fun () -> Config.compile_only := true), 9 | "compile only, output Erlang source"); 10 | ("-d", Arg.Unit (fun () -> Config.debug := true), "print debug messages"); 11 | ("-emu-args", Arg.String (fun v -> Config.emu_args := Some v), 12 | "Erlang emulator flag embedded into executable file"); 13 | ("-erl", Arg.String (fun v -> Config.erl_opts := Some v), 14 | "Erlang compiler (erlc) options"); 15 | ("-escript", Arg.Unit (fun () -> Config.escript := true), 16 | "create an executable file"); 17 | ("-i", Arg.Unit (fun () -> Config.gen_sig_file := true), 18 | "generate inferred interface to signature file (*.auto.bri)"); 19 | ("-I", Arg.String Config.add_load_path, "add the path to load path list"); 20 | ("-s", Arg.Unit (fun () -> Config.syntax_only := true), "check syntax only"); 21 | ("-spec", Arg.Unit (fun () -> Config.gen_spec := true), 22 | "generate -spec for functions"); 23 | ("-v", Arg.Unit (fun () -> Config.verbose := true), "print verbose messages"); 24 | ("-V", Arg.Unit (fun () -> printf "%s\n" Version.version), 25 | "print version and exit"); 26 | ("-print-tycon", Arg.String (fun v -> Config.print_tycon := Some v), 27 | "print type constructor of type (for debug)"); 28 | ("-print-type", Arg.String (fun v -> Config.print_type := Some v), 29 | "print type of value (for debug)"); 30 | ] 31 | (fun s -> files := !files @ [s]) 32 | (sprintf "Usage: %s [options] file" Sys.argv.(0)); 33 | if List.length !files = 0 then begin 34 | Printf.printf "Error: No input files\n"; 35 | Printf.printf "Try `-help' option for usage information.\n"; 36 | exit 1 37 | end; 38 | 39 | (* getenv BRAN_LIBS *) 40 | Spotlib.Option.iter 41 | (fun path -> 42 | Log.verbose "# BRAN_LIBS = %s\n" path; 43 | Config.add_load_path path) & Config.get_env_libs (); 44 | 45 | List.iter 46 | (fun fpath -> 47 | try 48 | begin 49 | begin match Filename.split_extension fpath with 50 | | (_, ".br") -> ignore & Compiler.compile_file fpath 51 | | (_, ".bri") -> ignore & Sig.load_file fpath 52 | | (_, ext) -> Log.error "Unknown file extension %s\n" ext 53 | end; 54 | 55 | let print_type f p name = 56 | let binding name = 57 | Binding.of_string & 58 | match String.index_opt name '.' with 59 | | None -> (Utils.module_name fpath) ^ "." ^ name 60 | | Some _ -> name 61 | in 62 | match name with 63 | | None -> () 64 | | Some name -> 65 | try begin 66 | match f & binding name with 67 | | None -> Spotlib.Exn.failwithf "Value `%s' is not found" name 68 | | Some t -> Printf.printf "%s" (p t) 69 | end with 70 | | Binding.Invalid_path -> failwith "Invalid binding path" 71 | in 72 | 73 | (* debug: -print-tycon *) 74 | print_type Library.find_tycon_opt Type.Tycon.to_repr !Config.print_tycon; 75 | 76 | (* debug: -print-type *) 77 | print_type Library.find_val_opt Type.to_repr !Config.print_type 78 | end 79 | with 80 | | e -> Console.print_exc fpath e) 81 | !files 82 | -------------------------------------------------------------------------------- /src/compiler.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | exception Error of string 4 | 5 | let compile_erl_file fpath = 6 | let open Unix.Command in 7 | let (dir, _) = Utils.dirbase fpath in 8 | let dir' = Spotlib.Filepath.to_string dir in 9 | let cmd_s = Printf.sprintf "erlc -W0 -o %s %s" dir' fpath in 10 | Log.verbose "# $ %s\n" cmd_s; 11 | let cmd = shell cmd_s in 12 | match print ~prefix:"# erlc" cmd with 13 | | (Unix.WEXITED 0, _) -> () 14 | | _ -> raise (Error "Erlang compilation failed") 15 | 16 | let create_exec_file fpath = 17 | let open Printf in 18 | let buf = Buffer.create 1 in 19 | let (exec, _) = Filename.split_extension fpath in 20 | bprintf buf "erl -boot start_clean -noinput -s init stop -eval '"; 21 | bprintf buf "{ok, _, Beam} = compile:file(\"%s\", [binary, compressed, debug_info]), " fpath; 22 | bprintf buf "escript:create(\"%s\", [shebang, {beam, Beam}, " exec; 23 | bprintf buf "{emu_args, \"-pa bran/ebin %s\"}])'" 24 | (Spotlib.Option.default !Config.emu_args (fun () -> "")); 25 | let cmd_s = Buffer.contents buf in 26 | Log.verbose "# $ %s\n" cmd_s; 27 | let cmd = Unix.Command.shell cmd_s in 28 | match Unix.Command.print ~prefix:"# erl" cmd with 29 | | (Unix.WEXITED 0, _) -> () 30 | | _ -> raise (Error "Executable file creation failed") 31 | 32 | (* 33 | let limit = ref 1000 34 | let rec optimize n e = 35 | if n = 0 then 36 | e 37 | else 38 | let e' = Beta.f e in 39 | (* 40 | if e = e' then (* TODO: (=) operator raises Out_of_memory exception *) 41 | e 42 | else 43 | *) 44 | optimize (n - 1) e' 45 | *) 46 | 47 | let gen_sig_file fpath defs = 48 | let open Ast_t in 49 | Log.verbose "# generate signature file\n"; 50 | let lines = Ast.fold (fun (env, accu) def -> 51 | match def.desc with 52 | | TypeDef (x, t) -> 53 | (* FIXME *) 54 | Printf.sprintf "type %s = %s" x (Type.Tycon.to_repr t) :: accu 55 | | VarDef ((x, t), _) -> 56 | Printf.sprintf "var %s : %s" x (Type.to_repr t) :: accu 57 | | RecDef { name = (x, t) } -> 58 | Printf.sprintf "def %s : %s" x (Type.to_repr t) :: accu 59 | | _ -> accu) 60 | defs (Sig.create_env ()) 61 | in 62 | let oc = open_out & Utils.replace_ext fpath ".auto.bri" in 63 | let s = String.concat "\n" lines in 64 | Log.verbose "%s\n" s; 65 | Printf.fprintf oc "%s\n" s 66 | 67 | let parse defs = 68 | let open Ast_t in 69 | let open With.Loc in 70 | let parse' (tycons, vals, exts) def = 71 | match def.desc with 72 | | TypeDef (x, tycon) -> 73 | Log.debug "# type %s : %s\n" x (Type.Tycon.to_string tycon); 74 | ((x, tycon) :: tycons, vals, exts) 75 | | VarDef ((x, t), _) -> 76 | Log.debug "# var %s : %s\n" x (Type.to_string t); 77 | (tycons, (x, t) :: vals, exts) 78 | | RecDef { name = (x, t) } -> 79 | Log.debug "# def %s : %s\n" x (Type.to_string t); 80 | (tycons, (x, t) :: vals, exts) 81 | | SigDef _ -> 82 | raise (Sig.Error (def.tag, "Signature definition only at .bri file")) 83 | | _ -> (tycons, vals, exts) 84 | in 85 | List.fold_left parse' ([], [], []) defs 86 | 87 | let register name defs = 88 | Log.verbose "# register module %s\n" name; 89 | let (tycons, vals, exts) = parse defs in 90 | Library.register { Module.parent = None; name; tycons; vals; exts } 91 | 92 | let compile_file' src = 93 | let open Source in 94 | let mx = Binding.of_string src.mod_name in 95 | let typed = Typing.f & Naming.f mx src.defs in 96 | let prog = Erlang.f & Closure.f & Alpha.f & KNormal.f typed in 97 | let outbuf = Buffer.create 128 in 98 | Emit.f src.erl_name outbuf prog; 99 | let outchan = open_out src.erl_path in 100 | Buffer.output_buffer outchan outbuf; 101 | close_out outchan; 102 | register src.mod_name typed; 103 | 104 | if !Config.gen_sig_file then 105 | gen_sig_file src.path typed; 106 | 107 | if not !Config.compile_only then begin 108 | if !Config.escript then 109 | create_exec_file src.erl_path 110 | else 111 | compile_erl_file src.erl_path; 112 | Unix.unlink src.erl_path 113 | end 114 | 115 | let compile_file fpath = 116 | let src = Source.parse fpath in 117 | if not !Config.syntax_only then 118 | compile_file' src 119 | -------------------------------------------------------------------------------- /src/alpha.ml: -------------------------------------------------------------------------------- 1 | (* rename identifiers to make them unique (alpha-conversion) *) 2 | 3 | open KNormal_t 4 | open Base 5 | 6 | let find x ids = try Id.Map.find x ids with Not_found -> x 7 | let genid x ids = if (Id.Map.mem x ids) then Id.genid x else x 8 | let add x y ids = Id.Map.add x y ids 9 | let add_list xs ids = List.fold_left (fun ids x -> add x (genid x ids) ids) ids xs 10 | 11 | let rec h ids (e, t) = 12 | let e' = 13 | match e with 14 | | Bool(b) -> Bool(b) 15 | | Int(i) -> Int(i) 16 | | Float v -> Float v 17 | | Char s -> Char s 18 | | String s -> String s 19 | | Atom s -> Atom s 20 | | Bitstring s -> Bitstring s 21 | | Record(xes) -> Record(List.map (fun (x, e) -> find x ids, (h ids e)) xes) 22 | | Field(e, x) -> Field(h ids e, find x ids) 23 | | Tuple(es) -> Tuple(List.map (h ids) es) 24 | | List(es) -> List(List.map (h ids) es) 25 | | Array(es) -> Array(List.map (h ids) es) 26 | | Var(`Local x) -> Var(`Local (find x ids)) 27 | | Var(`Module x) -> Var(`Module x) 28 | | Concat(e1, e2) -> Concat(h ids e1, h ids e2) 29 | | Constr(x, es) -> 30 | Constr(Binding.of_string & find (Binding.to_string x) ids, 31 | List.map (h ids) es) 32 | | Not(e) -> Not(h ids e) 33 | | And(e1, e2) -> And(h ids e1, h ids e2) 34 | | Or(e1, e2) -> Or(h ids e1, h ids e2) 35 | | Neg(e) -> Neg(h ids e) 36 | | Add(e1, e2) -> Add(h ids e1, h ids e2) 37 | | Sub(e1, e2) -> Sub(h ids e1, h ids e2) 38 | | Mul(e1, e2) -> Mul(h ids e1, h ids e2) 39 | | Div(e1, e2) -> Div(h ids e1, h ids e2) 40 | | Eq(e1, e2) -> Eq(h ids e1, h ids e2) 41 | | LE(e1, e2) -> LE(h ids e1, h ids e2) 42 | | App(e, ys) -> App(h ids e, List.map (h ids) ys) 43 | | ExtFunApp(x, ys) -> ExtFunApp(x, List.map (h ids) ys) 44 | | Get(e1, e2) -> Get(h ids e1, h ids e2) 45 | | Put(e1, e2, e3) -> Put(h ids e1, h ids e2, h ids e3) 46 | in 47 | (e', t) 48 | 49 | let rec pattern ids p = 50 | let open Ast.Pattern in 51 | match p with 52 | | PtUnit -> ids, PtUnit 53 | | PtBool(b) -> ids, (PtBool(b)) 54 | | PtInt(n) -> ids, (PtInt(n)) 55 | | PtFloat v -> ids, PtFloat v 56 | | PtAtom v -> ids, PtAtom v 57 | | PtString v -> ids, PtString v 58 | | PtVar(x, t) -> let x' = genid x ids in (add x x' ids), (PtVar(x', t)) 59 | | PtAlias (p, x, t) -> 60 | let ids', p' = pattern ids p in 61 | let x' = genid x ids' in 62 | add x x' ids, PtAlias (p', x', t) 63 | | PtTuple ps -> fold (fun ps' -> PtTuple ps') pattern ids ps 64 | | PtList ps -> fold (fun ps' -> PtList ps') pattern ids ps 65 | | PtCons (p1, p2) -> 66 | fold_bin (fun p1' p2' -> PtCons (p1', p2')) pattern ids p1 p2 67 | | PtField(xps) -> 68 | fold_assoc (fun xps' -> PtField xps') pattern ids xps 69 | | PtConstr(x, ps) -> 70 | fold (fun ps' -> PtConstr (x, ps')) pattern ids ps 71 | 72 | let rec g ids (e, t) = (* α変換ルーチン本体 (caml2html: alpha_g) *) 73 | let e' = 74 | match e with 75 | | Unit -> Unit 76 | | Exp(e) -> Exp(h ids e) 77 | | If(e, e1, e2) -> If(h ids e, g ids e1, g ids e2) 78 | | Match(x, pes) -> Match(find x ids, List.map (fun (p, e) -> let ids', p' = pattern ids p in p', g ids' e) pes) 79 | | Let((x, t), e1, e2) -> (* letのα変換 (caml2html: alpha_let) *) 80 | let x' = genid x ids in 81 | Let((x', t), g ids e1, g (add x x' ids) e2) 82 | | LetRec({ name = (x, t); args = yts; body = e1 }, e2) -> (* let recのα変換 (caml2html: alpha_letrec) *) 83 | let ids = add x (genid x ids) ids in 84 | let ys = List.map fst yts in 85 | let ids' = add_list ys ids in 86 | LetRec({ name = (find x ids, t); 87 | args = List.map (fun (y, t) -> (find y ids', t)) yts; 88 | body = g ids' e1 }, 89 | g ids e2) 90 | in 91 | (e', t) 92 | 93 | let f = 94 | let f' (ids, defs) = 95 | function 96 | | TypeDef(x, t) -> 97 | (add x (genid x ids) ids), TypeDef(x, t) :: defs 98 | | VarDef((x, t), e) -> 99 | (add x (genid x ids) ids), VarDef((x, t), g ids e) :: defs 100 | | RecDef({ name = (x, t); args = yts; body = e1 }) -> 101 | let ids = add x (genid x ids) ids in 102 | let ys = List.map fst yts in 103 | let ids' = add_list ys ids in 104 | ids, RecDef({ name = (x, t); args = List.map (fun (y, t) -> (find y ids', t)) yts; body = g ids' e1 }) :: defs in 105 | KNormal.fold f' Id.Map.empty 106 | -------------------------------------------------------------------------------- /src/console.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | let bprint_text_of_loc oc fpath loc indent = 4 | let open Printf in 5 | let open Location in 6 | let rec back ic = 7 | match pos_in ic with 8 | | 0 -> () 9 | | orig -> 10 | match input_char ic with 11 | | '\r' | '\n' -> () 12 | | c -> 13 | seek_in ic (orig - 1); 14 | back ic 15 | in 16 | with_ic (open_in fpath) 17 | (fun ic -> 18 | seek_in ic (start_offset loc); 19 | back ic; 20 | let text = input_line ic in 21 | bprintf oc "%s%s\n" (String.make indent ' ') text; 22 | bprintf oc "%s%s\n" (String.make (indent + start_col loc) ' ') 23 | (String.make (end_offset loc - start_offset loc) '^'); 24 | ()) 25 | 26 | let print_error fpath loc msg = 27 | let start_line = Location.start_line loc + 1 in 28 | let end_line = Location.end_line loc + 1 in 29 | let start_col = Location.start_col loc + 1 in 30 | let end_col = Location.end_col loc + 1 in 31 | if start_line = end_line then begin 32 | if start_col = end_col then 33 | Printf.printf "File \"%s\", line %d, characters %d:\n" 34 | fpath start_line start_col 35 | else 36 | Printf.printf "File \"%s\", line %d, characters %d-%d:\n" 37 | fpath start_line start_col end_col 38 | end 39 | else 40 | Printf.printf "File \"%s\", between line and characters %d:%d-%d:%d:\n" 41 | fpath start_line start_col end_line end_col; 42 | Log.error "%s\n" msg; 43 | exit 1 44 | 45 | let bprint_type_error oc fpath t1 t2 = 46 | let open Printf in 47 | let print_type oc t = 48 | let (sl1, sc1, el1, ec1) = Location.values1 t.With.Loc.tag in 49 | let lc = sprintf "(%d:%d-%d:%d)" sl1 sc1 el1 ec1 in 50 | let name = Type.to_repr t in 51 | bprintf oc " %s %s" 52 | (lc ^ (String.make (String.length lc mod 4) ' ')) 53 | (name ^ (String.make (String.length name mod 4) ' ')) 54 | in 55 | print_type oc t2; 56 | bprintf oc " <- actual type\n\n"; 57 | bprint_text_of_loc oc fpath t2.tag 4; 58 | bprintf oc "\n"; 59 | print_type oc t1; 60 | bprintf oc " <- expected type\n\n"; 61 | bprint_text_of_loc oc fpath t1.tag 4 62 | 63 | let print_exc fpath e = 64 | let open Printf in 65 | match e with 66 | | Lexer.Error (loc, msg) -> print_error fpath loc msg 67 | | Sig.Error (loc, msg) -> print_error fpath loc msg 68 | | Ast_t.Syntax_error (loc, None) -> 69 | print_error fpath loc "Syntax error" 70 | | Ast_t.Syntax_error (loc, Some msg) -> 71 | print_error fpath loc ("Syntax error: " ^ msg) 72 | | Ast_t.Unbound_value_error (loc, x) -> 73 | (* deprecated *) 74 | print_error fpath loc ("Unbound value `" ^ x ^ "'") 75 | | Ast_t.Unbound_module_error (loc, x) -> 76 | (* deprecated *) 77 | print_error fpath loc ("Unbound module `" ^ x ^ "'") 78 | | Naming.Unbound_value_error (loc, x, []) -> 79 | print_error fpath loc ("Unbound value `" ^ x ^ "'") 80 | | Naming.Unbound_value_error (loc, x, suggests) -> 81 | print_error fpath loc 82 | (sprintf "Unbound value `%s'. Did you mean %s?" x 83 | (String.concat ", " suggests)) 84 | | Naming.Unbound_constr_error (loc, x, []) -> 85 | print_error fpath loc ("Unbound constructor `" ^ x ^ "'") 86 | | Naming.Unbound_constr_error (loc, x, suggests) -> 87 | print_error fpath loc 88 | (sprintf "Unbound constructor `%s'. Did you mean %s?" x 89 | (String.concat ", " suggests)) 90 | | Naming.Unbound_module_error (loc, x, []) -> 91 | print_error fpath loc ("Unbound module `" ^ x ^ "'") 92 | | Naming.Unbound_module_error (loc, x, suggests) -> 93 | print_error fpath loc 94 | (sprintf "Unbound module `%s'. Did you mean %s?" x 95 | (String.concat ", " suggests)) 96 | | Typing.Invalid_constr_arguments (loc, x, ex, ac) -> 97 | print_error fpath loc 98 | (sprintf "The constructor `%s' expects %d argument(s), but is applied here to %d argument(s)" (Binding.name x) ex ac) 99 | | Typing.Error (e, t1, t2) -> 100 | let oc = Buffer.create 16 in 101 | bprintf oc "Type mismatch: This expression has type `%s', but the expression was expected of type `%s'\n\n" 102 | (Type.to_repr t2) (Type.to_repr t1); 103 | bprint_type_error oc fpath t1 t2; 104 | print_error fpath e.tag (Buffer.contents oc) 105 | | Typing.Topdef_error ((x, t), t1, t2) -> 106 | let oc = Buffer.create 16 in 107 | bprintf oc "Type mismatch: The argument of function `%s':(%s) should be `%s' instead of `%s'\n\n" 108 | x (Type.to_repr t) (Type.to_repr t1) (Type.to_repr t2); 109 | bprint_type_error oc fpath t1 t2; 110 | print_error fpath t2.tag (Buffer.contents oc) 111 | | e -> raise e 112 | -------------------------------------------------------------------------------- /src/naming.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open With.Loc 3 | open Ast_t 4 | 5 | exception Unbound_value_error of Location.t * Id.t * Id.t list 6 | exception Unbound_constr_error of Location.t * Id.t * Id.t list 7 | exception Unbound_module_error of Location.t * Id.t * Id.t list 8 | 9 | let find_module env loc mx = 10 | (* TODO: nested module *) 11 | match Library.find_module_opt mx with 12 | | Some m -> m 13 | | None -> 14 | match Sig.load_module mx with 15 | | `Error -> raise (Unbound_module_error (loc, Binding.to_string mx, [])) 16 | | `Ok -> Library.find_module mx 17 | 18 | let find_val env loc path = 19 | match Binding.path_name path with 20 | | None, name -> 21 | begin match Env.find_module_of_val_opt env name with 22 | | Some m -> 23 | `Module (Binding.add (Module.path m) name, Module.find_val m name) 24 | | None -> 25 | begin match Env.find_var_opt env name with 26 | | None -> `Not_found name 27 | | Some t -> `Local (name, t) 28 | end 29 | end 30 | | Some path, name -> 31 | let m = find_module env loc path in 32 | match Module.find_val_opt m name with 33 | | None -> `Not_found name 34 | | Some t -> `Module (Binding.add (Module.path m) name, t) 35 | 36 | let rec resolve_ptn mx env p = 37 | let open Ast.Pattern in 38 | let f = resolve_ptn mx in 39 | let env', p' = 40 | match p.desc with 41 | | PtUnit | PtBool _ | PtInt _ | PtFloat _ | PtAtom _ | PtString _ -> 42 | env, p.desc 43 | | PtVar (x, t) -> Env.add_var env x t, p.desc 44 | | PtAlias (p, x, t) -> 45 | let env', p' = resolve_ptn mx env p in 46 | Env.add_var env' x t, PtAlias (p', x, t) 47 | | PtTuple ps -> fold (fun ps -> PtTuple ps) f env ps 48 | | PtList ps -> fold (fun ps -> PtList ps) f env ps 49 | | PtCons (p1, p2) -> fold_bin (fun p1 p2 -> PtCons (p1, p2)) f env p1 p2 50 | | PtConstr (x, ps, _) -> 51 | begin match find_val env p.tag x with 52 | | `Not_found name -> raise (Unbound_constr_error (p.tag, name, [])) 53 | | `Local (name, t) -> 54 | fold (fun ps -> PtConstr (Binding.add mx name, ps, t)) f env ps 55 | | `Module (x', t) -> 56 | fold (fun ps -> PtConstr (x', ps, t)) f env ps 57 | end 58 | | _ -> 59 | Printf.printf "%s\n" (Ast.Pattern.to_string p); 60 | failwith "not implemented" 61 | in 62 | env', set p p' 63 | 64 | let rec resolve mx env { tag = loc; desc = (e, t) } = 65 | Log.debug "# Naming.resolve : %s\n" (Ast.string_of_expr e); 66 | let f = resolve mx env in 67 | let map = List.map f in 68 | let e', t' = 69 | match e with 70 | | Unit | Bool _ | Int _ | Float _ | Char _ | String _ | Atom _ | Bitstring _ -> e, t 71 | | Match (e1, ptns) -> 72 | Match (f e1, List.map 73 | (fun (p, e) -> 74 | let env', p' = resolve_ptn mx env p in 75 | let e' = resolve mx env' e in 76 | p', e') ptns), t 77 | | Var (`Unbound x) -> 78 | begin match find_val env loc x with 79 | | `Not_found name -> raise (Unbound_value_error (loc, name, [])) 80 | | `Local (name, t') -> Var (`Local name), t' 81 | | `Module (x', t') -> Var (`Module x'), t' 82 | end 83 | | Var (`Local _) | Var (`Module _) -> e, t 84 | | Constr (x, es) -> 85 | begin match find_val env loc x with 86 | | `Not_found name -> raise (Unbound_constr_error (loc, name, [])) 87 | | `Local (name, t') -> 88 | Constr (Binding.add mx name, map es), t' 89 | | `Module (x', t') -> Constr (x', map es), t' 90 | end 91 | | List es -> List (map es), t 92 | | Tuple es -> Tuple (map es), t 93 | | Array es -> Array (map es), t 94 | | Not e -> Not (f e), t 95 | | Neg e -> Neg (f e), t 96 | | And (e1, e2) -> And (f e1, f e2), t 97 | | Or (e1, e2) -> Or (f e1, f e2), t 98 | | Add (e1, e2) -> Add (f e1, f e2), t 99 | | Sub (e1, e2) -> Sub (f e1, f e2), t 100 | | Mul (e1, e2) -> Mul (f e1, f e2), t 101 | | Div (e1, e2) -> Div (f e1, f e2), t 102 | | Eq (e1, e2) -> Eq (f e1, f e2), t 103 | | LE (e1, e2) -> LE (f e1, f e2), t 104 | | Concat (e1, e2) -> Concat (f e1, f e2), t 105 | | If (e1, e2, e3) -> If (f e1, f e2, f e3), t 106 | | Get (e1, e2) -> Get (f e1, f e2), t 107 | | Put (e1, e2, e3) -> Put (f e1, f e2, f e3), t 108 | | Record xes -> Record (List.map (fun (x, e) -> (x, f e)) xes), t 109 | | Field (e, x) -> Field (f e, x), t 110 | | LetVar ((x, t), e1, e2) -> 111 | let env' = Env.add_var env x t in 112 | LetVar ((x, t), f e1, resolve mx env' e2), t 113 | | LetRec ({ name = xt; args = yts; body = e1 }, e2) -> 114 | let env' = Env.add_vars env yts in 115 | LetRec ({ name = xt; args = yts; body = resolve mx env' e1 }, f e2), t 116 | | App (e, es) -> App (f e, map es), t 117 | | Perform e -> Perform (f e), t 118 | | Bind (xt, e) -> Bind (xt, f e), t 119 | | Return e -> Return (f e), t 120 | in 121 | create loc (e', t') 122 | 123 | let resolve_def mx env def = 124 | Log.debug "# Naming.resolve_def: %s\n" (Ast.string_of_def def); 125 | set def & match def.desc with 126 | | TypeDef _ -> def.desc 127 | | VarDef (xt, et) -> VarDef (xt, resolve mx env et) 128 | | RecDef({ name = (x, ty_f); args = yts; body = et } as f) -> 129 | let env' = Env.add_vars env yts in 130 | RecDef { f with body = resolve mx env' et } 131 | | _ -> assert false 132 | 133 | let f mx defs = 134 | Ast.fold 135 | (fun (env, defs) def -> resolve_def mx env def :: defs) 136 | defs (Sig.create_env ()) 137 | -------------------------------------------------------------------------------- /src/OMakefile: -------------------------------------------------------------------------------- 1 | ######################################################################## 2 | # Permission is hereby granted, free of charge, to any person 3 | # obtaining a copy of this file, to deal in the File without 4 | # restriction, including without limitation the rights to use, 5 | # copy, modify, merge, publish, distribute, sublicense, and/or 6 | # sell copies of the File, and to permit persons to whom the 7 | # File is furnished to do so, subject to the following condition: 8 | # 9 | # THE FILE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 10 | # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 11 | # OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 12 | # IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, 13 | # DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR 14 | # OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE FILE OR 15 | # THE USE OR OTHER DEALINGS IN THE FILE. 16 | 17 | ######################################################################## 18 | # The standard OMakefile. 19 | # You will usually need to modify this file for your project. 20 | 21 | # Delete this line once you have configured this file 22 | 23 | ######################################################################## 24 | # Phony targets are scoped, so you probably want to declare them first. 25 | # 26 | 27 | .PHONY: all install clean 28 | 29 | ######################################################################## 30 | # Subdirectories. 31 | # You may want to include some subdirectories in this project. 32 | # If so, define the subdirectory targets and uncomment this section. 33 | # 34 | 35 | # .SUBDIRS: 36 | 37 | ######################################################################## 38 | # C configuration. 39 | # Delete this section if you are not building C files. 40 | # 41 | 42 | ################################################ 43 | # Configuration. You might want to modify any of these 44 | # configuration variables. 45 | # 46 | 47 | # CFLAGS += 48 | # ASFLAGS += 49 | # LDFLAGS += 50 | # INCLUDES += 51 | 52 | ################################################ 53 | # Uncomment the following section if you want 54 | # to build a C program in the current directory. 55 | # 56 | 57 | # CFILES[] = 58 | # file1 59 | # main 60 | # 61 | # MAIN = main 62 | # 63 | # .DEFAULT: $(CProgram $(MAIN), $(CFILES)) 64 | 65 | ################################################ 66 | # Uncomment the following section if you want to build a C library 67 | # in the current directory. 68 | # 69 | 70 | # LIBFILES[] = 71 | # file1 72 | # file2 73 | # 74 | # LIB = libxxx 75 | # 76 | # .DEFAULT: $(StaticCLibrary $(LIB), $(LIBFILES)) 77 | 78 | ######################################################################## 79 | # OCaml configuration. 80 | # Delete this section if you are not building OCaml files. 81 | # 82 | 83 | ################################################ 84 | # Configuration. You may want to modify any of these configuration 85 | # variables. 86 | # 87 | 88 | # 89 | # This project requires ocamlfind (default - false). 90 | # 91 | USE_OCAMLFIND = true 92 | # 93 | # OCAMLPACKS[] = 94 | # pack1 95 | # pack2 96 | # 97 | # if $(not $(OCAMLFIND_EXISTS)) 98 | # eprintln(This project requires ocamlfind, but is was not found.) 99 | # eprintln(You need to install ocamlfind and run "omake --configure".) 100 | # exit 1 101 | 102 | # 103 | # Include path 104 | # 105 | # OCAMLINCLUDES += 106 | 107 | # 108 | # Compile native or byte code? 109 | # 110 | # The default values are defined as follows: 111 | # 112 | # NATIVE_ENABLED = $(OCAMLOPT_EXISTS) 113 | # BYTE_ENABLED = $(not $(OCAMLOPT_EXISTS)) 114 | 115 | # 116 | # Various options 117 | # 118 | # OCAMLFLAGS += 119 | # OCAMLCFLAGS += 120 | # OCAMLOPTFLAGS += 121 | # OCAML_LINK_FLAGS += 122 | # OCAML_BYTE_LINK_FLAGS += 123 | # OCAML_NATIVE_LINK_FLAGS += 124 | 125 | ################################################ 126 | # Generated files 127 | # 128 | # Workaround for the fact that ocamldep does not pay attention to .mll 129 | # and .mly files. 130 | # 131 | OCamlGeneratedFiles(parser.ml lexer.ml) 132 | 133 | ################################################ 134 | # Build an OCaml library 135 | # 136 | 137 | # FILES[] = 138 | # file1 139 | # file2 140 | # 141 | # LIB = main 142 | # 143 | # .DEFAULT: $(OCamlLibrary $(LIB), $(FILES)) 144 | 145 | ################################################ 146 | # Build an OCaml program 147 | # 148 | 149 | OCAMLFLAGS += -g -thread -w A-4-9-27-40-42-44-45-48 -warn-error A 150 | 151 | MENHIR_FLAGS += -v 152 | MENHIR_ENABLED = true 153 | 154 | FILES[] = 155 | alpha 156 | ast 157 | ast_t 158 | base 159 | #beta 160 | binding 161 | bitstring 162 | closure 163 | closure_t 164 | compiler 165 | config 166 | console 167 | emit 168 | env 169 | erlang 170 | erlang_t 171 | id 172 | intRepr 173 | kNormal 174 | kNormal_t 175 | lexer 176 | library 177 | location 178 | log 179 | main 180 | module 181 | naming 182 | parser 183 | position 184 | sig 185 | source 186 | tagging 187 | type 188 | type_t 189 | typing 190 | utils 191 | version 192 | xbase 193 | xlist 194 | xmap 195 | xset 196 | xstring 197 | with 198 | 199 | BINDIR = ../bin 200 | PROGRAM = bran 201 | 202 | # OCAML_LIBS += 203 | # OCAML_CLIBS += 204 | # OCAML_OTHER_LIBS += 205 | # OCAML_LIB_FLAGS += 206 | # 207 | 208 | OCAMLPACKS[] += 209 | unix 210 | spotlib 211 | 212 | 213 | all: $(OCamlProgram $(PROGRAM), $(FILES)) 214 | mkdir -p $(BINDIR) 215 | cp $(PROGRAM) $(BINDIR)/$(PROGRAM) 216 | 217 | .DEFAULT: all 218 | 219 | # omake xxx.auto.mli creates the mli file from xxx.ml automatically 220 | %.auto.mli: %.ml 221 | $(OCamlC) -i -c $< > $@ 222 | 223 | clean: 224 | rm -rf *.cm* *.o *.opt *.automaton parser.ml parser.mli lexer.ml $(PROGRAM) $(BINDIR) 225 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Bran 2 | ==== 3 | 4 | [![Circle CI](https://circleci.com/gh/szktty/bran.png?style=badge)](https://circleci.com/gh/szktty/bran) 5 | 6 | A strongly-typed language with type inference running on Erlang VM, influenced by OCaml. 7 | 8 | 9 | ## Requirements 10 | 11 | ### For usage 12 | 13 | - Erlang/OTP 17.3 14 | 15 | ### For build 16 | 17 | - OCaml 4.02.1 18 | - Menhir 20140422 19 | - Spotlib 2.5.0 20 | - OMake 0.9.8.6-0.rc1 21 | 22 | ## For test 23 | 24 | - OUnit2 2.0.0 25 | 26 | 27 | ## Building from source 28 | 29 | ``` 30 | $ omake 31 | ``` 32 | 33 | ## Installation 34 | 35 | 1. Execute `make` at `liberl` directory to compile Erlang sources used by compiled Bran modules. 36 | 37 | ``` 38 | $ cd liberl 39 | $ make 40 | ``` 41 | 42 | 2. Copy this directory or create a symbolic link to installation destination. 43 | 44 | ``` 45 | $ ln -s /home/yourname/bran /opt/local/bran 46 | ``` 47 | 48 | 3. Add path of the `bin` directory to command line path. (environment variable `PATH`, etc.) 49 | 50 | ``` 51 | # .bashrc, etc. 52 | export PATH=/opt/local/bran/bin:$PATH 53 | ``` 54 | 55 | 4. Set environment variable `BRAN_LIBS` to the `lib` directory including signature files of Bran. 56 | 57 | ``` 58 | # .bashrc, etc. 59 | export BRAN_LIBS=/opt/local/bran/lib 60 | ``` 61 | 62 | 5. Add path of the `liberl/ebin` directory, including Erlang modules, to environment variable `ERL_LIBS`. 63 | 64 | ``` 65 | # .bashrc, etc. 66 | export ERL_LIBS=/opt/local/bran/liberl/ebin:$ERL_LIBS 67 | ``` 68 | 69 | 6. OK, let's try `bran` command. 70 | 71 | ``` 72 | $ bran 73 | ``` 74 | 75 | ## Usage 76 | 77 | ``` 78 | # compile 79 | $ ./bran fib.br 80 | 81 | # use as Erlang module 82 | $ erl 83 | ... 84 | 1> fib:fib(10). 85 | 89 86 | ``` 87 | 88 | ## ToDo 89 | 90 | - Data types 91 | - Map 92 | - Option 93 | - Reference 94 | - Exception 95 | - Binary 96 | - Process 97 | - Type system 98 | - Records 99 | - Variants 100 | - Polymorphic type 101 | - Syntax 102 | - Pattern matching 103 | - Exception handling 104 | - Labeled arguments and optional arguments 105 | - Message passing 106 | - Compilation 107 | - Optimization 108 | - Executable file generation (escript) 109 | - Library 110 | - Standard library 111 | - `Obj` module 112 | - OTP 113 | - Tools 114 | - Interactive shell 115 | - Source browsing support 116 | - Build tool support (rebar) 117 | - Build 118 | - Installation 119 | - Using packaging tools (OPAM, etc.) 120 | 121 | ## Syntax 122 | 123 | ### Files 124 | 125 | - `.bri` (interface file) 126 | - `.br` (implementation file) 127 | 128 | ### Data Types 129 | 130 | - unit 131 | - bool 132 | - int 133 | - float 134 | - char 135 | - string 136 | - list (empty lists must be specified type. for example: `([] : int list)`) 137 | - bitstring 138 | 139 | ### Comment 140 | 141 | ``` 142 | # comment 143 | ``` 144 | 145 | ### Literals 146 | 147 | #### Atom 148 | 149 | ``` 150 | @atom 151 | @Atom 152 | @atom_ok 153 | @Atom_ok 154 | @"atom" 155 | @"a t o m" 156 | @"*a+t-o/m!?* :-@" 157 | ``` 158 | 159 | #### String 160 | 161 | - On Bran, String is **not** a list of character type data. `string` and `char list` are different types. 162 | - Escape sequences are the same as one of Erlang. 163 | 164 | ``` 165 | "string" 166 | "42" 167 | "hello, world!\n" 168 | "\052" 169 | "\x00\xff" 170 | ``` 171 | 172 | #### Character 173 | 174 | - Character literals are single quote characters. 175 | 176 | ``` 177 | '0' 178 | 'a' 179 | 'Z' 180 | '\n' 181 | '\052' 182 | '\xff' 183 | ``` 184 | 185 | #### Bitstring 186 | 187 | Basically bitstring syntax is the same as one of Erlang. See [Bit Syntax Expressions](http://www.erlang.org/doc/reference_manual/expressions.html#bit_syntax). 188 | 189 | ``` 190 | <<42>> 191 | <<"abc">> 192 | <<1,17,42:16>> 193 | <<123/int-native>> 194 | <<123/unsigned-big-integer>> 195 | <"abc"/utf8>> 196 | ``` 197 | 198 | #### Integer 199 | 200 | - Erlang's `base#value` is `base r value` (ex. 16rff). Because `#` is used by comment in Bran. 201 | - Integer has any number of digits. 202 | 203 | ``` 204 | 42 205 | 042 # -> 42 206 | 2r101 207 | 16r1f 208 | ``` 209 | 210 | #### Float 211 | 212 | ``` 213 | 2.3 214 | 2.3e3 215 | 2.3e-3 216 | 7.000e+00 217 | ``` 218 | 219 | #### List 220 | 221 | ``` 222 | [] 223 | [1] 224 | [1, 2, 3] 225 | [1, 2, 3,] 226 | ``` 227 | 228 | #### Tuple 229 | 230 | ``` 231 | (1, "a") 232 | ``` 233 | 234 | #### Array 235 | 236 | ``` 237 | [||] 238 | [|1|] 239 | [|1, 2, 3|] 240 | [|1, 2, 3,|] 241 | ``` 242 | 243 | ### Variable bindings 244 | 245 | ``` 246 | var x = 1 247 | ``` 248 | 249 | ### Function 250 | 251 | #### Definition 252 | 253 | ``` 254 | # Top level 255 | def [rec] f x ... = [block] 256 | 257 | # Local 258 | def [rec] f x ... = [block] in ... 259 | 260 | # Circular reference 261 | def [rec] f x ... = ... 262 | and f x ... = ... 263 | ``` 264 | 265 | Top level definition starts at start of line. 266 | 267 | ``` 268 | def f x y = x + y 269 | ``` 270 | 271 | In function definition, definition must be indented and end with `in`. 272 | Indent size must be spaces more than one. 273 | 274 | ``` 275 | def f x = 276 | def f' x' = 277 | ... 278 | in 279 | f' x 280 | ``` 281 | 282 | signature (`.bri`): 283 | 284 | ``` 285 | def f : int -> int -> int 286 | ``` 287 | 288 | #### Call 289 | 290 | ``` 291 | f x y # Call function "f" with "x" and "y" arguments 292 | f x $ g y z # => f x (g y z) Haskell's "$" 293 | ``` 294 | 295 | 296 | ### External functions 297 | 298 | `.bri`: 299 | 300 | ``` 301 | external print_bool : bool -> unit = "bran_lib_pervasives:print_bool" 302 | ``` 303 | 304 | ### Calling Erlang functions 305 | 306 | use `Erlang.eval : string -> string`. 307 | 308 | ``` 309 | var result = Erlang.eval "ok." 310 | ``` 311 | 312 | ### Conditional 313 | 314 | Conditional expression syntax is: 315 | 316 | ``` 317 | if [bool-exp] then [block] end 318 | if [bool-exp] then [block] else [block] end 319 | if [bool-exp] then [simple-exp] else [simple-exp] 320 | ``` 321 | 322 | "`end`" can be omitted when blocks have only an simple expression (literals, field access, array access, type constructor with no arguments and expression with parentheses). 323 | 324 | Examples: 325 | 326 | ``` 327 | if x then 328 | print_string "true" 329 | true 330 | end 331 | 332 | if x then 333 | print_string "true" 334 | true 335 | else 336 | print_string "false" 337 | false 338 | end 339 | 340 | if x then true else false 341 | 342 | if x then true 343 | else false 344 | 345 | if x then 346 | true 347 | else 348 | false 349 | ``` 350 | 351 | ### Loop 352 | 353 | ``` 354 | for i = 1 to max do 355 | ... 356 | end 357 | ``` 358 | 359 | ### Exception handling 360 | 361 | ``` 362 | try [exp] with [pattern] end 363 | ``` 364 | 365 | Example: 366 | 367 | ``` 368 | try 369 | ... 370 | with 371 | | Not_found -> ... 372 | | e -> raise e 373 | end 374 | ``` 375 | 376 | ### Monad 377 | 378 | ``` 379 | perform 380 | x1 <- action1 381 | x2 <- action2 382 | action3 x1 x2 383 | return x1 384 | end 385 | ``` 386 | -------------------------------------------------------------------------------- /src/ast.ml: -------------------------------------------------------------------------------- 1 | open Ast_t 2 | open Base 3 | 4 | let rec string_of_pattern { With.Loc.desc = p } = 5 | match p with 6 | | PtUnit -> "PtUnit" 7 | | PtBool(b) -> "PtBool(" ^ (string_of_bool b) ^ ")" 8 | | PtInt (b, v) -> Printf.sprintf "PtInt(%d, %s)" b v 9 | | PtFloat v -> Printf.sprintf "PtFloat(%f)" v 10 | | PtAtom(v) -> "PtAtom(" ^ v ^ ")" 11 | | PtString(v) -> "PtString(" ^ v ^ ")" 12 | | PtVar(x, t) -> "PtVar(" ^ x ^ "," ^ (Type.to_string t) ^ ")" 13 | | PtAlias (p, x, t) -> 14 | Printf.sprintf "PtAlias(%s, %s, %s)" (string_of_pattern p) x (Type.to_string t) 15 | | PtTuple(ps) -> "PtTuple(" ^ (String.concat_map "; " string_of_pattern ps) ^ ")" 16 | | PtList(ps) -> "PtList([" ^ (String.concat_map "; " string_of_pattern ps) ^ "])" 17 | | PtCons (p1, p2) -> 18 | Printf.sprintf "PtCons(%s, %s)" (string_of_pattern p1) (string_of_pattern p2) 19 | | PtRecord(xps) -> "PtRecord([" ^ (String.concat "; " (List.map (fun (x, p) -> x ^ ", " ^ (string_of_pattern p)) xps)) ^ "])" 20 | | PtConstr(x, ps, t) -> 21 | Printf.sprintf "PtConstr(%s, [%s], %s)" 22 | (Binding.to_string x) 23 | (String.concat_map "; " string_of_pattern ps) 24 | (Type.to_string t) 25 | 26 | let rec string_of_typed_expr { With.Loc.desc = (e, t) } = 27 | (string_of_expr e) ^ " : " ^ (Type.to_string t) 28 | 29 | and string_of_expr = 30 | function 31 | | Unit -> "Unit" 32 | | Bool(b) -> "Bool(" ^ (string_of_bool b) ^ ")" 33 | | Int (b, v) -> Printf.sprintf "Int(%d, %s)" b v 34 | | Float v -> "Float(" ^ (string_of_float v) ^ ")" 35 | | Char s -> "Char(" ^ s ^ ")" 36 | | String s -> "String(" ^ s ^ ")" 37 | | Atom s -> "Atom(" ^ s ^ ")" 38 | | Bitstring x -> "Bitstring(" ^ (Bitstring.to_string x) ^ ")" 39 | | Record(xs) -> "Record(" ^ (String.concat_map "; " (fun (x, e) -> x ^ " = " ^ (string_of_typed_expr e)) xs) ^ ")" 40 | | Field(e, x) -> "Field(" ^ (string_of_typed_expr e) ^ ", " ^ x ^ ")" 41 | | List(es) -> "List([" ^ (String.concat "; " (List.map string_of_typed_expr es)) ^ "])" 42 | | Tuple(es) -> "Tuple([" ^ (String.concat "; " (List.map string_of_typed_expr es)) ^ "])" 43 | | Array(es) -> "Array([" ^ (String.concat "; " (List.map string_of_typed_expr es)) ^ "])" 44 | | Not(e) -> "Not(" ^ (string_of_typed_expr e) ^ ")" 45 | | And(e1, e2) -> "And(" ^ (string_of_typed_expr e1) ^ ", " ^ (string_of_typed_expr e2) ^ ")" 46 | | Or(e1, e2) -> "Or(" ^ (string_of_typed_expr e1) ^ ", " ^ (string_of_typed_expr e2) ^ ")" 47 | | Neg(e) -> "Neg(" ^ (string_of_typed_expr e) ^ ")" 48 | | Add(e1, e2) -> "Add(" ^ (string_of_typed_expr e1) ^ ", " ^ (string_of_typed_expr e2) ^ ")" 49 | | Sub(e1, e2) -> "Sub(" ^ (string_of_typed_expr e1) ^ ", " ^ (string_of_typed_expr e2) ^ ")" 50 | | Mul(e1, e2) -> "Mul(" ^ (string_of_typed_expr e1) ^ ", " ^ (string_of_typed_expr e2) ^ ")" 51 | | Div(e1, e2) -> "Div(" ^ (string_of_typed_expr e1) ^ ", " ^ (string_of_typed_expr e2) ^ ")" 52 | | Eq(e1, e2) -> "Eq(" ^ (string_of_typed_expr e1) ^ ", " ^ (string_of_typed_expr e2) ^ ")" 53 | | LE(e1, e2) -> "LE(" ^ (string_of_typed_expr e1) ^ ", " ^ (string_of_typed_expr e2) ^ ")" 54 | | If(e1, e2, e3) -> "If(" ^ (string_of_typed_expr e1) ^ " then " ^ (string_of_typed_expr e2) ^ " else " ^ (string_of_typed_expr e3) ^ ")" 55 | | Match(e, pes) -> "Match(" ^ (string_of_typed_expr e) ^ ", [" ^ (String.concat "; " (List.map (fun (p, e) -> (string_of_pattern p) ^ " -> " ^ (string_of_typed_expr e)) pes)) ^ "])" 56 | | LetVar((x, t), e1, e2) -> "LetVar(" ^ x ^ " : " ^ (Type.to_string t) ^ " = " ^ (string_of_typed_expr e1) ^ " in " ^ (string_of_typed_expr e2) ^ ")" 57 | | Var (`Unbound x) -> "Var(`Unbound " ^ (Binding.to_string x) ^ ")" 58 | | Var (`Local x) -> "Var(`Local " ^ x ^ ")" 59 | | Var (`Module x) -> "Var(`Module " ^ (Binding.to_string x) ^ ")" 60 | | Concat (e1, e2) -> "Concat(" ^ (string_of_typed_expr e1) ^ ", " ^ (string_of_typed_expr e2) ^ ")" 61 | | Constr(x, es) -> "Constr(" ^ (Binding.to_string x) ^ ", " ^ (String.concat_map ", " string_of_typed_expr es) ^ ")" 62 | | LetRec({ name = (x, t); args = yts; body = e1 }, e2) -> "LetRec(" ^ x ^ "(" ^ (String.concat ", " (List.map (fun (y, t) -> y ^ " : " ^ (Type.to_string t)) yts)) ^ ") : " ^ (Type.to_string t) ^ " = " ^ (string_of_typed_expr e1) ^ " in " ^ (string_of_typed_expr e2) ^ ")" 63 | | App(e, es) -> "App(" ^ (string_of_typed_expr e) ^ ", [" ^ (String.concat ", " (List.map string_of_typed_expr es)) ^ "])" 64 | | Get (e1, e2) -> 65 | Printf.sprintf "Get(%s, %s)" (string_of_typed_expr e1) 66 | (string_of_typed_expr e2) 67 | | Put (e1, e2, e3) -> 68 | Printf.sprintf "Put(%s, %s, %s)" (string_of_typed_expr e1) 69 | (string_of_typed_expr e2) (string_of_typed_expr e3) 70 | | Perform e -> Printf.sprintf "Perform(%s)" (string_of_typed_expr e) 71 | | Bind ((x, t), e) -> 72 | Printf.sprintf "Bind(%s:%s = %s)" x (Type.to_string t) (string_of_typed_expr e) 73 | | Return e -> Printf.sprintf "Return(%s)" (string_of_typed_expr e) 74 | 75 | let string_of_fundef { name = (x, t); args = yts; body = e } = 76 | x ^ " " ^ (String.concat " " (List.map (fun (y, t) -> y) yts)) ^ " : " ^ (Type.to_string t) ^ " = " ^ (string_of_typed_expr e) 77 | 78 | let string_of_sigdef { sig_name = (x, t); sig_ext = ext } = 79 | let typ = Type.to_string t in 80 | match ext with 81 | | None -> Printf.sprintf "%s : %s" x typ 82 | | Some f -> Printf.sprintf "external %s : %s = %s" x typ f 83 | 84 | let string_of_def { With.Loc.desc = def } = 85 | match def with 86 | | Nop -> "Nop" 87 | | TypeDef(x, t) -> "TypeDef(" ^ x ^ ", " ^ (Type.Tycon.to_string t) ^ ")" 88 | | VarDef((x, t), e) -> "VarDef((" ^ x ^ ", " ^ (Type.to_string t) ^ "), " ^ (string_of_typed_expr e) 89 | | RecDef(fundef) -> "RecDef(" ^ (string_of_fundef fundef) ^ ")" 90 | | SigDef(sigdef) -> "SigDef(" ^ (string_of_sigdef sigdef) ^ ")" 91 | 92 | let fold f defs env = 93 | let _, defs' = 94 | List.fold_left 95 | (fun ({ Env.venv = venv; tenv = tenv; tycons = tycons; mods = mods } as env, defs) def -> 96 | match With.Loc.desc def with 97 | | TypeDef(x, t) -> 98 | { Env.venv = Id.Map.add_alist (Type.Tycon.vars t) venv; 99 | Env.tenv = Id.Map.add_alist (Type.Tycon.types t) tenv; 100 | Env.tycons = Id.Map.add x t tycons; 101 | Env.mods = mods }, 102 | f (env, defs) def 103 | | VarDef((x, t), e) -> 104 | Env.add_var env x t, f (env, defs) def 105 | | RecDef({ name = (x, ty_f); args = yts; body = e }) -> 106 | let env' = { env with Env.venv = Id.Map.add_alist yts (Id.Map.add x ty_f venv) } in 107 | { env with Env.venv = Id.Map.add x ty_f venv }, f (env', defs) def 108 | | _ -> assert false) 109 | (env, []) defs in 110 | List.rev defs' 111 | 112 | module Pattern = struct 113 | 114 | type t = pattern 115 | 116 | let to_string = string_of_pattern 117 | 118 | let fold ret f env es = 119 | let env', es' = 120 | List.fold_left 121 | (fun (env, accu) e -> 122 | let env', e' = f env e in 123 | env', e' :: accu) 124 | (env, []) es 125 | in 126 | env', ret & List.rev es' 127 | 128 | let fold_bin ret f env e1 e2 = 129 | fold (fun es -> ret (List.nth es 0) (List.nth es 1)) f env [e1; e2] 130 | 131 | let fold_assoc ret f env es = 132 | let env', es' = 133 | List.fold_left 134 | (fun (env, accu) (k, v) -> 135 | let env', v' = f env v in 136 | env', (k, v') :: accu) 137 | (env, []) es 138 | in 139 | env', ret & List.rev es' 140 | 141 | end 142 | -------------------------------------------------------------------------------- /src/type.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Type_t 3 | 4 | type t = Type_t.t 5 | 6 | let counter = ref 0 7 | 8 | let newtyvar () = 9 | let base = Char.code 'z' - Char.code 'a' + 1 in 10 | let q = !counter / base in 11 | let m = !counter mod base in 12 | incr counter; 13 | Printf.sprintf "%c%s" (Char.chr & Char.code 'a' + m) 14 | (if q > 0 then string_of_int q else "") 15 | 16 | let rec string_of_t reached t = 17 | match With.Loc.desc t with 18 | | Var(v) -> "Var(" ^ v ^ ")" 19 | | Field(tid, t) -> "Field(" ^ (string_of_t reached tid) ^ ", " ^ (string_of_t reached t) ^ ")" 20 | | App(tycon, ts) -> "App(" ^ (string_of_tycon reached tycon) ^ ", [" ^ (String.concat ", " (List.map (string_of_t reached) ts)) ^ "])" 21 | | Poly([], t)-> "Poly([], " ^ (string_of_t reached t) ^ ")" 22 | | Poly(xs, t)-> "Poly(" ^ (String.concat ", " xs) ^ ", " ^ (string_of_t reached t) ^ ")" 23 | | Meta{ contents = Some(t) } -> "Meta(Some(" ^ (string_of_t reached t) ^ "))" 24 | | Meta{ contents = None } -> "Meta(None)" 25 | 26 | and string_of_tycon reached = 27 | function 28 | | Unit -> "Unit" 29 | | Bool -> "Bool" 30 | | Int -> "Int" 31 | | Float -> "Float" 32 | | Char -> "Char" 33 | | String -> "String" 34 | | Atom -> "Atom" 35 | | Bitstring -> "Bitstring" 36 | | Binary -> "Binary" 37 | | Arrow -> "Arrow" 38 | | List -> "List" 39 | | Tuple -> "Tuple" 40 | | Array -> "Array" 41 | | Module x -> "Module(" ^ x ^ ")" 42 | | Record(x, fs) -> "Record(" ^ x ^ ", {" ^ (String.concat ", " fs) ^ "})" 43 | | Variant(x, constrs) when Id.Set.mem x reached -> "Variant(" ^ x ^ ")" 44 | | Variant(x, constrs) -> "Variant(" ^ x ^ ", [" ^ (String.concat " | " (List.map (string_of_constr (Id.Set.add x reached)) constrs)) ^ "])" 45 | | TyFun(xs, t) -> 46 | Printf.sprintf "TyFun([%s], %s)" (String.concat ", " xs) (string_of_t reached t) 47 | | Instance (xts, t) -> 48 | Printf.sprintf "Instance([%s], %s)" 49 | (String.concat ", " 50 | (List.map (fun (x, t) -> 51 | Printf.sprintf "('%s, %s)" x (string_of_t reached t)) xts)) 52 | (string_of_t reached t) 53 | | NameTycon(x, { contents = None }) when Id.Set.mem x reached -> "NameTycon(" ^ x ^ ", None)" 54 | | NameTycon(x, { contents = None }) -> "NameTycon(" ^ x ^ ", None)" 55 | | NameTycon(x, { contents = Some(t) }) -> "NameTycon(" ^ x ^ ", Some(" ^ (string_of_tycon reached t) ^ "))" 56 | 57 | and string_of_constr reached = 58 | function 59 | | (x, []) -> x 60 | | (x, ts) -> x ^ " of " ^ (String.concat " * " (List.map (string_of_t reached) ts)) 61 | 62 | let string_of_t = string_of_t Id.Set.empty 63 | let string_of_tycon = string_of_tycon Id.Set.empty 64 | let string_of_constr = string_of_constr Id.Set.empty 65 | 66 | let rec prefix t = 67 | match With.Loc.desc t with 68 | | Var _ -> "p" 69 | | Field(_, t) -> prefix t 70 | | App(tycon, _) -> prefix_of_tycon tycon 71 | | Poly(_, t) -> prefix t 72 | | _ -> Log.debug "t = %s\n" (string_of_t t); assert false 73 | 74 | and prefix_of_tycon = 75 | function 76 | | Unit -> "u" 77 | | Bool -> "b" 78 | | Int -> "n" 79 | | Float -> "d" 80 | | Char -> "c" 81 | | String -> "s" 82 | | Atom -> "a" 83 | | Bitstring -> "bit" 84 | | Binary-> "bin" 85 | | Arrow -> "pfn" 86 | | List -> "l" 87 | | Tuple -> "t" 88 | | Array -> "y" 89 | | Module _ -> "m" 90 | | Record _ -> "st" 91 | | Variant _ -> "v" 92 | | TyFun(_, t) -> prefix t 93 | | Instance(_, t) -> prefix t 94 | | NameTycon(x, _) -> x 95 | 96 | let rec repr_of t = 97 | match With.Loc.desc t with 98 | | Var x -> "'" ^ x 99 | | Field(_, t) -> repr_of t 100 | | App(Unit, []) -> "unit" 101 | | App(Bool, []) -> "bool" 102 | | App(Int, []) -> "int" 103 | | App(Float, []) -> "float" 104 | | App(Atom, []) -> "atom" 105 | | App(Char, []) -> "char" 106 | | App(String, []) -> "string" 107 | | App(Bitstring, []) -> "bitstring" 108 | | App(Binary, []) -> "binary" 109 | | App(Arrow, xs) -> String.concat " -> " (List.map repr_of xs) 110 | | App(List, []) -> "list" 111 | | App(List, x :: _) -> (repr_of x) ^ " list" 112 | | App(Tuple, xs) -> "(" ^ (String.concat " * " (List.map repr_of xs)) ^ ")" 113 | | App(Module x, []) -> "module type " ^ x 114 | | App(Record(_, xs), ys) -> 115 | Printf.sprintf "{ %s }" 116 | (String.concat_map ", " 117 | (fun (x, y) -> x ^ " : " ^ (repr_of y)) (List.combine xs ys)) 118 | | App(Variant _ as tycon, _) -> repr_of_tycon tycon 119 | | Poly(xs, t) -> repr_of t 120 | | App(TyFun([], t), []) -> repr_of t 121 | | App (Instance ([(_, t1)], t2), _) -> 122 | Printf.sprintf "%s %s" (repr_of t1) (repr_of t2) 123 | | App (Instance (xts, t), _) -> 124 | Printf.sprintf "(%s) %s" 125 | (String.concat_map ", " (fun (_, t) -> repr_of t) xts) 126 | (repr_of t) 127 | | App(NameTycon(x, _), []) -> x 128 | | App(NameTycon(x, _), [t]) -> 129 | Printf.sprintf "%s %s" (repr_of t) x 130 | | App(NameTycon(x, _), ts) -> 131 | Printf.sprintf "(%s) %s" (String.concat ", " (List.map repr_of ts)) x 132 | | Meta { contents = None } -> "[?]" 133 | | Meta { contents = Some t } -> repr_of t 134 | | _ -> Printf.eprintf "%s : not implemented yet." (string_of_t t); assert false 135 | 136 | and repr_of_tycon = function 137 | | Unit -> "unit" 138 | | Bool -> "bool" 139 | | Int -> "int" 140 | | Float -> "float" 141 | | String -> "string" 142 | | TyFun(_, t) -> repr_of t 143 | | Variant (_, xts) -> 144 | String.concat_map " | " 145 | (fun (x, ts) -> 146 | match ts with 147 | | [] -> x 148 | | _ -> x ^ " of " ^ String.concat_map " * " repr_of ts) xts 149 | | t -> Printf.eprintf "%s : not implemented yet\n" (string_of_tycon t); assert false 150 | 151 | let to_string = string_of_t 152 | let to_repr = repr_of 153 | 154 | (* 等値判定。型推論後のみ使用可能。*) 155 | let rec equal t1 t2 = 156 | match With.Loc.desc t1, With.Loc.desc t2 with 157 | | App(Unit, xs), App(Unit, ys) 158 | | App(Bool, xs), App(Bool, ys) 159 | | App(Int, xs), App(Int, ys) 160 | | App(Arrow, xs), App(Arrow, ys) 161 | | App(Tuple, xs), App(Tuple, ys) when List.length xs = List.length ys -> List.for_all2 equal xs ys 162 | | App(Record(x, _), xs), App(Record(y, _), ys) 163 | | App(Variant(x, _), xs), App(Variant(y, _), ys) when List.length xs = List.length ys -> x = y && List.for_all2 equal xs ys 164 | | App(TyFun(xs, u), ys), t2 -> assert false (* inpossible after Typing.f *) 165 | | Poly([], u1), _ -> equal u1 t2 166 | | _, Poly([], u2) -> equal t1 u2 167 | | Poly(xs, u1), Poly(ys, u2) -> xs = ys && equal u1 u2 168 | | Var(x), Var(y) -> true 169 | | Field(_, x), Field(_, y) -> equal x y 170 | | Meta{ contents = Some(t1') }, _ -> equal t1' t2 171 | | Meta(x), Meta{ contents = Some(t2') } -> equal t1 t2' 172 | | Meta(x), Meta(y) when phys_equal x y -> true 173 | | Meta(x), t2 -> assert false (* inpossible after Typing.f *) 174 | | _, Meta(y) -> equal t2 t1 175 | | _, _ -> false 176 | 177 | let app loc tycon args = With.Loc.create loc & App (tycon, args) 178 | let void_app loc tycon = app loc tycon [] 179 | let app_unit loc = With.Loc.create loc (App (Unit, [])) 180 | 181 | module Tycon = struct 182 | 183 | type t = Type_t.tycon 184 | 185 | let to_string = string_of_tycon 186 | let to_repr = repr_of_tycon 187 | 188 | (* 型環境 venv に追加する識別子と型のリスト *) 189 | let vars t = 190 | Log.debug "# Types.vars %s\n" (string_of_tycon t); 191 | match t with 192 | | TyFun (xs, ({ desc = App(Variant(x, constrs), _) } as t)) -> 193 | List.map 194 | (function 195 | | y, [] -> y, With.Loc.create t.tag (Poly(xs, t)) 196 | (*| y, ts -> y, create t.tag (Poly(xs, create t.tag (App(Arrow, ts @ [t])))))*) 197 | | y, ts -> y, With.Loc.create t.tag (Poly(xs, t))) 198 | constrs 199 | | _ -> [] 200 | 201 | (* 型環境 tenv に追加する識別子と型のリスト *) 202 | let types t = 203 | Log.debug "# Types.types %s\n" (string_of_tycon t); 204 | match t with 205 | | TyFun(xs, ({ desc = App(Record(x, fs), ys) } as t)) -> 206 | (List.combine fs (List.map (fun y -> 207 | With.Loc.create t.tag (Poly (xs, With.Loc.create t.tag (Field(t, y))))) ys)) 208 | | _ -> [] 209 | 210 | end 211 | 212 | module Constr = struct 213 | 214 | type t = Type_t.constr 215 | 216 | let to_string = string_of_constr 217 | 218 | end 219 | 220 | module Meta = struct 221 | 222 | let create loc = With.Loc.create loc & Meta (ref None) 223 | 224 | end 225 | -------------------------------------------------------------------------------- /src/lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Lexing 3 | open Parser 4 | open Base 5 | 6 | exception Error of Location.t * string 7 | 8 | let curr = ref { pos_fname = ""; pos_lnum = 0; pos_bol = 0; pos_cnum = 0 } 9 | 10 | let next_line lexbuf = 11 | let pos = lexbuf.lex_curr_p in 12 | curr := { pos with pos_bol = lexbuf.lex_curr_pos; 13 | pos_lnum = pos.pos_lnum + 1 } 14 | 15 | let next_line_in_spaces lexbuf s = 16 | let (_, pos) = 17 | List.fold_left 18 | (fun (cnum, pos) (s, nl) -> 19 | let cnum' = cnum + String.length s + String.length nl in 20 | (cnum', 21 | begin match nl with 22 | | "" -> pos 23 | | _ -> { pos with pos_bol = cnum'; 24 | pos_lnum = pos.pos_lnum + 1 } 25 | end)) 26 | (lexbuf.lex_curr_pos - String.length s, !curr) & String.lines s 27 | in 28 | curr := pos 29 | 30 | let start_pos lexbuf = 31 | let pos = lexeme_start_p lexbuf in 32 | Position.of_lexing_pos 33 | { pos with pos_lnum = !curr.pos_lnum; 34 | pos_bol = pos.pos_cnum - !curr.pos_bol; 35 | pos_cnum = pos.pos_cnum } 36 | 37 | let end_pos lexbuf = 38 | let pos = lexeme_end_p lexbuf in 39 | Position.of_lexing_pos 40 | { pos with pos_lnum = !curr.pos_lnum; 41 | pos_bol = pos.pos_cnum - !curr.pos_bol - 1; 42 | pos_cnum = pos.pos_cnum } 43 | 44 | let to_loc lexbuf = 45 | let l = Location.create (start_pos lexbuf) (end_pos lexbuf) in 46 | (* Printf.printf "# Lexer: %s: \"%s\"\n" (Location.to_string l) (lexeme lexbuf); *) 47 | l 48 | 49 | let to_word lexbuf = 50 | With.Loc.create (to_loc lexbuf) (lexeme lexbuf) 51 | 52 | let strlit_to_word lexbuf read = 53 | With.Loc.create 54 | (Location.create (start_pos lexbuf) (end_pos lexbuf)) 55 | (read (Buffer.create 17) lexbuf) 56 | 57 | let with_word lexbuf s = 58 | With.Loc.create (to_loc lexbuf) s 59 | 60 | } 61 | 62 | let lower = ['a'-'z'] 63 | let upper = ['A'-'Z'] 64 | let hex = '0' ['x' 'X'] 65 | let digit = ['0'-'9'] 66 | let body = (digit|lower|upper|['_' '\''])* 67 | let ident = lower body 68 | let uident = upper body 69 | let octdigit = ['0'-'9'] 70 | let hexdigit = ['0'-'9' 'a'-'f' 'A'-'F'] 71 | let exp = ['e' 'E'] ['-' '+']? digit+ 72 | let float = digit+ '.' digit+ exp? 73 | let white = [' ' '\t']+ 74 | let nl = '\r' | '\n' | "\r\n" 75 | let id = ['a'-'z' 'A'-'Z' '_'] ['a'-'z' 'A'-'Z' '0'-'9' '_']* 76 | let hexstr = hexdigit hexdigit 77 | let octstr = digit? digit? digit? 78 | let escape = '\\' ['\'' '"' '\\' 'b' 'd' 'e' 'f' 'n' 'r' 's' 't' 'v'] 79 | let dqstrchr = escape | [^ '"' '\\' '\r' '\n'] 80 | let sqchr = escape | [^ '\'' '\\' '\r' '\n'] 81 | let octstr = octdigit octdigit? octdigit? 82 | let hexstr = hexdigit hexdigit | '{' hexdigit+ '}' 83 | let ctrlchr = ['a'-'z' 'A'-'Z'] 84 | let atom = ['a'-'z' 'A'-'Z' '0'-'9' '_']+ 85 | let blank = [' ' '\t'] 86 | let space = blank | nl 87 | let dirname = [^' ' '\t' '\r' '\n']+ 88 | let comment = [^ '\r' '\n']* 89 | 90 | 91 | rule token = parse 92 | | blank+ 93 | { token lexbuf } 94 | | nl+ as s 95 | { next_line_in_spaces lexbuf s; NL (to_loc lexbuf) } 96 | | (nl* blank* '#' comment (nl blank* '#' comment)*) as s 97 | { next_line_in_spaces lexbuf s; token lexbuf } 98 | | '(' 99 | { LPAREN (to_loc lexbuf) } 100 | | ')' 101 | { RPAREN (to_loc lexbuf) } 102 | | '[' 103 | { LBRACK (to_loc lexbuf) } 104 | | ']' 105 | { RBRACK (to_loc lexbuf) } 106 | | '{' 107 | { LBRACE (to_loc lexbuf) } 108 | | '}' 109 | { RBRACE (to_loc lexbuf) } 110 | | "true" 111 | { BOOL (With.Loc.create (to_loc lexbuf) true) } 112 | | "false" 113 | { BOOL (With.Loc.create (to_loc lexbuf) false) } 114 | | "assert" 115 | { ASSERT (to_loc lexbuf) } 116 | | "as" 117 | { AS (to_loc lexbuf) } 118 | | "not" 119 | { NOT (to_loc lexbuf) } 120 | | (digit+ as b) 'r' (['0'-'9' 'a'-'z' 'A'-'Z']+ as v) 121 | { let b' = int_of_string b in 122 | if not (2 <= b' && b' <= 36) then 123 | raise (Error (to_loc lexbuf, "base must be in range 2..36")) 124 | else 125 | INT (With.Loc.create (to_loc lexbuf) (b', v)) 126 | } 127 | | digit+ 128 | { INT (With.Loc.create (to_loc lexbuf) (10, lexeme lexbuf)) } 129 | | float as s 130 | { FLOAT (With.Loc.create (to_loc lexbuf) (float_of_string s)) } 131 | | '-' 132 | { MINUS (to_loc lexbuf) } 133 | | '+' 134 | { PLUS (to_loc lexbuf) } 135 | | '*' 136 | { AST (to_loc lexbuf) } 137 | | '/' 138 | { SLASH (to_loc lexbuf) } 139 | | "-." 140 | { MINUS_DOT (to_loc lexbuf) } 141 | | "+." 142 | { PLUS_DOT (to_loc lexbuf) } 143 | | "*." 144 | { AST_DOT (to_loc lexbuf) } 145 | | "/." 146 | { SLASH_DOT (to_loc lexbuf) } 147 | | '=' 148 | { EQUAL (to_loc lexbuf) } 149 | | "<>" 150 | { LESS_GREATER (to_loc lexbuf) } 151 | | "<=" 152 | { LESS_EQUAL (to_loc lexbuf) } 153 | | ">=" 154 | { GREATER_EQUAL (to_loc lexbuf) } 155 | | '<' 156 | { LESS (to_loc lexbuf) } 157 | | '>' 158 | { GREATER (to_loc lexbuf) } 159 | | '^' 160 | { UARROW (to_loc lexbuf) } 161 | | "->" 162 | { RARROW (to_loc lexbuf) } 163 | | "if" 164 | { IF (to_loc lexbuf) } 165 | | "then" 166 | { THEN (to_loc lexbuf) } 167 | | "else" 168 | { ELSE (to_loc lexbuf) } 169 | | "in" 170 | { IN (to_loc lexbuf) } 171 | | "rec" 172 | { REC (to_loc lexbuf) } 173 | | "def" 174 | { if (start_pos lexbuf).col = 0 then 175 | TOPDEF (to_loc lexbuf) 176 | else 177 | DEF (to_loc lexbuf) 178 | } 179 | | "external" { EXTERNAL (to_loc lexbuf) } 180 | | "var" 181 | { if (start_pos lexbuf).col = 0 then 182 | TOPVAR (to_loc lexbuf) 183 | else 184 | VAR (to_loc lexbuf) 185 | } 186 | | "of" { OF (to_loc lexbuf) } 187 | | "with" 188 | { WITH (to_loc lexbuf) } 189 | | "match" { MATCH (to_loc lexbuf) } 190 | | "end" 191 | { END (to_loc lexbuf) } 192 | | "exception" 193 | { EXCEPTION (to_loc lexbuf) } 194 | | "do" 195 | { DO (to_loc lexbuf) } 196 | | "for" { FOR (to_loc lexbuf) } 197 | | "fun" { FUN (to_loc lexbuf) } 198 | | "raise" { RAISE (to_loc lexbuf) } 199 | | "to" { TO (to_loc lexbuf) } 200 | | "try" { TRY (to_loc lexbuf) } 201 | | "type" { TYPE (to_loc lexbuf) } 202 | | "mod" { MOD (to_loc lexbuf) } 203 | | "perform" { PERFORM (to_loc lexbuf) } 204 | | "return" { RETURN (to_loc lexbuf) } 205 | | "receive" { RECEIVE (to_loc lexbuf) } 206 | | "and" { AND (to_loc lexbuf) } 207 | | ',' 208 | { COMMA (to_loc lexbuf) } 209 | | '_' 210 | { let loc = to_loc lexbuf in 211 | IDENT (With.Loc.create loc 212 | (Id.gentmp (Type.prefix 213 | (With.Loc.create loc (Type_t.App(Type_t.Unit, [])))))) } 214 | | '.' 215 | { DOT (to_loc lexbuf) } 216 | | '$' 217 | { DOL (to_loc lexbuf) } 218 | | "<-" 219 | { LARROW (to_loc lexbuf) } 220 | | ':' 221 | { COLON (to_loc lexbuf) } 222 | | "::" 223 | { CONS (to_loc lexbuf) } 224 | | ":=" 225 | { ASSIGN (to_loc lexbuf) } 226 | | ';' 227 | { SEMI (to_loc lexbuf) } 228 | | '!' 229 | { EXCL (to_loc lexbuf) } 230 | | '|' 231 | { PIPE (to_loc lexbuf) } 232 | | ''' (sqchr as s) ''' 233 | { CHAR (with_word lexbuf s) } 234 | | ''' ('\\' octstr as s) ''' 235 | { CHAR (with_word lexbuf s) } 236 | | ''' ('\\' 'x' hexstr as s) ''' 237 | { CHAR (with_word lexbuf s) } 238 | | ''' ('\\' '^' ctrlchr as s) ''' 239 | { CHAR (with_word lexbuf s) } 240 | | '"' 241 | { STRING (strlit_to_word lexbuf string) } 242 | | '@' atom 243 | { ATOM (With.Loc.create (to_loc lexbuf) 244 | (String.drop 1 & lexeme lexbuf)) } 245 | | '@' '"' 246 | { ATOM (strlit_to_word lexbuf string) } 247 | | "<<" 248 | { LESS_LESS (to_loc lexbuf) } 249 | | ">>" 250 | { GREATER_GREATER (to_loc lexbuf) } 251 | | eof 252 | { EOF (to_loc lexbuf) } 253 | | ident 254 | { IDENT (to_word lexbuf) } 255 | | uident 256 | { UIDENT (to_word lexbuf) } 257 | | ''' (ident as s) 258 | { QIDENT (With.Loc.create (to_loc lexbuf) s) } 259 | | _ 260 | { raise (Error (to_loc lexbuf, 261 | Printf.sprintf "unknown token '%s'" (lexeme lexbuf))) } 262 | 263 | and string buf = 264 | parse 265 | | '"' 266 | { Buffer.contents buf } 267 | | nl as s 268 | { Buffer.add_string buf s; 269 | next_line lexbuf; 270 | string buf lexbuf } 271 | | '\\' octstr 272 | { Buffer.add_string buf (lexeme lexbuf); string buf lexbuf } 273 | | '\\' 'x' hexstr 274 | { Buffer.add_string buf (lexeme lexbuf); string buf lexbuf } 275 | | '\\' '^' ctrlchr 276 | { Buffer.add_string buf (lexeme lexbuf); string buf lexbuf } 277 | | dqstrchr+ as s 278 | { Buffer.add_string buf s; string buf lexbuf } 279 | | _ { raise (Error (to_loc lexbuf, "Illegal string character: " ^ lexeme lexbuf)) } 280 | | eof { raise (Error (to_loc lexbuf, "String is not terminated")) } 281 | -------------------------------------------------------------------------------- /src/emit.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Printf 3 | open Erlang_t 4 | 5 | let mod_name = ref "" 6 | 7 | let gen_var s = "_" ^ s 8 | 9 | let gen_arg (x, _) = gen_var x 10 | 11 | let inject_sep oc sep f es = 12 | List.inject (fun () -> bprintf oc sep) f es 13 | 14 | let rec gen_exp oc = function 15 | | Atom s -> bprintf oc "'%s'" s 16 | | Int (b, v) -> bprintf oc "%d#%s" b v 17 | | Float v -> bprintf oc "%f" v 18 | | Char s -> bprintf oc "$%s" s 19 | | String s -> bprintf oc "%s" (Erlang.literal_of_string s) 20 | | Bitstring es -> 21 | begin 22 | let open Bitstring in 23 | bprintf oc "<<"; 24 | bprintf oc "%s" & String.concat_map ", " 25 | (fun e -> 26 | begin match e.Bits.value with 27 | | Bits.Int v -> sprintf "%d" v 28 | | Bits.Float v -> sprintf "%f" v 29 | | Bits.String v -> sprintf "\"%s\"" v 30 | | Bits.Var v -> sprintf "%s" (gen_var v) 31 | end ^ 32 | begin match e.Bits.size with 33 | | None -> "" 34 | | Some v -> ":" ^ string_of_int v 35 | end ^ "/" ^ 36 | begin match e.Bits.typ with 37 | | `Int -> "integer" 38 | | `Float -> "float" 39 | | `Binary -> "binary" 40 | | `Bitstring -> "bitstring" 41 | | `UTF8 -> "utf8" 42 | | `UTF16 -> "utf16" 43 | | `UTF32 -> "utf32" 44 | end ^ 45 | begin match e.Bits.sign with 46 | | None -> "" 47 | | Some `Unsigned -> "-unsigned" 48 | | Some `Signed -> "-signed" 49 | end ^ 50 | begin match e.Bits.endian with 51 | | None -> "" 52 | | Some `Big -> "-big" 53 | | Some `Little -> "-little" 54 | | Some `Native -> "-native" 55 | end ^ 56 | begin match e.Bits.unit with 57 | | None -> "" 58 | | Some v -> sprintf "-unit:%d" v 59 | end) es; 60 | bprintf oc ">>"; 61 | end 62 | | Var (`Local x) -> bprintf oc "%s" (gen_var x) 63 | | Var (`Module x) -> bprintf oc "%s()" (Binding.to_erl_fun x) 64 | | Tuple es -> 65 | bprintf oc "{"; 66 | inject_sep oc ", " (gen_exp oc) es; 67 | bprintf oc "}" 68 | | List es -> 69 | bprintf oc "["; 70 | inject_sep oc ", " (gen_exp oc) es; 71 | bprintf oc "]" 72 | | Array es -> 73 | bprintf oc "array:from_list(["; 74 | inject_sep oc ", " (gen_exp oc) es; 75 | bprintf oc "])" 76 | | Not e -> gen_prefix_exp oc "not" e 77 | | And (e1, e2) -> gen_bin_exp oc e1 "and" e2 78 | | Or (e1, e2) -> gen_bin_exp oc e1 "or" e2 79 | | Neg e -> gen_prefix_exp oc "-" e 80 | | Add (e1, e2) -> gen_bin_exp oc e1 "+" e2 81 | | Sub (e1, e2) -> gen_bin_exp oc e1 "-" e2 82 | | Mul (e1, e2) -> gen_bin_exp oc e1 "*" e2 83 | | Div (e1, e2) -> gen_bin_exp oc e1 "/" e2 84 | | Concat (e1, e2) -> gen_bin_exp oc e1 "++" e2 85 | | Eq (e1, e2) -> gen_bin_exp oc e1 "=:=" e2 86 | | LE (e1, e2) -> gen_bin_exp oc e1 "=<" e2 87 | | AppDir (x, es) -> 88 | bprintf oc "%s(" (Binding.to_erl_fun x); 89 | inject_sep oc ", " (gen_exp oc) es; 90 | bprintf oc ")" 91 | | If ptns -> 92 | bprintf oc "if "; 93 | inject_sep oc "; " (fun (e1, e2) -> 94 | gen_exp oc e1; 95 | bprintf oc " -> "; 96 | gen_exp oc e2) ptns; 97 | bprintf oc " end" 98 | | Match (x, pts) -> 99 | bprintf oc "case %s of " (gen_var x); 100 | inject_sep oc "; " (fun (p, t) -> 101 | gen_ptn oc p; 102 | bprintf oc " -> "; 103 | gen_exp oc t) pts; 104 | bprintf oc " end" 105 | | Let (x, e1, e2) -> 106 | bprintf oc "%s = " (gen_var x); 107 | gen_exp oc e1; 108 | bprintf oc ", "; 109 | gen_exp oc e2 110 | | Constr (x, []) -> 111 | Log.debug "# Constr %s\n" (Binding.to_erl_atom x); 112 | bprintf oc "%s" (Binding.to_erl_atom x) 113 | | Constr (x, es) -> 114 | bprintf oc "{%s, " (Binding.to_erl_atom x); 115 | inject_sep oc ", " (gen_exp oc) es; 116 | bprintf oc "}" 117 | | _ -> assert false 118 | 119 | and gen_prefix_exp oc op e = 120 | bprintf oc "("; 121 | gen_exp oc e; 122 | bprintf oc ")" 123 | 124 | and gen_bin_exp oc e1 op e2 = 125 | bprintf oc "("; 126 | gen_exp oc e1; 127 | bprintf oc " %s " op; 128 | gen_exp oc e2; 129 | bprintf oc ")" 130 | 131 | and gen_ptn oc = function 132 | | PtAtom s -> bprintf oc "'%s'" s 133 | | PtBool v -> bprintf oc "%s" (string_of_bool v) 134 | | PtInt (b, v) -> bprintf oc "%d#%s" b v 135 | | PtFloat v -> bprintf oc "%f" v 136 | | PtString s -> bprintf oc "\"%s\"" s 137 | | PtVar x -> bprintf oc "%s" (gen_var x) 138 | | PtAlias (p, x) -> 139 | bprintf oc "("; 140 | gen_ptn oc p; 141 | bprintf oc ") = %s" (gen_var x) 142 | | PtTuple ps -> 143 | bprintf oc "{"; 144 | inject_sep oc ", " (fun p -> gen_ptn oc p) ps; 145 | bprintf oc "}" 146 | | PtList ps -> 147 | bprintf oc "["; 148 | inject_sep oc ", " (fun p -> gen_ptn oc p) ps; 149 | bprintf oc "]" 150 | | PtCons (p1, p2) -> 151 | bprintf oc "["; 152 | gen_ptn oc p1; 153 | bprintf oc "|"; 154 | gen_ptn oc p2; 155 | bprintf oc "]" 156 | | PtConstr (x, []) -> bprintf oc "%s" (Binding.to_erl_atom x) 157 | | PtConstr (x, ps) -> 158 | bprintf oc "{%s, " (Binding.to_erl_atom x); 159 | inject_sep oc ", " (gen_ptn oc) ps; 160 | bprintf oc "}" 161 | | _ -> assert false (* TODO *) 162 | 163 | let rec gen_type_tycon ~format oc t = 164 | let open Type_t in 165 | match t with 166 | | Unit -> bprintf oc "{}" 167 | | Bool -> bprintf oc "bool()" 168 | | Int -> bprintf oc "integer()" 169 | | Float -> bprintf oc "float()" 170 | | Char -> bprintf oc "char()" 171 | | String -> bprintf oc "string()" 172 | | Atom -> bprintf oc "atom()" 173 | | Bitstring -> bprintf oc "bitstring()" 174 | | Binary -> bprintf oc "binary()" 175 | | Variant (tx, xts) -> 176 | begin match format with 177 | | `Spec -> bprintf oc "%s()" tx 178 | | `Type -> 179 | inject_sep oc " | " 180 | (fun (x, ts) -> 181 | match ts with 182 | | [] -> bprintf oc "'%s.%s'" !mod_name x 183 | | _ -> 184 | bprintf oc "{'%s.%s', " !mod_name x; 185 | inject_sep oc ", " (gen_type ~format oc) ts; 186 | bprintf oc "}") xts 187 | end 188 | | TyFun (_, t) -> gen_type ~format oc t 189 | | _ -> assert false 190 | 191 | and gen_type ~format oc t = 192 | let open Type_t in 193 | match t.desc with 194 | | Var _ -> bprintf oc "any()" 195 | | App (Tuple, ts) -> 196 | bprintf oc "{"; 197 | inject_sep oc ", " (gen_type ~format oc) ts; 198 | bprintf oc "}" 199 | | App (List, t :: _) -> 200 | bprintf oc "["; 201 | gen_type ~format oc t; 202 | bprintf oc "]" 203 | | App (Record (rx, xs), ts) -> 204 | bprintf oc "{"; 205 | List.inject2 206 | (fun () -> bprintf oc ", ") 207 | (fun x t -> 208 | bprintf oc "%s::" x; 209 | gen_type ~format oc t) xs ts; 210 | bprintf oc "}" 211 | | App (Arrow, ts) -> 212 | let (ts', t') = match List.rev ts with 213 | | t' :: ts' -> List.rev ts', t' 214 | | _ -> assert false 215 | in 216 | bprintf oc "("; 217 | inject_sep oc ", " (gen_type ~format oc) ts'; 218 | bprintf oc ") -> "; 219 | gen_type ~format oc t' 220 | | App (Instance ([(_, t)], { desc = App (List, []) }), _) -> 221 | bprintf oc "["; 222 | gen_type ~format oc t; 223 | bprintf oc "]" 224 | | App (Instance (_, t), _) -> gen_type ~format oc t 225 | | App (tycon, []) -> gen_type_tycon ~format oc tycon 226 | | Poly (_, t) -> gen_type ~format oc t 227 | | _ -> 228 | Printf.printf "Error: not implemented: %s\n" (Type.to_string t); 229 | assert false 230 | 231 | let gen_def oc = function 232 | | TypeDef (x, tycon) -> 233 | begin match tycon with 234 | | Type_t.TyFun (_, { desc = Type_t.App (Type_t.Record _, _) }) -> 235 | bprintf oc "-record(%s, " x; 236 | gen_type_tycon oc tycon ~format:`Type; 237 | bprintf oc ").\n" 238 | | _ -> 239 | bprintf oc "-type %s() :: " x; 240 | gen_type_tycon oc tycon ~format:`Type; 241 | bprintf oc ".\n" 242 | end 243 | | FunDef { name = (Id.L x, t); args = args; body = body } -> 244 | if !Config.gen_spec then begin 245 | bprintf oc "-spec %s" x; 246 | gen_type oc t ~format:`Spec; 247 | bprintf oc ".\n" 248 | end; 249 | bprintf oc "%s(%s) -> " x 250 | (String.concat_map ", " gen_arg args); 251 | gen_exp oc body; 252 | bprintf oc ".\n" 253 | | _ -> () 254 | 255 | let gen_export oc defs = 256 | let sigs = 257 | List.rev & List.fold_left (fun accu def -> 258 | match def with 259 | | FunDef { name = (Id.L x, _); args = args } -> 260 | (sprintf "%s/%d" x (List.length args)) :: accu 261 | | _ -> accu) [] defs 262 | in 263 | if List.length sigs > 0 then 264 | bprintf oc "-export([%s]).\n\n" (String.concat ", " sigs) 265 | 266 | let f name oc (Prog defs) = 267 | mod_name := Utils.module_name name; 268 | bprintf oc "%%%% Note: This code is automatically generated by bran. Do not modify it.\n\n"; 269 | bprintf oc "-module(%s).\n\n" name; 270 | gen_export oc defs; 271 | List.iter (gen_def oc) defs; 272 | bprintf oc "\n%%%% End.\n" 273 | -------------------------------------------------------------------------------- /src/kNormal.ml: -------------------------------------------------------------------------------- 1 | (* give names to intermediate values (K-normalization) *) 2 | (* 変換後のコードをなるべくオリジナルに近いものにするため、実際にはほとんどK正規形にはしない。 *) 3 | 4 | open KNormal_t 5 | open With.Loc 6 | open Base 7 | 8 | let rec ocaml_of_pattern = 9 | function 10 | | PtUnit -> "()" 11 | | PtBool(b) -> string_of_bool b 12 | | PtInt(n) -> IntRepr.to_string n 13 | | PtFloat v -> string_of_float v 14 | | PtAtom(v) -> "@\"" ^ v ^ "\"" 15 | | PtString(v) -> "\"" ^ v ^ "\"" 16 | | PtVar(x, t) -> x 17 | | PtAlias (p, x, _) -> ocaml_of_pattern p ^ " as " ^ x 18 | | PtTuple(ps) -> String.concat_map ", " ocaml_of_pattern ps 19 | | PtList(ps) -> String.concat_map ", " ocaml_of_pattern ps 20 | | PtCons (p1, p2) -> (ocaml_of_pattern p1) ^ "::" ^ (ocaml_of_pattern p2) 21 | | PtField(xps) -> String.concat ", " (List.map (fun (x, p) -> x ^ " = " ^ (ocaml_of_pattern p)) xps) 22 | | PtConstr(x, ps) -> 23 | (Binding.to_string x) ^ ", " ^ String.concat_map ", " ocaml_of_pattern ps 24 | 25 | let rec string_of_typed_expr (e, t) = (string_of_expr e) ^ " : " ^ (Type.to_string t) 26 | 27 | and string_of_expr = 28 | function 29 | | Bool(b) -> string_of_bool b 30 | | Int(n) -> IntRepr.to_string n 31 | | Float f -> string_of_float f 32 | | Char s -> "'" ^ s ^ "'" 33 | | String s -> "\"" ^ s ^ "\"" 34 | | Atom s -> "@\"" ^ s ^ "\"" 35 | | Bitstring x -> Bitstring.to_string x 36 | | Record(xes) -> "{" ^ (String.concat "; " (List.map (fun (x, e) -> x ^ " = " ^ (string_of_typed_expr e)) xes)) ^ "}" 37 | | Field(e, x) -> (string_of_typed_expr e) ^ "." ^ x 38 | | List(es) -> "[" ^ (String.concat_map ", " string_of_typed_expr es) ^ "]" 39 | | Tuple(es) -> "(" ^ (String.concat_map ", " string_of_typed_expr es) ^ ")" 40 | | Array(es) -> "[|" ^ (String.concat_map "; " string_of_typed_expr es) ^ "|]" 41 | | Not(e) -> "not " ^ (string_of_typed_expr e) 42 | | And(e1, e2) -> (string_of_typed_expr e1) ^ " && " ^ (string_of_typed_expr e2) 43 | | Or(e1, e2) -> (string_of_typed_expr e1) ^ " || " ^ (string_of_typed_expr e2) 44 | | Neg(e) -> "! " ^ (string_of_typed_expr e) 45 | | Add(e1, e2) -> (string_of_typed_expr e1) ^ " + " ^ (string_of_typed_expr e2) 46 | | Sub(e1, e2) -> (string_of_typed_expr e1) ^ " - " ^ (string_of_typed_expr e2) 47 | | Mul(e1, e2) -> (string_of_typed_expr e1) ^ " * " ^ (string_of_typed_expr e2) 48 | | Div(e1, e2) -> (string_of_typed_expr e1) ^ " / " ^ (string_of_typed_expr e2) 49 | | Var(`Local x) -> "Var(`Local " ^ x ^ ")" 50 | | Var(`Module x) -> "Var(`Module " ^ (Binding.to_string x) ^ ")" 51 | | Concat(e1, e2) -> (string_of_typed_expr e1) ^ " ^ " ^ (string_of_typed_expr e2) 52 | | Constr(x, es) -> "Constr(" ^ (Binding.to_string x) ^ ", [" ^ (String.concat ", " (List.map string_of_typed_expr es)) ^ "])" 53 | | Eq(e1, e2) -> (string_of_typed_expr e1) ^ " = " ^ (string_of_typed_expr e2) 54 | | LE(e1, e2) -> (string_of_typed_expr e1) ^ " <= " ^ (string_of_typed_expr e2) 55 | | App(e, args) -> "App(" ^ (string_of_typed_expr e) ^ ", [" ^ (String.concat ", " (List.map string_of_typed_expr args)) ^ "])" 56 | | ExtFunApp(x, args) -> "ExtFunApp(" ^ x ^ ", [" ^ (String.concat " " (List.map string_of_typed_expr args)) ^ "])" 57 | | Get (e1, e2) -> 58 | Printf.sprintf "Get(%s, %s)" (string_of_typed_expr e1) (string_of_typed_expr e2) 59 | | Put (e1, e2, e3) -> 60 | Printf.sprintf "Put(%s, %s, %s)" 61 | (string_of_typed_expr e1) (string_of_typed_expr e2) (string_of_typed_expr e3) 62 | 63 | let rec string_of_typed_term (e, t) = (string_of_term e) ^ " : " ^ (Type.to_string t) 64 | 65 | and string_of_term = 66 | function 67 | | Unit -> "()" 68 | | Exp(e) -> "Exp(" ^ string_of_typed_expr e ^ ")" 69 | | If(e, e1, e2) -> "If(" ^ (string_of_typed_expr e) ^ "then " ^ (string_of_typed_term e1) ^ "else " ^ (string_of_typed_term e2) ^ ")" 70 | | Match(x, pes) -> "Match(" ^ x ^ ", [" ^ (String.concat "" (List.map (fun (p, e) -> " | " ^ (ocaml_of_pattern p) ^ " -> " ^ (string_of_typed_term e)) pes)) ^ "])" 71 | | Let((s1, t), e1, e2) -> "Let(" ^ s1 ^ " : " ^ (Type.to_string t) ^ " = " ^ (string_of_typed_term e1) ^ " in " ^ (string_of_typed_term e2) ^ ")" 72 | | LetRec({ name = (x, t); args = yts; body = e1 }, e2) -> 73 | "LetRec(" ^ x ^ ", [" ^ (String.concat ", " (List.map (fun (y, t) -> y) yts)) ^ " : " ^ (Type.to_string t) ^ "] = " 74 | ^ (string_of_typed_term e1) ^ " in " ^ (string_of_typed_term e2) ^ ")" 75 | 76 | let rec insert_let (e, t) k = (* letを挿入する補助関数 (caml2html: knormal_insert) *) 77 | match e with 78 | | Exp(e) -> k e 79 | | LetRec(fundef, et) -> 80 | let e' = insert_let et k in 81 | LetRec(fundef, (e', t)) 82 | | _ -> 83 | let x = Id.gentmp (Type.prefix t) in 84 | let e' = k (Var(`Local x), t) in 85 | Let((x, t), (e, t), (e', t)) 86 | 87 | let rec pattern env p = 88 | Log.debug "KNormal.pattern %s\n" (Ast.Pattern.to_string p); 89 | let open Ast.Pattern in 90 | match p.desc with 91 | | Ast_t.PtUnit -> env, PtUnit 92 | | Ast_t.PtBool(b) -> env, PtBool b 93 | | Ast_t.PtInt(n) -> env, PtInt n 94 | | Ast_t.PtFloat v -> env, PtFloat v 95 | | Ast_t.PtAtom v -> env, PtAtom v 96 | | Ast_t.PtString v -> env, PtString v 97 | | Ast_t.PtVar(x, t) -> Env.add_var env x t, (PtVar(x, t)) 98 | | Ast_t.PtAlias (p, x, t) -> 99 | let env', p' = pattern env p in 100 | Env.add_var env x t, (PtAlias (p', x, t)) 101 | | Ast_t.PtTuple(ps) -> 102 | fold (fun ps' -> PtTuple ps') pattern env ps 103 | | Ast_t.PtList(ps) -> 104 | fold (fun ps' -> PtList ps') pattern env ps 105 | | Ast_t.PtCons (p1, p2) -> 106 | fold_bin (fun p1' p2' -> PtCons (p1', p2')) pattern env p1 p2 107 | | Ast_t.PtRecord(xps) -> 108 | fold_assoc (fun xps' -> PtField xps') pattern env xps 109 | | Ast_t.PtConstr(x, ps, _) -> 110 | fold (fun ps' -> PtConstr (x, ps')) pattern env ps 111 | 112 | let rec g ({ Env.venv = venv; tenv = tenv } as env) { tag = loc; desc = (e, t) } = (* K正規化ルーチン本体 (caml2html: knormal_g) *) 113 | Log.debug "kNormal.g %s\n" (Ast.string_of_expr e); 114 | let insert_lets es k = 115 | let rec insert_lets' es k args = 116 | match es with 117 | | [] -> k args 118 | | (e::es') -> insert_let (g env e) (fun et' -> insert_lets' es' k (args @ [et'])) in 119 | insert_lets' es k [] in 120 | 121 | let triple_of_insert_lets e1 e2 e3 k = 122 | insert_lets [e1; e2; e3] 123 | (fun es -> k (List.nth es 0) (List.nth es 1) (List.nth es 2)) 124 | in 125 | 126 | let binop e1 e2 f = 127 | insert_let (g env e1) 128 | (fun e1' -> insert_let (g env e2) 129 | (fun e2' -> f e1' e2')) in 130 | 131 | let e' = 132 | match e with 133 | | Ast_t.Unit -> Unit 134 | | Ast_t.Bool(b) -> Exp(Bool(b), t) 135 | | Ast_t.Int(n) -> Exp(Int(n), t) 136 | | Ast_t.Float(n) -> Exp(Float(n), t) 137 | | Ast_t.Char(n) -> Exp(Char(n), t) 138 | | Ast_t.String(s) -> Exp(String(s), t) 139 | | Ast_t.Atom(s) -> Exp(Atom(s), t) 140 | | Ast_t.Bitstring(x) -> Exp(Bitstring(x), t) 141 | | Ast_t.Record(xes) -> 142 | insert_lets (List.map snd xes) 143 | (fun ets' -> Exp(Record(List.combine (List.map fst xes) ets'), t)) 144 | | Ast_t.Field(e, x) -> insert_let (g env e) (fun e' -> Exp(Field(e', x), t)) 145 | | Ast_t.List(es) -> insert_lets es (fun es' -> Exp(List(es'), t)) 146 | | Ast_t.Tuple(es) -> insert_lets es (fun es' -> Exp(Tuple(es'), t)) 147 | | Ast_t.Array(es) -> insert_lets es (fun es' -> Exp(Array(es'), t)) 148 | | Ast_t.Not(e) -> insert_let (g env e) (fun e' -> Exp(Not(e'), t)) 149 | | Ast_t.And(e1, e2) -> binop e1 e2 (fun e1' e2' -> Exp(And(e1', e2'), t)) 150 | | Ast_t.Or(e1, e2) -> binop e1 e2 (fun e1' e2' -> Exp(Or(e1', e2'), t)) 151 | | Ast_t.Neg(e) -> insert_let (g env e) (fun e' -> Exp(Neg(e'), t)) 152 | | Ast_t.Add(e1, e2) -> binop e1 e2 (fun e1' e2' -> Exp(Add(e1', e2'), t)) (* 足し算のK正規化 (caml2html: knormal_add) *) 153 | | Ast_t.Sub(e1, e2) -> binop e1 e2 (fun e1' e2' -> Exp(Sub(e1', e2'), t)) 154 | | Ast_t.Mul(e1, e2) -> binop e1 e2 (fun e1' e2' -> Exp(Mul(e1', e2'), t)) 155 | | Ast_t.Div(e1, e2) -> binop e1 e2 (fun e1' e2' -> Exp(Div(e1', e2'), t)) 156 | | Ast_t.Var(`Local x) -> Exp(Var(`Local x), t) 157 | | Ast_t.Var(`Module x) -> Exp(Var(`Module x), t) 158 | | Ast_t.Var(`Unbound _) -> assert false 159 | | Ast_t.Concat(e1, e2) -> binop e1 e2 (fun e1' e2' -> Exp(Concat(e1', e2'), t)) 160 | | Ast_t.Constr(x, es) -> insert_lets es (fun es' -> Exp(Constr(x, es'), t)) 161 | | Ast_t.Eq(e1, e2) -> binop e1 e2 (fun e1' e2' -> Exp(Eq(e1', e2'), t)) 162 | | Ast_t.LE(e1, e2) -> binop e1 e2 (fun e1' e2' -> Exp(LE(e1', e2'), t)) 163 | | Ast_t.If(e1, e2, e3) -> insert_let (g env e1) (fun e1' -> If(e1', (g env e2), (g env e3))) 164 | | Ast_t.Match({ desc = (Ast_t.Var(`Local x), _) }, pes) -> 165 | let pes' = List.map 166 | (fun (p, e) -> 167 | let env', p' = pattern env p in 168 | let e' = g env' e in 169 | p', e') 170 | pes 171 | in 172 | Match(x, pes') 173 | | Ast_t.Match(e, pes) -> 174 | let e' = g env e in 175 | let pes' = List.map 176 | (fun (p, e) -> 177 | let env', p' = pattern env p in 178 | let e' = g env' e in 179 | p', e') 180 | pes in 181 | let x = Id.gentmp (Type.prefix t) in 182 | Let((x, t), e', (Match(x, pes'), t)) 183 | | Ast_t.LetVar((x, t), e1, e2) -> 184 | let e1' = g env e1 in 185 | let e2' = g (Env.add_var env x t) e2 in 186 | Let((x, t), e1', e2') 187 | | Ast_t.LetRec({ Ast_t.name = (x, t); Ast_t.args = yts; Ast_t.body = e1 }, e2) -> 188 | let venv' = Id.Map.add x t venv in 189 | let e2' = g { env with Env.venv = venv' } e2 in 190 | let e1' = g { env with Env.venv = Id.Map.add_alist yts venv' } e1 in 191 | LetRec({ name = (x, t); args = yts; body = e1' }, e2') 192 | (* 193 | | Ast_t.App({ desc = (Ast_t.Var(f), _) }, e2s) 194 | when Env.is_module_val env f -> 195 | let m = Env.find_module_of_val env f in 196 | Log.debug "# applying %s.%s (full imported)\n" m.Module.name f; 197 | let f' = Module.primitive m f in 198 | let rec bind xs = (* "xs" are identifiers for the arguments *) 199 | function 200 | | [] -> Exp(ExtFunApp(f', xs), t) 201 | | e2 :: e2s -> insert_let (g env e2) (fun x -> bind (xs @ [x]) e2s) in 202 | (bind [] e2s) (* left-to-right evaluation *) 203 | *) 204 | | Ast_t.App(e1, e2s) -> 205 | insert_let (g env e1) 206 | (fun f -> 207 | let rec bind xs = (* "xs" are identifiers for the arguments *) 208 | function 209 | | [] -> Exp(App(f, xs), t) 210 | | e2 :: e2s -> insert_let (g env e2) (fun x -> bind (xs @ [x]) e2s) in 211 | bind [] e2s) (* left-to-right evaluation *) 212 | | Ast_t.Get (e1, e2) -> 213 | let (_, t) as g_e1 = g env e1 in 214 | begin match t.desc with 215 | | Type_t.App(Type_t.Array, [t]) -> 216 | insert_let g_e1 (fun x -> insert_let (g env e2) 217 | (fun y -> Exp (Get(x, y), t))) 218 | | _ -> assert false 219 | end 220 | | Ast_t.Put (e1, e2, e3) -> 221 | triple_of_insert_lets e1 e2 e3 222 | (fun x y z -> Exp (Put (x, y, z), Type.app_unit loc)) 223 | | Ast_t.Perform _ -> failwith "not implemented" 224 | | Ast_t.Bind _ -> failwith "not implemented" 225 | | Ast_t.Return _ -> failwith "not implemented" 226 | in 227 | (e', t) 228 | 229 | let fold f env defs = 230 | let _, defs' = List.fold_left f (env, []) defs in 231 | List.rev defs' 232 | 233 | let map f defs = 234 | let f' (({ Env.venv = venv; tenv = tenv } as env), defs) def = 235 | Log.debug "# KNormal.map import mv %d\n" (List.length env.Env.mods); 236 | let env', def' = 237 | match def with 238 | | TypeDef(x, t) -> 239 | let env' = { env with 240 | Env.venv = Id.Map.add_alist (Type.Tycon.vars t) venv; 241 | Env.tenv = Id.Map.add_alist (Type.Tycon.types t) tenv } in 242 | env', f env' def 243 | | VarDef((x, t), e) -> 244 | Env.add_var env x t, f env def 245 | | RecDef({ name = (x, t); args = yts; body = e1 }) -> 246 | let env' = Env.add_var env x t in 247 | env', f env' def in 248 | env', (def' :: defs) in 249 | fold f' (Sig.create_env ()) defs 250 | 251 | let f' env e = g env e 252 | 253 | let f defs = 254 | Ast.fold (fun (env, defs) def -> 255 | match def.desc with 256 | | Ast_t.TypeDef(x, t) -> TypeDef(x, t) :: defs 257 | | Ast_t.VarDef((x, t), e) -> VarDef((x, t), f' env e) :: defs 258 | | Ast_t.RecDef({ Ast_t.name = (x, t); args = yts; body = e }) -> 259 | RecDef({ name = (x, t); args = yts; body = f' env e }) :: defs 260 | | _ -> assert false) defs (Sig.create_env ()) 261 | -------------------------------------------------------------------------------- /test/sealing.ml: -------------------------------------------------------------------------------- 1 | open Spotlib 2 | open Spotlib.Base 3 | 4 | let debug = ref false 5 | 6 | let printf = function 7 | | false -> Spotlib.Xprintf.zprintf 8 | | true -> 9 | flush_all (); 10 | Printf.printf "# Sealing: pid %d: "( Unix.getpid ()); 11 | Printf.printf 12 | 13 | let dprintf f = printf !debug f 14 | 15 | module FileChange = struct 16 | 17 | type change = 18 | | Not_changed 19 | | Accessed 20 | | Created 21 | | Modified 22 | | Changed 23 | | Deleted 24 | 25 | type t = { 26 | path : string; 27 | change : change; 28 | time : float; 29 | } 30 | 31 | let path fc = fc.path 32 | let change fc = fc.change 33 | let time fc = fc.time 34 | 35 | let change_to_string = function 36 | | Not_changed -> "Not_changed" 37 | | Accessed -> "Accessed" 38 | | Created -> "Created" 39 | | Modified -> "Modified" 40 | | Changed -> "Changed" 41 | | Deleted -> "Deleted" 42 | 43 | let to_string ch = 44 | let open Spotlib.Temporal in 45 | Printf.sprintf "(%s, %s, %s)" ch.path (change_to_string ch.change) 46 | (Datetime.to_string & Datetime.of_utc_tm & Unix.localtime ch.time) 47 | 48 | end 49 | 50 | module Result = struct 51 | 52 | type t = { 53 | stdout : string; 54 | stderr : string; 55 | status : Unix.process_status; 56 | file_changes : FileChange.t list; 57 | predictions : FileChange.t list; 58 | } 59 | 60 | let changes res = 61 | List.filter (fun fc -> fc.FileChange.change <> Not_changed) res.file_changes 62 | 63 | let find_files_changed res ch = 64 | List.map FileChange.path & 65 | List.filter (fun fc -> fc.FileChange.change = ch) res.file_changes 66 | 67 | let files_updated res = 68 | List.filter (fun fc -> 69 | match fc.FileChange.change with 70 | | FileChange.Not_changed -> false 71 | | _ -> true) 72 | res.file_changes 73 | 74 | let has_file_changes res = 75 | List.length (files_updated res) > 0 76 | 77 | let has_files_created_only res paths = 78 | let open FileChange in 79 | let (created, all) = 80 | List.fold_left 81 | (fun (accu, all) fc -> 82 | match fc.change with 83 | | Not_changed | Accessed -> accu, all 84 | | Created -> fc.path :: accu, all 85 | | _ -> accu, false) 86 | ([], true) res.file_changes 87 | in 88 | if not all || (List.length created <> List.length paths) then 89 | false 90 | else 91 | List.for_all (fun p -> List.mem p created) paths 92 | 93 | let return_code res = 94 | match res.status with 95 | | Unix.WEXITED v -> Some v 96 | | _ -> None 97 | 98 | let is_exited res = 99 | match res.status with 100 | | Unix.WEXITED _ -> true 101 | | _ -> false 102 | 103 | let is_succeeded res = 104 | match res.status with 105 | | Unix.WEXITED 0 -> true 106 | | _ -> false 107 | 108 | let prediction res = 109 | let open FileChange in 110 | let (related, others) = 111 | List.partition 112 | (fun ex -> List.exists (fun ac -> ex.path = ac.path) res.file_changes) 113 | res.predictions 114 | in 115 | if not & List.for_all 116 | (fun fc -> fc.change = Not_changed || fc.change = Accessed) others then 117 | `Failure 118 | else 119 | if List.for_all 120 | (fun ex -> List.exists 121 | (fun ac -> ex.path = ac.path && ex.change = ac.change) 122 | related) 123 | res.predictions then 124 | `Success 125 | else 126 | `Failure 127 | 128 | end 129 | 130 | module Env = struct 131 | 132 | module Vars = Map.Make(String) 133 | 134 | type t = { 135 | origdir : string; 136 | basedir : string; 137 | vars : string Vars.t; 138 | ignore_files : Str.regexp list; 139 | ignore_hidden : bool; 140 | expect_error : bool; 141 | expect_stderr : bool; 142 | quiet : bool; 143 | mutable file_changes : FileChange.t list; 144 | mutable predictions : FileChange.t list; 145 | } 146 | 147 | let ignore env path = 148 | let (dir, base) = 149 | match Filepath.dirbase & Filepath.of_string Filepath.os path with 150 | | _, None -> failwith "cannot delete root directory" 151 | | dir, Some base -> Filepath.to_string dir, base 152 | in 153 | (env.ignore_hidden && Xstring.is_prefix "." base) || 154 | (List.exists 155 | (fun re -> Str.string_match re base 0 || Str.string_match re path 0) 156 | env.ignore_files) 157 | 158 | let read_dir env path = 159 | List.filter (not ** ignore env) (Array.to_list & Sys.readdir path) 160 | 161 | let rec rm ~force env path = 162 | (* FIXME: ~force is for whether delete files not managed by the env or not *) 163 | if not & ignore env path then 164 | match Sys.is_directory path, force with 165 | | false, _ -> Sys.remove path 166 | | true, false -> 167 | Exn.failwithf "%s is not empty" path 168 | | true, true -> 169 | List.iter (rm ~force env) & read_dir env path; 170 | if Array.length (Sys.readdir path) = 0 then 171 | Unix.rmdir path 172 | 173 | let clear ?(force=false) env = 174 | Xunix.with_chdir env.origdir 175 | (fun () -> 176 | Xunix.with_chdir env.basedir 177 | (fun () -> List.iter (rm ~force env) & read_dir env ".")) 178 | 179 | (* initialize PRNG for parallel execution *) 180 | let () = Random.self_init () 181 | let gen_id () = Random.bits () 182 | 183 | let init_basedir basedir = 184 | let rec gendir () = 185 | let dir = Printf.sprintf "%s-%d-%x" basedir (Unix.getpid ()) (gen_id ()) in 186 | if Sys.file_exists dir then 187 | gendir () 188 | else 189 | match Spotlib.Xunix.mkdir dir ~perm:0o744 ~recursive:true with 190 | | `Ok -> dir 191 | | `Already_exists _ -> 192 | dprintf "# %d: basedir exists %s\n" (Unix.getpid ()) dir; 193 | gendir () 194 | | _ -> assert false 195 | in 196 | gendir () 197 | 198 | let create 199 | ?env 200 | ?(start_clear=false) 201 | ?(ignore_files=[]) 202 | ?(ignore_hidden=true) 203 | ?(parallel=true) 204 | ?(expect_error=true) 205 | ?(expect_stderr=false) 206 | ?(quiet=false) 207 | ?(basedir="test_output") 208 | () = 209 | let basedir' = 210 | if parallel then 211 | init_basedir basedir 212 | else 213 | basedir 214 | in 215 | dprintf "create: %s\n" basedir'; 216 | let vars = 217 | match env with 218 | | None -> Vars.empty 219 | | Some kvs -> 220 | List.fold_left (fun vars (k, v) -> Vars.add k v vars) Vars.empty kvs 221 | in 222 | let ignore_files' = List.map Str.regexp ignore_files in 223 | let e = { origdir = Unix.getcwd (); 224 | basedir = basedir'; vars; 225 | ignore_files = ignore_files'; 226 | ignore_hidden; expect_error; expect_stderr; 227 | quiet; file_changes = []; predictions = [] } 228 | in 229 | if start_clear && Sys.file_exists basedir' then 230 | clear e; 231 | if not & Sys.file_exists basedir' then begin 232 | match Spotlib.Xunix.mkdir basedir' ~perm:0o744 ~recursive:true with 233 | | _ -> () 234 | end; 235 | e 236 | 237 | let read_all_files env path = 238 | let rec f env path accu = 239 | List.fold_left (fun accu post -> 240 | if Sys.is_directory post then 241 | f env post accu 242 | else 243 | post :: accu) 244 | accu (read_dir env path) 245 | in 246 | f env path [] 247 | 248 | let find_change_opt env path = 249 | try 250 | Some (List.find 251 | (fun fc -> path = fc.FileChange.path) env.file_changes) 252 | with 253 | Not_found -> None 254 | 255 | let update_file_changes env = 256 | let open FileChange in 257 | let files = read_all_files env "." in 258 | let changes = 259 | List.fold_left 260 | (fun accu fc -> 261 | if not & List.mem fc.path files then 262 | { fc with change = Deleted; time = Unix.time () } :: accu 263 | else 264 | accu) [] env.file_changes 265 | in 266 | env.file_changes <- 267 | List.fold_left 268 | (fun accu path -> 269 | let stats = Unix.stat path in 270 | let fc = 271 | match find_change_opt env path with 272 | | None -> 273 | { path; change = Created; time = stats.st_mtime } 274 | | Some fc -> 275 | if fc.time >= (max stats.st_atime & 276 | max stats.st_mtime stats.st_ctime) then 277 | { fc with change = Not_changed; time = Unix.time () } 278 | else 279 | match fc.change with 280 | | Deleted -> 281 | { fc with change = Created; time = stats.st_mtime } 282 | | _ -> 283 | if stats.st_mtime >= stats.st_atime && 284 | stats.st_mtime >= stats.st_ctime then 285 | { fc with change = Modified; time = stats.st_mtime } 286 | else if stats.st_ctime > stats.st_atime && 287 | stats.st_ctime > stats.st_mtime then 288 | { fc with change = Changed; time = stats.st_ctime } 289 | else 290 | { fc with change = Accessed; time = stats.st_atime } 291 | in 292 | fc :: accu 293 | ) changes files 294 | 295 | let print_outerr outbuf errbuf = 296 | Printf.printf "stdout: "; 297 | Buffer.output_buffer stdout outbuf; 298 | Printf.printf "\nstderr: "; 299 | Buffer.output_buffer stderr errbuf; 300 | Printf.printf "\n"; 301 | flush_all () 302 | 303 | let init_file_changes env = 304 | List.iter (fun path -> 305 | env.file_changes <- { FileChange.path; 306 | change = FileChange.Not_changed; 307 | time = Unix.time () } :: env.file_changes) 308 | & read_all_files env env.basedir 309 | 310 | let run ?chdir env f = 311 | let chdir = 312 | match chdir with 313 | | None -> env.basedir 314 | | Some d -> d 315 | in 316 | init_file_changes env; 317 | Xunix.with_chdir chdir 318 | (fun () -> 319 | let ret = f env in 320 | update_file_changes env; 321 | ret) 322 | 323 | let shell env args = 324 | dprintf "$ %s\n" (String.concat " " args); 325 | let proc = Xunix.Command.execvp args in 326 | let outbuf = Buffer.create 256 in 327 | let errbuf = Buffer.create 256 in 328 | let (st, _) = 329 | Xunix.Command.iter proc 330 | ~f:(fun (ch, read) -> 331 | match read with 332 | | `EOF -> () 333 | | `Read s -> 334 | let buf = 335 | match ch with 336 | | `Out -> outbuf 337 | | `Err -> 338 | if not env.expect_stderr then begin 339 | Buffer.add_string errbuf s; 340 | print_outerr outbuf errbuf; 341 | failwith "Sealing.Env.run: stderr is not expected" 342 | end else 343 | errbuf 344 | in 345 | dprintf "out: '%s'\n" s; 346 | Buffer.add_string buf s) 347 | in 348 | if not env.expect_error && st <> (Unix.WEXITED 0) then 349 | failwith "Sealing.Env.run: error is not expected"; 350 | if not env.quiet && st <> (Unix.WEXITED 0) then 351 | print_outerr outbuf errbuf; 352 | update_file_changes env; 353 | { Result.stdout = Buffer.contents outbuf; 354 | stderr = Buffer.contents errbuf; 355 | status = st; 356 | file_changes = env.file_changes; 357 | predictions = env.predictions; 358 | } 359 | 360 | let install env src = 361 | let dest = 362 | match Filepath.dirbase & Filepath.of_string Filepath.os src with 363 | | _, None -> failwith "cannot copy root directory" 364 | | _, Some base -> base 365 | in 366 | dprintf "install: cp %s .\n" src; 367 | match Sys.command & Printf.sprintf "cp %s ." src with 368 | | 0 -> 369 | env.file_changes <- { FileChange.path = dest; 370 | change = Not_changed; 371 | time = Unix.time () } 372 | :: env.file_changes; 373 | dest 374 | | v -> Exn.failwithf "Env.install: copying file %s failed (exit %d)" src v 375 | 376 | let write env path f = 377 | with_oc (open_out path) f 378 | 379 | let predict env path change = 380 | env.predictions <- { FileChange.path; change; time = 0.0 } :: env.predictions 381 | 382 | end 383 | 384 | let run 385 | ?env 386 | ?start_clear 387 | ?ignore_files 388 | ?ignore_hidden 389 | ?parallel 390 | ?expect_error 391 | ?expect_stderr 392 | ?quiet 393 | ?basedir 394 | f = 395 | let env = Env.create ?env ?start_clear ?ignore_files 396 | ?ignore_hidden ?parallel ?basedir 397 | ?expect_error ?expect_stderr ?quiet () 398 | in 399 | Env.run env f 400 | 401 | let replace_extension path ext = 402 | (fst & Xfilename.split_extension path) ^ ext 403 | 404 | let _test () = 405 | let res = run (fun env -> Env.shell env ["ls"]) in 406 | print_endline res.stdout 407 | 408 | (* let _ = _test () *) 409 | -------------------------------------------------------------------------------- /src/closure.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Closure_t 3 | 4 | let rec string_of_pattern = 5 | function 6 | | PtUnit -> "PtUnit" 7 | | PtBool(b) -> "PtBool(" ^ (string_of_bool b) ^ ")" 8 | | PtInt(n) -> "PtInt(" ^ (IntRepr.to_string n) ^ ")" 9 | | PtFloat v -> "PtFloat(" ^ (string_of_float v) ^ ")" 10 | | PtAtom v -> "PtAtom(" ^ v ^ ")" 11 | | PtString v -> "PtString(" ^ v ^ ")" 12 | | PtVar(x, t) -> "PtVar(" ^ x ^ "," ^ (Type.to_string t) ^ ")" 13 | | PtAlias (p, x, t) -> 14 | Printf.sprintf "PtAlias(%s, %s, %s)" (string_of_pattern p) x (Type.to_string t) 15 | | PtTuple(ps) -> "PtTuple(" ^ (String.concat_map "; " string_of_pattern ps) ^ ")" 16 | | PtList(ps) -> "PtList(" ^ (String.concat_map "; " string_of_pattern ps) ^ ")" 17 | | PtCons (p1, p2) -> 18 | Printf.sprintf "PtCons(%s)" (String.concat_map ", " string_of_pattern [p1; p2]) 19 | | PtRecord(xps) -> "PtRecord([" ^ (String.concat "; " (List.map (fun (x, p) -> x ^ ", " ^ (string_of_pattern p)) xps)) ^ "])" 20 | | PtConstr(x, ps) -> 21 | "PtConstr(" ^ (Binding.to_string x) ^ ", [" ^ 22 | (String.concat_map "; " string_of_pattern ps) ^ "])" 23 | 24 | let rec string_of_typed_expr (e, t) = (string_of_expr e) ^ " : " ^ (Type.to_string t) 25 | 26 | and string_of_expr = 27 | function 28 | | Bool(b) -> string_of_bool b 29 | | Int(n) -> IntRepr.to_string n 30 | | Float(v) -> string_of_float v 31 | | Char(s) -> "'" ^ s ^ "'" 32 | | String(s) -> "\"" ^ s ^ "\"" 33 | | Atom(s) -> "@\"" ^ s ^ "\"" 34 | | Bitstring x -> Bitstring.to_string x 35 | | Record(xes) -> "{" ^ (String.concat "; " (List.map (fun (x, e) -> x ^ " = " ^ (string_of_typed_expr e)) xes)) ^ "}" 36 | | Field(e, x) -> (string_of_typed_expr e) ^ "." ^ x 37 | | Tuple(es) -> "(" ^ (String.concat_map ", " string_of_typed_expr es) ^ ")" 38 | | List(es) -> "[" ^ (String.concat_map ", " string_of_typed_expr es) ^ "]" 39 | | Array(es) -> "[|" ^ (String.concat_map "; " string_of_typed_expr es) ^ "|]" 40 | | Not(e) -> "not " ^ (string_of_typed_expr e) 41 | | And(e1, e2) -> (string_of_typed_expr e1) ^ " && " ^ (string_of_typed_expr e2) 42 | | Or(e1, e2) -> (string_of_typed_expr e1) ^ " || " ^ (string_of_typed_expr e2) 43 | | Neg(e) -> "-" ^ (string_of_typed_expr e) 44 | | Add(e1, e2) -> (string_of_typed_expr e1) ^ " + " ^ (string_of_typed_expr e2) 45 | | Sub(e1, e2) -> (string_of_typed_expr e1) ^ " - " ^ (string_of_typed_expr e2) 46 | | Mul(e1, e2) -> (string_of_typed_expr e1) ^ " * " ^ (string_of_typed_expr e2) 47 | | Div(e1, e2) -> (string_of_typed_expr e1) ^ " / " ^ (string_of_typed_expr e2) 48 | | Concat (e1, e2) -> (string_of_typed_expr e1) ^ " ^ " ^ (string_of_typed_expr e2) 49 | | Eq(e1, e2) -> (string_of_typed_expr e1) ^ " = " ^ (string_of_typed_expr e2) 50 | | LE(e1, e2) -> (string_of_typed_expr e1) ^ " <= " ^ (string_of_typed_expr e2) 51 | | Var(`Local x) -> "Var(`Local " ^ x ^ ")" 52 | | Var(`Module x) -> "Var(`Module " ^ (Binding.to_string x) ^ ")" 53 | | Constr(x, es) -> 54 | "Constr(" ^ (Binding.to_string x) ^ ", [" ^ (String.concat_map "; " string_of_typed_expr es) ^ "])" 55 | | AppCls(e, args) -> "AppCls(" ^ (string_of_typed_expr e) ^ ", [" ^ (String.concat "; " (List.map string_of_typed_expr args)) ^ "])" 56 | | AppDir(x, args) -> 57 | "AppDir(" ^ (Binding.to_string x) ^ ", [" ^ (String.concat_map " " string_of_typed_expr args) ^ "])" 58 | | Get(e1, e2) -> "Get(" ^ (string_of_typed_expr e1) ^ ", " ^ (string_of_typed_expr e2) 59 | | Put(e1, e2, e3) -> "Put(" ^ (string_of_typed_expr e1) ^ ", " ^ (string_of_typed_expr e2) ^ ", " ^ (string_of_typed_expr e3) 60 | 61 | let rec string_of_typed_term (e, t) = (string_of_term e) ^ " : " ^ (Type.to_string t) 62 | 63 | and string_of_term = 64 | function 65 | | Unit -> "Unit" 66 | | Exp(e) -> "Exp(" ^ (string_of_typed_expr e) ^ ")" 67 | | If(e1, e2, e3) -> "If(" ^ (string_of_typed_expr e1) ^ " then " ^ (string_of_typed_term e2) ^ " else " ^ (string_of_typed_term e3) ^ ")" 68 | | Match(x, pes) -> "Match(" ^ x ^ ", [" ^ (String.concat "; " (List.map (fun (p, e) -> (string_of_pattern p) ^ " -> " ^ (string_of_typed_term e)) pes)) ^ "])" 69 | | Let((x, t), e1, e2) -> "Let(" ^ x ^ " : " ^ (Type.to_string t) ^ " = " ^ (string_of_typed_term e1) ^ " in " ^ (string_of_typed_term e2) ^ ")" 70 | | MakeCls((x, t), { entry = Id.L(l); actual_fv = ys }, e) -> "MakeCls(" ^ x ^ " : " ^ (Type.to_string t) ^ " = " ^ l ^ ", [" ^ (String.concat ", " ys) ^ "] in " ^ (string_of_typed_term e) ^ ")" 71 | 72 | let string_of_typed_id (x, t) = x ^ " : " ^ (Type.to_string t) 73 | 74 | let string_of_fundef { name = (Id.L(x), t); args = yts; formal_fv = zts; body = e } = 75 | "{ name = " ^ x ^ ", args = [" ^ (String.concat ", " (List.map string_of_typed_id yts)) ^ "], formal_fv = [" ^ (String.concat ", " (List.map string_of_typed_id zts)) ^ "], body = " ^ (string_of_typed_term e) ^ "}" 76 | 77 | let string_of_def = 78 | function 79 | | TypeDef(x, t) -> "TypeDef(" ^ x ^ ", " ^ (Type.Tycon.to_string t) ^ ")" 80 | | VarDef((x, t), e) -> "VarDef((" ^ x ^ ", " ^ (Type.to_string t) ^ "), " ^ (string_of_typed_term e) ^ ")" 81 | | FunDef(fundef) -> "FunDef(" ^ (string_of_fundef fundef) ^ ")" 82 | 83 | let rec vars_of_pattern = 84 | function 85 | | PtUnit | PtBool _ | PtInt _ | PtFloat _ | PtAtom _ | PtString _ -> Id.Set.empty 86 | | PtVar(x, _) -> Id.Set.singleton x 87 | | PtAlias (p, x, _) -> Id.Set.add x & Id.Set.union Id.Set.empty & vars_of_pattern p 88 | | PtTuple(ps) | PtList ps | PtConstr(_, ps) -> 89 | List.fold_left (fun s p -> Id.Set.union s (vars_of_pattern p)) Id.Set.empty ps 90 | | PtCons (p1, p2) -> 91 | List.fold_left (fun s p -> Id.Set.union s (vars_of_pattern p)) Id.Set.empty [p1; p2] 92 | | PtRecord(xps) -> List.fold_left (fun s (_, p) -> Id.Set.union s (vars_of_pattern p)) Id.Set.empty xps 93 | 94 | let rec fv_of_expr (e, _) = 95 | match e with 96 | | Bool(_) | Int(_) | Float _ | Char _ | String _ | Atom _ | Bitstring _ -> Id.Set.empty 97 | | Record(xes) -> List.fold_left (fun s (_, e) -> Id.Set.union s (fv_of_expr e)) Id.Set.empty xes 98 | | Field(e, _) -> fv_of_expr e 99 | | Tuple(es) | List(es) | Array(es) -> 100 | List.fold_left (fun s e -> Id.Set.union s (fv_of_expr e)) Id.Set.empty es 101 | | Not(e) | Neg(e) -> fv_of_expr e 102 | | And(e1, e2) | Or(e1, e2) 103 | | Add(e1, e2) | Sub(e1, e2) | Mul(e1, e2) | Div(e1, e2) | Concat(e1, e2) 104 | | Eq(e1, e2) | LE(e1, e2) | Get(e1, e2) -> 105 | Id.Set.union (fv_of_expr e1) (fv_of_expr e2) 106 | | Var(`Local x) -> Id.Set.singleton x 107 | | Var (`Module _) -> Id.Set.empty 108 | | Constr(_, es) -> List.fold_left (fun s e -> Id.Set.union s (fv_of_expr e)) Id.Set.empty es 109 | | AppCls(e, es) -> List.fold_left (fun s e -> Id.Set.union s (fv_of_expr e)) Id.Set.empty (e :: es) 110 | | AppDir(_, es) -> List.fold_left (fun s e -> Id.Set.union s (fv_of_expr e)) Id.Set.empty es 111 | | Put(e1, e2, e3) -> 112 | Id.Set.union (fv_of_expr e3) & Id.Set.union (fv_of_expr e1) (fv_of_expr e2) 113 | 114 | let rec fv (e, _) = 115 | match e with 116 | | Unit -> Id.Set.empty 117 | | Exp(e) -> fv_of_expr e 118 | | If(e, e1, e2) -> Id.Set.union (fv_of_expr e) (Id.Set.union (fv e1) (fv e2)) 119 | | Match(x, pes) -> (List.fold_left (fun s (p, e) -> Id.Set.diff (Id.Set.union s (fv e)) (vars_of_pattern p)) Id.Set.empty pes) 120 | | Let((x, t), e1, e2) -> Id.Set.union (fv e1) (Id.Set.remove x (fv e2)) 121 | | MakeCls((x, t), { entry = l; actual_fv = ys }, e) -> Id.Set.remove x (Id.Set.union (Id.Set.of_list ys) (fv e)) 122 | 123 | let toplevel : def list ref = ref [] 124 | 125 | let ids_of_defs defs = 126 | List.fold_left 127 | (fun ids def -> 128 | match def with 129 | | VarDef((x, _), _) 130 | | FunDef{ name = (Id.L(x), _); formal_fv = [] } -> x :: ids (* 自由変数がないものは直接呼び出せるためグローバルなIDとして返す *) 131 | | TypeDef _ | FunDef _ -> ids (* 自由変数があるものはクロージャ呼び出し経由での適応となる *) 132 | ) [] defs 133 | 134 | let rec pattern env = 135 | function 136 | | KNormal_t.PtUnit -> env, PtUnit 137 | | KNormal_t.PtBool(b) -> env, PtBool(b) 138 | | KNormal_t.PtInt(n) -> env, PtInt(n) 139 | | KNormal_t.PtFloat v -> env, PtFloat v 140 | | KNormal_t.PtAtom v -> env, PtAtom v 141 | | KNormal_t.PtString v -> env, PtString v 142 | | KNormal_t.PtVar(x, t) -> Id.Map.add x t env, PtVar(x, t) 143 | | KNormal_t.PtAlias (p, x, t) -> 144 | let env', p' = pattern env p in 145 | Id.Map.add x t env', PtAlias (p', x, t) 146 | | KNormal_t.PtTuple(ps) -> 147 | let env, ps' = List.fold_left 148 | (fun (env, ps) p -> 149 | let env', p' = pattern env p in 150 | env', p' :: ps) 151 | (env, []) ps in 152 | env, PtTuple(List.rev ps') 153 | | KNormal_t.PtList(ps) -> 154 | let env, ps' = List.fold_left 155 | (fun (env, ps) p -> 156 | let env', p' = pattern env p in 157 | env', p' :: ps) 158 | (env, []) ps in 159 | env, PtList(List.rev ps') 160 | | KNormal_t.PtCons (p1, p2) -> 161 | let env', p1' = pattern env p1 in 162 | let env'', p2' = pattern env' p2 in 163 | env'', PtCons (p1', p2') 164 | | KNormal_t.PtField(xps) -> 165 | let env, xps' = List.fold_left 166 | (fun (env, xps) (x, p) -> 167 | let env', p' = pattern env p in 168 | env', (x, p') :: xps) 169 | (env, []) xps in 170 | env, PtRecord(List.rev xps') 171 | | KNormal_t.PtConstr(x, ps) -> 172 | let env, ps' = List.fold_left 173 | (fun (env, ps) p -> 174 | let env', p' = pattern env p in 175 | env', p' :: ps) 176 | (env, []) ps in 177 | env, PtConstr(x, List.rev ps') 178 | 179 | let rec h env known (expr, ty) = 180 | Log.debug "Closure.h %s\n" (KNormal.string_of_expr expr); 181 | let e' = 182 | match expr with 183 | | KNormal_t.Bool(b) -> Bool(b) 184 | | KNormal_t.Int(i) -> Int(i) 185 | | KNormal_t.Float v -> Float v 186 | | KNormal_t.Char s -> Char s 187 | | KNormal_t.String s -> String s 188 | | KNormal_t.Atom s -> Atom s 189 | | KNormal_t.Bitstring s -> Bitstring s 190 | | KNormal_t.Record(xes) -> Record(List.map (fun (x, e) -> x, h env known e) xes) 191 | | KNormal_t.Field(e, x) -> Field(h env known e, x) 192 | | KNormal_t.Tuple(es) -> Tuple(List.map (h env known) es) 193 | | KNormal_t.List(es) -> List(List.map (h env known) es) 194 | | KNormal_t.Array(es) -> Array(List.map (h env known) es) 195 | | KNormal_t.Not(e) -> Not(h env known e) 196 | | KNormal_t.Neg(e) -> Neg(h env known e) 197 | | KNormal_t.And(e1, e2) -> And(h env known e1, h env known e2) 198 | | KNormal_t.Or(e1, e2) -> Or(h env known e1, h env known e2) 199 | | KNormal_t.Add(e1, e2) -> Add(h env known e1, h env known e2) 200 | | KNormal_t.Sub(e1, e2) -> Sub(h env known e1, h env known e2) 201 | | KNormal_t.Mul(e1, e2) -> Mul(h env known e1, h env known e2) 202 | | KNormal_t.Div(e1, e2) -> Div(h env known e1, h env known e2) 203 | | KNormal_t.Concat(e1, e2) -> Concat(h env known e1, h env known e2) 204 | | KNormal_t.Eq(e1, e2) -> Eq(h env known e1, h env known e2) 205 | | KNormal_t.LE(e1, e2) -> LE(h env known e1, h env known e2) 206 | | KNormal_t.Var(x) -> Var(x) 207 | | KNormal_t.Constr(x, es) -> Constr(x, List.map (h env known) es) 208 | | KNormal_t.App((KNormal_t.Var(`Local x), ft), ys) when Id.Set.mem x known -> 209 | Log.debug "directly applying %s\n" x; 210 | AppDir(Binding.of_string x, List.map (h env known) ys) 211 | | KNormal_t.App((KNormal_t.Var(`Module x), ft), ys) -> 212 | Log.debug "directly applying %s\n" (Binding.to_string x); 213 | AppDir(x, List.map (h env known) ys) 214 | | KNormal_t.App(e, es) -> 215 | AppCls(h env known e, List.map (h env known) es) 216 | | KNormal_t.ExtFunApp(x, ys) -> 217 | AppDir(Binding.of_string x, List.map (h env known) ys) 218 | | KNormal_t.Get (e1, e2) -> Get (h env known e1, h env known e2) 219 | | KNormal_t.Put (e1, e2, e3) -> 220 | Put (h env known e1, h env known e2, h env known e3) 221 | in 222 | (e', ty) 223 | 224 | let rec g venv known (expr, ty) = (* クロージャ変換ルーチン本体 (caml2html: closure_g) *) 225 | Log.debug "Closure.g %s\n" (KNormal.string_of_term expr); 226 | let expr' = 227 | match expr with 228 | | KNormal_t.Unit -> Unit 229 | | KNormal_t.Exp(e) -> Exp(h venv known e) 230 | | KNormal_t.If(e, e1, e2) -> If(h venv known e, g venv known e1, g venv known e2) 231 | | KNormal_t.Match(x, pes) -> Match(x, (List.map (fun (p, e) -> let env', p' = pattern venv p in p', (g env' known e)) pes)) 232 | | KNormal_t.Let((x, t), e1, e2) -> Let((x, t), g venv known e1, g (Id.Map.add x t venv) known e2) 233 | | KNormal_t.LetRec({ KNormal_t.name = (x, ty_f); KNormal_t.args = yts; KNormal_t.body = e1 }, e2) -> (* 関数定義の場合 (caml2html: closure_letrec) *) 234 | (* 関数定義let rec x y1 ... yn = e1 in e2の場合は、 235 | xに自由変数がない(closureを介さずdirectに呼び出せる) 236 | と仮定し、knownに追加してe1をクロージャ変換してみる *) 237 | let toplevel_backup = !toplevel in 238 | let venv' = Id.Map.add x ty_f venv in 239 | let known' = Id.Set.add x known in 240 | let e1' = g (Id.Map.add_alist yts venv') known' e1 in 241 | (* 本当に自由変数がなかったか、変換結果e1'を確認する *) 242 | (* 注意: e1'にx自身が変数として出現する場合はclosureが必要! 243 | (thanks to nuevo-namasute and azounoman; test/cls-bug2.ml参照) *) 244 | let zs = Id.Set.diff (fv e1') (Id.Set.of_list ((List.map fst yts) @ (ids_of_defs !toplevel))) in 245 | let known', e1' = 246 | if Id.Set.is_empty zs then (Log.debug "function %s doesn't have free variables.\n" x; known', e1') 247 | (* 駄目だったら状態(toplevelの値)を戻して、クロージャ変換をやり直す *) 248 | else (Log.debug "free variable(s) %s found in function %s@.\n" (Id.pp_list (Id.Set.elements zs)) x; 249 | Log.debug "function %s cannot be directly applied in fact@.\n" x; 250 | toplevel := toplevel_backup; 251 | let e1' = g (Id.Map.add_alist yts venv') known e1 in 252 | known, e1') in 253 | let zs = Id.Set.elements (Id.Set.diff (fv e1') (Id.Set.add x (Id.Set.of_list ((List.map fst yts) @ (ids_of_defs !toplevel))))) in 254 | let zts = List.map (fun z -> z, Id.Map.find z venv') zs in (* ここで自由変数zの型を引くために引数venvが必要 *) 255 | toplevel := FunDef{ name = (Id.L(x), ty_f); args = yts; formal_fv = zts; body = e1' } :: !toplevel; (* トップレベル関数を追加 *) 256 | let e2' = g venv' known' e2 in 257 | if Id.Set.mem x (fv e2') then (* xが変数としてe2'に出現するか。ただし、自由変数がないときはクロージャをつくらず関数ポイントとして使用する *) 258 | MakeCls((x, ty_f), { entry = Id.L(x); actual_fv = zs }, e2') (* 出現していたら削除しない *) 259 | else (Log.debug "eliminating closure(s) %s@.\n" x; 260 | fst e2') (* 出現しなければMakeClsを削除 *) in 261 | (expr', ty) 262 | 263 | let f' { Env.venv = venv } e = 264 | let known = Id.Map.fold (fun x _ known -> Id.Set.add x known) venv Id.Set.empty in 265 | g venv known e 266 | 267 | let f defs = 268 | toplevel := []; 269 | ignore (KNormal.fold 270 | (fun ({ Env.venv = venv; tenv = tenv } as env, defs) def -> 271 | let env', def' = 272 | match def with 273 | | KNormal_t.TypeDef(x, t) -> 274 | { env with 275 | Env.venv = Id.Map.add_alist (Type.Tycon.vars t) venv; 276 | Env.tenv = Id.Map.add_alist (Type.Tycon.types t) tenv }, 277 | TypeDef(x, t) 278 | | KNormal_t.VarDef((x, t), e) -> 279 | Env.add_var env x t, (VarDef((x, t), f' env e)) 280 | | KNormal_t.RecDef({ KNormal_t.name = (x, ty_f); args = yts; body = e1 }) -> 281 | let env' = Env.add_var env x ty_f in 282 | env', (FunDef({ name = (Id.L(x), ty_f); args = yts; formal_fv = []; body = f' env' e1 })) in 283 | toplevel := def' :: !toplevel; 284 | (env', def' :: defs)) 285 | !Env.empty defs); 286 | Prog(List.rev !toplevel) 287 | 288 | --------------------------------------------------------------------------------