-- Obsolescent_Warning Node24
-- Task_Body_Procedure Node24
- -- Abstract_Interfaces Node24
+ -- Abstract_Interfaces Elist24
-- Abstract_Interface_Alias Node25
-- Has_Stream_Size_Clause Flag184
-- Is_Ada_2005 Flag185
-- Is_Interface Flag186
+ -- Has_Constrained_Partial_View Flag187
+ -- Has_Persistent_BSS Flag188
+ -- Is_Pure_Unit_Access_Type Flag189
+ -- Has_Specified_Stream_Input Flag190
+
+ -- Has_Specified_Stream_Output Flag191
+ -- Has_Specified_Stream_Read Flag192
+ -- Has_Specified_Stream_Write Flag193
+ -- Is_Local_Anonymous_Access Flag194
- -- (unused) Flag187
- -- (unused) Flag188
- -- (unused) Flag189
- -- (unused) Flag190
- -- (unused) Flag191
- -- (unused) Flag192
- -- (unused) Flag193
- -- (unused) Flag194
-- (unused) Flag195
-- (unused) Flag196
-- (unused) Flag197
function Abstract_Interfaces (Id : E) return L is
begin
- pragma Assert (Ekind (Id) = E_Record_Type
- or else Ekind (Id) = E_Record_Subtype
- or else Ekind (Id) = E_Record_Type_With_Private
- or else Ekind (Id) = E_Record_Subtype_With_Private);
+ pragma Assert
+ (Ekind (Id) = E_Record_Type
+ or else Ekind (Id) = E_Record_Subtype
+ or else Ekind (Id) = E_Record_Type_With_Private
+ or else Ekind (Id) = E_Record_Subtype_With_Private
+ or else Ekind (Id) = E_Class_Wide_Type);
return Elist24 (Id);
end Abstract_Interfaces;
function DT_Entry_Count (Id : E) return U is
begin
- pragma Assert (Ekind (Id) = E_Component and then Is_Tag (Id));
+ pragma Assert (Ekind (Id) = E_Component and then Is_Tag (Id));
return Uint15 (Id);
end DT_Entry_Count;
return Flag68 (Implementation_Base_Type (Id));
end Has_Component_Size_Clause;
+ function Has_Constrained_Partial_View (Id : E) return B is
+ begin
+ pragma Assert (Is_Type (Id));
+ return Flag187 (Id);
+ end Has_Constrained_Partial_View;
+
function Has_Controlled_Component (Id : E) return B is
begin
return Flag43 (Base_Type (Id));
return Flag154 (Id);
end Has_Per_Object_Constraint;
+ function Has_Persistent_BSS (Id : E) return B is
+ begin
+ return Flag188 (Id);
+ end Has_Persistent_BSS;
+
function Has_Pragma_Controlled (Id : E) return B is
begin
pragma Assert (Is_Access_Type (Id));
return Flag100 (Implementation_Base_Type (Id));
end Has_Specified_Layout;
+ function Has_Specified_Stream_Input (Id : E) return B is
+ begin
+ pragma Assert (Is_Type (Id));
+ return Flag190 (Id);
+ end Has_Specified_Stream_Input;
+
+ function Has_Specified_Stream_Output (Id : E) return B is
+ begin
+ pragma Assert (Is_Type (Id));
+ return Flag191 (Id);
+ end Has_Specified_Stream_Output;
+
+ function Has_Specified_Stream_Read (Id : E) return B is
+ begin
+ pragma Assert (Is_Type (Id));
+ return Flag192 (Id);
+ end Has_Specified_Stream_Read;
+
+ function Has_Specified_Stream_Write (Id : E) return B is
+ begin
+ pragma Assert (Is_Type (Id));
+ return Flag193 (Id);
+ end Has_Specified_Stream_Write;
+
function Has_Storage_Size_Clause (Id : E) return B is
begin
pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id));
return Flag19 (Id);
end Is_Abstract;
+ function Is_Local_Anonymous_Access (Id : E) return B is
+ begin
+ pragma Assert (Is_Access_Type (Id));
+ return Flag194 (Id);
+ end Is_Local_Anonymous_Access;
+
function Is_Access_Constant (Id : E) return B is
begin
pragma Assert (Is_Access_Type (Id));
function Is_Interface (Id : E) return B is
begin
- pragma Assert (Ekind (Id) = E_Record_Type
- or else Ekind (Id) = E_Record_Subtype
- or else Ekind (Id) = E_Record_Type_With_Private
- or else Ekind (Id) = E_Record_Subtype_With_Private
- or else Ekind (Id) = E_Class_Wide_Type);
return Flag186 (Id);
end Is_Interface;
function Is_Obsolescent (Id : E) return B is
begin
- pragma Assert (Is_Subprogram (Id));
return Flag153 (Id);
end Is_Obsolescent;
return Flag44 (Id);
end Is_Pure;
+ function Is_Pure_Unit_Access_Type (Id : E) return B is
+ begin
+ pragma Assert (Is_Access_Type (Id));
+ return Flag189 (Id);
+ end Is_Pure_Unit_Access_Type;
+
function Is_Remote_Call_Interface (Id : E) return B is
begin
return Flag62 (Id);
procedure Set_Abstract_Interfaces (Id : E; V : L) is
begin
- pragma Assert (Ekind (Id) = E_Record_Type
- or else Ekind (Id) = E_Record_Subtype
- or else Ekind (Id) = E_Record_Type_With_Private
- or else Ekind (Id) = E_Record_Subtype_With_Private);
+ pragma Assert
+ (Ekind (Id) = E_Record_Type
+ or else Ekind (Id) = E_Record_Subtype
+ or else Ekind (Id) = E_Record_Type_With_Private
+ or else Ekind (Id) = E_Record_Subtype_With_Private
+ or else Ekind (Id) = E_Class_Wide_Type);
Set_Elist24 (Id, V);
end Set_Abstract_Interfaces;
Set_Flag68 (Id, V);
end Set_Has_Component_Size_Clause;
+ procedure Set_Has_Constrained_Partial_View (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Type (Id));
+ Set_Flag187 (Id, V);
+ end Set_Has_Constrained_Partial_View;
+
procedure Set_Has_Contiguous_Rep (Id : E; V : B := True) is
begin
Set_Flag181 (Id, V);
Set_Flag154 (Id, V);
end Set_Has_Per_Object_Constraint;
+ procedure Set_Has_Persistent_BSS (Id : E; V : B := True) is
+ begin
+ Set_Flag188 (Id, V);
+ end Set_Has_Persistent_BSS;
+
procedure Set_Has_Pragma_Controlled (Id : E; V : B := True) is
begin
pragma Assert (Is_Access_Type (Id));
Set_Flag100 (Id, V);
end Set_Has_Specified_Layout;
+ procedure Set_Has_Specified_Stream_Input (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Type (Id));
+ Set_Flag190 (Id, V);
+ end Set_Has_Specified_Stream_Input;
+
+ procedure Set_Has_Specified_Stream_Output (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Type (Id));
+ Set_Flag191 (Id, V);
+ end Set_Has_Specified_Stream_Output;
+
+ procedure Set_Has_Specified_Stream_Read (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Type (Id));
+ Set_Flag192 (Id, V);
+ end Set_Has_Specified_Stream_Read;
+
+ procedure Set_Has_Specified_Stream_Write (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Type (Id));
+ Set_Flag193 (Id, V);
+ end Set_Has_Specified_Stream_Write;
+
procedure Set_Has_Storage_Size_Clause (Id : E; V : B := True) is
begin
pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id));
Set_Flag19 (Id, V);
end Set_Is_Abstract;
+ procedure Set_Is_Local_Anonymous_Access (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Access_Type (Id));
+ Set_Flag194 (Id, V);
+ end Set_Is_Local_Anonymous_Access;
+
procedure Set_Is_Access_Constant (Id : E; V : B := True) is
begin
pragma Assert (Is_Access_Type (Id));
procedure Set_Is_Interface (Id : E; V : B := True) is
begin
- pragma Assert (Ekind (Id) = E_Record_Type
- or else Ekind (Id) = E_Record_Subtype
- or else Ekind (Id) = E_Record_Type_With_Private
- or else Ekind (Id) = E_Record_Subtype_With_Private);
+ pragma Assert
+ (Ekind (Id) = E_Record_Type
+ or else Ekind (Id) = E_Record_Subtype
+ or else Ekind (Id) = E_Record_Type_With_Private
+ or else Ekind (Id) = E_Record_Subtype_With_Private
+ or else Ekind (Id) = E_Class_Wide_Type);
Set_Flag186 (Id, V);
end Set_Is_Interface;
procedure Set_Is_Obsolescent (Id : E; V : B := True) is
begin
- pragma Assert (Is_Subprogram (Id));
Set_Flag153 (Id, V);
end Set_Is_Obsolescent;
Set_Flag44 (Id, V);
end Set_Is_Pure;
+ procedure Set_Is_Pure_Unit_Access_Type (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Access_Type (Id));
+ Set_Flag189 (Id, V);
+ end Set_Is_Pure_Unit_Access_Type;
+
procedure Set_Is_Remote_Call_Interface (Id : E; V : B := True) is
begin
Set_Flag62 (Id, V);
W ("Has_Non_Standard_Rep", Flag75 (Id));
W ("Has_Object_Size_Clause", Flag172 (Id));
W ("Has_Per_Object_Constraint", Flag154 (Id));
+ W ("Has_Persistent_BSS", Flag188 (Id));
W ("Has_Pragma_Controlled", Flag27 (Id));
W ("Has_Pragma_Elaborate_Body", Flag150 (Id));
W ("Has_Pragma_Inline", Flag157 (Id));
W ("Has_Size_Clause", Flag29 (Id));
W ("Has_Small_Clause", Flag67 (Id));
W ("Has_Specified_Layout", Flag100 (Id));
+ W ("Has_Specified_Stream_Input", Flag190 (Id));
+ W ("Has_Specified_Stream_Output", Flag191 (Id));
+ W ("Has_Specified_Stream_Read", Flag192 (Id));
+ W ("Has_Specified_Stream_Write", Flag193 (Id));
W ("Has_Storage_Size_Clause", Flag23 (Id));
W ("Has_Stream_Size_Clause", Flag184 (Id));
W ("Has_Subprogram_Descriptor", Flag93 (Id));
W ("In_Use", Flag8 (Id));
W ("Is_AST_Entry", Flag132 (Id));
W ("Is_Abstract", Flag19 (Id));
+ W ("Is_Local_Anonymous_Access", Flag194 (Id));
W ("Is_Access_Constant", Flag69 (Id));
W ("Is_Ada_2005", Flag185 (Id));
W ("Is_Aliased", Flag15 (Id));
W ("Is_Private_Descendant", Flag53 (Id));
W ("Is_Public", Flag10 (Id));
W ("Is_Pure", Flag44 (Id));
+ W ("Is_Pure_Unit_Access_Type", Flag189 (Id));
W ("Is_Remote_Call_Interface", Flag62 (Id));
W ("Is_Remote_Types", Flag61 (Id));
W ("Is_Renaming_Of_Object", Flag112 (Id));
-- There can only be a single statement, contained on a single line,
-- not counting any pragma Assert statements.
--- This single statement must either by a function call with simple,
+-- This single statement must either be a function call with simple,
-- single token arguments, or it must be a membership test of the form
-- a in b, where a and b are single tokens.
-- present for the given type. Note that this flag can be False even
-- if Component_Size is non-zero (happens in the case of derived types).
+-- Has_Constrained_Partial_View (Flag187)
+-- Present in private type and their completions, when the private
+-- type has no discriminants and the full view has discriminants with
+-- defaults. In Ada 2005 heap-allocated objects of such types are not
+-- constrained, and can change their discriminants with full assignment.
+
-- Has_Contiguous_Rep (Flag181)
-- Present in enumeration types. True if the type as a representation
-- clause whose entries are successive integers.
-- 5. N_Range_Constraint - when the range expression uses the
-- discriminant of the enclosing type.
+-- Has_Persistent_BSS (Flag188)
+-- Present in all entities. Set True for entities to which a valid
+-- pragma Persistent_BSS applies. Note that although the pragma is
+-- only meaningful for objects, we set it for all entities in a unit
+-- to which the pragma applies, as well as the unit entity itself, for
+-- convenience in propagating the flag to contained entities.
+
-- Has_Pragma_Controlled (Flag27) [implementation base type only]
-- Present in access type entities. It is set if a pragma Controlled
-- applies to the access type.
-- representation clause, and thus is not inherited by a derived type.
-- This flag is always False for non-record types.
+-- Has_Specified_Stream_Input (Flag190)
+-- Has_Specified_Stream_Output (Flag191)
+-- Has_Specified_Stream_Read (Flag192)
+-- Has_Specified_Stream_Write (Flag193)
+-- Present in all type and subtype entities. Set for a given view if the
+-- corresponding stream-oriented attribute has been defined by an
+-- attribute definition clause. When such a clause occurs, a TSS is set
+-- on the underlying full view; the flags are used to track visibility of
+-- the attribute definition clause for partial or incomplete views.
+
-- Has_Storage_Size_Clause (Flag23) [implementation base type only]
-- Present in task types and access types. It is set if a Storage_Size
-- clause is present for the type. Used to prevent multiple clauses for
-- Implementation_Base_Type (synthesized)
-- Applies to all types. Similar to Base_Type, but never returns a
-- private type when applied to a non-private type. Instead in this
--- case, it always returns the Representation_Type of the base type
--- in this case, so that we still have a concrete type. Note: it is
--- allowed to apply Implementation_Base_Type to other than a type,
--- in which case it simply returns the entity unchanged.
+-- case, it always returns the Underlying_Type of the base type, so that
+-- we still have a concrete type. Note: it is allowed to apply
+-- Implementation_Base_Type to other than a type, in which case it
+-- simply returns the entity unchanged.
-- In_Package_Body (Flag48)
-- Set on the entity that denotes the package (the defining occurrence
-- Present in all types, and also for functions and procedures. Set
-- for abstract types and abstract subprograms.
+-- Is_Local_Anonymous_Access (Flag194)
+-- Present in access types. Set for an anonymous access type to indicate
+-- that the type is created for a record component with an access
+-- definition, an array component, or a stand-alone object. Such
+-- anonymous types have an accessibility level equal to that of the
+-- declaration in which they appear, unlike the anonymous access types
+-- that are created for access parameters and access discriminants.
+
-- Is_Access_Constant (Flag69)
-- Present in access types and subtypes. Indicates that the keyword
-- constant was present in the access type definition.
-- Is_Internal (Flag17)
-- Present in all entities. Set to indicate an entity created during
--- semantic processing (e.g. an implicit type). Need more documentation
--- on this one! ???
+-- semantic processing (e.g. an implicit type, or a temporary). The
+-- only current use of this flag is to indicate that temporaries
+-- generated for the result of an inlined function call need not be
+-- initialized, even when scalars are initialized or normalized.
-- Is_Interrupt_Handler (Flag89)
-- Present in procedures. Set if a pragma Interrupt_Handler applies
-- including generic formal parameters.
-- Is_Obsolescent (Flag153)
--- Present in subprogram entities. Set if a valid pragma Obsolescent
--- applies to the subprogram.
+-- Present in all entities. Set only for subprograms when a valid pragma
+-- Obsolescent applies to the subprogram.
-- Is_Optional_Parameter (Flag134)
-- Present in parameter entities. Set if the parameter is specified as
-- resulting from assignment to out parameters, or to objects designated
-- by access parameters).
+-- Is_Pure_Unit_Access_Type (Flag189)
+-- Present in access type and subtype entities. Set if the type or
+-- subtype appears in a pure unit. Used to give an error message at
+-- freeze time if the access type has a storage pool.
+
-- Is_Real_Type (synthesized)
-- Applies to all entities, true for real types and subtypes
-- For each enumeration value defined in Entity_Kind we list all the
-- attributes defined in Einfo which can legally be applied to an entity
-- of that kind. The implementation of the attribute functions (and for
- -- non-synthesized attributes, or the corresponding set procedures) are
+ -- non-synthetized attributes, of the corresponding set procedures) are
-- in the Einfo body.
-- The following attributes apply to all entities
-- Has_Fully_Qualified_Name (Flag173)
-- Has_Gigi_Rep_Item (Flag82)
-- Has_Homonym (Flag56)
+ -- Has_Persistent_BSS (Flag188)
-- Has_Pragma_Elaborate_Body (Flag150)
-- Has_Pragma_Inline (Flag157)
-- Has_Pragma_Unreferenced (Flag180)
-- Is_Known_Valid (Flag170)
-- Is_Limited_Composite (Flag106)
-- Is_Limited_Record (Flag25)
+ -- Is_Obsolescent (Flag153)
-- Is_Package_Body_Entity (Flag160)
-- Is_Packed_Array_Type (Flag138)
-- Is_Potentially_Use_Visible (Flag9)
-- Has_Alignment_Clause (Flag46)
-- Has_Atomic_Components (Flag86) (base type only)
-- Has_Complex_Representation (Flag140) (base type only)
+ -- Has_Constrained_Partial_View (Flag187)
-- Has_Discriminants (Flag5)
-- Has_Non_Standard_Rep (Flag75) (base type only)
-- Has_Object_Size_Clause (Flag172)
-- Has_Primitive_Operations (Flag120) (base type only)
-- Has_Size_Clause (Flag29)
-- Has_Specified_Layout (Flag100) (base type only)
+ -- Has_Specified_Stream_Input (Flag190)
+ -- Has_Specified_Stream_Output (Flag191)
+ -- Has_Specified_Stream_Read (Flag192)
+ -- Has_Specified_Stream_Write (Flag193)
-- Has_Task (Flag30) (base type only)
-- Has_Unchecked_Union (Flag123) (base type only)
-- Has_Volatile_Components (Flag87) (base type only)
-- Associated_Final_Chain (Node23)
-- Has_Pragma_Controlled (Flag27) (base type only)
-- Has_Storage_Size_Clause (Flag23) (base type only)
+ -- Is_Local_Anonymous_Access (Flag194)
-- Is_Access_Constant (Flag69)
+ -- Is_Pure_Unit_Access_Type (Flag189)
-- No_Pool_Assigned (Flag131) (base type only)
-- No_Strict_Aliasing (Flag136) (base type only)
-- (plus type attributes)
-- Is_Instantiated (Flag126) (generic case only)
-- Is_Intrinsic_Subprogram (Flag64)
-- Is_Machine_Code_Subprogram (Flag137) (non-generic case only)
- -- Is_Obsolescent (Flag153)
-- Is_Overriding_Operation (Flag39) (non-generic case only)
-- Is_Private_Descendant (Flag53)
-- Is_Pure (Flag44)
-- Is_Intrinsic_Subprogram (Flag64)
-- Is_Machine_Code_Subprogram (Flag137) (non-generic case only)
-- Is_Null_Init_Proc (Flag178)
- -- Is_Obsolescent (Flag153)
-- Is_Overriding_Operation (Flag39) (non-generic case only)
-- Is_Private_Descendant (Flag53)
-- Is_Pure (Flag44)
function Has_Completion_In_Body (Id : E) return B;
function Has_Complex_Representation (Id : E) return B;
function Has_Component_Size_Clause (Id : E) return B;
+ function Has_Constrained_Partial_View (Id : E) return B;
function Has_Contiguous_Rep (Id : E) return B;
function Has_Controlled_Component (Id : E) return B;
function Has_Controlling_Result (Id : E) return B;
function Has_Non_Standard_Rep (Id : E) return B;
function Has_Object_Size_Clause (Id : E) return B;
function Has_Per_Object_Constraint (Id : E) return B;
+ function Has_Persistent_BSS (Id : E) return B;
function Has_Pragma_Controlled (Id : E) return B;
function Has_Pragma_Elaborate_Body (Id : E) return B;
function Has_Pragma_Inline (Id : E) return B;
function Has_Size_Clause (Id : E) return B;
function Has_Small_Clause (Id : E) return B;
function Has_Specified_Layout (Id : E) return B;
+ function Has_Specified_Stream_Input (Id : E) return B;
+ function Has_Specified_Stream_Output (Id : E) return B;
+ function Has_Specified_Stream_Read (Id : E) return B;
+ function Has_Specified_Stream_Write (Id : E) return B;
function Has_Storage_Size_Clause (Id : E) return B;
function Has_Stream_Size_Clause (Id : E) return B;
function Has_Subprogram_Descriptor (Id : E) return B;
function Interface_Name (Id : E) return N;
function Is_AST_Entry (Id : E) return B;
function Is_Abstract (Id : E) return B;
+ function Is_Local_Anonymous_Access (Id : E) return B;
function Is_Access_Constant (Id : E) return B;
function Is_Ada_2005 (Id : E) return B;
function Is_Aliased (Id : E) return B;
function Is_Private_Descendant (Id : E) return B;
function Is_Public (Id : E) return B;
function Is_Pure (Id : E) return B;
+ function Is_Pure_Unit_Access_Type (Id : E) return B;
function Is_Remote_Call_Interface (Id : E) return B;
function Is_Remote_Types (Id : E) return B;
function Is_Renaming_Of_Object (Id : E) return B;
procedure Set_Has_Completion_In_Body (Id : E; V : B := True);
procedure Set_Has_Complex_Representation (Id : E; V : B := True);
procedure Set_Has_Component_Size_Clause (Id : E; V : B := True);
+ procedure Set_Has_Constrained_Partial_View (Id : E; V : B := True);
procedure Set_Has_Contiguous_Rep (Id : E; V : B := True);
procedure Set_Has_Controlled_Component (Id : E; V : B := True);
procedure Set_Has_Controlling_Result (Id : E; V : B := True);
procedure Set_Has_Non_Standard_Rep (Id : E; V : B := True);
procedure Set_Has_Object_Size_Clause (Id : E; V : B := True);
procedure Set_Has_Per_Object_Constraint (Id : E; V : B := True);
+ procedure Set_Has_Persistent_BSS (Id : E; V : B := True);
procedure Set_Has_Pragma_Controlled (Id : E; V : B := True);
procedure Set_Has_Pragma_Elaborate_Body (Id : E; V : B := True);
procedure Set_Has_Pragma_Inline (Id : E; V : B := True);
procedure Set_Has_Size_Clause (Id : E; V : B := True);
procedure Set_Has_Small_Clause (Id : E; V : B := True);
procedure Set_Has_Specified_Layout (Id : E; V : B := True);
+ procedure Set_Has_Specified_Stream_Input (Id : E; V : B := True);
+ procedure Set_Has_Specified_Stream_Output (Id : E; V : B := True);
+ procedure Set_Has_Specified_Stream_Read (Id : E; V : B := True);
+ procedure Set_Has_Specified_Stream_Write (Id : E; V : B := True);
procedure Set_Has_Storage_Size_Clause (Id : E; V : B := True);
procedure Set_Has_Stream_Size_Clause (Id : E; V : B := True);
procedure Set_Has_Subprogram_Descriptor (Id : E; V : B := True);
procedure Set_Interface_Name (Id : E; V : N);
procedure Set_Is_AST_Entry (Id : E; V : B := True);
procedure Set_Is_Abstract (Id : E; V : B := True);
+ procedure Set_Is_Local_Anonymous_Access (Id : E; V : B := True);
procedure Set_Is_Access_Constant (Id : E; V : B := True);
procedure Set_Is_Ada_2005 (Id : E; V : B := True);
procedure Set_Is_Aliased (Id : E; V : B := True);
procedure Set_Is_Private_Descendant (Id : E; V : B := True);
procedure Set_Is_Public (Id : E; V : B := True);
procedure Set_Is_Pure (Id : E; V : B := True);
+ procedure Set_Is_Pure_Unit_Access_Type (Id : E; V : B := True);
procedure Set_Is_Remote_Call_Interface (Id : E; V : B := True);
procedure Set_Is_Remote_Types (Id : E; V : B := True);
procedure Set_Is_Renaming_Of_Object (Id : E; V : B := True);
pragma Inline (Has_Completion_In_Body);
pragma Inline (Has_Complex_Representation);
pragma Inline (Has_Component_Size_Clause);
+ pragma Inline (Has_Constrained_Partial_View);
pragma Inline (Has_Contiguous_Rep);
pragma Inline (Has_Controlled_Component);
pragma Inline (Has_Controlling_Result);
pragma Inline (Has_Non_Standard_Rep);
pragma Inline (Has_Object_Size_Clause);
pragma Inline (Has_Per_Object_Constraint);
+ pragma Inline (Has_Persistent_BSS);
pragma Inline (Has_Pragma_Controlled);
pragma Inline (Has_Pragma_Elaborate_Body);
pragma Inline (Has_Pragma_Inline);
pragma Inline (Has_Size_Clause);
pragma Inline (Has_Small_Clause);
pragma Inline (Has_Specified_Layout);
+ pragma Inline (Has_Specified_Stream_Input);
+ pragma Inline (Has_Specified_Stream_Output);
+ pragma Inline (Has_Specified_Stream_Read);
+ pragma Inline (Has_Specified_Stream_Write);
pragma Inline (Has_Storage_Size_Clause);
pragma Inline (Has_Stream_Size_Clause);
pragma Inline (Has_Subprogram_Descriptor);
pragma Inline (Interface_Name);
pragma Inline (Is_AST_Entry);
pragma Inline (Is_Abstract);
+ pragma Inline (Is_Local_Anonymous_Access);
pragma Inline (Is_Access_Constant);
pragma Inline (Is_Ada_2005);
pragma Inline (Is_Access_Type);
pragma Inline (Is_Protected_Type);
pragma Inline (Is_Public);
pragma Inline (Is_Pure);
+ pragma Inline (Is_Pure_Unit_Access_Type);
pragma Inline (Is_Real_Type);
pragma Inline (Is_Record_Type);
pragma Inline (Is_Remote_Call_Interface);
pragma Inline (Set_Has_Completion_In_Body);
pragma Inline (Set_Has_Complex_Representation);
pragma Inline (Set_Has_Component_Size_Clause);
+ pragma Inline (Set_Has_Constrained_Partial_View);
pragma Inline (Set_Has_Contiguous_Rep);
pragma Inline (Set_Has_Controlled_Component);
pragma Inline (Set_Has_Controlling_Result);
pragma Inline (Set_Has_Non_Standard_Rep);
pragma Inline (Set_Has_Object_Size_Clause);
pragma Inline (Set_Has_Per_Object_Constraint);
+ pragma Inline (Set_Has_Persistent_BSS);
pragma Inline (Set_Has_Pragma_Controlled);
pragma Inline (Set_Has_Pragma_Elaborate_Body);
pragma Inline (Set_Has_Pragma_Inline);
pragma Inline (Set_Has_Size_Clause);
pragma Inline (Set_Has_Small_Clause);
pragma Inline (Set_Has_Specified_Layout);
+ pragma Inline (Set_Has_Specified_Stream_Input);
+ pragma Inline (Set_Has_Specified_Stream_Output);
+ pragma Inline (Set_Has_Specified_Stream_Read);
+ pragma Inline (Set_Has_Specified_Stream_Write);
pragma Inline (Set_Has_Storage_Size_Clause);
pragma Inline (Set_Has_Subprogram_Descriptor);
pragma Inline (Set_Has_Task);
pragma Inline (Set_Interface_Name);
pragma Inline (Set_Is_AST_Entry);
pragma Inline (Set_Is_Abstract);
+ pragma Inline (Set_Is_Local_Anonymous_Access);
pragma Inline (Set_Is_Access_Constant);
pragma Inline (Set_Is_Ada_2005);
pragma Inline (Set_Is_Aliased);
pragma Inline (Set_Is_Private_Descendant);
pragma Inline (Set_Is_Public);
pragma Inline (Set_Is_Pure);
+ pragma Inline (Set_Is_Pure_Unit_Access_Type);
pragma Inline (Set_Is_Remote_Call_Interface);
pragma Inline (Set_Is_Remote_Types);
pragma Inline (Set_Is_Renaming_Of_Object);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
-with Sem_Ch6;
+with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch11; use Sem_Ch11;
with Sem_Elab; use Sem_Elab;
-- of the range of each entry family. A single array with that size is
-- allocated for each concurrent object of the type.
+ function Build_Wrapper_Body
+ (Loc : Source_Ptr;
+ Proc_Nam : Entity_Id;
+ Obj_Typ : Entity_Id;
+ Formals : List_Id) return Node_Id;
+ -- Ada 2005 (AI-345): Build the body that wraps a primitive operation
+ -- associated with a protected or task type. This is required to implement
+ -- dispatching calls through interfaces. Proc_Nam is the entry name to be
+ -- wrapped, Obj_Typ is the type of the newly added formal parameter to
+ -- handle object notation, Formals are the original entry formals that will
+ -- be explicitly replicated.
+
+ function Build_Wrapper_Spec
+ (Loc : Source_Ptr;
+ Proc_Nam : Entity_Id;
+ Obj_Typ : Entity_Id;
+ Formals : List_Id) return Node_Id;
+ -- Ada 2005 (AI-345): Build the specification of a primitive operation
+ -- associated with a protected or task type. This is required implement
+ -- dispatching calls through interfaces. Proc_Nam is the entry name to be
+ -- wrapped, Obj_Typ is the type of the newly added formal parameter to
+ -- handle object notation, Formals are the original entry formals that will
+ -- be explicitly replicated.
+
function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id;
-- Build the function that translates the entry index in the call
-- (which depends on the size of entry families) into an index into the
Cdecls : List_Id;
begin
- Set_Corresponding_Record_Type (Ctyp, Rec_Ent);
+ Set_Corresponding_Record_Type (Ctyp, Rec_Ent);
Set_Ekind (Rec_Ent, E_Record_Type);
Set_Has_Delayed_Freeze (Rec_Ent, Has_Delayed_Freeze (Ctyp));
Set_Is_Concurrent_Record_Type (Rec_Ent, True);
end if;
-- Now we can construct the record type declaration. Note that this
- -- record is limited, reflecting the underlying limitedness of the
- -- task or protected object that it represents, and ensuring for
- -- example that it is properly passed by reference.
+ -- record is "limited tagged". It is "limited" to reflect the underlying
+ -- limitedness of the task or protected object that it represents, and
+ -- ensuring for example that it is properly passed by reference. It is
+ -- "tagged" to give support to dispatching calls through interfaces (Ada
+ -- 2005: AI-345)
return
Make_Full_Type_Declaration (Loc,
Component_List =>
Make_Component_List (Loc,
Component_Items => Cdecls),
+ Tagged_Present => Ada_Version >= Ada_05,
Limited_Present => True));
end Build_Corresponding_Record;
return Ecount;
end Build_Entry_Count_Expression;
+ ------------------------------
+ -- Build_Wrapper_Body --
+ ------------------------------
+
+ function Build_Wrapper_Body
+ (Loc : Source_Ptr;
+ Proc_Nam : Entity_Id;
+ Obj_Typ : Entity_Id;
+ Formals : List_Id) return Node_Id
+ is
+ Actuals : List_Id := No_List;
+ Body_Spec : Node_Id;
+ Conv_Id : Node_Id;
+ First_Formal : Node_Id;
+ Formal : Node_Id;
+
+ begin
+ Body_Spec := Build_Wrapper_Spec (Loc, Proc_Nam, Obj_Typ, Formals);
+
+ -- If we did not generate the specification do have nothing else to do
+
+ if Body_Spec = Empty then
+ return Empty;
+ end if;
+
+ -- Map formals to actuals. Use the list built for the wrapper spec,
+ -- skipping the object notation parameter.
+
+ First_Formal := First (Parameter_Specifications (Body_Spec));
+
+ Formal := First_Formal;
+ Next (Formal);
+
+ if Present (Formal) then
+ Actuals := New_List;
+
+ while Present (Formal) loop
+ Append_To (Actuals,
+ Make_Identifier (Loc, Chars =>
+ Chars (Defining_Identifier (Formal))));
+
+ Next (Formal);
+ end loop;
+ end if;
+
+ -- An access-to-variable first parameter will require an explicit
+ -- dereference in the unchecked conversion. This case occurs when
+ -- a protected entry wrapper must override an interface-level
+ -- procedure with interface access as first parameter.
+
+ -- SubprgName (O.all).Proc_Nam (Formal_1 .. Formal_N)
+
+ if Nkind (Parameter_Type (First_Formal)) = N_Access_Definition then
+ Conv_Id :=
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Chars => Name_uO));
+ else
+ Conv_Id :=
+ Make_Identifier (Loc, Chars => Name_uO);
+ end if;
+
+ if Ekind (Proc_Nam) = E_Function then
+ return
+ Make_Subprogram_Body (Loc,
+ Specification => Body_Spec,
+ Declarations => Empty_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements =>
+ New_List (
+ Make_Return_Statement (Loc,
+ Make_Function_Call (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (
+ Corresponding_Concurrent_Type (Obj_Typ),
+ Conv_Id),
+ Selector_Name =>
+ New_Reference_To (Proc_Nam, Loc)),
+ Parameter_Associations => Actuals)))));
+ else
+ return
+ Make_Subprogram_Body (Loc,
+ Specification => Body_Spec,
+ Declarations => Empty_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements =>
+ New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (
+ Corresponding_Concurrent_Type (Obj_Typ),
+ Conv_Id),
+ Selector_Name =>
+ New_Reference_To (Proc_Nam, Loc)),
+ Parameter_Associations => Actuals))));
+ end if;
+ end Build_Wrapper_Body;
+
+ ------------------------
+ -- Build_Wrapper_Spec --
+ ------------------------
+
+ function Build_Wrapper_Spec
+ (Loc : Source_Ptr;
+ Proc_Nam : Entity_Id;
+ Obj_Typ : Entity_Id;
+ Formals : List_Id) return Node_Id
+ is
+ New_Name_Id : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Chars (Proc_Nam));
+
+ First_Param : Node_Id := Empty;
+ Iface : Entity_Id;
+ Iface_Elmt : Elmt_Id := No_Elmt;
+ New_Formals : List_Id;
+ Obj_Param : Node_Id;
+ Obj_Param_Typ : Node_Id;
+ Iface_Prim_Op : Entity_Id;
+ Iface_Prim_Op_Elmt : Elmt_Id;
+
+ function Overriding_Possible
+ (Iface_Prim_Op : Entity_Id;
+ Proc_Nam : Entity_Id) return Boolean;
+ -- Determine whether a primitive operation can be overriden by the
+ -- wrapper. Iface_Prim_Op is the candidate primitive operation of an
+ -- abstract interface type, Proc_Nam is the generated entry wrapper.
+
+ function Replicate_Entry_Formals
+ (Loc : Source_Ptr;
+ Formals : List_Id) return List_Id;
+ -- An explicit parameter replication is required due to the
+ -- Is_Entry_Formal flag being set for all the formals. The explicit
+ -- replication removes the flag that would otherwise cause a different
+ -- path of analysis.
+
+ -------------------------
+ -- Overriding_Possible --
+ -------------------------
+
+ function Overriding_Possible
+ (Iface_Prim_Op : Entity_Id;
+ Proc_Nam : Entity_Id) return Boolean
+ is
+ Prim_Op_Spec : constant Node_Id := Parent (Iface_Prim_Op);
+ Proc_Spec : constant Node_Id := Parent (Proc_Nam);
+
+ Is_Access_To_Variable : Boolean;
+ Is_Out_Present : Boolean;
+
+ function Type_Conformant_Parameters
+ (Prim_Op_Param_Specs : List_Id;
+ Proc_Param_Specs : List_Id) return Boolean;
+ -- Determine whether the parameters of the generated entry wrapper
+ -- and those of a primitive operation are type conformant. During
+ -- this check, the first parameter of the primitive operation is
+ -- always skipped.
+
+ --------------------------------
+ -- Type_Conformant_Parameters --
+ --------------------------------
+
+ function Type_Conformant_Parameters
+ (Prim_Op_Param_Specs : List_Id;
+ Proc_Param_Specs : List_Id) return Boolean
+ is
+ Prim_Op_Param : Node_Id;
+ Proc_Param : Node_Id;
+
+ begin
+ -- Skip the first parameter of the primitive operation
+
+ Prim_Op_Param := Next (First (Prim_Op_Param_Specs));
+ Proc_Param := First (Proc_Param_Specs);
+ while Present (Prim_Op_Param)
+ and then Present (Proc_Param)
+ loop
+ -- The two parameters must be mode conformant and have
+ -- the exact same types.
+
+ if Out_Present (Prim_Op_Param) /= Out_Present (Proc_Param)
+ or else In_Present (Prim_Op_Param) /= In_Present (Proc_Param)
+ or else Etype (Parameter_Type (Prim_Op_Param)) /=
+ Etype (Parameter_Type (Proc_Param))
+ then
+ return False;
+ end if;
+
+ Next (Prim_Op_Param);
+ Next (Proc_Param);
+ end loop;
+
+ -- One of the lists is longer than the other
+
+ if Present (Prim_Op_Param) or else Present (Proc_Param) then
+ return False;
+ end if;
+
+ return True;
+ end Type_Conformant_Parameters;
+
+ -- Start of processing for Overriding_Possible
+
+ begin
+ if Chars (Iface_Prim_Op) /= Chars (Proc_Nam) then
+ return False;
+ end if;
+
+ -- Special check for protected procedures: If an inherited subprogram
+ -- is implemented by a protected procedure or an entry, then the
+ -- first parameter of the inherited subprogram shall be of mode OUT
+ -- or IN OUT, or an access-to-variable parameter.
+
+ if Ekind (Iface_Prim_Op) = E_Procedure then
+
+ Is_Out_Present :=
+ Present (Parameter_Specifications (Prim_Op_Spec))
+ and then
+ Out_Present (First (Parameter_Specifications (Prim_Op_Spec)));
+
+ Is_Access_To_Variable :=
+ Present (Parameter_Specifications (Prim_Op_Spec))
+ and then
+ Nkind (Parameter_Type
+ (First
+ (Parameter_Specifications (Prim_Op_Spec))))
+ = N_Access_Definition;
+
+ if not Is_Out_Present
+ and then not Is_Access_To_Variable
+ then
+ return False;
+ end if;
+ end if;
+
+ return Type_Conformant_Parameters (
+ Parameter_Specifications (Prim_Op_Spec),
+ Parameter_Specifications (Proc_Spec));
+
+ end Overriding_Possible;
+
+ -----------------------------
+ -- Replicate_Entry_Formals --
+ -----------------------------
+
+ function Replicate_Entry_Formals
+ (Loc : Source_Ptr;
+ Formals : List_Id) return List_Id
+ is
+ New_Formals : constant List_Id := New_List;
+ Formal : Node_Id;
+
+ begin
+ Formal := First (Formals);
+
+ if Present (Formal) then
+ while Present (Formal) loop
+
+ -- Create an explicit copy of the entry parameter
+
+ Append_To (New_Formals,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Chars => Chars (Defining_Identifier (Formal))),
+ In_Present => In_Present (Formal),
+ Out_Present => Out_Present (Formal),
+ Parameter_Type => New_Reference_To (Etype (
+ Parameter_Type (Formal)), Loc)));
+
+ Next (Formal);
+ end loop;
+ end if;
+
+ return New_Formals;
+ end Replicate_Entry_Formals;
+
+ -- Start of processing for Build_Wrapper_Spec
+
+ begin
+ -- The mode is determined by the first parameter of the interface-level
+ -- procedure that the current entry is trying to override.
+
+ pragma Assert (Present (Abstract_Interfaces
+ (Corresponding_Record_Type (Scope (Proc_Nam)))));
+
+ Iface_Elmt :=
+ First_Elmt (Abstract_Interfaces
+ (Corresponding_Record_Type (Scope (Proc_Nam))));
+
+ -- We must examine all the protected operations of the implemented
+ -- interfaces in order to discover a possible overriding candidate.
+
+ Examine_Interfaces : while Present (Iface_Elmt) loop
+ Iface := Node (Iface_Elmt);
+
+ if Present (Primitive_Operations (Iface)) then
+ Iface_Prim_Op_Elmt := First_Elmt (Primitive_Operations (Iface));
+
+ while Present (Iface_Prim_Op_Elmt) loop
+ Iface_Prim_Op := Node (Iface_Prim_Op_Elmt);
+
+ -- The current primitive operation can be overriden by the
+ -- generated entry wrapper.
+
+ if Overriding_Possible (Iface_Prim_Op, Proc_Nam) then
+ First_Param :=
+ First (Parameter_Specifications (Parent (Iface_Prim_Op)));
+
+ exit Examine_Interfaces;
+ end if;
+
+ Next_Elmt (Iface_Prim_Op_Elmt);
+ end loop;
+ end if;
+
+ Next_Elmt (Iface_Elmt);
+ end loop Examine_Interfaces;
+
+ -- Return if no interface primitive can be overriden
+
+ if not Present (First_Param) then
+ return Empty;
+ end if;
+
+ New_Formals := Replicate_Entry_Formals (Loc, Formals);
+
+ -- ??? Certain source packages contain protected or task types that do
+ -- not implement any interfaces and are compiled with the -gnat05
+ -- switch. In this case, a default first parameter is created.
+
+ if Present (First_Param) then
+ if Nkind (Parameter_Type (First_Param)) = N_Access_Definition then
+ Obj_Param_Typ :=
+ Make_Access_Definition (Loc,
+ Subtype_Mark =>
+ New_Reference_To (Obj_Typ, Loc));
+ else
+ Obj_Param_Typ := New_Reference_To (Obj_Typ, Loc);
+ end if;
+
+ Obj_Param :=
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uO),
+ In_Present => In_Present (First_Param),
+ Out_Present => Out_Present (First_Param),
+ Parameter_Type => Obj_Param_Typ);
+
+ else
+ Obj_Param :=
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uO),
+ In_Present => True,
+ Out_Present => True,
+ Parameter_Type => New_Reference_To (Obj_Typ, Loc));
+ end if;
+
+ Prepend_To (New_Formals, Obj_Param);
+
+ -- Minimum decoration needed to catch the entity in
+ -- Sem_Ch6.Override_Dispatching_Operation
+
+ if Ekind (Proc_Nam) = E_Procedure
+ or else Ekind (Proc_Nam) = E_Entry
+ then
+ Set_Ekind (New_Name_Id, E_Procedure);
+ return
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => New_Name_Id,
+ Parameter_Specifications => New_Formals);
+
+ else pragma Assert (Ekind (Proc_Nam) = E_Function);
+ Set_Ekind (New_Name_Id, E_Function);
+ return
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => New_Name_Id,
+ Parameter_Specifications => New_Formals,
+ Subtype_Mark => New_Copy (Subtype_Mark (Parent (Proc_Nam))));
+ end if;
+ end Build_Wrapper_Spec;
+
---------------------------
-- Build_Find_Body_Index --
---------------------------
if Unprotected then
Append_Char := 'N';
else
- Append_Char := 'P';
+ -- Ada 2005 (AI-345): The protected version no longer uses 'P'
+ -- as suffix in order to make it a primitive operation
+
+ if Ada_Version >= Ada_05 then
+ Append_Char := ' ';
+ else
+ Append_Char := 'P';
+ end if;
end if;
New_Id :=
-- the state of the protected object.
procedure Expand_N_Protected_Body (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
Pid : constant Entity_Id := Corresponding_Spec (N);
Has_Entries : Boolean := False;
Op_Decl : Node_Id;
then
New_Op_Body := Build_Find_Body_Index (Pid);
Insert_After (Current_Node, New_Op_Body);
+ Current_Node := New_Op_Body;
Analyze (New_Op_Body);
end if;
+
+ -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies
+ -- after the protected body. At this point the entry specs have been
+ -- created, frozen and included in the dispatch table for the
+ -- protected type.
+
+ pragma Assert (Present (Corresponding_Record_Type (Pid)));
+
+ if Ada_Version >= Ada_05
+ and then Present (Protected_Definition (Parent (Pid)))
+ and then Present (Abstract_Interfaces
+ (Corresponding_Record_Type (Pid)))
+ then
+ declare
+ Vis_Decl : Node_Id :=
+ First (Visible_Declarations
+ (Protected_Definition (Parent (Pid))));
+ Wrap_Body : Node_Id;
+
+ begin
+ -- Examine the visible declarations of the protected type,
+ -- looking for an entry declaration. We do not consider
+ -- entry families since they can not have dispatching
+ -- operations, thus they do not need entry wrappers.
+
+ while Present (Vis_Decl) loop
+ if Nkind (Vis_Decl) = N_Entry_Declaration then
+ Wrap_Body :=
+ Build_Wrapper_Body (Loc,
+ Proc_Nam => Defining_Identifier (Vis_Decl),
+ Obj_Typ => Corresponding_Record_Type (Pid),
+ Formals => Parameter_Specifications (Vis_Decl));
+
+ if Wrap_Body /= Empty then
+ Insert_After (Current_Node, Wrap_Body);
+ Current_Node := Wrap_Body;
+
+ Analyze (Wrap_Body);
+ end if;
+
+ elsif Nkind (Vis_Decl) = N_Subprogram_Declaration then
+ Wrap_Body :=
+ Build_Wrapper_Body (Loc,
+ Proc_Nam => Defining_Unit_Name
+ (Specification (Vis_Decl)),
+ Obj_Typ => Corresponding_Record_Type (Pid),
+ Formals => Parameter_Specifications
+ (Specification (Vis_Decl)));
+
+ if Wrap_Body /= Empty then
+ Insert_After (Current_Node, Wrap_Body);
+ Current_Node := Wrap_Body;
+
+ Analyze (Wrap_Body);
+ end if;
+ end if;
+
+ Next (Vis_Decl);
+ end loop;
+ end;
+ end if;
end Expand_N_Protected_Body;
-----------------------------------------
(Component_List (Type_Definition (Rec_Decl)));
end if;
+ -- Ada 2005 (AI-345): Propagate the attribute that contains the list
+ -- of implemented interfaces.
+
+ Set_Interface_List (Type_Definition (Rec_Decl), Interface_List (N));
+
Qualify_Entity_Names (N);
-- If the type has discriminants, their occurrences in the declaration
Analyze (Rec_Decl, Suppress => All_Checks);
+ -- Ada 2005 (AI-345): Construct the primitive entry wrappers before
+ -- the corresponding record is frozen
+
+ if Ada_Version >= Ada_05
+ and then Present (Visible_Declarations (Pdef))
+ and then Present (Corresponding_Record_Type
+ (Defining_Identifier (Parent (Pdef))))
+ and then Present (Abstract_Interfaces
+ (Corresponding_Record_Type
+ (Defining_Identifier (Parent (Pdef)))))
+ then
+ declare
+ Current_Node : Node_Id := Rec_Decl;
+ Vis_Decl : Node_Id;
+ Wrap_Spec : Node_Id;
+ New_N : Node_Id;
+
+ begin
+ -- Examine the visible declarations of the protected type, looking
+ -- for declarations of entries, and subprograms. We do not
+ -- consider entry families since they can not have dispatching
+ -- operations, thus they do not need entry wrappers.
+
+ Vis_Decl := First (Visible_Declarations (Pdef));
+
+ while Present (Vis_Decl) loop
+
+ Wrap_Spec := Empty;
+
+ if Nkind (Vis_Decl) = N_Entry_Declaration
+ and then not Present (Discrete_Subtype_Definition (Vis_Decl))
+ then
+ Wrap_Spec :=
+ Build_Wrapper_Spec (Loc,
+ Proc_Nam => Defining_Identifier (Vis_Decl),
+ Obj_Typ => Defining_Identifier (Rec_Decl),
+ Formals => Parameter_Specifications (Vis_Decl));
+
+ elsif Nkind (Vis_Decl) = N_Subprogram_Declaration then
+ Wrap_Spec :=
+ Build_Wrapper_Spec (Loc,
+ Proc_Nam => Defining_Unit_Name
+ (Specification (Vis_Decl)),
+ Obj_Typ => Defining_Identifier (Rec_Decl),
+ Formals => Parameter_Specifications
+ (Specification (Vis_Decl)));
+
+ end if;
+
+ if Wrap_Spec /= Empty then
+ New_N := Make_Subprogram_Declaration (Loc,
+ Specification => Wrap_Spec);
+
+ Insert_After (Current_Node, New_N);
+ Current_Node := New_N;
+
+ Analyze (New_N);
+ end if;
+
+ Next (Vis_Decl);
+ end loop;
+ end;
+ end if;
+
-- Collect pointers to entry bodies and their barriers, to be placed
-- in the Entry_Bodies_Array for the type. For each entry/family we
-- add an expression to the aggregate which is the initial value of
Make_Identifier (Loc, New_External_Name (Chars (Ttyp), 'E')),
Expression => New_Reference_To (Standard_True, Loc)));
end if;
+
+ -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies
+ -- after the task body. At this point the entry specs have been
+ -- created, frozen and included in the dispatch table for the task
+ -- type.
+
+ pragma Assert (Present (Corresponding_Record_Type (Ttyp)));
+
+ if Ada_Version >= Ada_05
+ and then Present (Task_Definition (Parent (Ttyp)))
+ and then Present (Abstract_Interfaces
+ (Corresponding_Record_Type (Ttyp)))
+ then
+ declare
+ Current_Node : Node_Id;
+ Vis_Decl : Node_Id :=
+ First (Visible_Declarations (Task_Definition (Parent (Ttyp))));
+ Wrap_Body : Node_Id;
+
+ begin
+ if Nkind (Parent (N)) = N_Subunit then
+ Current_Node := Corresponding_Stub (Parent (N));
+ else
+ Current_Node := N;
+ end if;
+
+ -- Examine the visible declarations of the task type,
+ -- looking for an entry declaration. We do not consider
+ -- entry families since they can not have dispatching
+ -- operations, thus they do not need entry wrappers.
+
+ while Present (Vis_Decl) loop
+ if Nkind (Vis_Decl) = N_Entry_Declaration
+ and then Ekind (Defining_Identifier (Vis_Decl)) = E_Entry
+ then
+
+ -- Create the specification of the wrapper
+
+ Wrap_Body :=
+ Build_Wrapper_Body (Loc,
+ Proc_Nam => Defining_Identifier (Vis_Decl),
+ Obj_Typ => Corresponding_Record_Type (Ttyp),
+ Formals => Parameter_Specifications (Vis_Decl));
+
+ if Wrap_Body /= Empty then
+ Insert_After (Current_Node, Wrap_Body);
+ Current_Node := Wrap_Body;
+
+ Analyze (Wrap_Body);
+ end if;
+ end if;
+
+ Next (Vis_Decl);
+ end loop;
+ end;
+ end if;
end Expand_N_Task_Body;
------------------------------------
-- Here we will do the expansion
Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc);
+
+ -- Ada 2005 (AI-345): Propagate the attribute that contains the list
+ -- of implemented interfaces.
+
+ Set_Interface_List (Type_Definition (Rec_Decl), Interface_List (N));
+
Rec_Ent := Defining_Identifier (Rec_Decl);
Cdecls := Component_Items (Component_List
(Type_Definition (Rec_Decl)));
Set_Needs_Debug_Info
(Defining_Entity (Proc_Spec), Comes_From_Source (Original_Node (N)));
- -- Now we can freeze the corresponding record. This needs manually
- -- freezing, since it is really part of the task type, and the task
- -- type is frozen at this stage. We of course need the initialization
- -- procedure for this corresponding record type and we won't get it
- -- in time if we don't freeze now.
+ -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs
+ -- before the corresponding record has been frozen.
- declare
- L : constant List_Id := Freeze_Entity (Rec_Ent, Loc);
+ if Ada_Version >= Ada_05
+ and then Present (Taskdef)
+ and then Present (Corresponding_Record_Type
+ (Defining_Identifier (Parent (Taskdef))))
+ and then Present (Abstract_Interfaces
+ (Corresponding_Record_Type
+ (Defining_Identifier (Parent (Taskdef)))))
+ then
+ declare
+ Current_Node : Node_Id := Rec_Decl;
+ Vis_Decl : Node_Id := First (Visible_Declarations (Taskdef));
+ Wrap_Spec : Node_Id;
+ New_N : Node_Id;
- begin
- if Is_Non_Empty_List (L) then
- Insert_List_After (Body_Decl, L);
- end if;
- end;
+ begin
+ -- Examine the visible declarations of the task type,
+ -- looking for an entry declaration. We do not consider
+ -- entry families since they can not have dispatching
+ -- operations, thus they do not need entry wrappers.
+
+ while Present (Vis_Decl) loop
+ if Nkind (Vis_Decl) = N_Entry_Declaration
+ and then Ekind (Defining_Identifier (Vis_Decl)) = E_Entry
+ then
+ Wrap_Spec :=
+ Build_Wrapper_Spec (Loc,
+ Proc_Nam => Defining_Identifier (Vis_Decl),
+ Obj_Typ => Etype (Rec_Ent),
+ Formals => Parameter_Specifications (Vis_Decl));
+
+ if Wrap_Spec /= Empty then
+ New_N :=
+ Make_Subprogram_Declaration (Loc,
+ Specification => Wrap_Spec);
+
+ Insert_After (Current_Node, New_N);
+ Current_Node := New_N;
+
+ Analyze (New_N);
+ end if;
+ end if;
+
+ Next (Vis_Decl);
+ end loop;
+ end;
+ end if;
+
+ -- Ada 2005 (AI-345): We must defer freezing to allow further
+ -- declaration of primitive subprograms covering task interfaces
+
+ if Ada_Version <= Ada_95 then
+
+ -- Now we can freeze the corresponding record. This needs manually
+ -- freezing, since it is really part of the task type, and the task
+ -- type is frozen at this stage. We of course need the initialization
+ -- procedure for this corresponding record type and we won't get it
+ -- in time if we don't freeze now.
+
+ declare
+ L : constant List_Id := Freeze_Entity (Rec_Ent, Loc);
+
+ begin
+ if Is_Non_Empty_List (L) then
+ Insert_List_After (Body_Decl, L);
+ end if;
+ end;
+ end if;
-- Complete the expansion of access types to the current task
-- type, if any were declared.
with Namet; use Namet;
with Nmake; use Nmake;
with Nlists; use Nlists;
-with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem_Res; use Sem_Res;
with Sinfo; use Sinfo;
-- For types whose root type is Wide_Character
-- xx = Wide_Character
-- tv = Wide_Character (Expr)
- -- pm = Wide_Character_Encoding_Method
-- For types whose root type is Wide_Wide_Character
-- xx = Wide_Wide_haracter
-- tv = Wide_Wide_Character (Expr)
- -- pm = Wide_Character_Encoding_Method
-- For floating-point types
-- xx = Floating_Point
Prefix => New_Reference_To (Ptyp, Loc),
Attribute_Name => Name_Aft));
- -- For wide [wide] character, append encoding method
-
- elsif Rtyp = Standard_Wide_Character
- or else Rtyp = Standard_Wide_Wide_Character
- then
- Append_To (Arglist,
- Make_Integer_Literal (Loc,
- Intval => Int (Wide_Character_Encoding_Method)));
-
-- For decimal, append Scale and also set to do literal conversion
elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
-- For types whose root type is Character
-- xx = Character
+ -- For types whose root type is Wide_Character
+ -- xx = Wide_Character
+
+ -- For types whose root type is Wide_Wide_Character
+ -- xx = Wide_Wide_Character
+
-- For types whose root type is Boolean
-- xx = Boolean
-- For floating-point types and ordinary fixed-point types
-- xx = Real
- -- For types derived from Wide_Character, typ'Value (X) expands into
-
- -- Value_Wide_Character (X, Wide_Character_Encoding_Method)
-
- -- For types derived from Wide_Wide_Character, typ'Value (X) expands into
-
- -- Value_Wide_Wide_Character (X, Wide_Character_Encoding_Method)
-
-- For decimal types with size <= Integer'Size, typ'Value (X)
-- expands into
elsif Rtyp = Standard_Wide_Character then
Vid := RE_Value_Wide_Character;
- Append_To (Args,
- Make_Integer_Literal (Loc,
- Intval => Int (Wide_Character_Encoding_Method)));
elsif Rtyp = Standard_Wide_Wide_Character then
Vid := RE_Value_Wide_Wide_Character;
- Append_To (Args,
- Make_Integer_Literal (Loc,
- Intval => Int (Wide_Character_Encoding_Method)));
elsif Rtyp = Base_Type (Standard_Short_Short_Integer)
or else Rtyp = Base_Type (Standard_Short_Integer)
-- Result_Type (Width_Wide_Character (
-- Wide_Character (typ'First),
-- Wide_Character (typ'Last),
- -- Wide_Character_Encoding_Method);
-- and typ'Wide_Width expands into:
-- Result_Type (Wide_Width_Wide_Character (
-- Wide_Character (typ'First),
-- Wide_Character (typ'Last));
- -- Wide_Character_Encoding_Method);
-- and typ'Wide_Wide_Width expands into
-- Result_Type (Wide_Wide_Width_Wide_Character (
-- Wide_Character (typ'First),
-- Wide_Character (typ'Last));
- -- Wide_Character_Encoding_Method);
-- For types derived from Wide_Wide_Character, typ'Width expands into
-- Result_Type (Width_Wide_Wide_Character (
-- Wide_Wide_Character (typ'First),
-- Wide_Wide_Character (typ'Last),
- -- Wide_Character_Encoding_Method);
-- and typ'Wide_Width expands into:
-- Result_Type (Wide_Width_Wide_Wide_Character (
-- Wide_Wide_Character (typ'First),
-- Wide_Wide_Character (typ'Last));
- -- Wide_Character_Encoding_Method);
-- and typ'Wide_Wide_Width expands into
-- Result_Type (Wide_Wide_Width_Wide_Wide_Char (
-- Wide_Wide_Character (typ'First),
-- Wide_Wide_Character (typ'Last));
- -- Wide_Character_Encoding_Method);
-- For real types, typ'Width and typ'Wide_[Wide_]Width expand into
Prefix => New_Reference_To (Ptyp, Loc),
Attribute_Name => Name_Last))));
- -- For enumeration'Wide_[Wide_]Width, add encoding method parameter
-
- if Attr /= Normal then
- Append_To (Arglist,
- Make_Integer_Literal (Loc,
- Intval => Int (Wide_Character_Encoding_Method)));
- end if;
-
Rewrite (N,
Convert_To (Typ,
Make_Function_Call (Loc,
Prefix => New_Reference_To (Ptyp, Loc),
Attribute_Name => Name_Last)));
- -- For Wide_[Wide_]Character'Width, add encoding method parameter
-
- if (Rtyp = Standard_Wide_Character
- or else
- Rtyp = Standard_Wide_Wide_Character)
- and then Attr /= Normal then
- Append_To (Arglist,
- Make_Integer_Literal (Loc,
- Intval => Int (Wide_Character_Encoding_Method)));
- end if;
-
Rewrite (N,
Convert_To (Typ,
Make_Function_Call (Loc,
-- Call the function, and do an unchecked conversion of the result
-- to the actual type of the prefix. If the target is a discriminant,
- -- set target type to force a constraint check (13.13.2 (35)).
+ -- and we are in the body of the default implementation of a 'Read
+ -- attribute, set target type to force a constraint check (13.13.2(35)).
- if Nkind (Targ) = N_Selected_Component
- and then Present (Entity (Selector_Name (Targ)))
- and then Ekind (Entity (Selector_Name (Targ)))
- = E_Discriminant
+ if Nkind (Targ) = N_Identifier
+ and then Is_Internal_Name (Chars (Targ))
+ and then Is_TSS (Scope (Entity (Targ)), TSS_Stream_Read)
then
Res :=
Unchecked_Convert_To (Base_Type (P_Type),
Decl : out Node_Id;
Pnam : out Entity_Id)
is
- Stms : List_Id;
+ Out_Formal : Node_Id;
+ -- Expression denoting the out formal parameter
+
+ Dcls : constant List_Id := New_List;
+ -- Declarations for the 'Read body
+
+ Stms : List_Id := New_List;
-- Statements for the 'Read body
+ Disc : Entity_Id;
+ -- Entity of the discriminant being processed
+
+ Tmp_For_Disc : Entity_Id;
+ -- Temporary object used to read the value of Disc
+
+ Tmps_For_Discs : constant List_Id := New_List;
+ -- List of object declarations for temporaries holding the read values
+ -- for the discriminants.
+
+ Cstr : constant List_Id := New_List;
+ -- List of constraints to be applied on temporary record
+
+ Discriminant_Checks : constant List_Id := New_List;
+ -- List of discriminant checks to be performed if the actual object
+ -- is constrained.
+
Tmp : constant Entity_Id := Make_Defining_Identifier (Loc, Name_V);
- -- Temporary, must hide formal (assignments to components of the
+ -- Temporary record must hide formal (assignments to components of the
-- record are always generated with V as the identifier for the record).
- Cstr : List_Id;
- -- List of constraints to be applied on temporary
-
- Disc : Entity_Id;
- Disc_Ref : Node_Id;
- Block : Node_Id;
+ Constrained_Stms : List_Id := New_List;
+ -- Statements within the block where we have the constrained temporary
begin
- Stms := New_List;
- Cstr := New_List;
+
Disc := First_Discriminant (Typ);
-- A mutable type cannot be a tagged type, so we generate a new name
Make_Defining_Identifier (Loc,
Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Read));
+ Out_Formal :=
+ Make_Selected_Component (Loc,
+ Prefix => New_Occurrence_Of (Pnam, Loc),
+ Selector_Name => Make_Identifier (Loc, Name_V));
+
-- Generate Reads for the discriminants of the type. The discriminants
-- need to be read before the rest of the components, so that
- -- variants are initialized correctly.
+ -- variants are initialized correctly. The discriminants must be read
+ -- into temporary variables so an incomplete Read (interrupted by an
+ -- exception, for example) does not alter the passed object.
while Present (Disc) loop
- Disc_Ref :=
- Make_Selected_Component (Loc,
- Prefix => Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Pnam, Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_V)),
- Selector_Name => New_Occurrence_Of (Disc, Loc));
+ Tmp_For_Disc := Make_Defining_Identifier (Loc,
+ New_External_Name (Chars (Disc), "D"));
- Set_Assignment_OK (Disc_Ref);
+ Append_To (Tmps_For_Discs,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Tmp_For_Disc,
+ Object_Definition => New_Occurrence_Of (Etype (Disc), Loc)));
+ Set_No_Initialization (Last (Tmps_For_Discs));
Append_To (Stms,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Etype (Disc), Loc),
- Attribute_Name => Name_Read,
- Expressions => New_List (
- Make_Identifier (Loc, Name_S),
- Disc_Ref)));
+ Attribute_Name => Name_Read,
+ Expressions => New_List (
+ Make_Identifier (Loc, Name_S),
+ New_Occurrence_Of (Tmp_For_Disc, Loc))));
Append_To (Cstr,
Make_Discriminant_Association (Loc,
Selector_Names => New_List (New_Occurrence_Of (Disc, Loc)),
- Expression => New_Copy_Tree (Disc_Ref)));
+ Expression => New_Occurrence_Of (Tmp_For_Disc, Loc)));
+
+ Append_To (Discriminant_Checks,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Op_Ne (Loc,
+ Left_Opnd => New_Occurrence_Of (Tmp_For_Disc, Loc),
+ Right_Opnd =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Out_Formal),
+ Selector_Name => New_Occurrence_Of (Disc, Loc))),
+ Reason => CE_Discriminant_Check_Failed));
Next_Discriminant (Disc);
end loop;
-- prior to being initialized. To this effect, we wrap the component
-- assignments in a block where V is a constrained temporary.
- Block :=
+ Append_To (Dcls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Tmp,
+ Object_Definition =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Occurrence_Of (Typ, Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => Cstr))));
+
+ Constrained_Stms := Statements (Handled_Statement_Sequence (Decl));
+ Append_To (Stms,
Make_Block_Statement (Loc,
- Declarations => New_List (
- Make_Object_Declaration (Loc,
- Defining_Identifier => Tmp,
- Object_Definition =>
- Make_Subtype_Indication (Loc,
- Subtype_Mark => New_Occurrence_Of (Typ, Loc),
- Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints => Cstr)))),
- Handled_Statement_Sequence =>
- Handled_Statement_Sequence (Decl));
-
- Append_To (Stms, Block);
-
- Append_To (Statements (Handled_Statement_Sequence (Block)),
+ Declarations => Dcls,
+ Handled_Statement_Sequence => Parent (Constrained_Stms)));
+
+ Append_To (Constrained_Stms,
+ Make_Implicit_If_Statement (Pnam,
+ Condition =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Copy_Tree (Out_Formal),
+ Attribute_Name => Name_Constrained),
+ Then_Statements => Discriminant_Checks));
+
+ Append_To (Constrained_Stms,
Make_Assignment_Statement (Loc,
- Name => Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Pnam, Loc),
- Selector_Name => Make_Identifier (Loc, Name_V)),
+ Name => Out_Formal,
Expression => Make_Identifier (Loc, Name_V)));
if Is_Unchecked_Union (Typ) then
Reason => PE_Unchecked_Union_Restriction));
end if;
+ Set_Declarations (Decl, Tmps_For_Discs);
Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stms));
function Make_Init_Proc_Name (Typ : Entity_Id) return Name_Id is
begin
- Get_Name_String (Chars (Typ));
- Name_Len := Name_Len + 2;
- Name_Buffer (Name_Len - 1) := TSS_Init_Proc (1);
- Name_Buffer (Name_Len) := TSS_Init_Proc (2);
- return Name_Find;
+ return Make_TSS_Name (Typ, TSS_Init_Proc);
end Make_Init_Proc_Name;
-------------------------
is
begin
Get_Name_String (Chars (Typ));
- Add_Char_To_Name_Buffer (Nam (1));
- Add_Char_To_Name_Buffer (Nam (2));
Add_Char_To_Name_Buffer ('_');
Add_Nat_To_Name_Buffer (Increment_Serial_Number);
+ Add_Char_To_Name_Buffer (Nam (1));
+ Add_Char_To_Name_Buffer (Nam (2));
return Name_Find;
end Make_TSS_Name_Local;
-- TSS Naming --
----------------
- -- A TSS is identified by its Chars name. The name has the form typXY,
- -- where typ is the type name, and XY are two characters that identify
- -- the particular TSS routine, using the following codes:
+ -- A TSS is identified by its Chars name. The name has the form typXY or
+ -- typ_<serial>XY, where typ is the type name, and XY are two characters
+ -- that identify the particular TSS routine. A unique serial number is
+ -- included for the case where several local instances of the same TSS
+ -- must be generated (see discussion under Make_TSS_Name_Local).
+
+ -- The following codes are used to denote TSSs:
-- Note: When making additions to this list, update the list in snames.adb
function Make_TSS_Name_Local
(Typ : Entity_Id;
Nam : TSS_Name_Type) return Name_Id;
- -- Similar to the above call, but a string of the form _nnn is appended
- -- to the name, where nnn is a unique serial number. This is used when
- -- multiple instances of the same TSS routine may be generated in the
- -- same scope (see also discussion above of current limitations).
+ -- Similar to the above call, but a string of the form _nnn is inserted
+ -- before the TSS code suffix, where nnn is a unique serial number. This
+ -- is used when multiple instances of the same TSS routine may be
+ -- generated in the same scope (see also discussion above of current
+ -- limitations).
function Make_Init_Proc_Name (Typ : Entity_Id) return Name_Id;
-- Version for init procs, same as Make_TSS_Name (Typ, TSS_Init_Proc)
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
Atype : Entity_Id;
procedure Check_Current_Instance (Comp_Decl : Node_Id);
- -- Check that an Access or Unchecked_Access attribute with
- -- a prefix which is the current instance type can only be
- -- applied when the type is limited.
+ -- Check that an Access or Unchecked_Access attribute with a prefix
+ -- which is the current instance type can only be applied when the type
+ -- is limited.
function After_Last_Declaration return Boolean;
-- If Loc is a freeze_entity that appears after the last declaration
-- in the scope, inhibit error messages on late completion.
procedure Freeze_Record_Type (Rec : Entity_Id);
- -- Freeze each component, handle some representation clauses, and
- -- freeze primitive operations if this is a tagged type.
+ -- Freeze each component, handle some representation clauses, and freeze
+ -- primitive operations if this is a tagged type.
----------------------------
-- After_Last_Declaration --
elsif Is_Integer_Type (E) then
Adjust_Esize_For_Alignment (E);
- elsif Is_Access_Type (E)
- and then No (Associated_Storage_Pool (E))
- then
- Check_Restriction (No_Standard_Storage_Pools, E);
+ elsif Is_Access_Type (E) then
+
+ -- Check restriction for standard storage pool
+
+ if No (Associated_Storage_Pool (E)) then
+ Check_Restriction (No_Standard_Storage_Pools, E);
+ end if;
+
+ -- Deal with error message for pure access type. This is not an
+ -- error in Ada 2005 if there is no pool (see AI-366).
+
+ if Is_Pure_Unit_Access_Type (E)
+ and then (Ada_Version < Ada_05
+ or else not No_Pool_Assigned (E))
+ then
+ Error_Msg_N ("named access type not allowed in pure unit", E);
+ end if;
end if;
+ -- Case of composite types
+
if Is_Composite_Type (E) then
- -- AI-117 requires that all new primitives of a tagged type
- -- must inherit the convention of the full view of the type.
- -- Inherited and overriding operations are defined to inherit
- -- the convention of their parent or overridden subprogram
- -- (also specified in AI-117), and that will have occurred
- -- earlier (in Derive_Subprogram and New_Overloaded_Entity).
- -- Here we set the convention of primitives that are still
- -- convention Ada, which will ensure that any new primitives
- -- inherit the type's convention. Class-wide types can have
- -- a foreign convention inherited from their specific type,
- -- but are excluded from this since they don't have any
- -- associated primitives.
+ -- AI-117 requires that all new primitives of a tagged type must
+ -- inherit the convention of the full view of the type. Inherited
+ -- and overriding operations are defined to inherit the convention
+ -- of their parent or overridden subprogram (also specified in
+ -- AI-117), and that will have occurred earlier (in
+ -- Derive_Subprogram and New_Overloaded_Entity). Here we set the
+ -- convention of primitives that are still convention Ada, which
+ -- will ensure that any new primitives inherit the type's
+ -- convention. Class-wide types can have a foreign convention
+ -- inherited from their specific type, but are excluded from this
+ -- since they don't have any associated primitives.
if Is_Tagged_Type (E)
and then not Is_Class_Wide_Type (E)
and then not Is_Class_Wide_Type (E)
then
declare
- Prim_List : constant Elist_Id := Primitive_Operations (E);
+ Prim_List : Elist_Id;
Prim : Elmt_Id;
Ent : Entity_Id;
begin
+ -- Ada 2005 (AI-345): In case of concurrent type generate
+ -- reference to the wrapper that allow us to dispatch calls
+ -- through their implemented abstract interface types.
+
+ -- The check for Present here is to protect against previously
+ -- reported critical errors.
+
+ if Is_Concurrent_Type (E)
+ and then Present (Corresponding_Record_Type (E))
+ then
+ pragma Assert (not Is_Empty_Elmt_List
+ (Abstract_Interfaces
+ (Corresponding_Record_Type (E))));
+
+ Prim_List := Primitive_Operations
+ (Corresponding_Record_Type (E));
+ else
+ Prim_List := Primitive_Operations (E);
+ end if;
+
+ -- Loop to generate references for primitive operations
+
Prim := First_Elmt (Prim_List);
while Present (Prim) loop
Ent := Node (Prim);
- -- If the operation is derived, get the original for
- -- cross-reference purposes (it is the original for
- -- which we want the xref, and for which the comes
- -- from source test needs to be performed).
+ -- If the operation is derived, get the original for cross-
+ -- reference purposes (it is the original for which we want
+ -- the xref, and for which the comes from source test needs
+ -- to be performed).
while Present (Alias (Ent)) loop
Ent := Alias (Ent);
-- Start of processing for Freeze_Expression
begin
- -- Immediate return if freezing is inhibited. This flag is set by
- -- the analyzer to stop freezing on generated expressions that would
- -- cause freezing if they were in the source program, but which are
- -- not supposed to freeze, since they are created.
+ -- Immediate return if freezing is inhibited. This flag is set by the
+ -- analyzer to stop freezing on generated expressions that would cause
+ -- freezing if they were in the source program, but which are not
+ -- supposed to freeze, since they are created.
if Must_Not_Freeze (N) then
return;
case Nkind (Parent_P) is
- -- A special test for the exception of (RM 13.14(8)) for the
- -- case of per-object expressions (RM 3.8(18)) occurring in a
- -- component definition or a discrete subtype definition. Note
- -- that we test for a component declaration which includes both
- -- cases we are interested in, and furthermore the tree does not
- -- have explicit nodes for either of these two constructs.
+ -- A special test for the exception of (RM 13.14(8)) for the case
+ -- of per-object expressions (RM 3.8(18)) occurring in component
+ -- definition or a discrete subtype definition. Note that we test
+ -- for a component declaration which includes both cases we are
+ -- interested in, and furthermore the tree does not have explicit
+ -- nodes for either of these two constructs.
when N_Component_Declaration =>
end if;
end if;
- -- If we have an enumeration literal that appears as the
- -- choice in the aggregate of an enumeration representation
- -- clause, then freezing does not occur (RM 13.14(10)).
+ -- If we have an enumeration literal that appears as the choice in
+ -- the aggregate of an enumeration representation clause, then
+ -- freezing does not occur (RM 13.14(10)).
when N_Enumeration_Representation_Clause =>
when N_Handled_Sequence_Of_Statements =>
- -- An exception occurs when the sequence of statements is
- -- for an expander generated body that did not do the usual
- -- freeze all operation. In this case we usually want to
- -- freeze outside this body, not inside it, and we skip
- -- past the subprogram body that we are inside.
+ -- An exception occurs when the sequence of statements is for
+ -- an expander generated body that did not do the usual freeze
+ -- all operation. In this case we usually want to freeze
+ -- outside this body, not inside it, and we skip past the
+ -- subprogram body that we are inside.
if In_Exp_Body (Parent_P) then
-- Note: The N_Loop_Statement is a special case. A type that
-- appears in the source can never be frozen in a loop (this
- -- occurs only because of a loop expanded by the expander),
- -- so we keep on going. Otherwise we terminate the search.
- -- Same is true of any entity which comes from source. (if they
- -- have a predefined type, that type does not appear to come
- -- from source, but the entity should not be frozen here).
+ -- occurs only because of a loop expanded by the expander), so we
+ -- keep on going. Otherwise we terminate the search. Same is true
+ -- of any entity which comes from source. (if they have a
+ -- predefined type, that type does not appear to come from source,
+ -- but the entity should not be frozen here).
when N_Loop_Statement =>
exit when not Comes_From_Source (Etype (N))
P := Parent_P;
end loop;
- -- If the expression appears in a record or an initialization
- -- procedure, the freeze nodes are collected and attached to
- -- the current scope, to be inserted and analyzed on exit from
- -- the scope, to insure that generated entities appear in the
- -- correct scope. If the expression is a default for a discriminant
- -- specification, the scope is still void. The expression can also
- -- appear in the discriminant part of a private or concurrent type.
+ -- If the expression appears in a record or an initialization procedure,
+ -- the freeze nodes are collected and attached to the current scope, to
+ -- be inserted and analyzed on exit from the scope, to insure that
+ -- generated entities appear in the correct scope. If the expression is
+ -- a default for a discriminant specification, the scope is still void.
+ -- The expression can also appear in the discriminant part of a private
+ -- or concurrent type.
-- If the expression appears in a constrained subcomponent of an
- -- enclosing record declaration, the freeze nodes must be attached
- -- to the outer record type so they can eventually be placed in the
+ -- enclosing record declaration, the freeze nodes must be attached to
+ -- the outer record type so they can eventually be placed in the
-- enclosing declaration list.
-- The other case requiring this special handling is if we are in
-- Freeze_Fixed_Point_Type --
-----------------------------
- -- Certain fixed-point types and subtypes, including implicit base
- -- types and declared first subtypes, have not yet set up a range.
- -- This is because the range cannot be set until the Small and Size
- -- values are known, and these are not known till the type is frozen.
+ -- Certain fixed-point types and subtypes, including implicit base types
+ -- and declared first subtypes, have not yet set up a range. This is
+ -- because the range cannot be set until the Small and Size values are
+ -- known, and these are not known till the type is frozen.
- -- To signal this case, Scalar_Range contains an unanalyzed syntactic
- -- range whose bounds are unanalyzed real literals. This routine will
- -- recognize this case, and transform this range node into a properly
- -- typed range with properly analyzed and resolved values.
+ -- To signal this case, Scalar_Range contains an unanalyzed syntactic range
+ -- whose bounds are unanalyzed real literals. This routine will recognize
+ -- this case, and transform this range node into a properly typed range
+ -- with properly analyzed and resolved values.
procedure Freeze_Fixed_Point_Type (Typ : Entity_Id) is
Rng : constant Node_Id := Scalar_Range (Typ);
end if;
-- Compute the fudged bounds. If the number is a model number,
- -- then we do nothing to include it, but we are allowed to
- -- backoff to the next adjacent model number when we exclude
- -- it. If it is not a model number then we straddle the two
- -- values with the model numbers on either side.
+ -- then we do nothing to include it, but we are allowed to backoff
+ -- to the next adjacent model number when we exclude it. If it is
+ -- not a model number then we straddle the two values with the
+ -- model numbers on either side.
Model_Num := UR_Trunc (Loval / Small) * Small;
Actual_Hi := Hival_Incl_EP;
end if;
- -- One pathological case: normally we never fudge a low
- -- bound down, since it would seem to increase the size
- -- (if it has any effect), but for ranges containing a
- -- single value, or no values, the high bound can be
- -- small too large. Consider:
+ -- One pathological case: normally we never fudge a low bound
+ -- down, since it would seem to increase the size (if it has
+ -- any effect), but for ranges containing single value, or no
+ -- values, the high bound can be small too large. Consider:
-- type t is delta 2.0**(-14)
-- range 131072.0 .. 0;
- -- That lower bound is *just* outside the range of 32
- -- bits, and does need fudging down in this case. Note
- -- that the bounds will always have crossed here, since
- -- the high bound will be fudged down if necessary, as
- -- in the case of:
+ -- That lower bound is *just* outside the range of 32 bits, and
+ -- does need fudging down in this case. Note that the bounds
+ -- will always have crossed here, since the high bound will be
+ -- fudged down if necessary, as in the case of:
-- type t is delta 2.0**(-14)
-- range 131072.0 .. 131072.0;
- -- So we can detect the situation by looking for crossed
- -- bounds, and if the bounds are crossed, and the low
- -- bound is greater than zero, we will always back it
- -- off by small, since this is completely harmless.
+ -- So we detect the situation by looking for crossed bounds,
+ -- and if the bounds are crossed, and the low bound is greater
+ -- than zero, we will always back it off by small, since this
+ -- is completely harmless.
if Actual_Lo > Actual_Hi then
if UR_Is_Positive (Actual_Lo) then
Adjust_Esize_For_Alignment (Typ);
end if;
- -- If we have a base type, then expand the bounds so that they
- -- extend to the full width of the allocated size in bits, to
- -- avoid junk range checks on intermediate computations.
+ -- If we have a base type, then expand the bounds so that they extend to
+ -- the full width of the allocated size in bits, to avoid junk range
+ -- checks on intermediate computations.
if Base_Type (Typ) = Typ then
Set_Realval (Lo, -(Small * (Uint_2 ** (Actual_Size - 1))));
Set_Analyzed (Lo, False);
Analyze (Lo);
- -- Resolve with universal fixed if the base type, and the base
- -- type if it is a subtype. Note we can't resolve the base type
- -- with itself, that would be a reference before definition.
+ -- Resolve with universal fixed if the base type, and the base type if
+ -- it is a subtype. Note we can't resolve the base type with itself,
+ -- that would be a reference before definition.
if Typ = Btyp then
Resolve (Lo, Universal_Fixed);
begin
Ensure_Type_Is_SA (Etype (E));
- -- Reset True_Constant flag, since something strange is going on
- -- with the scoping here, and our simple value tracing may not
- -- be sufficient for this indication to be reliable. We kill the
- -- Constant_Value indication for the same reason.
+ -- Reset True_Constant flag, since something strange is going on with
+ -- the scoping here, and our simple value tracing may not be sufficient
+ -- for this indication to be reliable. We kill the Constant_Value
+ -- indication for the same reason.
Set_Is_True_Constant (E, False);
Set_Current_Value (E, Empty);
-- Reset the Pure indication on an imported subprogram unless an
-- explicit Pure_Function pragma was present. We do this because
-- otherwise it is an insidious error to call a non-pure function
- -- from a pure unit and have calls mysteriously optimized away.
- -- What happens here is that the Import can bypass the normal
- -- check to ensure that pure units call only pure subprograms.
+ -- from pure unit and have calls mysteriously optimized away. What
+ -- happens here is that the Import can bypass the normal check to
+ -- ensure that pure units call only pure subprograms.
if Is_Imported (E)
and then Is_Pure (E)
null;
-- If the return type is generic, we have emitted a warning
- -- earlier on, and there is nothing else to check here.
- -- Specific instantiations may lead to erroneous behavior.
+ -- earlier on, and there is nothing else to check here. Specific
+ -- instantiations may lead to erroneous behavior.
elsif Is_Generic_Type (Etype (E)) then
null;
end if;
-- If any of the formals for an exported foreign convention
- -- subprogram have defaults, then emit an appropriate warning
- -- since this is odd (default cannot be used from non-Ada code)
+ -- subprogram have defaults, then emit an appropriate warning since
+ -- this is odd (default cannot be used from non-Ada code)
if Is_Exported (E) then
F := First_Formal (E);
end loop;
end if;
end if;
+
+ -- Pragma Inline_Always is disallowed for dispatching subprograms
+ -- because the address of such subprograms is saved in the dispatch
+ -- table to support dispatching calls, and dispatching calls cannot
+ -- be inlined. This is consistent with the restriction against using
+ -- 'Access or 'Address on an Inline_Always subprogram.
+
+ if Is_Dispatching_Operation (E) and then Is_Always_Inlined (E) then
+ Error_Msg_N
+ ("pragma Inline_Always not allowed for dispatching subprograms", E);
+ end if;
end Freeze_Subprogram;
----------------------
return;
end if;
- -- We only give the warning for non-imported entities of a type
- -- for which a non-null base init proc is defined (or for access
- -- types which have implicit null initialization).
+ -- We only give the warning for non-imported entities of a type for
+ -- which a non-null base init proc is defined (or for access types which
+ -- have implicit null initialization).
if Present (Expr)
and then (Has_Non_Null_Base_Init_Proc (Typ)
elsif Token = Tok_Separate then
Set_Unit (Comp_Unit_Node, P_Subunit);
- elsif Token = Tok_Procedure
- or else Token = Tok_Function
+ elsif Token = Tok_Function
+ or else Token = Tok_Not
+ or else Token = Tok_Overriding
+ or else Token = Tok_Procedure
then
Set_Unit (Comp_Unit_Node, P_Subprogram (Pf_Decl_Gins_Pbod_Rnam));
-- SUBPROGRAM_DEFAULT ::= DEFAULT_NAME | <>
- -- DEFAULT_NAME ::= NAME
+ -- DEFAULT_NAME ::= NAME | null
-- The caller has checked that the initial tokens are WITH FUNCTION or
-- WITH PROCEDURE, and the initial WITH has been scanned out.
+ -- A null default is an Ada 2005 feature.
+
-- Error recovery: cannot raise Error_Resync
function P_Formal_Subprogram_Declaration return Node_Id is
Scan; -- past <>
T_Semicolon;
+ elsif Token = Tok_Null then
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP
+ ("null default subprograms are an Ada 2005 extension");
+ Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
+ end if;
+
+ if Nkind (Spec_Node) = N_Procedure_Specification then
+ Set_Null_Present (Spec_Node);
+ else
+ Error_Msg_SP ("only procedures can be null");
+ end if;
+
+ Scan; -- past NULL
+ T_Semicolon;
+
else
Set_Default_Name (Def_Node, P_Name);
T_Semicolon;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
function P_Defining_Operator_Symbol return Node_Id;
procedure Check_Junk_Semicolon_Before_Return;
+
-- Check for common error of junk semicolon before RETURN keyword of
-- function specification. If present, skip over it with appropriate
-- error message, leaving Scan_Ptr pointing to the RETURN after. This
if Token = Tok_Return then
Restore_Scan_State (Scan_State);
- Error_Msg_SC ("Unexpected semicolon ignored");
+ Error_Msg_SC ("unexpected semicolon ignored");
Scan; -- rescan past junk semicolon
else
-- | function DEFINING_DESIGNATOR is
-- new generic_function_NAME [GENERIC_ACTUAL_PART];
+ -- NULL_PROCEDURE_DECLARATION ::=
+ -- SUBPROGRAM_SPECIFICATION is null;
+
+ -- Null procedures are an Ada 2005 feature. A null procedure declaration
+ -- is classified as a basic declarative item, but it is parsed here, with
+ -- other subprogram constructs.
+
-- The value in Pf_Flags indicates which of these possible declarations
-- is acceptable to the caller:
-- context is issued. The only possible values for Pf_Flags are those
-- defined as constants in the Par package.
- -- The caller has checked that the initial token is FUNCTION or PROCEDURE
+ -- The caller has checked that the initial token is FUNCTION, PROCEDURE,
+ -- NOT or OVERRIDING.
-- Error recovery: cannot raise Error_Resync
Func : Boolean;
Scan_State : Saved_Scan_State;
+ -- Flags for optional overriding indication. Two flags are needed,
+ -- to distinguish positive and negative overriding indicators from
+ -- the absence of any indicator.
+
+ Is_Overriding : Boolean := False;
+ Not_Overriding : Boolean := False;
+
begin
-- Set up scope stack entry. Note that the Labl field will be set later
Scope.Table (Scope.Last).Ecol := Start_Column;
Scope.Table (Scope.Last).Lreq := False;
+ -- Ada2005: scan leading overriding indicator.
+
+ if Token = Tok_Not then
+ Scan; -- past NOT
+
+ if Token = Tok_Overriding then
+ Scan; -- past OVERRIDING
+ Not_Overriding := True;
+ else
+ Error_Msg_SC ("OVERRIDING expected!");
+ end if;
+
+ elsif Token = Tok_Overriding then
+ Scan; -- past OVERRIDING
+ Is_Overriding := True;
+ end if;
+
+ if (Is_Overriding or else Not_Overriding) then
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP (" overriding indicator is an Ada 2005 extension");
+ Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
+
+ -- An overriding indicator is allowed for subprogram declarations,
+ -- bodies, renamings, stubs, and instantiations.
+
+ elsif Pf_Flags /= Pf_Decl_Gins_Pbod_Rnam_Stub then
+ Error_Msg_SC ("overriding indicator not allowed here!");
+
+ elsif Token /= Tok_Function
+ and then Token /= Tok_Procedure
+ then
+ Error_Msg_SC ("FUNCTION or PROCEDURE expected!");
+ end if;
+ end if;
+
Func := (Token = Tok_Function);
Fproc_Sloc := Token_Ptr;
Scan; -- past FUNCTION or PROCEDURE
if Token = Tok_Is then
Save_Scan_State (Scan_State); -- at the IS
- T_Is; -- checks for redundant IS's
+ T_Is; -- checks for redundant IS
if Token = Tok_New then
if not Pf_Flags.Gins then
Set_Generic_Associations (Inst_Node, P_Generic_Actual_Part_Opt);
TF_Semicolon;
Pop_Scope_Stack; -- Don't need scope stack entry in this case
+
+ if Is_Overriding then
+ Set_Must_Override (Inst_Node);
+
+ elsif Not_Overriding then
+ Set_Must_Not_Override (Inst_Node);
+ end if;
+
return Inst_Node;
else
Set_Defining_Unit_Name (Specification_Node, Name_Node);
Set_Parameter_Specifications (Specification_Node, Fpart_List);
+ if Is_Overriding then
+ Set_Must_Override (Specification_Node);
+
+ elsif Not_Overriding then
+ Set_Must_Not_Override (Specification_Node);
+ end if;
+
-- Error check: barriers not allowed on protected functions/procedures
if Token = Tok_When then
TF_Semicolon;
return Absdec_Node;
+ -- Ada 2005 (AI-248): Parse a null procedure declaration
+
+ elsif Token = Tok_Null then
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP ("null procedures are an Ada 2005 extension");
+ Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
+ end if;
+
+ Scan; -- past NULL
+
+ if Func then
+ Error_Msg_SP ("only procedures can be null");
+ else
+ Set_Null_Present (Specification_Node);
+ end if;
+
+ TF_Semicolon;
+ goto Subprogram_Declaration;
+
-- Check for IS NEW with Formal_Part present and handle nicely
elsif Token = Tok_New then
end if;
Scan; -- past WITH
+
+ if Token = Tok_Private then
+ Error_Msg_SP
+ ("PRIVATE not allowed in task type declaration");
+ end if;
end if;
Set_Task_Definition (Task_Node, P_Task_Definition);
-- Deal gracefully with multiple PRIVATE parts
while Token = Tok_Private loop
- Error_Msg_SC ("Only one private part allowed per task");
+ Error_Msg_SC ("only one private part allowed per task");
Scan; -- past PRIVATE
Append_List (P_Task_Items, Private_Declarations (Def_Node));
end loop;
if Token = Tok_Pragma then
Append (P_Pragma, Items);
- elsif Token = Tok_Entry then
+ -- Ada 2005 (AI-397): Reserved words NOT and OVERRIDING
+ -- may begin an entry declaration.
+
+ elsif Token = Tok_Entry
+ or else Token = Tok_Not
+ or else Token = Tok_Overriding
+ then
Append (P_Entry_Declaration, Items);
elsif Token = Tok_For then
elsif Token = Tok_Identifier
or else Token in Token_Class_Declk
then
- Error_Msg_SC ("Illegal declaration in task definition");
+ Error_Msg_SC ("illegal declaration in task definition");
Resync_Past_Semicolon;
else
end if;
Scan; -- past WITH
+
+ if Token = Tok_Private then
+ Error_Msg_SP
+ ("PRIVATE not allowed in protected type declaration");
+ end if;
end if;
Set_Protected_Definition (Protected_Node, P_Protected_Definition);
L : List_Id;
P : Source_Ptr;
+ function P_Entry_Or_Subprogram_With_Indicator return Node_Id;
+ -- Ada 2005 (AI-397): Parse an entry or a subprogram with an overriding
+ -- indicator. The caller has checked that the initial token is NOT or
+ -- OVERRIDING.
+
+ ------------------------------------------
+ -- P_Entry_Or_Subprogram_With_Indicator --
+ ------------------------------------------
+
+ function P_Entry_Or_Subprogram_With_Indicator return Node_Id is
+ Decl : Node_Id := Error;
+ Is_Overriding : Boolean := False;
+ Not_Overriding : Boolean := False;
+
+ begin
+ if Token = Tok_Not then
+ Scan; -- past NOT
+
+ if Token = Tok_Overriding then
+ Scan; -- past OVERRIDING
+ Not_Overriding := True;
+ else
+ Error_Msg_SC ("OVERRIDING expected!");
+ end if;
+
+ else
+ Scan; -- past OVERRIDING
+ Is_Overriding := True;
+ end if;
+
+ if (Is_Overriding or else Not_Overriding) then
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP (" overriding indicator is an Ada 2005 extension");
+ Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
+
+ elsif Token = Tok_Entry then
+ Decl := P_Entry_Declaration;
+
+ Set_Must_Override (Decl, Is_Overriding);
+ Set_Must_Not_Override (Decl, Not_Overriding);
+
+ elsif Token = Tok_Function or else Token = Tok_Procedure then
+ Decl := P_Subprogram (Pf_Decl);
+
+ Set_Must_Override (Specification (Decl), Is_Overriding);
+ Set_Must_Not_Override (Specification (Decl), Not_Overriding);
+
+ else
+ Error_Msg_SC ("ENTRY, FUNCTION or PROCEDURE expected!");
+ end if;
+ end if;
+
+ return Decl;
+ end P_Entry_Or_Subprogram_With_Indicator;
+
+ -- Start of processing for P_Protected_Operation_Declaration_Opt
+
begin
-- This loop runs more than once only when a junk declaration
-- is skipped.
if Token = Tok_Pragma then
return P_Pragma;
+ elsif Token = Tok_Not or else Token = Tok_Overriding then
+ return P_Entry_Or_Subprogram_With_Indicator;
+
elsif Token = Tok_Entry then
return P_Entry_Declaration;
------------------------------
-- ENTRY_DECLARATION ::=
+ -- [OVERRIDING_INDICATOR]
-- entry DEFINING_IDENTIFIER [(DISCRETE_SUBTYPE_DEFINITION)]
-- PARAMETER_PROFILE;
- -- The caller has checked that the initial token is ENTRY
+ -- The caller has checked that the initial token is ENTRY, NOT or
+ -- OVERRIDING.
-- Error recovery: cannot raise Error_Resync
Decl_Node : Node_Id;
Scan_State : Saved_Scan_State;
+ -- Flags for optional overriding indication. Two flags are needed,
+ -- to distinguish positive and negative overriding indicators from
+ -- the absence of any indicator.
+
+ Is_Overriding : Boolean := False;
+ Not_Overriding : Boolean := False;
+
begin
+ -- Ada 2005 (AI-397): Scan leading overriding indicator.
+
+ if Token = Tok_Not then
+ Scan; -- past NOT
+
+ if Token = Tok_Overriding then
+ Scan; -- part OVERRIDING
+ Not_Overriding := True;
+ else
+ Error_Msg_SC ("OVERRIDING expected!");
+ end if;
+
+ elsif Token = Tok_Overriding then
+ Scan; -- part OVERRIDING
+ Is_Overriding := True;
+ end if;
+
+ if (Is_Overriding or else Not_Overriding) then
+ if Ada_Version < Ada_05 then
+ Error_Msg_SP (" overriding indicator is an Ada 2005 extension");
+ Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
+
+ elsif Token /= Tok_Entry then
+ Error_Msg_SC ("ENTRY expected!");
+ end if;
+ end if;
+
Decl_Node := New_Node (N_Entry_Declaration, Token_Ptr);
Scan; -- past ENTRY
end if;
end if;
+ if Is_Overriding then
+ Set_Must_Override (Decl_Node);
+ elsif Not_Overriding then
+ Set_Must_Not_Override (Decl_Node);
+ end if;
+
-- Error recovery check for illegal return
if Token = Tok_Return then
with Interfaces; use Interfaces;
with System.Img_Char; use System.Img_Char;
-with System.WCh_Con; use System.WCh_Con;
-with System.WCh_WtS; use System.WCh_WtS;
package body System.Img_WChar is
--------------------------
function Image_Wide_Character
- (V : Wide_Character;
- EM : WC_Encoding_Method) return String
+ (V : Wide_Character) return String
is
- Val : constant Unsigned_16 := Wide_Character'Pos (V);
- WS : Wide_String (1 .. 3);
-
begin
- -- If in range of standard character, use standard character routine
-
- if Val < 16#80#
- or else (Val <= 16#FF#
- and then EM not in WC_Upper_Half_Encoding_Method)
- then
- return Image_Character (Character'Val (Val));
-
- -- if the value is one of the last two characters in the type, use
- -- their language-defined names (3.5.2(3)).
-
- elsif Val = 16#FFFE# then
- return "FFFE";
-
- elsif Val = 16#FFFF# then
- return "FFFF";
-
- -- Otherwise return an appropriate escape sequence (i.e. one matching
- -- the convention implemented by Scn.Wide_Char). The easiest thing is
- -- to build a wide string for the result, and then use the Wide_Value
- -- function to build the resulting String.
-
- else
- WS (1) := ''';
- WS (2) := V;
- WS (3) := ''';
-
- return Wide_String_To_String (WS, EM);
- end if;
+ return
+ Image_Wide_Wide_Character
+ (Wide_Wide_Character'Val (Wide_Character'Pos (V)));
end Image_Wide_Character;
-------------------------------
-------------------------------
function Image_Wide_Wide_Character
- (V : Wide_Wide_Character;
- EM : WC_Encoding_Method) return String
+ (V : Wide_Wide_Character) return String
is
- Val : constant Unsigned_32 := Wide_Wide_Character'Pos (V);
- WS : Wide_Wide_String (1 .. 3);
+ Val : Unsigned_32 := Wide_Wide_Character'Pos (V);
begin
- -- If in range of standard Wide_Character, then we use the
- -- Wide_Character routine
+ -- If in range of standard Character, use Character routine
- if Val <= 16#FFFF# then
- return Image_Wide_Character (Wide_Character'Val (Val), EM);
+ if Val <= 16#FF# then
+ return Image_Character (Character'Val (Wide_Wide_Character'Pos (V)));
- -- Otherwise return an appropriate escape sequence (i.e. one matching
- -- the convention implemented by Scn.Wide_Wide_Char). The easiest thing
- -- is to build a wide string for the result, and then use the
- -- Wide_Wide_Value function to build the resulting String.
+ -- Otherwise value returned is Hex_hhhhhhhh
else
- WS (1) := ''';
- WS (2) := V;
- WS (3) := ''';
-
- return Wide_Wide_String_To_String (WS, EM);
+ declare
+ Result : String (1 .. 12) := "Hex_hhhhhhhh";
+ Hex : constant array (Unsigned_32 range 0 .. 15) of Character :=
+ "0123456789ABCDEF";
+
+ begin
+ for J in reverse 5 .. 12 loop
+ Result (J) := Hex (Val mod 16);
+ Val := Val / 16;
+ end loop;
+
+ return Result;
+ end;
end if;
end Image_Wide_Wide_Character;
------------------------------------------------------------------------------
-- --
--- GNAT RUNTIME COMPONENTS --
+-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . I M G _ W C H A R --
-- --
-- Wide_[Wide_]Character'Image
-with System.WCh_Con;
-
package System.Img_WChar is
pragma Pure (Img_WChar);
- function Image_Wide_Character
- (V : Wide_Character;
- EM : System.WCh_Con.WC_Encoding_Method) return String;
- -- Computes Wide_Character'Image (V) and returns the computed result,
- -- The argument EM is a constant representing the encoding method in use.
- -- The encoding method used is guaranteed to be consistent across a
- -- given program execution and to correspond to the method used in the
- -- source programs.
+ function Image_Wide_Character (V : Wide_Character) return String;
+ -- Computes Wide_Character'Image (V) and returns the computed result
- function Image_Wide_Wide_Character
- (V : Wide_Wide_Character;
- EM : System.WCh_Con.WC_Encoding_Method) return String;
- -- Computes Wide_Wide_Character'Image (V) and returns the computed result,
- -- The argument EM is a constant representing the encoding method in use.
- -- The encoding method used is guaranteed to be consistent across a
- -- given program execution and to correspond to the method used in the
- -- source programs.
+ function Image_Wide_Wide_Character (V : Wide_Wide_Character) return String;
+ -- Computes Wide_Wide_Character'Image (V) and returns the computed result
end System.Img_WChar;
with Interfaces; use Interfaces;
with System.Val_Util; use System.Val_Util;
-with System.WCh_Con; use System.WCh_Con;
-with System.WCh_StW; use System.WCh_StW;
package body System.Val_WChar is
--------------------------
function Value_Wide_Character
- (Str : String;
- EM : WC_Encoding_Method) return Wide_Character
+ (Str : String) return Wide_Character
is
- WWC : constant Wide_Wide_Character :=
- Value_Wide_Wide_Character (Str, EM);
- WWV : constant Unsigned_32 := Wide_Wide_Character'Pos (WWC);
+ WWC : constant Wide_Wide_Character := Value_Wide_Wide_Character (Str);
+ WWV : constant Unsigned_32 := Wide_Wide_Character'Pos (WWC);
begin
if WWV > 16#FFFF# then
- raise Constraint_Error;
+ raise Constraint_Error
+ with "out of range character for Value attribute";
else
return Wide_Character'Val (WWV);
end if;
-------------------------------
function Value_Wide_Wide_Character
- (Str : String;
- EM : System.WCh_Con.WC_Encoding_Method) return Wide_Wide_Character
+ (Str : String) return Wide_Wide_Character
is
F : Natural;
L : Natural;
if L - F = 2 then
return Wide_Wide_Character'Val (Character'Pos (S (F + 1)));
- -- Otherwise must be a wide character in quotes. The easiest
- -- thing is to convert the string to a wide wide string and then
- -- pick up the single character that it should contain.
+ -- Otherwise something is very wrong
else
- declare
- WS : constant Wide_Wide_String :=
- String_To_Wide_Wide_String (S (F + 1 .. L - 1), EM);
-
- begin
- if WS'Length /= 1 then
- raise Constraint_Error;
- else
- return WS (WS'First);
- end if;
- end;
+ raise Constraint_Error with "invalid string for Value attribute";
end if;
- -- the last two values of the type have language-defined names:
+ -- Deal with Hex_hhhhhhhh cases for wide_[wide_]character cases
- elsif S = "FFFE" then
- return Wide_Wide_Character'Val (16#FFFE#);
+ elsif Str'Length = 12 and then Str (1 .. 4) = "Hex_" then
+ declare
+ W : Unsigned_32 := 0;
- elsif S = "FFFF" then
- return Wide_Wide_Character'Val (16#FFFF#);
+ begin
+ for J in 5 .. 12 loop
+ W := W * 16 + Character'Pos (Str (J));
- -- Otherwise must be a control character
+ if Str (J) in '0' .. '9' then
+ W := W - Character'Pos ('0');
+ elsif Str (J) in 'A' .. 'F' then
+ W := W - Character'Pos ('A') + 10;
+ elsif Str (J) in 'a' .. 'f' then
+ W := W - Character'Pos ('a') + 10;
+ else
+ raise Constraint_Error
+ with "illegal hex character for Value attribute";
+ end if;
+ end loop;
- else
- for C in Character'Val (16#00#) .. Character'Val (16#1F#) loop
- if S (F .. L) = Character'Image (C) then
- return Wide_Wide_Character'Val (Character'Pos (C));
+ if W > 16#7FFF_FFFF# then
+ raise Constraint_Error
+ with "out of range value for Value attribute";
+ else
+ return Wide_Wide_Character'Val (W);
end if;
- end loop;
+ end;
- for C in Character'Val (16#7F#) .. Character'Val (16#9F#) loop
- if S (F .. L) = Character'Image (C) then
- return Wide_Wide_Character'Val (Character'Pos (C));
- end if;
- end loop;
+ -- Otherwise must be one of the special names for Character
- raise Constraint_Error;
+ else
+ return
+ Wide_Wide_Character'Val (Character'Pos (Character'Value (Str)));
end if;
end Value_Wide_Wide_Character;
-- Processing for Wide_[Wide_]Value attribute
-with System.WCh_Con;
-
package System.Val_WChar is
pragma Pure (Val_WChar);
function Value_Wide_Character
- (Str : String;
- EM : System.WCh_Con.WC_Encoding_Method) return Wide_Character;
- -- Computes Wide_Character'Value (Str).
+ (Str : String) return Wide_Character;
+ -- Computes Wide_Character'Value (Str)
function Value_Wide_Wide_Character
- (Str : String;
- EM : System.WCh_Con.WC_Encoding_Method) return Wide_Wide_Character;
- -- Computes Wide_Character'Value (Str).
+ (Str : String) return Wide_Wide_Character;
+ -- Computes Wide_Character'Value (Str)
end System.Val_WChar;
------------------------------------------------------------------------------
-- --
--- GNAT RUNTIME COMPONENTS --
+-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . W I D _ W C H A R --
-- --
-- --
------------------------------------------------------------------------------
-with System.WCh_Con; use System.WCh_Con;
-
package body System.Wid_WChar is
--------------------------
--------------------------
function Width_Wide_Character
- (Lo, Hi : Wide_Character;
- EM : WC_Encoding_Method) return Natural
+ (Lo, Hi : Wide_Character) return Natural
is
W : Natural;
P : Natural;
P := Wide_Character'Pos (C);
-- Here if we find a character in wide character range
+ -- Width is max value (12) for Hex_hhhhhhhh
if P > 16#FF# then
+ return 12;
- case EM is
-
- when WCEM_Hex =>
- return Natural'Max (W, 5);
-
- when WCEM_Upper =>
- return Natural'Max (W, 2);
-
- when WCEM_Shift_JIS =>
- return Natural'Max (W, 2);
-
- when WCEM_EUC =>
- return Natural'Max (W, 2);
-
- when WCEM_UTF8 =>
- if Hi > Wide_Character'Val (16#07FF#) then
- return Natural'Max (W, 3);
- else
- return Natural'Max (W, 2);
- end if;
-
- when WCEM_Brackets =>
- return Natural'Max (W, 8);
-
- end case;
-
- -- If we are in character range then use length of character image
+ -- If we are in character range then use length of character image
else
declare
-------------------------------
function Width_Wide_Wide_Character
- (Lo, Hi : Wide_Wide_Character;
- EM : WC_Encoding_Method) return Natural
+ (Lo, Hi : Wide_Wide_Character) return Natural
is
W : Natural;
P : Natural;
for C in Lo .. Hi loop
P := Wide_Wide_Character'Pos (C);
- -- Here if we find a character in wide wide character range
+ -- Here if we find a character in wide wide character range.
+ -- Width is max value (12) for Hex_hhhhhhhh
if P > 16#FF# then
- case EM is
- when WCEM_Hex =>
- return Natural'Max (W, 5);
-
- when WCEM_Upper =>
- return Natural'Max (W, 2);
-
- when WCEM_Shift_JIS =>
- return Natural'Max (W, 2);
-
- when WCEM_EUC =>
- return Natural'Max (W, 2);
-
- when WCEM_UTF8 =>
- if Hi > Wide_Wide_Character'Val (16#FFFF#) then
- return Natural'Max (W, 4);
- elsif Hi > Wide_Wide_Character'Val (16#07FF#) then
- return Natural'Max (W, 3);
- else
- return Natural'Max (W, 2);
- end if;
-
- when WCEM_Brackets =>
- return Natural'Max (W, 10);
-
- end case;
+ W := 12;
-- If we are in character range then use length of character image
------------------------------------------------------------------------------
-- --
--- GNAT RUNTIME COMPONENTS --
+-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . W I D _ W C H A R --
-- --
-- This package contains the routines used for Wide_[Wide_]Character'Width
-with System.WCh_Con;
-
package System.Wid_WChar is
pragma Pure (Wid_WChar);
function Width_Wide_Character
- (Lo, Hi : Wide_Character;
- EM : System.WCh_Con.WC_Encoding_Method) return Natural;
+ (Lo, Hi : Wide_Character) return Natural;
-- Compute Width attribute for non-static type derived from Wide_Character.
- -- The arguments are the low and high bounds for the type. EM is the
- -- wide-character encoding method.
+ -- The arguments are the low and high bounds for the type.
function Width_Wide_Wide_Character
- (Lo, Hi : Wide_Wide_Character;
- EM : System.WCh_Con.WC_Encoding_Method) return Natural;
+ (Lo, Hi : Wide_Wide_Character) return Natural;
-- Same function for type derived from Wide_Wide_Character
end System.Wid_WChar;
------------------------------------------------------------------------------
-- --
--- GNAT RUNTIME COMPONENTS --
+-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . W W D _ C H A R --
-- --
begin
W := 0;
for C in Lo .. Hi loop
- declare
- S : constant Wide_String := Character'Wide_Image (C);
- begin
- W := Natural'Max (W, S'Length);
- end;
+ -- For Character range, use length of image
+
+ if Character'Pos (C) < 256 then
+ declare
+ S : constant Wide_String := Character'Wide_Image (C);
+ begin
+ W := Natural'Max (W, S'Length);
+ end;
+
+ -- For wide character, always max out at 12 (Hex_hhhhhhhh)
+
+ else
+ return 12;
+ end if;
end loop;
return W;
begin
W := 0;
for C in Lo .. Hi loop
- declare
- S : constant Wide_Wide_String := Character'Wide_Wide_Image (C);
- begin
- W := Natural'Max (W, S'Length);
- end;
+
+ -- For Character range, use length of image
+
+ if Character'Pos (C) < 256 then
+ declare
+ S : constant String := Character'Image (C);
+ begin
+ W := Natural'Max (W, S'Length);
+ end;
+
+ -- For wide character, always max out at 12 (Hex_hhhhhhhh)
+
+ else
+ return 12;
+ end if;
end loop;
return W;
------------------------------------------------------------------------------
-- --
--- GNAT RUNTIME COMPONENTS --
+-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . W W D _ W C H A R --
-- --
function Wide_Wide_Width_Wide_Wide_Char
(Lo, Hi : Wide_Wide_Character) return Natural
is
- W : Natural := 0;
LV : constant Unsigned_32 := Wide_Wide_Character'Pos (Lo);
HV : constant Unsigned_32 := Wide_Wide_Character'Pos (Hi);
if LV > HV then
return 0;
- end if;
+
+ -- Return max value (12) for wide character (Hex_hhhhhhhh)
+
+ elsif HV > 255 then
+ return 12;
-- If any characters in normal character range, then use normal
-- Wide_Wide_Width attribute on this range to find out a starting point.
-- Otherwise start with zero.
- if LV <= 255 then
- W :=
+ else
+ return
System.WWd_Char.Wide_Wide_Width_Character
(Lo => Character'Val (LV),
Hi => Character'Val (Unsigned_32'Min (255, HV)));
- else
- W := 0;
end if;
-
- -- Increase to at least 4 if FFFE or FFFF present. These correspond
- -- to the special language defined names FFFE/FFFF for these values.
-
- if 16#FFFF# in LV .. HV or else 16#FFFE# in LV .. HV then
- W := Natural'Max (W, 4);
- end if;
-
- -- Increase to at least 3 if any wide characters, corresponding to
- -- the normal ' character ' sequence. We know that the character fits.
-
- if HV > 255 then
- W := Natural'Max (W, 3);
- end if;
-
- return W;
end Wide_Wide_Width_Wide_Wide_Char;
-------------------------------
function Wide_Width_Wide_Character
(Lo, Hi : Wide_Character) return Natural
is
- W : Natural := 0;
LV : constant Unsigned_32 := Wide_Character'Pos (Lo);
HV : constant Unsigned_32 := Wide_Character'Pos (Hi);
if LV > HV then
return 0;
- end if;
+
+ -- Return max value (12) for wide character (Hex_hhhhhhhh)
+
+ elsif HV > 255 then
+ return 12;
-- If any characters in normal character range, then use normal
-- Wide_Wide_Width attribute on this range to find out a starting point.
-- Otherwise start with zero.
- if LV <= 255 then
- W :=
+ else
+ return
System.WWd_Char.Wide_Width_Character
(Lo => Character'Val (LV),
Hi => Character'Val (Unsigned_32'Min (255, HV)));
- else
- W := 0;
- end if;
-
- -- Increase to at least 4 if FFFE or FFFF present. These correspond
- -- to the special language defined names FFFE/FFFF for these values.
-
- if 16#FFFF# in LV .. HV or else 16#FFFE# in LV .. HV then
- W := Natural'Max (W, 4);
end if;
-
- -- Increase to at least 3 if any wide characters, corresponding to
- -- the normal 'character' sequence. We know that the character fits.
-
- if HV > 255 then
- W := Natural'Max (W, 3);
- end if;
-
- return W;
end Wide_Width_Wide_Character;
------------------------------------
-- Wide_Width_Wide_Wide_Character --
------------------------------------
- -- This is a nasty case, because we get into the business of representing
- -- out of range wide wide characters as wide strings. Let's let image do
- -- the work here. Too bad if this takes lots of time. It's silly anyway!
-
function Wide_Width_Wide_Wide_Character
(Lo, Hi : Wide_Wide_Character) return Natural
is
- W : Natural;
-
begin
- W := 0;
- for J in Lo .. Hi loop
- declare
- S : constant Wide_String := Wide_Wide_Character'Wide_Image (J);
- begin
- W := Natural'Max (W, S'Length);
- end;
- end loop;
-
- return W;
+ return Wide_Wide_Width_Wide_Wide_Char (Lo, Hi);
end Wide_Width_Wide_Wide_Character;
end System.Wwd_WChar;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Einfo; use Einfo;
with Errout; use Errout;
with Eval_Fat;
-with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Expander; use Expander;
with Freeze; use Freeze;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with Urealp; use Urealp;
-with Widechar; use Widechar;
package body Sem_Attr is
It : Interp;
function Get_Kind (E : Entity_Id) return Entity_Kind;
- -- Distinguish between access to regular and protected
- -- subprograms.
+ -- Distinguish between access to regular/protected subprograms
--------------
-- Get_Kind --
-- subprogram itself as the designated type. Type-checking in
-- this case compares the signatures of the designated types.
+ Set_Etype (N, Any_Type);
+
if not Is_Overloaded (P) then
- Acc_Type :=
- New_Internal_Entity
- (Get_Kind (Entity (P)), Current_Scope, Loc, 'A');
- Set_Etype (Acc_Type, Acc_Type);
- Set_Directly_Designated_Type (Acc_Type, Entity (P));
- Set_Etype (N, Acc_Type);
+ if not Is_Intrinsic_Subprogram (Entity (P)) then
+ Acc_Type :=
+ New_Internal_Entity
+ (Get_Kind (Entity (P)), Current_Scope, Loc, 'A');
+ Set_Etype (Acc_Type, Acc_Type);
+ Set_Directly_Designated_Type (Acc_Type, Entity (P));
+ Set_Etype (N, Acc_Type);
+ end if;
else
Get_First_Interp (P, Index, It);
- Set_Etype (N, Any_Type);
-
while Present (It.Nam) loop
if not Is_Intrinsic_Subprogram (It.Nam) then
Acc_Type :=
Get_Next_Interp (Index, It);
end loop;
+ end if;
- if Etype (N) = Any_Type then
- Error_Attr ("prefix of % attribute cannot be intrinsic", P);
- end if;
+ if Etype (N) = Any_Type then
+ Error_Attr ("prefix of % attribute cannot be intrinsic", P);
end if;
end Build_Access_Subprogram_Type;
Check_Restriction (No_Implicit_Dynamic_Code, P);
end if;
+ if Is_Always_Inlined (Entity (P)) then
+ Error_Attr
+ ("prefix of % attribute cannot be Inline_Always subprogram",
+ P);
+ end if;
+
-- Build the appropriate subprogram type
Build_Access_Subprogram_Type (P);
Index : Entity_Id;
D : Int;
- -- Dimension number for array attributes.
+ -- Dimension number for array attributes
begin
-- Case of string literal or string literal subtype. These cases
procedure Check_Array_Type is
D : Int;
- -- Dimension number for array attributes.
+ -- Dimension number for array attributes
begin
-- If the type is a string literal type, then this must be generated
procedure Check_Stream_Attribute (Nam : TSS_Name_Type) is
Etyp : Entity_Id;
Btyp : Entity_Id;
-
begin
Validate_Non_Static_Attribute_Function_Call;
-- attribute reference was generated by the expander (in which
-- case the underlying type will be used, as described in Sinfo),
-- or the attribute was specified explicitly for the type itself
- -- or one of its ancestors.
+ -- or one of its ancestors (taking visibility rules into account if
+ -- in Ada 2005 mode), or a pragma Stream_Convert applies to Btyp
+ -- (with no visibility restriction).
- if Is_Limited_Type (P_Type)
- and then Comes_From_Source (N)
- and then not Present (Find_Inherited_TSS (Btyp, Nam))
+ if Comes_From_Source (N)
+ and then not Stream_Attribute_Available (P_Type, Nam)
and then not Has_Rep_Pragma (Btyp, Name_Stream_Convert)
then
Error_Msg_Name_1 := Aname;
- Error_Msg_NE
- ("limited type& has no% attribute", P, Btyp);
- Explain_Limited_Type (P_Type, P);
+
+ if Is_Limited_Type (P_Type) then
+ Error_Msg_NE
+ ("limited type& has no% attribute", P, P_Type);
+ Explain_Limited_Type (P_Type, P);
+ else
+ Error_Msg_NE
+ ("attribute% for type& is not available", P, P_Type);
+ end if;
end if;
-- Check for violation of restriction No_Stream_Attributes
end if;
end if;
- if Is_Overloaded (P)
+ -- Ada 2005 (AI-345): Ensure that the compiler gives exactly the current
+ -- output compiling in Ada 95 mode
+
+ if Ada_Version < Ada_05
+ and then Is_Overloaded (P)
and then Aname /= Name_Access
and then Aname /= Name_Address
and then Aname /= Name_Code_Address
and then Aname /= Name_Unchecked_Access
then
Error_Attr ("ambiguous prefix for % attribute", P);
+
+ elsif Ada_Version >= Ada_05
+ and then Is_Overloaded (P)
+ and then Aname /= Name_Access
+ and then Aname /= Name_Address
+ and then Aname /= Name_Code_Address
+ and then Aname /= Name_Unchecked_Access
+ then
+ -- Ada 2005 (AI-345): Since protected and task types have primitive
+ -- entry wrappers, the attributes Count, Caller and AST_Entry require
+ -- a context check
+
+ if Ada_Version >= Ada_05
+ and then (Aname = Name_Count
+ or else Aname = Name_Caller
+ or else Aname = Name_AST_Entry)
+ then
+ declare
+ Count : Natural := 0;
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ Get_First_Interp (P, I, It);
+
+ while Present (It.Nam) loop
+ if Comes_From_Source (It.Nam) then
+ Count := Count + 1;
+ else
+ Remove_Interp (I);
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ if Count > 1 then
+ Error_Attr ("ambiguous prefix for % attribute", P);
+ else
+ Set_Is_Overloaded (P, False);
+ end if;
+ end;
+
+ else
+ Error_Attr ("ambiguous prefix for % attribute", P);
+ end if;
end if;
-- Remaining processing depends on attribute
Set_Address_Taken (Ent);
+ -- An Address attribute is accepted when generated by
+ -- the compiler for dispatching operation, and an error
+ -- is issued once the subprogram is frozen (to avoid
+ -- confusing errors about implicit uses of Address in
+ -- the dispatch table initialization).
+
+ if Is_Always_Inlined (Entity (P))
+ and then Comes_From_Source (P)
+ then
+ Error_Attr
+ ("prefix of % attribute cannot be Inline_Always" &
+ " subprogram", P);
+ end if;
+
elsif Is_Object (Ent)
or else Ekind (Ent) = E_Label
then
Attribute_Name => Name_Base),
Expression => Relocate_Node (E1)));
- -- E1 may be overloaded, and its interpretations preserved.
+ -- E1 may be overloaded, and its interpretations preserved
Save_Interps (E1, Expression (N));
Analyze (N);
if It.Nam = Ent then
null;
+ -- Ada 2005 (AI-345): Do not consider primitive entry
+ -- wrappers generated for task or protected types.
+
+ elsif Ada_Version >= Ada_05
+ and then not Comes_From_Source (It.Nam)
+ then
+ null;
+
else
Error_Attr ("ambiguous entry name", N);
end if;
if Is_Real_Type (P_Type) then
null;
- -- If not modular type, test for overflow check required.
+ -- If not modular type, test for overflow check required
else
if not Is_Modular_Integer_Type (P_Type)
P : constant Node_Id := Prefix (N);
C_Type : constant Entity_Id := Etype (N);
- -- The type imposed by the context.
+ -- The type imposed by the context
E1 : Node_Id;
-- First expression, or Empty if none
for J in UI_To_Int (Lo) .. UI_To_Int (Hi) loop
- -- Assume all wide-character escape sequences are
- -- same length, so we can quit when we reach one.
-
- -- Is this right for UTF-8?
+ -- All wide characters look like Hex_hhhhhhhh
if J > 255 then
- if Id = Attribute_Wide_Width then
- W := Int'Max (W, 3);
- exit;
- else
- W := Int'Max (W, Length_Wide);
- exit;
- end if;
+ W := 12;
else
C := Character'Val (J);
-- enclosing composite type.
if Ada_Version >= Ada_05
- and then Ekind (Btyp) = E_Anonymous_Access_Type
- and then (Is_Array_Type (Scope (Btyp))
- or else Ekind (Scope (Btyp)) = E_Record_Type)
+ and then Is_Local_Anonymous_Access (Btyp)
and then Object_Access_Level (P) > Type_Access_Level (Btyp)
then
-- In an instance, this is a runtime check, but one we
Eval_Attribute (N);
end Resolve_Attribute;
+ --------------------------------
+ -- Stream_Attribute_Available --
+ --------------------------------
+
+ function Stream_Attribute_Available
+ (Typ : Entity_Id;
+ Nam : TSS_Name_Type;
+ Partial_View : Node_Id := Empty) return Boolean
+ is
+ Etyp : Entity_Id := Typ;
+
+ function Has_Specified_Stream_Attribute
+ (Typ : Entity_Id;
+ Nam : TSS_Name_Type) return Boolean;
+ -- True iff there is a visible attribute definition clause specifying
+ -- attribute Nam for Typ.
+
+ ------------------------------------
+ -- Has_Specified_Stream_Attribute --
+ ------------------------------------
+
+ function Has_Specified_Stream_Attribute
+ (Typ : Entity_Id;
+ Nam : TSS_Name_Type) return Boolean
+ is
+ begin
+ return False
+ or else
+ (Nam = TSS_Stream_Input
+ and then Has_Specified_Stream_Input (Typ))
+ or else
+ (Nam = TSS_Stream_Output
+ and then Has_Specified_Stream_Output (Typ))
+ or else
+ (Nam = TSS_Stream_Read
+ and then Has_Specified_Stream_Read (Typ))
+ or else
+ (Nam = TSS_Stream_Write
+ and then Has_Specified_Stream_Write (Typ));
+ end Has_Specified_Stream_Attribute;
+
+ -- Start of processing for Stream_Attribute_Available
+
+ begin
+ -- We need some comments in this body ???
+
+ if Has_Specified_Stream_Attribute (Typ, Nam) then
+ return True;
+ end if;
+
+ if Is_Class_Wide_Type (Typ) then
+ return not Is_Limited_Type (Typ)
+ or else Stream_Attribute_Available (Etype (Typ), Nam);
+ end if;
+
+ if Nam = TSS_Stream_Input
+ and then Is_Abstract (Typ)
+ and then not Is_Class_Wide_Type (Typ)
+ then
+ return False;
+ end if;
+
+ if not (Is_Limited_Type (Typ)
+ or else (Present (Partial_View)
+ and then Is_Limited_Type (Partial_View)))
+ then
+ return True;
+ end if;
+
+ if Nam = TSS_Stream_Input then
+ return Ada_Version >= Ada_05
+ and then Stream_Attribute_Available (Etyp, TSS_Stream_Read);
+ elsif Nam = TSS_Stream_Output then
+ return Ada_Version >= Ada_05
+ and then Stream_Attribute_Available (Etyp, TSS_Stream_Write);
+ end if;
+
+ -- Case of Read and Write: check for attribute definition clause that
+ -- applies to an ancestor type.
+
+ while Etype (Etyp) /= Etyp loop
+ Etyp := Etype (Etyp);
+
+ if Has_Specified_Stream_Attribute (Etyp, Nam) then
+ return True;
+ end if;
+ end loop;
+
+ if Ada_Version < Ada_05 then
+
+ -- In Ada 95 mode, also consider a non-visible definition
+
+ declare
+ Btyp : constant Entity_Id := Implementation_Base_Type (Typ);
+ begin
+ return Btyp /= Typ
+ and then Stream_Attribute_Available
+ (Btyp, Nam, Partial_View => Typ);
+ end;
+ end if;
+
+ return False;
+ end Stream_Attribute_Available;
+
end Sem_Attr;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- This spec also documents all GNAT implementation defined pragmas
-with Snames; use Snames;
-with Types; use Types;
+with Exp_Tss; use Exp_Tss;
+with Snames; use Snames;
+with Types; use Types;
package Sem_Attr is
------------------
Attribute_Abort_Signal => True,
- --
- -- Standard'Abort_Signal (Standard is the only allowed prefix)
- -- provides the entity for the special exception used to signal
- -- task abort or asynchronous transfer of control. Normally this
- -- attribute should only be used in the tasking runtime (it is
- -- highly peculiar, and completely outside the normal semantics
- -- of Ada, for a user program to intercept the abort exception).
+ -- Standard'Abort_Signal (Standard is the only allowed prefix) provides
+ -- the entity for the special exception used to signal task abort or
+ -- asynchronous transfer of control. Normally this attribute should only
+ -- be used in the tasking runtime (it is highly peculiar, and completely
+ -- outside the normal semantics of Ada, for a user program to intercept
+ -- the abort exception).
------------------
-- Address_Size --
------------------
Attribute_Address_Size => True,
- --
-- Standard'Address_Size (Standard is the only allowed prefix) is
-- a static constant giving the number of bits in an Address. It
-- is used primarily for constructing the definition of Memory_Size
---------------
Attribute_Asm_Input => True,
- --
-- Used only in conjunction with the Asm and Asm_Volatile subprograms
-- in package Machine_Code to construct machine instructions. See
-- documentation in package Machine_Code in file s-maccod.ads.
----------------
Attribute_Asm_Output => True,
- --
-- Used only in conjunction with the Asm and Asm_Volatile subprograms
-- in package Machine_Code to construct machine instructions. See
-- documentation in package Machine_Code in file s-maccod.ads.
---------------
Attribute_AST_Entry => True,
- --
-- E'Ast_Entry, where E is a task entry, yields a value of the
-- predefined type System.DEC.AST_Handler, that enables the given
-- entry to be called when an AST occurs. If the name to which the
---------
Attribute_Bit => True,
- --
- -- Obj'Bit, where Obj is any object, yields the bit offset within
- -- the storage unit (byte) that contains the first bit of storage
- -- allocated for the object. The value of this attribute is of the
- -- type Universal_Integer, and is always a non-negative number not
- -- exceeding the value of System.Storage_Unit.
+ -- Obj'Bit, where Obj is any object, yields the bit offset within the
+ -- storage unit (byte) that contains the first bit of storage allocated
+ -- for the object. The attribute value is of type Universal_Integer,
+ -- and is always a non-negative number not exceeding the value of
+ -- System.Storage_Unit.
--
-- For an object that is a variable or a constant allocated in a
-- register, the value is zero. (The use of this attribute does not
-- force the allocation of a variable to memory).
--
- -- For an object that is a formal parameter, this attribute applies
- -- to either the matching actual parameter or to a copy of the
- -- matching actual parameter.
+ -- For an object that is a formal parameter, this attribute applies to
+ -- either the matching actual parameter or to a copy of the matching
+ -- actual parameter.
--
-- For an access object the value is zero. Note that Obj.all'Bit is
-- subject to an Access_Check for the designated object. Similarly
------------------
Attribute_Code_Address => True,
- --
- -- subp'Code_Address, where subp is a subprogram entity, gives the
- -- address of the first generated instruction for a subprogram. This
- -- is often, but not always the same as the 'Address value, which is
- -- the address to be used in a call. The differences occur in the case
- -- of a nested procedure (where Address yields the address of the
- -- trampoline code used to load the static link), and on some systems
- -- which use procedure descriptors (in which case Address yields the
- -- address of the descriptor).
+ -- The reference subp'Code_Address, where subp is a subprogram entity,
+ -- gives the address of the first generated instruction for the sub-
+ -- program. This is often, but not always the same as the 'Address
+ -- value, which is the address to be used in a call. The differences
+ -- occur in the case of a nested procedure (where Address yields the
+ -- address of the trampoline code used to load the static link), and on
+ -- some systems which use procedure descriptors (in which case Address
+ -- yields the address of the descriptor).
-----------------------
-- Default_Bit_Order --
-----------------------
Attribute_Default_Bit_Order => True,
- --
-- Standard'Default_Bit_Order (Standard is the only permissible prefix),
-- provides the value System.Default_Bit_Order as a Pos value (0 for
-- High_Order_First, 1 for Low_Order_First). This is used to construct
---------------
Attribute_Elab_Body => True,
- --
- -- This attribute can only be applied to a program unit name. It
- -- returns the entity for the corresponding elaboration procedure
- -- for elaborating the body of the referenced unit. This is used
- -- in the main generated elaboration procedure by the binder, and
- -- is not normally used in any other context, but there may be
- -- specialized situations in which it is useful to be able to
- -- call this elaboration procedure from Ada code, e.g. if it
- -- is necessary to do selective reelaboration to fix some error.
+ -- This attribute can only be applied to a program unit name. It returns
+ -- the entity for the corresponding elaboration procedure for elabor-
+ -- ating the body of the referenced unit. This is used in the main
+ -- generated elaboration procedure by the binder, and is not normally
+ -- used in any other context, but there may be specialized situations in
+ -- which it is useful to be able to call this elaboration procedure from
+ -- Ada code, e.g. if it is necessary to do selective reelaboration to
+ -- fix some error.
---------------
-- Elab_Spec --
---------------
Attribute_Elab_Spec => True,
- --
-- This attribute can only be applied to a program unit name. It
-- returns the entity for the corresponding elaboration procedure
-- for elaborating the spec of the referenced unit. This is used
----------------
Attribute_Elaborated => True,
- --
-- Lunit'Elaborated, where Lunit is a library unit, yields a boolean
-- value indicating whether or not the body of the designated library
-- unit has been elaborated yet.
--------------
Attribute_Enum_Rep => True,
- --
-- For every enumeration subtype S, S'Enum_Rep denotes a function
-- with the following specification:
--
-----------------
Attribute_Fixed_Value => True,
- --
-- For every fixed-point type S, S'Fixed_Value denotes a function
-- with the following specification:
--
--
-- V = Arg * S'Small
--
- -- The effect is thus equivalent to first converting the argument
- -- to the integer type used to represent S, and then doing an
- -- unchecked conversion to the fixed-point type. This attribute is
- -- primarily intended for use in implementation of the input-output
- -- functions for fixed-point values.
+ -- The effect is thus equivalent to first converting the argument to
+ -- the integer type used to represent S, and then doing an unchecked
+ -- conversion to the fixed-point type. This attribute is primarily
+ -- intended for use in implementation of the input-output functions for
+ -- fixed-point values.
-----------------------
-- Has_Discriminants --
-----------------------
Attribute_Has_Discriminants => True,
- --
-- Gtyp'Has_Discriminants, where Gtyp is a generic formal type, yields
-- a Boolean value indicating whether or not the actual instantiation
-- type has discriminants.
---------
Attribute_Img => True,
- --
-- The 'Img function is defined for any prefix, P, that denotes an
-- object of scalar type T. P'Img is equivalent to T'Image (P). This
-- is convenient for debugging. For example:
-------------------
Attribute_Integer_Value => True,
- --
-- For every integer type S, S'Integer_Value denotes a function
-- with the following specification:
--
------------------
Attribute_Machine_Size => True,
- --
-- This attribute is identical to the Object_Size attribute. It is
-- provided for compatibility with the DEC attribute of this name.
-----------------------
Attribute_Maximum_Alignment => True,
- --
-- Standard'Maximum_Alignment (Standard is the only permissible prefix)
-- provides the maximum useful alignment value for the target. This
-- is a static value that can be used to specify the alignment for an
--------------------
Attribute_Mechanism_Code => True,
- --
-- function'Mechanism_Code yeilds an integer code for the mechanism
-- used for the result of function, and subprogram'Mechanism_Code (n)
-- yields the mechanism used for formal parameter number n (a static
--------------------
Attribute_Null_Parameter => True,
+ -- A reference T'Null_Parameter denotes an (imaginary) object of type or
+ -- subtype T allocated at (machine) address zero. The attribute is
+ -- allowed only as the default expression of a formal parameter, or as
+ -- an actual expression of a subporgram call. In either case, the
+ -- subprogram must be imported.
--
- -- A reference T'Null_Parameter denotes an (imaginary) object of
- -- type or subtype T allocated at (machine) address zero. The
- -- attribute is allowed only as the default expression of a formal
- -- parameter, or as an actual expression of a subporgram call. In
- -- either case, the subprogram must be imported.
- --
- -- The identity of the object is represented by the address zero
- -- in the argument list, independent of the passing mechanism
- -- (explicit or default).
+ -- The identity of the object is represented by the address zero in the
+ -- argument list, independent of the passing mechanism (explicit or
+ -- default).
--
- -- The reason that this capability is needed is that for a record
- -- or other composite object passed by reference, there is no other
- -- way of specifying that a zero address should be passed.
+ -- The reason that this capability is needed is that for a record or
+ -- other composite object passed by reference, there is no other way of
+ -- specifying that a zero address should be passed.
-----------------
-- Object_Size --
-----------------
Attribute_Object_Size => True,
- --
-- Type'Object_Size is the same as Type'Size for all types except
-- fixed-point types and discrete types. For fixed-point types and
-- discrete types, this attribute gives the size used for default
- -- allocation of objects and components of the size. See section
- -- in Einfo ("Handling of type'Size values") for further details.
+ -- allocation of objects and components of the size. See section in
+ -- Einfo ("Handling of type'Size values") for further details.
-------------------------
-- Passed_By_Reference --
-------------------------
Attribute_Passed_By_Reference => True,
- --
- -- T'Passed_By_Reference for any subtype T returns a boolean value
- -- that is true if the type is normally passed by reference and
- -- false if the type is normally passed by copy in calls. For scalar
- -- types, the result is always False and is static. For non-scalar
- -- types, the result is non-static (since it is computed by Gigi).
+ -- T'Passed_By_Reference for any subtype T returns a boolean value that
+ -- is true if the type is normally passed by reference and false if the
+ -- type is normally passed by copy in calls. For scalar types, the
+ -- result is always False and is static. For non-scalar types, the
+ -- result is non-static (since it is computed by Gigi).
------------------
-- Range_Length --
------------------
Attribute_Range_Length => True,
- --
- -- T'Range_Length for any discrete type T yields the number of
- -- values represented by the subtype (zero for a null range). The
- -- result is static for static subtypes. Note that Range_Length
- -- applied to the index subtype of a one dimensional array always
- -- gives the same result as Range applied to the array itself.
- -- The result is of type universal integer.
+ -- T'Range_Length for any discrete type T yields the number of values
+ -- represented by the subtype (zero for a null range). The result is
+ -- static for static subtypes. Note that Range_Length applied to the
+ -- index subtype of a one dimensional array always gives the same result
+ -- as Range applied to the array itself. The result is of type universal
+ -- integer.
------------------
-- Storage_Unit --
------------------
Attribute_Storage_Unit => True,
- --
-- Standard'Storage_Unit (Standard is the only permissible prefix)
-- provides the value System.Storage_Unit, and is intended primarily
-- for constructing this definition in package System (see note above
-----------------
Attribute_Target_Name => True,
- --
- -- Standard'Target_Name yields the string identifying the target
- -- for the compilation, taken from Sdefault.Target_Name.
+ -- Standard'Target_Name yields the string identifying the target for the
+ -- compilation, taken from Sdefault.Target_Name.
----------------
-- To_Address --
----------------
Attribute_To_Address => True,
- --
- -- System'To_Address (Address is the only permissible prefix)
- -- is a function that takes any integer value, and converts it into
- -- an address value. The semantics is to first convert the integer
- -- value to type Integer_Address according to normal conversion
- -- rules, and then to convert this to an address using the same
- -- semantics as the System.Storage_Elements.To_Address function.
- -- The important difference is that this is a static attribute
- -- so it can be used in initializations in preealborate packages.
+ -- System'To_Address (Address is the only permissible prefix) is a
+ -- function that takes any integer value, and converts it into an
+ -- address value. The semantics is to first convert the integer value to
+ -- type Integer_Address according to normal conversion rules, and then
+ -- to convert this to an address using the same semantics as the
+ -- System.Storage_Elements.To_Address function. The important difference
+ -- is that this is a static attribute so it can be used in
+ -- initializations in preealborate packages.
----------------
-- Type_Class --
----------------
Attribute_Type_Class => True,
- --
- -- T'Type_Class for any type or subtype T yields the value of the
- -- type class for the full type of T. If T is a generic formal type,
- -- then the value is the value for the corresponding actual subtype.
- -- The value of this attribute is of type System.Aux_DEC.Type_Class,
- -- which has the following definition:
+ -- T'Type_Class for any type or subtype T yields the value of the type
+ -- class for the full type of T. If T is a generic formal type, then the
+ -- value is the value for the corresponding actual subtype. The value of
+ -- this attribute is of type System.Aux_DEC.Type_Class, which has the
+ -- following definition:
--
-- type Type_Class is
-- (Type_Class_Enumeration,
-- Type_Class_Task,
-- Type_Class_Address);
--
- -- Protected types yield the value Type_Class_Task, which thus
- -- applies to all concurrent types. This attribute is designed to
- -- be compatible with the DEC Ada attribute of the same name.
+ -- Protected types yield the value Type_Class_Task, which thus applies
+ -- to all concurrent types. This attribute is designed to be compatible
+ -- with the DEC Ada attribute of the same name.
--
-- Note: if pragma Extend_System is used to merge the definitions of
-- Aux_DEC into System, then the type Type_Class can be referenced
-----------------
Attribute_UET_Address => True,
- --
-- Unit'UET_Address, where Unit is a program unit, yields the address
-- of the unit exception table for the specified unit. This is only
-- used in the internal implementation of exception handling. See the
------------------------------
Attribute_Universal_Literal_String => True,
- --
- -- The prefix of 'Universal_Literal_String must be a named number.
- -- The static result is the string consisting of the characters of
- -- the number as defined in the original source. This allows the
- -- user program to access the actual text of named numbers without
- -- intermediate conversions and without the need to enclose the
- -- strings in quotes (which would preclude their use as numbers).
- -- This is used internally for the construction of values of the
- -- floating-point attributes from the file ttypef.ads, but may
- -- also be used by user programs.
+ -- The prefix of 'Universal_Literal_String must be a named number. The
+ -- static result is the string consisting of the characters of the
+ -- number as defined in the original source. This allows the user
+ -- program to access the actual text of named numbers without
+ -- intermediate conversions and without the need to enclose the strings
+ -- in quotes (which would preclude their use as numbers). This is used
+ -- internally for the construction of values of the floating-point
+ -- attributes from the file ttypef.ads, but may also be used by user
+ -- programs.
-------------------------
-- Unrestricted_Access --
-------------------------
Attribute_Unrestricted_Access => True,
- --
-- The Unrestricted_Access attribute is similar to Access except that
-- all accessibility and aliased view checks are omitted. This is very
-- much a user-beware attribute. Basically its status is very similar
---------------
Attribute_VADS_Size => True,
- --
- -- Typ'VADS_Size yields the Size value typically yielded by some
- -- Ada 83 compilers. The differences between VADS_Size and Size
- -- is that for scalar types for which no Size has been specified,
- -- VADS_Size yields the Object_Size rather than the Value_Size.
- -- For example, while Natural'Size is typically 31, the value of
- -- Natural'VADS_Size is 32. For all other types, Size and VADS_Size
- -- yield the same value.
+ -- Typ'VADS_Size yields the Size value typically yielded by some Ada 83
+ -- compilers. The differences between VADS_Size and Size is that for
+ -- scalar types for which no Size has been specified, VADS_Size yields
+ -- the Object_Size rather than the Value_Size. For example, while
+ -- Natural'Size is typically 31, the value of Natural'VADS_Size is 32.
+ -- For all other types, Size and VADS_Size yield the same value.
----------------
-- Value_Size --
----------------
Attribute_Value_Size => True,
- --
- -- Type'Value_Size is the number of bits required to represent a
- -- value of the given subtype. It is the same as Type'Size, but,
- -- unlike Size, may be set for non-first subtypes. See section
- -- in Einfo ("Handling of type'Size values") for further details.
+ -- Type'Value_Size is the number of bits required to represent value of
+ -- the given subtype. It is the same as Type'Size, but, unlike Size, may
+ -- be set for non-first subtypes. See section in Einfo ("Handling of
+ -- type'Size values") for further details.
---------------
-- Word_Size --
---------------
Attribute_Word_Size => True,
- --
-- Standard'Word_Size (Standard is the only permissible prefix)
-- provides the value System.Word_Size, and is intended primarily
-- for constructing this definition in package System (see note above
-- other attributes).
procedure Resolve_Attribute (N : Node_Id; Typ : Entity_Id);
- -- Performs type resolution of attribute. If the attribute yields
- -- a universal value, mark its type as that of the context. On
- -- the other hand, if the context itself is universal (as in
- -- T'Val (T'Pos (X)), mark the type as being the largest type of
- -- that class that can be used at run-time. This is correct since
- -- either the value gets folded (in which case it doesn't matter
- -- what type of the class we give if, since the folding uses universal
- -- arithmetic anyway) or it doesn't get folded (in which case it is
- -- going to be dealt with at runtime, and the largest type is right).
+ -- Performs type resolution of attribute. If the attribute yields a
+ -- universal value, mark its type as that of the context. On the other
+ -- hand, if the context itself is universal (as in T'Val (T'Pos (X)), mark
+ -- the type as being the largest type of that class that can be used at
+ -- run-time. This is correct since either the value gets folded (in which
+ -- case it doesn't matter what type of the class we give if, since the
+ -- folding uses universal arithmetic anyway) or it doesn't get folded (in
+ -- which case it is going to be dealt with at runtime, and the largest type
+ -- is right).
+
+ function Stream_Attribute_Available
+ (Typ : Entity_Id;
+ Nam : TSS_Name_Type;
+ Partial_View : Entity_Id := Empty) return Boolean;
+ -- For a limited type Typ, return True iff the given attribute is
+ -- available. For Ada 05, availability is defined by 13.13.2(36/1). For Ada
+ -- 95, an attribute is considered to be available if it has been specified
+ -- using an attribute definition clause for the type, or for its full view,
+ -- or for an ancestor of either. Parameter Partial_View is used only
+ -- internally, when checking for an attribute definition clause that is not
+ -- visible (Ada 95 only).
end Sem_Attr;
-- disallow Storage_Size for derived task types, but that is also
-- clearly unintentional.
+ procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type);
+ -- Common processing for 'Read, 'Write, 'Input and 'Output attribute
+ -- definition clauses.
+
+ procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type) is
+ Subp : Entity_Id := Empty;
+ I : Interp_Index;
+ It : Interp;
+ Pnam : Entity_Id;
+
+ Is_Read : constant Boolean := (TSS_Nam = TSS_Stream_Read);
+
+ function Has_Good_Profile (Subp : Entity_Id) return Boolean;
+ -- Return true if the entity is a subprogram with an appropriate
+ -- profile for the attribute being defined.
+
+ ----------------------
+ -- Has_Good_Profile --
+ ----------------------
+
+ function Has_Good_Profile (Subp : Entity_Id) return Boolean is
+ F : Entity_Id;
+ Is_Function : constant Boolean := (TSS_Nam = TSS_Stream_Input);
+ Expected_Ekind : constant array (Boolean) of Entity_Kind :=
+ (False => E_Procedure, True => E_Function);
+ Typ : Entity_Id;
+
+ begin
+ if Ekind (Subp) /= Expected_Ekind (Is_Function) then
+ return False;
+ end if;
+
+ F := First_Formal (Subp);
+
+ if No (F)
+ or else Ekind (Etype (F)) /= E_Anonymous_Access_Type
+ or else Designated_Type (Etype (F)) /=
+ Class_Wide_Type (RTE (RE_Root_Stream_Type))
+ then
+ return False;
+ end if;
+
+ if not Is_Function then
+ Next_Formal (F);
+
+ declare
+ Expected_Mode : constant array (Boolean) of Entity_Kind :=
+ (False => E_In_Parameter,
+ True => E_Out_Parameter);
+ begin
+ if Parameter_Mode (F) /= Expected_Mode (Is_Read) then
+ return False;
+ end if;
+ end;
+
+ Typ := Etype (F);
+
+ else
+ Typ := Etype (Subp);
+ end if;
+
+ return Base_Type (Typ) = Base_Type (Ent)
+ and then No (Next_Formal (F));
+
+ end Has_Good_Profile;
+
+ -- Start of processing for Analyze_Stream_TSS_Definition
+
+ begin
+ FOnly := True;
+
+ if not Is_Type (U_Ent) then
+ Error_Msg_N ("local name must be a subtype", Nam);
+ return;
+ end if;
+
+ Pnam := TSS (Base_Type (U_Ent), TSS_Nam);
+
+ if Present (Pnam) and then Has_Good_Profile (Pnam) then
+ Error_Msg_Sloc := Sloc (Pnam);
+ Error_Msg_Name_1 := Attr;
+ Error_Msg_N ("% attribute already defined #", Nam);
+ return;
+ end if;
+
+ Analyze (Expr);
+
+ if Is_Entity_Name (Expr) then
+ if not Is_Overloaded (Expr) then
+ if Has_Good_Profile (Entity (Expr)) then
+ Subp := Entity (Expr);
+ end if;
+
+ else
+ Get_First_Interp (Expr, I, It);
+
+ while Present (It.Nam) loop
+ if Has_Good_Profile (It.Nam) then
+ Subp := It.Nam;
+ exit;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end if;
+ end if;
+
+ if Present (Subp) then
+ if Is_Abstract (Subp) then
+ Error_Msg_N ("stream subprogram must not be abstract", Expr);
+ return;
+ end if;
+
+ Set_Entity (Expr, Subp);
+ Set_Etype (Expr, Etype (Subp));
+
+ if TSS_Nam = TSS_Stream_Input then
+ New_Stream_Function (N, U_Ent, Subp, TSS_Nam);
+ else
+ New_Stream_Procedure (N, U_Ent, Subp, TSS_Nam,
+ Out_P => Is_Read);
+ end if;
+
+ else
+ Error_Msg_Name_1 := Attr;
+ Error_Msg_N ("incorrect expression for% attribute", Expr);
+ end if;
+ end Analyze_Stream_TSS_Definition;
+
+ -- Start of processing for Analyze_Attribute_Definition_Clause
+
begin
Analyze (Nam);
Ent := Entity (Nam);
return;
end if;
- -- Rep clause applies to full view of incomplete type or private type
- -- if we have one (if not, this is a premature use of the type).
- -- However, certain semantic checks need to be done on the specified
- -- entity (i.e. the private view), so we save it in Ent.
+ -- Rep clause applies to full view of incomplete type or private type if
+ -- we have one (if not, this is a premature use of the type). However,
+ -- certain semantic checks need to be done on the specified entity (i.e.
+ -- the private view), so we save it in Ent.
if Is_Private_Type (Ent)
and then Is_Derived_Type (Ent)
and then not Is_Tagged_Type (Ent)
and then No (Full_View (Ent))
then
- -- If this is a private type whose completion is a derivation
- -- from another private type, there is no full view, and the
- -- attribute belongs to the type itself, not its underlying parent.
+ -- If this is a private type whose completion is a derivation from
+ -- another private type, there is no full view, and the attribute
+ -- belongs to the type itself, not its underlying parent.
U_Ent := Ent;
elsif Ekind (Ent) = E_Incomplete_Type then
- -- The attribute applies to the full view, set the entity
- -- of the attribute definition accordingly.
+ -- The attribute applies to the full view, set the entity of the
+ -- attribute definition accordingly.
Ent := Underlying_Type (Ent);
U_Ent := Ent;
-- Input --
-----------
- when Attribute_Input => Input : declare
- Subp : Entity_Id := Empty;
- I : Interp_Index;
- It : Interp;
- Pnam : Entity_Id;
-
- function Has_Good_Profile (Subp : Entity_Id) return Boolean;
- -- Return true if the entity is a function with an appropriate
- -- profile for the Input attribute.
-
- ----------------------
- -- Has_Good_Profile --
- ----------------------
-
- function Has_Good_Profile (Subp : Entity_Id) return Boolean is
- F : Entity_Id;
- Ok : Boolean := False;
-
- begin
- if Ekind (Subp) = E_Function then
- F := First_Formal (Subp);
-
- if Present (F) and then No (Next_Formal (F)) then
- if Ekind (Etype (F)) = E_Anonymous_Access_Type
- and then
- Designated_Type (Etype (F)) =
- Class_Wide_Type (RTE (RE_Root_Stream_Type))
- then
- Ok := Base_Type (Etype (Subp)) = Base_Type (Ent);
- end if;
- end if;
- end if;
-
- return Ok;
- end Has_Good_Profile;
-
- -- Start of processing for Input attribute definition
-
- begin
- FOnly := True;
-
- if not Is_Type (U_Ent) then
- Error_Msg_N ("local name must be a subtype", Nam);
- return;
-
- else
- Pnam := TSS (Base_Type (U_Ent), TSS_Stream_Input);
-
- if Present (Pnam)
- and then Base_Type (Etype (Pnam)) = Base_Type (U_Ent)
- then
- Error_Msg_Sloc := Sloc (Pnam);
- Error_Msg_N ("input attribute already defined #", Nam);
- return;
- end if;
- end if;
-
- Analyze (Expr);
-
- if Is_Entity_Name (Expr) then
- if not Is_Overloaded (Expr) then
- if Has_Good_Profile (Entity (Expr)) then
- Subp := Entity (Expr);
- end if;
-
- else
- Get_First_Interp (Expr, I, It);
-
- while Present (It.Nam) loop
- if Has_Good_Profile (It.Nam) then
- Subp := It.Nam;
- exit;
- end if;
-
- Get_Next_Interp (I, It);
- end loop;
- end if;
- end if;
-
- if Present (Subp) then
- Set_Entity (Expr, Subp);
- Set_Etype (Expr, Etype (Subp));
- New_Stream_Function (N, U_Ent, Subp, TSS_Stream_Input);
- else
- Error_Msg_N ("incorrect expression for input attribute", Expr);
- return;
- end if;
- end Input;
+ when Attribute_Input =>
+ Analyze_Stream_TSS_Definition (TSS_Stream_Input);
+ Set_Has_Specified_Stream_Input (Ent);
-------------------
-- Machine_Radix --
-- Output --
------------
- when Attribute_Output => Output : declare
- Subp : Entity_Id := Empty;
- I : Interp_Index;
- It : Interp;
- Pnam : Entity_Id;
-
- function Has_Good_Profile (Subp : Entity_Id) return Boolean;
- -- Return true if the entity is a procedure with an
- -- appropriate profile for the output attribute.
-
- ----------------------
- -- Has_Good_Profile --
- ----------------------
-
- function Has_Good_Profile (Subp : Entity_Id) return Boolean is
- F : Entity_Id;
- Ok : Boolean := False;
-
- begin
- if Ekind (Subp) = E_Procedure then
- F := First_Formal (Subp);
-
- if Present (F) then
- if Ekind (Etype (F)) = E_Anonymous_Access_Type
- and then
- Designated_Type (Etype (F)) =
- Class_Wide_Type (RTE (RE_Root_Stream_Type))
- then
- Next_Formal (F);
- Ok := Present (F)
- and then Parameter_Mode (F) = E_In_Parameter
- and then Base_Type (Etype (F)) = Base_Type (Ent)
- and then No (Next_Formal (F));
- end if;
- end if;
- end if;
-
- return Ok;
- end Has_Good_Profile;
-
- -- Start of processing for Output attribute definition
-
- begin
- FOnly := True;
-
- if not Is_Type (U_Ent) then
- Error_Msg_N ("local name must be a subtype", Nam);
- return;
-
- else
- Pnam := TSS (Base_Type (U_Ent), TSS_Stream_Output);
-
- if Present (Pnam)
- and then
- Base_Type (Etype (Next_Formal (First_Formal (Pnam))))
- = Base_Type (U_Ent)
- then
- Error_Msg_Sloc := Sloc (Pnam);
- Error_Msg_N ("output attribute already defined #", Nam);
- return;
- end if;
- end if;
-
- Analyze (Expr);
-
- if Is_Entity_Name (Expr) then
- if not Is_Overloaded (Expr) then
- if Has_Good_Profile (Entity (Expr)) then
- Subp := Entity (Expr);
- end if;
-
- else
- Get_First_Interp (Expr, I, It);
-
- while Present (It.Nam) loop
- if Has_Good_Profile (It.Nam) then
- Subp := It.Nam;
- exit;
- end if;
-
- Get_Next_Interp (I, It);
- end loop;
- end if;
- end if;
-
- if Present (Subp) then
- Set_Entity (Expr, Subp);
- Set_Etype (Expr, Etype (Subp));
- New_Stream_Procedure (N, U_Ent, Subp, TSS_Stream_Output);
- else
- Error_Msg_N ("incorrect expression for output attribute", Expr);
- return;
- end if;
- end Output;
+ when Attribute_Output =>
+ Analyze_Stream_TSS_Definition (TSS_Stream_Output);
+ Set_Has_Specified_Stream_Output (Ent);
----------
-- Read --
----------
- when Attribute_Read => Read : declare
- Subp : Entity_Id := Empty;
- I : Interp_Index;
- It : Interp;
- Pnam : Entity_Id;
-
- function Has_Good_Profile (Subp : Entity_Id) return Boolean;
- -- Return true if the entity is a procedure with an appropriate
- -- profile for the Read attribute.
-
- ----------------------
- -- Has_Good_Profile --
- ----------------------
-
- function Has_Good_Profile (Subp : Entity_Id) return Boolean is
- F : Entity_Id;
- Ok : Boolean := False;
-
- begin
- if Ekind (Subp) = E_Procedure then
- F := First_Formal (Subp);
-
- if Present (F) then
- if Ekind (Etype (F)) = E_Anonymous_Access_Type
- and then
- Designated_Type (Etype (F)) =
- Class_Wide_Type (RTE (RE_Root_Stream_Type))
- then
- Next_Formal (F);
- Ok := Present (F)
- and then Parameter_Mode (F) = E_Out_Parameter
- and then Base_Type (Etype (F)) = Base_Type (Ent)
- and then No (Next_Formal (F));
- end if;
- end if;
- end if;
-
- return Ok;
- end Has_Good_Profile;
-
- -- Start of processing for Read attribute definition
-
- begin
- FOnly := True;
-
- if not Is_Type (U_Ent) then
- Error_Msg_N ("local name must be a subtype", Nam);
- return;
-
- else
- Pnam := TSS (Base_Type (U_Ent), TSS_Stream_Read);
-
- if Present (Pnam)
- and then Base_Type (Etype (Next_Formal (First_Formal (Pnam))))
- = Base_Type (U_Ent)
- then
- Error_Msg_Sloc := Sloc (Pnam);
- Error_Msg_N ("read attribute already defined #", Nam);
- return;
- end if;
- end if;
-
- Analyze (Expr);
-
- if Is_Entity_Name (Expr) then
- if not Is_Overloaded (Expr) then
- if Has_Good_Profile (Entity (Expr)) then
- Subp := Entity (Expr);
- end if;
-
- else
- Get_First_Interp (Expr, I, It);
-
- while Present (It.Nam) loop
- if Has_Good_Profile (It.Nam) then
- Subp := It.Nam;
- exit;
- end if;
-
- Get_Next_Interp (I, It);
- end loop;
- end if;
- end if;
-
- if Present (Subp) then
- Set_Entity (Expr, Subp);
- Set_Etype (Expr, Etype (Subp));
- New_Stream_Procedure (N, U_Ent, Subp, TSS_Stream_Read, True);
- else
- Error_Msg_N ("incorrect expression for read attribute", Expr);
- return;
- end if;
- end Read;
+ when Attribute_Read =>
+ Analyze_Stream_TSS_Definition (TSS_Stream_Read);
+ Set_Has_Specified_Stream_Read (Ent);
----------
-- Size --
-- Write --
-----------
- -- Write attribute definition clause
- -- check for class-wide case will be performed later
-
- when Attribute_Write => Write : declare
- Subp : Entity_Id := Empty;
- I : Interp_Index;
- It : Interp;
- Pnam : Entity_Id;
-
- function Has_Good_Profile (Subp : Entity_Id) return Boolean;
- -- Return true if the entity is a procedure with an
- -- appropriate profile for the write attribute.
-
- ----------------------
- -- Has_Good_Profile --
- ----------------------
-
- function Has_Good_Profile (Subp : Entity_Id) return Boolean is
- F : Entity_Id;
- Ok : Boolean := False;
-
- begin
- if Ekind (Subp) = E_Procedure then
- F := First_Formal (Subp);
-
- if Present (F) then
- if Ekind (Etype (F)) = E_Anonymous_Access_Type
- and then
- Designated_Type (Etype (F)) =
- Class_Wide_Type (RTE (RE_Root_Stream_Type))
- then
- Next_Formal (F);
- Ok := Present (F)
- and then Parameter_Mode (F) = E_In_Parameter
- and then Base_Type (Etype (F)) = Base_Type (Ent)
- and then No (Next_Formal (F));
- end if;
- end if;
- end if;
-
- return Ok;
- end Has_Good_Profile;
-
- -- Start of processing for Write attribute definition
-
- begin
- FOnly := True;
-
- if not Is_Type (U_Ent) then
- Error_Msg_N ("local name must be a subtype", Nam);
- return;
- end if;
-
- Pnam := TSS (Base_Type (U_Ent), TSS_Stream_Write);
-
- if Present (Pnam)
- and then Base_Type (Etype (Next_Formal (First_Formal (Pnam))))
- = Base_Type (U_Ent)
- then
- Error_Msg_Sloc := Sloc (Pnam);
- Error_Msg_N ("write attribute already defined #", Nam);
- return;
- end if;
-
- Analyze (Expr);
-
- if Is_Entity_Name (Expr) then
- if not Is_Overloaded (Expr) then
- if Has_Good_Profile (Entity (Expr)) then
- Subp := Entity (Expr);
- end if;
-
- else
- Get_First_Interp (Expr, I, It);
-
- while Present (It.Nam) loop
- if Has_Good_Profile (It.Nam) then
- Subp := It.Nam;
- exit;
- end if;
-
- Get_Next_Interp (I, It);
- end loop;
- end if;
- end if;
-
- if Present (Subp) then
- Set_Entity (Expr, Subp);
- Set_Etype (Expr, Etype (Subp));
- New_Stream_Procedure (N, U_Ent, Subp, TSS_Stream_Write);
- else
- Error_Msg_N ("incorrect expression for write attribute", Expr);
- return;
- end if;
- end Write;
+ when Attribute_Write =>
+ Analyze_Stream_TSS_Definition (TSS_Stream_Write);
+ Set_Has_Specified_Stream_Write (Ent);
-- All other attributes cannot be set
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
Found_Explicit : Boolean;
Decl_Privates : Boolean;
- function Has_Overriding_Pragma (Subp : Entity_Id) return Boolean;
- -- Check whether a pragma Overriding has been provided for a primitive
- -- operation that is found to be overriding in the private part.
-
function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean;
-- Check whether an inherited subprogram is an operation of an
-- untagged derived type.
- ---------------------------
- -- Has_Overriding_Pragma --
- ---------------------------
-
- function Has_Overriding_Pragma (Subp : Entity_Id) return Boolean is
- Decl : constant Node_Id := Unit_Declaration_Node (Subp);
- Prag : Node_Id;
-
- begin
- if No (Decl)
- or else Nkind (Decl) /= N_Subprogram_Declaration
- or else No (Next (Decl))
- then
- return False;
-
- else
- Prag := Next (Decl);
-
- while Present (Prag)
- and then Nkind (Prag) = N_Pragma
- loop
- if Chars (Prag) = Name_Overriding
- or else Chars (Prag) = Name_Optional_Overriding
- then
- return True;
- else
- Next (Prag);
- end if;
- end loop;
- end if;
-
- return False;
- end Has_Overriding_Pragma;
-
---------------------
-- Is_Primitive_Of --
---------------------
Replace_Elmt (Op_Elmt, New_Op);
Remove_Elmt (Op_List, Op_Elmt_2);
Found_Explicit := True;
+ Set_Is_Overriding_Operation (New_Op);
Decl_Privates := True;
- -- If explicit_overriding is in effect, check that
- -- the overriding operation is properly labelled.
-
- if Explicit_Overriding
- and then Comes_From_Source (New_Op)
- and then not Has_Overriding_Pragma (New_Op)
- then
- Error_Msg_NE
- ("Missing overriding pragma for&",
- New_Op, New_Op);
- end if;
-
exit;
end if;
Set_RM_Size (Priv, RM_Size (Full));
Set_Size_Known_At_Compile_Time (Priv, Size_Known_At_Compile_Time
(Full));
- Set_Is_Volatile (Priv, Is_Volatile (Full));
- Set_Treat_As_Volatile (Priv, Treat_As_Volatile (Full));
- Set_Is_Ada_2005 (Priv, Is_Ada_2005 (Full));
+ Set_Is_Volatile (Priv, Is_Volatile (Full));
+ Set_Treat_As_Volatile (Priv, Treat_As_Volatile (Full));
+ Set_Is_Ada_2005 (Priv, Is_Ada_2005 (Full));
+
+ if Is_Unchecked_Union (Full) then
+ Set_Is_Unchecked_Union (Base_Type (Priv));
+ end if;
-- Why is atomic not copied here ???
if Referenced (Full) then
and then not Error_Posted (Full)
then
if Priv_Is_Base_Type then
- Set_Access_Disp_Table (Priv, Access_Disp_Table
- (Base_Type (Full)));
+
+ -- Ada 2005 (AI-345): The full view of a type implementing
+ -- an interface can be a task type.
+
+ -- type T is new I with private;
+ -- private
+ -- task type T is new I with ...
+
+ if Is_Interface (Etype (Priv))
+ and then Is_Concurrent_Type (Base_Type (Full))
+ then
+ -- Protect the frontend against previous errors
+
+ if Present (Corresponding_Record_Type
+ (Base_Type (Full)))
+ then
+ Set_Access_Disp_Table
+ (Priv, Access_Disp_Table
+ (Corresponding_Record_Type (Base_Type (Full))));
+ else
+ pragma Assert (Serious_Errors_Detected > 0);
+ null;
+ end if;
+
+ else
+ Set_Access_Disp_Table
+ (Priv, Access_Disp_Table (Base_Type (Full)));
+ end if;
end if;
Set_First_Entity (Priv, First_Entity (Full));
procedure Analyze_Subprogram_Renaming (N : Node_Id) is
Spec : constant Node_Id := Specification (N);
Save_AV : constant Ada_Version_Type := Ada_Version;
+ Save_AV_Exp : constant Ada_Version_Type := Ada_Version_Explicit;
Nam : constant Node_Id := Name (N);
New_S : Entity_Id;
Old_S : Entity_Id := Empty;
New_S := Rename_Spec;
Set_Has_Completion (Rename_Spec, False);
+ -- Ada 2005: check overriding indicator.
+
+ if Must_Override (Specification (N))
+ and then not Is_Overriding_Operation (Rename_Spec)
+ then
+ Error_Msg_NE ("subprogram& is not overriding", N, Rename_Spec);
+
+ elsif Must_Not_Override (Specification (N))
+ and then Is_Overriding_Operation (Rename_Spec)
+ then
+ Error_Msg_NE
+ ("subprogram& overrides inherited operation", N, Rename_Spec);
+ end if;
+
else
Generate_Definition (New_S);
New_Overloaded_Entity (New_S);
+
if Is_Entity_Name (Nam)
and then Is_Intrinsic_Subprogram (Entity (Nam))
then
Set_Has_Completion (New_S);
end if;
- -- Find the renamed entity that matches the given specification.
- -- Disable Ada_83 because there is no requirement of full conformance
- -- between renamed entity and new entity, even though the same circuit
- -- is used.
+ -- Find the renamed entity that matches the given specification. Disable
+ -- Ada_83 because there is no requirement of full conformance between
+ -- renamed entity and new entity, even though the same circuit is used.
+ -- This is a bit of a kludge, which introduces a really irregular use of
+ -- Ada_Version[_Explicit]. Would be nice to find cleaner way to do this
+ -- ???
Ada_Version := Ada_Version_Type'Max (Ada_Version, Ada_95);
+ Ada_Version_Explicit := Ada_Version;
if No (Old_S) then
Old_S := Find_Renamed_Entity (N, Name (N), New_S, Is_Actual);
Generate_Reference (Old_S, Nam);
end if;
- -- For a renaming-as-body, require subtype conformance,
- -- but if the declaration being completed has not been
- -- frozen, then inherit the convention of the renamed
- -- subprogram prior to checking conformance (unless the
- -- renaming has an explicit convention established; the
+ -- For a renaming-as-body, require subtype conformance, but if the
+ -- declaration being completed has not been frozen, then inherit the
+ -- convention of the renamed subprogram prior to checking conformance
+ -- (unless the renaming has an explicit convention established; the
-- rule stated in the RM doesn't seem to address this ???).
if Present (Rename_Spec) then
Set_Alias (New_S, Old_S);
end if;
- -- Note that we do not set Is_Intrinsic_Subprogram if we have
- -- a renaming as body, since the entity in this case is not an
- -- intrinsic (it calls an intrinsic, but we have a real body
- -- for this call, and it is in this body that the required
- -- intrinsic processing will take place).
+ -- Note that we do not set Is_Intrinsic_Subprogram if we have a
+ -- renaming as body, since the entity in this case is not an
+ -- intrinsic (it calls an intrinsic, but we have a real body for
+ -- this call, and it is in this body that the required intrinsic
+ -- processing will take place).
- -- Also, if this is a renaming of inequality, the renamed
- -- operator is intrinsic, but what matters is the corresponding
- -- equality operator, which may be user-defined.
+ -- Also, if this is a renaming of inequality, the renamed operator
+ -- is intrinsic, but what matters is the corresponding equality
+ -- operator, which may be user-defined.
Set_Is_Intrinsic_Subprogram
(New_S,
Set_Is_Abstract (New_S, Is_Abstract (Old_S));
Check_Library_Unit_Renaming (N, Old_S);
- -- Pathological case: procedure renames entry in the scope of
- -- its task. Entry is given by simple name, but body must be built
- -- for procedure. Of course if called it will deadlock.
+ -- Pathological case: procedure renames entry in the scope of its
+ -- task. Entry is given by simple name, but body must be built for
+ -- procedure. Of course if called it will deadlock.
if Ekind (Old_S) = E_Entry then
Set_Has_Completion (New_S, False);
end if;
else
- -- A common error is to assume that implicit operators for types
- -- are defined in Standard, or in the scope of a subtype. In those
- -- cases where the renamed entity is given with an expanded name,
- -- it is worth mentioning that operators for the type are not
- -- declared in the scope given by the prefix.
+ -- A common error is to assume that implicit operators for types are
+ -- defined in Standard, or in the scope of a subtype. In those cases
+ -- where the renamed entity is given with an expanded name, it is
+ -- worth mentioning that operators for the type are not declared in
+ -- the scope given by the prefix.
if Nkind (Nam) = N_Expanded_Name
and then Nkind (Selector_Name (Nam)) = N_Operator_Symbol
end if;
end if;
+ -- Ada 2005 AI 404: if the new subprogram is dispatching, verify that
+ -- controlling access parameters are known non-null for the renamed
+ -- subprogram. Test also applies to a subprogram instantiation that
+ -- is dispatching.
+
+ if Ada_Version >= Ada_05
+ and then not Is_Dispatching_Operation (Old_S)
+ and then Is_Dispatching_Operation (New_S)
+ then
+ declare
+ Old_F : Entity_Id;
+ New_F : Entity_Id;
+
+ begin
+ Old_F := First_Formal (Old_S);
+ New_F := First_Formal (New_S);
+ while Present (Old_F) loop
+ if Ekind (Etype (Old_F)) = E_Anonymous_Access_Type
+ and then Is_Controlling_Formal (New_F)
+ and then not Can_Never_Be_Null (Old_F)
+ then
+ Error_Msg_N ("access parameter is controlling,", New_F);
+ Error_Msg_NE ("\corresponding parameter of& " &
+ " must be explicitly null excluding", New_F, Old_S);
+ end if;
+
+ Next_Formal (Old_F);
+ Next_Formal (New_F);
+ end loop;
+ end;
+ end if;
+
Ada_Version := Save_AV;
+ Ada_Version_Explicit := Save_AV_Exp;
end Analyze_Subprogram_Renaming;
-------------------------
Set_Hidden_By_Use_Clause (N, No_Elist);
-- Use clause is not allowed in a spec of a predefined package
- -- declaration except that packages whose file name starts a-n
- -- are OK (these are children of Ada.Numerics, and such packages
- -- are never loaded by Rtsfind).
+ -- declaration except that packages whose file name starts a-n are OK
+ -- (these are children of Ada.Numerics, and such packages are never
+ -- loaded by Rtsfind).
if Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
and then Name_Buffer (1 .. 3) /= "a-n"
if Nkind (Parent (N)) = N_Compilation_Unit then
if Nkind (Id) = N_Identifier then
- Error_Msg_N ("Type is not directly visible", Id);
+ Error_Msg_N ("type is not directly visible", Id);
elsif Is_Child_Unit (Scope (Entity (Id)))
and then Scope (Entity (Id)) /= System_Aux_Id
and then Item /= N
loop
if Nkind (Item) = N_With_Clause
+
+ -- Protect the frontend against previously reported
+ -- critical errors
+
+ and then Nkind (Name (Item)) /= N_Selected_Component
and then Entity (Name (Item)) = Pack
then
Par := Nam;
if Present (Candidate) then
if Is_Child_Unit (Candidate) then
- Error_Msg_N
- ("missing with_clause for child unit &", Selector);
+
+ -- If the candidate is a private child unit and we are
+ -- in the visible part of a public unit, specialize the
+ -- error message. There might be a private with_clause for
+ -- it, but it is not currently active.
+
+ if Is_Private_Descendant (Candidate)
+ and then Ekind (Current_Scope) = E_Package
+ and then not In_Private_Part (Current_Scope)
+ and then not Is_Private_Descendant (Current_Scope)
+ then
+ Error_Msg_N ("private child unit& is not visible here",
+ Selector);
+ else
+ Error_Msg_N
+ ("missing with_clause for child unit &", Selector);
+ end if;
else
Error_Msg_NE ("& is not a visible entity of&", N, Selector);
end if;
or else K = N_Package_Specification;
end Has_Declarations;
+ -------------------------------------------
+ -- Has_Discriminant_Dependent_Constraint --
+ -------------------------------------------
+
+ function Has_Discriminant_Dependent_Constraint
+ (Comp : Entity_Id) return Boolean
+ is
+ Comp_Decl : constant Node_Id := Parent (Comp);
+ Subt_Indic : constant Node_Id :=
+ Subtype_Indication (Component_Definition (Comp_Decl));
+ Constr : Node_Id;
+ Assn : Node_Id;
+
+ begin
+ if Nkind (Subt_Indic) = N_Subtype_Indication then
+ Constr := Constraint (Subt_Indic);
+
+ if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
+ Assn := First (Constraints (Constr));
+ while Present (Assn) loop
+ case Nkind (Assn) is
+ when N_Subtype_Indication |
+ N_Range |
+ N_Identifier
+ =>
+ if Depends_On_Discriminant (Assn) then
+ return True;
+ end if;
+
+ when N_Discriminant_Association =>
+ if Depends_On_Discriminant (Expression (Assn)) then
+ return True;
+ end if;
+
+ when others =>
+ null;
+
+ end case;
+
+ Next (Assn);
+ end loop;
+ end if;
+ end if;
+
+ return False;
+ end Has_Discriminant_Dependent_Constraint;
+
--------------------
-- Has_Infinities --
--------------------
P_Aliased : Boolean := False;
Comp : Entity_Id;
- function Has_Dependent_Constraint (Comp : Entity_Id) return Boolean;
- -- Returns True if and only if Comp has a constrained subtype
- -- that depends on a discriminant.
-
function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean;
-- Returns True if and only if Comp is declared within a variant part
- ------------------------------
- -- Has_Dependent_Constraint --
- ------------------------------
-
- function Has_Dependent_Constraint (Comp : Entity_Id) return Boolean is
- Comp_Decl : constant Node_Id := Parent (Comp);
- Subt_Indic : constant Node_Id :=
- Subtype_Indication (Component_Definition (Comp_Decl));
- Constr : Node_Id;
- Assn : Node_Id;
-
- begin
- if Nkind (Subt_Indic) = N_Subtype_Indication then
- Constr := Constraint (Subt_Indic);
-
- if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
- Assn := First (Constraints (Constr));
- while Present (Assn) loop
- case Nkind (Assn) is
- when N_Subtype_Indication |
- N_Range |
- N_Identifier
- =>
- if Depends_On_Discriminant (Assn) then
- return True;
- end if;
-
- when N_Discriminant_Association =>
- if Depends_On_Discriminant (Expression (Assn)) then
- return True;
- end if;
-
- when others =>
- null;
-
- end case;
-
- Next (Assn);
- end loop;
- end if;
- end if;
-
- return False;
- end Has_Dependent_Constraint;
-
--------------------------------
-- Is_Declared_Within_Variant --
--------------------------------
end if;
+ -- A heap object is constrained by its initial value
+
+ -- Ada 2005 AI-363:if the designated type is a type with a
+ -- constrained partial view, the resulting heap object is not
+ -- constrained, and a renaming of the component is now unsafe.
+
if Is_Access_Type (Prefix_Type)
- or else Nkind (P) = N_Explicit_Dereference
+ and then
+ not Has_Constrained_Partial_View
+ (Designated_Type (Prefix_Type))
+ then
+ return False;
+
+ elsif Nkind (P) = N_Explicit_Dereference
+ and then not Has_Constrained_Partial_View (Prefix_Type)
then
return False;
end if;
and then In_Package_Body (Current_Scope)))
and then (Is_Declared_Within_Variant (Comp)
- or else Has_Dependent_Constraint (Comp))
+ or else Has_Discriminant_Dependent_Constraint (Comp))
and then not P_Aliased
then
return True;
end if;
end Is_Partially_Initialized_Type;
+ ------------------------------------
+ -- Is_Potentially_Persistent_Type --
+ ------------------------------------
+
+ function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is
+ Comp : Entity_Id;
+ Indx : Node_Id;
+
+ begin
+ -- For private type, test corrresponding full type
+
+ if Is_Private_Type (T) then
+ return Is_Potentially_Persistent_Type (Full_View (T));
+
+ -- Scalar types are potentially persistent
+
+ elsif Is_Scalar_Type (T) then
+ return True;
+
+ -- Record type is potentially persistent if not tagged and the types of
+ -- all it components are potentially persistent, and no component has
+ -- an initialization expression.
+
+ elsif Is_Record_Type (T)
+ and then not Is_Tagged_Type (T)
+ and then not Is_Partially_Initialized_Type (T)
+ then
+ Comp := First_Component (T);
+ while Present (Comp) loop
+ if not Is_Potentially_Persistent_Type (Etype (Comp)) then
+ return False;
+ else
+ Next_Entity (Comp);
+ end if;
+ end loop;
+
+ return True;
+
+ -- Array type is potentially persistent if its component type is
+ -- potentially persistent and if all its constraints are static.
+
+ elsif Is_Array_Type (T) then
+ if not Is_Potentially_Persistent_Type (Component_Type (T)) then
+ return False;
+ end if;
+
+ Indx := First_Index (T);
+ while Present (Indx) loop
+ if not Is_OK_Static_Subtype (Etype (Indx)) then
+ return False;
+ else
+ Next_Index (Indx);
+ end if;
+ end loop;
+
+ return True;
+
+ -- All other types are not potentially persistent
+
+ else
+ return False;
+ end if;
+ end Is_Potentially_Persistent_Type;
+
-----------------------------
-- Is_RCI_Pkg_Spec_Or_Body --
-----------------------------
-- the level is the same as that of the enclosing component type.
Btyp := Base_Type (Typ);
+
if Ekind (Btyp) in Access_Kind then
if Ekind (Btyp) = E_Anonymous_Access_Type
- and then not Is_Array_Type (Scope (Btyp)) -- Ada 2005 (AI-230)
- and then Ekind (Scope (Btyp)) /= E_Record_Type -- Ada 2005 (AI-230)
+ and then not Is_Local_Anonymous_Access (Typ) -- Ada 2005 (AI-230)
then
return Scope_Depth (Standard_Standard);
end if;
function Has_Declarations (N : Node_Id) return Boolean;
-- Determines if the node can have declarations
+ function Has_Discriminant_Dependent_Constraint
+ (Comp : Entity_Id) return Boolean;
+ -- Returns True if and only if Comp has a constrained subtype
+ -- that depends on a discriminant.
+
function Has_Infinities (E : Entity_Id) return Boolean;
-- Determines if the range of the floating-point type E includes
-- infinities. Returns False if E is not a floating-point type.
-- one field has an initialization expression). Note that initialization
-- resulting from the use of pragma Normalized_Scalars does not count.
+ function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean;
+ -- Determines if type T is a potentially persistent type. A potentially
+ -- persistent type is defined (recursively) as a scalar type, a non-tagged
+ -- record whose components are all of a potentially persistent type, or an
+ -- array with all static constraints whose component type is potentially
+ -- persistent. A private type is potentially persistent if the full type
+ -- is potentially persistent.
+
function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean;
-- Return True if a compilation unit is the specification or the
-- body of a remote call interface package.
or else NT (N).Nkind = N_Private_Extension_Declaration
or else NT (N).Nkind = N_Protected_Type_Declaration
or else NT (N).Nkind = N_Record_Definition
+ or else NT (N).Nkind = N_Single_Protected_Declaration
+ or else NT (N).Nkind = N_Single_Task_Declaration
or else NT (N).Nkind = N_Task_Type_Declaration);
return List2 (N);
end Interface_List;
return Flag8 (N);
end Must_Not_Freeze;
+ function Must_Not_Override
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Entry_Declaration
+ or else NT (N).Nkind = N_Function_Instantiation
+ or else NT (N).Nkind = N_Function_Specification
+ or else NT (N).Nkind = N_Procedure_Instantiation
+ or else NT (N).Nkind = N_Procedure_Specification);
+ return Flag15 (N);
+ end Must_Not_Override;
+
+ function Must_Override
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Entry_Declaration
+ or else NT (N).Nkind = N_Function_Instantiation
+ or else NT (N).Nkind = N_Function_Specification
+ or else NT (N).Nkind = N_Procedure_Instantiation
+ or else NT (N).Nkind = N_Procedure_Specification);
+ return Flag14 (N);
+ end Must_Override;
+
function Name
(N : Node_Id) return Node_Id is
begin
begin
pragma Assert (False
or else NT (N).Nkind = N_Component_List
+ or else NT (N).Nkind = N_Procedure_Specification
or else NT (N).Nkind = N_Record_Definition);
return Flag13 (N);
end Null_Present;
or else NT (N).Nkind = N_Private_Extension_Declaration
or else NT (N).Nkind = N_Protected_Type_Declaration
or else NT (N).Nkind = N_Record_Definition
+ or else NT (N).Nkind = N_Single_Protected_Declaration
+ or else NT (N).Nkind = N_Single_Task_Declaration
or else NT (N).Nkind = N_Task_Type_Declaration);
Set_List2_With_Parent (N, Val);
end Set_Interface_List;
Set_Flag8 (N, Val);
end Set_Must_Not_Freeze;
+ procedure Set_Must_Not_Override
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Entry_Declaration
+ or else NT (N).Nkind = N_Function_Instantiation
+ or else NT (N).Nkind = N_Function_Specification
+ or else NT (N).Nkind = N_Procedure_Instantiation
+ or else NT (N).Nkind = N_Procedure_Specification);
+ Set_Flag15 (N, Val);
+ end Set_Must_Not_Override;
+
+ procedure Set_Must_Override
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Entry_Declaration
+ or else NT (N).Nkind = N_Function_Instantiation
+ or else NT (N).Nkind = N_Function_Specification
+ or else NT (N).Nkind = N_Procedure_Instantiation
+ or else NT (N).Nkind = N_Procedure_Specification);
+ Set_Flag14 (N, Val);
+ end Set_Must_Override;
+
procedure Set_Name
(N : Node_Id; Val : Node_Id) is
begin
begin
pragma Assert (False
or else NT (N).Nkind = N_Component_List
+ or else NT (N).Nkind = N_Procedure_Specification
or else NT (N).Nkind = N_Record_Definition);
Set_Flag13 (N, Val);
end Set_Null_Present;
-- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
-- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
-- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
+ -- ACCESS_DEFINITION [:= EXPRESSION];
+ -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
-- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
-- | SINGLE_TASK_DECLARATION
-- | SINGLE_PROTECTED_DECLARATION
-- extra temporary (with Is_True_Constant set False), and initialize
-- this temporary as required (the temporary itself is not atomic).
+ -- Note: there is not node kind for object definition. Instead, the
+ -- corresponding field holds a subtype indication, an array type
+ -- definition, or (Ada 2005, AI-406) an access definition.
+
-- N_Object_Declaration
-- Sloc points to first identifier
-- Defining_Identifier (Node1)
-- Aliased_Present (Flag4) set if ALIASED appears
-- Constant_Present (Flag17) set if CONSTANT appears
-- Null_Exclusion_Present (Flag11)
- -- Object_Definition (Node4) subtype indication/array type definition
+ -- Object_Definition (Node4) subtype indic./array type def./ access def.
-- Expression (Node3) (set to Empty if not present)
-- Handler_List_Entry (Node2-Sem)
-- Corresponding_Generic_Association (Node5-Sem)
-----------------------------------
-- SUBPROGRAM_SPECIFICATION ::=
+ -- [[not] overriding]
-- procedure DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE
- -- | function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE
+ -- | [[not] overriding]
+ -- function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE
-- Note: there are no separate nodes for the profiles, instead the
-- information appears directly in the following nodes.
-- Parameter_Specifications (List3) (set to No_List if no formal part)
-- Subtype_Mark (Node4) for return type
-- Generic_Parent (Node5-Sem)
+ -- Must_Override (Flag14) set if overriding indicator present
+ -- Must_Not_Override (Flag15) set if not_overriding indicator present
-- N_Procedure_Specification
-- Sloc points to PROCEDURE
-- Elaboration_Boolean (Node2-Sem)
-- Parameter_Specifications (List3) (set to No_List if no formal part)
-- Generic_Parent (Node5-Sem)
+ -- Null_Present (Flag13) set for null procedure case (Ada 2005 feature)
+ -- Must_Override (Flag14) set if overriding indicator present
+ -- Must_Not_Override (Flag15) set if not_overriding indicator present
+
+ -- Note: overriding indicator is an Ada 2005 feature
---------------------
-- 6.1 Designator --
----------------------------------
-- SINGLE_TASK_DECLARATION ::=
- -- task DEFINING_IDENTIFIER [is TASK_DEFINITION];
+ -- task DEFINING_IDENTIFIER
+ -- [is [new INTERFACE_LIST with] TASK_DEFINITITION];
-- N_Single_Task_Declaration
-- Sloc points to TASK
-- Defining_Identifier (Node1)
+ -- Interface_List (List2) (set to No_List if none)
-- Task_Definition (Node3) (set to Empty if not present)
--------------------------
---------------------------------------
-- SINGLE_PROTECTED_DECLARATION ::=
- -- protected DEFINING_IDENTIFIER is PROTECTED_DEFINITION;
+ -- protected DEFINING_IDENTIFIER
+ -- is [new INTERFACE_LIST with] PROTECTED_DEFINITION;
-- Note: single protected declarations are not allowed in Ada 83 mode
-- N_Single_Protected_Declaration
-- Sloc points to PROTECTED
-- Defining_Identifier (Node1)
+ -- Interface_List (List2) (set to No_List if none)
-- Protected_Definition (Node3)
-------------------------------
------------------------------
-- ENTRY_DECLARATION ::=
+ -- [[not] overriding]
-- entry DEFINING_IDENTIFIER
-- [(DISCRETE_SUBTYPE_DEFINITION)] PARAMETER_PROFILE;
-- Discrete_Subtype_Definition (Node4) (set to Empty if not present)
-- Parameter_Specifications (List3) (set to No_List if no formal part)
-- Corresponding_Body (Node5-Sem)
+ -- Must_Override (Flag14) set if overriding indicator present
+ -- Must_Not_Override (Flag15) set if not_overriding indicator present
+
+ -- Note: overriding indicator is an Ada 2005 feature
-----------------------------
-- 9.5.2 Accept statement --
-- GENERIC_INSTANTIATION ::=
-- package DEFINING_PROGRAM_UNIT_NAME is
-- new generic_package_NAME [GENERIC_ACTUAL_PART];
- -- | procedure DEFINING_PROGRAM_UNIT_NAME is
+ -- | [[not] overriding]
+ -- procedure DEFINING_PROGRAM_UNIT_NAME is
-- new generic_procedure_NAME [GENERIC_ACTUAL_PART];
- -- | function DEFINING_DESIGNATOR is
+ -- | [[not] overriding]
+ -- function DEFINING_DESIGNATOR is
-- new generic_function_NAME [GENERIC_ACTUAL_PART];
-- N_Package_Instantiation
-- Generic_Associations (List3) (set to No_List if no
-- generic actual part)
-- Instance_Spec (Node5-Sem)
+ -- Must_Override (Flag14) set if overriding indicator present
+ -- Must_Not_Override (Flag15) set if not_overriding indicator present
-- ABE_Is_Certain (Flag18-Sem)
-- N_Function_Instantiation
-- generic actual part)
-- Parent_Spec (Node4-Sem)
-- Instance_Spec (Node5-Sem)
+ -- Must_Override (Flag14) set if overriding indicator present
+ -- Must_Not_Override (Flag15) set if not_overriding indicator present
-- ABE_Is_Certain (Flag18-Sem)
+ -- Note: overriding indicator is an Ada 2005 feature
+
------------------------------
-- 12.3 Generic Actual Part --
------------------------------
function Must_Not_Freeze
(N : Node_Id) return Boolean; -- Flag8
+ function Must_Not_Override
+ (N : Node_Id) return Boolean; -- Flag15
+
+ function Must_Override
+ (N : Node_Id) return Boolean; -- Flag14
+
function Name
(N : Node_Id) return Node_Id; -- Node2
procedure Set_Must_Not_Freeze
(N : Node_Id; Val : Boolean := True); -- Flag8
+ procedure Set_Must_Not_Override
+ (N : Node_Id; Val : Boolean := True); -- Flag15
+
+ procedure Set_Must_Override
+ (N : Node_Id; Val : Boolean := True); -- Flag14
+
procedure Set_Name
(N : Node_Id; Val : Node_Id); -- Node2
pragma Inline (More_Ids);
pragma Inline (Must_Be_Byte_Aligned);
pragma Inline (Must_Not_Freeze);
+ pragma Inline (Must_Not_Override);
+ pragma Inline (Must_Override);
pragma Inline (Name);
pragma Inline (Names);
pragma Inline (Next_Entity);
pragma Inline (Set_More_Ids);
pragma Inline (Set_Must_Be_Byte_Aligned);
pragma Inline (Set_Must_Not_Freeze);
+ pragma Inline (Set_Must_Not_Override);
+ pragma Inline (Set_Must_Override);
pragma Inline (Set_Name);
pragma Inline (Set_Names);
pragma Inline (Set_Next_Entity);
-- that is currently being written. Note that Debug_Node is always empty
-- if a debug source file is not being written.
+ procedure Sprint_And_List (List : List_Id);
+ -- Print the given list with items separated by vertical "and"
+
procedure Sprint_Bar_List (List : List_Id);
-- Print the given list with items separated by vertical bars
end Source_Dump;
---------------------
+ -- Sprint_And_List --
+ ---------------------
+
+ procedure Sprint_And_List (List : List_Id) is
+ Node : Node_Id;
+ begin
+ if Is_Non_Empty_List (List) then
+ Node := First (List);
+ loop
+ Sprint_Node (Node);
+ Next (Node);
+ exit when Node = Empty;
+ Write_Str (" and ");
+ end loop;
+ end if;
+ end Sprint_And_List;
+
+ ---------------------
-- Sprint_Bar_List --
---------------------
procedure Sprint_Bar_List (List : List_Id) is
Node : Node_Id;
-
begin
if Is_Non_Empty_List (List) then
Node := First (List);
-
loop
Sprint_Node (Node);
Next (Node);
begin
if Is_Non_Empty_List (List) then
Node := First (List);
-
loop
Sprint_Node (Node);
Next (Node);
then
Write_Str (", ");
end if;
-
end loop;
end if;
end Sprint_Comma_List;
Sprint_Node (Subtype_Indication (Node));
- if Present (Record_Extension_Part (Node)) then
+ if Present (Interface_List (Node)) then
+ Sprint_And_List (Interface_List (Node));
Write_Str_With_Col_Check (" with ");
+ end if;
+
+ if Present (Record_Extension_Part (Node)) then
+ if No (Interface_List (Node)) then
+ Write_Str_With_Col_Check (" with ");
+ end if;
+
Sprint_Node (Record_Extension_Part (Node));
end if;
Write_Indent_Str_Sloc ("protected type ");
Write_Id (Defining_Identifier (Node));
Write_Discr_Specs (Node);
- Write_Str (" is");
+
+ if Present (Interface_List (Node)) then
+ Write_Str (" is new ");
+ Sprint_And_List (Interface_List (Node));
+ Write_Str (" with ");
+ else
+ Write_Str (" is");
+ end if;
+
Sprint_Node (Protected_Definition (Node));
Write_Id (Defining_Identifier (Node));
Write_Char (';');
when N_Subprogram_Declaration =>
Write_Indent;
Sprint_Node_Sloc (Specification (Node));
+
+ if Nkind (Specification (Node)) = N_Procedure_Specification
+ and then Null_Present (Specification (Node))
+ then
+ Write_Str_With_Col_Check (" is null");
+ end if;
+
Write_Char (';');
when N_Subprogram_Info =>
Write_Id (Defining_Identifier (Node));
Write_Discr_Specs (Node);
+ if Present (Interface_List (Node)) then
+ Write_Str (" is new ");
+ Sprint_And_List (Interface_List (Node));
+ end if;
+
if Present (Task_Definition (Node)) then
- Write_Str (" is");
+ if No (Interface_List (Node)) then
+ Write_Str (" is");
+ else
+ Write_Str (" with ");
+ end if;
+
Sprint_Node (Task_Definition (Node));
Write_Id (Defining_Identifier (Node));
end if;
OSDN Git Service
