Jonathan Graveline pushed to branch graveline at Stefan / Typer
Commits: 5aa903a9 by Jonathan Graveline at 2018-05-10T01:12:36Z Modification of mktup and new function used in mktup - - - - -
1 changed file:
- src/opslexp.ml
Changes:
===================================== src/opslexp.ml ===================================== --- a/src/opslexp.ml +++ b/src/opslexp.ml @@ -926,11 +926,64 @@ and clean_map cases =
(** Turning a set of declarations into an object. **)
+let shift n lexp = Lexp.mkSusp lexp (S.Shift (S.Identity,n)) + +(* arguments are : *) +(* len is the length of the tuple, 'n value' as in nth value of the tuple *) +let rec reset_intra_ref len n value = + + let rec reset_intra_ref' scope value = + + let reset' = reset_intra_ref' scope in + let nscope nv = reset_intra_ref' (scope + nv) in + + match value with + + (* the real thing is with Var, all other pattern are for sub expression *) + (* We want to reset variable from inside the tuple so their idx aren't modified *) + | Var (v,idx) -> if (idx <= len && idx > scope) then Var (v, (idx + n)) else Var (v,idx) + + (* now just check sub expression *) + | Susp (l,s) -> Susp (reset' l,s) + + | Let (loc,defs,l) -> + let reset'' (v,l,t) = (v,reset' l,reset' t) in + Let (loc, List.map reset'' defs, nscope (List.length defs) l) + + | Arrow (k,ov,t,loc,l) -> Arrow (k,ov,reset' t,loc,nscope 1 l) + + | Lambda (k,v,t,l) -> Lambda (k,v,reset' t,nscope 1 l) + + | Call (l,args) -> + let reset'' (k,l) = (k,reset' l) in + Call (nscope (List.length args) l, List.map reset'' args) + + | Inductive (loc,label,args,ctors) -> + let reset'' (k,vo,t) = (k,vo,reset' t) in + let ctors' = SMap.map (fun ctor -> List.map reset'' ctor) ctors in + Inductive (loc,label,List.map reset'' args,ctors') + + | Cons (l,s) -> Cons (reset' l,s) + + | Case (loc,l,t,brc,dflt) -> + let reset'' (loc2,vs,l2) = (loc2,vs,nscope 1 l2) in + let brc' = SMap.map reset'' brc in + let dflt' = match dflt with + | None -> None + | Some (vo,l) -> Some (vo,nscope 1 l) in + Case (loc,reset' l,reset' t,brc',dflt') + + | _ -> value + in reset_intra_ref' 0 value + 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 reset' n (k,l) = (k,reset_intra_ref (List.length vals) n l) in + Call (Cons (Inductive (loc, type_label, [], SMap.add cons_name (List.map (fun (oname, t) @@ -938,8 +991,10 @@ let mktup types vals = types) SMap.empty), cons_label), - List.map (fun v -> (P.Aimplicit, v)) vals) + List.mapi reset' + (List.mapi (fun n v -> (P.Aimplicit, shift (- n) v)) vals))
+(* 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);
View it on GitLab: https://gitlab.com/monnier/typer/commit/5aa903a940ea1793a50ed3ba26633eb99b06...
Afficher les réponses par date