mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-22 21:41:28 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2015-01-06  Eric Botcazou  <ebotcazou@adacore.com>

	* einfo.ads (Has_Independent_Components): Document extended usage.
	* einfo.adb (Has_Independent_Components): Remove obsolete assertion.
	(Set_Has_Independent_Components): Adjust assertion.
	* sem_prag.adb (Analyze_Pragma): Also set Has_Independent_Components
	for pragma Atomic_Components.  Set Has_Independent_Components
	on the object instead of the type for an object declaration with
	pragma Independent_Components.

2015-01-06  Olivier Hainque  <hainque@adacore.com>

	* set_targ.adb (Read_Target_Dependent_Values): Set
	Long_Double_Index when "long double" is read.
	(elaboration code): Register_Back_End_Types only when not reading from
	config files. Doing otherwise is pointless and error prone.

2015-01-06  Robert Dewar  <dewar@adacore.com>

	* s-valrea.adb (Value_Real): Check for Str'Last = Positive'Last

2015-01-06  Robert Dewar  <dewar@adacore.com>

	* a-wtgeau.adb, a-ztgeau.adb, a-tigeau.adb (String_Skip): Raise PE if
	Str'Last = Positive'Last.

2015-01-06  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch6.adb (Matches_Limited_View): Handle properly the case
	where the non-limited type is a generic actual and appears as
	a subtype of the non-limited view of the other.
	* freeze.adb (Build_Renamed_Body): If the return type of the
	declaration that is being completed is a limited view and the
	non-limited view is available, use it in the specification of
	the generated body.

2015-01-06  Javier Miranda  <miranda@adacore.com>

	* exp_disp.adb: Reapplying reversed patch.

2015-01-06  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb (Find_Type_Name): If there is a previous tagged
	incomplete view, the type of the classwide type common to both
	views is the type being declared.

From-SVN: r219247
This commit is contained in:
Arnaud Charlet 2015-01-06 11:08:52 +01:00
parent 8a52daeeb0
commit 28fa5430b8
13 changed files with 202 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
gcc/ada/ChangeLog
View File

@ -1,3 +1,50 @@
2015-01-06 Eric Botcazou <ebotcazou@adacore.com>
* einfo.ads (Has_Independent_Components): Document extended
usage.
* einfo.adb (Has_Independent_Components): Remove obsolete assertion.
(Set_Has_Independent_Components): Adjust assertion.
* sem_prag.adb (Analyze_Pragma): Also set Has_Independent_Components
for pragma Atomic_Components. Set Has_Independent_Components
on the object instead of the type for an object declaration with
pragma Independent_Components.
2015-01-06 Olivier Hainque <hainque@adacore.com>
* set_targ.adb (Read_Target_Dependent_Values): Set
Long_Double_Index when "long double" is read.
(elaboration code): Register_Back_End_Types only when not reading from
config files. Doing otherwise is pointless and error prone.
2015-01-06 Robert Dewar <dewar@adacore.com>
* s-valrea.adb (Value_Real): Check for Str'Last = Positive'Last
2015-01-06 Robert Dewar <dewar@adacore.com>
* a-wtgeau.adb, a-ztgeau.adb, a-tigeau.adb (String_Skip): Raise PE if
Str'Last = Positive'Last.
2015-01-06 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb (Matches_Limited_View): Handle properly the case
where the non-limited type is a generic actual and appears as
a subtype of the non-limited view of the other.
* freeze.adb (Build_Renamed_Body): If the return type of the
declaration that is being completed is a limited view and the
non-limited view is available, use it in the specification of
the generated body.
2015-01-06 Javier Miranda <miranda@adacore.com>
* exp_disp.adb: Reapplying reversed patch.
2015-01-06 Ed Schonberg <schonberg@adacore.com>
* sem_ch3.adb (Find_Type_Name): If there is a previous tagged
incomplete view, the type of the classwide type common to both
views is the type being declared.
2015-01-06 Eric Botcazou <ebotcazou@adacore.com>
* einfo.ads (Is_Independent): Further document extended usage.

15
gcc/ada/a-tigeau.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, 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- --
@ -443,6 +443,19 @@ package body Ada.Text_IO.Generic_Aux is
procedure String_Skip (Str : String; Ptr : out Integer) is
begin
-- Routines calling String_Skip malfunction if Str'Last = Positive'Last.
-- It's too much trouble to make this silly case work, so we just raise
-- Program_Error with an appropriate message. We raise Program_Error
-- rather than Constraint_Error because we don't want this case to be
-- converted to Data_Error.
if Str'Last = Positive'Last then
raise Program_Error with
"string upper bound is Positive'Last, not supported";
end if;
-- Normal case where Str'Last < Positive'Last
Ptr := Str'First;
loop

15
gcc/ada/a-wtgeau.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, 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- --
@ -484,6 +484,19 @@ package body Ada.Wide_Text_IO.Generic_Aux is
procedure String_Skip (Str : String; Ptr : out Integer) is
begin
-- Routines calling String_Skip malfunction if Str'Last = Positive'Last.
-- It's too much trouble to make this silly case work, so we just raise
-- Program_Error with an appropriate message. We raise Program_Error
-- rather than Constraint_Error because we don't want this case to be
-- converted to Data_Error.
if Str'Last = Positive'Last then
raise Program_Error with
"string upper bound is Positive'Last, not supported";
end if;
-- Normal case where Str'Last < Positive'Last
Ptr := Str'First;
loop

15
gcc/ada/a-ztgeau.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, 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- --
@ -484,6 +484,19 @@ package body Ada.Wide_Wide_Text_IO.Generic_Aux is
procedure String_Skip (Str : String; Ptr : out Integer) is
begin
-- Routines calling String_Skip malfunction if Str'Last = Positive'Last.
-- It's too much trouble to make this silly case work, so we just raise
-- Program_Error with an appropriate message. We raise Program_Error
-- rather than Constraint_Error because we don't want this case to be
-- converted to Data_Error.
if Str'Last = Positive'Last then
raise Program_Error with
"string upper bound is Positive'Last, not supported";
end if;
-- Normal case where Str'Last < Positive'Last
Ptr := Str'First;
loop

6
gcc/ada/einfo.adb
View File

@ -1468,8 +1468,7 @@ package body Einfo is
function Has_Independent_Components (Id : E) return B is
begin
pragma Assert (Is_Array_Type (Id) or else Is_Record_Type (Id));
return Flag34 (Base_Type (Id));
return Flag34 (Implementation_Base_Type (Id));
end Has_Independent_Components;
function Has_Inheritable_Invariants (Id : E) return B is
@ -4262,8 +4261,7 @@ package body Einfo is
procedure Set_Has_Independent_Components (Id : E; V : B := True) is
begin
pragma Assert ((Is_Array_Type (Id) or else Is_Record_Type (Id))
and then Is_Base_Type (Id));
pragma Assert (not Is_Type (Id) or else Is_Base_Type (Id));
Set_Flag34 (Id, V);
end Set_Has_Independent_Components;

17
gcc/ada/einfo.ads
View File

@ -1605,11 +1605,16 @@ package Einfo is
-- Implicit_Dereference. Set also on the discriminant named in the aspect
-- clause, to simplify type resolution.
-- Has_Independent_Components (Flag34) [base type only]
-- Defined in types. Set if the aspect Independent_Components applies
-- (in the base type only), if corresponding pragma or aspect applies.
-- In the case of an object of anonymous array type, the flag is set on
-- the created array type.
-- Has_Independent_Components (Flag34) [implementation base type only]
-- Defined in all types and objects. Set only for a record type or an
-- array type or array object if a valid pragma Independent_Components
-- applies to the type or object. Note that in the case of an object,
-- this flag is only set on the object if there was an explicit pragma
-- for the object. In other words, the proper test for whether an object
-- has independent components is to see if either the object or its base
-- type has this flag set. Note that in the case of a type, the pragma
-- will be chained to the rep item chain of the first subtype in the
-- usual manner.
-- Has_Inheritable_Invariants (Flag248)
-- Defined in all type entities. Set in private types from which one
@ -5525,6 +5530,7 @@ package Einfo is
-- Has_Atomic_Components (Flag86)
-- Has_Biased_Representation (Flag139)
-- Has_Completion (Flag26) (constants only)
-- Has_Independent_Components (Flag34)
-- Has_Thunks (Flag228) (constants only)
-- Has_Size_Clause (Flag29)
-- Has_Up_Level_Access (Flag215)
@ -6236,6 +6242,7 @@ package Einfo is
-- Has_Alignment_Clause (Flag46)
-- Has_Atomic_Components (Flag86)
-- Has_Biased_Representation (Flag139)
-- Has_Independent_Components (Flag34)
-- Has_Initial_Value (Flag219)
-- Has_Size_Clause (Flag29)
-- Has_Up_Level_Access (Flag215)

19
gcc/ada/exp_disp.adb
View File

@ -1138,6 +1138,25 @@ package body Exp_Disp is
Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ));
end if;
-- No displacement of the pointer to the object needed when the type of
-- the operand is not an interface type and the interface is one of
-- its parent types (since they share the primary dispatch table).
declare
Opnd : Entity_Id := Operand_Typ;
begin
if Is_Access_Type (Opnd) then
Opnd := Designated_Type (Opnd);
end if;
if not Is_Interface (Opnd)
and then Is_Ancestor (Iface_Typ, Opnd, Use_Full_View => True)
then
return;
end if;
end;
-- Evaluate if we can statically displace the pointer to the object
declare

20
gcc/ada/freeze.adb
View File

@ -412,6 +412,26 @@ package body Freeze is
Set_Body_To_Inline (Decl, Old_S);
end if;
-- Check whether the return type is a limited view. If the subprogram
-- is already frozen the generated body may have a non-limited view
-- of the type, that must be used, because it is the one in the spec
-- of the renaming declaration.
if Ekind (Old_S) = E_Function
and then Is_Entity_Name (Result_Definition (Spec))
then
declare
Ret_Type : constant Entity_Id := Etype (Result_Definition (Spec));
begin
if Ekind (Ret_Type) = E_Incomplete_Type
and then Present (Non_Limited_View (Ret_Type))
then
Set_Result_Definition (Spec,
New_Occurrence_Of (Non_Limited_View (Ret_Type), Loc));
end if;
end;
end if;
-- The body generated for this renaming is an internal artifact, and
-- does not constitute a freeze point for the called entity.

28
gcc/ada/s-valrea.adb
View File

@ -377,12 +377,30 @@ package body System.Val_Real is
----------------
function Value_Real (Str : String) return Long_Long_Float is
V : Long_Long_Float;
P : aliased Integer := Str'First;
begin
V := Scan_Real (Str, P'Access, Str'Last);
Scan_Trailing_Blanks (Str, P);
return V;
-- We have to special case Str'Last = Positive'Last because the normal
-- circuit ends up setting P to Str'Last + 1 which is out of bounds. We
-- deal with this by converting to a subtype which fixes the bounds.
if Str'Last = Positive'Last then
declare
subtype NT is String (1 .. Str'Length);
begin
return Value_Real (NT (Str));
end;
-- Normal case where Str'Last < Positive'Last
else
declare
V : Long_Long_Float;
P : aliased Integer := Str'First;
begin
V := Scan_Real (Str, P'Access, Str'Last);
Scan_Trailing_Blanks (Str, P);
return V;
end;
end if;
end Value_Real;
end System.Val_Real;

12
gcc/ada/sem_ch3.adb
View File

@ -16354,14 +16354,12 @@ package body Sem_Ch3 is
Set_Ekind (Id, Ekind (Prev)); -- will be reset later
Set_Class_Wide_Type (Id, Class_Wide_Type (Prev));
-- If the incomplete type is completed by a private declaration
-- the class-wide type remains associated with the incomplete
-- type, to prevent order-of-elaboration issues in gigi, else
-- we associate the class-wide type with the known full view.
-- The type of the classwide type is the current Id. Previously
-- this was not done for private declarations because of order-
-- of elaboration issues in the back-end, but gigi now handles
-- this properly.
if Nkind (N) /= N_Private_Type_Declaration then
Set_Etype (Class_Wide_Type (Id), Id);
end if;
Set_Etype (Class_Wide_Type (Id), Id);
end if;
-- Case of full declaration of private type

17
gcc/ada/sem_ch6.adb
View File

@ -6600,13 +6600,22 @@ package body Sem_Ch6 is
begin
-- In some cases a type imported through a limited_with clause, and
-- its nonlimited view are both visible, for example in an anonymous
-- access-to-class-wide type in a formal. Both entities designate the
-- same type.
-- access-to-class-wide type in a formal, or when building the body
-- for a subprogram renaming after the subprogram has been frozen.
-- In these cases Both entities designate the same type. In addition,
-- if one of them is an actual in an instance, it may be a subtype of
-- the non-limited view of the other.
if From_Limited_With (T1) and then T2 = Available_View (T1) then
if From_Limited_With (T1)
and then (T2 = Available_View (T1)
or else Is_Subtype_Of (T2, Available_View (T1)))
then
return True;
elsif From_Limited_With (T2) and then T1 = Available_View (T2) then
elsif From_Limited_With (T2)
and then (T1 = Available_View (T2)
or else Is_Subtype_Of (T1, Available_View (T2)))
then
return True;
elsif From_Limited_With (T1)

13
gcc/ada/sem_prag.adb
View File

@ -11491,12 +11491,15 @@ package body Sem_Prag is
E := Base_Type (E);
end if;
Set_Has_Volatile_Components (E);
-- Atomic implies both Independent and Volatile
if Prag_Id = Pragma_Atomic_Components then
Set_Has_Atomic_Components (E);
Set_Has_Independent_Components (E);
end if;
Set_Has_Volatile_Components (E);
else
Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
end if;
@ -14977,11 +14980,13 @@ package body Sem_Prag is
D := Declaration_Node (E);
K := Nkind (D);
-- The flag is set on the base type, or on the object
if K = N_Full_Type_Declaration
and then (Is_Array_Type (E) or else Is_Record_Type (E))
then
Independence_Checks.Append ((N, Base_Type (E)));
Set_Has_Independent_Components (Base_Type (E));
Independence_Checks.Append ((N, Base_Type (E)));
-- For record type, set all components independent
@ -14998,8 +15003,8 @@ package body Sem_Prag is
and then Nkind (Object_Definition (D)) =
N_Constrained_Array_Definition
then
Independence_Checks.Append ((N, Base_Type (Etype (E))));
Set_Has_Independent_Components (Base_Type (Etype (E)));
Set_Has_Independent_Components (E);
Independence_Checks.Append ((N, E));
else
Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);

19
gcc/ada/set_targ.adb
View File

@ -165,7 +165,7 @@ package body Set_Targ is
-- type can be found if it gets registered at all.
Long_Double_Index : Integer := -1;
-- Once all the back-end types have been registered, the index in
-- Once all the floating point types have been registered, the index in
-- FPT_Mode_Table at which "long double" can be found, if anywhere. A
-- negative value means that no "long double" has been registered. This
-- is useful to know whether we have a "long double" available at all and
@ -769,6 +769,10 @@ package body Set_Targ is
begin
E.NAME := new String'(Nam_Buf (1 .. Nam_Len));
if Long_Double_Index < 0 and then E.NAME.all = "long double" then
Long_Double_Index := Num_FPT_Modes;
end if;
E.DIGS := Get_Nat;
Check_Spaces;
@ -887,13 +891,6 @@ begin
end loop;
end;
-- Register floating-point types from the back end. We do this
-- unconditionally so C_Type_For may be called regardless of -gnateT, for
-- which cstand has a use, and early so we can use FPT_Mode_Table below to
-- compute some FP attributes.
Register_Back_End_Types (Register_Float_Type'Access);
-- Case of reading the target dependent values from file
-- This is bit more complex than might be expected, because it has to be
@ -939,7 +936,11 @@ begin
Wchar_T_Size := Get_Wchar_T_Size;
Words_BE := Get_Words_BE;
-- Compute the sizes of floating point types
-- Let the back-end register its floating point types and compute
-- the sizes of our standard types from there:
Num_FPT_Modes := 0;
Register_Back_End_Types (Register_Float_Type'Access);
declare
T : FPT_Mode_Entry renames