Setepenre pushed to branch master at Stefan / Typer

Commits: 7d78d71b by Pierre Delaunay at 2016-06-14T20:00:25-04:00 delete dead code + add macro decls test

Changes to be committed: * src/eval.ml : remove dead code * tests/macro_test.ml: new test * btl/types.typer : added properties * src/lparse.ml : added properties * src/debruijn.ml : * new function (add_property) * new function (dump_properties) * src/debug_util.ml: * new debug option (dump-prop)

- - - - -

7 changed files:

- btl/types.typer - src/builtin.ml - src/debruijn.ml - src/debug_util.ml - src/eval.ml - src/lparse.ml - tests/macro_test.ml

Changes:

===================================== btl/types.typer ===================================== --- a/btl/types.typer +++ b/btl/types.typer @@ -150,7 +150,7 @@ 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);

===================================== src/builtin.ml ===================================== --- a/src/builtin.ml +++ b/src/builtin.ml @@ -161,7 +161,9 @@ let rec tlist2olist acc expr = tlist2olist (hd::acc) tl | Vcons((_, "nil"), []) -> List.rev acc | _ -> + print_string (value_name expr); print_string "\n"; value_print expr; + builtin_error dloc "List conversion failure'"

let make_node loc args_val ctx =

===================================== src/debruijn.ml ===================================== --- a/src/debruijn.ml +++ b/src/debruijn.ml @@ -203,3 +203,71 @@ let replace_by ctx name by = let nenv = List.fold_left (fun ctx elem -> cons elem ctx) nenv decls in (a, nenv, b)

+(* -------------------------------------------------------------------------- *) +(* PropertyMap *) +(* -------------------------------------------------------------------------- *) + + +let add_property ctx (var_n, var_i) (att_n, att_i) (prop: lexp) + : lexp_context = + + let (a, b, property_map) = ctx in + let n = get_size ctx in + + (* get_var properties *) + let vmap = try PropertyMap.find (var_i, var_n) property_map + with Not_found -> PropertyMap.empty in + + (* add property *) + let nvmap = PropertyMap.add (n - att_i, att_n) prop vmap in + + (* update properties *) + let property_map = PropertyMap.add (n - var_i, var_n) nvmap property_map in + + (a, b, property_map) + + +let dump_properties ctx = + let (a, b, property_map) = ctx in + print_string (make_title " Properties "); + + make_rheader [ + (Some ('l', 10), "V-NAME"); + (Some ('l', 4), "RIDX"); + (Some ('l', 10), "P-NAME"); + (Some ('l', 4), "RIDX"); + (Some ('l', 32), "LEXP")]; + + print_string (make_sep '-'); + + PropertyMap.iter (fun (var_i, var_n) pmap -> + print_string " | "; + lalign_print_string var_n 10; print_string " | "; + ralign_print_int var_i 4; print_string " | "; + let first = ref true in + + PropertyMap.iter (fun (att_i, att_n) lxp -> + (if (!first = false) then + print_string (make_line ' ' 20) + else + first := false); + + lalign_print_string att_n 10; print_string " | "; + ralign_print_int att_i 4; print_string " : "; + lexp_print lxp; print_string "\n") pmap) property_map; + + print_string (make_sep '-'); + + + + + + + + + + + + + +

===================================== src/debug_util.ml ===================================== --- a/src/debug_util.ml +++ b/src/debug_util.ml @@ -321,6 +321,10 @@ let main () =

) flexps));

+ (if (get_p_option "dump-prop") then( + dump_properties ctx; + print_string "\n")); + (* get typecheck context *) let lctx_to_cctx (lctx: lexp_context) = let (_, env, _) = ctx in env in

===================================== src/eval.ml ===================================== --- a/src/eval.ml +++ b/src/eval.ml @@ -106,7 +106,7 @@ let rec _eval lxp ctx i: (value_type) =

and get_predef_eval name ctx = - let r = (get_rte_size ctx) - !builtin_size + 1in + let r = (get_rte_size ctx) - !builtin_size in let v = mkSusp (get_predef name) (S.shift r) in _eval (erase_type v) ctx 0

@@ -241,9 +241,8 @@ and typer_builtins_impl = [ ("run-io" , run_io); ("read" , read_impl); ("write" , write_impl); - ("new-attribute" , new_attribute) - ] + and bind_impl loc args_val ctx =

let io, cb = match args_val with @@ -395,45 +394,3 @@ let from_lctx (ctx: lexp_context) rm: runtime_env = done;

!rctx - - (* let ((n, _), env, _) = ctx in - let rctx = ref make_runtime_ctx in - - let bsize = 0 in - let csize = n - 1 in - - (* add all variables * ) - for i = bsize to csize do - let name = match (Myers.nth (csize - i) env) with - | (_, Some (_, name), _, _) -> Some name - | _ -> None in - - rctx := add_rte_variable name Vdummy (!rctx) - done; *) - - let diff = csize - bsize in - - (* process all of them *) - for i = 0 to diff do - try - let j = diff - i (* - 1 *) in - let name, exp = match Myers.nth (csize - i) env with - | (_, Some (_, name), LetDef exp, _) -> Some name, Some exp - | _ -> None, None in - - let vxp = match exp with - | Some lxp -> - let lxp = (erase_type lxp) in - (try (eval lxp !rctx) - with e -> elexp_print lxp; - print_string "\n"; raise e) - - | None -> Vdummy in - rctx := add_rte_variable name vxp (!rctx) - - with Not_found -> - print_int n; print_string " "; - print_int (csize - i); print_string "\n "; - raise Not_found - done; - !rctx *)

===================================== src/lparse.ml ===================================== --- a/src/lparse.ml +++ b/src/lparse.ml @@ -462,9 +462,7 @@ and lexp_call (fun_name: pexp) (sargs: sexp list) ctx i = lexp_fatal loc ("Could not find Variable: " ^ name) in

(* Get the macro *) - let lxp = try env_lookup_expr ctx ((loc, name), idx) (* with - | e -> e - | _ -> lexp_fatal loc "The macro cannot be expanded"; *) + let lxp = try env_lookup_expr ctx ((loc, name), idx) with Not_found -> lexp_fatal loc (name ^ " was found but " ^ (string_of_int idx) ^ " is not a correct index.") in @@ -515,6 +513,18 @@ and lexp_call (fun_name: pexp) (sargs: sexp list) ctx i = let new_args = List.map (fun g -> (Aexplicit, g)) largs in Call(body, new_args), ltp

+ (* attribute *) + | Pvar(l, "new-attribute"), _ -> + let pargs = List.map pexp_parse sargs in + let largs = _lexp_parse_all pargs ctx i in + + let eltp = match largs with + | [eltp] -> eltp + | _ -> lexp_warning l "new-attribute expects one argument"; + dltype in + + eltp, ltp + | (Pvar (l, n), Var((_, "Macro"), _)) -> (* FIXME: check db_idx points too a Macro type *) handle_macro_call (l, n) @@ -533,9 +543,9 @@ and lexp_call (fun_name: pexp) (sargs: sexp list) ctx i = Call(body, new_args), ltp

| e, _ -> - pexp_print e; print_string "\n"; - print_string ((pexp_to_string e) ^ "\n"); - lexp_fatal (pexp_location e) "This expression cannot be called" + pexp_print e; print_string "\n"; + print_string ((pexp_to_string e) ^ "\n"); + lexp_fatal (pexp_location e) "This expression cannot be called"

(* Read a pattern and create the equivalent representation *) @@ -622,7 +632,7 @@ and lexp_parse_inductive ctors ctx i =

(* Macro declaration handling, return a list of declarations * to be processed *) -and lexp_decls_macro (loc, mname) sargs ctx: pdecl list = +and lexp_decls_macro (loc, mname) sargs ctx: (pdecl list * lexp_context) = (* lookup for mname_ *) let idx = try senv_lookup mname ctx with Not_found -> @@ -642,26 +652,43 @@ and lexp_decls_macro (loc, mname) sargs ctx: pdecl list = lexp_print lxp; print_string "\n"; lexp_fatal loc "Macro is ill formed" in

- (* build new function *) - let arg = olist2tlist_lexp sargs ctx in - let lxp = Call(lxp, [(Aexplicit, arg)]) in - let elexp = EL.erase_type lxp in - let rctx = (from_lctx ctx 0) in + match lxp with + | Var((_, "add-attribute"), _) ->( + (* Builtin macro *) + let pargs = List.map pexp_parse sargs in + let largs = _lexp_parse_all pargs ctx 0 in + + (* extract info *) + let var, att, fn = match largs with + | [Var((_, vn), vi); Var((_, an), ai); fn] -> (vn, vi), (an, ai), fn + | _ -> lexp_fatal loc "add-attribute expects 3 args" in + + let ctx = add_property ctx var att fn in + + [], ctx + ) + (* Standard Macro *) + | _ -> ( + (* build new function *) + let arg = olist2tlist_lexp sargs ctx in + let lxp = Call(lxp, [(Aexplicit, arg)]) in + let elexp = EL.erase_type lxp in + let rctx = (from_lctx ctx 0) in

- (* get a list of declaration *) - let decls = eval elexp rctx in + (* get a list of declaration *) + let decls = eval elexp rctx in

- (* convert typer list to ocaml *) - let decls = tlist2olist [] decls in + (* convert typer list to ocaml *) + let decls = tlist2olist [] decls in

- (* extract sexp from result *) - let decls = List.map (fun g -> - match g with - | Vsexp(sxp) -> sxp - | _ -> lexp_fatal loc "Macro expects sexp list") decls in + (* extract sexp from result *) + let decls = List.map (fun g -> + match g with + | Vsexp(sxp) -> sxp + | _ -> lexp_fatal loc "Macro expects sexp list") decls in

- (* read as pexp_declaraton *) - pexp_decls_all decls + (* read as pexp_declaraton *) + pexp_decls_all decls, ctx)

(* Parse let declaration *) and lexp_p_decls decls ctx = _lexp_decls decls ctx 0 @@ -753,7 +780,7 @@ and _lexp_decls decls ctx i: ((vdef * lexp * ltype) list list * lexp_context) = (* Special case *) | [Lmcall ((l, s), sargs)] -> (* get pexp decls *) - let pdecls = lexp_decls_macro (l, s) sargs ctx in + let pdecls, ctx = lexp_decls_macro (l, s) sargs ctx in let decls, ctx = _lexp_decls pdecls ctx i in all := (List.append (List.rev decls) !all); ctx

===================================== tests/macro_test.ml ===================================== --- a/tests/macro_test.ml +++ b/tests/macro_test.ml @@ -66,5 +66,33 @@ let _ = (add_test "MACROS" "macros base" (fun () -> )

+let _ = (add_test "MACROS" "macros decls" (fun () -> + reset_eval_trace (); + + let dcode = " + decls-impl = lambda (x : List Sexp) -> + cons (node_ (symbol_ "_=_") + (cons (symbol_ "a") (cons (integer_ 1) nil))) + (cons (node_ (symbol_ "_=_") + (cons (symbol_ "b") (cons (integer_ 2) nil))) nil); + + my-decls = Macro_ decls-impl; + + my-decls Nat;" in + + let rctx, lctx = eval_decl_str dcode lctx rctx in + + let ecode = "a; b;" in + + let ret = eval_expr_str ecode lctx rctx in + + match ret with + | [Vint(a); Vint(b)] -> + if (a = 1 && b = 2) then success () else failure () + + | _ -> failure ()) +) + + (* run all tests *) let _ = run_all ()

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