Commits

Anonymous committed 38fca6d

Comments (0)

Files changed (5)

 - PR#5735: %apply and %revapply not first class citizens
 - PR#5738: first class module patterns not handled by ocamldep
 - PR#5747: 'unused open' warning not given when compiling with -annot
+- PR#5758: Compiler bug when matching on floats
 
 Internals:
 - Moved debugger/envaux.ml to typing/envaux.ml to publish env_of_only_summary

bytecomp/matching.ml

       | _ -> raise NoMatch)
   | Tpat_constant cst ->
       (fun q rem -> match q.pat_desc with
-      | Tpat_constant cst' when cst=cst' ->
+      | Tpat_constant cst' when const_compare cst cst' = 0 ->
           p,rem
       | Tpat_any -> p,rem
       | _ -> raise NoMatch)
     add jumps
 
 
-let rec jumps_union env1 env2 = match env1,env2 with
+let rec jumps_union (env1:(int*ctx list)list) env2 = match env1,env2 with
 | [],_ -> env2
 | _,[] -> env1
 | ((i1,pss1) as x1::rem1), ((i2,pss2) as x2::rem2) ->
 (* A slight attempt to identify semantically equivalent lambda-expressions *)
 exception Not_simple
 
-let rec raw_rec env = function
+let rec raw_rec env : lambda -> lambda = function
   | Llet(Alias,x,ex, body) -> raw_rec ((x,raw_rec env ex)::env) body
   | Lvar id as l ->
       begin try List.assoc id env with
               simplify rem
           | Tpat_record (lbls, closed) ->
               let all_lbls = all_record_args lbls in
-              let full_pat = {pat with pat_desc=Tpat_record (all_lbls, closed)} in
+              let full_pat =
+                {pat with pat_desc=Tpat_record (all_lbls, closed)} in
               (full_pat::patl,action)::
               simplify rem
           | Tpat_or _ ->
   ctx : ctx list ;
   pat : pattern}
 
-let add make_matching_fun division key patl_action args =
+let add make_matching_fun division eq_key key patl_action args =
   try
-    let cell = List.assoc key division in
+    let (_,cell) = List.find (fun (k,_) -> eq_key key k) division in
     cell.pm.cases <- patl_action :: cell.pm.cases;
     division
   with Not_found ->
     (key, cell) :: division
 
 
-let divide make get_key get_args ctx pm =
+let divide make eq_key get_key get_args ctx pm =
 
   let rec divide_rec = function
     | (p::patl,action) :: rem ->
         let this_match = divide_rec rem in
         add
           (make p pm.default ctx)
-          this_match (get_key p) (get_args p patl,action) pm.args
+          this_match eq_key (get_key p) (get_args p patl,action) pm.args
     | _ -> [] in
 
   divide_rec pm.cases
       matcher_const cst p1 rem with
     | NoMatch -> matcher_const cst p2 rem
     end
-| Tpat_constant c1 when c1=cst -> rem
-| Tpat_any                     -> rem
+| Tpat_constant c1 when const_compare c1 cst = 0 -> rem
+| Tpat_any    -> rem
 | _ -> raise NoMatch
 
 let get_key_constant caller = function
 
 let divide_constant ctx m =
   divide
-    make_constant_matching (get_key_constant "divide")
+    make_constant_matching
+    (fun c d -> const_compare c d = 0) (get_key_constant "divide")
     get_args_constant
     ctx m
 
         | None, Some r2 -> r2
         | Some (a1::rem1), Some (a2::_) ->
             {a1 with
-pat_loc = Location.none ;
-pat_desc = Tpat_or (a1, a2, None)}::
+             pat_loc = Location.none ;
+             pat_desc = Tpat_or (a1, a2, None)}::
             rem
         | _, _ -> assert false
         end
-    | Tpat_construct (_, _, cstr1, [arg],_) when cstr.cstr_tag = cstr1.cstr_tag ->
-        arg::rem
+    | Tpat_construct (_, _, cstr1, [arg],_)
+      when cstr.cstr_tag = cstr1.cstr_tag -> arg::rem
     | Tpat_any -> omega::rem
     | _ -> raise NoMatch in
     matcher_rec
     fun q rem -> match q.pat_desc with
     | Tpat_or (_,_,_) -> raise OrPat
     | Tpat_construct (_, _, cstr1, args,_)
-        when cstr.cstr_tag = cstr1.cstr_tag -> args @ rem
+      when cstr.cstr_tag = cstr1.cstr_tag -> args @ rem
     | Tpat_any -> Parmatch.omegas cstr.cstr_arity @ rem
     | _        -> raise NoMatch
 
 let divide_constructor ctx pm =
   divide
     make_constr_matching
-    get_key_constr get_args_constr
+    (=) get_key_constr get_args_constr
     ctx pm
 
 (* Matching against a variant *)
           match pato with
             None ->
               add (make_variant_matching_constant p lab def ctx) variants
-                (Cstr_constant tag) (patl, action) al
+                (=) (Cstr_constant tag) (patl, action) al
           | Some pat ->
               add (make_variant_matching_nonconst p lab def ctx) variants
-                (Cstr_block tag) (pat :: patl, action) al
+                (=) (Cstr_block tag) (pat :: patl, action) al
         end
     | cl -> []
   in
 let divide_array kind ctx pm =
   divide
     (make_array_matching kind)
-    get_key_array get_args_array ctx pm
+    (=) get_key_array get_args_array ctx pm
 
 (* To combine sub-matchings together *)
 
-let float_compare s1 s2 =
-  let f1 = float_of_string s1 and f2 = float_of_string s2 in
-  Pervasives.compare f1 f2
-
 let sort_lambda_list l =
-  List.sort
-    (fun (x,_) (y,_) -> match x,y with
-    | Const_float f1, Const_float f2 -> float_compare f1 f2
-    | _, _ -> Pervasives.compare x y)
-    l
+  List.sort (fun (x,_) (y,_) -> const_compare x y) l
 
 let rec cut n l =
   if n = 0 then [],l
 
 
 
-let rec comp_match_handlers comp_fun partial ctx arg first_match next_matchs = match next_matchs with
+let rec comp_match_handlers comp_fun partial ctx arg first_match next_matchs =
+  match next_matchs with
   | [] -> comp_fun partial ctx arg first_match
   | rem ->
       let rec c_rec body total_body = function

testsuite/tests/basic-more/morematch.ml

   test "lucexn1" lucexn  (Error "coucou") "coucou" ;
   test "lucexn2" lucexn (Found ("int: ",0)) "int: 0" ;
   ()
+
+(*
+  PR#5758: different representations of floats
+*)
+
+let pr5758 x str =
+  match (x, str) with
+  | (1. , "A") -> "Matched A"
+  | (1.0, "B") -> "Matched B"
+  | (1. , "C") -> "Matched C"
+  | result ->
+    match result with
+    | (1., "A") -> "Failed match A then later matched"
+    | _ -> "Failed twice"
+;;
+
+let () =
+  test "pr5758" (pr5758 1.) "A" "Matched A"
+;;

typing/parmatch.ml

 | Tpat_variant (tag, _, row) -> is_absent tag row
 | _ -> false
 
+let const_compare x y =
+  match x,y with
+  | Const_float f1, Const_float f2 ->
+      Pervasives.compare (float_of_string f1) (float_of_string f2)
+  | _, _ -> Pervasives.compare x y
+
 let records_args l1 l2 =
   (* Invariant: fields are already sorted by Typecore.type_label_a_list *)
   let rec combine r1 r2 l1 l2 = match l1,l2 with
   | _,(Tpat_any|Tpat_var _) -> true
   | Tpat_or (p1,p2,_),_     -> compat p1 q || compat p2 q
   | _,Tpat_or (q1,q2,_)     -> compat p q1 || compat p q2
-  | Tpat_constant c1, Tpat_constant c2 -> c1=c2
+  | Tpat_constant c1, Tpat_constant c2 -> const_compare c1 c2 = 0
   | Tpat_tuple ps, Tpat_tuple qs -> compats ps qs
   | Tpat_lazy p, Tpat_lazy q -> compat p q
   | Tpat_construct (_, _, c1,ps1, _), Tpat_construct (_, _, c2,ps2, _) ->
       c1.cstr_tag = c2.cstr_tag
   | Tpat_variant(l1, _, _), Tpat_variant(l2, _, _) ->
       l1 = l2
-  | Tpat_constant(Const_float s1), Tpat_constant(Const_float s2) ->
-      float_of_string s1 = float_of_string s2
-  | Tpat_constant(c1), Tpat_constant(c2) -> c1 = c2
+  | Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0
   | Tpat_tuple _, Tpat_tuple _ -> true
   | Tpat_lazy _, Tpat_lazy _ -> true
   | Tpat_record _ , Tpat_record _ -> true
   | (Tpat_var _|Tpat_any),_ -> true
   | Tpat_alias(p,_,_), _ -> le_pat p q
   | _, Tpat_alias(q,_,_) -> le_pat p q
-  | Tpat_constant(c1), Tpat_constant(c2) -> c1 = c2
+  | Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0
   | Tpat_construct(_,_,c1,ps,_), Tpat_construct(_,_,c2,qs,_) ->
       c1.cstr_tag = c2.cstr_tag && le_pats ps qs
   | Tpat_variant(l1,Some p1,_), Tpat_variant(l2,Some p2,_) ->
 | _,(Tpat_any|Tpat_var _) -> p
 | Tpat_or (p1,p2,_),_     -> orlub p1 p2 q
 | _,Tpat_or (q1,q2,_)     -> orlub q1 q2 p (* Thanks god, lub is commutative *)
-| Tpat_constant c1, Tpat_constant c2 when c1=c2 -> p
+| Tpat_constant c1, Tpat_constant c2 when const_compare c1 c2 = 0 -> p
 | Tpat_tuple ps, Tpat_tuple qs ->
     let rs = lubs ps qs in
     make_pat (Tpat_tuple rs) p.pat_type p.pat_env

typing/parmatch.mli

 val all_record_args :
     (Path.t * Longident.t loc * label_description * pattern) list ->
     (Path.t * Longident.t loc * label_description * pattern) list
+val const_compare : constant -> constant -> int
 
 val le_pat : pattern -> pattern -> bool
 val le_pats : pattern list -> pattern list -> bool