Setepenre pushed to branch master at Stefan / Typer

Commits: d5da7869 by Pierre Delaunay at 2016-06-25T18:35:09-04:00 new calling convention for builtin functions (location -> int -> value_type list -> runtime_env -> value_type) ^~~~^ new

This allows us to have a more accurate call trace when eval is called inside a builtin-function.

Changes to be committed: * btl/types.typer * src/builtin.ml * src/eval.ml

- - - - -

4 changed files:

- .travis.yml - btl/types.typer - src/builtin.ml - src/eval.ml

Changes:

===================================== .travis.yml ===================================== --- a/.travis.yml +++ b/.travis.yml @@ -8,6 +8,7 @@ sudo: true before_script: - sudo apt-get -qq update - sudo apt-get install opam + - opam init - opam config setup -a - opam config env

===================================== btl/types.typer ===================================== --- a/btl/types.typer +++ b/btl/types.typer @@ -153,10 +153,10 @@ read = Built-in "read" (FileHandle -> Int -> IO String); Attribute = Built-in "Attribute"; new-attribute = Built-in "new-attribute" (Type -> Attribute);

-add-attribute = Built-in "add-attribute" (Sexp -> Sexp -> Sexp -> List Sexp); +add-attribute = Built-in "add-attribute" (Sexp -> Sexp -> Sexp -> List Sexp); attribute = Macro_ add-attribute;

-get-attribute = Built-in "get-attribute" (String -> Attribute); +get-attribute = Built-in "get-attribute" Macro; has-attribute = Built-in "has-attribute" (String -> Attribute -> Bool);

% -----------------------------------------------------

===================================== src/builtin.ml ===================================== --- a/src/builtin.ml +++ b/src/builtin.ml @@ -97,7 +97,7 @@ let type_float = Builtin((dloc, "Float"), type0) let type_string = Builtin((dloc, "String"), type0)

(* Builtin of builtin * string * ltype *) -let _generic_binary_iop name f loc (args_val: value_type list) +let _generic_binary_iop name f loc (depth: int) (args_val: value_type list) (ctx: runtime_env) =

let l, r = match args_val with @@ -117,11 +117,11 @@ let idiv_impl = _generic_binary_iop "Integer::div" (fun a b -> a / b)

(* loc is given by the compiler *) -let none_fun : (location -> value_type list -> runtime_env -> value_type) +let none_fun : (location -> int -> value_type list -> runtime_env -> value_type) = (fun loc args_val ctx -> builtin_error loc "Requested Built-in was not implemented")

-let make_symbol loc args_val ctx = +let make_symbol loc depth args_val ctx = (* symbol is a simple string *) let lxp = match args_val with | [r] -> r @@ -166,7 +166,7 @@ let rec tlist2olist acc expr =

builtin_error dloc "List conversion failure'"

-let make_node loc args_val ctx = +let make_node loc depth args_val ctx =

let op, tlist = match args_val with | [Vsexp(op); lst] -> op, lst @@ -190,7 +190,7 @@ let make_node loc args_val ctx =

Vsexp(Node(op, s))

-let make_string loc args_val ctx = +let make_string loc depth args_val ctx = let lxp = match args_val with | [r] -> r | _ -> builtin_error loc ("string_ expects 1 argument") in @@ -199,7 +199,7 @@ let make_string loc args_val ctx = | Vstring(str) -> Vsexp(String(loc, str)) | _ -> builtin_error loc ("string_ expects one string as argument")

-let make_integer loc args_val ctx = +let make_integer loc depth args_val ctx = let lxp = match args_val with | [r] -> r | _ -> builtin_error loc ("integer_ expects 1 argument") in @@ -208,24 +208,24 @@ let make_integer loc args_val ctx = | Vint(str) -> Vsexp(Integer(loc, str)) | _ -> builtin_error loc ("integer_ expects one string as argument")

-let make_float loc args_val ctx = Vdummy -let make_block loc args_val ctx = Vdummy +let make_float loc depth args_val ctx = Vdummy +let make_block loc depth args_val ctx = Vdummy

let ttrue = Vcons((dloc, "True"), []) let tfalse = Vcons((dloc, "False"), []) let btyper b = if b then ttrue else tfalse

-let string_eq loc args_val ctx = +let string_eq loc depth args_val ctx = match args_val with | [Vstring(s1); Vstring(s2)] -> btyper (s1 = s2) | _ -> builtin_error loc "string_eq expects 2 strings"

-let int_eq loc args_val ctx = +let int_eq loc depth args_val ctx = match args_val with | [Vint(s1); Vint(s2)] -> btyper (s1 = s2) | _ -> builtin_error loc "int_eq expects 2 integer"

-let sexp_eq loc args_val ctx = +let sexp_eq loc depth args_val ctx = match args_val with | [Vsexp(s1); Vsexp(s2)] -> ( match s1, s2 with @@ -237,7 +237,7 @@ let sexp_eq loc args_val ctx = | _ -> builtin_error loc "int_eq expects 2 sexp"

-let open_impl loc args_val ctx = +let open_impl loc depth args_val ctx =

let file, mode = match args_val with | [Vstring(file_name); Vstring(mode)] -> file_name, mode @@ -250,7 +250,7 @@ let open_impl loc args_val ctx = | "w" -> Vout(open_out file) | _ -> builtin_error loc "wrong open mode")

-let read_impl loc args_val ctx = +let read_impl loc depth args_val ctx =

let channel = match args_val with | [Vin(c); _] -> c @@ -261,7 +261,7 @@ let read_impl loc args_val ctx = let line = input_line channel in Vstring(line)

-let write_impl loc args_val ctx = +let write_impl loc depth args_val ctx =

let channel, msg = match args_val with | [Vout(c); Vstring(msg)] -> c, msg

===================================== src/eval.ml ===================================== --- a/src/eval.ml +++ b/src/eval.ml @@ -135,7 +135,7 @@ and eval_call ctx i lname eargs =

| Vbuiltin (str), args -> (* lookup the built-in implementation and call it *) - (get_builtin_impl str loc) loc args ctx + (get_builtin_impl str loc) loc (i + 1) args ctx

(* return result of eval *) | _, [] -> f @@ -239,7 +239,7 @@ and typer_builtins_impl = [ ("write" , write_impl); ]

-and bind_impl loc args_val ctx = +and bind_impl loc depth args_val ctx =

let io, cb = match args_val with | [io; callback] -> io, callback @@ -264,9 +264,9 @@ and bind_impl loc args_val ctx = let nctx = add_rte_variable None underlying ctx in

(* eval callback *) - _eval body nctx 0) + _eval body nctx depth)

-and run_io loc args_val ctx = +and run_io loc depth args_val ctx =

let io, ltp = match args_val with | [io; ltp] -> io, ltp @@ -282,14 +282,14 @@ and run_io loc args_val ctx = (* return given type *) ltp

-and typer_eval loc args ctx = +and typer_eval loc depth args ctx = let arg = match args with | [a] -> a | _ -> eval_error loc "eval_ expects a single argument" in (* I need to be able to lexp sexp but I don't have lexp ctx *) match arg with (* Nodes that can be evaluated *) - | Closure (_, body, ctx) -> _eval body ctx 1 + | Closure (_, body, ctx) -> _eval body ctx depth (* Leaf *) | _ -> arg

@@ -308,7 +308,7 @@ and get_builtin_impl str loc = (* Sexp -> (Sexp -> List Sexp -> Sexp) -> (String -> Sexp) -> (String -> Sexp) -> (Int -> Sexp) -> (Float -> Sexp) -> (List Sexp -> Sexp) -> Sexp *) -and sexp_dispatch loc args ctx = +and sexp_dispatch loc depth args ctx = let eval a b = _eval a b 1 in let sxp, nd, sym, str, it, flt, blk, rctx = match args with | [sxp; Closure(_, nd, rctx); Closure(_, sym, _);

View it on GitLab: https://gitlab.com/monnier/typer/commit/d5da7869ce48357edc95ab4d2bebc5b4e1bb...