camlspotter avatar camlspotter committed a1487e7

ocaml-4.00.1-12983

Comments (0)

Files changed (23)

0scripts/0CHECKOUT-SVN

 
 set -e
 
-REV=12923
-VERSION=4.00
+REV=12983
+DIR=release
+VERSION=4.00.1
 
 # Move to the ocaml-svn-copy head
 # hg update -C ocaml-svn-copy
 /bin/rm -rf [A-z]* \#*
 
-# svn co http://caml.inria.fr/svn/ocaml/release/$VERSION/
-svn co http://caml.inria.fr/svn/ocaml/version/$VERSION/
+svn co http://caml.inria.fr/svn/ocaml/$DIR/$VERSION/
 
 # tar zxvf ../ocaml-$VERSION.tgz
 (cd $VERSION; tar cf - .) | tar xf -
 
 Bug fixes:
 - PR#4019: better documentation of Str.matched_string
+- PR#5111: ocamldoc, heading tags inside spans tags is illegal in html
+- PR#5278: better error message when typing "make"
+- PR#5468: ocamlbuild should preserve order of parametric tags
+- PR#5563: harden Unix.select against file descriptors above FD_SETSIZE
+- PR#5690: "ocamldoc ... -text README" raises exception
 - PR#5700: crash with native-code stack backtraces under MacOS 10.8 x86-64
 - PR#5707: AMD64 code generator: do not use r10 and r11 for parameter passing,
   as these registers can be destroyed by the dynamic loader
 - PR#5712: some documentation problems
+- PR#5715: configuring with -no-shared-libs breaks under cygwin
 - PR#5718: false positive on 'unused constructor' warning
 - PR#5719: ocamlyacc generates code that is not warning 33-compliant
+- PR#5725: ocamldoc output of preformatted code
+- PR#5727: emacs caml-mode indents shebang line in toplevel scripts
+- PR#5729: tools/untypeast.ml creates unary Pexp_tuple
 - PR#5731: instruction scheduling forgot to account for destroyed registers
 - PR#5735: %apply and %revapply not first class citizens
 - PR#5738: first class module patterns not handled by ocamldep
 - PR#5742: missing bound checks in Array.sub
+- PR#5744: ocamldoc error on "val virtual"
 - PR#5757: GC compaction bug (crash)
+- PR#5758: Compiler bug when matching on floats
+- PR#5761: Incorrect bigarray custom block size
 
 
 OCaml 4.00.0:
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile 12873 2012-08-23 06:49:17Z garrigue $
+# $Id: Makefile 12929 2012-09-17 16:23:06Z doligez $
 
 # The main Makefile
 
 	@echo "Please refer to the installation instructions in file INSTALL."
 	@echo "If you've just unpacked the distribution, something like"
 	@echo "	./configure"
-	@echo "	make world"
-	@echo "	make opt"
+	@echo "	make world.opt"
 	@echo "	make install"
 	@echo "should work.  But see the file INSTALL for more details."
 
 .PHONY: partialclean beforedepend alldepend cleanboot coldstart
 .PHONY: compare core coreall
 .PHONY: coreboot defaultentry depend distclean install installopt
-.PHONY: library library-cross libraryopt ocamlbuild-mixed-boot
+.PHONY: library library-cross libraryopt
 .PHONY: ocamlbuild.byte ocamlbuild.native ocamldebugger ocamldoc
 .PHONY: ocamldoc.opt ocamllex ocamllex.opt ocamltools ocamltoolsopt
 .PHONY: ocamltoolsopt.opt ocamlyacc opt-core opt opt.opt otherlibraries
-4.00.1+dev3_2012-09-08
+4.00.1
 
 # The version string is the first line of this file.
 # It must be in the format described in stdlib/sys.mli
 
-# $Id: VERSION 12910 2012-09-10 09:52:09Z doligez $
+# $Id: VERSION 12983 2012-10-03 15:11:00Z doligez $

Binary file modified.

Binary file modified.

Binary file modified.

bytecomp/matching.ml

 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: matching.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
+(* $Id: matching.ml 12961 2012-09-27 13:30:07Z garrigue $ *)
 
 (* Compilation of pattern matching *)
 
       | _ -> 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
 ;(*                                                                     *)
 ;(***********************************************************************)
 
-;(* $Id: caml.el 12152 2012-02-13 17:48:41Z doligez $ *)
+;(* $Id: caml.el 12973 2012-09-28 16:54:20Z doligez $ *)
 
 ;;; caml.el --- OCaml code editing commands for Emacs
 
 (defconst caml-kwop-regexps (make-vector 9 nil)
   "Array of regexps representing caml keywords of different priorities.")
 
+(defun caml-in-shebang-line ()
+  (save-excursion
+    (beginning-of-line)
+    (and (= 1 (point)) (looking-at "#!"))))
+
 (defun caml-in-expr-p ()
   (let ((pos (point)) (in-expr t))
     (caml-find-kwop
              caml-matching-kw-regexp "\\|"
              (aref caml-kwop-regexps caml-max-indent-priority)))
     (cond
+     ; special case for #! at beginning of file
+     ((caml-in-shebang-line) (setq in-expr nil))
      ; special case for ;;
      ((and (> (point) 1) (= (preceding-char) ?\;) (= (following-char) ?\;))
       (setq in-expr nil))

ocamlbuild/my_std.ml

   let union a b =
     rev (rev_append_uniq (rev_append_uniq [] a) b)
 
+  let ordered_unique (type el) (lst : el list)  =
+    let module Set = Set.Make(struct
+      type t = el
+      let compare = Pervasives.compare
+      let print _ _ = ()
+    end)
+    in
+    let _, lst =
+      List.fold_left (fun (set,acc) el ->
+        if Set.mem el set
+        then set, acc
+        else Set.add el set, el :: acc) (Set.empty,[]) lst
+    in
+    List.rev lst
+
 end
 
 module String = struct

ocamlbuild/param_tags.ml

 (* Original author: Romain Bardou *)
 
 module StringSet = Set.Make(String)
-module SSOSet = Set.Make(struct
-  type t = string * string option
-  let compare = Pervasives.compare
-end)
 
 (* tag name -> tag action (string -> unit) *)
 let declared_tags = Hashtbl.create 17
 
-let acknowledged_tags = ref SSOSet.empty
+let acknowledged_tags = ref []
 
 let only_once f =
   let instances = ref StringSet.empty in
 
 let acknowledge tag =
   let tag = Lexers.tag_gen (Lexing.from_string tag) in
-  acknowledged_tags := SSOSet.add tag !acknowledged_tags
+  acknowledged_tags := tag :: !acknowledged_tags
+
 
 let really_acknowledge (name, param) =
   match param with
         List.iter (fun f -> f param) actions
 
 let init () =
-  SSOSet.iter really_acknowledge !acknowledged_tags
+  List.iter really_acknowledge (My_std.List.ordered_unique !acknowledged_tags)
 
 let make = Printf.sprintf "%s(%s)"

ocamlbuild/signatures.mli

   val print : (Format.formatter -> 'a -> 'b) -> Format.formatter -> 'a list -> unit
   val filter_opt : ('a -> 'b option) -> 'a list -> 'b list
   val union : 'a list -> 'a list -> 'a list
-
+  val ordered_unique : 'a list -> 'a list
   (* Original functions *)
   include module type of List
 end

ocamldoc/odoc_ast.ml

 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_ast.ml 12796 2012-07-30 11:22:29Z doligez $ *)
+(* $Id: odoc_ast.ml 12951 2012-09-25 07:14:43Z guesdon $ *)
 
 (** Analysis of implementation files. *)
 open Misc
         | { cf_desc = Typedtree.Tcf_val (_, _, _, ident, Tcfk_concrete exp, _) } :: q
           when Name.from_ident ident = name ->
             exp.Typedtree.exp_type
+        | { cf_desc = Typedtree.Tcf_val (_, _, _, ident, Tcfk_virtual typ, _) } :: q
+          when Name.from_ident ident = name ->
+            typ.Typedtree.ctyp_type
         | _ :: q ->
             iter q
       in
       in
       fun ct_decl -> iter ct_decl.Types.clty_type
 
-    let search_virtual_attribute_type table ctname name =
-      let ct_decl = search_class_type_declaration table ctname in
-      let cls_sig = class_sig_of_cltype_decl ct_decl.ci_type_decl in
-      let (_,_,texp) = Types.Vars.find name cls_sig.cty_vars in
-      texp
-
    let search_method_expression cls name =
       let rec iter = function
         | [] ->
           let complete_name = Name.concat current_class_name label in
           let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
           let type_exp =
-            try
-              if virt then
-                Typedtree_search.search_virtual_attribute_type table
-                (Name.simple current_class_name) label
-              else
-                Typedtree_search.search_attribute_type tt_cls label
+            try Typedtree_search.search_attribute_type tt_cls label
             with Not_found ->
                 raise (Failure (Odoc_messages.attribute_not_found_in_typedtree complete_name))
           in

ocamldoc/odoc_html.ml

 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: odoc_html.ml 12886 2012-08-27 11:49:55Z guesdon $ *)
+(* $Id: odoc_html.ml 12953 2012-09-25 07:50:40Z guesdon $ *)
 
 (** Generation of html documentation.*)
 
       if info then
         (
          if complete then
-           self#html_of_info ~indent: false
+           self#html_of_info ~indent: true
          else
            self#html_of_info_first_sentence
         ) b m.m_info
       if info then
         (
          if complete then
-           self#html_of_info ~indent: false
+           self#html_of_info ~indent: true
          else
            self#html_of_info_first_sentence
         ) b mt.mt_info
       print_DEBUG "html#html_of_class : info" ;
       (
        if complete then
-         self#html_of_info ~indent: false
+         self#html_of_info ~indent: true
        else
          self#html_of_info_first_sentence
       ) b c.cl_info
       bs b "</pre>";
       (
        if complete then
-         self#html_of_info ~indent: false
+         self#html_of_info ~indent: true
        else
          self#html_of_info_first_sentence
       ) b ct.clt_info

otherlibs/bigarray/bigarray_stubs.c

 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: bigarray_stubs.c 12433 2012-05-06 08:23:37Z xleroy $ */
+/* $Id: bigarray_stubs.c 12963 2012-09-27 15:48:40Z doligez $ */
 
 #include <stddef.h>
 #include <stdarg.h>
   }
   /* Compute required size in OCaml heap.  Assumes struct caml_ba_array
      is exactly 4 + num_dims words */
+  /* PR#5516: use C99's flexible array types if possible */
+#if (__STDC_VERSION__ >= 199901L)
+  Assert(sizeof(struct caml_ba_array) == 4 * sizeof(value));
+#else
   Assert(sizeof(struct caml_ba_array) == 5 * sizeof(value));
+#endif
   *wsize_32 = (4 + b->num_dims) * 4;
   *wsize_64 = (4 + b->num_dims) * 8;
 }
   case CAML_BA_NATIVE_INT:
     caml_ba_deserialize_longarray(b->data, num_elts); break;
   }
+  /* PR#5516: use C99's flexible array types if possible */
+#if (__STDC_VERSION__ >= 199901L)
+  return sizeof(struct caml_ba_array) + b->num_dims * sizeof(intnat);
+#else
   return sizeof(struct caml_ba_array) + (b->num_dims - 1) * sizeof(intnat);
+#endif
 }
 
 /* Create / update proxy to indicate that b2 is a sub-array of b1 */

otherlibs/labltk/lib/Makefile

 opt: $(LIBNAME).cmxa
 
 clean:
-	rm -f $(LIBNAME)top$(EXE) $(LIBNAME) *.cm* *.$(A)
+	rm -f $(LIBNAME)top$(EXE) $(LIBNAME) *.cm* *.$(A) *$(EXT_DLL)
 
 superclean:
 	- if test -f tk.cmo; then \
 	cd ../camltk; $(MAKE)
 	$(MKLIB) -ocamlc '$(CAMLCB)' -o $(LIBNAME) \
 	  -I ../labltk -I ../camltk $(TKOBJS) \
-	  $(TK_LINK)
+	  -cclib "\"$(TK_LINK)\""
 
 $(LIBNAME).cmxa: $(SUPPORT:.cmo=.cmx) ../Widgets.src
 	$(MAKE) superclean
 	cd ../camltk; $(MAKE) opt
 	$(MKLIB) -ocamlopt '$(CAMLOPTB)' -o $(LIBNAME) -oc $(LIBNAME) \
 	  -I ../labltk -I ../camltk $(TKOBJS:.cmo=.cmx) \
-	  $(TK_LINK)
+	  -cclib "\"$(TK_LINK)\""
 
 $(LIBNAME)top$(EXE) : $(TOPDEPS) $(LIBNAME).cma ../support/lib$(LIBNAME).$(A)
 	$(CAMLC) -verbose -linkall -o $(LIBNAME)top$(EXE) -I ../support \

otherlibs/unix/select.c

 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: select.c 11156 2011-07-27 14:17:02Z doligez $ */
+/* $Id: select.c 12947 2012-09-24 11:25:32Z xleroy $ */
 
 #include <mlvalues.h>
 #include <alloc.h>
 #endif
 #include <string.h>
 #include <unistd.h>
+#include <errno.h>
 
-typedef fd_set file_descr_set;
-
-static void fdlist_to_fdset(value fdlist, fd_set *fdset, int *maxfd)
+static int fdlist_to_fdset(value fdlist, fd_set *fdset, int *maxfd)
 {
   value l;
   FD_ZERO(fdset);
   for (l = fdlist; l != Val_int(0); l = Field(l, 1)) {
-    int fd = Int_val(Field(l, 0));
-    FD_SET(fd, fdset);
+    long fd = Long_val(Field(l, 0));
+    /* PR#5563: harden against bad fds */
+    if (fd < 0 || fd >= FD_SETSIZE) return -1;
+    FD_SET((int) fd, fdset);
     if (fd > *maxfd) *maxfd = fd;
   }
+  return 0;
 }
 
 static value fdset_to_fdlist(value fdlist, fd_set *fdset)
 
   Begin_roots3 (readfds, writefds, exceptfds);
     maxfd = -1;
-    fdlist_to_fdset(readfds, &read, &maxfd);
-    fdlist_to_fdset(writefds, &write, &maxfd);
-    fdlist_to_fdset(exceptfds, &except, &maxfd);
+    retcode  = fdlist_to_fdset(readfds, &read, &maxfd);
+    retcode += fdlist_to_fdset(writefds, &write, &maxfd);
+    retcode += fdlist_to_fdset(exceptfds, &except, &maxfd);
+    /* PR#5563: if a bad fd was encountered, report EINVAL error */
+    if (retcode != 0) unix_error(EINVAL, "select", Nothing);
     tm = Double_val(timeout);
     if (tm < 0.0)
       tvp = (struct timeval *) NULL;

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"
+;;

testsuite/tests/lib-systhreads/testfork.ml

   print_string "Forking..."; print_newline();
   match Unix.fork() with
   | 0 ->
+      Thread.delay 0.5;
       print_string "In child..."; print_newline();
       Gc.minor();
       print_string "Child did minor GC."; print_newline();
       exit 0
   | pid ->
       print_string "In parent..."; print_newline();
-      Thread.delay 2.0;
+      Thread.delay 4.0;
       print_string "Parent is exiting."; print_newline();
       exit 0
 

testsuite/tests/lib-threads/test5.runner

 ./program > test5.result &
 pid=$!
-sleep 1
+sleep 3
 kill -9 $pid

tools/untypeast.ml

         Pexp_construct (lid,
           (match args with
               [] -> None
-            | args -> Some
-                  { pexp_desc = Pexp_tuple (List.map untype_expression args);
-                  pexp_loc = exp.exp_loc; }
+          | [ arg ] -> Some (untype_expression arg)
+          | args -> Some
+            { pexp_desc = Pexp_tuple (List.map untype_expression args);
+              pexp_loc = exp.exp_loc; }
           ), explicit_arity)
     | Texp_variant (label, expo) ->
         Pexp_variant (label, match expo with

typing/parmatch.ml

 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: parmatch.ml 12800 2012-07-30 18:59:07Z doligez $ *)
+(* $Id: parmatch.ml 12961 2012-09-27 13:30:07Z garrigue $ *)
 
 (* Detection of partial matches and unused match cases. *)
 
 | 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

 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: parmatch.mli 12521 2012-05-31 07:57:32Z garrigue $ *)
+(* $Id: parmatch.mli 12961 2012-09-27 13:30:07Z garrigue $ *)
 
 (* Detection of partial matches and unused match cases. *)
 open Asttypes
 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
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.