From: Denis Mazzucato Date: Thu, 25 Sep 2025 09:31:46 +0000 (+0200) Subject: ada: Direct attribute definition for constructors X-Git-Url: http://git.ipfire.org/gitweb.cgi?a=commitdiff_plain;h=f5836f73b1021990e1ae448092cf6dc294eb7684;p=thirdparty%2Fgcc.git ada: Direct attribute definition for constructors This patch introduces the 'Constructor attribute and implements its direct attribute definition syntax within subprogram specification. This new shorthand avoids having to come up with an arbitrary subprogram name and to type out the constructor aspect. Before, constructors where defined through the aspect Constructor, which has been removed. Furthermore, this patch prepares for the expansion of direct attribute definitions to other attributes. gcc/ada/ChangeLog: * errout.adb (Set_Msg_Node): Support N_Attribute_Reference and nodes that denotes direct attribute definitions. * exp_dbug.ads: Description for the encoding of direct attribute definitions as tick are hard to deal in entity names. * erroutc.adb (Set_Msg_Insertion_Name): Replace underscore between prefix and attribute name in direct attribute definitions; at this point we lost the semantic information of node type and we resort to match the string name as described in exp_dbug.adb. * exp_aggr.adb (Convert_To_Positional): Use Needs_Construction and Has_Default_Constructor. * exp_ch3.adb (Build_Record_Init_Proc) (Expand_N_Object_Declaration): Likewise. * exp_attr.adb (Expand_N_Attribute_Reference): Likewise. * exp_ch4.adb (Expand_N_Allocator): Likewise. * exp_ch6.adb (Prepend_Constructor_Procedure_Prologue): Use Is_Constructor_Procedure. (Make_Parent_Constructor_Call): Use Direct_Attribute_Definition_Name. * gen_il-fields.ads: Remove Constructor_List and Constructor_Name. * gen_il-gen-gen_entities.adb: Likewise. * einfo.ads (Needs_Construction): Add description. (Has_Delayed_Aspects): Adjust indentation. * par-ch13.adb (P_Attribute_Designators): Parse attribute designators. (P_Representation_Clause): Use P_Attribute_Designators. * par-ch6.adb (P_Subprogram): Support attribute designators in subprogram name. (Rewrites_Entity_If_Direct_Attribute_Def): Fix the specification node in case of direct attribute definitions. * par-endh.adb (Check_End, Same_Label): Likewise. * par.adb (P_Attribute_Designators): Specification. * sem_attr.adb (Analyze_Attribute): Error when using 'Constructor outside procedure specification. (Analyze_Attribute): Add error handling code. * sem_ch3.adb (Analyze_Aspect_Specifications): Likewise. * sem_ch6.adb (Analyze_Direct_Attribute_Definition): Handle direct attribute definitions. Add error handling code for the 'Construction attribute and set constructor flags when necessary. (Analyze_Subprogram_Specification): Use Analyze_Direct_Attribute_Definition. * sem_util.adb (Direct_Attribute_Definition_Name): Name of entities created for direct attribute definitions. We emit an error if multiple attributes. (Is_Direct_Attribute_Subp_Spec): Helper to check whether a subprogram specification is a direct attribute definition. (Is_Constructor_Procedure): Helper to check whether a subprogram is a constructor procedure. (Has_Default_Constructor): Check whether the default constructor exists. (Default_Constructor): Not used anymore. (Parameter_Count): Likewise. (Process_End_Label): Get_Attribute_Reference_Name_String encodes also direct attribute definition end labels. * sem_util.ads: Likewise. * snames.ads-tmpl: Support for 'Constructor attribute. * snames.adb-tmpl (Is_Direct_Attribute_Definition_Name): Helper to check attributes allowed in direct attribute definitions. * aspects.ads: Remove constructor aspect. * sem_ch13.adb: Likewise. --- diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index ab87f54f20a..5d242ed0b1c 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -81,7 +81,6 @@ package Aspects is Aspect_Bit_Order, Aspect_Component_Size, Aspect_Constant_Indexing, - Aspect_Constructor, -- GNAT Aspect_Contract_Cases, -- GNAT Aspect_Convention, Aspect_CPU, @@ -440,7 +439,6 @@ package Aspects is Aspect_Bit_Order => Expression, Aspect_Component_Size => Expression, Aspect_Constant_Indexing => Name, - Aspect_Constructor => Name, Aspect_Contract_Cases => Expression, Aspect_Convention => Name, Aspect_CPU => Expression, @@ -547,7 +545,6 @@ package Aspects is Aspect_Component_Size => True, Aspect_Constant_Indexing => False, Aspect_Contract_Cases => False, - Aspect_Constructor => False, Aspect_Convention => True, Aspect_CPU => False, Aspect_Default_Component_Value => True, @@ -723,7 +720,6 @@ package Aspects is Aspect_Constant_After_Elaboration => Name_Constant_After_Elaboration, Aspect_Constant_Indexing => Name_Constant_Indexing, Aspect_Contract_Cases => Name_Contract_Cases, - Aspect_Constructor => Name_Constructor, Aspect_Convention => Name_Convention, Aspect_CPU => Name_CPU, Aspect_CUDA_Device => Name_CUDA_Device, @@ -997,7 +993,6 @@ package Aspects is Aspect_Asynchronous => Always_Delay, Aspect_Attach_Handler => Always_Delay, Aspect_Constant_Indexing => Always_Delay, - Aspect_Constructor => Always_Delay, Aspect_CPU => Always_Delay, Aspect_CUDA_Device => Always_Delay, Aspect_CUDA_Global => Always_Delay, diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index ab7552fb994..8e41d0f234d 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1585,11 +1585,11 @@ package Einfo is -- type derivation. -- Has_Delayed_Aspects --- Defined in all entities. Set if the Rep_Item chain for the entity has --- one or more N_Aspect_Definition nodes chained which are not to be --- evaluated till the freeze point. The aspect definition expression --- clause has been preanalyzed to get visibility at the point of use, --- but no other action has been taken. +-- Defined in all entities. Set if the Rep_Item chain for the entity has +-- one or more N_Aspect_Definition nodes chained which are not to be +-- evaluated till the freeze point. The aspect definition expression +-- clause has been preanalyzed to get visibility at the point of use, +-- but no other action has been taken. -- Has_Delayed_Freeze -- Defined in all entities. Set to indicate that an explicit freeze @@ -3706,6 +3706,11 @@ package Einfo is -- preelaborable initialization at freeze time (this has to be deferred -- to the freeze point because of the rule about overriding Initialize). +-- Needs_Construction +-- Defined in all type and subtype entities. Set only for record type +-- entities for which at least one ancestor has specified a constructor +-- through the 'Constructor direct attribute definition. + -- Needs_Debug_Info -- Defined in all entities. Set if the entity requires normal debugging -- information to be generated. This is true of all entities that have @@ -5130,6 +5135,7 @@ package Einfo is -- May_Inherit_Delayed_Rep_Aspects -- Must_Be_On_Byte_Boundary -- Must_Have_Preelab_Init + -- Needs_Construction -- Optimize_Alignment_Space -- Optimize_Alignment_Time -- Partial_View_Has_Unknown_Discr diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 472fbbe6cb2..220523c1690 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -163,8 +163,8 @@ package body Errout is procedure Set_Msg_Node (Node : Node_Id); -- Add the sequence of characters for the name associated with the given -- node to the current message. For N_Designator, N_Selected_Component, - -- N_Defining_Program_Unit_Name, and N_Expanded_Name, the Prefix is - -- included as well. + -- N_Defining_Program_Unit_Name, N_Expanded_Name, and N_Attribute_Reference + -- the Prefix is included as well. procedure Set_Posted (N : Node_Id); -- Sets the Error_Posted flag on the given node, and all its parents that @@ -3800,6 +3800,29 @@ package body Errout is Set_Msg_Node (Selector_Name (Node)); return; + when N_Attribute_Reference => + Set_Msg_Node (Prefix (Node)); + Set_Msg_Char ('''); + Get_Unqualified_Decoded_Name_String (Attribute_Name (Node)); + Adjust_Name_Case (Global_Name_Buffer, Sloc (Node)); + Set_Msg_Name_Buffer; + return; + + when N_Defining_Identifier => + + -- Handle direct attribute definitions + + if Parent_Kind (Node) in N_Subprogram_Specification + and then Original_Node (Parent (Node)) /= Parent (Node) + and then Nkind (Defining_Unit_Name + (Original_Node (Parent (Node)))) + = N_Attribute_Reference + then + Set_Msg_Node + (Defining_Unit_Name (Original_Node (Parent (Node)))); + return; + end if; + when others => null; end case; diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index 14a11ff925c..bbbe245cefd 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -1579,6 +1579,46 @@ package body Erroutc is ---------------------------- procedure Set_Msg_Insertion_Name is + procedure Replace_With_Attribute_Definition; + -- This procedure handles direct attribute definition names of the form: + -- 'D' Prefix_Name "_" Attribute_Name "_Att" + -- Specifically, it replace the current Namet.Global_Name_Buffer with an + -- all lowercase string of the prefix, and a tick attribute; at this + -- stage there is no way to recognize more than an ending attribute ??? + -- + -- Note that, at this point, it is not possible to restore the original + -- casing thus lowercase is default.a + + procedure Replace_With_Attribute_Definition is + First : constant Integer := 2; + Last : constant Integer := Name_Len - 4; + Att_Buf : Bounded_String (Max_Length => Name_Len - 7); + begin + Until_Tick : + for J in First .. Last loop + + -- J could be at the position separating the prefix from the + -- attribute name. + + if Name_Buffer (J) = '_' then + Att_Buf.Length := 0; + Append (Att_Buf, Name_Buffer (J + 1 .. Last)); + Set_Casing (Att_Buf, All_Lower_Case); + if Is_Direct_Attribute_Definition_Name (Name_Find (Att_Buf)) + then + Name_Buffer (J) := '''; + exit Until_Tick; + end if; + end if; + end loop Until_Tick; + + -- Remove prefix 'D' and suffix "_Att" + + Name_Buffer (1 .. Last - 1) := Name_Buffer (2 .. Last); + Name_Len := Last - 1; + Set_Casing (All_Lower_Case); + end Replace_With_Attribute_Definition; + begin if Error_Msg_Name_1 = No_Name then null; @@ -1624,7 +1664,14 @@ package body Erroutc is -- Else output with surrounding quotes in proper casing mode else - Set_Casing (Identifier_Casing (Flag_Source)); + if Name_Buffer (1) = 'D' + and then Name_Buffer (Name_Len - 3 .. Name_Len) = "_Att" + then + Replace_With_Attribute_Definition; + else + Set_Casing (Identifier_Casing (Flag_Source)); + end if; + Set_Msg_Quote; Set_Msg_Name_Buffer; Set_Msg_Quote; diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index d62b7351e86..6b6b0aba4b0 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -4914,11 +4914,10 @@ package body Exp_Aggr is -- IP procedure. if Has_Default_Init_Comps (N) - or else Present (Constructor_Name (Ctyp)) + or else Needs_Construction (Ctyp) or else (Is_Access_Type (Ctyp) - and then Present - (Constructor_Name - (Directly_Designated_Type (Ctyp)))) + and then Needs_Construction + (Directly_Designated_Type (Ctyp))) then return; end if; diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index a2b891b3307..41a7703e523 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -5165,7 +5165,8 @@ package body Exp_Attr is Make_Selected_Component (Loc, Prefix => New_Occurrence_Of (Result_Id, Loc), Selector_Name => Make_Identifier (Loc, - Chars (Constructor_Name (Typ)))); + Direct_Attribute_Definition_Name + (Typ, Name_Constructor))); begin Set_Is_Prefixed_Call (Proc_Name); @@ -8600,6 +8601,7 @@ package body Exp_Attr is | Attribute_Bit_Order | Attribute_Class | Attribute_Compiler_Version + | Attribute_Constructor | Attribute_Default_Bit_Order | Attribute_Default_Scalar_Storage_Order | Attribute_Definite diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 482084cdebc..db41ab75d3e 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -3185,8 +3185,8 @@ package body Exp_Ch3 is if Parent_Subtype_Renaming_Discrims then Append_List_To (Body_Stmts, Build_Init_Call_Thru (Parameters)); - elsif Present (Constructor_Name (Rec_Type)) then - if Present (Default_Constructor (Rec_Type)) then + elsif Needs_Construction (Rec_Type) then + if Has_Default_Constructor (Rec_Type) then -- The 'Make attribute reference (with no arguments) will -- generate a call to the one-parameter constructor procedure. @@ -3810,8 +3810,8 @@ package body Exp_Ch3 is -- Expand components with constructors to have the 'Make -- attribute. - elsif Present (Constructor_Name (Typ)) - and then Present (Default_Constructor (Typ)) + elsif Needs_Construction (Typ) + and then Has_Default_Constructor (Typ) then Set_Expression (Decl, Make_Attribute_Reference (Loc, @@ -4560,7 +4560,7 @@ package body Exp_Ch3 is -- since the call is generated, there had better be a routine -- at the other end of the call, even if it does nothing). - -- 10. The type has a specified Constructor aspect. + -- 10. The type needs construction with constructors. -- Note: the reason we exclude the CPP_Class case is because in this -- case the initialization is performed by the C++ constructors, and @@ -4577,7 +4577,7 @@ package body Exp_Ch3 is or else Is_Tagged_Type (Rec_Id) or else Is_Concurrent_Record_Type (Rec_Id) or else Has_Task (Rec_Id) - or else Present (Constructor_Name (Rec_Id)) + or else Needs_Construction (Rec_Id) then return True; end if; @@ -7587,8 +7587,8 @@ package body Exp_Ch3 is if No (Expr) and then Constant_Present (N) - and then (No (Constructor_Name (Typ)) - or else No (Default_Constructor (Typ))) + and then (not Needs_Construction (Typ) + or else not Has_Default_Constructor (Typ)) then return; end if; @@ -7619,8 +7619,8 @@ package body Exp_Ch3 is if Comes_From_Source (N) and then No (Expr) - and then Present (Constructor_Name (Typ)) - and then Present (Default_Constructor (Typ)) + and then Needs_Construction (Typ) + and then Has_Default_Constructor (Typ) then Expr := Make_Attribute_Reference (Loc, Attribute_Name => Name_Make, diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 8a6abfc4907..5971db3952a 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -4498,7 +4498,7 @@ package body Exp_Ch4 is -- Here we set no initialization on types with constructors since we -- generate initialization for the separately. - if Present (Constructor_Name (Directly_Designated_Type (PtrT))) + if Needs_Construction (Directly_Designated_Type (PtrT)) and then Nkind (Expression (N)) = N_Identifier then Set_No_Initialization (N, False); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index da09e9e36c2..d209ab09c1f 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -6250,9 +6250,9 @@ package body Exp_Ch6 is procedure Prepend_Constructor_Procedure_Prologue (Spec_Id : Entity_Id; Body_Id : Entity_Id; L : List_Id); -- If N is the body of a constructor procedure (that is, a procedure - -- named in a Constructor aspect specification for the type of the - -- procedure's first parameter), then prepend and analyze the - -- associated initialization code for that parameter. + -- named T'Constructor where T is the type of the procedure's first + -- parameter), then prepend and analyze the associated initialization + -- code for that parameter. -- This has nothing to do with CPP constructors. ---------------- @@ -6339,16 +6339,10 @@ package body Exp_Ch6 is function First_Param_Type return Entity_Id is (Implementation_Base_Type (Etype (First_Formal (Spec_Id)))); - Is_Constructor_Procedure : constant Boolean := - Nkind (Specification (N)) = N_Procedure_Specification - and then Present (First_Formal (Spec_Id)) - and then Present (Constructor_Name (First_Param_Type)) - and then Chars (Spec_Id) = Chars (Constructor_Name - (First_Param_Type)) - and then Ekind (First_Formal (Spec_Id)) = E_In_Out_Parameter - and then Scope (Spec_Id) = Scope (First_Param_Type); begin - if not Is_Constructor_Procedure then + if not (Nkind (Specification (N)) = N_Procedure_Specification + and then Is_Constructor_Procedure (Spec_Id)) + then return; -- the usual case end if; @@ -6539,7 +6533,8 @@ package body Exp_Ch6 is Attribute_Name => Name_Super), Selector_Name => Make_Identifier (Loc, - Chars (Constructor_Name (Parent_Type)))); + Direct_Attribute_Definition_Name + (Parent_Type, Name_Constructor))); begin Set_Is_Prefixed_Call (Proc_Name); diff --git a/gcc/ada/exp_dbug.ads b/gcc/ada/exp_dbug.ads index 1a64888cec2..0786c4040be 100644 --- a/gcc/ada/exp_dbug.ads +++ b/gcc/ada/exp_dbug.ads @@ -192,6 +192,25 @@ package Exp_Dbug is -- extra__messages__Oeq__2 + ---------------------------------- + -- Direct Attribute Definitions -- + ---------------------------------- + + -- Direct attribute definitions are subprogram declarations where the + -- subprogram name is an attribute reference, eg.: + -- procedure T'Constructor (Self... + -- defines a constructor. The above rules applied to direct attribute + -- definitions would result in names with quotation marks, which are + -- typically hard to deal with down the chain. To avoid this problem, + -- names of such definitions are encoded with as: + + -- 'D' Prefix_Name '_' Attribute_Name "_Att" + + -- For instance, the constructor above is encoded as Dt_constructor_Att. + + -- Note that, attribute reference with multiple attributes are not + -- supported yet ??? + ---------------------------------- -- Resolving Other Name Clashes -- ---------------------------------- diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads index a5ea239f1a1..d25006cb02d 100644 --- a/gcc/ada/gen_il-fields.ads +++ b/gcc/ada/gen_il-fields.ads @@ -474,8 +474,6 @@ package Gen_IL.Fields is Component_Clause, Component_Size, Component_Type, - Constructor_List, - Constructor_Name, Continue_Mark, Contract, Contract_Wrapper, diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb index 3d55a69f262..d3ac63a6256 100644 --- a/gcc/ada/gen_il-gen-gen_entities.adb +++ b/gcc/ada/gen_il-gen-gen_entities.adb @@ -455,8 +455,6 @@ begin -- Gen_IL.Gen.Gen_Entities Pre => "Ekind (Base_Type (N)) in Access_Subprogram_Kind"), Sm (Class_Wide_Equivalent_Type, Node_Id), Sm (Class_Wide_Type, Node_Id), - Sm (Constructor_List, Elist_Id), - Sm (Constructor_Name, Node_Id), Sm (Contract, Node_Id), Sm (Current_Use_Clause, Node_Id), Sm (Derived_Type_Link, Node_Id), diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb index dbb894f79cd..00b780bb0df 100644 --- a/gcc/ada/par-ch13.adb +++ b/gcc/ada/par-ch13.adb @@ -632,6 +632,77 @@ package body Ch13 is return Aspects; end Get_Aspect_Specifications; + ----------------------------- + -- P_Attribute_Designators -- + ----------------------------- + + function P_Attribute_Designators (Initial_Prefix : Node_Id) return Node_Id + is + Accumulator : Node_Id := Initial_Prefix; + Designator : Name_Id; + begin + while Token = Tok_Apostrophe loop + + Scan; -- past apostrophe + + Designator := No_Name; + + if Token = Tok_Identifier then + Designator := Token_Name; + + -- Note that the parser must complain in case of an internal + -- attribute name that comes from source since internal names are + -- meant to be used only by the compiler. + + if not Is_Attribute_Name (Designator) + and then (not Is_Internal_Attribute_Name (Designator) + or else Comes_From_Source (Token_Node)) + then + Signal_Bad_Attribute; + end if; + + if Style_Check then + Style.Check_Attribute_Name (False); + end if; + + -- Here for case of attribute designator is not an identifier + + else + if Token = Tok_Delta then + Designator := Name_Delta; + + elsif Token = Tok_Digits then + Designator := Name_Digits; + + elsif Token = Tok_Access then + Designator := Name_Access; + + else + Error_Msg_AP ("attribute designator expected"); + raise Error_Resync; + end if; + + if Style_Check then + Style.Check_Attribute_Name (True); + end if; + end if; + + -- Here we have an OK attribute scanned, and the corresponding + -- Attribute identifier node is stored in Designator. + + declare + Temp : constant Node_Id := Accumulator; + begin + Accumulator := New_Node (N_Attribute_Reference, Prev_Token_Ptr); + Set_Prefix (Accumulator, Temp); + end; + Set_Attribute_Name (Accumulator, Designator); + Scan; + end loop; + + return Accumulator; + end P_Attribute_Designators; + -------------------------------------------- -- 13.1 Representation Clause (also I.7) -- -------------------------------------------- @@ -674,8 +745,6 @@ package body Ch13 is function P_Representation_Clause return Node_Id is For_Loc : Source_Ptr; Name_Node : Node_Id; - Prefix_Node : Node_Id; - Attr_Name : Name_Id; Identifier_Node : Node_Id; Rep_Clause_Node : Node_Id; Expr_Node : Node_Id; @@ -693,8 +762,7 @@ package body Ch13 is -- Check case of qualified name to give good error message if Token = Tok_Dot then - Error_Msg_SC - ("representation clause requires simple name!"); + Error_Msg_SC ("representation clause requires simple name!"); loop exit when Token /= Tok_Dot; @@ -706,80 +774,28 @@ package body Ch13 is -- Attribute Definition Clause if Token = Tok_Apostrophe then + Name_Node := P_Attribute_Designators (Identifier_Node); - -- Allow local names of the form a'b'.... This enables - -- us to parse class-wide streams attributes correctly. - - Name_Node := Identifier_Node; - while Token = Tok_Apostrophe loop - - Scan; -- past apostrophe - - Identifier_Node := Token_Node; - Attr_Name := No_Name; - - if Token = Tok_Identifier then - Attr_Name := Token_Name; - - -- Note that the parser must complain in case of an internal - -- attribute name that comes from source since internal names - -- are meant to be used only by the compiler. - - if not Is_Attribute_Name (Attr_Name) - and then (not Is_Internal_Attribute_Name (Attr_Name) - or else Comes_From_Source (Token_Node)) - then - Signal_Bad_Attribute; - end if; - - if Style_Check then - Style.Check_Attribute_Name (False); - end if; - - -- Here for case of attribute designator is not an identifier - - else - if Token = Tok_Delta then - Attr_Name := Name_Delta; - - elsif Token = Tok_Digits then - Attr_Name := Name_Digits; + -- Check for Address clause which needs to be marked for use in + -- optimizing performance of Exp_Util.Following_Address_Clause. - elsif Token = Tok_Access then - Attr_Name := Name_Access; - - else - Error_Msg_AP ("attribute designator expected"); - raise Error_Resync; - end if; - - if Style_Check then - Style.Check_Attribute_Name (True); - end if; - end if; - - -- Here we have an OK attribute scanned, and the corresponding - -- Attribute identifier node is stored in Ident_Node. - - Prefix_Node := Name_Node; - Name_Node := New_Node (N_Attribute_Reference, Prev_Token_Ptr); - Set_Prefix (Name_Node, Prefix_Node); - Set_Attribute_Name (Name_Node, Attr_Name); - Scan; - - -- Check for Address clause which needs to be marked for use in - -- optimizing performance of Exp_Util.Following_Address_Clause. + declare + Cursor : Node_Id := Name_Node; + begin + while Nkind (Prefix (Cursor)) = N_Attribute_Reference loop + Cursor := Prefix (Cursor); + end loop; - if Attr_Name = Name_Address - and then Nkind (Prefix_Node) = N_Identifier + if Attribute_Name (Cursor) = Name_Address + and then Nkind (Prefix (Cursor)) = N_Identifier then - Set_Name_Table_Boolean1 (Chars (Prefix_Node), True); + Set_Name_Table_Boolean1 (Chars (Prefix (Cursor)), True); end if; - end loop; + end; Rep_Clause_Node := New_Node (N_Attribute_Definition_Clause, For_Loc); - Set_Name (Rep_Clause_Node, Prefix_Node); - Set_Chars (Rep_Clause_Node, Attr_Name); + Set_Name (Rep_Clause_Node, Prefix (Name_Node)); + Set_Chars (Rep_Clause_Node, Attribute_Name (Name_Node)); T_Use; Expr_Node := P_Expression_No_Right_Paren; diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index a6418a5dc9e..2be3670a3d2 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -128,7 +128,8 @@ package body Ch6 is -- This routine scans out a subprogram declaration, subprogram body, -- subprogram renaming declaration or subprogram generic instantiation. - -- It also handles the new Ada 2012 expression function form + -- It also handles the new Ada 2012 expression function form, and the GNAT + -- extension for direct attribute definition. -- SUBPROGRAM_DECLARATION ::= -- SUBPROGRAM_SPECIFICATION @@ -141,6 +142,9 @@ package body Ch6 is -- SUBPROGRAM_SPECIFICATION ::= -- procedure DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE -- | function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE + -- | procedure LOCAL_NAME'ATTRIBUTE_DESIGNATOR PARAMETER_PROFILE + -- | function LOCAL_NAME'ATTRIBUTE_DESIGNATOR + -- PARAMETER_AND_RESULT_PROFILE -- PARAMETER_PROFILE ::= [FORMAL_PART] @@ -190,6 +194,13 @@ package body Ch6 is function Contains_Import_Aspect (Aspects : List_Id) return Boolean; -- Return True if Aspects contains an Import aspect. + procedure Rewrite_Entity_If_Direct_Attribute_Def + (Name : Node_Id; Spec : Node_Id); + -- In case of direct attribute definitions this procedure rewrites the + -- defining unit name of the specification node with a new entity. It is + -- essential to maintain the information that the original node comes + -- from a direct attribute definition. + ---------------------------- -- Contains_Import_Aspect -- ---------------------------- @@ -208,6 +219,39 @@ package body Ch6 is return False; end Contains_Import_Aspect; + -------------------------------------------- + -- Rewrite_Entity_If_Direct_Attribute_Def -- + -------------------------------------------- + + procedure Rewrite_Entity_If_Direct_Attribute_Def + (Name : Node_Id; Spec : Node_Id) + is + New_Entity, Copy_Spec : Node_Id; + begin + if Nkind (Name) = N_Attribute_Reference + and then Is_Direct_Attribute_Definition_Name (Attribute_Name (Name)) + then + -- Note that, this workaround is needed to retain the info that + -- the current subprogram comes from a direct attribute + -- definition. Otherwise, we would need to add an entity flag + -- Is_Constructor. Currently this flag already exists and could be + -- misleading as it refer to CPP constructors ??? + + Copy_Spec := New_Copy (Spec); + + New_Entity := Make_Defining_Identifier (Sloc (Name), + Direct_Attribute_Definition_Name + (Prefix (Name), Attribute_Name (Name))); + Set_Comes_From_Source (New_Entity); + Set_Parent (New_Entity, Copy_Spec); + + Set_Defining_Unit_Name (Copy_Spec, New_Entity); + Rewrite (Spec, Copy_Spec); + end if; + end Rewrite_Entity_If_Direct_Attribute_Def; + + -- Local variables + Specification_Node : Node_Id; Name_Node : Node_Id; Aspects : List_Id; @@ -232,6 +276,8 @@ package body Ch6 is Is_Overriding : Boolean := False; Not_Overriding : Boolean := False; + -- Start of processing for P_Subprogram + begin -- Set up scope stack entry. Note that the Labl field will be set later @@ -343,11 +389,19 @@ package body Ch6 is Name_Node := P_Defining_Program_Unit_Name; end if; + -- Deal with direct attribute definition in subprogram specification + + if Token = Tok_Apostrophe then + Error_Msg_GNAT_Extension ("direct attribute definition", Token_Ptr); + + Name_Node := P_Attribute_Designators (Name_Node); + end if; + Scopes (Scope.Last).Labl := Name_Node; Ignore (Tok_Colon); -- Deal with generic instantiation, the one case in which we do not - -- have a subprogram specification as part of whatever we are parsing + -- have a subprogram specification as part of whatever we are parsing. if Token = Tok_Is then Save_Scan_State (Scan_State); -- at the IS @@ -940,6 +994,9 @@ package body Ch6 is Parse_Decls_Begin_End (Body_Node); end if; + Rewrite_Entity_If_Direct_Attribute_Def + (Name_Node, Specification_Node); + return Body_Node; end Scan_Body_Or_Expression_Function; end if; @@ -952,6 +1009,9 @@ package body Ch6 is Set_Specification (Decl_Node, Specification_Node); Aspects := Get_Aspect_Specifications (Semicolon => False); + Rewrite_Entity_If_Direct_Attribute_Def + (Name_Node, Specification_Node); + -- Aspects may be present on a subprogram body. The source parsed -- so far is that of its specification. Go parse the body and attach -- the collected aspects, if any, to the body. diff --git a/gcc/ada/par-endh.adb b/gcc/ada/par-endh.adb index 816670568a6..8637e07238b 100644 --- a/gcc/ada/par-endh.adb +++ b/gcc/ada/par-endh.adb @@ -156,12 +156,12 @@ package body Endh is function Same_Label (Label1, Label2 : Node_Id) return Boolean; -- This function compares the two names associated with the given nodes. -- If they are both simple (i.e. have Chars fields), then they have to - -- be the same name. Otherwise they must both be N_Selected_Component - -- nodes, referring to the same set of names, or Label1 is an N_Designator - -- referring to the same set of names as the N_Defining_Program_Unit_Name - -- in Label2. Any other combination returns False. This routine is used - -- to compare the End_Labl scanned from the End line with the saved label - -- value in the scope stack. + -- be the same name. If they are both N_Selected_Component or + -- N_Attribute_Reference nodes, they must refer to the same set of names. + -- Otherwise, Label1 must be a N_Designator referring to the same set of + -- names as the N_Defining_Program_Unit_Name in Label2. Any other + -- combination returns False. This routine is used to compare the End_Labl + -- scanned from the End line with the saved label value in the scope stack. --------------- -- Check_End -- @@ -270,6 +270,16 @@ package body Endh is end if; End_Labl := P_Designator; + + -- Case of direct attribute definition + + if Token = Tok_Apostrophe then + Error_Msg_GNAT_Extension + ("direct attribute definition", Token_Ptr); + + End_Labl := P_Attribute_Designators (End_Labl); + end if; + End_Labl_Present := True; -- We have now scanned out a name. Here is where we do a check @@ -1359,6 +1369,12 @@ package body Endh is return Same_Label (Prefix (Label1), Prefix (Label2)) and then Same_Label (Selector_Name (Label1), Selector_Name (Label2)); + elsif Nkind (Label1) = N_Attribute_Reference + and then Nkind (Label2) = N_Attribute_Reference + then + return Same_Label (Prefix (Label1), Prefix (Label2)) and then + Attribute_Name (Label1) = Attribute_Name (Label2); + elsif Nkind (Label1) = N_Designator and then Nkind (Label2) = N_Defining_Program_Unit_Name then diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 8ced09dc009..6fc4bed530b 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -1019,6 +1019,16 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is package Ch13 is function P_Representation_Clause return Node_Id; + function P_Attribute_Designators + (Initial_Prefix : Node_Id) return Node_Id; + -- This procedure parses trailing apostrophes and attribute designators, + -- i.e., the "'b'c..." suffix in "a'b'c...". "a" must have already been + -- parsed into Initial_Prefix and the scan pointer must be pointing + -- right past "a". If no apostrophe is found we just return + -- Initial_Prefix, otherwise the return value is a chain of + -- N_Attribute_Reference nodes, nested via the Prefix field and ending + -- with Initial_Prefix. + function Aspect_Specifications_Present (Strict : Boolean := Ada_Version < Ada_2012) return Boolean; -- This function tests whether the next keyword is WITH followed by diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 962b0889c84..88b7e765cf8 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -3957,6 +3957,13 @@ package body Sem_Attr is Error_Attr_P ("prefix of % attribute must be object of discriminated type"); + ----------------- + -- Constructor -- + ----------------- + + when Attribute_Constructor => + Error_Attr_P ("attribute% can only be used to define constructors"); + --------------- -- Copy_Sign -- --------------- @@ -5180,12 +5187,17 @@ package body Sem_Attr is Expr : Entity_Id; begin if not All_Extensions_Allowed then - Error_Msg_GNAT_Extension ("Make attribute", Loc); + Error_Msg_GNAT_Extension ("attribute %", Loc); return; end if; + Check_Type; Set_Etype (N, Etype (P)); + if not Needs_Construction (Entity (P)) then + Error_Msg_NE ("no available constructor for&", N, Entity (P)); + end if; + if Present (Expressions (N)) then Expr := First (Expressions (N)); while Present (Expr) loop @@ -5197,6 +5209,9 @@ package body Sem_Attr is Next (Expr); end loop; + + elsif not Has_Default_Constructor (Entity (P)) then + Error_Msg_NE ("no default constructor for&", N, Entity (P)); end if; end; @@ -11144,6 +11159,7 @@ package body Sem_Attr is | Attribute_Class | Attribute_Code_Address | Attribute_Compiler_Version + | Attribute_Constructor | Attribute_Count | Attribute_Default_Bit_Order | Attribute_Default_Scalar_Storage_Order diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index f7be890536d..c2a590dc887 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -5041,16 +5041,6 @@ package body Sem_Ch13 is Analyze_Aspect_Implicit_Dereference; goto Continue; - when Aspect_Constructor => - if not All_Extensions_Allowed then - Error_Msg_Name_1 := Nam; - Error_Msg_GNAT_Extension ("aspect %", Loc); - goto Continue; - end if; - - Set_Constructor_Name (E, Expr); - Set_Needs_Construction (E); - -- Dimension when Aspect_Dimension => @@ -11753,8 +11743,7 @@ package body Sem_Ch13 is -- name, so we need to verify that one of these interpretations is -- the one available at the freeze point. - elsif A_Id in Aspect_Constructor - | Aspect_Destructor + elsif A_Id in Aspect_Destructor | Aspect_Input | Aspect_Output | Aspect_Read @@ -12050,8 +12039,7 @@ package body Sem_Ch13 is -- Special case, the expression of these aspects is just an entity -- that does not need any resolution, so just analyze. - when Aspect_Constructor - | Aspect_Input + when Aspect_Input | Aspect_Output | Aspect_Put_Image | Aspect_Read @@ -17357,9 +17345,6 @@ package body Sem_Ch13 is => null; - when Aspect_Constructor => - null; - when Aspect_Dynamic_Predicate | Aspect_Ghost_Predicate | Aspect_Predicate diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 2a42d89d971..233f8237aa5 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -5246,6 +5246,15 @@ package body Sem_Ch3 is and then Nkind (E) = N_Aggregate then Act_T := Etype (E); + + elsif Needs_Construction (T) + and then not Has_Init_Expression (N) + and then not Has_Default_Constructor (T) + and then not Suppress_Initialization (Id) + and then Comes_From_Source (N) + then + Error_Msg_NE ("no default constructor for&", + Object_Definition (N), T); end if; -- Check No_Wide_Characters restriction diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 5e84889e401..4456c94eeff 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -5270,10 +5270,95 @@ package body Sem_Ch6 is -- both subprogram bodies and subprogram declarations (specs). function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id is + procedure Analyze_Direct_Attribute_Definition (Designator : Entity_Id); + -- This procedure checks whether the direct attribute definition for N + -- is correct for the given attribute name, and analyzes it. + function Is_Invariant_Procedure_Or_Body (E : Entity_Id) return Boolean; -- Determine whether entity E denotes the spec or body of an invariant -- procedure. + ----------------------------------------- + -- Analyze_Direct_Attribute_Definition -- + ----------------------------------------- + + procedure Analyze_Direct_Attribute_Definition (Designator : Entity_Id) is + Att_N : constant Node_Id := Original_Node (N); + Prefix_E : constant Entity_Id := + Get_Name_Entity_Id (Chars (Prefix (Defining_Unit_Name (Att_N)))); + Att_Name : constant Name_Id := + Attribute_Name (Defining_Unit_Name (Att_N)); + begin + pragma Assert (N /= Att_N); + + if not Is_Direct_Attribute_Definition_Name (Att_Name) then + Error_Msg_Name_1 := Att_Name; + Error_Msg_N + ("direct definition syntax not supported for attribute%", + Designator); + end if; + + -- Handle each kind of attribute separately + + case Att_Name is + + when Name_Constructor => + Error_Msg_Name_1 := Att_Name; + + -- No further action required in a subprogram body + + if Parent_Kind (N) not in N_Subprogram_Declaration then + return; + + elsif No (Prefix_E) or else not Is_Type (Prefix_E) then + Error_Msg_N + ("prefix& of attribute% must be a type", + Prefix (Defining_Unit_Name (Att_N))); + + elsif Ekind (Designator) /= E_Procedure then + Error_Msg_N + ("attribute% can only be specified to a procedure", N); + + elsif No (First_Formal (Designator)) + or else Etype (First_Formal (Designator)) /= Prefix_E + or else Ekind (First_Formal (Designator)) + /= E_In_Out_Parameter + then + declare + Problem : constant Source_Ptr := + (if No (First_Formal (Designator)) + then Sloc (N) + else Sloc (First_Formal (Designator))); + begin + Error_Msg_Node_1 := Defining_Unit_Name (Att_N); + Error_Msg_Node_2 := Prefix_E; + Error_Msg + ("& must have a first IN OUT formal of type&", Problem); + end; + + elsif Is_Frozen (Prefix_E) + or else Current_Scope /= Scope (Prefix_E) + then + Error_Msg_Sloc := Sloc (Freeze_Node (Prefix_E)); + Error_Msg_N + ("& must be defined before freezing#", Designator); + + elsif Parent_Kind (Enclosing_Package_Or_Subprogram (Designator)) + /= N_Package_Specification + then + Error_Msg_N + ("& is required to be a primitive operation", Designator); + + else + Set_Needs_Construction (Prefix_E); + end if; + + when others => + null; + + end case; + end Analyze_Direct_Attribute_Definition; + ------------------------------------ -- Is_Invariant_Procedure_Or_Body -- ------------------------------------ @@ -5416,89 +5501,6 @@ package body Sem_Ch6 is End_Scope; - -- Register the subprogram in a Constructor_List when it is a valid - -- constructor. - - if All_Extensions_Allowed - and then Present (First_Formal (Designator)) - then - - declare - First_Form_Type : constant Entity_Id := - Etype (First_Formal (Designator)); - - Construct : Elmt_Id; - begin - -- Valid constructors have a "controlling" formal of a type - -- with the Constructor aspect specified. Additionally, the - -- subprogram name must match value described by the aspect. - - -- Additionally, constructor declarations must exist within the - -- same scope as the type declaration and before the type is - -- frozen. - - -- For example: - -- - -- type Foo is null record with Constructor => Bar; - -- - -- procedure Bar (Self : in out Foo); - -- - - if Present (Constructor_Name (First_Form_Type)) - and then Current_Scope = Scope (First_Form_Type) - and then Chars (Constructor_Name (First_Form_Type)) - = Chars (Designator) - and then Ekind (Designator) = E_Procedure - and then Nkind (Parent (N)) = N_Subprogram_Declaration - then - -- If the constructor list is empty than we don't have to - -- look for duplicates - we simply create the list and - -- add it. - - if No (Constructor_List (First_Form_Type)) then - Set_Constructor_List - (First_Form_Type, New_Elmt_List (Designator)); - - -- Otherwise, we need to check the constructor hasen't - -- already been added (e.g. a specification and body) and - -- that there isn't a constructor with the same number of - -- type of formals. - - -- NOTE: The Constructor_List is sorted by the number of - -- parameters. - - else - Construct := First_Elmt - (Constructor_List (First_Form_Type)); - - -- Skip over constructors with less than the number of - -- parameters than Designator ??? - - -- Loop through the constructors looking for ones which - -- "match." - - Outter : loop - - -- When we are at the end of the constructor list we - -- know there are no matches, so it is safe to add. - - if No (Construct) then - Append_Elmt - (Designator, - Constructor_List (First_Form_Type)); - exit Outter; - end if; - - -- Loop through the formals and check the formals - -- match on type ??? - - Next_Elmt (Construct); - end loop Outter; - end if; - end if; - end; - end if; - -- The subprogram scope is pushed and popped around the processing of -- the return type for consistency with call above to Process_Formals -- (which itself can call Analyze_Return_Type), and to ensure that any @@ -5511,6 +5513,12 @@ package body Sem_Ch6 is End_Scope; end if; + -- Handle subprogram specification directly referencing an attribute + + if Is_Direct_Attribute_Subp_Spec (N) then + Analyze_Direct_Attribute_Definition (Designator); + end if; + -- Function case if Nkind (N) = N_Function_Specification then diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index a8984c89cf2..5fd2445aa4c 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -6331,6 +6331,26 @@ package body Sem_Util is end if; end Conditional_Delay; + -------------------------------------- + -- Direct_Attribute_Definition_Name -- + -------------------------------------- + + function Direct_Attribute_Definition_Name + (Prefix : Entity_Id; Att_Name : Name_Id) return Name_Id is + begin + if Nkind (Prefix) = N_Attribute_Reference then + Error_Msg_N ("attribute streams not supported in " + & "direct attribute definitions", + Prefix); + end if; + + pragma Assert (Is_Attribute_Name (Att_Name)); + return New_External_Name + (Related_Id => Chars (Prefix), + Suffix => "_" & Get_Name_String (Att_Name) & "_Att", + Prefix => 'D'); + end Direct_Attribute_Definition_Name; + -------------------------------------- -- Copy_Assertion_Policy_Attributes -- -------------------------------------- @@ -6832,30 +6852,6 @@ package body Sem_Util is return Is_Class_Wide_Type (Typ) or else Needs_Finalization (Typ); end CW_Or_Needs_Finalization; - ------------------------- - -- Default_Constructor -- - ------------------------- - - function Default_Constructor (Typ : Entity_Id) return Entity_Id is - Construct : Elmt_Id; - begin - pragma Assert (Is_Type (Typ)); - if No (Constructor_Name (Typ)) or else No (Constructor_List (Typ)) then - return Empty; - end if; - - Construct := First_Elmt (Constructor_List (Typ)); - while Present (Construct) loop - if Parameter_Count (Elists.Node (Construct)) = 1 then - return Elists.Node (Construct); - end if; - - Next_Elmt (Construct); - end loop; - - return Empty; - end Default_Constructor; - --------------------- -- Defining_Entity -- --------------------- @@ -11850,6 +11846,35 @@ package body Sem_Util is (First_Discriminant (Typ))); end Has_Defaulted_Discriminants; + ----------------------------- + -- Has_Default_Constructor -- + ----------------------------- + + function Has_Default_Constructor (Typ : Entity_Id) return Boolean is + Cursor : Entity_Id; + begin + pragma Assert (Is_Type (Typ)); + if not Needs_Construction (Typ) then + return False; + end if; + + -- Iterate through all homonyms to find the default constructor + + Cursor := Get_Name_Entity_Id + (Direct_Attribute_Definition_Name (Typ, Name_Constructor)); + while Present (Cursor) loop + if Is_Constructor_Procedure (Cursor) + and then No (Next_Formal (First_Formal (Cursor))) + then + return True; + end if; + + Cursor := Homonym (Cursor); + end loop; + + return False; + end Has_Default_Constructor; + ------------------- -- Has_Denormals -- ------------------- @@ -16249,6 +16274,17 @@ package body Sem_Util is and then Attribute_Name (N) = Name_Result; end Is_Attribute_Result; + ----------------------------------- + -- Is_Direct_Attribute_Subp_Spec -- + ----------------------------------- + + function Is_Direct_Attribute_Subp_Spec (N : Node_Id) return Boolean is + begin + return Nkind (N) in N_Subprogram_Specification + and then Nkind (Defining_Unit_Name (Original_Node (N))) + = N_Attribute_Reference; + end Is_Direct_Attribute_Subp_Spec; + ------------------------- -- Is_Attribute_Update -- ------------------------- @@ -16684,6 +16720,28 @@ package body Sem_Util is end if; end Is_Constant_Bound; + ------------------------------ + -- Is_Constructor_Procedure -- + ------------------------------ + + function Is_Constructor_Procedure (Subp : Entity_Id) return Boolean is + First_Param : Entity_Id; + begin + if not (Present (First_Formal (Subp)) + and then Ekind (First_Formal (Subp)) = E_In_Out_Parameter + and then Is_Direct_Attribute_Subp_Spec (Parent (Subp)) + and then Attribute_Name (Defining_Unit_Name + (Original_Node (Parent (Subp)))) + = Name_Constructor) + then + return False; + end if; + + First_Param := Implementation_Base_Type (Etype (First_Formal (Subp))); + return Scope (Subp) = Scope (First_Param) + and then Needs_Construction (First_Param); + end Is_Constructor_Procedure; + --------------------------- -- Is_Container_Element -- --------------------------- @@ -26669,24 +26727,6 @@ package body Sem_Util is return Empty; end Param_Entity; - --------------------- - -- Parameter_Count -- - --------------------- - - function Parameter_Count (Subp : Entity_Id) return Nat is - Result : Nat := 0; - Param : Entity_Id; - begin - Param := First_Entity (Subp); - while Present (Param) loop - Result := Result + 1; - - Param := Next_Entity (Param); - end loop; - - return Result; - end Parameter_Count; - ---------------------- -- Policy_In_Effect -- ---------------------- @@ -27097,6 +27137,11 @@ package body Sem_Util is -- the case where Ent is a child unit. This procedure generates an -- appropriate cross-reference entry. E is the corresponding entity. + procedure Get_Attribute_Reference_Name_String (N : Node_Id); + -- This procedure append to the Global_Name_Buffer the decoded string + -- name of the attribute reference N, including apostrophes and multiple + -- prefixes. + ------------------------- -- Generate_Parent_Ref -- ------------------------- @@ -27118,6 +27163,21 @@ package body Sem_Util is end if; end Generate_Parent_Ref; + ----------------------------------------- + -- Get_Attribute_Reference_Name_String -- + ----------------------------------------- + + procedure Get_Attribute_Reference_Name_String (N : Node_Id) is + begin + if Nkind (N) /= N_Attribute_Reference then + Get_Decoded_Name_String (Chars (N)); + else + Get_Attribute_Reference_Name_String (Prefix (N)); + Append (Global_Name_Buffer, '''); + Get_Decoded_Name_String (Attribute_Name (N)); + end if; + end Get_Attribute_Reference_Name_String; + -- Start of processing for Process_End_Label begin @@ -27198,9 +27258,12 @@ package body Sem_Util is -- If the end label is not for the given entity, then either we have -- some previous error, or this is a generic instantiation for which -- we do not need to make a cross-reference in this case anyway. In - -- either case we simply ignore the call. + -- either case we simply ignore the call. Matching label for direct + -- attribute definitions are checked elsewhere. - if Chars (Ent) /= Chars (Endl) then + if Nkind (Endl) /= N_Attribute_Reference + and then Chars (Ent) /= Chars (Endl) + then return; end if; @@ -27227,7 +27290,7 @@ package body Sem_Util is -- mean the semicolon immediately following the label). This is -- done for the sake of the 'e' or 't' entry generated below. - Get_Decoded_Name_String (Chars (Endl)); + Get_Attribute_Reference_Name_String (Endl); Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len)); end if; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index ee9ecd2abb4..71889b2a25a 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -569,6 +569,10 @@ package Sem_Util is -- of Old_Ent is set and Old_Ent has not yet been Frozen (i.e. Is_Frozen is -- False). + function Direct_Attribute_Definition_Name + (Prefix : Entity_Id; Att_Name : Name_Id) return Name_Id; + -- Returns the name used for entities of direct attribute definitions. + procedure Copy_Assertion_Policy_Attributes (New_Prag, Old_Prag : Node_Id); -- Copy Is_Checked, Is_Ignored and Ghost_Assertion_Level attributes from -- Old_Node. @@ -674,10 +678,6 @@ package Sem_Util is -- as Needs_Finalization except with pragma Restrictions (No_Finalization), -- in which case we know that class-wide objects do not need finalization. - function Default_Constructor (Typ : Entity_Id) return Entity_Id; - -- Determine the default constructor (e.g. the constructor with only one - -- formal parameter) for a given type Typ. - function Defining_Entity (N : Node_Id) return Entity_Id; -- Given a declaration N, returns the associated defining entity. If the -- declaration has a specification, the entity is obtained from the @@ -1407,6 +1407,9 @@ package Sem_Util is function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean; -- Simple predicate to test for defaulted discriminants + function Has_Default_Constructor (Typ : Entity_Id) return Boolean; + -- Determine whether Typ has a constructor with only one formal parameter. + function Has_Denormals (E : Entity_Id) return Boolean; -- Determines if the floating-point type E supports denormal numbers. -- Returns False if E is not a floating-point type. @@ -1880,6 +1883,10 @@ package Sem_Util is function Is_Attribute_Result (N : Node_Id) return Boolean; -- Determine whether node N denotes attribute 'Result + function Is_Direct_Attribute_Subp_Spec (N : Node_Id) return Boolean; + -- Determine whether N denotes a direct attribute definition subprogram + -- specification node. + function Is_Attribute_Update (N : Node_Id) return Boolean; -- Determine whether node N denotes attribute 'Update @@ -1914,6 +1921,10 @@ package Sem_Util is -- enumeration literal, or an expression composed of constant-bound -- subexpressions which are evaluated by means of standard operators. + function Is_Constructor_Procedure (Subp : Entity_Id) return Boolean; + -- Returns True if Subp's name directly references an attribute, has a + -- first in out formal that needs construction within the same scope. + function Is_Container_Element (Exp : Node_Id) return Boolean; -- This routine recognizes expressions that denote an element of one of -- the predefined containers, when the source only contains an indexing @@ -2973,9 +2984,6 @@ package Sem_Util is -- WARNING: this routine should be used in debugging scenarios such as -- tracking down undefined symbols as it is fairly low level. - function Parameter_Count (Subp : Entity_Id) return Nat; - -- Return the number of parameters for a given subprogram Subp. - function Param_Entity (N : Node_Id) return Entity_Id; -- Given an expression N, determines if the expression is a reference -- to a formal (of a subprogram or entry), and if so returns the Id diff --git a/gcc/ada/snames.adb-tmpl b/gcc/ada/snames.adb-tmpl index fcfd3901e17..b5f53cd4749 100644 --- a/gcc/ada/snames.adb-tmpl +++ b/gcc/ada/snames.adb-tmpl @@ -412,6 +412,15 @@ package body Snames is end if; end Is_Convention_Name; + ----------------------------------------- + -- Is_Direct_Attribute_Definition_Name -- + ----------------------------------------- + + function Is_Direct_Attribute_Definition_Name (N : Name_Id) return Boolean is + begin + return Is_Attribute_Name (N) and then N = Name_Constructor; + end Is_Direct_Attribute_Definition_Name; + ------------------------------ -- Is_Entity_Attribute_Name -- ------------------------------ diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index d6fe60ba89a..cb07f97c4fe 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -147,7 +147,6 @@ package Snames is -- Names of aspects for which there are no matching pragmas or attributes -- so that they need to be included for aspect specification use. - Name_Constructor : constant Name_Id := N + $; Name_Default_Value : constant Name_Id := N + $; Name_Default_Component_Value : constant Name_Id := N + $; Name_Designated_Storage_Model : constant Name_Id := N + $; @@ -956,6 +955,7 @@ package Snames is Name_Component_Size : constant Name_Id := N + $; Name_Compose : constant Name_Id := N + $; Name_Constrained : constant Name_Id := N + $; + Name_Constructor : constant Name_Id := N + $; Name_Count : constant Name_Id := N + $; Name_Default_Bit_Order : constant Name_Id := N + $; -- GNAT Name_Default_Scalar_Storage_Order : constant Name_Id := N + $; -- GNAT @@ -1500,6 +1500,7 @@ package Snames is Attribute_Component_Size, Attribute_Compose, Attribute_Constrained, + Attribute_Constructor, Attribute_Count, Attribute_Default_Bit_Order, Attribute_Default_Scalar_Storage_Order, @@ -2077,6 +2078,10 @@ package Snames is -- mode. This is the mechanism for considering this pragma illegal in -- normal GNAT programs. + function Is_Direct_Attribute_Definition_Name (N : Name_Id) return Boolean; + -- Test to see if the name N is the name of a recognized attribute and is + -- allowed to be directly referenced in subprogram specification. + function Is_Entity_Attribute_Name (N : Name_Id) return Boolean; -- Test to see if the name N is the name of a recognized entity attribute, -- i.e. an attribute reference that returns an entity.