-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2019, 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- --
-- T has discriminants but there are no discriminant constraints). The
-- Related_Nod is the same as Decl_Node in Create_Constrained_Components.
-- The For_Access says whether or not this subtype is really constraining
- -- an access type. That is its sole purpose is the designated type of an
- -- access type -- in which case a Private_Subtype Is_For_Access_Subtype
- -- is built to avoid freezing T when the access subtype is frozen.
+ -- an access type.
function Build_Scalar_Bound
(Bound : Node_Id;
-- Needs a more complete spec--what are the parameters exactly, and what
-- exactly is the returned value, and how is Bound affected???
- procedure Build_Underlying_Full_View
- (N : Node_Id;
- Typ : Entity_Id;
- Par : Entity_Id);
- -- If the completion of a private type is itself derived from a private
- -- type, or if the full view of a private subtype is itself private, the
- -- back-end has no way to compute the actual size of this type. We build
- -- an internal subtype declaration of the proper parent type to convey
- -- this information. This extra mechanism is needed because a full
- -- view cannot itself have a full view (it would get clobbered during
- -- view exchanges).
-
procedure Check_Access_Discriminant_Requires_Limited
(D : Node_Id;
Loc : Node_Id);
-- declaration, Prev_T is the original incomplete type, whose full view is
-- the record type.
- procedure Replace_Components (Typ : Entity_Id; Decl : Node_Id);
- -- Subsidiary to Build_Derived_Record_Type. For untagged records, we
- -- build a copy of the declaration tree of the parent, and we create
- -- independently the list of components for the derived type. Semantic
- -- information uses the component entities, but record representation
- -- clauses are validated on the declaration tree. This procedure replaces
- -- discriminants and components in the declaration with those that have
- -- been created by Inherit_Components.
+ procedure Replace_Discriminants (Typ : Entity_Id; Decl : Node_Id);
+ -- Subsidiary to Build_Derived_Record_Type. For untagged record types, we
+ -- first create the list of components for the derived type from that of
+ -- the parent by means of Inherit_Components and then build a copy of the
+ -- declaration tree of the parent with the help of the mapping returned by
+ -- Inherit_Components, which will for example by used to validate record
+ -- representation claused given for the derived type. If the parent type
+ -- is private and has discriminants, the ancestor discriminants used in the
+ -- inheritance are that of the private declaration, whereas the ancestor
+ -- discriminants present in the declaration tree of the parent are that of
+ -- the full declaration; as a consequence, the remapping done during the
+ -- copy will leave the references to the ancestor discriminants unchanged
+ -- in the declaration tree and they need to be fixed up. If the derived
+ -- type has a known discriminant part, then the remapping done during the
+ -- copy will only create references to the girder discriminants and they
+ -- need to be replaced with references to the non-girder discriminants.
procedure Set_Fixed_Range
(E : Entity_Id;
Set_Has_Delayed_Freeze (Current_Scope);
end if;
- -- Ada 2005: If the designated type is an interface that may contain
- -- tasks, create a Master entity for the declaration. This must be done
- -- before expansion of the full declaration, because the declaration may
- -- include an expression that is an allocator, whose expansion needs the
- -- proper Master for the created tasks.
+ -- If the designated type is limited and class-wide, the object might
+ -- contain tasks, so we create a Master entity for the declaration. This
+ -- must be done before expansion of the full declaration, because the
+ -- declaration may include an expression that is an allocator, whose
+ -- expansion needs the proper Master for the created tasks.
- if Nkind (Related_Nod) = N_Object_Declaration and then Expander_Active
+ if Expander_Active
+ and then Nkind (Related_Nod) = N_Object_Declaration
then
- if Is_Interface (Desig_Type) and then Is_Limited_Record (Desig_Type)
+ if Is_Limited_Record (Desig_Type)
+ and then Is_Class_Wide_Type (Desig_Type)
+ and then Tasking_Allowed
then
Build_Class_Wide_Master (Anon_Type);
-- Similarly, if the type is an anonymous access that designates
-- tasks, create a master entity for it in the current context.
- elsif Has_Task (Desig_Type) and then Comes_From_Source (Related_Nod)
+ elsif Has_Task (Desig_Type)
+ and then Comes_From_Source (Related_Nod)
then
Build_Master_Entity (Defining_Identifier (Related_Nod));
Build_Master_Renaming (Anon_Type);
Set_Ekind (Tag, E_Component);
Set_Is_Tag (Tag);
Set_Is_Aliased (Tag);
+ Set_Is_Independent (Tag);
Set_Related_Type (Tag, Iface);
Init_Component_Location (Tag);
Set_Analyzed (Decl);
Set_Ekind (Offset, E_Component);
Set_Is_Aliased (Offset);
+ Set_Is_Independent (Offset);
Set_Related_Type (Offset, Iface);
Init_Component_Location (Offset);
Insert_After (Last_Tag, Decl);
if Is_Limited_Record (Typ) then
return True;
- -- If the root type is limited (and not a limited interface)
- -- so is the current type
+ -- If the root type is limited (and not a limited interface) so is
+ -- the current type.
elsif Is_Limited_Record (R)
and then (not Is_Interface (R) or else not Is_Limited_Interface (R))
return True;
-- Else the type may have a limited interface progenitor, but a
- -- limited record parent.
+ -- limited record parent that is not an interface.
- elsif R /= P and then Is_Limited_Record (P) then
+ elsif R /= P
+ and then Is_Limited_Record (P)
+ and then not Is_Interface (P)
+ then
return True;
else
end if;
end if;
+ -- Avoid reporting spurious errors if the component is initialized with
+ -- a raise expression (which is legal in any expression context)
+
+ if Present (E)
+ and then
+ (Nkind (E) = N_Raise_Expression
+ or else (Nkind (E) = N_Qualified_Expression
+ and then Nkind (Expression (E)) = N_Raise_Expression))
+ then
+ null;
+
-- The parent type may be a private view with unknown discriminants,
-- and thus unconstrained. Regular components must be constrained.
- if not Is_Definite_Subtype (T) and then Chars (Id) /= Name_uParent then
+ elsif not Is_Definite_Subtype (T)
+ and then Chars (Id) /= Name_uParent
+ then
if Is_Class_Wide_Type (T) then
Error_Msg_N
("class-wide subtype with unknown discriminants" &
end if;
Set_Etype (Id, T);
- Set_Is_Aliased (Id, Aliased_Present (Component_Definition (N)));
+
+ if Aliased_Present (Component_Definition (N)) then
+ Set_Is_Aliased (Id);
+
+ -- AI12-001: All aliased objects are considered to be specified as
+ -- independently addressable (RM C.6(8.1/4)).
+
+ Set_Is_Independent (Id);
+ end if;
-- The component declaration may have a per-object constraint, set
-- the appropriate flag in the defining identifier of the subtype.
-- is consistent with that of the parent.
declare
- Par_Discr : constant Entity_Id :=
- Get_Reference_Discriminant (Par_Type);
- Cur_Discr : constant Entity_Id :=
+ Cur_Discr : constant Entity_Id :=
Get_Reference_Discriminant (Prev);
+ Par_Discr : constant Entity_Id :=
+ Get_Reference_Discriminant (Par_Type);
begin
if Corresponding_Discriminant (Cur_Discr) /= Par_Discr then
- Error_Msg_N ("aspect incosistent with that of parent", N);
+ Error_Msg_N
+ ("aspect inconsistent with that of parent", N);
end if;
-- Check that specification in partial view matches the
Chars (Cur_Discr)
then
Error_Msg_N
- ("aspect incosistent with that of parent", N);
+ ("aspect inconsistent with that of parent", N);
end if;
end;
end if;
Set_Etype (Id, Universal_Integer);
Set_Ekind (Id, E_Named_Integer);
Set_Is_Frozen (Id, True);
+
+ Set_Debug_Info_Needed (Id);
return;
end if;
-- Ghost mode.
procedure Analyze_Object_Declaration (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Id : constant Entity_Id := Defining_Identifier (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ Id : constant Entity_Id := Defining_Identifier (N);
+ Next_Decl : constant Node_Id := Next (N);
+
Act_T : Entity_Id;
T : Entity_Id;
Prev_Entity : Entity_Id := Empty;
procedure Check_Dynamic_Object (Typ : Entity_Id);
- -- A library-level object with non-static discriminant constraints may
+ -- A library-level object with nonstatic discriminant constraints may
-- require dynamic allocation. The declaration is illegal if the
-- profile includes the restriction No_Implicit_Heap_Allocations.
-- This function is called when a non-generic library level object of a
-- task type is declared. Its function is to count the static number of
-- tasks declared within the type (it is only called if Has_Task is set
- -- for T). As a side effect, if an array of tasks with non-static bounds
+ -- for T). As a side effect, if an array of tasks with nonstatic bounds
-- or a variant record type is encountered, Check_Restriction is called
-- indicating the count is unknown.
A_Id := Get_Aspect_Id (Chars (Identifier (A)));
while Present (A) loop
if A_Id = Aspect_Alignment or else A_Id = Aspect_Address then
+
+ -- Set flag on object entity, for later processing at
+ -- the freeze point.
+
+ Set_Has_Delayed_Aspects (Id);
return True;
end if;
-- Save the Ghost-related attributes to restore on exit
Related_Id : Entity_Id;
+ Full_View_Present : Boolean := False;
-- Start of processing for Analyze_Object_Declaration
and then Nkind (E) = N_Aggregate
and then
((Present (Following_Address_Clause (N))
- and then not Ignore_Rep_Clauses)
+ and then not Ignore_Rep_Clauses)
or else Delayed_Aspect_Present)
then
Set_Etype (E, T);
- else
+ -- If the aggregate is limited it will be built in place, and its
+ -- expansion is deferred until the object declaration is expanded.
+ if Is_Limited_Type (T) then
+ Set_Expansion_Delayed (E);
+ end if;
+
+ else
-- If the expression is a formal that is a "subprogram pointer"
- -- this is illegal in accessibility terms. Add an explicit
- -- conversion to force the corresponding check, as is done for
- -- assignments.
+ -- this is illegal in accessibility terms (see RM 3.10.2 (13.1/2)
+ -- and AARM 3.10.2 (13.b/2)). Add an explicit conversion to force
+ -- the corresponding check, as is done for assignments.
- if Comes_From_Source (N)
- and then Is_Entity_Name (E)
+ if Is_Entity_Name (E)
and then Present (Entity (E))
and then Is_Formal (Entity (E))
and then
elsif Is_Scalar_Type (T) and then Is_OK_Static_Expression (E) then
Set_Is_Known_Valid (Id);
+
+ -- If it is a constant initialized with a valid nonstatic entity,
+ -- the constant is known valid as well, and can inherit the subtype
+ -- of the entity if it is a subtype of the given type. This info
+ -- is preserved on the actual subtype of the constant.
+
+ elsif Is_Scalar_Type (T)
+ and then Is_Entity_Name (E)
+ and then Is_Known_Valid (Entity (E))
+ and then In_Subrange_Of (Etype (Entity (E)), T)
+ then
+ Set_Is_Known_Valid (Id);
+ Set_Ekind (Id, E_Constant);
+ Set_Actual_Subtype (Id, Etype (Entity (E)));
end if;
-- Deal with setting of null flags
-- default initialization when we have at least one case of an explicit
-- default initial value and then this is not an internal declaration
-- whose initialization comes later (as for an aggregate expansion).
+ -- If expression is an aggregate it may be expanded into assignments
+ -- and the declaration itself is marked with No_Initialization, but
+ -- the predicate still applies.
if not Suppress_Assignment_Checks (N)
and then Present (Predicate_Function (T))
and then not Predicates_Ignored (T)
- and then not No_Initialization (N)
+ and then
+ (not No_Initialization (N)
+ or else (Present (E) and then Nkind (E) = N_Aggregate))
and then
(Present (E)
or else
null;
else
- Insert_After (N,
- Make_Predicate_Check (T, New_Occurrence_Of (Id, Loc)));
+ -- The check must be inserted after the expanded aggregate
+ -- expansion code, if any.
+
+ declare
+ Check : constant Node_Id :=
+ Make_Predicate_Check (T, New_Occurrence_Of (Id, Loc));
+
+ begin
+ if No (Next_Decl) then
+ Append_To (List_Containing (N), Check);
+ else
+ Insert_Before (Next_Decl, Check);
+ end if;
+ end;
end if;
end if;
elsif Is_Interface (T) then
null;
- -- In GNATprove mode, Expand_Subtype_From_Expr does nothing. Thus,
- -- we should prevent the generation of another Itype with the
- -- same name as the one already generated, or we end up with
- -- two identical types in GNATprove.
-
- elsif GNATprove_Mode then
- null;
-
-- If the type is an unchecked union, no subtype can be built from
-- the expression. Rewrite declaration as a renaming, which the
-- back-end can handle properly. This is a rather unusual case,
Act_T := Find_Type_Of_Object (Object_Definition (N), N);
end if;
+ -- Propagate attributes to full view when needed.
+
Set_Is_Constr_Subt_For_U_Nominal (Act_T);
+ if Is_Private_Type (Act_T) and then Present (Full_View (Act_T))
+ then
+ Full_View_Present := True;
+ end if;
+
+ if Full_View_Present then
+ Set_Is_Constr_Subt_For_U_Nominal (Full_View (Act_T));
+ end if;
+
if Aliased_Present (N) then
Set_Is_Constr_Subt_For_UN_Aliased (Act_T);
+
+ if Full_View_Present then
+ Set_Is_Constr_Subt_For_UN_Aliased (Full_View (Act_T));
+ end if;
end if;
Freeze_Before (N, Act_T);
if Aliased_Present (N) then
Set_Is_Aliased (Id);
+ -- AI12-001: All aliased objects are considered to be specified as
+ -- independently addressable (RM C.6(8.1/4)).
+
+ Set_Is_Independent (Id);
+
-- If the object is aliased and the type is unconstrained with
-- defaulted discriminants and there is no expression, then the
-- object is constrained by the defaults, so it is worthwhile
("subtype mark required", One_Cstr);
-- String subtype must have a lower bound of 1 in SPARK.
- -- Note that we do not need to test for the non-static case
+ -- Note that we do not need to test for the nonstatic case
-- here, since that was already taken care of in
-- Process_Range_Expr_In_Decl.
=>
Set_Ekind (Id, E_Record_Subtype);
+ -- Subtype declarations introduced for formal type parameters
+ -- in generic instantiations should inherit the Size value of
+ -- the type they rename.
+
+ if Present (Generic_Parent_Type (N)) then
+ Set_RM_Size (Id, RM_Size (T));
+ end if;
+
if Ekind (T) = E_Record_Subtype
and then Present (Cloned_Subtype (T))
then
Check_SPARK_05_Restriction
("aliased is not allowed", Component_Definition (Def));
Set_Has_Aliased_Components (Etype (T));
+
+ -- AI12-001: All aliased objects are considered to be specified as
+ -- independently addressable (RM C.6(8.1/4)).
+
+ Set_Has_Independent_Components (Etype (T));
end if;
-- Ada 2005 (AI-231): Propagate the null-excluding attribute to the
Has_Private_Component (Derived_Type));
Conditional_Delay (Derived_Type, Subt);
+ if Is_Access_Subprogram_Type (Derived_Type) then
+ Set_Can_Use_Internal_Rep
+ (Derived_Type, Can_Use_Internal_Rep (Parent_Type));
+ end if;
+
-- Ada 2005 (AI-231): Set the null-exclusion attribute, and verify
-- that it is not redundant.
Parent_Type : Entity_Id;
Derived_Type : Entity_Id)
is
- Loc : constant Source_Ptr := Sloc (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ Def : constant Node_Id := Type_Definition (N);
+ Indic : constant Node_Id := Subtype_Indication (Def);
Corr_Record : constant Entity_Id := Make_Temporary (Loc, 'C');
Corr_Decl : Node_Id;
-- this case.
Constraint_Present : constant Boolean :=
- Nkind (Subtype_Indication (Type_Definition (N))) =
- N_Subtype_Indication;
+ Nkind (Indic) = N_Subtype_Indication;
D_Constraint : Node_Id;
New_Constraint : Elist_Id := No_Elist;
Expand_To_Stored_Constraint
(Parent_Type,
Build_Discriminant_Constraints
- (Parent_Type,
- Subtype_Indication (Type_Definition (N)), True));
+ (Parent_Type, Indic, True));
end if;
End_Scope;
elsif Constraint_Present then
- -- Build constrained subtype, copying the constraint, and derive
- -- from it to create a derived constrained type.
+ -- Build an unconstrained derived type and rewrite the derived type
+ -- as a subtype of this new base type.
declare
- Loc : constant Source_Ptr := Sloc (N);
- Anon : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Derived_Type), 'T'));
- Decl : Node_Id;
+ Parent_Base : constant Entity_Id := Base_Type (Parent_Type);
+ New_Base : Entity_Id;
+ New_Decl : Node_Id;
+ New_Indic : Node_Id;
begin
- Decl :=
+ New_Base :=
+ Create_Itype (Ekind (Derived_Type), N, Derived_Type, 'B');
+
+ New_Decl :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => New_Base,
+ Type_Definition =>
+ Make_Derived_Type_Definition (Loc,
+ Abstract_Present => Abstract_Present (Def),
+ Limited_Present => Limited_Present (Def),
+ Subtype_Indication =>
+ New_Occurrence_Of (Parent_Base, Loc)));
+
+ Mark_Rewrite_Insertion (New_Decl);
+ Insert_Before (N, New_Decl);
+ Analyze (New_Decl);
+
+ New_Indic :=
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Occurrence_Of (New_Base, Loc),
+ Constraint => Relocate_Node (Constraint (Indic)));
+
+ Rewrite (N,
Make_Subtype_Declaration (Loc,
- Defining_Identifier => Anon,
- Subtype_Indication =>
- New_Copy_Tree (Subtype_Indication (Type_Definition (N))));
- Insert_Before (N, Decl);
- Analyze (Decl);
+ Defining_Identifier => Derived_Type,
+ Subtype_Indication => New_Indic));
- Rewrite (Subtype_Indication (Type_Definition (N)),
- New_Occurrence_Of (Anon, Loc));
- Set_Analyzed (Derived_Type, False);
Analyze (N);
return;
end;
-- Verify that new discriminants are used to constrain old ones
- D_Constraint :=
- First
- (Constraints
- (Constraint (Subtype_Indication (Type_Definition (N)))));
+ D_Constraint := First (Constraints (Constraint (Indic)));
Old_Disc := First_Discriminant (Parent_Type);
Parent_Type : Entity_Id;
Derived_Type : Entity_Id)
is
+ function Bound_Belongs_To_Type (B : Node_Id) return Boolean;
+ -- When the type declaration includes a constraint, we generate
+ -- a subtype declaration of an anonymous base type, with the constraint
+ -- given in the original type declaration. Conceptually, the bounds
+ -- are converted to the new base type, and this conversion freezes
+ -- (prematurely) that base type, when the bounds are simply literals.
+ -- As a result, a representation clause for the derived type is then
+ -- rejected or ignored. This procedure recognizes the simple case of
+ -- literal bounds, which allows us to indicate that the conversions
+ -- are not freeze points, and the subsequent representation clause
+ -- can be accepted.
+ -- A similar approach might be used to resolve the long-standing
+ -- problem of premature freezing of derived numeric types ???
+
+ function Bound_Belongs_To_Type (B : Node_Id) return Boolean is
+ begin
+ return Nkind (B) = N_Type_Conversion
+ and then Is_Entity_Name (Expression (B))
+ and then Ekind (Entity (Expression (B))) = E_Enumeration_Literal;
+ end Bound_Belongs_To_Type;
+
Loc : constant Source_Ptr := Sloc (N);
Def : constant Node_Id := Type_Definition (N);
Indic : constant Node_Id := Subtype_Indication (Def);
-- However, if the type inherits predicates the expressions will
-- be elaborated earlier and must freeze.
- if Nkind (Indic) /= N_Subtype_Indication
+ if (Nkind (Indic) /= N_Subtype_Indication
+ or else
+ (Bound_Belongs_To_Type (Lo) and then Bound_Belongs_To_Type (Hi)))
and then not Has_Predicates (Derived_Type)
then
Set_Must_Not_Freeze (Lo);
Full_Parent := Underlying_Full_View (Full_Parent);
end if;
- -- For record, access and most enumeration types, derivation from
- -- the full view requires a fully-fledged declaration. In the other
- -- cases, just use an itype.
+ -- For record, concurrent, access and most enumeration types, the
+ -- derivation from full view requires a fully-fledged declaration.
+ -- In the other cases, just use an itype.
- if Ekind (Full_Parent) in Record_Kind
- or else Ekind (Full_Parent) in Access_Kind
+ if Is_Record_Type (Full_Parent)
+ or else Is_Concurrent_Type (Full_Parent)
+ or else Is_Access_Type (Full_Parent)
or else
- (Ekind (Full_Parent) in Enumeration_Kind
+ (Is_Enumeration_Type (Full_Parent)
and then not Is_Standard_Character_Type (Full_Parent)
and then not Is_Generic_Type (Root_Type (Full_Parent)))
then
-- is now installed. Subprograms have been derived on the partial
-- view, the completion does not derive them anew.
- if Ekind (Full_Parent) in Record_Kind then
+ if Is_Record_Type (Full_Parent) then
-- If parent type is tagged, the completion inherits the proper
-- primitive operations.
-- Build the full derivation if this is not the anonymous derived
-- base type created by Build_Derived_Record_Type in the constrained
-- case (see point 5. of its head comment) since we build it for the
- -- derived subtype. And skip it for synchronized types altogether, as
- -- gigi does not use these types directly.
+ -- derived subtype.
if Present (Full_View (Parent_Type))
and then not Is_Itype (Derived_Type)
- and then not Is_Concurrent_Type (Full_View (Parent_Type))
then
declare
Der_Base : constant Entity_Id := Base_Type (Derived_Type);
-- An empty Discs list means that there were no constraints in the
-- subtype indication or that there was an error processing it.
+ procedure Check_Generic_Ancestors;
+ -- In Ada 2005 (AI-344), the restriction that a derived tagged type
+ -- cannot be declared at a deeper level than its parent type is
+ -- removed. The check on derivation within a generic body is also
+ -- relaxed, but there's a restriction that a derived tagged type
+ -- cannot be declared in a generic body if it's derived directly
+ -- or indirectly from a formal type of that generic. This applies
+ -- to progenitors as well.
+
+ -----------------------------
+ -- Check_Generic_Ancestors --
+ -----------------------------
+
+ procedure Check_Generic_Ancestors is
+ Ancestor_Type : Entity_Id;
+ Intf_List : List_Id;
+ Intf_Name : Node_Id;
+
+ procedure Check_Ancestor;
+ -- For parent and progenitors.
+
+ --------------------
+ -- Check_Ancestor --
+ --------------------
+
+ procedure Check_Ancestor is
+ begin
+ -- If the derived type does have a formal type as an ancestor
+ -- then it's an error if the derived type is declared within
+ -- the body of the generic unit that declares the formal type
+ -- in its generic formal part. It's sufficient to check whether
+ -- the ancestor type is declared inside the same generic body
+ -- as the derived type (such as within a nested generic spec),
+ -- in which case the derivation is legal. If the formal type is
+ -- declared outside of that generic body, then it's certain
+ -- that the derived type is declared within the generic body
+ -- of the generic unit declaring the formal type.
+
+ if Is_Generic_Type (Ancestor_Type)
+ and then Enclosing_Generic_Body (Ancestor_Type) /=
+ Enclosing_Generic_Body (Derived_Type)
+ then
+ Error_Msg_NE
+ ("ancestor type& is formal type of enclosing"
+ & " generic unit (RM 3.9.1 (4/2))",
+ Indic, Ancestor_Type);
+ end if;
+ end Check_Ancestor;
+
+ begin
+ if Nkind (N) = N_Private_Extension_Declaration then
+ Intf_List := Interface_List (N);
+ else
+ Intf_List := Interface_List (Type_Definition (N));
+ end if;
+
+ if Present (Enclosing_Generic_Body (Derived_Type)) then
+ Ancestor_Type := Parent_Type;
+
+ while not Is_Generic_Type (Ancestor_Type)
+ and then Etype (Ancestor_Type) /= Ancestor_Type
+ loop
+ Ancestor_Type := Etype (Ancestor_Type);
+ end loop;
+
+ Check_Ancestor;
+
+ if Present (Intf_List) then
+ Intf_Name := First (Intf_List);
+ while Present (Intf_Name) loop
+ Ancestor_Type := Entity (Intf_Name);
+ Check_Ancestor;
+ Next (Intf_Name);
+ end loop;
+ end if;
+ end if;
+ end Check_Generic_Ancestors;
+
+ -- Start of processing for Build_Derived_Record_Type
+
begin
if Ekind (Parent_Type) = E_Record_Type_With_Private
and then Present (Full_View (Parent_Type))
Parent_Base := Base_Type (Parent_Type);
end if;
+ -- If the parent type is declared as a subtype of another private
+ -- type with inherited discriminants, its generated base type is
+ -- itself a record subtype. To further inherit the constraint we
+ -- need to use its own base to have an unconstrained type on which
+ -- to apply the inherited constraint.
+
+ if Ekind (Parent_Base) = E_Record_Subtype then
+ Parent_Base := Base_Type (Parent_Base);
+ end if;
+
-- AI05-0115: if this is a derivation from a private type in some
-- other scope that may lead to invisible components for the derived
-- type, mark it accordingly.
-- Indic can either be an N_Identifier if the subtype indication
-- contains no constraint or an N_Subtype_Indication if the subtype
- -- indication has a constraint.
+ -- indication has a constraint. In either case it can include an
+ -- interface list.
Indic := Subtype_Indication (Type_Def);
Constraint_Present := (Nkind (Indic) = N_Subtype_Indication);
Freeze_Before (N, Parent_Type);
end if;
- -- In Ada 2005 (AI-344), the restriction that a derived tagged type
- -- cannot be declared at a deeper level than its parent type is
- -- removed. The check on derivation within a generic body is also
- -- relaxed, but there's a restriction that a derived tagged type
- -- cannot be declared in a generic body if it's derived directly
- -- or indirectly from a formal type of that generic.
-
if Ada_Version >= Ada_2005 then
- if Present (Enclosing_Generic_Body (Derived_Type)) then
- declare
- Ancestor_Type : Entity_Id;
-
- begin
- -- Check to see if any ancestor of the derived type is a
- -- formal type.
-
- Ancestor_Type := Parent_Type;
- while not Is_Generic_Type (Ancestor_Type)
- and then Etype (Ancestor_Type) /= Ancestor_Type
- loop
- Ancestor_Type := Etype (Ancestor_Type);
- end loop;
-
- -- If the derived type does have a formal type as an
- -- ancestor, then it's an error if the derived type is
- -- declared within the body of the generic unit that
- -- declares the formal type in its generic formal part. It's
- -- sufficient to check whether the ancestor type is declared
- -- inside the same generic body as the derived type (such as
- -- within a nested generic spec), in which case the
- -- derivation is legal. If the formal type is declared
- -- outside of that generic body, then it's guaranteed that
- -- the derived type is declared within the generic body of
- -- the generic unit declaring the formal type.
-
- if Is_Generic_Type (Ancestor_Type)
- and then Enclosing_Generic_Body (Ancestor_Type) /=
- Enclosing_Generic_Body (Derived_Type)
- then
- Error_Msg_NE
- ("parent type of& must not be descendant of formal type"
- & " of an enclosing generic body",
- Indic, Derived_Type);
- end if;
- end;
- end if;
+ Check_Generic_Ancestors;
elsif Type_Access_Level (Derived_Type) /=
Type_Access_Level (Parent_Type)
Set_Stored_Constraint
(Derived_Type, Expand_To_Stored_Constraint (Parent_Type, Discs));
- Replace_Components (Derived_Type, New_Decl);
+ Replace_Discriminants (Derived_Type, New_Decl);
end if;
-- Insert the new derived type declaration
(Derived_Type, No_Tagged_Streams_Pragma (Parent_Type));
end if;
- -- If the parent has primitive routines, set the derived type link
+ -- If the parent has primitive routines and may have not-seen-yet aspect
+ -- specifications (e.g., a Pack pragma), then set the derived type link
+ -- in order to later diagnose "early derivation" issues. If in different
+ -- compilation units, then "early derivation" cannot be an issue (and we
+ -- don't like interunit references that go in the opposite direction of
+ -- semantic dependencies).
- if Has_Primitive_Operations (Parent_Type) then
+ if Has_Primitive_Operations (Parent_Type)
+ and then Enclosing_Comp_Unit_Node (Parent_Type) =
+ Enclosing_Comp_Unit_Node (Derived_Type)
+ then
Set_Derived_Type_Link (Parent_Base, Derived_Type);
end if;
begin
if Ekind (T) = E_Record_Type then
- if For_Access then
- Set_Ekind (Def_Id, E_Private_Subtype);
- Set_Is_For_Access_Subtype (Def_Id, True);
- else
- Set_Ekind (Def_Id, E_Record_Subtype);
- end if;
+ Set_Ekind (Def_Id, E_Record_Subtype);
-- Inherit preelaboration flag from base, for types for which it
-- may have been set: records, private types, protected types.
then
Create_Constrained_Components (Def_Id, Related_Nod, T, Elist);
- elsif not For_Access then
+ else
Set_Cloned_Subtype (Def_Id, T);
end if;
end if;
-- If Nod is a library unit entity, then Insert_After won't work,
-- because Nod is not a member of any list. Therefore, we use
-- Add_Global_Declaration in this case. This can happen if we have a
- -- build-in-place library function.
+ -- build-in-place library function, child unit or not.
if (Nkind (Nod) in N_Entity and then Is_Compilation_Unit (Nod))
- or else
- (Nkind (Nod) = N_Defining_Program_Unit_Name
- and then Is_Compilation_Unit (Defining_Identifier (Nod)))
+ or else (Nkind_In (Nod, N_Defining_Program_Unit_Name,
+ N_Subprogram_Declaration)
+ and then Is_Compilation_Unit (Defining_Entity (Nod)))
then
Add_Global_Declaration (IR);
else
return New_Bound;
end Build_Scalar_Bound;
- --------------------------------
- -- Build_Underlying_Full_View --
- --------------------------------
-
- procedure Build_Underlying_Full_View
- (N : Node_Id;
- Typ : Entity_Id;
- Par : Entity_Id)
- is
- Loc : constant Source_Ptr := Sloc (N);
- Subt : constant Entity_Id :=
- Make_Defining_Identifier
- (Loc, New_External_Name (Chars (Typ), 'S'));
-
- Constr : Node_Id;
- Indic : Node_Id;
- C : Node_Id;
- Id : Node_Id;
-
- procedure Set_Discriminant_Name (Id : Node_Id);
- -- If the derived type has discriminants, they may rename discriminants
- -- of the parent. When building the full view of the parent, we need to
- -- recover the names of the original discriminants if the constraint is
- -- given by named associations.
-
- ---------------------------
- -- Set_Discriminant_Name --
- ---------------------------
-
- procedure Set_Discriminant_Name (Id : Node_Id) is
- Disc : Entity_Id;
-
- begin
- Set_Original_Discriminant (Id, Empty);
-
- if Has_Discriminants (Typ) then
- Disc := First_Discriminant (Typ);
- while Present (Disc) loop
- if Chars (Disc) = Chars (Id)
- and then Present (Corresponding_Discriminant (Disc))
- then
- Set_Chars (Id, Chars (Corresponding_Discriminant (Disc)));
- end if;
- Next_Discriminant (Disc);
- end loop;
- end if;
- end Set_Discriminant_Name;
-
- -- Start of processing for Build_Underlying_Full_View
-
- begin
- if Nkind (N) = N_Full_Type_Declaration then
- Constr := Constraint (Subtype_Indication (Type_Definition (N)));
-
- elsif Nkind (N) = N_Subtype_Declaration then
- Constr := New_Copy_Tree (Constraint (Subtype_Indication (N)));
-
- elsif Nkind (N) = N_Component_Declaration then
- Constr :=
- New_Copy_Tree
- (Constraint (Subtype_Indication (Component_Definition (N))));
-
- else
- raise Program_Error;
- end if;
-
- C := First (Constraints (Constr));
- while Present (C) loop
- if Nkind (C) = N_Discriminant_Association then
- Id := First (Selector_Names (C));
- while Present (Id) loop
- Set_Discriminant_Name (Id);
- Next (Id);
- end loop;
- end if;
-
- Next (C);
- end loop;
-
- Indic :=
- Make_Subtype_Declaration (Loc,
- Defining_Identifier => Subt,
- Subtype_Indication =>
- Make_Subtype_Indication (Loc,
- Subtype_Mark => New_Occurrence_Of (Par, Loc),
- Constraint => New_Copy_Tree (Constr)));
-
- -- If this is a component subtype for an outer itype, it is not
- -- a list member, so simply set the parent link for analysis: if
- -- the enclosing type does not need to be in a declarative list,
- -- neither do the components.
-
- if Is_List_Member (N)
- and then Nkind (N) /= N_Component_Declaration
- then
- Insert_Before (N, Indic);
- else
- Set_Parent (Indic, Parent (N));
- end if;
-
- Analyze (Indic);
- Set_Underlying_Full_View (Typ, Full_View (Subt));
- Set_Is_Underlying_Full_View (Full_View (Subt));
- end Build_Underlying_Full_View;
-
-------------------------------
-- Check_Abstract_Overriding --
-------------------------------
if Ekind (Contr_Typ) /= E_Protected_Type then
Error_Msg_Node_2 := Contr_Typ;
Error_Msg_NE
- ("interface subprogram & cannot be implemented by a " &
- "primitive procedure of task type &", Subp_Alias,
- Iface_Alias);
+ ("interface subprogram & cannot be implemented by a "
+ & "primitive procedure of task type &",
+ Subp_Alias, Iface_Alias);
-- An interface subprogram whose implementation kind is By_
-- Protected_Procedure must be implemented by a procedure.
elsif Ekind (Impl_Subp) /= E_Procedure then
Error_Msg_Node_2 := Iface_Alias;
Error_Msg_NE
- ("type & must implement abstract subprogram & with a " &
- "procedure", Subp_Alias, Contr_Typ);
+ ("type & must implement abstract subprogram & with a "
+ & "procedure", Subp_Alias, Contr_Typ);
elsif Present (Get_Rep_Pragma (Impl_Subp, Name_Implemented))
and then Implementation_Kind (Impl_Subp) /= Impl_Kind
then
Error_Msg_Name_1 := Impl_Kind;
Error_Msg_N
- ("overriding operation& must have synchronization%",
- Subp_Alias);
+ ("overriding operation& must have synchronization%",
+ Subp_Alias);
end if;
-- If primitive has Optional synchronization, overriding operation
- -- must match if it has an explicit synchronization..
+ -- must match if it has an explicit synchronization.
elsif Present (Get_Rep_Pragma (Impl_Subp, Name_Implemented))
and then Implementation_Kind (Impl_Subp) /= Impl_Kind
then
- Error_Msg_Name_1 := Impl_Kind;
- Error_Msg_N
- ("overriding operation& must have syncrhonization%",
- Subp_Alias);
+ Error_Msg_Name_1 := Impl_Kind;
+ Error_Msg_N
+ ("overriding operation& must have synchronization%", Subp_Alias);
end if;
end Check_Pragma_Implemented;
else
-- Specialize error message according to kind of illegal
- -- initial expression.
+ -- initial expression. We check the Original_Node to cover
+ -- cases where the initialization expression of an object
+ -- declaration generated by the compiler has been rewritten
+ -- (such as for dispatching calls).
- if Nkind (Exp) = N_Type_Conversion
- and then Nkind (Expression (Exp)) = N_Function_Call
+ if Nkind (Original_Node (Exp)) = N_Type_Conversion
+ and then
+ Nkind (Expression (Original_Node (Exp))) = N_Function_Call
then
-- No error for internally-generated object declarations,
-- which can come from build-in-place assignment statements.
-- Next_Entity field of full to ensure that the calls to Copy_Node do
-- not corrupt the entity chain.
- -- Note that the type of the full view is the same entity as the type
- -- of the partial view. In this fashion, the subtype has access to the
- -- correct view of the parent.
-
Save_Next_Entity := Next_Entity (Full);
Save_Homonym := Homonym (Priv);
- case Ekind (Full_Base) is
- when Class_Wide_Kind
- | Private_Kind
- | Protected_Kind
- | Task_Kind
- | E_Record_Subtype
- | E_Record_Type
- =>
- Copy_Node (Priv, Full);
+ if Is_Private_Type (Full_Base)
+ or else Is_Record_Type (Full_Base)
+ or else Is_Concurrent_Type (Full_Base)
+ then
+ Copy_Node (Priv, Full);
- Set_Has_Discriminants
- (Full, Has_Discriminants (Full_Base));
- Set_Has_Unknown_Discriminants
- (Full, Has_Unknown_Discriminants (Full_Base));
- Set_First_Entity (Full, First_Entity (Full_Base));
- Set_Last_Entity (Full, Last_Entity (Full_Base));
+ -- Note that the Etype of the full view is the same as the Etype of
+ -- the partial view. In this fashion, the subtype has access to the
+ -- correct view of the parent.
- -- If the underlying base type is constrained, we know that the
- -- full view of the subtype is constrained as well (the converse
- -- is not necessarily true).
+ Set_Has_Discriminants (Full, Has_Discriminants (Full_Base));
+ Set_Has_Unknown_Discriminants
+ (Full, Has_Unknown_Discriminants (Full_Base));
+ Set_First_Entity (Full, First_Entity (Full_Base));
+ Set_Last_Entity (Full, Last_Entity (Full_Base));
- if Is_Constrained (Full_Base) then
- Set_Is_Constrained (Full);
- end if;
+ -- If the underlying base type is constrained, we know that the
+ -- full view of the subtype is constrained as well (the converse
+ -- is not necessarily true).
- when others =>
- Copy_Node (Full_Base, Full);
+ if Is_Constrained (Full_Base) then
+ Set_Is_Constrained (Full);
+ end if;
- Set_Chars (Full, Chars (Priv));
- Conditional_Delay (Full, Priv);
- Set_Sloc (Full, Sloc (Priv));
- end case;
+ else
+ Copy_Node (Full_Base, Full);
+
+ -- The following subtlety with the Etype of the full view needs to be
+ -- taken into account here. One could think that it must naturally be
+ -- set to the base type of the full base:
+
+ -- Set_Etype (Full, Base_Type (Full_Base));
+
+ -- so that the full view becomes a subtype of the full base when the
+ -- latter is a base type, which must for example happen when the full
+ -- base is declared as derived type. That's also correct if the full
+ -- base is declared as an array type, or a floating-point type, or a
+ -- fixed-point type, or a signed integer type, as these declarations
+ -- create an implicit base type and a first subtype so the Etype of
+ -- the full views must be the implicit base type. But that's wrong
+ -- if the full base is declared as an access type, or an enumeration
+ -- type, or a modular integer type, as these declarations directly
+ -- create a base type, i.e. with Etype pointing to itself. Moreover
+ -- the full base being declared in the private part, i.e. when the
+ -- views are swapped, the end result is that the Etype of the full
+ -- base is set to its private view in this case and that we need to
+ -- propagate this setting to the full view in order for the subtype
+ -- to be compatible with the base type.
+
+ if Is_Base_Type (Full_Base)
+ and then (Is_Derived_Type (Full_Base)
+ or else Ekind (Full_Base) in Array_Kind
+ or else Ekind (Full_Base) in Fixed_Point_Kind
+ or else Ekind (Full_Base) in Float_Kind
+ or else Ekind (Full_Base) in Signed_Integer_Kind)
+ then
+ Set_Etype (Full, Full_Base);
+ end if;
+
+ Set_Chars (Full, Chars (Priv));
+ Set_Sloc (Full, Sloc (Priv));
+ Conditional_Delay (Full, Priv);
+ end if;
Link_Entities (Full, Save_Next_Entity);
Set_Homonym (Full, Save_Homonym);
-- Set common attributes for all subtypes: kind, convention, etc.
- Set_Ekind (Full, Subtype_Kind (Ekind (Full_Base)));
- Set_Convention (Full, Convention (Full_Base));
-
- -- The Etype of the full view is inconsistent. Gigi needs to see the
- -- structural full view, which is what the current scheme gives: the
- -- Etype of the full view is the etype of the full base. However, if the
- -- full base is a derived type, the full view then looks like a subtype
- -- of the parent, not a subtype of the full base. If instead we write:
-
- -- Set_Etype (Full, Full_Base);
-
- -- then we get inconsistencies in the front-end (confusion between
- -- views). Several outstanding bugs are related to this ???
-
+ Set_Ekind (Full, Subtype_Kind (Ekind (Full_Base)));
+ Set_Convention (Full, Convention (Full_Base));
Set_Is_First_Subtype (Full, False);
Set_Scope (Full, Scope (Priv));
Set_Size_Info (Full, Full_Base);
Set_RM_Size (Full, RM_Size (Full_Base));
Set_Is_Itype (Full);
- -- For the unusual case of a type with unknown discriminants whose
- -- completion is an array, use the proper full base.
-
- if Is_Array_Type (Full_Base)
- and then Has_Unknown_Discriminants (Priv)
- then
- Set_Etype (Full, Full_Base);
- end if;
-
-- A subtype of a private-type-without-discriminants, whose full-view
-- has discriminants with default expressions, is not constrained.
Set_Freeze_Node (Full, Empty);
Set_Is_Frozen (Full, False);
- Set_Full_View (Priv, Full);
if Has_Discriminants (Full) then
Set_Stored_Constraint_From_Discriminant_Constraint (Full);
(Full, Related_Nod, Full_Base, Discriminant_Constraint (Priv));
-- If the full base is itself derived from private, build a congruent
- -- subtype of its underlying type, for use by the back end. For a
- -- constrained record component, the declaration cannot be placed on
- -- the component list, but it must nevertheless be built an analyzed, to
- -- supply enough information for Gigi to compute the size of component.
+ -- subtype of its underlying full view, for use by the back end.
- elsif Ekind (Full_Base) in Private_Kind
- and then Is_Derived_Type (Full_Base)
- and then Has_Discriminants (Full_Base)
- and then (Ekind (Current_Scope) /= E_Record_Subtype)
+ elsif Is_Private_Type (Full_Base)
+ and then Present (Underlying_Full_View (Full_Base))
then
- if not Is_Itype (Priv)
- and then
- Nkind (Subtype_Indication (Parent (Priv))) = N_Subtype_Indication
- then
- Build_Underlying_Full_View
- (Parent (Priv), Full, Etype (Full_Base));
-
- elsif Nkind (Related_Nod) = N_Component_Declaration then
- Build_Underlying_Full_View (Related_Nod, Full, Etype (Full_Base));
- end if;
+ declare
+ Underlying_Full_Base : constant Entity_Id
+ := Underlying_Full_View (Full_Base);
+ Underlying_Full : constant Entity_Id
+ := Make_Defining_Identifier (Sloc (Priv), Chars (Priv));
+ begin
+ Set_Is_Itype (Underlying_Full);
+ Set_Associated_Node_For_Itype (Underlying_Full, Related_Nod);
+ Complete_Private_Subtype
+ (Priv, Underlying_Full, Underlying_Full_Base, Related_Nod);
+ Set_Underlying_Full_View (Full, Underlying_Full);
+ Set_Is_Underlying_Full_View (Underlying_Full);
+ end;
elsif Is_Record_Type (Full_Base) then
-- Show Full is simply a renaming of Full_Base
Set_Cloned_Subtype (Full, Full_Base);
+
+ -- Propagate predicates
+
+ if Has_Predicates (Full_Base) then
+ Set_Has_Predicates (Full);
+
+ if Present (Predicate_Function (Full_Base))
+ and then No (Predicate_Function (Full))
+ then
+ Set_Predicate_Function (Full, Predicate_Function (Full_Base));
+ end if;
+ end if;
end if;
-- It is unsafe to share the bounds of a scalar type, because the Itype
- -- is elaborated on demand, and if a bound is non-static then different
+ -- is elaborated on demand, and if a bound is nonstatic, then different
-- orders of elaboration in different units will lead to different
-- external symbols.
or else Is_Incomplete_Or_Private_Type (Desig_Type))
and then not Is_Constrained (Desig_Type)
then
- -- ??? The following code is a temporary bypass to ignore a
- -- discriminant constraint on access type if it is constraining
- -- the current record. Avoid creating the implicit subtype of the
- -- record we are currently compiling since right now, we cannot
- -- handle these. For now, just return the access type itself.
+ -- If this is a constrained access definition for a record
+ -- component, we leave the type as an unconstrained access,
+ -- and mark the component so that its actual type is built
+ -- at a point of use (e.g., an assignment statement). This
+ -- is handled in Sem_Util.Build_Actual_Subtype_Of_Component.
if Desig_Type = Current_Scope
and then No (Def_Id)
then
+ Desig_Subtype :=
+ Create_Itype
+ (E_Void, Related_Nod, Scope_Id => Scope (Desig_Type));
Set_Ekind (Desig_Subtype, E_Record_Subtype);
Def_Id := Entity (Subtype_Mark (S));
+ -- We indicate that the component has a per-object constraint
+ -- for treatment at a point of use, even though the constraint
+ -- may be independent of discriminants of the enclosing type.
+
+ if Nkind (Related_Nod) = N_Component_Declaration then
+ Set_Has_Per_Object_Constraint
+ (Defining_Identifier (Related_Nod));
+ end if;
+
-- This call added to ensure that the constraint is analyzed
-- (needed for a B test). Note that we still return early from
- -- this procedure to avoid recursive processing. ???
+ -- this procedure to avoid recursive processing.
Constrain_Discriminated_Type
(Desig_Subtype, S, Related_Nod, For_Access => True);
Set_Is_Constrained (Def_Id, True);
Set_Is_Aliased (Def_Id, Is_Aliased (T));
+ Set_Is_Independent (Def_Id, Is_Independent (T));
Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id));
Set_Is_Private_Composite (Def_Id, Is_Private_Composite (T));
function Build_Constrained_Discriminated_Type
(Old_Type : Entity_Id) return Entity_Id;
- -- Ditto for record components
+ -- Ditto for record components. Handle the case where the constraint
+ -- is a conversion of the discriminant value, introduced during
+ -- expansion.
function Build_Constrained_Access_Type
(Old_Type : Entity_Id) return Entity_Id;
if Is_Discriminant (Expr) then
Need_To_Create_Itype := True;
+
+ -- After expansion of discriminated task types, the value
+ -- of the discriminant may be converted to a run-time type
+ -- for restricted run-times. Propagate the value of the
+ -- discriminant as well, so that e.g. the secondary stack
+ -- component has a static constraint. Necessary for LLVM.
+
+ elsif Nkind (Expr) = N_Type_Conversion
+ and then Is_Discriminant (Expression (Expr))
+ then
+ Need_To_Create_Itype := True;
end if;
Next_Elmt (Old_Constraint);
if Is_Discriminant (Expr) then
Expr := Get_Discr_Value (Expr);
+
+ elsif Nkind (Expr) = N_Type_Conversion
+ and then Is_Discriminant (Expression (Expr))
+ then
+ Expr := New_Copy_Tree (Expr);
+ Set_Expression (Expr, Get_Discr_Value (Expression (Expr)));
end if;
Append (New_Copy_Tree (Expr), To => Constr_List);
Related_Nod : Node_Id) return Entity_Id
is
T_Sub : constant Entity_Id :=
- Create_Itype (E_Record_Subtype,
- Related_Nod, Corr_Rec, 'C', Suffix_Index => -1);
+ Create_Itype
+ (Ekind => E_Record_Subtype,
+ Related_Nod => Related_Nod,
+ Related_Id => Corr_Rec,
+ Suffix => 'C',
+ Suffix_Index => -1);
begin
Set_Etype (T_Sub, Corr_Rec);
Set_Has_Discriminants (T_Sub, Has_Discriminants (Prot_Subt));
+ Set_Is_Tagged_Type (T_Sub, Is_Tagged_Type (Corr_Rec));
Set_Is_Constrained (T_Sub, True);
Set_First_Entity (T_Sub, First_Entity (Corr_Rec));
Set_Last_Entity (T_Sub, Last_Entity (Corr_Rec));
procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id) is
begin
- Set_Component_Alignment (T1, Component_Alignment (T2));
- Set_Component_Type (T1, Component_Type (T2));
- Set_Component_Size (T1, Component_Size (T2));
- Set_Has_Controlled_Component (T1, Has_Controlled_Component (T2));
- Set_Has_Non_Standard_Rep (T1, Has_Non_Standard_Rep (T2));
- Propagate_Concurrent_Flags (T1, T2);
- Set_Is_Packed (T1, Is_Packed (T2));
- Set_Has_Aliased_Components (T1, Has_Aliased_Components (T2));
- Set_Has_Atomic_Components (T1, Has_Atomic_Components (T2));
- Set_Has_Volatile_Components (T1, Has_Volatile_Components (T2));
+ Set_Component_Alignment (T1, Component_Alignment (T2));
+ Set_Component_Type (T1, Component_Type (T2));
+ Set_Component_Size (T1, Component_Size (T2));
+ Set_Has_Controlled_Component (T1, Has_Controlled_Component (T2));
+ Set_Has_Non_Standard_Rep (T1, Has_Non_Standard_Rep (T2));
+ Propagate_Concurrent_Flags (T1, T2);
+ Set_Is_Packed (T1, Is_Packed (T2));
+ Set_Has_Aliased_Components (T1, Has_Aliased_Components (T2));
+ Set_Has_Atomic_Components (T1, Has_Atomic_Components (T2));
+ Set_Has_Independent_Components (T1, Has_Independent_Components (T2));
+ Set_Has_Volatile_Components (T1, Has_Volatile_Components (T2));
end Copy_Array_Base_Type_Attributes;
-----------------------------------
begin
Set_Size_Info (T1, T2);
- Set_First_Index (T1, First_Index (T2));
- Set_Is_Aliased (T1, Is_Aliased (T2));
- Set_Is_Volatile (T1, Is_Volatile (T2));
- Set_Treat_As_Volatile (T1, Treat_As_Volatile (T2));
- Set_Is_Constrained (T1, Is_Constrained (T2));
- Set_Depends_On_Private (T1, Has_Private_Component (T2));
- Inherit_Rep_Item_Chain (T1, T2);
- Set_Convention (T1, Convention (T2));
- Set_Is_Limited_Composite (T1, Is_Limited_Composite (T2));
- Set_Is_Private_Composite (T1, Is_Private_Composite (T2));
- Set_Packed_Array_Impl_Type (T1, Packed_Array_Impl_Type (T2));
+ Set_First_Index (T1, First_Index (T2));
+ Set_Is_Aliased (T1, Is_Aliased (T2));
+ Set_Is_Atomic (T1, Is_Atomic (T2));
+ Set_Is_Independent (T1, Is_Independent (T2));
+ Set_Is_Volatile (T1, Is_Volatile (T2));
+ Set_Is_Volatile_Full_Access (T1, Is_Volatile_Full_Access (T2));
+ Set_Treat_As_Volatile (T1, Treat_As_Volatile (T2));
+ Set_Is_Constrained (T1, Is_Constrained (T2));
+ Set_Depends_On_Private (T1, Has_Private_Component (T2));
+ Inherit_Rep_Item_Chain (T1, T2);
+ Set_Convention (T1, Convention (T2));
+ Set_Is_Limited_Composite (T1, Is_Limited_Composite (T2));
+ Set_Is_Private_Composite (T1, Is_Private_Composite (T2));
+ Set_Packed_Array_Impl_Type (T1, Packed_Array_Impl_Type (T2));
end Copy_Array_Subtype_Attributes;
-----------------------------------
Set_Derived_Name;
-- Otherwise, the type is inheriting a private operation, so enter it
- -- with a special name so it can't be overridden.
+ -- with a special name so it can't be overridden. See also below, where
+ -- we check for this case, and if so avoid setting Requires_Overriding.
else
Set_Chars (New_Subp, New_External_Name (Chars (Parent_Subp), 'P'));
or else Is_Abstract_Subprogram (Alias (New_Subp))
then
Set_Is_Abstract_Subprogram (New_Subp);
- else
+
+ -- If the Chars of the new subprogram is different from that of the
+ -- parent's one, it means that we entered it with a special name so
+ -- it can't be overridden (see above). In that case we had better not
+ -- *require* it to be overridden. This is the case where the parent
+ -- type inherited the operation privately, so there's no danger of
+ -- dangling dispatching.
+
+ elsif Chars (New_Subp) = Chars (Alias (New_Subp)) then
Set_Requires_Overriding (New_Subp);
end if;
-- Because the implicit base is used in the conversion of the bounds, we
-- have to freeze it now. This is similar to what is done for numeric
- -- types, and it equally suspicious, but otherwise a non-static bound
+ -- types, and it equally suspicious, but otherwise a nonstatic bound
-- will have a reference to an unfrozen type, which is rejected by Gigi
-- (???). This requires specific care for definition of stream
-- attributes. For details, see comments at the end of
Digs_Val : Uint;
Base_Typ : Entity_Id;
Implicit_Base : Entity_Id;
- Bound : Node_Id;
function Can_Derive_From (E : Entity_Id) return Boolean;
-- Find if given digits value, and possibly a specified range, allows
-- derivation from specified type
+ procedure Convert_Bound (B : Node_Id);
+ -- If specified, the bounds must be static but may be of different
+ -- types. They must be converted into machine numbers of the base type,
+ -- in accordance with RM 4.9(38).
+
function Find_Base_Type return Entity_Id;
-- Find a predefined base type that Def can derive from, or generate
-- an error and substitute Long_Long_Float if none exists.
return True;
end Can_Derive_From;
+ -------------------
+ -- Convert_Bound --
+ --------------------
+
+ procedure Convert_Bound (B : Node_Id) is
+ begin
+ -- If the bound is not a literal it can only be static if it is
+ -- a static constant, possibly of a specified type.
+
+ if Is_Entity_Name (B)
+ and then Ekind (Entity (B)) = E_Constant
+ then
+ Rewrite (B, Constant_Value (Entity (B)));
+ end if;
+
+ if Nkind (B) = N_Real_Literal then
+ Set_Realval (B, Machine (Base_Typ, Realval (B), Round, B));
+ Set_Is_Machine_Number (B);
+ Set_Etype (B, Base_Typ);
+ end if;
+ end Convert_Bound;
+
--------------------
-- Find_Base_Type --
--------------------
Set_Scalar_Range (T, Real_Range_Specification (Def));
Set_Is_Constrained (T);
- -- The bounds of this range must be converted to machine numbers
- -- in accordance with RM 4.9(38).
-
- Bound := Type_Low_Bound (T);
-
- if Nkind (Bound) = N_Real_Literal then
- Set_Realval
- (Bound, Machine (Base_Typ, Realval (Bound), Round, Bound));
- Set_Is_Machine_Number (Bound);
- end if;
-
- Bound := Type_High_Bound (T);
-
- if Nkind (Bound) = N_Real_Literal then
- Set_Realval
- (Bound, Machine (Base_Typ, Realval (Bound), Round, Bound));
- Set_Is_Machine_Number (Bound);
- end if;
+ Convert_Bound (Type_Low_Bound (T));
+ Convert_Bound (Type_High_Bound (T));
else
Set_Scalar_Range (T, Scalar_Range (Base_Typ));
end if;
-- In the subtype indication case, if the immediate parent of the
- -- new subtype is non-static, then the subtype we create is non-
- -- static, even if its bounds are static.
+ -- new subtype is nonstatic, then the subtype we create is nonstatic,
+ -- even if its bounds are static.
if Nkind (N) = N_Subtype_Indication
and then not Is_OK_Static_Subtype (Entity (Subtype_Mark (N)))
=>
return not Comes_From_Source (Exp)
and then
- OK_For_Limited_Init_In_05
- (Typ, Expression (Original_Node (Exp)));
+ -- If the conversion has been rewritten, check Original_Node
+
+ ((Original_Node (Exp) /= Exp
+ and then
+ OK_For_Limited_Init_In_05 (Typ, Original_Node (Exp)))
+
+ -- Otherwise, check the expression of the compiler-generated
+ -- conversion (which is a conversion that we want to ignore
+ -- for purposes of the limited-initialization restrictions).
+
+ or else
+ (Original_Node (Exp) = Exp
+ and then
+ OK_For_Limited_Init_In_05 (Typ, Expression (Exp))));
when N_Explicit_Dereference
| N_Indexed_Component
Related_Nod : Node_Id)
is
Id_B : constant Entity_Id := Base_Type (Id);
- Full_B : Entity_Id := Full_View (Id_B);
+ Full_B : constant Entity_Id := Full_View (Id_B);
Full : Entity_Id;
begin
if Present (Full_B) then
- -- Get to the underlying full view if necessary
-
- if Is_Private_Type (Full_B)
- and then Present (Underlying_Full_View (Full_B))
- then
- Full_B := Underlying_Full_View (Full_B);
- end if;
-
-- The Base_Type is already completed, we can complete the subtype
-- now. We have to create a new entity with the same name, Thus we
-- can't use Create_Itype.
Set_Is_Itype (Full);
Set_Associated_Node_For_Itype (Full, Related_Nod);
Complete_Private_Subtype (Id, Full, Full_B, Related_Nod);
+ Set_Full_View (Id, Full);
end if;
-- The parent subtype may be private, but the base might not, in some
end if;
Complete_Private_Subtype (Full, Priv, Full_T, N);
+ Set_Full_View (Full, Priv);
if Present (Priv_Scop) then
Pop_Scope;
Set_Ekind (Tag_Comp, E_Component);
Set_Is_Tag (Tag_Comp);
Set_Is_Aliased (Tag_Comp);
+ Set_Is_Independent (Tag_Comp);
Set_Etype (Tag_Comp, RTE (RE_Tag));
Set_DT_Entry_Count (Tag_Comp, No_Uint);
Set_Original_Record_Component (Tag_Comp, Tag_Comp);
end if;
end Record_Type_Definition;
- ------------------------
- -- Replace_Components --
- ------------------------
+ ---------------------------
+ -- Replace_Discriminants --
+ ---------------------------
- procedure Replace_Components (Typ : Entity_Id; Decl : Node_Id) is
+ procedure Replace_Discriminants (Typ : Entity_Id; Decl : Node_Id) is
function Process (N : Node_Id) return Traverse_Result;
-------------
if Nkind (N) = N_Discriminant_Specification then
Comp := First_Discriminant (Typ);
while Present (Comp) loop
- if Chars (Comp) = Chars (Defining_Identifier (N)) then
+ if Original_Record_Component (Comp) = Defining_Identifier (N)
+ or else Chars (Comp) = Chars (Defining_Identifier (N))
+ then
Set_Defining_Identifier (N, Comp);
exit;
end if;
elsif Nkind (N) = N_Variant_Part then
Comp := First_Discriminant (Typ);
while Present (Comp) loop
- if Chars (Comp) = Chars (Name (N)) then
- Set_Entity (Name (N), Comp);
+ if Original_Record_Component (Comp) = Entity (Name (N))
+ or else Chars (Comp) = Chars (Name (N))
+ then
+ Set_Name (N, New_Occurrence_Of (Comp, Sloc (N)));
exit;
end if;
Next_Discriminant (Comp);
end loop;
-
- elsif Nkind (N) = N_Component_Declaration then
- Comp := First_Component (Typ);
- while Present (Comp) loop
- if Chars (Comp) = Chars (Defining_Identifier (N)) then
- Set_Defining_Identifier (N, Comp);
- exit;
- end if;
-
- Next_Component (Comp);
- end loop;
end if;
return OK;
procedure Replace is new Traverse_Proc (Process);
- -- Start of processing for Replace_Components
+ -- Start of processing for Replace_Discriminants
begin
Replace (Decl);
- end Replace_Components;
+ end Replace_Discriminants;
-------------------------------
-- Set_Completion_Referenced --
("non-static expression used for integer type bound!", Expr);
Errs := True;
- -- The bounds are folded into literals, and we set their type to be
- -- universal, to avoid typing difficulties: we cannot set the type
- -- of the literal to the new type, because this would be a forward
- -- reference for the back end, and if the original type is user-
- -- defined this can lead to spurious semantic errors (e.g. 2928-003).
-
- else
- if Is_Entity_Name (Expr) then
- Fold_Uint (Expr, Expr_Value (Expr), True);
- end if;
+ -- Otherwise the bounds are folded into literals
- Set_Etype (Expr, Universal_Integer);
+ elsif Is_Entity_Name (Expr) then
+ Fold_Uint (Expr, Expr_Value (Expr), True);
end if;
end Check_Bound;
if Hi = Error or else Lo = Error then
Base_Typ := Any_Integer;
Set_Error_Posted (T, True);
+ Errs := True;
-- Here both bounds are OK expressions
end if;
end if;
+ -- Set the type of the bounds to the implicit base: we cannot set it to
+ -- the new type, because this would be a forward reference for the code
+ -- generator and, if the original type is user-defined, this could even
+ -- lead to spurious semantic errors. Furthermore we do not set it to be
+ -- universal, because this could make it much larger than needed here.
+
+ if not Errs then
+ Set_Etype (Lo, Implicit_Base);
+ Set_Etype (Hi, Implicit_Base);
+ end if;
+
-- Complete both implicit base and declared first subtype entities. The
-- inheritance of the rep item chain ensures that SPARK-related pragmas
-- are not clobbered when the signed integer type acts as a full view of
projects / thirdparty / gcc.git / blobdiff