summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Values.ml112
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 =