Jonathan Graveline pushed to branch graveline at Stefan / Typer
Commits: 3d4d9623 by Jonathan Graveline at 2018-05-17T00:33:20Z Unfinished work on ctx2tup and mktup - - - - -
1 changed file:
- src/opslexp.ml
Changes:
===================================== src/opslexp.ml ===================================== --- a/src/opslexp.ml +++ b/src/opslexp.ml @@ -925,6 +925,8 @@ 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 @@ -932,37 +934,50 @@ let mktup types vals = let cons_label = (loc, cons_name) in let type_label = (loc, "record") in
- let shift n lexp = Lexp.mkSusp lexp (S.Shift (S.Identity,n)) 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*)
- Call (Cons (Inductive (loc, type_label, [], + let body = Call (Cons (Inductive (loc, type_label, [], SMap.add cons_name (List.map (fun (oname, t) - -> (P.Aimplicit, oname, t)) + -> (P.Aimplicit, oname, shift self_len t)) types) SMap.empty), cons_label), - (* shift could be done in sform_load but it is easy to put it here *) - List.mapi (fun n v -> (P.Aimplicit, shift (- n) v)) vals) + + 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)*)
-(* does not seem to let previous global declaration be used by next global declaration *) let ctx2tup ctx nctx = 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 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 rec shift_vs rdefs types vals defs = match rdefs with - | [] -> get_ts_vs nctx types vals - | (oname, LetDef e, t) :: rdefs - -> let name = maybev oname in - let defs = (name, e, t) :: defs in - shift_vs rdefs ((oname, t) :: types) - (Let (DB.dloc, defs, e) :: vals) defs - | _ -> U.internal_error "ctx2tup: Non-letdef in recursive vars" in - shift_vs (List.rev defs) types vals [] + -> 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])) | _ -> assert false in let (types, vals) = get_ts_vs nctx [] [] in mktup types vals
View it on GitLab: https://gitlab.com/monnier/typer/commit/3d4d9623830585cfbafa147a42cc81872350...
Afficher les réponses par date