end if;
end Pred;
+ ----------------------------------
+ -- Preelaborable_Initialization --
+ ----------------------------------
+
+ when Attribute_Preelaborable_Initialization =>
+
+ -- This attribute should already be folded during analysis, but if
+ -- for some reason it hasn't been, we fold it now.
+
+ Fold_Uint
+ (N,
+ UI_From_Int
+ (Boolean'Pos (Has_Preelaborable_Initialization (Ptyp))),
+ Static => False);
+
--------------
-- Priority --
--------------
-- Duplicate_Subexpr with an explicit dereference when From is an access
-- parameter.
- function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean;
- -- Check if the type has a private view or if the public view appears in
- -- the visible part of a package spec.
-
function Prim_Op_Kind
(Prim : Entity_Id;
Typ : Entity_Id) return Node_Id;
end if;
end New_Value;
- -----------------------------------
- -- Original_View_In_Visible_Part --
- -----------------------------------
-
- function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is
- Scop : constant Entity_Id := Scope (Typ);
-
- begin
- -- The scope must be a package
-
- if not Is_Package_Or_Generic_Package (Scop) then
- return False;
- end if;
-
- -- A type with a private declaration has a private view declared in
- -- the visible part.
-
- if Has_Private_Declaration (Typ) then
- return True;
- end if;
-
- return List_Containing (Parent (Typ)) =
- Visible_Declarations (Package_Specification (Scop));
- end Original_View_In_Visible_Part;
-
------------------
-- Prim_Op_Kind --
------------------
Attribute_22 : constant Attribute_Class_Array := Attribute_Class_Array'(
Attribute_Enum_Rep |
Attribute_Enum_Val => True,
+ Attribute_Preelaborable_Initialization => True,
others => False);
-- The following array contains all attributes that imply a modification
end if;
end if;
+ ----------------------------------
+ -- Preelaborable_Initialization --
+ ----------------------------------
+
+ when Attribute_Preelaborable_Initialization =>
+ Check_E0;
+ Check_Type;
+
+ -- If we're in an instance, we know that the legality of the
+ -- attribute prefix type was already checked in the generic.
+
+ if not In_Instance then
+
+ -- If the prefix type is a generic formal type, then it must be
+ -- either a formal private type or a formal derived type.
+
+ if Is_Generic_Type (P_Type) then
+ if not Is_Private_Type (P_Type)
+ and then not Is_Derived_Type (P_Type)
+ then
+ Error_Attr_P ("formal type prefix of % attribute must be "
+ & "formal private or formal derived type");
+ end if;
+
+ -- Otherwise, the prefix type must be a nonformal composite
+ -- type declared within the visible part of a package or
+ -- generic package.
+
+ elsif not Is_Composite_Type (P_Type)
+ or else not Original_View_In_Visible_Part (P_Type)
+ then
+ Error_Attr_P
+ ("prefix of % attribute must be composite type declared "
+ & "in visible part of a package or generic package");
+ end if;
+ end if;
+
+ Set_Etype (N, Standard_Boolean);
+
--------------
-- Priority --
--------------
-- is to say if we are within an instantiation. Same processing applies
-- to selected GNAT attributes.
- elsif (Id = Attribute_Atomic_Always_Lock_Free or else
- Id = Attribute_Definite or else
- Id = Attribute_Descriptor_Size or else
- Id = Attribute_Has_Access_Values or else
- Id = Attribute_Has_Discriminants or else
- Id = Attribute_Has_Tagged_Values or else
- Id = Attribute_Lock_Free or else
- Id = Attribute_Type_Class or else
- Id = Attribute_Unconstrained_Array or else
+ elsif (Id = Attribute_Atomic_Always_Lock_Free or else
+ Id = Attribute_Definite or else
+ Id = Attribute_Descriptor_Size or else
+ Id = Attribute_Has_Access_Values or else
+ Id = Attribute_Has_Discriminants or else
+ Id = Attribute_Has_Tagged_Values or else
+ Id = Attribute_Lock_Free or else
+ Id = Attribute_Preelaborable_Initialization or else
+ Id = Attribute_Type_Class or else
+ Id = Attribute_Unconstrained_Array or else
Id = Attribute_Max_Alignment_For_Allocation)
and then not Is_Generic_Type (P_Entity)
then
-- unconstrained arrays. Furthermore, it is essential to fold this
-- in the packed case, since otherwise the value will be incorrect.
- elsif Id = Attribute_Atomic_Always_Lock_Free or else
- Id = Attribute_Definite or else
- Id = Attribute_Descriptor_Size or else
- Id = Attribute_Has_Access_Values or else
- Id = Attribute_Has_Discriminants or else
- Id = Attribute_Has_Tagged_Values or else
- Id = Attribute_Lock_Free or else
- Id = Attribute_Type_Class or else
- Id = Attribute_Unconstrained_Array or else
+ -- Folding can also be done for Preelaborable_Initialization based on
+ -- whether the prefix type has preelaborable initialization, even though
+ -- the attribute is nonstatic.
+
+ elsif Id = Attribute_Atomic_Always_Lock_Free or else
+ Id = Attribute_Definite or else
+ Id = Attribute_Descriptor_Size or else
+ Id = Attribute_Has_Access_Values or else
+ Id = Attribute_Has_Discriminants or else
+ Id = Attribute_Has_Tagged_Values or else
+ Id = Attribute_Lock_Free or else
+ Id = Attribute_Preelaborable_Initialization or else
+ Id = Attribute_Type_Class or else
+ Id = Attribute_Unconstrained_Array or else
Id = Attribute_Component_Size
then
Static := False;
Fold_Uint (N, Expr_Value (E1) - 1, Static);
end if;
+ ----------------------------------
+ -- Preelaborable_Initialization --
+ ----------------------------------
+
+ when Attribute_Preelaborable_Initialization =>
+ Fold_Uint
+ (N,
+ UI_From_Int
+ (Boolean'Pos (Has_Preelaborable_Initialization (P_Type))),
+ Static);
+
-----------
-- Range --
-----------
-- Aspect Full_Access_Only must be analyzed last so that
-- aspects Volatile and Atomic, if any, are analyzed.
+ -- Skip creation of pragma Preelaborable_Initialization
+ -- in the case where the aspect has an expression,
+ -- because the pragma is only needed for setting flag
+ -- Known_To_Have_Preelab_Init, which is set by other
+ -- means following resolution of the aspect expression.
+
if A_Id not in Aspect_Export
| Aspect_Full_Access_Only
| Aspect_Import
+ and then (A_Id /= Aspect_Preelaborable_Initialization
+ or else not Present (Expression (ASN)))
then
Make_Pragma_From_Boolean_Aspect (ASN);
end if;
| Aspect_Async_Writers
| Aspect_Effective_Reads
| Aspect_Effective_Writes
+ | Aspect_Preelaborable_Initialization
then
Error_Msg_Name_1 := Nam;
| Aspect_Async_Writers
| Aspect_Effective_Reads
| Aspect_Effective_Writes
+ | Aspect_Preelaborable_Initialization
then
Error_Msg_N
("aspect % not allowed for formal type declaration",
| Attribute_Iterable
| Attribute_Iterator_Element
| Attribute_Output
+ | Attribute_Put_Image
| Attribute_Read
| Attribute_Variable_Indexing
| Attribute_Write;
E := First_Entity (Current_Scope);
while Present (E) loop
Resolve_Aspect_Expressions (E);
+
+ -- Now that the aspect expressions have been resolved, if this is
+ -- at the end of the visible declarations, we can set the flag
+ -- Known_To_Have_Preelab_Init properly on types declared in the
+ -- visible part, which is needed for checking whether full types
+ -- in the private part satisfy the Preelaborable_Initialization
+ -- aspect of the partial view. We can't wait for the creation of
+ -- the pragma by Analyze_Aspects_At_Freeze_Point, because the
+ -- freeze point may occur after the end of the package declaration
+ -- (in the case of nested packages).
+
+ if Is_Type (E)
+ and then L = Visible_Declarations (Parent (L))
+ and then Has_Aspect (E, Aspect_Preelaborable_Initialization)
+ then
+ declare
+ ASN : constant Node_Id :=
+ Find_Aspect (E, Aspect_Preelaborable_Initialization);
+ Expr : constant Node_Id := Expression (ASN);
+ begin
+ -- Set Known_To_Have_Preelab_Init to True if aspect has no
+ -- expression, or if the expression is True (or was folded
+ -- to True), or if the expression is a conjunction of one or
+ -- more Preelaborable_Initialization attributes applied to
+ -- formal types and wasn't folded to False. (Note that
+ -- Is_Conjunction_Of_Formal_Preelab_Init_Attributes goes to
+ -- Original_Node if needed, hence test for Standard_False.)
+
+ if not Present (Expr)
+ or else (Is_Entity_Name (Expr)
+ and then Entity (Expr) = Standard_True)
+ or else
+ (Is_Conjunction_Of_Formal_Preelab_Init_Attributes (Expr)
+ and then
+ not (Is_Entity_Name (Expr)
+ and then Entity (Expr) = Standard_False))
+ then
+ Set_Known_To_Have_Preelab_Init (E);
+ end if;
+ end;
+ end if;
+
Next_Entity (E);
end loop;
end Resolve_Aspects;
end if;
-- Check preelaborable initialization for full type completing a
- -- private type for which pragma Preelaborable_Initialization given.
+ -- private type when aspect Preelaborable_Initialization is True.
+ -- We pass True for the parameter Formal_Types_Have_Preelab_Init
+ -- to take into account the rule that presumes that subcomponents
+ -- of generic formal types mentioned in the type's P_I aspect have
+ -- preelaborable initialization (see RM 10.2.1(11.8/5)).
if Is_Type (E)
and then Must_Have_Preelab_Init (E)
- and then not Has_Preelaborable_Initialization (E)
+ and then not Has_Preelaborable_Initialization
+ (E, Formal_Types_Have_Preelab_Init => True)
then
Error_Msg_N
("full view of & does not have preelaborable initialization", E);
-- Has_Preelaborable_Initialization --
--------------------------------------
- function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean is
+ function Has_Preelaborable_Initialization
+ (E : Entity_Id;
+ Formal_Types_Have_Preelab_Init : Boolean := False) return Boolean
+ is
Has_PE : Boolean;
procedure Check_Components (E : Entity_Id);
-- component type has PI.
if No (Exp) then
- if not Has_Preelaborable_Initialization (Etype (Ent)) then
+ if not Has_Preelaborable_Initialization
+ (Etype (Ent), Formal_Types_Have_Preelab_Init)
+ then
Has_PE := False;
exit;
end if;
-- Array types have PI if the component type has PI
elsif Is_Array_Type (E) then
- Has_PE := Has_Preelaborable_Initialization (Component_Type (E));
+ Has_PE := Has_Preelaborable_Initialization
+ (Component_Type (E), Formal_Types_Have_Preelab_Init);
-- A derived type has preelaborable initialization if its parent type
-- has preelaborable initialization and (in the case of a derived record
elsif Is_Derived_Type (E) then
+ -- When the rule of RM 10.2.1(11.8/5) applies, we presume a component
+ -- of a generic formal derived type has preelaborable initialization.
+ -- (See comment on spec of Has_Preelaborable_Initialization.)
+
+ if Is_Generic_Type (E) and then Formal_Types_Have_Preelab_Init then
+ return True;
+ end if;
+
-- If the derived type is a private extension then it doesn't have
-- preelaborable initialization.
-- have preelaborable initialization.
elsif Is_Private_Type (E) then
- return False;
+
+ -- When the rule of RM 10.2.1(11.8/5) applies, we presume a component
+ -- of a generic formal private type has preelaborable initialization.
+ -- (See comment on spec of Has_Preelaborable_Initialization.)
+
+ if Is_Generic_Type (E) and then Formal_Types_Have_Preelab_Init then
+ return True;
+ else
+ return False;
+ end if;
-- Record type has PI if it is non private and all components have PI
or else Is_Task_Interface (T);
end Is_Concurrent_Interface;
+ ------------------------------------------------------
+ -- Is_Conjunction_Of_Formal_Preelab_Init_Attributes --
+ ------------------------------------------------------
+
+ function Is_Conjunction_Of_Formal_Preelab_Init_Attributes
+ (Expr : Node_Id) return Boolean
+ is
+
+ function Is_Formal_Preelab_Init_Attribute
+ (N : Node_Id) return Boolean;
+ -- Returns True if N is a Preelaborable_Initialization attribute
+ -- applied to a generic formal type, or N's Original_Node is such
+ -- an attribute.
+
+ --------------------------------------
+ -- Is_Formal_Preelab_Init_Attribute --
+ --------------------------------------
+
+ function Is_Formal_Preelab_Init_Attribute
+ (N : Node_Id) return Boolean
+ is
+ Orig_N : constant Node_Id := Original_Node (N);
+
+ begin
+ return Nkind (Orig_N) = N_Attribute_Reference
+ and then Attribute_Name (Orig_N) = Name_Preelaborable_Initialization
+ and then Is_Entity_Name (Prefix (Orig_N))
+ and then Is_Generic_Type (Entity (Prefix (Orig_N)));
+ end Is_Formal_Preelab_Init_Attribute;
+
+ -- Start of Is_Conjunction_Of_Formal_Preelab_Init_Attributes
+
+ begin
+ return Is_Formal_Preelab_Init_Attribute (Expr)
+ or else (Nkind (Expr) = N_Op_And
+ and then
+ Is_Conjunction_Of_Formal_Preelab_Init_Attributes
+ (Left_Opnd (Expr))
+ and then
+ Is_Conjunction_Of_Formal_Preelab_Init_Attributes
+ (Right_Opnd (Expr)));
+ end Is_Conjunction_Of_Formal_Preelab_Init_Attributes;
+
-----------------------
-- Is_Constant_Bound --
-----------------------
end if;
end Original_Corresponding_Operation;
+ -----------------------------------
+ -- Original_View_In_Visible_Part --
+ -----------------------------------
+
+ function Original_View_In_Visible_Part
+ (Typ : Entity_Id) return Boolean
+ is
+ Scop : constant Entity_Id := Scope (Typ);
+
+ begin
+ -- The scope must be a package
+
+ if not Is_Package_Or_Generic_Package (Scop) then
+ return False;
+ end if;
+
+ -- A type with a private declaration has a private view declared in
+ -- the visible part.
+
+ if Has_Private_Declaration (Typ) then
+ return True;
+ end if;
+
+ return List_Containing (Parent (Typ)) =
+ Visible_Declarations (Package_Specification (Scop));
+ end Original_View_In_Visible_Part;
+
-------------------
-- Output_Entity --
-------------------
-- non-null), which causes the type to not have preelaborable
-- initialization.
- function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean;
+ function Has_Preelaborable_Initialization
+ (E : Entity_Id;
+ Formal_Types_Have_Preelab_Init : Boolean := False) return Boolean;
-- Return True iff type E has preelaborable initialization as defined in
-- Ada 2005 (see AI-161 for details of the definition of this attribute).
+ -- If Formal_Types_Have_Preelab_Init is True, indicates that the function
+ -- should presume that for any subcomponents of formal private or derived
+ -- types, the types have preelaborable initialization (RM 10.2.1(11.8/5)).
+ -- NOTE: The treatment of subcomponents of formal types should only apply
+ -- for types actually specified in the P_I aspect of the outer type, but
+ -- for now we take a more liberal interpretation. This needs addressing,
+ -- perhaps by passing the outermost type instead of the simple flag. ???
function Has_Prefix (N : Node_Id) return Boolean;
-- Return True if N has attribute Prefix
-- Returns true if the two specifications of the given
-- nonoverridable aspect are compatible.
+ function Is_Conjunction_Of_Formal_Preelab_Init_Attributes
+ (Expr : Node_Id) return Boolean;
+ -- Returns True if Expr is a Preelaborable_Initialization attribute applied
+ -- to a formal type, or a sequence of two or more such attributes connected
+ -- by "and" operators, or if the Original_Node of Expr or its constituents
+ -- is such an attribute.
+
function Is_Constant_Bound (Exp : Node_Id) return Boolean;
-- Exp is the expression for an array bound. Determines whether the
-- bound is a compile-time known value, or a constant entity, or an
-- corresponding operation of S is the original corresponding operation of
-- S2. Otherwise, it is S itself.
+ function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean;
+ -- Returns True if the type Typ has a private view or if the public view
+ -- appears in the visible part of a package spec.
+
procedure Output_Entity (Id : Entity_Id);
-- Print entity Id to standard output. The name of the entity appears in
-- fully qualified form.
return Pragma_Interrupt_Priority;
when Name_Lock_Free =>
return Pragma_Lock_Free;
+ when Name_Preelaborable_Initialization =>
+ return Pragma_Preelaborable_Initialization;
when Name_Priority =>
return Pragma_Priority;
when Name_Secondary_Stack_Size =>
or else N = Name_Interface
or else N = Name_Interrupt_Priority
or else N = Name_Lock_Free
+ or else N = Name_Preelaborable_Initialization
or else N = Name_Priority
or else N = Name_Secondary_Stack_Size
or else N = Name_Storage_Size
-- some exceptions). See the body of Get_Attribute_Id for details. The
-- same is true of other enumeration types declared in this package.
+ -- ALSO NOTE: In the case of a name that corresponds to both an attribute
+ -- and a pragma, the Name_Id must be defined in the attribute section
+ -- (between First_Attribute_Name and Last_Attribute_Name). Also, please
+ -- add a comment in the list of Name_Ids at the point where the name would
+ -- normally appear alphabetically (for an example, see comment starting
+ -- "Note: CPU ..."). The Pragma_Id with that name must be defined in the
+ -- last section of literals for type Pragma_Id (see set of Pragma_Ids that
+ -- require special processing due to matching an attribute name). Finally,
+ -- the bodies of functions Get_Pragma_Id and Is_Pragma_Name must be updated
+ -- to test for each such pragma that shares a name with an attribute.
+
------------------
-- Preset Names --
------------------
Name_Precondition : constant Name_Id := N + $; -- GNAT
Name_Predicate : constant Name_Id := N + $; -- GNAT
Name_Predicate_Failure : constant Name_Id := N + $; -- Ada 12
- Name_Preelaborable_Initialization : constant Name_Id := N + $; -- Ada 05
+
+ -- Note: Preelaborable_Initialization is not in this list because its name
+ -- matches the name of the corresponding attribute. However, it is included
+ -- in the definition of the type Pragma_Id, and the functions Get_Pragma_Id
+ -- and Is_Pragma_Name correctly recognize and process that pragma name.
+ -- Preelaborable_Initialization is a standard Ada 2005 pragma.
+
Name_Preelaborate : constant Name_Id := N + $;
Name_Pre_Class : constant Name_Id := N + $; -- GNAT
Name_Pool_Address : constant Name_Id := N + $; -- GNAT
Name_Pos : constant Name_Id := N + $;
Name_Position : constant Name_Id := N + $;
+ Name_Preelaborable_Initialization : constant Name_Id := N + $; -- Ada 22
Name_Priority : constant Name_Id := N + $; -- Ada 05
Name_Range : constant Name_Id := N + $;
Name_Range_Length : constant Name_Id := N + $; -- GNAT
Attribute_Pool_Address,
Attribute_Pos,
Attribute_Position,
+ Attribute_Preelaborable_Initialization,
Attribute_Priority,
Attribute_Range,
Attribute_Range_Length,
Pragma_Precondition,
Pragma_Predicate,
Pragma_Predicate_Failure,
- Pragma_Preelaborable_Initialization,
Pragma_Preelaborate,
Pragma_Pre_Class,
Pragma_Provide_Shift_Operators,
-- The following pragmas are on their own, out of order, because of the
-- special processing required to deal with the fact that their names
- -- match existing attribute names.
+ -- match existing attribute names. Note that when a pragma is added in
+ -- this section, functions Get_Pragma_Id and Is_Pragma_Name must be
+ -- updated to account for the new pragma.
Pragma_CPU,
Pragma_Default_Scalar_Storage_Order,
Pragma_Interface,
Pragma_Interrupt_Priority,
Pragma_Lock_Free,
+ Pragma_Preelaborable_Initialization,
Pragma_Priority,
Pragma_Secondary_Stack_Size,
Pragma_Storage_Size,
projects / thirdparty / gcc.git / commitdiff
