From b755002353acce53a9655374eb7627f286c0b3eb Mon Sep 17 00:00:00 2001
From: Hadrien Renaud <hadrien.renaud2@arm.com>
Date: Mon, 28 Oct 2024 17:55:36 +0000
Subject: [PATCH] [asl] Change error message for bad pattern.

---
 asllib/PP.mli                              |  3 +++
 asllib/Typing.ml                           | 18 ++++++++----------
 asllib/error.ml                            |  5 +++++
 asllib/tests/regressions.t/bad-pattern.asl |  6 ++++++
 asllib/tests/regressions.t/run.t           |  2 ++
 5 files changed, 24 insertions(+), 10 deletions(-)
 create mode 100644 asllib/tests/regressions.t/bad-pattern.asl

diff --git a/asllib/PP.mli b/asllib/PP.mli
index 2e3a7706f..4370abc36 100644
--- a/asllib/PP.mli
+++ b/asllib/PP.mli
@@ -76,6 +76,9 @@ val pp_int_constraints : int_constraint list printer
 val pp_local_decl_item : local_decl_item printer
 (** Pretty-print a local declaration item. *)
 
+val pp_pattern : pattern printer
+(** Pretty-print a pattern. *)
+
 val pp_t : t printer
 (** Print an AST from printer for a literal *)
 
diff --git a/asllib/Typing.ml b/asllib/Typing.ml
index 9bfe96775..e6ac1214e 100644
--- a/asllib/Typing.ml
+++ b/asllib/Typing.ml
@@ -1239,7 +1239,7 @@ module Annotate (C : ANNOTATE_CONFIG) : S = struct
         Pattern_Not new_q |: TypingRule.PNot
     (* End *)
     (* Begin PSingle *)
-    | Pattern_Single e ->
+    | Pattern_Single e as p ->
         let t_e, e' = annotate_expr env e in
         let+ () =
          fun () ->
@@ -1254,12 +1254,12 @@ module Annotate (C : ANNOTATE_CONFIG) : S = struct
           | T_Bits _, T_Bits _ ->
               check_bits_equal_width loc env t_struct t_e_struct ()
           | T_Enum li1, T_Enum li2 when list_equal String.equal li1 li2 -> ()
-          | _ -> fatal_from loc (Error.BadTypesForBinop (EQ_OP, t, t_e))
+          | _ -> fatal_from loc (Error.BadPattern (p, t))
         in
         Pattern_Single e' |: TypingRule.PSingle
     (* End *)
     (* Begin PGeq *)
-    | Pattern_Geq e ->
+    | Pattern_Geq e as p ->
         let t_e, e' = annotate_expr env e in
         let+ () = check_statically_evaluable env e' in
         let+ () =
@@ -1268,12 +1268,12 @@ module Annotate (C : ANNOTATE_CONFIG) : S = struct
           and t_e_struct = Types.get_structure env t_e in
           match (t_struct.desc, t_e_struct.desc) with
           | T_Real, T_Real | T_Int _, T_Int _ -> ()
-          | _ -> fatal_from loc (Error.BadTypesForBinop (GEQ, t, t_e))
+          | _ -> fatal_from loc (Error.BadPattern (p, t))
         in
         Pattern_Geq e' |: TypingRule.PGeq
     (* End *)
     (* Begin PLeq *)
-    | Pattern_Leq e ->
+    | Pattern_Leq e as p ->
         let t_e, e' = annotate_expr env e in
         let+ () = check_statically_evaluable env e' in
         let+ () =
@@ -1282,12 +1282,12 @@ module Annotate (C : ANNOTATE_CONFIG) : S = struct
           and t_e_anon = Types.make_anonymous env t_e in
           match (t_anon.desc, t_e_anon.desc) with
           | T_Real, T_Real | T_Int _, T_Int _ -> ()
-          | _ -> fatal_from loc (Error.BadTypesForBinop (LEQ, t, t_e))
+          | _ -> fatal_from loc (Error.BadPattern (p, t))
         in
         Pattern_Leq e' |: TypingRule.PLeq
     (* End *)
     (* Begin PRange *)
-    | Pattern_Range (e1, e2) ->
+    | Pattern_Range (e1, e2) as p ->
         let t_e1, e1' = annotate_expr env e1
         and t_e2, e2' = annotate_expr env e2 in
         let+ () =
@@ -1297,9 +1297,7 @@ module Annotate (C : ANNOTATE_CONFIG) : S = struct
           and t_e2_anon = Types.make_anonymous env t_e2 in
           match (t_anon.desc, t_e1_anon.desc, t_e2_anon.desc) with
           | T_Real, T_Real, T_Real | T_Int _, T_Int _, T_Int _ -> ()
-          | _, T_Int _, T_Int _ | _, T_Real, T_Real ->
-              fatal_from loc (Error.BadTypesForBinop (GEQ, t, t_e1))
-          | _ -> fatal_from loc (Error.BadTypesForBinop (GEQ, t_e1, t_e2))
+          | _ -> fatal_from loc (Error.BadPattern (p, t))
         in
         Pattern_Range (e1', e2') |: TypingRule.PRange
     (* End *)
diff --git a/asllib/error.ml b/asllib/error.ml
index d5d11e7c4..1d8aaaa9e 100644
--- a/asllib/error.ml
+++ b/asllib/error.ml
@@ -63,6 +63,7 @@ type error_desc =
   | BadRecursiveDecls of identifier list
   | UnrespectedParserInvariant
   | BadATC of ty * ty  (** asserting, asserted *)
+  | BadPattern of pattern * ty
   | ConstrainedIntegerExpected of ty
   | ParameterWithoutDecl of identifier
   | BaseValueEmptyType of ty
@@ -269,6 +270,10 @@ module PPrint = struct
            corresponding@ getter@ of@ signature@ @[@[%a@]@ ->@ %a@]"
           func.name (pp_comma_list pp_ty) args pp_ty ret
     | UnexpectedATC -> pp_print_text f "ASL Typing error: unexpected ATC."
+    | BadPattern (p, t) ->
+        fprintf f
+          "ASL Typing error:@ Bad@ pattern@ %a@ for@ expression@ of@ type@ %a."
+          pp_pattern p pp_ty t
     | BadReturnStmt (Some t) ->
         fprintf f
           "ASL Typing error:@ cannot@ return@ nothing@ from@ a@ function,@ an@ \
diff --git a/asllib/tests/regressions.t/bad-pattern.asl b/asllib/tests/regressions.t/bad-pattern.asl
new file mode 100644
index 000000000..a70fcf9ba
--- /dev/null
+++ b/asllib/tests/regressions.t/bad-pattern.asl
@@ -0,0 +1,6 @@
+func main () => integer
+begin
+  case 3 of
+  when '101' => print ("Cannot happen");
+  end
+end
diff --git a/asllib/tests/regressions.t/run.t b/asllib/tests/regressions.t/run.t
index 3882e03bb..2a4fe9f61 100644
--- a/asllib/tests/regressions.t/run.t
+++ b/asllib/tests/regressions.t/run.t
@@ -438,3 +438,5 @@ Empty getters/setters
   ASL Static Error: Unsupported expression n.
   File pstate-exp.asl, line 98, characters 12 to 13:
   ASL Static Error: Unsupported expression n.
+
+  $ aslref bad-pattern.asl