diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/ChangeLog | 12 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 23 | ||||
| -rw-r--r-- | gcc/ada/s-direio.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 6 |
4 files changed, 41 insertions, 18 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 4c2d48092bb..e6560e26aba 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 53a9c9a2a7b..33a4ce35cb6 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 8a6dd435e7c..447367cafea 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 bc2b7a7e2f0..c2f7790c3c8 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); |