diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 4c2d48092bb8f788ada1a66ad7cff2543c646952..e6560e26aba950b0c9a940cd7b7b5b5cf3e0f072 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 53a9c9a2a7b79237ac803c7b41169c78f2a536a6..33a4ce35cb6781288673cdf0dfcd771d66e53f41 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 8a6dd435e7cb5a1803f81d6400f5f7ef896c4279..447367cafeaf8a5d16d2eec1c3abcf9575d1710b 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 bc2b7a7e2f0b19c93cfb5dfe696a4ef9dcf6f882..c2f7790c3c8b4e52c73bc04638178a3a17dc743d 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);