Merge pull request #8959 from gasche/refactor-pat-bound-idents

clarify the implementation of Typedtree.pat_bound_idents_full

Changes

@@ -70,8 +70,11 @@ Working version
 - #8928: Move contains_calls and num_stack_slots from Proc to Mach.fundecl
   (Greta Yorsh, review by Florian Angeletti and Vincent Laviron)
 
-- #8968: refactor the generic pattern-traversal functions
-  in Typecore and Typedtree.
+- #8959, #8960, #8968: minor refactorings in the typing of patterns:
+  + refactor the {let,pat}_bound_idents* functions
+  + minor bugfix in type_pat
+  + refactor the generic pattern-traversal functions
+    in Typecore and Typedtree
   (Gabriel Scherer, review by Thomas Refis)
 
 ### Code generation and optimizations:

lambda/translmod.ml

@@ -547,8 +547,9 @@ and transl_structure loc fields cc rootpath final_env = function
           Lsequence(transl_exp expr, body), size
       | Tstr_value(rec_flag, pat_expr_list) ->
           (* Translate bindings first *)
-          let mk_lam_let =  transl_let rec_flag pat_expr_list in
-          let ext_fields = rev_let_bound_idents pat_expr_list @ fields in
+          let mk_lam_let = transl_let rec_flag pat_expr_list in
+          let ext_fields =
+            List.rev_append (let_bound_idents pat_expr_list) fields in
           (* Then, translate remainder of struct *)
           let body, size =
             transl_structure loc ext_fields cc rootpath final_env rem

typing/typeclass.ml

@@ -1200,7 +1200,7 @@ and class_expr_aux cl_num val_env met_env scl =
              ((id', expr)
               :: vals,
               Env.add_value id' desc met_env))
-          (let_bound_idents_with_loc defs)
+          (let_bound_idents_full defs)
           ([], met_env)
       in
       let cl = class_expr cl_num val_env met_env scl' in

typing/typedtree.ml

@@ -638,41 +638,43 @@ let exists_pattern f p =
 
 (* List the identifiers bound by a pattern or a let *)
 
-let idents = ref([]: (Ident.t * string loc * Types.type_expr) list)
-
-let rec bound_idents pat =
+let rec iter_bound_idents f pat =
   match pat.pat_desc with
-  | Tpat_var (id,s) -> idents := (id,s,pat.pat_type) :: !idents
+  | Tpat_var (id,s) ->
+     f (id,s,pat.pat_type)
   | Tpat_alias(p, id, s) ->
-      bound_idents p; idents := (id,s,pat.pat_type) :: !idents
+      iter_bound_idents f p;
+      f (id,s,pat.pat_type)
   | Tpat_or(p1, _, _) ->
-      (* Invariant : both arguments binds the same variables *)
-      bound_idents p1
-  | d -> shallow_iter_pattern_desc bound_idents d
+      (* Invariant : both arguments bind the same variables *)
+      iter_bound_idents f p1
+  | d ->
+     shallow_iter_pattern_desc (iter_bound_idents f) d
+
+let rev_pat_bound_idents_full pat =
+  let idents_full = ref [] in
+  let add id_full = idents_full := id_full :: !idents_full in
+  iter_bound_idents add pat;
+  !idents_full
+
+let rev_only_idents idents_full =
+  List.rev_map (fun (id,_,_) -> id) idents_full
 
 let pat_bound_idents_full pat =
-  idents := [];
-  bound_idents pat;
-  let res = !idents in
-  idents := [];
-  res
-
+  List.rev (rev_pat_bound_idents_full pat)
 let pat_bound_idents pat =
-  List.map (fun (id,_,_) -> id) (pat_bound_idents_full pat)
+  rev_only_idents (rev_pat_bound_idents_full pat)
 
-let rev_let_bound_idents_with_loc bindings =
-  idents := [];
-  List.iter (fun vb -> bound_idents vb.vb_pat) bindings;
-  let res = !idents in idents := []; res
-
-let let_bound_idents_with_loc pat_expr_list =
-  List.rev(rev_let_bound_idents_with_loc pat_expr_list)
-
-let rev_let_bound_idents pat =
-  List.map (fun (id,_,_) -> id) (rev_let_bound_idents_with_loc pat)
+let rev_let_bound_idents_full bindings =
+  let idents_full = ref [] in
+  let add id_full = idents_full := id_full :: !idents_full in
+  List.iter (fun vb -> iter_bound_idents add vb.vb_pat) bindings;
+  !idents_full
 
+let let_bound_idents_full bindings =
+  List.rev (rev_let_bound_idents_full bindings)
 let let_bound_idents pat =
-  List.map (fun (id,_,_) -> id) (let_bound_idents_with_loc pat)
+  rev_only_idents (rev_let_bound_idents_full pat)
 
 let alpha_var env id = List.assoc id env
 

typing/typedtree.mli

@@ -722,9 +722,7 @@ val iter_pattern: (pattern -> unit) -> pattern -> unit
 val exists_pattern: (pattern -> bool) -> pattern -> bool
 
 val let_bound_idents: value_binding list -> Ident.t list
-val rev_let_bound_idents: value_binding list -> Ident.t list
-
-val let_bound_idents_with_loc:
+val let_bound_idents_full:
     value_binding list -> (Ident.t * string loc * type_expr) list
 
 (** Alpha conversion of patterns *)

typing/typemod.ml

@@ -2029,7 +2029,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
         List.map (fun (id, { Asttypes.loc; _ }, _typ)->
           Signature_names.check_value names loc id;
           Sig_value(id, Env.find_value (Pident id) newenv, Exported)
-        ) (let_bound_idents_with_loc defs),
+        ) (let_bound_idents_full defs),
         newenv
     | Pstr_primitive sdesc ->
         let (desc, newenv) = Typedecl.transl_value_decl env loc sdesc in