2012-04-02 Robert Dewar <dewar@adacore.com>

	* einfo.adb (First_Component_Or_Discriminant) Now applies to
	all types with discriminants, not just records.
	* exp_attr.adb (Expand_N_Attribute): Add Scalar_Values handling
	for arrays, scalars and non-variant records.
	* sem_attr.adb (Analyze_Attribute): Handle Valid_Scalars
	* sem_attr.ads (Valid_Scalars): Update description
	* sem_util.ads, sem_util.adb (No_Scalar_Parts): New function.

From-SVN: r186069

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 39a5be5..b8155a1 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,13 @@
+2012-04-02  Robert Dewar  <dewar@adacore.com>
+
+       * einfo.adb (First_Component_Or_Discriminant) Now applies to
+       all types with discriminants, not just records.
+       * exp_attr.adb (Expand_N_Attribute): Add Scalar_Values handling
+       for arrays, scalars and non-variant records.
+       * sem_attr.adb (Analyze_Attribute): Handle Valid_Scalars
+       * sem_attr.ads (Valid_Scalars): Update description
+       * sem_util.ads, sem_util.adb (No_Scalar_Parts): New function.
+
 2012-03-31  Eric Botcazou  <ebotcazou@adacore.com>
 
        Revert

diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index 0fdc83c..0f597a1 100644 (file)
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -5880,7 +5880,9 @@ package body Einfo is
 
    begin
       pragma Assert
-        (Is_Record_Type (Id) or else Is_Incomplete_Or_Private_Type (Id));
+        (Is_Record_Type (Id)
+         or else Is_Incomplete_Or_Private_Type (Id)
+         or else Has_Discriminants (Id));
 
       Comp_Id := First_Entity (Id);
       while Present (Comp_Id) loop

diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index b8058ae..3557701 100644 (file)
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -76,6 +76,14 @@ package body Exp_Attr is
    -- Local Subprograms --
    -----------------------
 
+   function Build_Array_VS_Func
+     (A_Type : Entity_Id;
+      Nod    : Node_Id) return Entity_Id;
+   --  Build function to test Valid_Scalars for array type A_Type. Nod is the
+   --  Valid_Scalars attribute node, used to insert the function body, and the
+   --  value returned is the entity of the constructed function body. We do not
+   --  bother to generate a separate spec for this subprogram.
+
    procedure Compile_Stream_Body_In_Scope
      (N     : Node_Id;
       Decl  : Node_Id;
@@ -174,6 +182,149 @@ package body Exp_Attr is
    --  expansion. Typically used for rounding and truncation attributes that
    --  appear directly inside a conversion to integer.
 
+   -------------------------
+   -- Build_Array_VS_Func --
+   -------------------------
+
+   function Build_Array_VS_Func
+     (A_Type : Entity_Id;
+      Nod    : Node_Id) return Entity_Id
+   is
+      Loc        : constant Source_Ptr := Sloc (Nod);
+      Comp_Type  : constant Entity_Id  := Component_Type (A_Type);
+      Body_Stmts : List_Id;
+      Index_List : List_Id;
+      Func_Id    : Entity_Id;
+      Formals    : List_Id;
+
+      function Test_Component return List_Id;
+      --  Create one statement to test validity of one component designated by
+      --  a full set of indexes. Returns statement list containing test.
+
+      function Test_One_Dimension (N : Int) return List_Id;
+      --  Create loop to test one dimension of the array. The single statement
+      --  in the loop body tests the inner dimensions if any, or else the
+      --  single component. Note that this procedure is called recursively,
+      --  with N being the dimension to be initialized. A call with N greater
+      --  than the number of dimensions simply generates the component test,
+      --  terminating the recursion. Returns statement list containing tests.
+
+      --------------------
+      -- Test_Component --
+      --------------------
+
+      function Test_Component return List_Id is
+         Comp : Node_Id;
+         Anam : Name_Id;
+
+      begin
+         Comp :=
+           Make_Indexed_Component (Loc,
+             Prefix      => Make_Identifier (Loc, Name_uA),
+             Expressions => Index_List);
+
+         if Is_Scalar_Type (Comp_Type) then
+            Anam := Name_Valid;
+         else
+            Anam := Name_Valid_Scalars;
+         end if;
+
+         return New_List (
+           Make_If_Statement (Loc,
+             Condition =>
+               Make_Op_Not (Loc,
+                 Right_Opnd =>
+                   Make_Attribute_Reference (Loc,
+                     Attribute_Name => Anam,
+                     Prefix         => Comp)),
+             Then_Statements => New_List (
+               Make_Simple_Return_Statement (Loc,
+                 Expression => New_Occurrence_Of (Standard_False, Loc)))));
+      end Test_Component;
+
+      ------------------------
+      -- Test_One_Dimension --
+      ------------------------
+
+      function Test_One_Dimension (N : Int) return List_Id is
+         Index : Entity_Id;
+
+      begin
+         --  If all dimensions dealt with, we simply test the component
+
+         if N > Number_Dimensions (A_Type) then
+            return Test_Component;
+
+         --  Here we generate the required loop
+
+         else
+            Index :=
+              Make_Defining_Identifier (Loc, New_External_Name ('J', N));
+
+            Append (New_Reference_To (Index, Loc), Index_List);
+
+            return New_List (
+              Make_Implicit_Loop_Statement (Nod,
+                Identifier => Empty,
+                Iteration_Scheme =>
+                  Make_Iteration_Scheme (Loc,
+                    Loop_Parameter_Specification =>
+                      Make_Loop_Parameter_Specification (Loc,
+                        Defining_Identifier => Index,
+                        Discrete_Subtype_Definition =>
+                          Make_Attribute_Reference (Loc,
+                            Prefix => Make_Identifier (Loc, Name_uA),
+                            Attribute_Name  => Name_Range,
+                            Expressions     => New_List (
+                              Make_Integer_Literal (Loc, N))))),
+                Statements =>  Test_One_Dimension (N + 1)),
+              Make_Simple_Return_Statement (Loc,
+                Expression => New_Occurrence_Of (Standard_True, Loc)));
+         end if;
+      end Test_One_Dimension;
+
+   --  Start of processing for Build_Array_VS_Func
+
+   begin
+      Index_List := New_List;
+      Func_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('V'));
+
+      Body_Stmts := Test_One_Dimension (1);
+
+      --  Parameter is always (A : A_Typ)
+
+      Formals := New_List (
+        Make_Parameter_Specification (Loc,
+          Defining_Identifier => Make_Defining_Identifier (Loc, Name_uA),
+          In_Present          => True,
+          Out_Present         => False,
+          Parameter_Type      => New_Reference_To (A_Type, Loc)));
+
+      --  Build body
+
+      Set_Ekind       (Func_Id, E_Function);
+      Set_Is_Internal (Func_Id);
+
+      Insert_Action (Nod,
+        Make_Subprogram_Body (Loc,
+          Specification              =>
+            Make_Function_Specification (Loc,
+              Defining_Unit_Name       => Func_Id,
+              Parameter_Specifications => Formals,
+                Result_Definition        =>
+                  New_Occurrence_Of (Standard_Boolean, Loc)),
+          Declarations               => New_List,
+          Handled_Statement_Sequence =>
+            Make_Handled_Sequence_Of_Statements (Loc,
+              Statements => Body_Stmts)));
+
+      if not Debug_Generated_Code then
+         Set_Debug_Info_Off (Func_Id);
+      end if;
+
+      return Func_Id;
+   end Build_Array_VS_Func;
+
    ----------------------------------
    -- Compile_Stream_Body_In_Scope --
    ----------------------------------
@@ -5373,8 +5524,89 @@ package body Exp_Attr is
       -------------------
 
       when Attribute_Valid_Scalars => Valid_Scalars : declare
+         Ftyp : Entity_Id;
+
       begin
-         raise Program_Error;
+         if Present (Underlying_Type (Ptyp)) then
+            Ftyp := Underlying_Type (Ptyp);
+         else
+            Ftyp := Ptyp;
+         end if;
+
+         --  For scalar types, Valid_Scalars is the same as Valid
+
+         if Is_Scalar_Type (Ftyp) then
+            Rewrite (N,
+              Make_Attribute_Reference (Loc,
+                Attribute_Name => Name_Valid,
+                Prefix         => Pref));
+            Analyze_And_Resolve (N, Standard_Boolean);
+
+         --  For array types, we construct a function that determines if there
+         --  are any non-valid scalar subcomponents, and call the function.
+         --  We only do this for arrays whose component type needs checking
+
+         elsif Is_Array_Type (Ftyp)
+           and then not No_Scalar_Parts (Component_Type (Ftyp))
+         then
+            Rewrite (N,
+              Make_Function_Call (Loc,
+                Name                   =>
+                  New_Occurrence_Of (Build_Array_VS_Func (Ftyp, N), Loc),
+                Parameter_Associations => New_List (Pref)));
+
+            Analyze_And_Resolve (N, Standard_Boolean);
+
+         --  For record types, we build a big conditional expression, applying
+         --  Valid or Valid_Scalars as appropriate to all relevant components.
+
+         elsif (Is_Record_Type (Ptyp) or else Has_Discriminants (Ptyp))
+           and then not No_Scalar_Parts (Ptyp)
+         then
+            declare
+               C : Entity_Id;
+               X : Node_Id;
+               A : Name_Id;
+
+            begin
+               X := New_Occurrence_Of (Standard_True, Loc);
+               C := First_Component_Or_Discriminant (Ptyp);
+               while Present (C) loop
+                  if No_Scalar_Parts (Etype (C)) then
+                     goto Continue;
+                  elsif Is_Scalar_Type (Etype (C)) then
+                     A := Name_Valid;
+                  else
+                     A := Name_Valid_Scalars;
+                  end if;
+
+                  X :=
+                    Make_And_Then (Loc,
+                      Left_Opnd   => X,
+                      Right_Opnd  =>
+                        Make_Attribute_Reference (Loc,
+                          Attribute_Name => A,
+                          Prefix         =>
+                            Make_Selected_Component (Loc,
+                              Prefix        =>
+                                Duplicate_Subexpr (Pref, Name_Req => True),
+                              Selector_Name =>
+                                New_Occurrence_Of (C, Loc))));
+               <<Continue>>
+                  Next_Component_Or_Discriminant (C);
+               end loop;
+
+               Rewrite (N, X);
+               Analyze_And_Resolve (N, Standard_Boolean);
+            end;
+
+         --  For all other types, result is True (but not static)
+
+         else
+            Rewrite (N, New_Occurrence_Of (Standard_Boolean, Loc));
+            Analyze_And_Resolve (N, Standard_Boolean);
+            Set_Is_Static_Expression (N, False);
+         end if;
       end Valid_Scalars;
 
       -----------

diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 77db15e..10af9e2 100644 (file)
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -323,7 +323,7 @@ package body Sem_Attr is
       --  type or a private type for which no full view has been given.
 
       procedure Check_Object_Reference (P : Node_Id);
-      --  Check that P (the prefix of the attribute) is an object reference
+      --  Check that P is an object reference
 
       procedure Check_Program_Unit;
       --  Verify that prefix of attribute N is a program unit
@@ -5202,8 +5202,13 @@ package body Sem_Attr is
 
       when Attribute_Valid_Scalars =>
          Check_E0;
-         Check_Type;
-         --  More stuff TBD ???
+         Check_Object_Reference (P);
+
+         if No_Scalar_Parts (P_Type) then
+            Error_Attr_P ("?attribute % always True, no scalars to check");
+         end if;
+
+         Set_Etype (N, Standard_Boolean);
 
       -----------
       -- Value --

diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads
index 45e1bc0..7258593 100644 (file)
--- a/gcc/ada/sem_attr.ads
+++ b/gcc/ada/sem_attr.ads
@@ -560,12 +560,18 @@ package Sem_Attr is
       --    For a scalar type, the result is the same as obj'Valid
       --
       --    For an array object, the result is True if the result of applying
-      --    Valid_Scalars to every component is True.
+      --    Valid_Scalars to every component is True. For an empty array the
+      --    result is True.
       --
       --    For a record object, the result is True if the result of applying
       --    Valid_Scalars to every component is True. For class-wide types,
       --    only the components of the base type are checked. For variant
-      --    records, only the components actually present are checked.
+      --    records, only the components actually present are checked. The
+      --    discriminants, if any, are also checked. If there are no components
+      --    or discriminants, the result is True.
+      --
+      --    For any other type that has discriminants, the result is True if
+      --    the result of applying Valid_Scalars to each discriminant is True.
       --
       --    For all other types, the result is always True
       --
@@ -574,7 +580,7 @@ package Sem_Attr is
       --  type, or in the composite case if no scalar subcomponents exist. For
       --  a variant record, the warning is given only if none of the variants
       --  have scalar subcomponents. In addition, the warning is suppressed
-      --  for private types, or generic types in an instance.
+      --  for private types, or generic formal types in an instance.
 
       ----------------
       -- Value_Size --

diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 50200e7..e07d5bb 100644 (file)
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -10499,6 +10499,34 @@ package body Sem_Util is
       Actual_Id := Next_Actual (Actual_Id);
    end Next_Actual;
 
+   ---------------------
+   -- No_Scalar_Parts --
+   ---------------------
+
+   function No_Scalar_Parts (T : Entity_Id) return Boolean is
+      C : Entity_Id;
+
+   begin
+      if Is_Scalar_Type (T) then
+         return False;
+
+      elsif Is_Array_Type (T) then
+         return No_Scalar_Parts (Component_Type (T));
+
+      elsif Is_Record_Type (T) or else Has_Discriminants (T) then
+         C := First_Component_Or_Discriminant (T);
+         while Present (C) loop
+            if not No_Scalar_Parts (Etype (C)) then
+               return False;
+            else
+               Next_Component_Or_Discriminant (C);
+            end if;
+         end loop;
+      end if;
+
+      return True;
+   end No_Scalar_Parts;
+
    -----------------------
    -- Normalize_Actuals --
    -----------------------

diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 34d2fc0..607bd8e 100644 (file)
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -1221,6 +1221,11 @@ package Sem_Util is
    --  Note that the result produced is always an expression, not a parameter
    --  association node, even if named notation was used.
 
+   function No_Scalar_Parts (T : Entity_Id) return Boolean;
+   --  Tests if type T can be determined at compile time to have no scalar
+   --  parts in the sense of the Valid_Scalars attribute. Returns True if
+   --  this is the case, meaning that the result of Valid_Scalars is True.
+
    procedure Normalize_Actuals
      (N       : Node_Id;
       S       : Entity_Id;