diff --git a/ocaml/lambda/debuginfo.ml b/ocaml/lambda/debuginfo.ml index 8eabb28424d..e36d3c18207 100644 --- a/ocaml/lambda/debuginfo.ml +++ b/ocaml/lambda/debuginfo.ml @@ -231,17 +231,17 @@ let compare { dbg = dbg1; } { dbg = dbg2; } = | d1 :: ds1, d2 :: ds2 -> let c = String.compare d1.dinfo_file d2.dinfo_file in if c <> 0 then c else - let c = compare d1.dinfo_line d2.dinfo_line in + let c = Int.compare d1.dinfo_line d2.dinfo_line in if c <> 0 then c else - let c = compare d1.dinfo_char_end d2.dinfo_char_end in + let c = Int.compare d1.dinfo_char_end d2.dinfo_char_end in if c <> 0 then c else - let c = compare d1.dinfo_char_start d2.dinfo_char_start in + let c = Int.compare d1.dinfo_char_start d2.dinfo_char_start in if c <> 0 then c else - let c = compare d1.dinfo_start_bol d2.dinfo_start_bol in + let c = Int.compare d1.dinfo_start_bol d2.dinfo_start_bol in if c <> 0 then c else - let c = compare d1.dinfo_end_bol d2.dinfo_end_bol in + let c = Int.compare d1.dinfo_end_bol d2.dinfo_end_bol in if c <> 0 then c else - let c = compare d1.dinfo_end_line d2.dinfo_end_line in + let c = Int.compare d1.dinfo_end_line d2.dinfo_end_line in if c <> 0 then c else loop ds1 ds2 in diff --git a/ocaml/parsing/builtin_attributes.ml b/ocaml/parsing/builtin_attributes.ml index c45ac147b3b..6a084155e28 100644 --- a/ocaml/parsing/builtin_attributes.ml +++ b/ocaml/parsing/builtin_attributes.ml @@ -31,11 +31,7 @@ let mark_used t = Attribute_table.remove unused_attrs t (* [attr_order] is used to issue unused attribute warnings in the order the attributes occur in the file rather than the random order of the hash table *) -let attr_order a1 a2 = - match String.compare a1.loc.loc_start.pos_fname a2.loc.loc_start.pos_fname - with - | 0 -> Int.compare a1.loc.loc_start.pos_lnum a2.loc.loc_start.pos_lnum - | n -> n +let attr_order a1 a2 = Location.compare a1.loc a2.loc let unchecked_properties = Attribute_table.create 1 let mark_property_checked txt loc = diff --git a/ocaml/parsing/location.ml b/ocaml/parsing/location.ml index 79cdfae109b..17dc69034c7 100644 --- a/ocaml/parsing/location.ml +++ b/ocaml/parsing/location.ml @@ -18,6 +18,46 @@ open Lexing type t = Warnings.loc = { loc_start: position; loc_end: position; loc_ghost: bool };; +let compare_position : position -> position -> int = + fun + { pos_fname = pos_fname_1 + ; pos_lnum = pos_lnum_1 + ; pos_bol = pos_bol_1 + ; pos_cnum = pos_cnum_1 + } + { pos_fname = pos_fname_2 + ; pos_lnum = pos_lnum_2 + ; pos_bol = pos_bol_2 + ; pos_cnum = pos_cnum_2 + } + -> + match String.compare pos_fname_1 pos_fname_2 with + | 0 -> begin match Int.compare pos_lnum_1 pos_lnum_2 with + | 0 -> begin match Int.compare pos_bol_1 pos_bol_2 with + | 0 -> Int.compare pos_cnum_1 pos_cnum_2 + | i -> i + end + | i -> i + end + | i -> i +;; + +let compare + { loc_start = loc_start_1 + ; loc_end = loc_end_1 + ; loc_ghost = loc_ghost_1 } + { loc_start = loc_start_2 + ; loc_end = loc_end_2 + ; loc_ghost = loc_ghost_2 } + = + match compare_position loc_start_1 loc_start_2 with + | 0 -> begin match compare_position loc_end_1 loc_end_2 with + | 0 -> Bool.compare loc_ghost_1 loc_ghost_2 + | i -> i + end + | i -> i +;; + let in_file name = let loc = { dummy_pos with pos_fname = name } in { loc_start = loc; loc_end = loc; loc_ghost = true } @@ -274,6 +314,11 @@ struct (* non overlapping intervals *) type 'a t = ('a bound * 'a bound) list + let compare (fst1, snd1) (fst2, snd2) = + match Int.compare fst1 fst2 with + | 0 -> Int.compare snd1 snd2 + | i -> i + let of_intervals intervals = let pos = List.map (fun ((a, x), (b, y)) -> diff --git a/ocaml/parsing/location.mli b/ocaml/parsing/location.mli index 9b04565325a..ab4436be09f 100644 --- a/ocaml/parsing/location.mli +++ b/ocaml/parsing/location.mli @@ -52,6 +52,14 @@ type t = Warnings.loc = { Else all fields are correct. *) +(** Strict comparison: Compares all fields of the two locations, irrespective of + whether or not they happen to refer to the same place. For fully-defined + locations within the same file, is guaranteed to return them in source + order; otherwise, or if given two locations that differ only in ghostiness, + is just guaranteed to produce a consistent order, but which one is + unspecified. *) +val compare : t -> t -> int + val none : t (** An arbitrary value of type [t]; describes an empty ghost range. *) diff --git a/ocaml/testsuite/tests/warnings/w53.compilers.reference b/ocaml/testsuite/tests/warnings/w53.compilers.reference index c2012bb4103..93a993a9464 100644 --- a/ocaml/testsuite/tests/warnings/w53.compilers.reference +++ b/ocaml/testsuite/tests/warnings/w53.compilers.reference @@ -98,14 +98,14 @@ File "w53.ml", line 75, characters 14-25: 75 | type t4 [@@@immediate64] (* rejected *) ^^^^^^^^^^^ Warning 53 [misplaced-attribute]: the "immediate64" attribute cannot appear in this context -File "w53.ml", line 79, characters 32-43: -79 | let x = (4 [@immediate], 42 [@immediate64]) (* rejected *) - ^^^^^^^^^^^ -Warning 53 [misplaced-attribute]: the "immediate64" attribute cannot appear in this context File "w53.ml", line 79, characters 15-24: 79 | let x = (4 [@immediate], 42 [@immediate64]) (* rejected *) ^^^^^^^^^ Warning 53 [misplaced-attribute]: the "immediate" attribute cannot appear in this context +File "w53.ml", line 79, characters 32-43: +79 | let x = (4 [@immediate], 42 [@immediate64]) (* rejected *) + ^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "immediate64" attribute cannot appear in this context File "w53.ml", line 84, characters 26-31: 84 | type t2 = {x : int} [@@@boxed] (* rejected *) ^^^^^ @@ -118,14 +118,14 @@ File "w53.ml", line 87, characters 17-24: 87 | val x : int [@@unboxed] (* rejected *) ^^^^^^^ Warning 53 [misplaced-attribute]: the "unboxed" attribute cannot appear in this context -File "w53.ml", line 91, characters 30-35: -91 | let x = (5 [@unboxed], 42 [@boxed]) (* rejected *) - ^^^^^ -Warning 53 [misplaced-attribute]: the "boxed" attribute cannot appear in this context File "w53.ml", line 91, characters 15-22: 91 | let x = (5 [@unboxed], 42 [@boxed]) (* rejected *) ^^^^^^^ Warning 53 [misplaced-attribute]: the "unboxed" attribute cannot appear in this context +File "w53.ml", line 91, characters 30-35: +91 | let x = (5 [@unboxed], 42 [@boxed]) (* rejected *) + ^^^^^ +Warning 53 [misplaced-attribute]: the "boxed" attribute cannot appear in this context File "w53.ml", line 95, characters 21-30: 95 | type 'a t1 = 'a [@@principal] (* rejected *) ^^^^^^^^^ diff --git a/ocaml/testsuite/tests/warnings/w53_marshalled.compilers.reference b/ocaml/testsuite/tests/warnings/w53_marshalled.compilers.reference index 3676847046c..c7df69df884 100644 --- a/ocaml/testsuite/tests/warnings/w53_marshalled.compilers.reference +++ b/ocaml/testsuite/tests/warnings/w53_marshalled.compilers.reference @@ -94,14 +94,14 @@ File "w53.ml", line 75, characters 14-25: 75 | type t4 [@@@immediate64] (* rejected *) ^^^^^^^^^^^ Warning 53 [misplaced-attribute]: the "immediate64" attribute cannot appear in this context -File "w53.ml", line 79, characters 32-43: -79 | let x = (4 [@immediate], 42 [@immediate64]) (* rejected *) - ^^^^^^^^^^^ -Warning 53 [misplaced-attribute]: the "immediate64" attribute cannot appear in this context File "w53.ml", line 79, characters 15-24: 79 | let x = (4 [@immediate], 42 [@immediate64]) (* rejected *) ^^^^^^^^^ Warning 53 [misplaced-attribute]: the "immediate" attribute cannot appear in this context +File "w53.ml", line 79, characters 32-43: +79 | let x = (4 [@immediate], 42 [@immediate64]) (* rejected *) + ^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "immediate64" attribute cannot appear in this context File "w53.ml", line 84, characters 26-31: 84 | type t2 = {x : int} [@@@boxed] (* rejected *) ^^^^^ @@ -114,14 +114,14 @@ File "w53.ml", line 87, characters 17-24: 87 | val x : int [@@unboxed] (* rejected *) ^^^^^^^ Warning 53 [misplaced-attribute]: the "unboxed" attribute cannot appear in this context -File "w53.ml", line 91, characters 30-35: -91 | let x = (5 [@unboxed], 42 [@boxed]) (* rejected *) - ^^^^^ -Warning 53 [misplaced-attribute]: the "boxed" attribute cannot appear in this context File "w53.ml", line 91, characters 15-22: 91 | let x = (5 [@unboxed], 42 [@boxed]) (* rejected *) ^^^^^^^ Warning 53 [misplaced-attribute]: the "unboxed" attribute cannot appear in this context +File "w53.ml", line 91, characters 30-35: +91 | let x = (5 [@unboxed], 42 [@boxed]) (* rejected *) + ^^^^^ +Warning 53 [misplaced-attribute]: the "boxed" attribute cannot appear in this context File "w53.ml", line 95, characters 21-30: 95 | type 'a t1 = 'a [@@principal] (* rejected *) ^^^^^^^^^ diff --git a/ocaml/tools/ocamlprof.ml b/ocaml/tools/ocamlprof.ml index 05df51bbb93..79ac5fd0f0c 100644 --- a/ocaml/tools/ocamlprof.ml +++ b/ocaml/tools/ocamlprof.ml @@ -134,7 +134,7 @@ let init_rewrite modes mod_name = end let final_rewrite add_function = - to_insert := List.sort (fun x y -> compare (snd x) (snd y)) !to_insert; + to_insert := List.sort (fun x y -> Int.compare (snd x) (snd y)) !to_insert; prof_counter := 0; List.iter add_function !to_insert; copy (in_channel_length !inchan); diff --git a/ocaml/typing/stypes.ml b/ocaml/typing/stypes.ml index d35cc889431..7dee0018867 100644 --- a/ocaml/typing/stypes.ml +++ b/ocaml/typing/stypes.ml @@ -65,8 +65,8 @@ let record_phrase loc = same upper bound -> sorted by decreasing lower bound *) let cmp_loc_inner_first loc1 loc2 = - match compare loc1.loc_end.pos_cnum loc2.loc_end.pos_cnum with - | 0 -> compare loc2.loc_start.pos_cnum loc1.loc_start.pos_cnum + match Int.compare loc1.loc_end.pos_cnum loc2.loc_end.pos_cnum with + | 0 -> Int.compare loc2.loc_start.pos_cnum loc1.loc_start.pos_cnum | x -> x ;; let cmp_ti_inner_first ti1 ti2 =