[multiple changes]

2013-10-15  Thomas Quinot  <quinot@adacore.com>

	* exp_pakd.adb (Expand_Packed_Element_Set,
	Expand_Packed_Element_Reference): Adjust for the case of packed
	arrays of reverse-storage-order types.

2013-10-15  Robert Dewar  <dewar@adacore.com>

	* sem_prag.adb: Minor reformatting.

2013-10-15  Ed Schonberg  <schonberg@adacore.com>

	* sem_attr.adb (Analyze_Attribute_Specification, case
	To_Address): If the expression is an identifier, do not modify
	its type; it will be converted when necessary, and the type of
	the expression must remain consistent with that of the entity
	for back-end consistency.

2013-10-15  Robert Dewar  <dewar@adacore.com>

	* sem_ch7.adb (Unit_Requires_Body): Add flag
	Ignore_Abstract_State (Analyze_Package_Specification): Enforce
	rule requiring Elaborate_Body if a non-null abstract state is
	specified for a library-level package.
	* sem_ch7.ads (Unit_Requires_Body): Add flag Ignore_Abstract_State.

From-SVN: r203598

6 files changed, 184 insertions, 28 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 382274e..41fd986 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,29 @@
+2013-10-15  Thomas Quinot  <quinot@adacore.com>
+
+	* exp_pakd.adb (Expand_Packed_Element_Set,
+	Expand_Packed_Element_Reference): Adjust for the case of packed
+	arrays of reverse-storage-order types.
+
+2013-10-15  Robert Dewar  <dewar@adacore.com>
+
+	* sem_prag.adb: Minor reformatting.
+
+2013-10-15  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_attr.adb (Analyze_Attribute_Specification, case
+	To_Address): If the expression is an identifier, do not modify
+	its type; it will be converted when necessary, and the type of
+	the expression must remain consistent with that of the entity
+	for back-end consistency.
+
+2013-10-15  Robert Dewar  <dewar@adacore.com>
+
+	* sem_ch7.adb (Unit_Requires_Body): Add flag
+	Ignore_Abstract_State (Analyze_Package_Specification): Enforce
+	rule requiring Elaborate_Body if a non-null abstract state is
+	specified for a library-level package.
+	* sem_ch7.ads (Unit_Requires_Body): Add flag Ignore_Abstract_State.
+
 2013-10-15  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* sem_prag.adb (Analyze_Constituent): When
diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb
index 45aafad..7a27b7a 100644
--- a/gcc/ada/exp_pakd.adb
+++ b/gcc/ada/exp_pakd.adb
@@ -543,39 +543,78 @@ package body Exp_Pakd is
    --  array type on the fly). Such actions are inserted into the tree
    --  directly using Insert_Action.
 
-   function Byte_Swap (N : Node_Id) return Node_Id;
+   function Byte_Swap
+     (N             : Node_Id;
+      Left_Justify  : Boolean := False;
+      Right_Justify : Boolean := False) return Node_Id;
    --  Wrap N in a call to a byte swapping function, with appropriate type
-   --  conversions.
+   --  conversions. If Left_Justify is set True, the value is left justified
+   --  before swapping. If Right_Justify is set True, the value is right
+   --  justified after swapping. The Etype of the returned node is an
+   --  integer type of an appropriate power-of-2 size.
 
    ---------------
    -- Byte_Swap --
    ---------------
 
-   function Byte_Swap (N : Node_Id) return Node_Id is
+   function Byte_Swap
+     (N             : Node_Id;
+      Left_Justify  : Boolean := False;
+      Right_Justify : Boolean := False) return Node_Id
+   is
       Loc     : constant Source_Ptr := Sloc (N);
       T       : constant Entity_Id := Etype (N);
+      T_Size  : constant Uint := RM_Size (T);
+
       Swap_RE : RE_Id;
       Swap_F  : Entity_Id;
+      Swap_T  : Entity_Id;
+      --  Swapping function
+
+      Arg     : Node_Id;
+      Swapped : Node_Id;
+      Shift   : Uint;
 
    begin
-      pragma Assert (Esize (T) > 8);
+      pragma Assert (T_Size > 8);
 
-      if Esize (T) <= 16 then
+      if T_Size <= 16 then
          Swap_RE := RE_Bswap_16;
-      elsif Esize (T) <= 32 then
+
+      elsif T_Size <= 32 then
          Swap_RE := RE_Bswap_32;
-      else pragma Assert (Esize (T) <= 64);
+
+      else pragma Assert (T_Size <= 64);
          Swap_RE := RE_Bswap_64;
       end if;
 
       Swap_F := RTE (Swap_RE);
+      Swap_T := Etype (Swap_F);
+      Shift := Esize (Swap_T) - T_Size;
+
+      Arg := RJ_Unchecked_Convert_To (Swap_T, N);
+
+      if Left_Justify and then Shift > Uint_0 then
+         Arg :=
+           Make_Op_Shift_Left (Loc,
+             Left_Opnd  => Arg,
+             Right_Opnd => Make_Integer_Literal (Loc, Shift));
+      end if;
+
+      Swapped :=
+        Make_Function_Call (Loc,
+          Name                   => New_Occurrence_Of (Swap_F, Loc),
+          Parameter_Associations => New_List (Arg));
+
+      if Right_Justify and then Shift > Uint_0 then
+         Swapped :=
+           Make_Op_Shift_Right (Loc,
+             Left_Opnd  => Swapped,
+             Right_Opnd => Make_Integer_Literal (Loc, Shift));
+      end if;
 
-      return
-        Unchecked_Convert_To (T,
-          Make_Function_Call (Loc,
-            Name                   => New_Occurrence_Of (Swap_F, Loc),
-            Parameter_Associations =>
-              New_List (Unchecked_Convert_To (Etype (Swap_F), N))));
+      Set_Etype (Swapped, Swap_T);
+      return Swapped;
    end Byte_Swap;
 
    ------------------------------
@@ -1537,7 +1576,9 @@ package body Exp_Pakd is
               and then not In_Reverse_Storage_Order_Object (Obj)
             then
                Require_Byte_Swapping := True;
-               New_Rhs := Byte_Swap (New_Rhs);
+               New_Rhs := Byte_Swap (New_Rhs,
+                            Left_Justify  => Bytes_Big_Endian,
+                            Right_Justify => not Bytes_Big_Endian);
             end if;
          end;
 
@@ -1610,7 +1651,6 @@ package body Exp_Pakd is
                   --  not a left justified conversion.
 
                   Rhs := RJ_Unchecked_Convert_To (Etype (Obj), Rhs);
-
                end Fixup_Rhs;
 
             begin
@@ -1660,18 +1700,24 @@ package body Exp_Pakd is
 
                if Nkind (New_Rhs) = N_Op_And then
                   Set_Paren_Count (New_Rhs, 1);
+                  Set_Etype (New_Rhs, Etype (Left_Opnd (New_Rhs)));
                end if;
 
                New_Rhs :=
                  Make_Op_Or (Loc,
                    Left_Opnd  => New_Rhs,
-                   Right_Opnd => Or_Rhs);
+                   Right_Opnd => Unchecked_Convert_To
+                                   (Etype (New_Rhs), Or_Rhs));
             end;
          end if;
 
          if Require_Byte_Swapping then
             Set_Etype (New_Rhs, Etype (Obj));
-            New_Rhs := Byte_Swap (New_Rhs);
+            New_Rhs :=
+              Unchecked_Convert_To (Etype (Obj),
+                Byte_Swap (New_Rhs,
+                             Left_Justify  => not Bytes_Big_Endian,
+                             Right_Justify => Bytes_Big_Endian));
          end if;
 
          --  Now do the rewrite
@@ -1991,6 +2037,11 @@ package body Exp_Pakd is
       Lit   : Node_Id;
       Arg   : Node_Id;
 
+      Byte_Swapped : Boolean;
+      --  Set true if bytes were swapped for the purpose of extracting the
+      --  element, in which case we must swap back if the component type is
+      --  a composite type with reverse scalar storage order.
+
    begin
       --  If the node is an actual in a call, the prefix has not been fully
       --  expanded, to account for the additional expansion for in-out actuals
@@ -2057,7 +2108,13 @@ package body Exp_Pakd is
            and then Esize (Atyp) > 8
            and then not In_Reverse_Storage_Order_Object (Obj)
          then
-            Obj := Byte_Swap (Obj);
+            Obj := Byte_Swap (Obj,
+                     Left_Justify  => Bytes_Big_Endian,
+                     Right_Justify => not Bytes_Big_Endian);
+            Byte_Swapped := True;
+
+         else
+            Byte_Swapped := False;
          end if;
 
          --  We generate a shift right to position the field, followed by a
@@ -2075,6 +2132,15 @@ package body Exp_Pakd is
              Left_Opnd  => Make_Shift_Right (Obj, Shift),
              Right_Opnd => Lit);
 
+         --  Swap back if necessary
+
+         Set_Etype (Arg, Ctyp);
+         if Byte_Swapped and then Reverse_Storage_Order (Ctyp) then
+            Arg := Byte_Swap (Arg,
+                     Left_Justify  => not Bytes_Big_Endian,
+                     Right_Justify => False);
+         end if;
+
          --  We needed to analyze this before we do the unchecked convert
          --  below, but we need it temporarily attached to the tree for
          --  this analysis (hence the temporary Set_Parent call).
@@ -2597,6 +2663,18 @@ package body Exp_Pakd is
       Source_Siz := UI_To_Int (RM_Size (Source_Typ));
       Target_Siz := UI_To_Int (RM_Size (Target_Typ));
 
+      --  For a little-endian target type stored byte-swapped on a
+      --  big-endian machine, do not mask to Target_Siz bits.
+
+      if Bytes_Big_Endian
+           and then (Is_Record_Type (Target_Typ)
+                       or else
+                     Is_Array_Type (Target_Typ))
+           and then Reverse_Storage_Order (Target_Typ)
+      then
+         Source_Siz := Target_Siz;
+      end if;
+
       --  First step, if the source type is not a discrete type, then we first
       --  convert to a modular type of the source length, since otherwise, on
       --  a big-endian machine, we get left-justification. We do it for little-
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 493f544..177c3de 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -5627,9 +5627,16 @@ package body Sem_Attr is
                Error_Attr ("address value out of range for % attribute", E1);
             end if;
 
+            --  In most cases the expression is a numeric literal or some other
+            --  address expression, but if it is a declared constant it may be
+            --  of a compatible type that must be left on the node.
+
+            if Is_Entity_Name (E1) then
+               null;
+
             --  Set type to universal integer if negative
 
-            if Val < 0 then
+            elsif Val < 0 then
                Set_Etype (E1, Universal_Integer);
 
             --  Otherwise set type to Unsigned_64 to accomodate max values
diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb
index d15add3..0239fa7 100644
--- a/gcc/ada/sem_ch7.adb
+++ b/gcc/ada/sem_ch7.adb
@@ -1483,7 +1483,38 @@ package body Sem_Ch7 is
          Clear_Constants (Id, First_Private_Entity (Id));
       end if;
 
+      --  Issue an error in SPARK mode if a package specification contains
+      --  more than one tagged type or type extension.
+
       Check_One_Tagged_Type_Or_Extension_At_Most;
+
+      --  Issue an error if a package that is a library unit does not require a
+      --  body, and we have a non-null abstract state (SPARK LRM 7.1.5(4)).
+
+      if not Unit_Requires_Body (Id, Ignore_Abstract_State => True)
+        and then Present (Abstract_States (Id))
+
+        --  We use Scope_Depth of 1 to identify library units, which seems a
+        --  bit ugly, but there doesn't seem to be an easier way.
+
+        and then Scope_Depth (Id) = 1
+
+        --  A null abstract state always appears as the sole element of the
+        --  state list.
+
+        and then not Is_Null_State (Node (First_Elmt (Abstract_States (Id))))
+      then
+         declare
+            P : constant Node_Id := Get_Pragma (Id, Pragma_Abstract_State);
+         begin
+            Error_Msg_NE
+              ("package & specifies a non-null abstract state", P, Id);
+            Error_Msg_N
+              ("\but package does not otherwise require a body", P);
+            Error_Msg_N
+              ("\pragma Elaborate_Body is required in this case", P);
+         end;
+      end if;
    end Analyze_Package_Specification;
 
    --------------------------------------
@@ -2588,7 +2619,10 @@ package body Sem_Ch7 is
    -- Unit_Requires_Body --
    ------------------------
 
-   function Unit_Requires_Body (P : Entity_Id) return Boolean is
+   function Unit_Requires_Body
+     (P                     : Entity_Id;
+      Ignore_Abstract_State : Boolean := False) return Boolean
+   is
       E : Entity_Id;
 
    begin
@@ -2627,12 +2661,17 @@ package body Sem_Ch7 is
          end;
 
       --  A [generic] package that introduces at least one non-null abstract
-      --  state requires completion. A null abstract state always appears as
-      --  the sole element of the state list.
+      --  state requires completion. However, there is a separate rule that
+      --  requires that such a package have a reason other than this for a
+      --  body being required (if necessary a pragma Elaborate_Body must be
+      --  provided). If Ignore_Abstract_State is True, we don't do this check
+      --  (so we can use Unit_Requires_Body to check for some other reason).
 
       elsif Ekind_In (P, E_Generic_Package, E_Package)
+        and then not Ignore_Abstract_State
         and then Present (Abstract_States (P))
-        and then not Is_Null_State (Node (First_Elmt (Abstract_States (P))))
+        and then
+            not Is_Null_State (Node (First_Elmt (Abstract_States (P))))
       then
          return True;
       end if;
diff --git a/gcc/ada/sem_ch7.ads b/gcc/ada/sem_ch7.ads
index 0445b24..11e05cd 100644
--- a/gcc/ada/sem_ch7.ads
+++ b/gcc/ada/sem_ch7.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2013, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -52,9 +52,15 @@ package Sem_Ch7 is
    --  but is deferred until the compilation of the  private part of the
    --  child for public child packages.
 
-   function Unit_Requires_Body (P : Entity_Id) return Boolean;
-   --  Check if a unit requires a body. A specification requires a body
-   --  if it contains declarations that require completion in a body.
+   function Unit_Requires_Body
+     (P                     : Entity_Id;
+      Ignore_Abstract_State : Boolean := False) return Boolean;
+   --  Check if a unit requires a body. A specification requires a body if it
+   --  contains declarations that require completion in a body. If the flag
+   --  Ignore_Abstract_State is set True, then the test for a non-null abstract
+   --  state (which normally requires a body) is not carried out. This allows
+   --  the use of this routine to tell if there is some other reason that a
+   --  body is required (as is required for analyzing Abstract_State).
 
    procedure May_Need_Implicit_Body (E : Entity_Id);
    --  If a package declaration contains tasks or RACWs and does not require
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 64d684d..8fa7853 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -4960,7 +4960,7 @@ package body Sem_Prag is
                      Pragma_Misplaced;
 
                   elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
-                           or else Nkind (Parent_Node) =
+                          or else Nkind (Parent_Node) =
                                              N_Generic_Subprogram_Declaration)
                     and then Plist = Generic_Formal_Declarations (Parent_Node)
                   then