2014-08-04 Thomas Quinot <quinot@adacore.com>

	* s-fatgen.ads, s-fatgen.adb (S, P): New visible type declarations
	(Unaligned_Valid): Remove now unused subprogram.
	* exp_attr.adb (Expand_N_Attribute_Reference, case
	Attribute_Valid): If the prefix is in reverse SSO or potentially
	unaligned, copy it using a byte copy operation to a temporary
	variable.
	* einfo.adb: Minor comment fix.

2014-08-04  Hristian Kirtchev  <kirtchev@adacore.com>

	* freeze.adb (Freeze_Entity): Do not freeze formal subprograms.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@213540 138bc75d-0d04-0410-961f-82ee72b054a4

6 files changed, 120 insertions, 74 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 985c915be82..b7c71fd4796 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,17 @@
+2014-08-04  Thomas Quinot  <quinot@adacore.com>
+
+	* s-fatgen.ads, s-fatgen.adb (S, P): New visible type declarations
+	(Unaligned_Valid): Remove now unused subprogram.
+	* exp_attr.adb (Expand_N_Attribute_Reference, case
+	Attribute_Valid): If the prefix is in reverse SSO or potentially
+	unaligned, copy it using a byte copy operation to a temporary
+	variable.
+	* einfo.adb: Minor comment fix.
+
+2014-08-04  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* freeze.adb (Freeze_Entity): Do not freeze formal subprograms.
+
 2014-08-04  Robert Dewar  <dewar@adacore.com>
 
 	* s-imgrea.adb (Image_Floating_Point): Don't add space before +Inf.
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index 6afc37ceb3a..631ddc76c58 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -563,7 +563,7 @@ package body Einfo is
 
    --    (Has_Protected)                 Flag271
    --    (SSO_Set_Low_By_Default)        Flag272
-   --    (SSO_Set_Low_By_Default)        Flag273
+   --    (SSO_Set_High_By_Default)       Flag273
 
    --    Is_Generic_Actual_Subprogram    Flag274
    --    No_Predicate_On_Actual          Flag275
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 18ad6d1f3d7..f67220b61e2 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -23,6 +23,7 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
+with Aspects;  use Aspects;
 with Atree;    use Atree;
 with Checks;   use Checks;
 with Einfo;    use Einfo;
@@ -6406,6 +6407,23 @@ package body Exp_Attr is
                Pkg : RE_Id;
                Ftp : Entity_Id;
 
+               function Get_Fat_Entity (Nam : Name_Id) return Entity_Id;
+               --  Return entity for Pkg.Nam
+
+               --------------------
+               -- Get_Fat_Entity --
+               --------------------
+
+               function Get_Fat_Entity (Nam : Name_Id) return Entity_Id is
+                  Exp_Name : constant Node_Id :=
+                    Make_Selected_Component (Loc,
+                      Prefix        => New_Occurrence_Of (RTE (Pkg), Loc),
+                      Selector_Name => Make_Identifier (Loc, Nam));
+               begin
+                  Find_Selected_Component (Exp_Name);
+                  return Entity (Exp_Name);
+               end Get_Fat_Entity;
+
             begin
                case Float_Rep (Btyp) is
 
@@ -6419,34 +6437,76 @@ package body Exp_Attr is
                   when IEEE_Binary =>
                      Find_Fat_Info (Ptyp, Ftp, Pkg);
 
-                     --  If the floating-point object might be unaligned, we
-                     --  need to call the special routine Unaligned_Valid,
-                     --  which makes the needed copy, being careful not to
-                     --  load the value into any floating-point register.
-                     --  The argument in this case is obj'Address (see
-                     --  Unaligned_Valid routine in Fat_Gen).
-
-                     if Is_Possibly_Unaligned_Object (Pref) then
-                        Expand_Fpt_Attribute
-                          (N, Pkg, Name_Unaligned_Valid,
-                           New_List (
-                             Make_Attribute_Reference (Loc,
-                               Prefix => Relocate_Node (Pref),
-                               Attribute_Name => Name_Address)));
-
-                     --  In the normal case where we are sure the object is
-                     --  aligned, we generate a call to Valid, and the argument
-                     --  in this case is obj'Unrestricted_Access (after
-                     --  converting obj to the right floating-point type).
+                     --  If the prefix is a reverse SSO component, or is
+                     --  possibly unaligned, first create a temporary copy
+                     --  that is in native SSO, and properly aligned. Make it
+                     --  Volatile to prevent folding in the back-end. Note
+                     --  that we use an intermediate constrained string type
+                     --  to initialize the temporary, as the value at hand
+                     --  might be invalid, and in that case it cannot be copied
+                     --  using a floating point register.
+
+                     if In_Reverse_Storage_Order_Object (Pref)
+                          or else
+                        Is_Possibly_Unaligned_Object (Pref)
+                     then
+                        declare
+                           Temp : constant Entity_Id :=
+                                    Make_Temporary (Loc, 'F');
 
-                     else
-                        Expand_Fpt_Attribute
-                          (N, Pkg, Name_Valid,
-                           New_List (
-                             Make_Attribute_Reference (Loc,
-                               Prefix => Unchecked_Convert_To (Ftp, Pref),
-                               Attribute_Name => Name_Unrestricted_Access)));
+                           Fat_S : constant Entity_Id :=
+                                     Get_Fat_Entity (Name_S);
+                           --  Constrained string subtype of appropriate size
+
+                           Fat_P : constant Entity_Id :=
+                                     Get_Fat_Entity (Name_P);
+                           --  Access to Fat_S
+
+                           Decl : constant Node_Id :=
+                             Make_Object_Declaration (Loc,
+                               Defining_Identifier => Temp,
+                               Aliased_Present     => True,
+                               Object_Definition   =>
+                                 New_Occurrence_Of (Ptyp, Loc));
+
+                        begin
+                           Set_Aspect_Specifications (Decl, New_List (
+                             Make_Aspect_Specification (Loc,
+                               Identifier =>
+                                 Make_Identifier (Loc, Name_Volatile))));
+
+                           Insert_Actions (N,
+                             New_List (
+                               Decl,
+
+                               Make_Assignment_Statement (Loc,
+                                 Name =>
+                                   Make_Explicit_Dereference (Loc,
+                                     Prefix =>
+                                       Unchecked_Convert_To (Fat_P,
+                                         Make_Attribute_Reference (Loc,
+                                           Prefix =>
+                                             New_Occurrence_Of (Temp, Loc),
+                                           Attribute_Name =>
+                                             Name_Unrestricted_Access))),
+                                 Expression =>
+                                   Unchecked_Convert_To (Fat_S,
+                                     Relocate_Node (Pref)))),
+                             Suppress => All_Checks);
+
+                           Rewrite (Pref, New_Occurrence_Of (Temp, Loc));
+                        end;
                      end if;
+
+                     --  We now have an object of the proper endianness and
+                     --  alignment, and can call the Valid runtime routine.
+
+                     Expand_Fpt_Attribute
+                       (N, Pkg, Name_Valid,
+                        New_List (
+                          Make_Attribute_Reference (Loc,
+                            Prefix => Unchecked_Convert_To (Ftp, Pref),
+                            Attribute_Name => Name_Unrestricted_Access)));
                end case;
 
                --  One more task, we still need a range check. Required
@@ -6462,7 +6522,7 @@ package body Exp_Attr is
                       Left_Opnd  => Relocate_Node (N),
                       Right_Opnd =>
                         Make_In (Loc,
-                          Left_Opnd => Convert_To (Btyp, Pref),
+                          Left_Opnd  => Convert_To (Btyp, Pref),
                           Right_Opnd => New_Occurrence_Of (Ptyp, Loc))));
                end if;
             end;
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index fb4241a40aa..971bc39d2e0 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -3818,8 +3818,12 @@ package body Freeze is
       then
          return No_List;
 
-      --  Generic types need no freeze node and have no delayed semantic
-      --  checks.
+      --  Formal subprograms are never frozen
+
+      elsif Is_Formal_Subprogram (E) then
+         return No_List;
+
+      --  Generic types are never frozen as they lack delayed semantic checks
 
       elsif Is_Generic_Type (E) then
          return No_List;
diff --git a/gcc/ada/s-fatgen.adb b/gcc/ada/s-fatgen.adb
index be564cf6a0e..62534f67c38 100644
--- a/gcc/ada/s-fatgen.adb
+++ b/gcc/ada/s-fatgen.adb
@@ -918,30 +918,4 @@ package body System.Fat_Gen is
          ((E = IEEE_Emin - 1) and then abs To_Float (SR) = 1.0);
    end Valid;
 
-   ---------------------
-   -- Unaligned_Valid --
-   ---------------------
-
-   function Unaligned_Valid (A : System.Address) return Boolean is
-      subtype FS is String (1 .. T'Size / Character'Size);
-      type FSP is access FS;
-
-      function To_FSP is new Ada.Unchecked_Conversion (Address, FSP);
-
-      Local_T : aliased T;
-
-   begin
-      --  Note that we have to be sure that we do not load the value into a
-      --  floating-point register, since a signalling NaN may cause a trap.
-      --  The following assignment is what does the actual alignment, since
-      --  we know that the target Local_T is aligned.
-
-      To_FSP (Local_T'Address).all := To_FSP (A).all;
-
-      --  Now that we have an aligned value, we can use the normal aligned
-      --  version of Valid to obtain the required result.
-
-      return Valid (Local_T'Access);
-   end Unaligned_Valid;
-
 end System.Fat_Gen;
diff --git a/gcc/ada/s-fatgen.ads b/gcc/ada/s-fatgen.ads
index 6c4e6f7b508..d8d761eaaed 100644
--- a/gcc/ada/s-fatgen.ads
+++ b/gcc/ada/s-fatgen.ads
@@ -94,24 +94,18 @@ package System.Fat_Gen is
    --  be an abnormal value that cannot be passed in a floating-point
    --  register, and the whole point of 'Valid is to prevent exceptions.
    --  Note that the object of type T must have the natural alignment
-   --  for type T. See Unaligned_Valid for further discussion.
-
-   function Unaligned_Valid (A : System.Address) return Boolean;
-   --  This version of Valid is used if the floating-point value to
-   --  be checked is not known to be aligned (for example it appears
-   --  in a packed record). In this case, we cannot call Valid since
-   --  Valid assumes proper full alignment. Instead Unaligned_Valid
-   --  performs the same processing for a possibly unaligned float,
-   --  by first doing a copy and then calling Valid. One might think
-   --  that the front end could simply do a copy to an aligned temp,
-   --  but remember that we may have an abnormal value that cannot
-   --  be copied into a floating-point register, so things are a bit
-   --  trickier than one might expect.
-   --
-   --  Note: Unaligned_Valid is never called for a target which does
-   --  not require strict alignment (e.g. the ia32/x86), since on a
-   --  target not requiring strict alignment, it is fine to pass a
-   --  non-aligned value to the standard Valid routine.
+   --  for type T.
+
+   type S is new String (1 .. T'Size / Character'Size);
+   type P is access all S with Storage_Size => 0;
+   --  Buffer and access types used to initialize temporaries for validity
+   --  checks, if the value to be checked has reverse scalar storage order, or
+   --  is not known to be properly aligned (for example it appears in a packed
+   --  record). In this case, we cannot call Valid since Valid assumes proper
+   --  full alignment. Instead, we copy the value to a temporary location using
+   --  type S (we cannot simply do a copy of a T value, because the value might
+   --  be invalid, in which case it might not be possible to copy it through a
+   --  floating point register).
 
 private
    pragma Inline (Machine);