Attention une mise à jour du service Gitlab va être effectuée le mardi 30 novembre entre 17h30 et 18h00. Cette mise à jour va générer une interruption du service dont nous ne maîtrisons pas complètement la durée mais qui ne devrait pas excéder quelques minutes. Cette mise à jour intermédiaire en version 14.0.12 nous permettra de rapidement pouvoir mettre à votre disposition une version plus récente.

Commit 6e021172 authored by Jean-Christophe Filliâtre's avatar Jean-Christophe Filliâtre
Browse files

programs: fixed bug with type substitution and purification

parent 23eae6d0
...@@ -346,7 +346,13 @@ end = struct ...@@ -346,7 +346,13 @@ end = struct
let ps_equal ps1 ps2 = ls_equal ps1.ps_impure ps2.ps_impure let ps_equal ps1 ps2 = ls_equal ps1.ps_impure ps2.ps_impure
let rec subst_var ts s vs = let subst_var ?(effect=false) ?(pure=false) ts s vs =
if effect && pure then invalid_arg "subst_var";
let ts =
if effect then Mtv.map effectify ts
else if pure then Mtv.map purify ts
else ts
in
let ty' = ty_inst ts vs.vs_ty in let ty' = ty_inst ts vs.vs_ty in
if ty_equal ty' vs.vs_ty then if ty_equal ty' vs.vs_ty then
s, vs s, vs
...@@ -354,11 +360,14 @@ end = struct ...@@ -354,11 +360,14 @@ end = struct
let vs' = create_vsymbol (id_clone vs.vs_name) ty' in let vs' = create_vsymbol (id_clone vs.vs_name) ty' in
Mvs.add vs (t_var vs') s, vs' Mvs.add vs (t_var vs') s, vs'
and subst_post ts s ((v, q), ql) = let subst_post ts s ((v, q), ql) =
let vq = let s, v = subst_var ts s v in v, f_ty_subst ts s q in let vq = let s, v = subst_var ~pure:true ts s v in v, f_ty_subst ts s q in
let handler (e, (v, q)) = match v with let handler (e, (v, q)) = match v with
| None -> e, (v, f_ty_subst ts s q) | None ->
| Some v -> let s, v = subst_var ts s v in e, (Some v, f_ty_subst ts s q) e, (v, f_ty_subst ts s q)
| Some v ->
let s, v = subst_var ~pure:true ts s v in
e, (Some v, f_ty_subst ts s q)
in in
vq, List.map handler ql vq, List.map handler ql
...@@ -377,8 +386,8 @@ end = struct ...@@ -377,8 +386,8 @@ end = struct
and subst_binder ts s pv = and subst_binder ts s pv =
let v' = subst_type_v ts s pv.pv_tv in let v' = subst_type_v ts s pv.pv_tv in
let s, effect = subst_var ts s pv.pv_effect in let s, effect = subst_var ~effect:true ts s pv.pv_effect in
let s, pure = subst_var ts s pv.pv_pure in let s, pure = subst_var ~pure:true ts s pv.pv_pure in
let regions = E.subst_set ts pv.pv_regions in let regions = E.subst_set ts pv.pv_regions in
let pv' = create_pvsymbol (id_clone pv.pv_name) v' ~effect ~pure ~regions in let pv' = create_pvsymbol (id_clone pv.pv_name) v' ~effect ~pure ~regions in
s, pv' s, pv'
......
(**
module Alg module Alg
type t = A type t = A
...@@ -6,8 +7,8 @@ module Alg ...@@ -6,8 +7,8 @@ module Alg
let foo (x: t) = match x with A -> 0 end let foo (x: t) = match x with A -> 0 end
end end
**)
(**
module M module M
type pointer model int type pointer model int
...@@ -19,7 +20,6 @@ module M ...@@ -19,7 +20,6 @@ module M
let foo () = f null let foo () = f null
end end
**)
(** (**
module TestRef module TestRef
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment