diff options
| author |  Pierre-Marie Pédrot <pierre-marie.pedrot@inria.fr> | 2016-08-22 14:39:10 +0200 |
|---|---|---|
| committer | Pierre-Marie Pédrot <pierre-marie.pedrot@inria.fr> | 2016-09-09 12:03:25 +0200 |
| commit | 37195c027472b7f0110249b28356271e713fee6f (patch) | |
| tree | 26eeac7ec60bd309d26c673462e369c0239652b7 | |
| parent | 76370ea2ddc2c09485f02c86798914a6d4cf5523 (diff) | |
More efficient implementation of map_named_val.
| -rw-r--r-- | kernel/environ.ml | 7 | ||||
| -rw-r--r-- | kernel/pre_env.ml | 15 | ||||
| -rw-r--r-- | kernel/pre_env.mli | 3 |
3 files changed, 18 insertions, 7 deletions
diff --git a/kernel/environ.ml b/kernel/environ.ml index be3b4977e..f4a3312ef 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -105,12 +105,7 @@ let named_vals_of_val c = c.env_named_val (* [map_named_val f ctxt] apply [f] to the body and the type of each declarations. *** /!\ *** [f t] should be convertible with t *) -let rec map_named_val f ctx = match match_named_context_val ctx with -| None -> empty_named_context_val -| Some (d, v, ctx) -> - let d = Context.Named.Declaration.map_constr f d in - let ctx = map_named_val f ctx in - push_named_context_val_val d v ctx +let map_named_val = map_named_val let empty_named_context = Context.Named.empty diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml index 62e5cd366..defc0afc8 100644 --- a/kernel/pre_env.ml +++ b/kernel/pre_env.ml @@ -132,7 +132,7 @@ let env_of_rel n env = (* Named context *) let push_named_context_val_val d rval ctxt = - assert (not (Id.Map.mem (get_id d) ctxt.env_named_map)); +(* assert (not (Id.Map.mem (get_id d) ctxt.env_named_map)); *) { env_named_ctx = Context.Named.add d ctxt.env_named_ctx; env_named_val = (get_id d, rval) :: ctxt.env_named_val; @@ -150,6 +150,19 @@ let match_named_context_val c = match c.env_named_ctx, c.env_named_val with Some (decl, v, cval) | _ -> assert false +let map_named_val f ctxt = + let open Context.Named.Declaration in + let fold accu d = + let d' = map_constr f d in + let accu = + if d == d' then accu + else Id.Map.modify (get_id d) (fun _ (_, v) -> (d', v)) accu + in + (accu, d') + in + let map, ctx = List.fold_map fold ctxt.env_named_map ctxt.env_named_ctx in + { ctxt with env_named_ctx = ctx; env_named_map = map } + let push_named d env = (* if not (env.env_rel_context = []) then raise (ASSERT env.env_rel_context); assert (env.env_rel_context = []); *) diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli index f916c399f..4390177da 100644 --- a/kernel/pre_env.mli +++ b/kernel/pre_env.mli @@ -80,6 +80,9 @@ val push_named_context_val_val : Context.Named.Declaration.t -> lazy_val -> named_context_val -> named_context_val val match_named_context_val : named_context_val -> (Context.Named.Declaration.t * lazy_val * named_context_val) option +val map_named_val : + (constr -> constr) -> named_context_val -> named_context_val + val push_named : Context.Named.Declaration.t -> env -> env val lookup_named_val : Id.t -> env -> lazy_val val env_of_named : Id.t -> env -> env |