Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
matching: constants aren't all in the same group
  • Loading branch information
trefis committed May 4, 2018
1 parent 597a85f commit d6a7a40
Show file tree
Hide file tree
Showing 2 changed files with 70 additions and 26 deletions.
38 changes: 34 additions & 4 deletions bytecomp/matching.ml
Expand Up @@ -728,9 +728,33 @@ let pat_as_constr = function
| {pat_desc=Tpat_construct (_, cstr,_)} -> cstr
| _ -> fatal_error "Matching.pat_as_constr"

let group_constant = function
| {pat_desc= Tpat_constant _} -> true
| _ -> false
let group_const_int = function
| {pat_desc= Tpat_constant Const_int _ } -> true
| _ -> false

let group_const_char = function
| {pat_desc= Tpat_constant Const_char _ } -> true
| _ -> false

let group_const_string = function
| {pat_desc= Tpat_constant Const_string _ } -> true
| _ -> false

let group_const_float = function
| {pat_desc= Tpat_constant Const_float _ } -> true
| _ -> false

let group_const_int32 = function
| {pat_desc= Tpat_constant Const_int32 _ } -> true
| _ -> false

let group_const_int64 = function
| {pat_desc= Tpat_constant Const_int64 _ } -> true
| _ -> false

let group_const_nativeint = function
| {pat_desc= Tpat_constant Const_nativeint _ } -> true
| _ -> false

and group_constructor = function
| {pat_desc = Tpat_construct (_,_,_)} -> true
Expand Down Expand Up @@ -762,7 +786,13 @@ and group_lazy = function

let get_group p = match p.pat_desc with
| Tpat_any -> group_var
| Tpat_constant _ -> group_constant
| Tpat_constant Const_int _ -> group_const_int
| Tpat_constant Const_char _ -> group_const_char
| Tpat_constant Const_string _ -> group_const_string
| Tpat_constant Const_float _ -> group_const_float
| Tpat_constant Const_int32 _ -> group_const_int32
| Tpat_constant Const_int64 _ -> group_const_int64
| Tpat_constant Const_nativeint _ -> group_const_nativeint
| Tpat_construct _ -> group_constructor
| Tpat_tuple _ -> group_tuple
| Tpat_record _ -> group_record
Expand Down
58 changes: 36 additions & 22 deletions testsuite/tests/basic/patmatch_incoherence.ml
Expand Up @@ -15,8 +15,16 @@ match { x = [] } with
| { x = "" :: _ } -> ()
;;
[%%expect{|
Uncaught exception: File "bytecomp/matching.ml", line 2237, characters 58-64: Assertion failed

(let (*match* = [0: 0a] *match* =a (field 0 *match*))
(if *match*
(let (*match* =a (field 0 *match*))
(catch
(if (!= *match* 3) (exit 1) (let (*match* =a (field 1 *match*)) 0a))
with (1)
(stringswitch *match*
case "": (let (*match* =a (field 1 *match*)) 0a))))
0a))
- : unit = ()
|}];;


Expand All @@ -31,8 +39,14 @@ match { x = assert false } with
| { x = "" } -> ()
;;
[%%expect{|
Uncaught exception: File "bytecomp/matching.ml", line 2237, characters 58-64: Assertion failed

(let
(*match* =
(makeblock 0
(raise (makeblock 0 (global Assert_failureg) [0: "" 1 12])))
*match* =a (field 0 *match*))
(catch (if (!= *match* 3) (exit 2) 0a) with (2)
(stringswitch *match* case "": 0a)))
Exception: Assert_failure ("", 1, 12).
|}];;

match { x = assert false } with
Expand All @@ -53,8 +67,8 @@ Here is an example of a case that is not matched:
(makeblock 0
(raise (makeblock 0 (global Assert_failureg) [0: "" 1 12])))
*match* =a (field 0 *match*))
(if *match* (exit 1) 0a))
with (1) (raise (makeblock 0 (global Match_failureg) [0: "" 1 0])))
(if *match* (exit 3) 0a))
with (3) (raise (makeblock 0 (global Match_failureg) [0: "" 1 0])))
Exception: Assert_failure ("", 1, 12).
|}];;

Expand All @@ -76,8 +90,8 @@ Here is an example of a case that is not matched:
(makeblock 0
(raise (makeblock 0 (global Assert_failureg) [0: "" 1 12])))
*match* =a (field 0 *match*))
(if *match* (exit 3) 0a))
with (3) (raise (makeblock 0 (global Match_failureg) [0: "" 1 0])))
(if *match* (exit 5) 0a))
with (5) (raise (makeblock 0 (global Match_failureg) [0: "" 1 0])))
Exception: Assert_failure ("", 1, 12).
|}];;

Expand All @@ -100,9 +114,9 @@ Here is an example of a case that is not matched:
(raise (makeblock 0 (global Assert_failureg) [0: "" 1 12])))
*match* =a (field 0 *match*))
(catch
(let (len =a (array.length[gen] *match*)) (if (!= len 0) (exit 6) 0a))
with (6) (if (!= *match* 3) (exit 5) 0a)))
with (5) (raise (makeblock 0 (global Match_failureg) [0: "" 1 0])))
(let (len =a (array.length[gen] *match*)) (if (!= len 0) (exit 8) 0a))
with (8) (if (!= *match* 3) (exit 7) 0a)))
with (7) (raise (makeblock 0 (global Match_failureg) [0: "" 1 0])))
Exception: Assert_failure ("", 1, 12).
|}];;

Expand All @@ -124,9 +138,9 @@ Here is an example of a case that is not matched:
(makeblock 0
(raise (makeblock 0 (global Assert_failureg) [0: "" 1 12])))
*match* =a (field 0 *match*))
(catch (if (!= *match* 88) (exit 8) 0a) with (8)
(if (!= *match* 3) (exit 7) 0a)))
with (7) (raise (makeblock 0 (global Match_failureg) [0: "" 1 0])))
(catch (if (!= *match* 88) (exit 10) 0a) with (10)
(if (!= *match* 3) (exit 9) 0a)))
with (9) (raise (makeblock 0 (global Match_failureg) [0: "" 1 0])))
Exception: Assert_failure ("", 1, 12).
|}];;

Expand All @@ -149,14 +163,14 @@ Here is an example of a case that is not matched:
(raise (makeblock 0 (global Assert_failureg) [0: "" 1 12])))
*match* =a (field 0 *match*))
(catch
(if (isint *match*) (exit 10)
(if (isint *match*) (exit 12)
(let (variant =a (field 0 *match*))
(if (!= variant 88) (exit 10)
(if (!= variant 88) (exit 12)
(let (*match* =a (field 1 *match*))
(stringswitch *match* case "lol": 0a
default: (exit 9))))))
with (10) (if (!= *match* 3) (exit 9) 0a)))
with (9) (raise (makeblock 0 (global Match_failureg) [0: "" 1 0])))
default: (exit 11))))))
with (12) (if (!= *match* 3) (exit 11) 0a)))
with (11) (raise (makeblock 0 (global Match_failureg) [0: "" 1 0])))
Exception: Assert_failure ("", 1, 12).
|}];;

Expand All @@ -181,10 +195,10 @@ Here is an example of a case that is not matched:
(raise (makeblock 0 (global Assert_failureg) [0: "" 1 12])))
*match* =a (field 0 *match*)
*match* =a (field 0 *match*))
(if (!=. *match* 2.) (exit 11)
(if (!=. *match* 2.) (exit 13)
(let (*match* =a (field 1 *match*))
(stringswitch *match* case "": 0a
default: (exit 11)))))
with (11) (raise (makeblock 0 (global Match_failureg) [0: "" 1 0])))
default: (exit 13)))))
with (13) (raise (makeblock 0 (global Match_failureg) [0: "" 1 0])))
Exception: Assert_failure ("", 1, 12).
|}];;

0 comments on commit d6a7a40

Please sign in to comment.