diff options
Diffstat (limited to 'src/Pure.ml')
-rw-r--r-- | src/Pure.ml | 154 |
1 files changed, 121 insertions, 33 deletions
diff --git a/src/Pure.ml b/src/Pure.ml index ee4e74bb..61d2d130 100644 --- a/src/Pure.ml +++ b/src/Pure.ml @@ -95,22 +95,10 @@ type var = { itself. *) -type var_or_dummy = Var of var | Dummy (** Ignored value: `_`. *) - -(** A left value (which appears on the left of assignments *) -type lvalue = - | LvVar of var_or_dummy - | LvTuple of typed_lvalue list - (** Rk.: for now we don't support general ADTs *) - -and typed_lvalue = { value : lvalue; ty : ty } - type projection_elem = { pkind : E.field_proj_kind; field_id : FieldId.id } type projection = projection_elem list -type place = { var : VarId.id; projection : projection } - type mplace = { name : string option; projection : projection } (** "Meta" place. @@ -119,6 +107,112 @@ type mplace = { name : string option; projection : projection } we introduce. *) +type place = { var : VarId.id; projection : projection } + +(** Ancestor for [iter_var_or_dummy] iter visitor *) +class ['self] iter_value_base = + object (_self : 'self) + inherit [_] VisitorsRuntime.iter + + method visit_var : 'env -> var -> unit = fun _ _ -> () + + method visit_mplace : 'env -> mplace -> unit = fun _ _ -> () + + method visit_ty : 'env -> ty -> unit = fun _ _ -> () + end + +(** Ancestor for [map_var_or_dummy] visitor *) +class ['self] map_value_base = + object (_self : 'self) + inherit [_] VisitorsRuntime.map + + method visit_var : 'env -> var -> var = fun _ x -> x + + method visit_mplace : 'env -> mplace -> mplace = fun _ x -> x + + method visit_ty : 'env -> ty -> ty = fun _ x -> x + end + +(** Ancestor for [reduce_var_or_dummy] visitor *) +class virtual ['self] reduce_value_base = + object (self : 'self) + inherit [_] VisitorsRuntime.reduce + + method visit_var : 'env -> var -> 'a = fun _ _ -> self#zero + + method visit_mplace : 'env -> mplace -> 'a = fun _ _ -> self#zero + + method visit_ty : 'env -> ty -> 'a = fun _ _ -> self#zero + end + +type var_or_dummy = + | Var of var * mplace option + | Dummy (** Ignored value: `_`. *) +[@@deriving + visitors + { + name = "iter_var_or_dummy"; + variety = "iter"; + ancestors = [ "iter_value_base" ]; + nude = true (* Don't inherit [VisitorsRuntime.iter] *); + concrete = true; + polymorphic = false; + }, + visitors + { + name = "map_var_or_dummy"; + variety = "map"; + ancestors = [ "map_value_base" ]; + nude = true (* Don't inherit [VisitorsRuntime.map] *); + concrete = true; + polymorphic = false; + }, + visitors + { + name = "reduce_var_or_dummy"; + variety = "reduce"; + ancestors = [ "reduce_value_base" ]; + nude = true (* Don't inherit [VisitorsRuntime.reduce] *); + polymorphic = false; + }] + +(** A left value (which appears on the left of assignments *) +type lvalue = LvVar of var_or_dummy | LvAdt of adt_lvalue + +and adt_lvalue = { + variant_id : (VariantId.id option[@opaque]); + field_values : typed_lvalue list; +} + +and typed_lvalue = { value : lvalue; ty : ty } +[@@deriving + visitors + { + name = "iter_typed_lvalue"; + variety = "iter"; + ancestors = [ "iter_var_or_dummy" ]; + nude = true (* Don't inherit [VisitorsRuntime.iter] *); + concrete = true; + polymorphic = false; + }, + visitors + { + name = "map_typed_lvalue"; + variety = "map"; + ancestors = [ "map_var_or_dummy" ]; + nude = true (* Don't inherit [VisitorsRuntime.iter] *); + concrete = true; + polymorphic = false; + }, + visitors + { + name = "reduce_typed_lvalue"; + variety = "reduce"; + ancestors = [ "reduce_var_or_dummy" ]; + nude = true (* Don't inherit [VisitorsRuntime.iter] *); + polymorphic = false; + }] + type rvalue = | RvConcrete of constant_value | RvPlace of place @@ -159,17 +253,15 @@ type call = { args_mplaces : mplace option list; (** Meta data *) } +(* TODO: we might want to merge Call and Assign *) type let_bindings = - | Call of (typed_lvalue * mplace option) list * call + | Call of typed_lvalue * call (** The called function and the tuple of returned values. *) - | Assign of typed_lvalue * mplace option * typed_rvalue * mplace option - (** Variable assignment: the introduced pattern and the place we read *) - | Deconstruct of - (var_or_dummy * mplace option) list - * (TypeDefId.id * VariantId.id) option - * typed_rvalue - * mplace option - (** This is used in two cases. + | Assign of typed_lvalue * typed_rvalue * mplace option + (** Variable assignment: the introduced pattern and the place we read. + + We are quite general for the left-value on purpose; this is used + in several situations: 1. When deconstructing a tuple: ``` @@ -186,18 +278,13 @@ type let_bindings = ... ``` - Later, depending on the language we extract to, we can eventually - update it to something like this (for F*, for instance): + Note that later, depending on the language we extract to, we can + eventually update it to something like this (for F*, for instance): ``` let x = Cons?.v ls in let tl = Cons?.tl ls in ... ``` - - Note that we prefer not handling this case through a match. - - TODO: why don't we merge this with Assign? It would make things a lot - simpler (before: introduce general ADTs in lvalue). *) (** Meta-information stored in the AST *) @@ -210,6 +297,8 @@ class ['self] iter_expression_base = method visit_typed_rvalue : 'env -> typed_rvalue -> unit = fun _ _ -> () + method visit_typed_lvalue : 'env -> typed_lvalue -> unit = fun _ _ -> () + method visit_let_bindings : 'env -> let_bindings -> unit = fun _ _ -> () method visit_mplace : 'env -> mplace -> unit = fun _ _ -> () @@ -233,6 +322,9 @@ class ['self] map_expression_base = method visit_typed_rvalue : 'env -> typed_rvalue -> typed_rvalue = fun _ x -> x + method visit_typed_lvalue : 'env -> typed_lvalue -> typed_lvalue = + fun _ x -> x + method visit_let_bindings : 'env -> let_bindings -> let_bindings = fun _ x -> x @@ -274,11 +366,7 @@ and switch_body = | SwitchInt of T.integer_type * (scalar_value * expression) list * expression | Match of match_branch list -and match_branch = { - variant_id : VariantId.id; - vars : var_or_dummy list; - branch : expression; -} +and match_branch = { pat : typed_lvalue; branch : expression } [@@deriving visitors { |