Aspect_Bit_Order,
Aspect_Component_Size,
Aspect_Constant_Indexing,
- Aspect_Constructor, -- GNAT
Aspect_Contract_Cases, -- GNAT
Aspect_Convention,
Aspect_CPU,
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,
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,
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,
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,
-- 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
-- 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
-- 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
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
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;
----------------------------
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;
-- 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;
-- 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;
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);
| Attribute_Bit_Order
| Attribute_Class
| Attribute_Compiler_Version
+ | Attribute_Constructor
| Attribute_Default_Bit_Order
| Attribute_Default_Scalar_Storage_Order
| Attribute_Definite
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.
-- 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,
-- 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
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;
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;
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,
-- 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);
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.
----------------
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;
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);
-- 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 --
----------------------------------
Component_Clause,
Component_Size,
Component_Type,
- Constructor_List,
- Constructor_Name,
Continue_Mark,
Contract,
Contract_Wrapper,
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),
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) --
--------------------------------------------
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;
-- 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;
-- 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;
-- 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
-- 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]
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 --
----------------------------
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;
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
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
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;
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.
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 --
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
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
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
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 --
---------------
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
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;
| Attribute_Class
| Attribute_Code_Address
| Attribute_Compiler_Version
+ | Attribute_Constructor
| Attribute_Count
| Attribute_Default_Bit_Order
| Attribute_Default_Scalar_Storage_Order
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 =>
-- 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
-- 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
=>
null;
- when Aspect_Constructor =>
- null;
-
when Aspect_Dynamic_Predicate
| Aspect_Ghost_Predicate
| Aspect_Predicate
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
-- 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 --
------------------------------------
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
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
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 --
--------------------------------------
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 --
---------------------
(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 --
-------------------
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 --
-------------------------
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 --
---------------------------
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 --
----------------------
-- 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 --
-------------------------
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
-- 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;
-- 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;
-- 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.
-- 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
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.
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
-- 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
-- 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
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 --
------------------------------
-- 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 + $;
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
Attribute_Component_Size,
Attribute_Compose,
Attribute_Constrained,
+ Attribute_Constructor,
Attribute_Count,
Attribute_Default_Bit_Order,
Attribute_Default_Scalar_Storage_Order,
-- 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.
projects / thirdparty / gcc.git / commitdiff
