mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-25 01:20:52 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2010-10-19  Tristan Gingold  <gingold@adacore.com>

	* init.c: On Alpha/VMS, only adjust PC for HPARITH.

2010-10-19  Tristan Gingold  <gingold@adacore.com>

	* sem_attr.adb (Eval_Attribute): Handle Attribute_Ref, which can be
	evaluated on VMS.

2010-10-19  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch12.adb (Check_Generic_Child_Unit): Handle properly the case of
	an instantiation of a renaming of the implicit generic child that
	appears within an instance of its parent.

2010-10-19  Thomas Quinot  <quinot@adacore.com>

	* exp_ch9.adb: Minor reformatting.
	* einfo.adb, einfo.ads, atree.adb, atree.ads, exp_dist.adb, atree.h:
	(Referenced_Object): Remove unused entity attribute.
	(Direct_Primitive_Operations): Move to Elist10, this is set for all
	tagged types, including synchronous ones, so can't use field15 which is
	used as Storage_Size_Variable for task types and Entry_Bodies_Array for
	protected types.
	(Add_RACW_Primitive_Declarations_And_Bodies): Remove bogus guard
	against Concurrent_Types (we must handle the case of a RACW designating
	a class-wide private synchronous type).
	Use Direct_Primitive_Operations, not Primitive_Operations, since we
	really want the former.

2010-10-19  Bob Duff  <duff@adacore.com>

	* sem_ch8.adb (Pop_Scope): Change "return;" to "raise Program_Error;".

2010-10-19  Javier Miranda  <miranda@adacore.com>

	* exp_ch4.adb (Expand_Set_Membership.Make_Cond): Add missing support
	for N_Range nodes.

From-SVN: r165689
This commit is contained in:
Arnaud Charlet 2010-10-19 12:23:10 +02:00
parent 6c946a9fc3
commit 4620272938
13 changed files with 143 additions and 84 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
gcc/ada/ChangeLog
View File

@ -1,3 +1,42 @@
2010-10-19 Tristan Gingold <gingold@adacore.com>
* init.c: On Alpha/VMS, only adjust PC for HPARITH.
2010-10-19 Tristan Gingold <gingold@adacore.com>
* sem_attr.adb (Eval_Attribute): Handle Attribute_Ref, which can be
evaluated on VMS.
2010-10-19 Ed Schonberg <schonberg@adacore.com>
* sem_ch12.adb (Check_Generic_Child_Unit): Handle properly the case of
an instantiation of a renaming of the implicit generic child that
appears within an instance of its parent.
2010-10-19 Thomas Quinot <quinot@adacore.com>
* exp_ch9.adb: Minor reformatting.
* einfo.adb, einfo.ads, atree.adb, atree.ads, exp_dist.adb, atree.h:
(Referenced_Object): Remove unused entity attribute.
(Direct_Primitive_Operations): Move to Elist10, this is set for all
tagged types, including synchronous ones, so can't use field15 which is
used as Storage_Size_Variable for task types and Entry_Bodies_Array for
protected types.
(Add_RACW_Primitive_Declarations_And_Bodies): Remove bogus guard
against Concurrent_Types (we must handle the case of a RACW designating
a class-wide private synchronous type).
Use Direct_Primitive_Operations, not Primitive_Operations, since we
really want the former.
2010-10-19 Bob Duff <duff@adacore.com>
* sem_ch8.adb (Pop_Scope): Change "return;" to "raise Program_Error;".
2010-10-19 Javier Miranda <miranda@adacore.com>
* exp_ch4.adb (Expand_Set_Membership.Make_Cond): Add missing support
for N_Range nodes.
2010-10-19 Thomas Quinot <quinot@adacore.com>
* einfo.ads, atree.ads: Minor comment fixes.

17
gcc/ada/atree.adb
View File

@ -2455,6 +2455,17 @@ package body Atree is
end if;
end Elist8;
function Elist10 (N : Node_Id) return Elist_Id is
pragma Assert (Nkind (N) in N_Entity);
Value : constant Union_Id := Nodes.Table (N + 1).Field10;
begin
if Value = 0 then
return No_Elist;
else
return Elist_Id (Value);
end if;
end Elist10;
function Elist13 (N : Node_Id) return Elist_Id is
pragma Assert (Nkind (N) in N_Entity);
Value : constant Union_Id := Nodes.Table (N + 2).Field6;
@ -4672,6 +4683,12 @@ package body Atree is
Nodes.Table (N + 1).Field8 := Union_Id (Val);
end Set_Elist8;
procedure Set_Elist10 (N : Node_Id; Val : Elist_Id) is
begin
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Field10 := Union_Id (Val);
end Set_Elist10;
procedure Set_Elist13 (N : Node_Id; Val : Elist_Id) is
begin
pragma Assert (Nkind (N) in N_Entity);

10
gcc/ada/atree.ads
View File

@ -193,8 +193,8 @@ package Atree is
-- Uint6 Synonym for Field6 typed as Uint (Empty = Uint_0)
-- Similar definitions for Field7 to Field28 (and Node7-Node28,
-- Elist7-Elist28, Uint7-Uint28, Ureal7-Ureal28). Note that not all
-- these functions are defined, only the ones that are actually used.
-- Elist7-Elist28, Uint7-Uint28, Ureal7-Ureal28). Note that not all these
-- functions are defined, only the ones that are actually used.
function Last_Node_Id return Node_Id;
pragma Inline (Last_Node_Id);
@ -1112,6 +1112,9 @@ package Atree is
function Elist8 (N : Node_Id) return Elist_Id;
pragma Inline (Elist8);
function Elist10 (N : Node_Id) return Elist_Id;
pragma Inline (Elist10);
function Elist13 (N : Node_Id) return Elist_Id;
pragma Inline (Elist13);
@ -2172,6 +2175,9 @@ package Atree is
procedure Set_Elist8 (N : Node_Id; Val : Elist_Id);
pragma Inline (Set_Elist8);
procedure Set_Elist10 (N : Node_Id; Val : Elist_Id);
pragma Inline (Set_Elist10);
procedure Set_Elist13 (N : Node_Id; Val : Elist_Id);
pragma Inline (Set_Elist13);

1
gcc/ada/atree.h
View File

@ -427,6 +427,7 @@ extern Node_Id Current_Error_Node;
#define Elist3(N) Field3 (N)
#define Elist4(N) Field4 (N)
#define Elist8(N) Field8 (N)
#define Elist10(N) Field10 (N)
#define Elist13(N) Field13 (N)
#define Elist15(N) Field15 (N)
#define Elist16(N) Field16 (N)

47
gcc/ada/einfo.adb
View File

@ -85,10 +85,10 @@ package body Einfo is
-- Current_Value Node9
-- Renaming_Map Uint9
-- Direct_Primitive_Operations Elist10
-- Discriminal_Link Node10
-- Handler_Records List10
-- Normalized_Position_Max Uint10
-- Referenced_Object Node10
-- Component_Bit_Offset Uint11
-- Full_View Node11
@ -121,7 +121,6 @@ package body Einfo is
-- Entry_Parameters_Type Node15
-- Extra_Formal Node15
-- Lit_Indexes Node15
-- Direct_Primitive_Operations Elist15
-- Related_Instance Node15
-- Scale_Value Uint15
-- Storage_Size_Variable Node15
@ -819,9 +818,8 @@ package body Einfo is
function Direct_Primitive_Operations (Id : E) return L is
begin
pragma Assert (Is_Tagged_Type (Id)
and then not Is_Concurrent_Type (Id));
return Elist15 (Id);
pragma Assert (Is_Tagged_Type (Id));
return Elist10 (Id);
end Direct_Primitive_Operations;
function Directly_Designated_Type (Id : E) return E is
@ -2429,12 +2427,6 @@ package body Einfo is
return Flag227 (Id);
end Referenced_As_Out_Parameter;
function Referenced_Object (Id : E) return N is
begin
pragma Assert (Is_Type (Id));
return Node10 (Id);
end Referenced_Object;
function Register_Exception_Call (Id : E) return N is
begin
pragma Assert (Ekind (Id) = E_Exception);
@ -4832,15 +4824,8 @@ package body Einfo is
procedure Set_Direct_Primitive_Operations (Id : E; V : L) is
begin
pragma Assert
(Is_Tagged_Type (Id)
and then
(Is_Record_Type (Id)
or else
Is_Incomplete_Type (Id)
or else
Ekind_In (Id, E_Private_Type, E_Private_Subtype)));
Set_Elist15 (Id, V);
pragma Assert (Is_Tagged_Type (Id));
Set_Elist10 (Id, V);
end Set_Direct_Primitive_Operations;
procedure Set_Prival (Id : E; V : E) is
@ -4908,12 +4893,6 @@ package body Einfo is
Set_Flag227 (Id, V);
end Set_Referenced_As_Out_Parameter;
procedure Set_Referenced_Object (Id : E; V : N) is
begin
pragma Assert (Is_Type (Id));
Set_Node10 (Id, V);
end Set_Referenced_Object;
procedure Set_Register_Exception_Call (Id : E; V : N) is
begin
pragma Assert (Ekind (Id) = E_Exception);
@ -7432,8 +7411,13 @@ package body Einfo is
procedure Write_Field10_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
when Type_Kind =>
Write_Str ("Referenced_Object");
when Class_Wide_Kind |
Incomplete_Kind |
E_Record_Type |
E_Record_Subtype |
Private_Kind |
Concurrent_Kind =>
Write_Str ("Direct_Primitive_Operations");
when E_In_Parameter |
E_Constant =>
@ -7616,13 +7600,6 @@ package body Einfo is
Task_Kind =>
Write_Str ("Storage_Size_Variable");
when Class_Wide_Kind |
Incomplete_Kind |
E_Record_Type |
E_Record_Subtype |
Private_Kind =>
Write_Str ("Direct_Primitive_Operations");
when E_Component =>
Write_Str ("DT_Entry_Count");

25
gcc/ada/einfo.ads
View File

@ -769,7 +769,7 @@ package Einfo is
-- Present in floating point types and subtypes and decimal types and
-- subtypes. Contains the Digits value specified in the declaration.
-- Direct_Primitive_Operations (Elist15)
-- Direct_Primitive_Operations (Elist10)
-- Present in tagged types and subtypes (including synchronized types),
-- in tagged private types and in tagged incomplete types. Element list
-- of entities for primitive operations of the tagged type. Not present
@ -3308,12 +3308,6 @@ package Einfo is
-- we have a separate warning for variables that are only assigned and
-- never read, and out parameters are a special case.
-- Referenced_Object (Node10)
-- Present in all type entities. Set non-Empty only for type entities
-- constructed for unconstrained objects, or objects that depend on
-- discriminants. Points to the expression from which the actual
-- subtype of the object can be evaluated.
-- Register_Exception_Call (Node20)
-- Present in exception entities. When an exception is declared,
-- a call is expanded to Register_Exception. This field points to
@ -4697,7 +4691,6 @@ package Einfo is
-- Associated_Node_For_Itype (Node8)
-- Class_Wide_Type (Node9)
-- Referenced_Object (Node10)
-- Full_View (Node11)
-- Esize (Uint12)
-- RM_Size (Uint13)
@ -4854,6 +4847,7 @@ package Einfo is
-- E_Class_Wide_Type
-- E_Class_Wide_Subtype
-- Direct_Primitive_Operations (Elist10)
-- Cloned_Subtype (Node16) (subtype case only)
-- First_Entity (Node17)
-- Equivalent_Type (Node18) (always Empty for type)
@ -5126,6 +5120,7 @@ package Einfo is
-- E_Incomplete_Type
-- E_Incomplete_Subtype
-- Direct_Primitive_Operations (Elist10)
-- Non_Limited_View (Node17)
-- Private_Dependents (Elist18)
-- Discriminant_Constraint (Elist21)
@ -5280,7 +5275,7 @@ package Einfo is
-- E_Private_Type
-- E_Private_Subtype
-- Direct_Primitive_Operations (Elist15)
-- Direct_Primitive_Operations (Elist10)
-- First_Entity (Node17)
-- Private_Dependents (Elist18)
-- Underlying_Full_View (Node19)
@ -5369,6 +5364,7 @@ package Einfo is
-- E_Protected_Type
-- E_Protected_Subtype
-- Direct_Primitive_Operations (Elist10)
-- Entry_Bodies_Array (Node15)
-- First_Private_Entity (Node16)
-- First_Entity (Node17)
@ -5387,7 +5383,7 @@ package Einfo is
-- E_Record_Type
-- E_Record_Subtype
-- Direct_Primitive_Operations (Elist15)
-- Direct_Primitive_Operations (Elist10)
-- Access_Disp_Table (Elist16) (base type only)
-- Dispatch_Table_Wrappers (Elist26) (base type only)
-- Cloned_Subtype (Node16) (subtype case only)
@ -5420,7 +5416,7 @@ package Einfo is
-- E_Record_Type_With_Private
-- E_Record_Subtype_With_Private
-- Direct_Primitive_Operations (Elist15)
-- Direct_Primitive_Operations (Elist10)
-- Access_Disp_Table (Elist16) (base type only)
-- Dispatch_Table_Wrappers (Elist26) (base type only)
-- First_Entity (Node17)
@ -5494,6 +5490,7 @@ package Einfo is
-- E_Task_Type
-- E_Task_Subtype
-- Direct_Primitive_Operations (Elist10)
-- Storage_Size_Variable (Node15) (base type only)
-- First_Private_Entity (Node16)
-- First_Entity (Node17)
@ -6104,7 +6101,6 @@ package Einfo is
function Referenced (Id : E) return B;
function Referenced_As_LHS (Id : E) return B;
function Referenced_As_Out_Parameter (Id : E) return B;
function Referenced_Object (Id : E) return N;
function Register_Exception_Call (Id : E) return N;
function Related_Array_Object (Id : E) return E;
function Related_Expression (Id : E) return N;
@ -6287,7 +6283,7 @@ package Einfo is
-- predicate is true only if the value is set (Known) and is set to a
-- compile time known value. Note that in the case of Alignment and
-- Normalized_First_Bit, dynamic values are not possible, so we do not
-- need a separate Known_Static calls in these cases. The not set (unknown
-- need a separate Known_Static calls in these cases. The not set (unknown)
-- values are as follows:
-- Alignment Uint_0 or No_Uint
@ -6675,7 +6671,6 @@ package Einfo is
procedure Set_Referenced (Id : E; V : B := True);
procedure Set_Referenced_As_LHS (Id : E; V : B := True);
procedure Set_Referenced_As_Out_Parameter (Id : E; V : B := True);
procedure Set_Referenced_Object (Id : E; V : N);
procedure Set_Register_Exception_Call (Id : E; V : N);
procedure Set_Related_Array_Object (Id : E; V : E);
procedure Set_Related_Expression (Id : E; V : N);
@ -7393,7 +7388,6 @@ package Einfo is
pragma Inline (Referenced);
pragma Inline (Referenced_As_LHS);
pragma Inline (Referenced_As_Out_Parameter);
pragma Inline (Referenced_Object);
pragma Inline (Register_Exception_Call);
pragma Inline (Related_Array_Object);
pragma Inline (Related_Expression);
@ -7784,7 +7778,6 @@ package Einfo is
pragma Inline (Set_Referenced);
pragma Inline (Set_Referenced_As_LHS);
pragma Inline (Set_Referenced_As_Out_Parameter);
pragma Inline (Set_Referenced_Object);
pragma Inline (Set_Register_Exception_Call);
pragma Inline (Set_Related_Array_Object);
pragma Inline (Set_Related_Expression);

7
gcc/ada/exp_ch4.adb
View File

@ -3351,7 +3351,7 @@ package body Exp_Ch4 is
-- number-of-elements * component_type'Max_Size_In_Storage_Elements
-- which avoids this problem. All this is a big bogus, but it does
-- which avoids this problem. All this is a bit bogus, but it does
-- mean we catch common cases of trying to allocate arrays that
-- are too large, and which in the absence of a check results in
-- undetected chaos ???
@ -4348,8 +4348,9 @@ package body Exp_Ch4 is
R : constant Node_Id := Relocate_Node (Alt);
begin
if Is_Entity_Name (Alt)
and then Is_Type (Entity (Alt))
if (Is_Entity_Name (Alt)
and then Is_Type (Entity (Alt)))
or else Nkind (Alt) = N_Range
then
Cond :=
Make_In (Sloc (Alt),

11
gcc/ada/exp_ch9.adb
View File

@ -7420,11 +7420,10 @@ package body Exp_Ch9 is
-- Generate a specification without a letter suffix in order to
-- override an interface function or procedure.
Spec :=
Build_Protected_Sub_Specification (N, Pid, Dispatching_Mode);
Spec := Build_Protected_Sub_Specification (N, Pid, Dispatching_Mode);
-- The formal parameters become the actuals of the protected
-- function or procedure call.
-- The formal parameters become the actuals of the protected function
-- or procedure call.
Actuals := New_List;
Formal := First (Parameter_Specifications (Spec));
@ -7457,8 +7456,8 @@ package body Exp_Ch9 is
return
Make_Subprogram_Body (Loc,
Declarations => Empty_List,
Specification => Spec,
Declarations => Empty_List,
Specification => Spec,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stmts));
end Build_Dispatching_Subprogram_Body;

12
gcc/ada/exp_dist.adb
View File

@ -1314,15 +1314,17 @@ package body Exp_Dist is
end if;
-- Build callers, receivers for every primitive operations and a RPC
-- receiver for this type.
-- receiver for this type. Note that we use Direct_Primitive_Operations,
-- not Primitive_Operations, because we really want just the primitives
-- of the tagged type itself, and in the case of a tagged synchronized
-- type we do not want to get the primitives of the corresponding
-- record type).
if not Is_Concurrent_Type (Designated_Type)
and then Present (Primitive_Operations (Designated_Type))
then
if Present (Direct_Primitive_Operations (Designated_Type)) then
Overload_Counter_Table.Reset;
Current_Primitive_Elmt :=
First_Elmt (Primitive_Operations (Designated_Type));
First_Elmt (Direct_Primitive_Operations (Designated_Type));
while Current_Primitive_Elmt /= No_Elmt loop
Current_Primitive := Node (Current_Primitive_Elmt);

29
gcc/ada/init.c
View File

@ -1396,13 +1396,13 @@ __gnat_handle_vms_condition (int *sigargs, void *mechargs)
exception = &storage_error;
msg = "stack overflow (or erroneous memory access)";
}
__gnat_adjust_context_for_raise (0, (void *)mechargs);
__gnat_adjust_context_for_raise (SS$_ACCVIO, (void *)mechargs);
break;
case SS$_STKOVF:
exception = &storage_error;
msg = "stack overflow";
__gnat_adjust_context_for_raise (0, (void *)mechargs);
__gnat_adjust_context_for_raise (SS$_STKOVF, (void *)mechargs);
break;
case SS$_HPARITH:
@ -1411,11 +1411,7 @@ __gnat_handle_vms_condition (int *sigargs, void *mechargs)
#else
exception = &constraint_error;
msg = "arithmetic error";
#ifndef __alpha__
/* No need to adjust pc on Alpha: the pc is already on the instruction
after the trapping one. */
__gnat_adjust_context_for_raise (0, (void *)mechargs);
#endif
__gnat_adjust_context_for_raise (SS$_HPARITH, (void *)mechargs);
#endif
break;
@ -1491,17 +1487,20 @@ __gnat_install_handler (void)
void
__gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext)
{
/* Add one to the address of the instruction signaling the condition,
located in the sigargs array. */
if (signo == SS$_HPARITH)
{
/* Sub one to the address of the instruction signaling the condition,
located in the sigargs array. */
CHF$MECH_ARRAY * mechargs = (CHF$MECH_ARRAY *) ucontext;
CHF$SIGNAL_ARRAY * sigargs
= (CHF$SIGNAL_ARRAY *) mechargs->chf$q_mch_sig_addr;
CHF$MECH_ARRAY * mechargs = (CHF$MECH_ARRAY *) ucontext;
CHF$SIGNAL_ARRAY * sigargs
= (CHF$SIGNAL_ARRAY *) mechargs->chf$q_mch_sig_addr;
int vcount = sigargs->chf$is_sig_args;
int * pc_slot = & (&sigargs->chf$l_sig_name)[vcount-2];
int vcount = sigargs->chf$is_sig_args;
int * pc_slot = & (&sigargs->chf$l_sig_name)[vcount-2];
(*pc_slot) ++;
(*pc_slot)--;
}
}
#endif

8
gcc/ada/sem_attr.adb
View File

@ -6910,6 +6910,13 @@ package body Sem_Attr is
end case;
end;
---------
-- Ref --
---------
when Attribute_Ref =>
Fold_Uint (N, Expr_Value (E1), True);
---------------
-- Remainder --
---------------
@ -7679,7 +7686,6 @@ package body Sem_Attr is
Attribute_Position |
Attribute_Priority |
Attribute_Read |
Attribute_Ref |
Attribute_Result |
Attribute_Storage_Pool |
Attribute_Storage_Size |

19
gcc/ada/sem_ch12.adb
View File

@ -5309,6 +5309,25 @@ package body Sem_Ch12 is
then
Install_Parent (Inst_Par);
Parent_Installed := True;
-- The generic unit may be the renaming of the implicit child
-- present in an instance. In that case the parent instance is
-- obtained from the name of the renamed entity.
elsif Ekind (Entity (Gen_Id)) = E_Generic_Package
and then Present (Renamed_Entity (Entity (Gen_Id)))
and then Is_Child_Unit (Renamed_Entity (Entity (Gen_Id)))
then
declare
Renamed_Package : constant Node_Id :=
Name (Parent (Entity (Gen_Id)));
begin
if Nkind (Renamed_Package) = N_Expanded_Name then
Inst_Par := Entity (Prefix (Renamed_Package));
Install_Parent (Inst_Par);
Parent_Installed := True;
end if;
end;
end if;
end if;

2
gcc/ada/sem_ch8.adb
View File

@ -6683,7 +6683,7 @@ package body Sem_Ch8 is
or else
SST.Actions_To_Be_Wrapped_After /= No_List
then
return;
raise Program_Error;
end if;
-- Free last subprogram name if allocated, and pop scope