[Ada] Missing constraint check on if-expression returning a string

If the context of an if-expression is constrained, its dependent
expressions must obey the constraints of the expected type. Prior to
this patch, this check was performed only for scalar types, by means of
an added conversion.  This is now enforced on all types by means of a
qualified expression on each dependent expression.

Compiling ce.adb must yield:

  ce.adb:33:21: warning: string length wrong for type "T" defined at line 5
  ce.adb:33:21: warning: "Constraint_Error" will be raised at run time
  ce.adb:37:39: warning: string length wrong for type "T" defined at line 5
  ce.adb:37:39: warning: "Constraint_Error" will be raised at run time
  ce.adb:38:39: warning: too few elements for type "T" defined at line 5
  ce.adb:38:39: warning: "Constraint_Error" will be raised at run time
  ce.adb:39:39: warning: too few elements for type "T" defined at line 5
  ce.adb:39:39: warning: "Constraint_Error" will be raised at run time
----
with Text_IO;
procedure Ce is

  package Aerodrome_Identifier is
    subtype T is String (1 .. 4);
  end;

  package Flight_Identifier is
    type T is
     record
       ADEP                : Aerodrome_Identifier.T;
       Counter             : Positive;
     end record;
  end;

  procedure Assign (X : Flight_Identifier.T) is
  begin
    Text_IO.Put_Line (X.ADEP); -- outputs the 4 zero bytes
  end;

  function Env_Aerodrome_Value return String is ("ABCD");
  function Void return String is ("What?");
  function Void2 return String is
  begin
    return "who knows";
  end;
  Here : Aerodrome_Identifier.T;
  type Four is range 1 .. 4;
  Nothing : String := "";
begin
  Assign((ADEP =>
       (if (Void'Length = 5)
               then "" --!! This value should always raise Constraint_Error !!
                  else Env_Aerodrome_Value & "!"),
        Counter=> 17));

   Here := (if (Void'Length = 5) then "" else Env_Aerodrome_Value);
   Here := (if (Void'Length = 5) then Nothing else Env_Aerodrome_Value);
   Here := (if (Void'Length = 5) then Void2 (1..3) else Void2 & Void);
end;
----

2018-11-14  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* sem_res.adb (Resolve_If_Expression): Verify that the subtypes
	of all dependent expressions obey the constraints of the
	expected type for the if-expression.
	(Analyze_Expression): Only add qualificiation to the dependent
	expressions when the context type is constrained. Small
	adjustment to previous patch.

From-SVN: r266128

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 82329ac..8832485 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,12 @@
+2018-11-14  Ed Schonberg  <schonberg@adacore.com>
+
+       * sem_res.adb (Resolve_If_Expression): Verify that the subtypes
+       of all dependent expressions obey the constraints of the
+       expected type for the if-expression.
+       (Analyze_Expression): Only add qualificiation to the dependent
+       expressions when the context type is constrained. Small
+       adjustment to previous patch.
+
 2018-11-14  Eric Botcazou  <ebotcazou@adacore.com>
 
        * sem_prag.adb (Process_Compile_Time_Warning_Or_Error): Don't

diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 800bf69..eb17098 100644 (file)
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -8460,8 +8460,35 @@ package body Sem_Res is
       Condition : constant Node_Id := First (Expressions (N));
       Then_Expr : Node_Id;
       Else_Expr : Node_Id;
-      Else_Typ  : Entity_Id;
-      Then_Typ  : Entity_Id;
+
+      procedure Apply_Check (Expr : Node_Id);
+      --  When a dependent expression is of a subtype different from the
+      --  context subtype, then insert a qualification  to ensure the
+      --  generation of a constraint check. This was previously done only
+      --  for scalar types.
+
+      -----------------
+      -- Apply_Check --
+      -----------------
+
+      procedure Apply_Check (Expr : Node_Id) is
+         Loc       : constant Source_Ptr := Sloc (Expr);
+         Expr_Type : constant Entity_Id := Etype (Expr);
+      begin
+
+         if Expr_Type /= Typ
+            and then not Is_Tagged_Type (Typ)
+            and then not Is_Access_Type (Typ)
+            and then Is_Constrained (Typ)
+            and then not Inside_A_Generic
+         then
+            Rewrite (Expr,
+                 Make_Qualified_Expression (Loc,
+                   Subtype_Mark => New_Occurrence_Of (Typ, Loc),
+                   Expression   => Relocate_Node (Expr)));
+            Analyze_And_Resolve (Expr, Typ);
+         end if;
+      end Apply_Check;
 
    begin
       --  Defend against malformed expressions
@@ -8480,17 +8507,7 @@ package body Sem_Res is
 
       Resolve (Condition, Any_Boolean);
       Resolve (Then_Expr, Typ);
-      Then_Typ := Etype (Then_Expr);
-
-      --  When the "then" expression is of a scalar subtype different from the
-      --  result subtype, then insert a conversion to ensure the generation of
-      --  a constraint check. The same is done for the else part below, again
-      --  comparing subtypes rather than base types.
-
-      if Is_Scalar_Type (Then_Typ) and then Then_Typ /= Typ then
-         Rewrite (Then_Expr, Convert_To (Typ, Then_Expr));
-         Analyze_And_Resolve (Then_Expr, Typ);
-      end if;
+      Apply_Check (Then_Expr);
 
       --  If ELSE expression present, just resolve using the determined type
       --  If type is universal, resolve to any member of the class.
@@ -8506,16 +8523,12 @@ package body Sem_Res is
             Resolve (Else_Expr, Typ);
          end if;
 
-         Else_Typ := Etype (Else_Expr);
-
-         if Is_Scalar_Type (Else_Typ) and then Else_Typ /= Typ then
-            Rewrite (Else_Expr, Convert_To (Typ, Else_Expr));
-            Analyze_And_Resolve (Else_Expr, Typ);
+         Apply_Check (Else_Expr);
 
          --  Apply RM 4.5.7 (17/3): whether the expression is statically or
          --  dynamically tagged must be known statically.
 
-         elsif Is_Tagged_Type (Typ) and then not Is_Class_Wide_Type (Typ) then
+         if Is_Tagged_Type (Typ) and then not Is_Class_Wide_Type (Typ) then
             if Is_Dynamically_Tagged (Then_Expr) /=
                Is_Dynamically_Tagged (Else_Expr)
             then