From 462027293874eb55bf0da3468f5635bc9f550ed3 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 19 Oct 2010 12:23:10 +0200 Subject: [multiple changes] 2010-10-19 Tristan Gingold * init.c: On Alpha/VMS, only adjust PC for HPARITH. 2010-10-19 Tristan Gingold * sem_attr.adb (Eval_Attribute): Handle Attribute_Ref, which can be evaluated on VMS. 2010-10-19 Ed Schonberg * 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 * 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 * sem_ch8.adb (Pop_Scope): Change "return;" to "raise Program_Error;". 2010-10-19 Javier Miranda * exp_ch4.adb (Expand_Set_Membership.Make_Cond): Add missing support for N_Range nodes. From-SVN: r165689 --- gcc/ada/ChangeLog | 39 +++++++++++++++++++++++++++++++++++++++ gcc/ada/atree.adb | 17 +++++++++++++++++ gcc/ada/atree.ads | 10 ++++++++-- gcc/ada/atree.h | 1 + gcc/ada/einfo.adb | 47 ++++++++++++----------------------------------- gcc/ada/einfo.ads | 25 +++++++++---------------- gcc/ada/exp_ch4.adb | 7 ++++--- gcc/ada/exp_ch9.adb | 11 +++++------ gcc/ada/exp_dist.adb | 12 +++++++----- gcc/ada/init.c | 29 ++++++++++++++--------------- gcc/ada/sem_attr.adb | 8 +++++++- gcc/ada/sem_ch12.adb | 19 +++++++++++++++++++ gcc/ada/sem_ch8.adb | 2 +- 13 files changed, 143 insertions(+), 84 deletions(-) (limited to 'gcc') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index acc417c..52d61914 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,42 @@ +2010-10-19 Tristan Gingold + + * init.c: On Alpha/VMS, only adjust PC for HPARITH. + +2010-10-19 Tristan Gingold + + * sem_attr.adb (Eval_Attribute): Handle Attribute_Ref, which can be + evaluated on VMS. + +2010-10-19 Ed Schonberg + + * 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 + + * 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 + + * sem_ch8.adb (Pop_Scope): Change "return;" to "raise Program_Error;". + +2010-10-19 Javier Miranda + + * exp_ch4.adb (Expand_Set_Membership.Make_Cond): Add missing support + for N_Range nodes. + 2010-10-19 Thomas Quinot * einfo.ads, atree.ads: Minor comment fixes. diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 4b518b1..957cca5 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -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); diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 06e06de..904c637 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -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); diff --git a/gcc/ada/atree.h b/gcc/ada/atree.h index 447338f..454ed14 100644 --- a/gcc/ada/atree.h +++ b/gcc/ada/atree.h @@ -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) diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 0ea9515..48672cf 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -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"); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 6accd05..de37ed3 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -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); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index d501cd5..efa0e74 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -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), diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index b38e2ab..171c81c 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -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; diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index 2a0f800..84cba49 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -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); diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 766dbdd..60b7cfd 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -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 diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 1691fab..f520b4b 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -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 | diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 45b61bb..4b15644 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -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; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index cdd8bf6..0e9d0b4 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -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 -- cgit v1.1