[multiple changes]

2009-04-09  Javier Miranda  <miranda@adacore.com>

	* sem_ch3.adb (Build_Derived_Record_Type): Fix typo.
	(Derive_Progenitor_Subprograms): Handle interfaces in subtypes of
	tagged types.

2009-04-09  Robert Dewar  <dewar@adacore.com>

	* s-direio.adb: Minor reformatting

	* exp_ch4.adb (Expand_Concatenate): Avoid overflow checks for String

From-SVN: r145808

4 files changed, 41 insertions, 18 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 4c2d480..e6560e26 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,15 @@
+2009-04-09  Javier Miranda  <miranda@adacore.com>
+
+	* sem_ch3.adb (Build_Derived_Record_Type): Fix typo.
+	(Derive_Progenitor_Subprograms): Handle interfaces in subtypes of
+	tagged types.
+
+2009-04-09  Robert Dewar  <dewar@adacore.com>
+
+	* s-direio.adb: Minor reformatting
+
+	* exp_ch4.adb (Expand_Concatenate): Avoid overflow checks for String
+
 2009-04-09  Robert Dewar  <dewar@adacore.com>
 
 	* exp_ch4.adb (Expand_Concatenate): Improve handling of overflow cases
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 53a9c9a..33a4ce3 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -3,7 +3,7 @@
 --                         GNAT COMPILER COMPONENTS                         --
 --                                                                          --
 --                              E X P _ C H 4                               --
---                                                               g           --
+--                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
 --          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
@@ -2337,6 +2337,16 @@ package body Exp_Ch4 is
       if Is_Enumeration_Type (Ityp) then
          Artyp := Standard_Integer;
 
+      --  If index type is Positive, we use the standard unsigned type, to give
+      --  more room on the top of the range, obviating the need for an overflow
+      --  check when creating the upper bound. This is needed to avoid junk
+      --  overflow checks in the common case of String types.
+
+      --  ??? Disabled for now
+
+      --  elsif Istyp = Standard_Positive then
+      --     Artyp := Standard_Unsigned;
+
       --  For modular types, we use a 32-bit modular type for types whose size
       --  is in the range 1-31 bits. For 32-bit unsigned types, we use the
       --  identity type, and for larger unsigned types we use 64-bits.
@@ -2417,7 +2427,7 @@ package body Exp_Ch4 is
                  Make_Op_Add (Loc,
                    Left_Opnd  =>
                      New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)),
-                   Right_Opnd => Make_Artyp_Literal (1));
+                   Right_Opnd => Make_Integer_Literal (Loc, 1));
             end if;
 
             --  Skip null string literal
@@ -2729,9 +2739,14 @@ package body Exp_Ch4 is
                 Left_Opnd  => New_Copy (Aggr_Length (NN)),
                 Right_Opnd => Make_Artyp_Literal (1))));
 
-      --  Now force overflow checking on High_Bound
+      --  Note that calculation of the high bound may cause overflow in some
+      --  very weird cases, so in the general case we need an overflow check
+      --  on the high bound. We can avoid this for the common case of string
+      --  types since we chose a wider range for the arithmetic type.
 
-      Activate_Overflow_Check (High_Bound);
+      if Istyp /= Standard_Positive then
+         Activate_Overflow_Check (High_Bound);
+      end if;
 
       --  Handle the exceptional case where the result is null, in which case
       --  case the bounds come from the last operand (so that we get the proper
diff --git a/gcc/ada/s-direio.adb b/gcc/ada/s-direio.adb
index 8a6dd43..447367c 100644
--- a/gcc/ada/s-direio.adb
+++ b/gcc/ada/s-direio.adb
@@ -63,7 +63,6 @@ package body System.Direct_IO is
 
    function AFCB_Allocate (Control_Block : Direct_AFCB) return FCB.AFCB_Ptr is
       pragma Unreferenced (Control_Block);
-
    begin
       return new Direct_AFCB;
    end AFCB_Allocate;
@@ -76,7 +75,6 @@ package body System.Direct_IO is
 
    procedure AFCB_Close (File : not null access Direct_AFCB) is
       pragma Unreferenced (File);
-
    begin
       null;
    end AFCB_Close;
@@ -110,8 +108,8 @@ package body System.Direct_IO is
    is
       Dummy_File_Control_Block : Direct_AFCB;
       pragma Warnings (Off, Dummy_File_Control_Block);
-      --  Yes, we know this is never assigned a value, only the tag
-      --  is used for dispatching purposes, so that's expected.
+      --  Yes, we know this is never assigned a value, only the tag is used for
+      --  dispatching purposes, so that's expected.
 
    begin
       FIO.Open (File_Ptr  => AP (File),
@@ -156,8 +154,8 @@ package body System.Direct_IO is
    is
       Dummy_File_Control_Block : Direct_AFCB;
       pragma Warnings (Off, Dummy_File_Control_Block);
-      --  Yes, we know this is never assigned a value, only the tag
-      --  is used for dispatching purposes, so that's expected.
+      --  Yes, we know this is never assigned a value, only the tag is used for
+      --  dispatching purposes, so that's expected.
 
    begin
       FIO.Open (File_Ptr  => AP (File),
@@ -254,10 +252,9 @@ package body System.Direct_IO is
       pragma Warnings (Off, File);
       --  File is actually modified via Unrestricted_Access below, but
       --  GNAT will generate a warning anyway.
-      --  Note that we do not use pragma Unmodified here, since in -gnatc
-      --  mode, GNAT will complain that File is modified for
-      --  "File.Index := 1;"
-
+      --
+      --  Note that we do not use pragma Unmodified here, since in -gnatc mode,
+      --  GNAT will complain that File is modified for "File.Index := 1;"
    begin
       FIO.Reset (AP (File)'Unrestricted_Access, Mode);
       File.Index := 1;
@@ -267,7 +264,6 @@ package body System.Direct_IO is
    procedure Reset (File : in out File_Type) is
       pragma Warnings (Off, File);
       --  See above (other Reset procedure) for explanations on this pragma
-
    begin
       FIO.Reset (AP (File)'Unrestricted_Access);
       File.Index := 1;
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index bc2b7a7..c2f7790 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -6467,7 +6467,7 @@ package body Sem_Ch3 is
          --  could still refer to the full type prior the change to the new
          --  subtype and hence would not match the new base type created here.
 
-         Derive_Subprograms (Parent_Type, Base_Type (Derived_Type));
+         Derive_Subprograms (Parent_Type, Derived_Type);
 
          --  For tagged types the Discriminant_Constraint of the new base itype
          --  is inherited from the first subtype so that no subtype conformance
@@ -11496,8 +11496,8 @@ package body Sem_Ch3 is
       --  Step 2: Add primitives of progenitors that are not implemented by
       --  parents of Tagged_Type
 
-      if Present (Interfaces (Tagged_Type)) then
-         Iface_Elmt := First_Elmt (Interfaces (Tagged_Type));
+      if Present (Interfaces (Base_Type (Tagged_Type))) then
+         Iface_Elmt := First_Elmt (Interfaces (Base_Type (Tagged_Type)));
          while Present (Iface_Elmt) loop
             Iface := Node (Iface_Elmt);