diff options
| -rw-r--r-- | src/Values.ml | 112 |
1 files changed, 55 insertions, 57 deletions
diff --git a/src/Values.ml b/src/Values.ml index 1720dfc2..bcacfefa 100644 --- a/src/Values.ml +++ b/src/Values.ml @@ -347,108 +347,102 @@ type abs = { which are a special kind of value. *) -(** Monomorphic version of the map visitor for [g_typed_value]. - - The type variables are quantified at the level of the class (not at the - level of each method). As a consequence, the visit methods don't need to - take closures as parameters. +(** Polymorphic version of the map visitor for [g_typed_value]. The polymorphic visitor generated by the visitors macro caused some - trouble: it was in some cases not possible to override a function - to refine the behaviour of a visitor. With this version, it is - possible. Note that this works only because the polymorphism of - [g_value], [g_adt_value], etc. is "uniform": the type instantiation - is always the same. - + trouble, especially because the map functions allowed to change the + type parameters (for instance the typed of `visit_'ty` was: + `'env 'r_0 'r_1. 'env -> 'r_0 ty -> 'r_1 ty`, which prevented from + initializing it as `fun ty -> ty`). *) class virtual ['self] map_g_typed_value = object (self : 'self) inherit [_] VisitorsRuntime.map - method virtual visit_'sv : 'monomorphic. 'env -> 'sv -> 'sv - - method virtual visit_'bc : 'monomorphic. 'env -> 'bc -> 'bc - - method virtual visit_'lc : 'monomorphic. 'env -> 'lc -> 'lc - method visit_Concrete - : 'monomorphic. 'env -> constant_value -> ('r, 'sv, 'bc, 'lv) g_value = + : 'env -> constant_value -> ('r, 'sv, 'bc, 'lv) g_value = fun _env cv -> Concrete cv method visit_Adt - : 'monomorphic. - 'env -> ('r, 'sv, 'bc, 'lc) g_adt_value -> ('r, 'sv, 'bc, 'lc) g_value - = - fun env av -> - let av = self#visit_g_adt_value env av in + : ('env -> 'sv -> 'sv) -> + ('env -> 'bc -> 'bc) -> + ('env -> 'lc -> 'lc) -> + 'env -> + ('r, 'sv, 'bc, 'lc) g_adt_value -> + ('r, 'sv, 'bc, 'lc) g_value = + fun visit_'sv visit_'bc visit_'lc env av -> + let av = self#visit_g_adt_value visit_'sv visit_'bc visit_'lc env av in Adt av - method visit_Bottom : 'monomorphic. 'env -> ('r, 'sv, 'bc, 'lv) g_value = + method visit_Bottom : 'env -> ('r, 'sv, 'bc, 'lv) g_value = fun _env -> Bottom method visit_Borrow - : 'monomorphic. 'env -> 'bc -> ('r, 'sv, 'bc, 'lv) g_value = - fun env bc -> Borrow (self#visit_'bc env bc) + : ('env -> 'bc -> 'bc) -> 'env -> 'bc -> ('r, 'sv, 'bc, 'lv) g_value = + fun visit_'bc env bc -> Borrow (visit_'bc env bc) - method visit_Loan : 'monomorphic. 'env -> 'lc -> ('r, 'sv, 'bc, 'lv) g_value - = - fun env lc -> Loan (self#visit_'lc env lc) + method visit_Loan + : ('env -> 'lc -> 'lc) -> 'env -> 'lc -> ('r, 'sv, 'bc, 'lv) g_value = + fun visit_'lc env lc -> Loan (visit_'lc env lc) method visit_Symbolic - : 'monomorphic. 'env -> 'sv -> ('r, 'sv, 'bc, 'lv) g_value = - fun env sv -> Symbolic (self#visit_'sv env sv) + : ('env -> 'sv -> 'sv) -> 'env -> 'sv -> ('r, 'sv, 'bc, 'lv) g_value = + fun visit_'sv env sv -> Symbolic (visit_'sv env sv) method visit_g_value - : 'monomorphic. - 'env -> ('r, 'sv, 'bc, 'lv) g_value -> ('r, 'sv, 'bc, 'lv) g_value = - fun env v -> + : ('env -> 'sv -> 'sv) -> + ('env -> 'bc -> 'bc) -> + ('env -> 'lc -> 'lc) -> + 'env -> + ('r, 'sv, 'bc, 'lv) g_value -> + ('r, 'sv, 'bc, 'lv) g_value = + fun visit_'sv visit_'bc visit_'lc env v -> match v with | Concrete cv -> self#visit_Concrete env cv - | Adt av -> Adt (self#visit_g_adt_value env av) + | Adt av -> + Adt (self#visit_g_adt_value visit_'sv visit_'bc visit_'lc env av) | Bottom -> self#visit_Bottom env - | Borrow bc -> self#visit_Borrow env bc - | Loan lc -> self#visit_Loan env lc - | Symbolic sv -> self#visit_Symbolic env sv + | Borrow bc -> self#visit_Borrow visit_'bc env bc + | Loan lc -> self#visit_Loan visit_'lc env lc + | Symbolic sv -> self#visit_Symbolic visit_'sv env sv method visit_g_adt_value - : 'monomorphic. + : ('env -> 'sv -> 'sv) -> + ('env -> 'bc -> 'bc) -> + ('env -> 'lc -> 'lc) -> 'env -> ('r, 'sv, 'bc, 'lv) g_adt_value -> ('r, 'sv, 'bc, 'lv) g_adt_value = - fun env av -> + fun visit_'sv visit_'bc visit_'lc env av -> let variant_id = av.variant_id in let field_values = - self#visit_list self#visit_g_typed_value env av.field_values + self#visit_list + (self#visit_g_typed_value visit_'sv visit_'bc visit_'lc) + env av.field_values in { variant_id; field_values } method visit_g_typed_value - : 'monomorphic. + : ('env -> 'sv -> 'sv) -> + ('env -> 'bc -> 'bc) -> + ('env -> 'lc -> 'lc) -> 'env -> ('r, 'sv, 'bc, 'lv) g_typed_value -> ('r, 'sv, 'bc, 'lv) g_typed_value = - fun env v -> - let value = self#visit_g_value env v.value in + fun visit_'sv visit_'bc visit_'lc env v -> + let value = + self#visit_g_value visit_'sv visit_'bc visit_'lc env v.value + in let ty = self#visit_ty env v.ty in { value; ty } - method visit_ty : 'monomorphic. 'env -> 'r ty -> 'r ty = fun _env ty -> ty + method visit_ty : 'env -> 'r ty -> 'r ty = fun _env ty -> ty end class ['self] map_typed_value = object (self : 'self) inherit [_] map_g_typed_value - method visit_'sv - : 'monomorphic. 'env -> symbolic_proj_comp -> symbolic_proj_comp = - fun env sv -> self#visit_symbolic_proj_comp env sv - - method visit_'bc : 'monomorphic. 'env -> borrow_content -> borrow_content = - fun env bc -> self#visit_borrow_content env bc - - method visit_'lc : 'monomorphic. 'env -> loan_content -> loan_content = - fun env lc -> self#visit_loan_content env lc - method visit_symbolic_proj_comp : 'monomorphic. 'env -> symbolic_proj_comp -> symbolic_proj_comp = fun _env sv -> sv @@ -493,10 +487,14 @@ class ['self] map_typed_value = method visit_typed_value : 'monomorphic. 'env -> typed_value -> typed_value = - fun env v -> self#visit_g_typed_value env v + fun env v -> + self#visit_g_typed_value self#visit_symbolic_proj_comp + self#visit_borrow_content self#visit_loan_content env v method visit_adt_value : 'monomorphic. 'env -> adt_value -> adt_value = - fun env v -> self#visit_g_adt_value env v + fun env v -> + self#visit_g_adt_value self#visit_symbolic_proj_comp + self#visit_borrow_content self#visit_loan_content env v end (*class ['self] map_typed_avalue = |