Jonathan Graveline pushed to branch graveline at Stefan / Typer

Commits: 69659f54 by Jonathan Graveline at 2018-05-17T22:19:36Z ctx2tup from master and different shift for tuple values - - - - -

1 changed file:

- src/opslexp.ml

Changes:

===================================== src/opslexp.ml ===================================== --- a/src/opslexp.ml +++ b/src/opslexp.ml @@ -89,11 +89,8 @@ let rec lctx_to_subst lctx = | DB.CVfix (defs, lctx) -> let s1 = lctx_to_subst lctx in let s2 = lexp_defs_subst DB.dloc S.identity - (List.map (fun (oname, odef, t) - -> (maybev oname, - (match odef with LetDef e -> e - | _ -> L.impossible), - t)) + (List.map (fun (oname, e, t) + -> (maybev oname, e, t)) (List.rev defs)) in L.scompose s2 s1

@@ -925,61 +922,57 @@ and clean_map cases = cases

(** Turning a set of declarations into an object. **) - -let shift n lexp = Lexp.mkSusp lexp (S.shift n) - -let mktup types vals = - let loc = DB.dloc in - let cons_name = "cons" in - let cons_label = (loc, cons_name) in - let type_label = (loc, "record") in - - let self_len = List.length types in - - let nlet l (oname,t) e = Let (DB.dloc, [((maybev oname), e, t)], l) in - (*let nlet l (oname,t) e = ((maybev oname), shift (self_len - (List.length l)) e, t) :: l in*) - - let body = Call (Cons (Inductive (loc, type_label, [], - SMap.add cons_name - (List.map (fun (oname, t) - -> (P.Aimplicit, oname, shift self_len t)) - types) - SMap.empty), - cons_label), - - List.mapi (fun n v -> ( - (P.Aimplicit, shift (self_len - n - 1) v) - - )) - vals - ) in - - List.fold_left2 nlet body (List.rev types) (List.rev vals) - (*Let (DB.dloc, List.rev (List.fold_left2 nlet [] types vals), body)*)

let ctx2tup ctx nctx = + U.debug_msg ("Entering ctx2tup\n"); assert (M.length nctx >= M.length ctx && ctx == M.nthcdr (M.length nctx - M.length ctx) nctx); - - let to_rdef l rdef = match rdef with - | (oname, LetDef e, t) -> (oname, t) :: l - | _ -> U.internal_error "ctx2tup: Non-letdef in recursive vars" in - - let to_rval l rdef = match rdef with - | (oname, LetDef e, t) -> e :: l - | _ -> U.internal_error "ctx2tup: Non-letdef in recursive vars" in - - let rec get_ts_vs nctx types vals = - if nctx == ctx then (types, vals) else + let rec get_blocs nctx blocs = + if nctx == ctx then blocs else match DB.lctx_view nctx with - | DB.CVlet (oname, LetDef e, t, nctx) - -> get_ts_vs nctx ((oname, t) :: types) (e :: vals) - | DB.CVfix (defs, nctx) - -> let rtypes = (List.fold_left to_rdef [] defs) in - let rvals = (List.fold_left to_rval [] defs) in - get_ts_vs nctx (List.concat (rtypes :: [types])) (List.concat (rvals :: [vals])) + | DB.CVlet (_, _, _, nctx) as bloc -> get_blocs nctx (bloc :: blocs) + | DB.CVfix (_, nctx) as bloc -> get_blocs nctx (bloc :: blocs) | _ -> assert false in - let (types, vals) = get_ts_vs nctx [] [] in - mktup types vals + let rec mk_lets_and_tup blocs types = + let loc = U.dummy_location in + match blocs with + | [] + -> let cons_name = "cons" in + let cons_label = (loc, cons_name) in + let type_label = (loc, "record") in + let offset = List.length types in + let types = List.rev types in + U.debug_msg ("Building tuple of size " ^ string_of_int offset ^ "\n"); + Call (Cons (Inductive (loc, type_label, [], + SMap.add cons_name + (List.map (fun (oname, t) + -> (P.Aimplicit, oname, + (* FIXME: We need to shift + * for references outside + * of the blocs, but for + * references within the blocs, + * this means we refer to the + * let-binding i.s.o the tuple + * field (which would be both + * equivalent and preferable). *) + mkSusp t (S.shift offset))) + types) + SMap.empty), + cons_label), + List.mapi (fun i (oname, t) + -> (P.Aimplicit, Var (maybev oname, offset - i - 1))) + types) + | (DB.CVlet (oname, LetDef e, t, _) :: blocs) + -> Let (loc, [(maybev oname, mkSusp e (S.shift 1), t)], + mk_lets_and_tup blocs ((oname, t) :: types)) + | (DB.CVfix (defs, _) :: blocs) + -> Let (loc, List.map (fun (oname, e, t) -> (maybev oname, e, t)) defs, + mk_lets_and_tup blocs (List.append + (List.rev + (List.map (fun (oname, _, t) + -> (oname, t)) + defs)) + types)) in + mk_lets_and_tup (get_blocs nctx []) []

(* opslexp.ml ends here. *)

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