diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/debug.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/exp_put_image.adb | 286 | ||||
| -rw-r--r-- | gcc/ada/freeze.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/rtsfind.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 54 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 50 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.ads | 5 | ||||
| -rw-r--r-- | gcc/ada/sem_disp.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 143 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 25 |
11 files changed, 425 insertions, 154 deletions
diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 3f1fa55..978f333 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -164,7 +164,7 @@ package body Debug is -- d_w -- d_x Disable inline expansion of Image attribute for enumeration types -- d_y - -- d_z Enable Put_Image on tagged types + -- d_z -- d_A Stop generation of ALI file -- d_B Warn on build-in-place function calls @@ -993,9 +993,6 @@ package body Debug is -- d_x The compiler does not expand in line the Image attribute for user- -- defined enumeration types and the standard boolean type. - -- d_z Enable the default Put_Image on tagged types that are not - -- predefined. - -- d_A Do not generate ALI files by setting Opt.Disable_ALI_File. -- d_B Warn on build-in-place function calls. This allows users to diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 4dbaadd..ce6d294 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -10345,9 +10345,7 @@ package body Exp_Ch3 is -- Spec of Put_Image - if Enable_Put_Image (Tag_Typ) - and then No (TSS (Tag_Typ, TSS_Put_Image)) - then + if Enable_Put_Image (Tag_Typ) then Append_To (Res, Predef_Spec_Or_Body (Loc, Tag_Typ => Tag_Typ, Name => Make_TSS_Name (Tag_Typ, TSS_Put_Image), diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb index 33c72c3..3a9751b 100644 --- a/gcc/ada/exp_put_image.adb +++ b/gcc/ada/exp_put_image.adb @@ -23,13 +23,14 @@ -- -- ------------------------------------------------------------------------------ +with Aspects; use Aspects; with Atree; use Atree; +with Csets; use Csets; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; with Exp_Tss; use Exp_Tss; -with Exp_Util; -with Debug; use Debug; +with Exp_Util; use Exp_Util; with Lib; use Lib; with Namet; use Namet; with Nlists; use Nlists; @@ -49,9 +50,6 @@ with Uintp; use Uintp; package body Exp_Put_Image is - Tagged_Put_Image_Enabled : Boolean renames Debug_Flag_Underscore_Z; - -- ???Set True to enable Put_Image for at least some tagged types - ----------------------- -- Local Subprograms -- ----------------------- @@ -649,32 +647,90 @@ package body Exp_Put_Image is -- Loop through components, skipping all internal components, -- which are not part of the value (e.g. _Tag), except that we -- don't skip the _Parent, since we do want to process that - -- recursively. If _Parent is an interface type, being abstract - -- with no components there is no need to handle it. + -- recursively. while Present (Item) loop if Nkind (Item) in N_Component_Declaration | N_Discriminant_Specification - and then - ((Chars (Defining_Identifier (Item)) = Name_uParent - and then not Is_Interface - (Etype (Defining_Identifier (Item)))) - or else - not Is_Internal_Name (Chars (Defining_Identifier (Item)))) then - if First_Time then - First_Time := False; - else - Append_To (Result, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Record_Between), Loc), - Parameter_Associations => New_List - (Make_Identifier (Loc, Name_S)))); + if Chars (Defining_Identifier (Item)) = Name_uParent then + declare + Parent_Type : constant Entity_Id := + Underlying_Type (Base_Type ( + (Etype (Defining_Identifier (Item))))); + + Parent_Aspect_Spec : constant Node_Id := + Find_Aspect (Parent_Type, Aspect_Put_Image); + + Parent_Type_Decl : constant Node_Id := + Declaration_Node (Parent_Type); + + Parent_Rdef : Node_Id := + Type_Definition (Parent_Type_Decl); + begin + -- If parent type has an noninherited + -- explicitly-specified Put_Image aspect spec, then + -- display parent part by calling specified procedure, + -- and then use extension-aggregate syntax for the + -- remaining components as per RM 4.10(15/5); + -- otherwise, "look through" the parent component + -- to its components - we don't want the image text + -- to include mention of an "_parent" component. + + if Present (Parent_Aspect_Spec) and then + Entity (Parent_Aspect_Spec) = Parent_Type + then + Append_Component_Attr + (Result, Defining_Identifier (Item)); + + -- Omit the " with " if no subsequent components. + + if not Is_Null_Extension_Of + (Descendant => Typ, + Ancestor => Parent_Type) + then + Append_To (Result, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of + (RTE (RE_Put_UTF_8), Loc), + Parameter_Associations => New_List + (Make_Identifier (Loc, Name_S), + Make_String_Literal (Loc, " with ")))); + end if; + else + if Nkind (Parent_Rdef) = N_Derived_Type_Definition + then + Parent_Rdef := + Record_Extension_Part (Parent_Rdef); + end if; + + if Present (Component_List (Parent_Rdef)) then + Append_List_To (Result, + Make_Component_List_Attributes + (Component_List (Parent_Rdef))); + end if; + end if; + end; + + elsif not Is_Internal_Name + (Chars (Defining_Identifier (Item))) + then + if First_Time then + First_Time := False; + else + Append_To (Result, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Record_Between), Loc), + Parameter_Associations => New_List + (Make_Identifier (Loc, Name_S)))); + end if; + + Append_To (Result, Make_Component_Name (Item)); + Append_Component_Attr + (Result, Defining_Identifier (Item)); end if; - - Append_To (Result, Make_Component_Name (Item)); - Append_Component_Attr (Result, Defining_Identifier (Item)); end if; Next (Item); @@ -690,13 +746,35 @@ package body Exp_Put_Image is function Make_Component_Name (C : Entity_Id) return Node_Id is Name : constant Name_Id := Chars (Defining_Identifier (C)); + pragma Assert (Name /= Name_uParent); + + function To_Upper (S : String) return String; + -- Same as Ada.Characters.Handling.To_Upper, but withing + -- Ada.Characters.Handling seems to cause mailserver problems. + + -------------- + -- To_Upper -- + -------------- + + function To_Upper (S : String) return String is + begin + return Result : String := S do + for Char of Result loop + Char := Fold_Upper (Char); + end loop; + end return; + end To_Upper; + + -- Start of processing for Make_Component_Name + begin return Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Put_UTF_8), Loc), Parameter_Associations => New_List (Make_Identifier (Loc, Name_S), - Make_String_Literal (Loc, Get_Name_String (Name) & " => "))); + Make_String_Literal (Loc, + To_Upper (Get_Name_String (Name)) & " => "))); end Make_Component_Name; Stms : constant List_Id := New_List; @@ -707,38 +785,47 @@ package body Exp_Put_Image is -- Start of processing for Build_Record_Put_Image_Procedure begin - Append_To (Stms, - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Record_Before), Loc), - Parameter_Associations => New_List - (Make_Identifier (Loc, Name_S)))); + if Is_Null_Record_Type (Btyp, Ignore_Privacy => True) then + Append_To (Stms, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Put_UTF_8), Loc), + Parameter_Associations => New_List + (Make_Identifier (Loc, Name_S), + Make_String_Literal (Loc, "(NULL RECORD)")))); + else + Append_To (Stms, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Record_Before), Loc), + Parameter_Associations => New_List + (Make_Identifier (Loc, Name_S)))); - -- Generate Put_Images for the discriminants of the type + -- Generate Put_Images for the discriminants of the type - Append_List_To (Stms, - Make_Component_Attributes (Discriminant_Specifications (Type_Decl))); + Append_List_To (Stms, + Make_Component_Attributes + (Discriminant_Specifications (Type_Decl))); - Rdef := Type_Definition (Type_Decl); + Rdef := Type_Definition (Type_Decl); - -- In the record extension case, the components we want, including the - -- _Parent component representing the parent type, are to be found in - -- the extension. We will process the _Parent component using the type - -- of the parent. + -- In the record extension case, the components we want are to be + -- found in the extension (although we have to process the + -- _Parent component to find inherited components). - if Nkind (Rdef) = N_Derived_Type_Definition then - Rdef := Record_Extension_Part (Rdef); - end if; + if Nkind (Rdef) = N_Derived_Type_Definition then + Rdef := Record_Extension_Part (Rdef); + end if; - if Present (Component_List (Rdef)) then - Append_List_To (Stms, - Make_Component_List_Attributes (Component_List (Rdef))); - end if; + if Present (Component_List (Rdef)) then + Append_List_To (Stms, + Make_Component_List_Attributes (Component_List (Rdef))); + end if; - Append_To (Stms, - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Record_After), Loc), - Parameter_Associations => New_List - (Make_Identifier (Loc, Name_S)))); + Append_To (Stms, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Record_After), Loc), + Parameter_Associations => New_List + (Make_Identifier (Loc, Name_S)))); + end if; Pnam := Make_Put_Image_Name (Loc, Btyp); Build_Put_Image_Proc (Loc, Btyp, Decl, Pnam, Stms); @@ -843,9 +930,9 @@ package body Exp_Put_Image is -- -- Put_Image on tagged types triggers some bugs. - if Is_Remote_Types (Scope (Typ)) + if Ada_Version < Ada_2022 + or else Is_Remote_Types (Scope (Typ)) or else (Is_Tagged_Type (Typ) and then In_Predefined_Unit (Typ)) - or else (Is_Tagged_Type (Typ) and then not Tagged_Put_Image_Enabled) then return False; end if; @@ -952,7 +1039,7 @@ package body Exp_Put_Image is -- For T'Image (X) Generate an Expression_With_Actions node: -- -- do - -- S : Buffer := New_Buffer; + -- S : Buffer; -- U_Type'Put_Image (S, X); -- Result : constant String := Get (S); -- Destroy (S); @@ -970,13 +1057,16 @@ package body Exp_Put_Image is Object_Definition => New_Occurrence_Of (RTE (RE_Buffer_Type), Loc)); + Image_Prefix : constant Node_Id := + Duplicate_Subexpr (First (Expressions (N))); + Put_Im : constant Node_Id := Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (U_Type, Loc), Attribute_Name => Name_Put_Image, Expressions => New_List ( New_Occurrence_Of (Sink_Entity, Loc), - New_Copy_Tree (First (Expressions (N))))); + Image_Prefix)); Result_Entity : constant Entity_Id := Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('R')); Result_Decl : constant Node_Id := @@ -989,12 +1079,86 @@ package body Exp_Put_Image is Name => New_Occurrence_Of (RTE (RE_Get), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (Sink_Entity, Loc)))); - Image : constant Node_Id := - Make_Expression_With_Actions (Loc, - Actions => New_List (Sink_Decl, Put_Im, Result_Decl), - Expression => New_Occurrence_Of (Result_Entity, Loc)); + Actions : List_Id; + + function Put_String_Exp (String_Exp : Node_Id; + Wide_Wide : Boolean := False) return Node_Id; + -- Generate a call to evaluate a String (or Wide_Wide_String, depending + -- on the Wide_Wide Boolean parameter) expression and output it into + -- the buffer. + + -------------------- + -- Put_String_Exp -- + -------------------- + + function Put_String_Exp (String_Exp : Node_Id; + Wide_Wide : Boolean := False) return Node_Id is + Put_Id : constant RE_Id := + (if Wide_Wide then RE_Wide_Wide_Put else RE_Put_UTF_8); + + -- We could build a nondispatching call here, but to make + -- that work we'd have to change Rtsfind spec to make available + -- corresponding callees out of Ada.Strings.Text_Buffers.Unbounded + -- (as opposed to from Ada.Strings.Text_Buffers). Seems simpler to + -- introduce a type conversion and leave it to the optimizer to + -- eliminate the dispatching. This does not *introduce* any problems + -- if a no-dispatching-allowed restriction is in effect, since we + -- are already in the middle of generating a call to T'Class'Image. + + Sink_Exp : constant Node_Id := + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of + (Class_Wide_Type (RTE (RE_Root_Buffer_Type)), Loc), + Expression => New_Occurrence_Of (Sink_Entity, Loc)); + begin + return + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (Put_Id), Loc), + Parameter_Associations => New_List (Sink_Exp, String_Exp)); + end Put_String_Exp; + + -- Start of processing for Build_Image_Call + begin - return Image; + if Is_Class_Wide_Type (U_Type) then + -- Generate qualified-expression syntax; qualification name comes + -- from calling Ada.Tags.Wide_Wide_Expanded_Name. + + declare + -- The copy of Image_Prefix will be evaluated before the + -- original, which is ok if no side effects are involved. + + pragma Assert (Side_Effect_Free (Image_Prefix)); + + Specific_Type_Name : constant Node_Id := + Put_String_Exp + (Make_Function_Call (Loc, + Name => New_Occurrence_Of + (RTE (RE_Wide_Wide_Expanded_Name), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr (Image_Prefix), + Attribute_Name => Name_Tag))), + Wide_Wide => True); + + Qualification : constant Node_Id := + Put_String_Exp (Make_String_Literal (Loc, "'")); + begin + Actions := New_List + (Sink_Decl, + Specific_Type_Name, + Qualification, + Put_Im, + Result_Decl); + end; + else + Actions := New_List (Sink_Decl, Put_Im, Result_Decl); + end if; + + return Make_Expression_With_Actions (Loc, + Actions => Actions, + Expression => New_Occurrence_Of (Result_Entity, Loc)); end Build_Image_Call; ------------------------------ @@ -1023,7 +1187,7 @@ package body Exp_Put_Image is -- Don't do it if type Root_Buffer_Type is unavailable in the runtime. if not In_Predefined_Unit (Compilation_Unit) - and then Tagged_Put_Image_Enabled + and then Ada_Version >= Ada_2022 and then Tagged_Seen and then not No_Run_Time_Mode and then RTE_Available (RE_Root_Buffer_Type) diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 21d24cd..fa16887 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -7591,6 +7591,7 @@ package body Freeze is or else Is_TSS (Id, TSS_Stream_Output) or else Is_TSS (Id, TSS_Stream_Read) or else Is_TSS (Id, TSS_Stream_Write) + or else Is_TSS (Id, TSS_Put_Image) or else Nkind (Original_Node (P)) = N_Subprogram_Renaming_Declaration) then diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index ad84e9e..6bec611 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -708,6 +708,7 @@ package Rtsfind is RE_TK_Tagged, -- Ada.Tags RE_TK_Task, -- Ada.Tags RE_Unregister_Tag, -- Ada.Tags + RE_Wide_Wide_Expanded_Name, -- Ada.Tags RE_Set_Specific_Handler, -- Ada.Task_Termination RE_Specific_Handler, -- Ada.Task_Termination @@ -2389,6 +2390,7 @@ package Rtsfind is RE_TK_Tagged => Ada_Tags, RE_TK_Task => Ada_Tags, RE_Unregister_Tag => Ada_Tags, + RE_Wide_Wide_Expanded_Name => Ada_Tags, RE_Set_Specific_Handler => Ada_Task_Termination, RE_Specific_Handler => Ada_Task_Termination, diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index dcd5954..83d7d3c 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -5230,44 +5230,64 @@ package body Sem_Ch13 is F := First_Formal (Subp); - if No (F) - or else Etype (F) /= Class_Wide_Type (RTE (RE_Root_Buffer_Type)) + if No (F) then + return False; + end if; + + if Base_Type (Etype (F)) + /= Class_Wide_Type (RTE (RE_Root_Buffer_Type)) then + if Report then + Error_Msg_N + ("wrong type for Put_Image procedure''s first parameter", + Parameter_Type (Parent (F))); + end if; + return False; end if; - Next_Formal (F); + if Parameter_Mode (F) /= E_In_Out_Parameter then + if Report then + Error_Msg_N + ("wrong mode for Put_Image procedure''s first parameter", + Parent (F)); + end if; - if Parameter_Mode (F) /= E_In_Parameter then return False; end if; + Next_Formal (F); + Typ := Etype (F); -- Verify that the prefix of the attribute and the local name for -- the type of the formal match. - if Typ /= Ent then - return False; - end if; + if Base_Type (Typ) /= Base_Type (Ent) then + if Report then + Error_Msg_N + ("wrong type for Put_Image procedure''s second parameter", + Parameter_Type (Parent (F))); + end if; - if Present (Next_Formal (F)) then return False; + end if; - elsif not Is_Scalar_Type (Typ) - and then not Is_First_Subtype (Typ) - then - if Report and not Is_First_Subtype (Typ) then + if Parameter_Mode (F) /= E_In_Parameter then + if Report then Error_Msg_N - ("subtype of formal in Put_Image operation must be a " - & "first subtype", Parameter_Type (Parent (F))); + ("wrong mode for Put_Image procedure''s second parameter", + Parent (F)); end if; return False; + end if; - else - return True; + if Present (Next_Formal (F)) then + return False; end if; + + return True; end Has_Good_Profile; -- Start of processing for Analyze_Put_Image_TSS_Definition @@ -5386,7 +5406,7 @@ package body Sem_Ch13 is if No (F) or else Ekind (Etype (F)) /= E_Anonymous_Access_Type - or else Designated_Type (Etype (F)) /= + or else Base_Type (Designated_Type (Etype (F))) /= Class_Wide_Type (RTE (RE_Root_Stream_Type)) then return False; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 7a24298..4250483 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -19013,56 +19013,6 @@ package body Sem_Ch3 is return False; end Is_EVF_Procedure; - ----------------------- - -- Is_Null_Extension -- - ----------------------- - - function Is_Null_Extension (T : Entity_Id) return Boolean is - Type_Decl : constant Node_Id := Parent (Base_Type (T)); - Comp_List : Node_Id; - Comp : Node_Id; - - begin - if Nkind (Type_Decl) /= N_Full_Type_Declaration - or else not Is_Tagged_Type (T) - or else Nkind (Type_Definition (Type_Decl)) /= - N_Derived_Type_Definition - or else No (Record_Extension_Part (Type_Definition (Type_Decl))) - then - return False; - end if; - - Comp_List := - Component_List (Record_Extension_Part (Type_Definition (Type_Decl))); - - if Present (Discriminant_Specifications (Type_Decl)) then - return False; - - elsif Present (Comp_List) - and then Is_Non_Empty_List (Component_Items (Comp_List)) - then - Comp := First (Component_Items (Comp_List)); - - -- Only user-defined components are relevant. The component list - -- may also contain a parent component and internal components - -- corresponding to secondary tags, but these do not determine - -- whether this is a null extension. - - while Present (Comp) loop - if Comes_From_Source (Comp) then - return False; - end if; - - Next (Comp); - end loop; - - return True; - - else - return True; - end if; - end Is_Null_Extension; - -------------------------- -- Is_Private_Primitive -- -------------------------- diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads index dcd4a34..eedb98c 100644 --- a/gcc/ada/sem_ch3.ads +++ b/gcc/ada/sem_ch3.ads @@ -176,11 +176,6 @@ package Sem_Ch3 is -- corresponding to that discriminant in the constraint that specifies its -- value. - function Is_Null_Extension (T : Entity_Id) return Boolean; - -- Returns True if the tagged type T has an N_Full_Type_Declaration that - -- is a null extension, meaning that it has an extension part without any - -- components and does not have a known discriminant part. - function Is_Visible_Component (C : Entity_Id; N : Node_Id := Empty) return Boolean; diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 15b700fa..06c4b07 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -45,7 +45,6 @@ with Restrict; use Restrict; with Rident; use Rident; with Sem; use Sem; with Sem_Aux; use Sem_Aux; -with Sem_Ch3; use Sem_Ch3; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Eval; use Sem_Eval; @@ -1209,7 +1208,7 @@ package body Sem_Disp is -- primitives. -- 3. Subprograms associated with stream attributes (built by - -- New_Stream_Subprogram) + -- New_Stream_Subprogram) or with the Put_Image attribute. -- 4. Wrappers built for inherited operations with inherited class- -- wide conditions, where the conditions include calls to other @@ -1238,6 +1237,7 @@ package body Sem_Disp is or else Get_TSS_Name (Subp) = TSS_Stream_Read or else Get_TSS_Name (Subp) = TSS_Stream_Write + or else Get_TSS_Name (Subp) = TSS_Put_Image or else (Is_Wrapper (Subp) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index c0bc4b7..e5b76f3 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -712,7 +712,7 @@ package body Sem_Util is return Make_Level_Literal (Type_Access_Level (Etype (E))); - -- A non-discriminant selected component where the component + -- A nondiscriminant selected component where the component -- is an anonymous access type means that its associated -- level is that of the containing type - see RM 3.10.2 (16). @@ -18576,18 +18576,143 @@ package body Sem_Util is return False; end Is_Nontrivial_DIC_Procedure; + ----------------------- + -- Is_Null_Extension -- + ----------------------- + + function Is_Null_Extension + (T : Entity_Id; Ignore_Privacy : Boolean := False) return Boolean + is + Type_Decl : Node_Id; + Type_Def : Node_Id; + begin + if Ignore_Privacy then + Type_Decl := Parent (Underlying_Type (Base_Type (T))); + else + Type_Decl := Parent (Base_Type (T)); + if Nkind (Type_Decl) /= N_Full_Type_Declaration then + return False; + end if; + end if; + pragma Assert (Nkind (Type_Decl) = N_Full_Type_Declaration); + Type_Def := Type_Definition (Type_Decl); + if Present (Discriminant_Specifications (Type_Decl)) + or else Nkind (Type_Def) /= N_Derived_Type_Definition + or else not Is_Tagged_Type (T) + or else No (Record_Extension_Part (Type_Def)) + then + return False; + end if; + + return Is_Null_Record_Definition (Record_Extension_Part (Type_Def)); + end Is_Null_Extension; + + -------------------------- + -- Is_Null_Extension_Of -- + -------------------------- + + function Is_Null_Extension_Of + (Descendant, Ancestor : Entity_Id) return Boolean + is + Ancestor_Type : constant Entity_Id + := Underlying_Type (Base_Type (Ancestor)); + Descendant_Type : Entity_Id := Underlying_Type (Base_Type (Descendant)); + begin + pragma Assert (Descendant_Type /= Ancestor_Type); + while Descendant_Type /= Ancestor_Type loop + if not Is_Null_Extension + (Descendant_Type, Ignore_Privacy => True) + then + return False; + end if; + Descendant_Type := Etype (Subtype_Indication + (Type_Definition (Parent (Descendant_Type)))); + Descendant_Type := Underlying_Type (Base_Type (Descendant_Type)); + end loop; + return True; + end Is_Null_Extension_Of; + + ------------------------------- + -- Is_Null_Record_Definition -- + ------------------------------- + + function Is_Null_Record_Definition (Record_Def : Node_Id) return Boolean is + Item : Node_Id; + begin + -- Testing Null_Present is just an optimization, not required. + + if Null_Present (Record_Def) then + return True; + elsif Present (Variant_Part (Component_List (Record_Def))) then + return False; + elsif not Present (Component_List (Record_Def)) then + return True; + end if; + + Item := First (Component_Items (Component_List (Record_Def))); + + while Present (Item) loop + if Nkind (Item) = N_Component_Declaration + and then Is_Internal_Name (Chars (Defining_Identifier (Item))) + then + null; + elsif Nkind (Item) = N_Pragma then + null; + else + return False; + end if; + Item := Next (Item); + end loop; + + return True; + end Is_Null_Record_Definition; + ------------------------- -- Is_Null_Record_Type -- ------------------------- - function Is_Null_Record_Type (T : Entity_Id) return Boolean is - Decl : constant Node_Id := Parent (T); + function Is_Null_Record_Type + (T : Entity_Id; Ignore_Privacy : Boolean := False) return Boolean + is + Decl : Node_Id; + Type_Def : Node_Id; begin - return Nkind (Decl) = N_Full_Type_Declaration - and then Nkind (Type_Definition (Decl)) = N_Record_Definition - and then - (No (Component_List (Type_Definition (Decl))) - or else Null_Present (Component_List (Type_Definition (Decl)))); + if not Is_Record_Type (T) then + return False; + end if; + + if Ignore_Privacy then + Decl := Parent (Underlying_Type (Base_Type (T))); + else + Decl := Parent (Base_Type (T)); + if Nkind (Decl) /= N_Full_Type_Declaration then + return False; + end if; + end if; + pragma Assert (Nkind (Decl) = N_Full_Type_Declaration); + Type_Def := Type_Definition (Decl); + + if Has_Discriminants (Defining_Identifier (Decl)) then + return False; + end if; + + case Nkind (Type_Def) is + when N_Record_Definition => + return Is_Null_Record_Definition (Type_Def); + when N_Derived_Type_Definition => + if not Is_Null_Record_Type + (Etype (Subtype_Indication (Type_Def)), + Ignore_Privacy => Ignore_Privacy) + then + return False; + elsif not Is_Tagged_Type (T) then + return True; + else + return Is_Null_Extension (T, Ignore_Privacy => Ignore_Privacy); + end if; + when others => + return False; + end case; end Is_Null_Record_Type; --------------------- @@ -19183,7 +19308,7 @@ package body Sem_Util is elsif Is_Tagged_Type (Typ) then return True; - -- Case of non-discriminated record + -- Case of nondiscriminated record else declare diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 10f1ba5..0894d03 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -2126,9 +2126,28 @@ package Sem_Util is -- assertion expression of pragma Default_Initial_Condition and if it does, -- the encapsulated expression is nontrivial. - function Is_Null_Record_Type (T : Entity_Id) return Boolean; - -- Determine whether T is declared with a null record definition or a - -- null component list. + function Is_Null_Extension + (T : Entity_Id; Ignore_Privacy : Boolean := False) return Boolean; + -- Given a tagged type, returns True if argument is a type extension + -- that introduces no new components (discriminant or nondiscriminant). + -- Ignore_Privacy should be True for use in implementing dynamic semantics. + + function Is_Null_Extension_Of + (Descendant, Ancestor : Entity_Id) return Boolean; + -- Given two tagged types, the first a descendant of the second, + -- returns True if every component of Descendant is inherited + -- (directly or indirectly) from Ancestor. Privacy is ignored. + + function Is_Null_Record_Definition (Record_Def : Node_Id) return Boolean; + -- Returns True for an N_Record_Definition node that has no user-defined + -- components (and no variant part). + + function Is_Null_Record_Type + (T : Entity_Id; Ignore_Privacy : Boolean := False) return Boolean; + -- Determine whether T is declared with a null record definition, a + -- null component list, or as a type derived from a null record type + -- (with a null extension if tagged). Returns True for interface types, + -- False for discriminated types. function Is_Object_Image (Prefix : Node_Id) return Boolean; -- Returns True if an 'Img, 'Image, 'Wide_Image, or 'Wide_Wide_Image |