[asl] Allow ATCs on tuples

asllib/Interpreter.ml

@@ -298,8 +298,10 @@ module Make (B : Backend.S) (C : Config) = struct
   (* Utils *)
   (* ----- *)
   let v_false = L_Bool false |> B.v_of_literal
-  let m_false = return v_false
+  let v_true = L_Bool true |> B.v_of_literal
   let v_zero = L_Int Z.zero |> B.v_of_literal
+  let m_false = return v_false
+  let m_true = return v_true
   let m_zero = return v_zero
 
   let sync_list ms =
@@ -563,36 +565,48 @@ module Make (B : Backend.S) (C : Config) = struct
 
   (* Begin ValOfType *)
   and is_val_of_type loc env v ty : bool B.m =
-    let value_m_to_bool_m m = choice m true false in
     let big_or = big_op m_false (B.binop BOR) in
-    match ty.desc with
-    | T_Int UnConstrained -> return true
-    | T_Int (UnderConstrained _) ->
-        (* This cannot happen, because:
-           1. Forgetting now about named types, or any kind of compound types,
-              you cannot ask: [expr as ty] if ty is the unconstrained integer
-              because there is no syntax for it.
-           2. You cannot construct a type that is an alias for the
-              underconstrained integer type.
-           3. You cannot put the underconstrained integer type in a compound
-              type.
-        *)
-        fatal_from loc Error.UnrespectedParserInvariant
-    | T_Bits (e, _) ->
-        let* v' = eval_expr_sef env e and* v_length = B.bitvector_length v in
-        B.binop EQ_OP v_length v' |> value_m_to_bool_m
-    | T_Int (WellConstrained constraints) ->
-        let map_constraint = function
-          | Constraint_Exact e ->
-              let* v' = eval_expr_sef env e in
-              B.binop EQ_OP v v'
-          | Constraint_Range (e1, e2) ->
-              let* v1 = eval_expr_sef env e1 and* v2 = eval_expr_sef env e2 in
-              let* c1 = B.binop LEQ v1 v and* c2 = B.binop LEQ v v2 in
-              B.binop BAND c1 c2
-        in
-        List.map map_constraint constraints |> big_or |> value_m_to_bool_m
-    | _ -> fatal_from loc TypeInferenceNeeded
+    let rec in_values v ty =
+      match ty.desc with
+      | T_Int UnConstrained -> m_true
+      | T_Int (UnderConstrained _) ->
+          (* This cannot happen, because:
+             1. Forgetting now about named types, or any kind of compound types,
+                you cannot ask: [expr as ty] if ty is the unconstrained integer
+                because there is no syntax for it.
+             2. You cannot construct a type that is an alias for the
+                underconstrained integer type.
+             3. You cannot put the underconstrained integer type in a compound
+                type.
+          *)
+          fatal_from loc Error.UnrespectedParserInvariant
+      | T_Bits (e, _) ->
+          let* v' = eval_expr_sef env e and* v_length = B.bitvector_length v in
+          B.binop EQ_OP v_length v'
+      | T_Int (WellConstrained constraints) ->
+          let map_constraint = function
+            | Constraint_Exact e ->
+                let* v' = eval_expr_sef env e in
+                B.binop EQ_OP v v'
+            | Constraint_Range (e1, e2) ->
+                let* v1 = eval_expr_sef env e1 and* v2 = eval_expr_sef env e2 in
+                let* c1 = B.binop LEQ v1 v and* c2 = B.binop LEQ v v2 in
+                B.binop BAND c1 c2
+          in
+          List.map map_constraint constraints |> big_or
+      | T_Tuple tys ->
+          let fold (i, prev) ty' =
+            let m =
+              let* v' = B.get_index i v in
+              let* here = in_values v' ty' in
+              prev >>= B.binop BAND here
+            in
+            (i + 1, m)
+          in
+          List.fold_left fold (0, m_true) tys |> snd
+      | _ -> fatal_from loc TypeInferenceNeeded
+    in
+    choice (in_values v ty) true false
   (* End *)
 
   (* Evaluation of Left-Hand-Side Expressions *)

asllib/Typing.ml

@@ -213,6 +213,7 @@ module Property (C : ANNOTATE_CONFIG) = struct
   let ok () = () [@@inline]
   let check_true b fail () = if b then () else fail () [@@inline]
   let check_true' b = check_true b assumption_failed [@@inline]
+  let check_all2 li1 li2 f () = List.iter2 (fun x1 x2 -> f x1 x2 ()) li1 li2
 end
 
 (* -------------------------------------------------------------------------
@@ -871,6 +872,16 @@ module Annotate (C : ANNOTATE_CONFIG) = struct
         t1 |: TypingRule.CheckUnop
   (* End *)
 
+  let rec check_atc ~fail env t1 t2 =
+    if Types.type_equal env t1 t2 then ok
+    else
+      match (t1.desc, t2.desc) with
+      | T_Int _, T_Int _ | T_Bits _, T_Bits _ -> ok
+      | T_Tuple l1, T_Tuple l2 when List.compare_lengths l1 l2 = 0 ->
+          check_all2 l1 l2 (check_atc ~fail env)
+      | T_Named _, _ | _, T_Named _ -> assert false
+      | _ -> fail
+
   let var_in_env ?(local = true) env x =
     (local && IMap.mem x env.local.storage_types)
     || IMap.mem x env.global.storage_types
@@ -1399,12 +1410,12 @@ module Annotate (C : ANNOTATE_CONFIG) = struct
         let t_struct = Types.get_structure env t in
         let ty' = annotate_type ~loc env ty in
         let ty_struct = Types.get_structure env ty' in
-        (if Types.type_equal env t_struct ty_struct then (ty', e'')
-         else
-           match (t_struct.desc, ty_struct.desc) with
-           | T_Bits _, T_Bits _ | T_Int _, T_Int _ ->
-               (ty', E_ATC (e'', ty_struct) |> here)
-           | _ -> fatal_from e (BadATC (t, ty')))
+        let+ () =
+          check_atc env t_struct ty_struct ~fail:(fun () ->
+              fatal_from loc (BadATC (t, ty)))
+        in
+        (if Types.subtype_satisfies env t ty' then (ty', e'')
+         else (ty', E_ATC (e'', ty_struct) |> here))
         |: TypingRule.ATC
     (* End *)
     | E_Var x -> (

asllib/tests/atcs.t

@@ -64,9 +64,9 @@ ATCs on other types
   > end
 
   $ aslref atcs6.asl
-  File atcs6.asl, line 3, characters 11 to 33:
-  ASL Typing error: cannot perform Asserted Type Conversion on
-    (integer {42}, bits(4)) by myty.
+  File atcs6.asl, line 3, characters 11 to 25:
+  ASL Execution error: Mismatch type:
+    value [42, '0000'] does not belong to type (integer {0..10}, bits(4)).
   [1]
 
   $ cat > atcs7.asl <<EOF