Setepenre pushed to branch master at Stefan / Typer

Commits: 38d418dc by Pierre Delaunay at 2016-05-23T17:48:02-04:00 fix eval order

Changes to be committed: * src/eval.ml * src/lparse.ml - add dummy type annotation if none present

- - - - -

3 changed files:

- src/debruijn.ml - src/eval.ml - src/lparse.ml

Changes:

===================================== src/debruijn.ml ===================================== --- a/src/debruijn.ml +++ b/src/debruijn.ml @@ -126,7 +126,7 @@ let env_add_var_info var (ctx: lexp_context) =

let env_extend (ctx: lexp_context) (def: vdef) (v: varbind) (t: lexp) = let ((n, map), e, f) = ctx in - env_add_var_info (0, Some def, v, t) (senv_add_var def ctx) + env_add_var_info (1, Some def, v, t) (senv_add_var def ctx)

let _name_error loc estr str = @@ -169,7 +169,7 @@ let _env_lookup ctx (v: vref): env_elem = let env_lookup_type ctx (v : vref): lexp = let (_, idx) = v in let (_, _, _, ltp) = _env_lookup ctx v in - (* unsusp_all *) (Susp (ltp, (S.shift (idx + 1)))) + (Susp (ltp, (S.shift (idx + 1))))

let env_lookup_expr ctx (v : vref): lexp = let (_, idx) = v in @@ -178,7 +178,17 @@ let env_lookup_expr ctx (v : vref): lexp = let lxp = match lxp with | LetDef lxp -> lxp in

- (* unsusp_all *) (Susp (lxp, (S.shift (idx - r + 1)))) + (if (r != 1) then ( + let s1 = (Susp (lxp, (S.shift (idx - r + 1)))) in + let s2 = (Susp (lxp, (S.shift (idx + 1)))) in + + lexp_print (unsusp_all s1); print_string "\n"; + lexp_print (unsusp_all s2); print_string "\n"; + + )); + (*let idx = if r > 0 then idx - r else idx + 1 in *) + + (Susp (lxp, (S.shift (idx - r + 1))))

let env_lookup_by_index index (ctx: lexp_context): env_elem = (Myers.nth index (_get_env ctx))

===================================== src/eval.ml ===================================== --- a/src/eval.ml +++ b/src/eval.ml @@ -186,14 +186,19 @@ and eval_decls decls ctx = _eval_decls decls ctx 0 and _eval_decls (decls: ((vdef * elexp) list)) (ctx: runtime_env) i: runtime_env =

- (* Read declarations once and push them *) - let ctx = List.fold_left (fun ctx ((_, name), lxp) -> - add_rte_variable (Some name) Vdummy ctx) - ctx decls in - let n = (List.length decls) - 1 in

(* Read declarations once and push them *) + List.fold_left (fun ctx ((_, name), lxp) -> + let ctx = add_rte_variable (Some name) Vdummy ctx in + let lxp = _eval lxp ctx (i + 1) in + set_rte_variable 0 (Some name) lxp ctx) + + ctx decls + + + + (* Read declarations once and push them * ) let _, ctx = List.fold_left (fun (idx, ctx) ((_, name), lxp) -> _global_eval_trace := []; let lxp = _eval lxp ctx (i + 1) in @@ -201,7 +206,8 @@ and _eval_decls (decls: ((vdef * elexp) list)) (idx - 1, ctx)) (n, ctx) decls in

- ctx + ctx *) + (* -------------------------------------------------------------------------- *) (* Builtin Implementation (Some require eval) *)

===================================== src/lparse.ml ===================================== --- a/src/lparse.ml +++ b/src/lparse.ml @@ -283,7 +283,7 @@ and _lexp_p_check (p : pexp) (t : ltype) (ctx : lexp_context) i: lexp = (* This case cannot be inferred *) | Plambda (kind, var, None, body) ->( (* Read var type from the provided type *) - let ltp, lbtp = match t with + let ltp, lbtp = match unsusp_all t with | Arrow(kind, _, ltp, _, lbtp) -> ltp, lbtp | _ -> lexp_error tloc "Type does not match"; dltype, dltype in

@@ -643,11 +643,14 @@ and _lexp_decls decls ctx i: (((vdef * lexp * ltype) list) * lexp_context) = let (_, _, _, ltp) = SMap.find s !merged in merged := SMap.add s (l, s, Some lxp, ltp) !merged; let r = !offset in + let r = if r = 0 then 1 else r in offset := 0; replace_by vctx s (r, Some (l, s), (LetDef lxp), ltp);

with Not_found -> - let lxp, ltp = lexp_p_infer pxp vctx in + (* Add dummy first *) + let tctx = env_extend vctx (l, s) ForwardRef dltype in + let lxp, ltp = lexp_p_infer pxp tctx in names := s::!names; merged := SMap.add s (l, s, Some lxp, ltp) !merged; env_extend vctx (l, s) (LetDef lxp) ltp) @@ -694,7 +697,7 @@ and print_lexp_ctx (ctx : lexp_context) = (Some ('l', 7), "INDEX"); (Some ('l', 10), "NAME"); (Some ('l', 4), "OFF"); - (Some ('l', 32), "VALUE:TYPE")]; + (Some ('l', 29), "VALUE:TYPE")];

print_string (make_sep '-');

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