Setepenre pushed to branch master at Stefan / Typer

Commits: 3be5ffe6 by Pierre Delaunay at 2016-04-29T12:21:49-04:00 Fix Macro handling. Removed some dead code

Changes to be committed: * src/lparse.ml

- - - - -

10 changed files:

- btl/list.typer - samples/macro.typer - samples/nat.typer - src/builtin.ml - src/debug.ml - src/env.ml - src/eval.ml - src/lexp.ml - src/lparse.ml - tests/eval_test.ml

Changes:

===================================== btl/list.typer ===================================== --- a/btl/list.typer +++ b/btl/list.typer @@ -25,4 +25,6 @@ tail = lambda a => lambda xs -> case xs | nil => nil - | cons hd tl => tl; \ No newline at end of file + | cons hd tl => tl; + +

===================================== samples/macro.typer ===================================== --- a/samples/macro.typer +++ b/samples/macro.typer @@ -11,4 +11,4 @@ give_type = lambda expr ->

sqr = Macro_ (give_type sqr_fun sqr_type);

-main = (sqr 2); \ No newline at end of file +main = (sqr 2);

===================================== samples/nat.typer ===================================== --- a/samples/nat.typer +++ b/samples/nat.typer @@ -25,8 +25,6 @@ n1 = (to-num zero); n2 = (to-num one); n3 = (to-num two);

- - -m1 = (to-num (plus zero two)); % 2 +m1 = (to-num (plus zero two)); % 2 m2 = (to-num (plus two zero)); % 2 m3 = (to-num (plus two one)); % 3 \ No newline at end of file

===================================== src/builtin.ml ===================================== --- a/src/builtin.ml +++ b/src/builtin.ml @@ -85,17 +85,14 @@ let builtin_fmult = Builtin (FMult, "_*_", fop_binary) *)

(* Builtin of builtin * string * ltype *) let _generic_binary_iop name f loc (args_val: value_type list) (ctx: runtime_env) = - (* We don't have to access context because: *) - (* x + y is parsed as Call(_+_ x y) *) - (* Partial application handling aggregates arguments in a ctx *) - (* once all arguments are present Call(_+_ x y) is called *) - (* First, its arguments are evaluated which is where x, y are replaced *) - (* by their value in the context then _generic_binary_iop handle the function *) - (* i.e we don't need to push x and y in the context. *) - (* We don't even need the context *) - let l, r = match args_val with - | [a; b] -> a, b - | _ -> builtin_error loc (name ^ " expects 2 arguments") in + + (* + let l, r = get_rte_variable None 0 ctx, + get_rte_variable None 1 ctx in *) + + let l, r = match args_val with + | [l; r] -> l, r + | _ -> builtin_error loc (name ^ " expects 2 Integers arguments") in

match l, r with | Vint(v), Vint(w) -> Vint(f v w) @@ -169,13 +166,12 @@ let builtin_float = Builtin (SexpType, "float_", type_mfloat) let builtin_node = Builtin (SexpType, "node_", type_mnode) (* let builtin_expand = Builtin (SexpType, "expand_", type_mexpand) *)

-let type_macro = - let ctors = SMap.empty in - let ctors = SMap.add "Macro_" [(Aexplicit, None, type_sexp)] ctors in - Inductive (dloc, (dloc, "built-in"), [], ctors)

let builtin_macro = Cons (((dloc, "Macro"), (-4)), (dloc, "Macro_")) -let macro_cons = Arrow (Aexplicit, None, type_sexp , dloc, type_macro) +let type_macro = Builtin (MacroType, "Macro", type0) +let macro_cons = Arrow (Aexplicit, None, type_sexp, dloc, type_macro) + + (* * Should we have a function that * -> returns a new context inside typer ? (So we need to add a ctx type too) @@ -222,7 +218,7 @@ let _builtin_lookup = SMap.empty typer_builtins

-let get_builtin_impl btype str ltp loc = +let get_builtin_impl btype str loc = try SMap.find str _builtin_lookup with Not_found -> builtin_error loc "Requested Built-in does not exist"

===================================== src/debug.ml ===================================== --- a/src/debug.ml +++ b/src/debug.ml @@ -189,25 +189,35 @@ let str_split str sep = List.rev (!ret));;

let debug_lexp_decls decls = - + let sep = " : " in List.iter (fun e -> let ((loc, name), lxp, ltp) = e in

print_string " "; lalign_print_string (lexp_to_string lxp) 15; - print_string "["; print_loc loc; print_string "] "; + print_string "["; print_loc loc; print_string "]";

let str = _lexp_str_decls (!debug_ppctx) [e] in

+ (* First col size = 15 + 1 + 2 + 3 + 5 + 6 + * = 32 *) + let str = match str with - | hd::tl -> print_string hd; print_string "\n"; tl + | fst::tl -> print_string (sep ^ fst); print_string "\n"; tl | _ -> [] in

(* inefficient but makes things pretty iff -fmt-pretty=on *) let str = List.flatten (List.map (fun g -> str_split g '\n') str) in

+ let str = match str with + | scd::tl -> + print_string " FILE: "; + lalign_print_string loc.file 25; + print_string (sep ^ scd); print_string "\n"; tl + | _ -> [] in + List.iter (fun g -> - print_string (make_line ' ' 34); + print_string ((make_line ' ' 32) ^ sep); print_string g; print_string "\n") str;

===================================== src/env.ml ===================================== --- a/src/env.ml +++ b/src/env.ml @@ -54,7 +54,7 @@ type value_type = | Vint of int | Vstring of string | Vcons of symbol * value_type list - | Vbuiltin + | Vbuiltin of builtin * string | Closure of lexp * (((string option * value_type) ref myers) * (int * int)) (* Macro type *) | Vsexp of sexp @@ -74,11 +74,8 @@ let rec value_print (vtp: value_type) = List.iter (fun arg -> print_string " "; value_print arg) args; print_string ")";

- + | Vbuiltin(_, str) -> print_string str | Vdummy -> print_string "value_print_dummy" - | Vbuiltin -> print_string "value_print_builtin" - | _ -> print_string "value_print_bug" -

let value_location (vtp: value_type) = match vtp with @@ -178,9 +175,10 @@ let temp_ctx (ctx: runtime_env): runtime_env = let (l, (osize, _)) = ctx in let tsize = length l in (* Check if temporary variables are present *) - if tsize != osize then - (* remove them *) - (select_n ctx osize) + if tsize != osize then( + (* remove them + print_string "temp ctx was useful\n"; *) + (select_n ctx osize)) else ctx ;;

===================================== src/eval.ml ===================================== --- a/src/eval.ml +++ b/src/eval.ml @@ -74,14 +74,14 @@ let rec _eval lxp ctx i: (value_type) = match lxp with (* Leafs *) (* ---------------- *) - | Imm(Integer (_, i)) -> Vint(i) - | Imm(String (_, s)) -> Vstring(s) - | Inductive (_, _, _, _) -> Vdummy - | Cons (_, label) -> Vcons (label, []) - | Lambda (_, _, _, lxp) -> Closure(lxp, ctx) - | Builtin _ -> Vbuiltin - - (* Return a value stored in the env *) + | Imm(Integer (_, i)) -> Vint(i) + | Imm(String (_, s)) -> Vstring(s) + | Inductive (_, _, _, _) -> Vdummy + | Cons (_, label) -> Vcons (label, []) + | Lambda (_, _, _, lxp) -> Closure(lxp, ctx) + | Builtin (btype, str, _) -> Vbuiltin(btype, str) + + (* Return a value stored in env *) | Var((loc, name), idx) as e -> eval_var ctx e ((loc, name), idx)

(* Nodes *) @@ -90,22 +90,12 @@ let rec _eval lxp ctx i: (value_type) = let nctx = _eval_decls decls ctx i in _eval inst nctx (i + 1)

- (* Built-in Function *) - | Call(Builtin(btype, str, ltp), args)-> - (* built-in does not have location info. So we extract it from args *) - let tloc = match args with - | (_, hd)::tl -> lexp_location hd - | _ -> dloc in - let args_val = List.map (fun (k, e) -> _eval e ctx (i + 1)) args in - (get_builtin_impl btype str ltp tloc) tloc args_val ctx - (* Function call *) - | Call (lname, args) as call -> eval_call ctx i lname args call + | Call (lname, args) -> eval_call ctx i lname args

(* Case *) | Case (loc, target, _, pat, dflt) -> (eval_case ctx i loc target pat dflt)

- | _ -> print_string "debug catch-all eval: "; lexp_print lxp; Vstring("eval Not Implemented")

@@ -115,16 +105,30 @@ and eval_var ctx lxp v = with e -> eval_error loc ("Variable: " ^ name ^ (str_idx idx) ^ " was not found ")

-and eval_call ctx i lname args call = - (* create a clean environment *) - let args_val = List.map (fun (k, e) -> _eval e ctx (i + 1)) args in - let clean_ctx = temp_ctx ctx in +and eval_call ctx i lname args = + let loc = lexp_location lname in + let args = List.map (fun (k, e) -> _eval e ctx (i + 1)) args in + let f = _eval lname ctx (i + 1) in + + (* + let eval_call' f arg = + match f with + | Vcons(label, fields) -> + Vcons (label, arg::fields) + + | Closure (lxp, ctx) -> + _eval lxp (add_rte_variable None arg ctx) (i + 1) + + | Vbuiltin (btype, str) -> + (get_builtin_impl btype str loc) loc [] (add_rte_variable None arg ctx)

- (* get function body *) - let body = _eval lname ctx (i + 1) in + | _ -> value_print f; + eval_error loc "Cannot eval function" in

- let rec eval_call body args ctx = - match body, args with + List.fold_left eval_call' f args *) + + let rec eval_call f args ctx = + match f, args with | Vcons (n, []), _ -> Vcons(n, args)

(* we add an argument to the closure *) @@ -133,16 +137,18 @@ and eval_call ctx i lname args call = let ret = _eval lxp nctx (i + 1) in eval_call ret tl nctx

- (* No more arguments *) - | Closure (_, _), [] -> body + | Vbuiltin (btype, str), args -> + (* lookup the built-in implementation and call it *) + (get_builtin_impl btype str loc) loc args ctx

(* return result of eval *) - | _, [] -> body + | Closure (_, _), [] -> f + | _, [] -> f

- | _ -> value_print body; - eval_error dloc "Cannot eval function" in + | _ -> value_print f; + eval_error loc "Cannot eval function" in

- eval_call body args_val clean_ctx + eval_call f args ctx

and eval_case ctx i loc target pat dflt = (* Eval target *) @@ -160,7 +166,7 @@ and eval_case ctx i loc target pat dflt = (* -- Crash -- *) eval_error loc "Target is not a Constructor" in

- let ctor_n = List.length args in + (* let ctor_n = List.length args in *)

(* Check if a default is present *) let run_default df = @@ -186,7 +192,8 @@ and eval_case ctx i loc target pat dflt = (* Get working pattern *) let key, (_, pat_args, exp) = SMap.min_binding sol in

- (* build context (List.fold2 has problem with some cases) *) + (* build context (List.fold2 has problem with some cases) *) + (* This is more robust *) let rec fold2 nctx pats args = match pats, args with | (Some (_, (_, name)))::pats, arg::args -> @@ -267,9 +274,9 @@ let eval_all lxps rctx silent = (* build a rctx from a lctx *) let from_lctx (ctx: lexp_context): runtime_env = let ((_, _), env, _) = ctx in - let rctx = ref (default_rctx ()) in + let rctx = ref make_runtime_ctx in

- (* Skip builtins *) + (* Skip builtins: They are already in default_rctx() *) let bsize = List.length typer_builtins in let csize = get_size ctx in

@@ -295,7 +302,3 @@ let from_lctx (ctx: lexp_context): runtime_env = rctx := set_rte_variable j (Some name) vxp (!rctx) done; !rctx - - - -

===================================== src/lexp.ml ===================================== --- a/src/lexp.ml +++ b/src/lexp.ml @@ -622,14 +622,19 @@ and _lexp_to_str ctx exp =

| Call(fname, args) -> ( (* get function name *) - let str, idx = match fname with - | Var((_, name), idx) -> name, idx - | Builtin (_, name, _) -> name, 0 - | _ -> (error "unkwn"), -1 in + let str, idx, inner_parens, outer_parens = match fname with + | Var((_, name), idx) -> name, idx, false, true + | Builtin (_, name, _) -> name, 0, false, true + | Lambda _ -> "__", 0, true, false + | Cons _ -> "__", 0, false, false + | _ -> "__", -1, true, true in

let binop_str op (_, lhs) (_, rhs) = (lexp_to_str lhs) ^ op ^ (lexp_to_str rhs) in

+ let add_parens bl str = + if bl then "(" ^ str ^ ")" else str in + match (str, args) with (* Special Operators *) | ("_=_", [lhs; rhs]) -> binop_str " = " lhs rhs @@ -643,7 +648,10 @@ and _lexp_to_str ctx exp = (fun str (_, lxp) -> str ^ " " ^ (lexp_to_str lxp)) "" args in

- "(" ^ (fun_call (lexp_to_str fname)) ^ args ^ ")") + let str = fun_call (lexp_to_str fname) in + let str = add_parens inner_parens str in + let str = str ^ args in + add_parens outer_parens str)

| Inductive (_, (_, name), [], ctors) -> (keyword "inductive_") ^ " (" ^ name ^") " ^

===================================== src/lparse.ml ===================================== --- a/src/lparse.ml +++ b/src/lparse.ml @@ -339,12 +339,12 @@ and lexp_call (fun_name: pexp) (sargs: sexp list) ctx i = let new_args = List.map (fun g -> (Aexplicit, g)) largs in

(* consume Arrows and args together *) - let rec get_return_type i ltp args = + let rec get_return_type name i ltp args = match ltp, args with | _, [] -> ltp - | Arrow(_, _, _, _, ltp), hd::tl -> (get_return_type (i + 1) ltp tl) + | Arrow(_, _, _, _, ltp), hd::tl -> (get_return_type name (i + 1) ltp tl) | _, _ -> lexp_warning loc - ("Function was provided with too many args. Expected: " ^ + (name ^ " was provided with too many args. Expected: " ^ (string_of_int i)); ltp in

(* Vanilla : sqr is inferred and (lambda x -> x * x) is returned @@ -354,13 +354,13 @@ and lexp_call (fun_name: pexp) (sargs: sexp list) ctx i =

(* retrieve function's body *) let body, ltp = _lexp_p_infer fun_name ctx (i + 1) in - let ret_type = get_return_type 0 ltp new_args in + (* let ret_type = get_return_type 0 ltp new_args in *)

- (* handle named functions*) - let named_call (loc, name) = + let handle_named_call (loc, name) = try (* Check if the function was defined *) let idx = senv_lookup name ctx in let vf = (make_var name idx loc) in + let ret_type = get_return_type name 0 ltp new_args in

(* Replace a built-in name by builtin so they can be recognized * during eval *) @@ -378,131 +378,53 @@ and lexp_call (fun_name: pexp) (sargs: sexp list) ctx i = let vf = (make_var name (-1) loc) in Call(vf, new_args), ltp in

- (* determine function type *) - match fun_name, ltp with - (* Anonymous *) - | ((Plambda _), _) -> Call(body, new_args), ltp - - (* Call to a macro *) - | (Pvar (loc, name), Inductive _) -> - (* look up for definition *) - let idx = senv_lookup name ctx in - let vf = (make_var name idx loc) in + let handle_macro_call (loc, name) = + (* look up for definition *) + let idx = try senv_lookup name ctx + with Not_found -> + lexp_fatal loc ("Could not find Variable: " ^ name) in

- (* Get the macro *) - let lxp = match env_lookup_expr ctx ((loc, name), idx) with - | None -> lexp_fatal loc "The macro cannot be expanded"; - | Some e -> e in + (* Get the macro *) + let lxp = try match env_lookup_expr ctx ((loc, name), idx) with + | None -> lexp_fatal loc "The macro cannot be expanded"; + | Some e -> e + with Not_found -> + lexp_fatal loc (name ^ " was found but " ^ (string_of_int idx) ^ + " is not a correct index.") in

- print_string "HERE"; + let rctx = try (from_lctx ctx) + with e -> + lexp_fatal loc "Could not convert lexp context into rte context" in

- let rctx = (from_lctx ctx) in + let sxp = match eval lxp rctx with + (* (Macro_ sexp) is returned *) + | Vcons(_, [Vsexp(sxp)]) -> sxp + | v -> value_print v; print_string "\n"; + lexp_fatal loc "Macro_ expects sexp" in

- print_string "HERE"; + let pxp = pexp_parse sxp in + (* Generated Code *) + let lxp, ltp = _lexp_p_infer pxp ctx (i + 1) in + Call(lxp, new_args), ltp in

- let sxp = match eval lxp rctx with - | Vsexp(sxp) -> sxp - | v -> value_print v; - lexp_fatal loc "Macro_ expects sexp" in + (* determine function type *) + match fun_name, ltp with + (* Anonymous *) + | ((Plambda _), _) -> Call(body, new_args), ltp

- let pxp = pexp_parse sxp in - (* Generated Code *) - let lxp, ltp = _lexp_p_infer pxp ctx (i + 1) in - Call(lxp, new_args), ltp + (* Call to a macro *) + | (Pvar (l, n), Builtin(tp, "Macro", _)) when tp = MacroType -> + handle_macro_call (l, n)

(* Call to Vanilla or constructor *) - | (Pvar v, _) -> named_call v + | (Pvar v, _) -> handle_named_call v

(* Constructor. This case is rarely used *) - | (Pcons(_, v), _) -> named_call v + | (Pcons(_, v), _) -> handle_named_call v

| e, _ -> lexp_fatal (pexp_location e) "This expression cannot be called"

- (* - (* Process Arguments *) - let pargs = List.map pexp_parse _args in - let largs = _lexp_parse_all pargs ctx i in - let new_args = List.map (fun g -> (Aexplicit, g)) largs in - - (* check if anonymous *) - match fname with - (* arg_kind * pvar * pexp option * pexp *) - | Plambda _ -> let lbd, ltype = _lexp_p_infer fname ctx (i + 1) in - Call(lbd, new_args), ltype - - | _ -> begin - - (* get function name *) - let name, loc = match fname with - | Pvar(loc, nm) -> nm, loc - | Pcons (_, (loc, nm)) -> nm, loc - | _-> - lexp_fatal (pexp_location fname) "This expression cannot be called" in - - (* retrieve function body *) - let body, ltp = _lexp_p_infer fname ctx (i + 1) in - - (* Check if macro *) - let _ = match ltp with - | Inductive (_, (_, "built-in"), [], _) -> lexp_print body; print_string "\n"; - | _ -> () in - - try - - (* Check if the function was defined *) - let idx = senv_lookup name ctx in - let vf = (make_var name idx loc) in - - (* consume Arrows and args together *) - let rec get_return_type i ltp args = - match ltp, args with - | _, [] -> ltp - | Arrow(_, _, _, _, ltp), hd::tl -> (get_return_type (i + 1) ltp tl) - | _, _ -> lexp_warning loc ("""^ name ^ - "" was provided with too many args. Expected: " ^ - (string_of_int i)); ltp in - - let ret_type = get_return_type 0 ltp new_args in - - (* Is the function built-in ? *) - (* built-in cannot be partially applied that is why we can get_return_type *) - (* they can only if you redefine the operation *) - if (is_lbuiltin idx ctx) then ( - match env_lookup_expr ctx ((loc, name), idx) with - | None -> lexp_error loc "Unknown builtin"; - Call(vf, new_args), ret_type - - (* Is it a macro ? *) - | Some Cons (((_, "Macro"), _), (_, "Macro_")) -> - Call(vf, new_args), type_macro - (* - let lxp = match largs with - | [lxp] -> lxp - | hd::tl -> lexp_error loc "Macro_ expects one lexp"; hd - | _ -> lexp_fatal loc "Macro_ expects one lexp" in - - let rctx = (from_lctx ctx) in - - (* eval argument *) - let sxp = match eval lxp rctx with - | Vsexp(sxp) -> sxp - | v -> lexp_fatal loc "Macro_ expects sexp" in - - let pxp = pexp_parse sxp in - _lexp_p_infer pxp ctx (i + 1) *) - - (* a builtin functions *) - | Some e -> Call(e, new_args), ret_type - ) - else Call(vf, new_args), ret_type - - with Not_found -> - (* Don't stop even if an error was found *) - lexp_error loc ("The function "" ^ name ^ "" was not defined"); - let vf = (make_var name (-1) loc) in - Call(vf, new_args), ltp end *) - (* Read a pattern and create the equivalent representation *) and lexp_read_pattern pattern exp target ctx: ((string * location * (arg_kind * vdef) option list) * lexp_context) =

===================================== tests/eval_test.ml ===================================== --- a/tests/eval_test.ml +++ b/tests/eval_test.ml @@ -362,7 +362,7 @@ length = lambda a => lambda xs -> case xs | nil => 0 - | cons hd tl => (1 + length a tl); + | cons hd tl => (1 + (length a tl));

head : (a : Type) => List a -> a; head = lambda a =>

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