From ef2a63ba1869942eae7ab3ceb4cada0f025a60ad Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Mon, 18 Oct 2010 09:59:45 +0000 Subject: einfo.ads, einfo.adb (Primitive_Operations): New synthesized attribute. 2010-10-18 Javier Miranda * einfo.ads, einfo.adb (Primitive_Operations): New synthesized attribute. (Direct_Primitive_Operations): Renaming of old Primitive_Operations. (Set_Direct_Primitive_Operations): Renaming of old Set_Primitive_Operations. Update documentation * sem_ch3.adb, exp_util.adb, sem_ch7.adb, sem_ch8.adb, exp_ch3.adb: Replace occurrences of Set_Primitive_Operations by Set_Direct_Primitive_Operations. * sem_cat.adb (Validate_RACW_Primitives): No action needed for tagged concurrent types. * exp_dist.adb (Add_RACW_Primitive_Declarations_And_Bodies): Do not process primitives of concurrent types. * lib-xref.adb (Generate_Prim_Op_References): Minor code cleanup. From-SVN: r165618 --- gcc/ada/ChangeLog | 16 ++++++++++++++ gcc/ada/einfo.adb | 35 ++++++++++++++++++++++++------ gcc/ada/einfo.ads | 42 +++++++++++++++++++++--------------- gcc/ada/exp_ch3.adb | 4 ++-- gcc/ada/exp_dist.adb | 13 ++++++----- gcc/ada/exp_util.adb | 4 ++-- gcc/ada/lib-xref.adb | 9 +------- gcc/ada/sem_cat.adb | 6 ++++++ gcc/ada/sem_ch3.adb | 61 +++++++++++++++++++++++++++------------------------- gcc/ada/sem_ch7.adb | 10 ++++----- gcc/ada/sem_ch8.adb | 2 +- 11 files changed, 126 insertions(+), 76 deletions(-) (limited to 'gcc') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 37b23e9..0813f2e 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,19 @@ +2010-10-18 Javier Miranda + + * einfo.ads, einfo.adb (Primitive_Operations): New synthesized + attribute. + (Direct_Primitive_Operations): Renaming of old Primitive_Operations. + (Set_Direct_Primitive_Operations): Renaming of old + Set_Primitive_Operations. Update documentation + * sem_ch3.adb, exp_util.adb, sem_ch7.adb, sem_ch8.adb, exp_ch3.adb: + Replace occurrences of Set_Primitive_Operations by + Set_Direct_Primitive_Operations. + * sem_cat.adb (Validate_RACW_Primitives): No action needed for tagged + concurrent types. + * exp_dist.adb (Add_RACW_Primitive_Declarations_And_Bodies): Do not + process primitives of concurrent types. + * lib-xref.adb (Generate_Prim_Op_References): Minor code cleanup. + 2010-10-18 Eric Botcazou * exp_ch6.adb (Expand_N_Subprogram_Declaration): Use Freeze_Before. diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 6782c5b..a8bb4d2 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -121,7 +121,7 @@ package body Einfo is -- Entry_Parameters_Type Node15 -- Extra_Formal Node15 -- Lit_Indexes Node15 - -- Primitive_Operations Elist15 + -- Direct_Primitive_Operations Elist15 -- Related_Instance Node15 -- Scale_Value Uint15 -- Storage_Size_Variable Node15 @@ -817,6 +817,12 @@ package body Einfo is return Uint17 (Id); end Digits_Value; + function Direct_Primitive_Operations (Id : E) return L is + begin + pragma Assert (Is_Tagged_Type (Id)); + return Elist15 (Id); + end Direct_Primitive_Operations; + function Directly_Designated_Type (Id : E) return E is begin pragma Assert (Is_Access_Type (Id)); @@ -2355,8 +2361,16 @@ package body Einfo is function Primitive_Operations (Id : E) return L is begin - pragma Assert (Is_Tagged_Type (Id)); - return Elist15 (Id); + if Is_Concurrent_Type (Id) then + if Present (Corresponding_Record_Type (Id)) then + return Direct_Primitive_Operations + (Corresponding_Record_Type (Id)); + else + return No_Elist; + end if; + else + return Direct_Primitive_Operations (Id); + end if; end Primitive_Operations; function Prival (Id : E) return E is @@ -4817,11 +4831,18 @@ package body Einfo is Set_Node8 (Id, V); end Set_Postcondition_Proc; - procedure Set_Primitive_Operations (Id : E; V : L) is + procedure Set_Direct_Primitive_Operations (Id : E; V : L) is begin - pragma Assert (Is_Tagged_Type (Id)); + 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); - end Set_Primitive_Operations; + end Set_Direct_Primitive_Operations; procedure Set_Prival (Id : E; V : E) is begin @@ -7583,7 +7604,7 @@ package body Einfo is E_Record_Type | E_Record_Subtype | Private_Kind => - Write_Str ("Primitive_Operations"); + 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 c459f64..3abc37b 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -769,6 +769,16 @@ 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) +-- Present in tagged record types and subtypes, in tagged private types +-- and in tagged incomplete types. Points to an element list of entities +-- for primitive operations for the tagged type. Not present in untagged +-- types (it is an error to reference the primitive operations field of a +-- type that is not tagged). In order to fulfill the C++ ABI, entities of +-- primitives that come from source must be stored in this list following +-- their order of occurrence in the sources. For incomplete types the +-- list is always empty. + -- Directly_Designated_Type (Node20) -- Present in access types. This field points to the type that is -- directly designated by the access type. In the case of an access @@ -3201,15 +3211,12 @@ package Einfo is -- to generate the call to this procedure in case the expander inserts -- implicit return statements. --- Primitive_Operations (Elist15) --- Present in tagged record types and subtypes and in tagged private --- types. Points to an element list of entities for primitive operations --- for the tagged type. Not present (and not set) in untagged types (it --- is an error to reference the primitive operations field of a type --- that is not tagged). In order to fulfill the C++ ABI, entities of --- primitives that come from source must be stored in this list following --- their order of occurrence in the sources. Also present in incomplete --- types, but in this case the list is always empty. +-- Primitive_Operations (synthesized) +-- Present in concurrent types, tagged record types and subtypes, tagged +-- private types and tagged incomplete types. For concurrent types that +-- have available their Corresponding_Record_Type (CRT) returns the list +-- of Direct_Primitive_Operations of its CRT; otherwise returns No_Elist. +-- For all the other types returns its Direct_Primitive_Operations. -- Prival (Node17) -- Present in private components of protected types. Refers to the entity @@ -5262,7 +5269,7 @@ package Einfo is -- E_Private_Type -- E_Private_Subtype - -- Primitive_Operations (Elist15) + -- Direct_Primitive_Operations (Elist15) -- First_Entity (Node17) -- Private_Dependents (Elist18) -- Underlying_Full_View (Node19) @@ -5369,7 +5376,7 @@ package Einfo is -- E_Record_Type -- E_Record_Subtype - -- Primitive_Operations (Elist15) + -- Direct_Primitive_Operations (Elist15) -- Access_Disp_Table (Elist16) (base type only) -- Dispatch_Table_Wrappers (Elist26) (base type only) -- Cloned_Subtype (Node16) (subtype case only) @@ -5402,7 +5409,7 @@ package Einfo is -- E_Record_Type_With_Private -- E_Record_Subtype_With_Private - -- Primitive_Operations (Elist15) + -- Direct_Primitive_Operations (Elist15) -- Access_Disp_Table (Elist16) (base type only) -- Dispatch_Table_Wrappers (Elist26) (base type only) -- First_Entity (Node17) @@ -6072,7 +6079,7 @@ package Einfo is function Packed_Array_Type (Id : E) return E; function Parent_Subtype (Id : E) return E; function Postcondition_Proc (Id : E) return E; - function Primitive_Operations (Id : E) return L; + function Direct_Primitive_Operations (Id : E) return L; function Prival (Id : E) return E; function Prival_Link (Id : E) return E; function Private_Dependents (Id : E) return L; @@ -6248,8 +6255,9 @@ package Einfo is function Number_Dimensions (Id : E) return Pos; function Number_Entries (Id : E) return Nat; function Number_Formals (Id : E) return Pos; - function Root_Type (Id : E) return E; function Parameter_Mode (Id : E) return Formal_Kind; + function Primitive_Operations (Id : E) return L; + function Root_Type (Id : E) return E; function Scope_Depth_Set (Id : E) return B; function Size_Clause (Id : E) return N; function Stream_Size_Clause (Id : E) return N; @@ -6641,7 +6649,7 @@ package Einfo is procedure Set_Packed_Array_Type (Id : E; V : E); procedure Set_Parent_Subtype (Id : E; V : E); procedure Set_Postcondition_Proc (Id : E; V : E); - procedure Set_Primitive_Operations (Id : E; V : L); + procedure Set_Direct_Primitive_Operations (Id : E; V : L); procedure Set_Prival (Id : E; V : E); procedure Set_Prival_Link (Id : E; V : E); procedure Set_Private_Dependents (Id : E; V : L); @@ -7047,6 +7055,7 @@ package Einfo is pragma Inline (Dependent_Instances); pragma Inline (Depends_On_Private); pragma Inline (Digits_Value); + pragma Inline (Direct_Primitive_Operations); pragma Inline (Directly_Designated_Type); pragma Inline (Discard_Names); pragma Inline (Discriminal); @@ -7358,7 +7367,6 @@ package Einfo is pragma Inline (Parameter_Mode); pragma Inline (Parent_Subtype); pragma Inline (Postcondition_Proc); - pragma Inline (Primitive_Operations); pragma Inline (Prival); pragma Inline (Prival_Link); pragma Inline (Private_Dependents); @@ -7482,6 +7490,7 @@ package Einfo is pragma Inline (Set_Dependent_Instances); pragma Inline (Set_Depends_On_Private); pragma Inline (Set_Digits_Value); + pragma Inline (Set_Direct_Primitive_Operations); pragma Inline (Set_Directly_Designated_Type); pragma Inline (Set_Discard_Names); pragma Inline (Set_Discriminal); @@ -7748,7 +7757,6 @@ package Einfo is pragma Inline (Set_Packed_Array_Type); pragma Inline (Set_Parent_Subtype); pragma Inline (Set_Postcondition_Proc); - pragma Inline (Set_Primitive_Operations); pragma Inline (Set_Prival); pragma Inline (Set_Prival_Link); pragma Inline (Set_Private_Dependents); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index f67e1c4..aca005e 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -6144,8 +6144,8 @@ package body Exp_Ch3 is (Rep, Access_Disp_Table (Def_Id)); Set_Dispatch_Table_Wrappers (Rep, Dispatch_Table_Wrappers (Def_Id)); - Set_Primitive_Operations - (Rep, Primitive_Operations (Def_Id)); + Set_Direct_Primitive_Operations + (Rep, Direct_Primitive_Operations (Def_Id)); end; end if; diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index b8feb09..2a0f800 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -1316,7 +1316,9 @@ package body Exp_Dist is -- Build callers, receivers for every primitive operations and a RPC -- receiver for this type. - if Present (Primitive_Operations (Designated_Type)) then + if not Is_Concurrent_Type (Designated_Type) + and then Present (Primitive_Operations (Designated_Type)) + then Overload_Counter_Table.Reset; Current_Primitive_Elmt := @@ -1336,8 +1338,9 @@ package body Exp_Dist is Is_TSS (Current_Primitive, TSS_Stream_Input) or else Is_TSS (Current_Primitive, TSS_Stream_Output) or else Is_TSS (Current_Primitive, TSS_Stream_Read) or else - Is_TSS (Current_Primitive, TSS_Stream_Write) or else - Is_Predefined_Interface_Primitive (Current_Primitive)) + Is_TSS (Current_Primitive, TSS_Stream_Write) + or else + Is_Predefined_Interface_Primitive (Current_Primitive)) and then not Is_Hidden (Current_Primitive) then -- The first thing to do is build an up-to-date copy of the @@ -1413,8 +1416,8 @@ package body Exp_Dist is RACW_Type => Stub_Elements.RACW_Type, Parent_Primitive => Current_Primitive); - Current_Receiver := Defining_Unit_Name ( - Specification (Current_Receiver_Body)); + Current_Receiver := + Defining_Unit_Name (Specification (Current_Receiver_Body)); Append_To (Body_Decls, Current_Receiver_Body); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 77ad7a0..7068e22 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -4115,8 +4115,8 @@ package body Exp_Util is if Is_Tagged_Type (Priv_Subtyp) then Set_Class_Wide_Type (Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ)); - Set_Primitive_Operations (Priv_Subtyp, - Primitive_Operations (Unc_Typ)); + Set_Direct_Primitive_Operations (Priv_Subtyp, + Direct_Primitive_Operations (Unc_Typ)); end if; Set_Full_View (Priv_Subtyp, Full_Subtyp); diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index 02af70c..db8097a 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -241,14 +241,7 @@ package body Lib.Xref is -- The check for Present here is to protect against previously -- reported critical errors. - if Is_Concurrent_Type (Base_T) - and then Present (Corresponding_Record_Type (Base_T)) - then - Prim_List := Primitive_Operations - (Corresponding_Record_Type (Base_T)); - else - Prim_List := Primitive_Operations (Base_T); - end if; + Prim_List := Primitive_Operations (Base_T); if No (Prim_List) then return; diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index aa62305..9f64223 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.adb @@ -1334,6 +1334,12 @@ package body Sem_Cat is begin Desig_Type := Etype (Designated_Type (T)); + -- No action needed for concurrent types + + if Is_Concurrent_Type (Desig_Type) then + return; + end if; + Primitive_Subprograms := Primitive_Operations (Desig_Type); Subprogram_Elmt := First_Elmt (Primitive_Subprograms); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index d99db52..a17ab53 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2444,7 +2444,7 @@ package body Sem_Ch3 is if Tagged_Present (N) then Set_Is_Tagged_Type (T); Make_Class_Wide_Type (T); - Set_Primitive_Operations (T, New_Elmt_List); + Set_Direct_Primitive_Operations (T, New_Elmt_List); end if; Push_Scope (T); @@ -2496,7 +2496,7 @@ package body Sem_Ch3 is or else Task_Present (Def)); Set_Interfaces (T, New_Elmt_List); - Set_Primitive_Operations (T, New_Elmt_List); + Set_Direct_Primitive_Operations (T, New_Elmt_List); -- Complete the decoration of the class-wide entity if it was already -- built (i.e. during the creation of the limited view) @@ -3936,8 +3936,8 @@ package body Sem_Ch3 is if Is_Tagged_Type (T) then Set_Is_Tagged_Type (Id); Set_Is_Abstract_Type (Id, Is_Abstract_Type (T)); - Set_Primitive_Operations - (Id, Primitive_Operations (T)); + Set_Direct_Primitive_Operations + (Id, Direct_Primitive_Operations (T)); Set_Class_Wide_Type (Id, Class_Wide_Type (T)); if Is_Interface (T) then @@ -3960,10 +3960,11 @@ package body Sem_Ch3 is (Id, Known_To_Have_Preelab_Init (T)); if Is_Tagged_Type (T) then - Set_Is_Tagged_Type (Id); - Set_Is_Abstract_Type (Id, Is_Abstract_Type (T)); - Set_Primitive_Operations (Id, Primitive_Operations (T)); - Set_Class_Wide_Type (Id, Class_Wide_Type (T)); + Set_Is_Tagged_Type (Id); + Set_Is_Abstract_Type (Id, Is_Abstract_Type (T)); + Set_Class_Wide_Type (Id, Class_Wide_Type (T)); + Set_Direct_Primitive_Operations (Id, + Direct_Primitive_Operations (T)); end if; -- In general the attributes of the subtype of a private type @@ -7352,7 +7353,7 @@ package body Sem_Ch3 is -- Set fields for tagged types if Is_Tagged then - Set_Primitive_Operations (Derived_Type, New_Elmt_List); + Set_Direct_Primitive_Operations (Derived_Type, New_Elmt_List); -- All tagged types defined in Ada.Finalization are controlled @@ -8237,7 +8238,8 @@ package body Sem_Ch3 is Set_Corresponding_Record_Type (Def_Id, Corresponding_Record_Type (T)); else - Set_Primitive_Operations (Def_Id, Primitive_Operations (T)); + Set_Direct_Primitive_Operations (Def_Id, + Direct_Primitive_Operations (T)); end if; Set_Is_Abstract_Type (Def_Id, Is_Abstract_Type (T)); @@ -9811,7 +9813,8 @@ package body Sem_Ch3 is if Is_Tagged_Type (Full_Base) then Set_Is_Tagged_Type (Full); - Set_Primitive_Operations (Full, Primitive_Operations (Full_Base)); + Set_Direct_Primitive_Operations (Full, + Direct_Primitive_Operations (Full_Base)); -- Inherit class_wide type of full_base in case the partial view was -- not tagged. Otherwise it has already been created when the private @@ -11552,7 +11555,8 @@ package body Sem_Ch3 is Conditional_Delay (Full, Priv); if Is_Tagged_Type (Full) then - Set_Primitive_Operations (Full, Primitive_Operations (Priv)); + Set_Direct_Primitive_Operations (Full, + Direct_Primitive_Operations (Priv)); if Priv = Base_Type (Priv) then Set_Class_Wide_Type (Full, Class_Wide_Type (Priv)); @@ -13529,8 +13533,10 @@ package body Sem_Ch3 is Set_Etype (T, Any_Type); Set_Scalar_Range (T, Scalar_Range (Any_Type)); - if Is_Tagged_Type (T) then - Set_Primitive_Operations (T, New_Elmt_List); + if Is_Tagged_Type (T) + and then Is_Record_Type (T) + then + Set_Direct_Primitive_Operations (T, New_Elmt_List); end if; return; @@ -14290,7 +14296,6 @@ package body Sem_Ch3 is if not Tagged_Present (Type_Definition (N)) then Tag_Mismatch; Set_Is_Tagged_Type (Id); - Set_Primitive_Operations (Id, New_Elmt_List); end if; elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition then @@ -14302,7 +14307,6 @@ package body Sem_Ch3 is -- Set some attributes to produce a usable full view Set_Is_Tagged_Type (Id); - Set_Primitive_Operations (Id, New_Elmt_List); end if; else @@ -15421,12 +15425,12 @@ package body Sem_Ch3 is -- Customize the class-wide type: It has no prim. op., it cannot be -- abstract and its Etype points back to the specific root type. - Set_Ekind (CW_Type, E_Class_Wide_Type); - Set_Is_Tagged_Type (CW_Type, True); - Set_Primitive_Operations (CW_Type, New_Elmt_List); - Set_Is_Abstract_Type (CW_Type, False); - Set_Is_Constrained (CW_Type, False); - Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T)); + Set_Ekind (CW_Type, E_Class_Wide_Type); + Set_Is_Tagged_Type (CW_Type, True); + Set_Direct_Primitive_Operations (CW_Type, New_Elmt_List); + Set_Is_Abstract_Type (CW_Type, False); + Set_Is_Constrained (CW_Type, False); + Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T)); if Ekind (T) = E_Class_Wide_Subtype then Set_Etype (CW_Type, Etype (Base_Type (T))); @@ -16990,7 +16994,7 @@ package body Sem_Ch3 is -- of the class-wide type which depend on the full declaration. if Is_Tagged_Type (Priv_T) then - Set_Primitive_Operations (Priv_T, Full_List); + Set_Direct_Primitive_Operations (Priv_T, Full_List); Set_Class_Wide_Type (Base_Type (Full_T), Class_Wide_Type (Priv_T)); @@ -18268,14 +18272,13 @@ package body Sem_Ch3 is end if; Make_Class_Wide_Type (T); - Set_Primitive_Operations (T, New_Elmt_List); + Set_Direct_Primitive_Operations (T, New_Elmt_List); end if; - -- We must suppress range checks when processing the components - -- of a record in the presence of discriminants, since we don't - -- want spurious checks to be generated during their analysis, but - -- must reset the Suppress_Range_Checks flags after having processed - -- the record definition. + -- We must suppress range checks when processing record components in + -- the presence of discriminants, since we don't want spurious checks to + -- be generated during their analysis, but Suppress_Range_Checks flags + -- must be reset the after processing the record definition. -- Note: this is the only use of Kill_Range_Checks, and is a bit odd, -- couldn't we just use the normal range check suppression method here. diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index ae14084..08d68bf 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -1956,11 +1956,11 @@ package body Sem_Ch7 is Set_Private_Dependents (Id, New_Elmt_List); if Tagged_Present (Def) then - Set_Ekind (Id, E_Record_Type_With_Private); - Set_Primitive_Operations (Id, New_Elmt_List); - Set_Is_Abstract_Type (Id, Abstract_Present (Def)); - Set_Is_Limited_Record (Id, Limited_Present (Def)); - Set_Has_Delayed_Freeze (Id, True); + Set_Ekind (Id, E_Record_Type_With_Private); + Set_Direct_Primitive_Operations (Id, New_Elmt_List); + Set_Is_Abstract_Type (Id, Abstract_Present (Def)); + Set_Is_Limited_Record (Id, Limited_Present (Def)); + Set_Has_Delayed_Freeze (Id, True); -- Create a class-wide type with the same attributes diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index d45ebda..e891e70 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -5707,7 +5707,7 @@ package body Sem_Ch8 is end if; Set_Is_Tagged_Type (T); - Set_Primitive_Operations (T, New_Elmt_List); + Set_Direct_Primitive_Operations (T, New_Elmt_List); Make_Class_Wide_Type (T); Set_Entity (N, Class_Wide_Type (T)); Set_Etype (N, Class_Wide_Type (T)); -- cgit v1.1