Skip to content

R
riscv-gcc-1
Commit fea9e956 by Ed Schonberg Committed by Arnaud Charlet
Options

errout.adb (Unwind_Internal_Type): Use predicate Is_Access__Protected_Subprogram_Type. 

2007-04-06  Ed Schonberg  <schonberg@adacore.com>
	    Robert Dewar  <dewar@adacore.com>
	    Bob Duff  <duff@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>

	* errout.adb (Unwind_Internal_Type): Use predicate
	Is_Access__Protected_Subprogram_Type.

	* freeze.adb (Size_Known): Use First/Next_Component_Or_Discriminant
	(Freeze_Entity, packed array case): Do not override explicitly set
	alignment and size clauses.
	(Freeze_Entity):  An entity declared in an outer scope can be frozen if
	the enclosing subprogram is a child unit body that acts as a spec.
	(Freeze_Entity): Use new predicate Is_Access_Protected_Subprogram_Type.
	(Freeze_Record_Type): New Ada 2005 processing for reverse bit order
	Remove all code for DSP option

	* layout.adb (Layout_Record_Type): Use First/
	Next_Component_Or_Discriminant
	(Layout_Type): Use new predicate Is_Access_Protected_Subprogram_Type,
	to handle properly the anonymous access case.

	* sem_attr.adb (Build_Access_Object_Type): Use E_Access_Attribute_Type
	for all access attributes, because overload resolution should work the
	same for 'Access, 'Unchecked_Access, and 'Unrestricted_Access. This
	causes the error message for the ambiguous "X'Access = Y'Access" and
	"X'Unrestricted_Access = Y'Access" and so forth to match.
	(Resolve_Attribute, case 'Access): Remove use of Original_Access_Type,
	now that anonymous access to protected operations have their own kind.
	(Resolve_Attribute): In case of dispatching call check the violation of
	restriction No_Dispatching_Calls.
	(Check_Array_Type): Check new -gnatyA array index style option

	* sem_ch3.ads, sem_ch3.adb (Derived_Type_Declaration): Reject an
	attempt to derive from a synchronized tagged type.
	(Analyze_Type_Declaration): If there is a incomplete tagged view of the
	type, inherit the class-wide type already created, because it may
	already have been used in a self-referential anonymous access component.
	(Mentions_T): Recognize self-referential anonymous access components
	that use (a subtype of) the class-wide type of the enclosing type.
	(Build_Derived_Record_Type): Add earlier setting of Is_Tagged_Type. Pass
	Derived_Type for Prev formal on call to
	Check_Anonymous_Access_Components rather than Empty.
	(Make_Incomplete_Type_Declaration): Add test for case where the type has
	a record extension in deciding whether to create a class-wide type,
	rather than just checking Tagged_Present.
	(Replace_Anonymous_Access_To_Protected_Subprogram): Procedure applies
	to stand-alone object declarations as well as component declarations.
	(Array_Type_Declaration): Initialize Packed_Array_Type to Empty, to
	prevent accidental overwriting when enclosing package appears in
	a limited_with_clause.
	(Array_Type_Declaration): If the component type is an anonymous access,
	the associated_node for the itype is the type declaration itself.
	(Add_Interface_Tag_Components): Modified to support concurrent
	types with abstract interfaces.
	(Check_Abstract_Interfaces): New subprogram that verifies the ARM
	rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2).
	(Build_Derived_Record_Type): Add call to Analyze_Interface_Declaration
	to complete the decoration of synchronized interface types. Add also
	a call to Check_Abstract_Interfaces to verify the ARM rules.
	(Derive_Interface_Subprograms): Modified to support concurrent types
	with abstract interfaces.
	(Analyze_Subtype_Indication): Resolve the range with the given subtype
	mark, rather than delaying the full resolution depending on context.
	(Analyze_Component_Declaration,Analyze_Interface_Declaration,
	Analyze_Object_Declaration,Analyze_Subtype_Declaration,
	Array_Type_Declaration,Build_Derived_Record_Type,
	Build_Discriminated_Subtype,Check_Abstract_Overriding,Check_Completion,
	Derive_Interface_Subprograms,Derive_Subprogram,Make_Class_Wide_Type,
	Process_Full_View,Record_Type_Declaration): Split Is_Abstract flag into
	Is_Abstract_Subprogram and Is_Abstract_Type. Make sure these are
	called only when appropriate.
	(Copy_And_Swap): Copy Has_Unreferenced_Objects flag from full type
	to private type.
	(Analyze_Subtype_Declaration): For an access subtype declaration, create
	an itype reference for the anonymous designated subtype, to prevent
	scope anonmalies in gigi.
	(Build_Itype_Reference): New utility, to simplify construction of such
	references.

From-SVN: r123559
parent f937473f
Showing with 1171 additions and 792 deletions
gcc/ada/errout.adb
......@@ -2706,7 +2706,7 @@ package body Errout is
if Is_Access_Type (Ent) then
if Ekind (Ent) = E_Access_Subprogram_Type
or else Ekind (Ent) = E_Anonymous_Access_Subprogram_Type
or else Ekind (Ent) = E_Access_Protected_Subprogram_Type
or else Is_Access_Protected_Subprogram_Type (Ent)
then
Ent := Directly_Designated_Type (Ent);
......
gcc/ada/freeze.adb
......@@ -727,144 +727,132 @@ package body Freeze is
-- Loop through components
Comp := First_Entity (T);
Comp := First_Component_Or_Discriminant (T);
while Present (Comp) loop
if Ekind (Comp) = E_Component
or else
Ekind (Comp) = E_Discriminant
then
Ctyp := Etype (Comp);
Ctyp := Etype (Comp);
-- We do not know the packed size if there is a
-- component clause present (we possibly could,
-- but this would only help in the case of a record
-- with partial rep clauses. That's because in the
-- case of full rep clauses, the size gets figured
-- out anyway by a different circuit).
-- We do not know the packed size if there is a component
-- clause present (we possibly could, but this would only
-- help in the case of a record with partial rep clauses.
-- That's because in the case of full rep clauses, the
-- size gets figured out anyway by a different circuit).
if Present (Component_Clause (Comp)) then
Packed_Size_Known := False;
end if;
if Present (Component_Clause (Comp)) then
Packed_Size_Known := False;
end if;
-- We need to identify a component that is an array
-- where the index type is an enumeration type with
-- non-standard representation, and some bound of the
-- type depends on a discriminant.
-- This is because gigi computes the size by doing a
-- substituation of the appropriate discriminant value
-- in the size expression for the base type, and gigi
-- is not clever enough to evaluate the resulting
-- expression (which involves a call to rep_to_pos)
-- at compile time.
-- It would be nice if gigi would either recognize that
-- this expression can be computed at compile time, or
-- alternatively figured out the size from the subtype
-- directly, where all the information is at hand ???
if Is_Array_Type (Etype (Comp))
and then Present (Packed_Array_Type (Etype (Comp)))
then
declare
Ocomp : constant Entity_Id :=
Original_Record_Component (Comp);
OCtyp : constant Entity_Id := Etype (Ocomp);
Ind : Node_Id;
Indtyp : Entity_Id;
Lo, Hi : Node_Id;
-- We need to identify a component that is an array where
-- the index type is an enumeration type with non-standard
-- representation, and some bound of the type depends on a
-- discriminant.
begin
Ind := First_Index (OCtyp);
while Present (Ind) loop
Indtyp := Etype (Ind);
-- This is because gigi computes the size by doing a
-- substituation of the appropriate discriminant value in
-- the size expression for the base type, and gigi is not
-- clever enough to evaluate the resulting expression (which
-- involves a call to rep_to_pos) at compile time.
if Is_Enumeration_Type (Indtyp)
and then Has_Non_Standard_Rep (Indtyp)
then
Lo := Type_Low_Bound (Indtyp);
Hi := Type_High_Bound (Indtyp);
if Is_Entity_Name (Lo)
and then
Ekind (Entity (Lo)) = E_Discriminant
then
return False;
elsif Is_Entity_Name (Hi)
and then
Ekind (Entity (Hi)) = E_Discriminant
then
return False;
end if;
end if;
-- It would be nice if gigi would either recognize that
-- this expression can be computed at compile time, or
-- alternatively figured out the size from the subtype
-- directly, where all the information is at hand ???
Next_Index (Ind);
end loop;
end;
end if;
if Is_Array_Type (Etype (Comp))
and then Present (Packed_Array_Type (Etype (Comp)))
then
declare
Ocomp : constant Entity_Id :=
Original_Record_Component (Comp);
OCtyp : constant Entity_Id := Etype (Ocomp);
Ind : Node_Id;
Indtyp : Entity_Id;
Lo, Hi : Node_Id;
-- Clearly size of record is not known if the size of
-- one of the components is not known.
begin
Ind := First_Index (OCtyp);
while Present (Ind) loop
Indtyp := Etype (Ind);
if not Size_Known (Ctyp) then
return False;
end if;
if Is_Enumeration_Type (Indtyp)
and then Has_Non_Standard_Rep (Indtyp)
then
Lo := Type_Low_Bound (Indtyp);
Hi := Type_High_Bound (Indtyp);
-- Accumulate packed size if possible
if Is_Entity_Name (Lo)
and then Ekind (Entity (Lo)) = E_Discriminant
then
return False;
if Packed_Size_Known then
elsif Is_Entity_Name (Hi)
and then Ekind (Entity (Hi)) = E_Discriminant
then
return False;
end if;
end if;
-- We can only deal with elementary types, since for
-- non-elementary components, alignment enters into
-- the picture, and we don't know enough to handle
-- proper alignment in this context. Packed arrays
-- count as elementary if the representation is a
-- modular type.
Next_Index (Ind);
end loop;
end;
end if;
if Is_Elementary_Type (Ctyp)
or else (Is_Array_Type (Ctyp)
and then
Present (Packed_Array_Type (Ctyp))
and then
Is_Modular_Integer_Type
(Packed_Array_Type (Ctyp)))
then
-- If RM_Size is known and static, then we can
-- keep accumulating the packed size.
-- Clearly size of record is not known if the size of
-- one of the components is not known.
if Known_Static_RM_Size (Ctyp) then
if not Size_Known (Ctyp) then
return False;
end if;
-- A little glitch, to be removed sometime ???
-- gigi does not understand zero sizes yet.
-- Accumulate packed size if possible
if RM_Size (Ctyp) = Uint_0 then
Packed_Size_Known := False;
if Packed_Size_Known then
-- Normal case where we can keep accumulating
-- the packed array size.
-- We can only deal with elementary types, since for
-- non-elementary components, alignment enters into the
-- picture, and we don't know enough to handle proper
-- alignment in this context. Packed arrays count as
-- elementary if the representation is a modular type.
else
Packed_Size := Packed_Size + RM_Size (Ctyp);
end if;
if Is_Elementary_Type (Ctyp)
or else (Is_Array_Type (Ctyp)
and then Present (Packed_Array_Type (Ctyp))
and then Is_Modular_Integer_Type
(Packed_Array_Type (Ctyp)))
then
-- If RM_Size is known and static, then we can
-- keep accumulating the packed size.
-- If we have a field whose RM_Size is not known
-- then we can't figure out the packed size here.
if Known_Static_RM_Size (Ctyp) then
else
-- A little glitch, to be removed sometime ???
-- gigi does not understand zero sizes yet.
if RM_Size (Ctyp) = Uint_0 then
Packed_Size_Known := False;
-- Normal case where we can keep accumulating the
-- packed array size.
else
Packed_Size := Packed_Size + RM_Size (Ctyp);
end if;
-- If we have a non-elementary type we can't figure
-- out the packed array size (alignment issues).
-- If we have a field whose RM_Size is not known then
-- we can't figure out the packed size here.
else
Packed_Size_Known := False;
end if;
-- If we have a non-elementary type we can't figure out
-- the packed array size (alignment issues).
else
Packed_Size_Known := False;
end if;
end if;
Next_Entity (Comp);
Next_Component_Or_Discriminant (Comp);
end loop;
if Packed_Size_Known then
......@@ -1627,9 +1615,9 @@ package body Freeze is
end if;
-- If component clause is present, then deal with the
-- non-default bit order case. We cannot do this before
-- the freeze point, because there is no required order
-- for the component clause and the bit_order clause.
-- non-default bit order case for Ada 95 mode. The required
-- processing for Ada 2005 mode is handled separately after
-- processing all components.
-- We only do this processing for the base type, and in
-- fact that's important, since otherwise if there are
......@@ -1639,6 +1627,7 @@ package body Freeze is
if Present (CC)
and then Reverse_Bit_Order (Rec)
and then Ekind (E) = E_Record_Type
and then Ada_Version <= Ada_95
then
declare
CFB : constant Uint := Component_Bit_Offset (Comp);
......@@ -1693,7 +1682,9 @@ package body Freeze is
else
-- Give warning if suspicious component clause
if Intval (FB) >= System_Storage_Unit then
if Intval (FB) >= System_Storage_Unit
and then Warn_On_Reverse_Bit_Order
then
Error_Msg_N
("?Bit_Order clause does not affect " &
"byte ordering", Pos);
......@@ -1762,20 +1753,20 @@ package body Freeze is
S : Entity_Id := Scope (Rec);
begin
-- We have a pretty bad kludge here. Suppose Rec is a
-- subtype being defined in a subprogram that's created
-- as part of the freezing of Rec'Base. In that case,
-- we know that Comp'Base must have already been frozen by
-- the time we get to elaborate this because Gigi doesn't
-- elaborate any bodies until it has elaborated all of the
-- declarative part. But Is_Frozen will not be set at this
-- point because we are processing code in lexical order.
-- We detect this case by going up the Scope chain of
-- Rec and seeing if we have a subprogram scope before
-- reaching the top of the scope chain or that of Comp'Base.
-- If we do, then mark that Comp'Base will actually be
-- frozen. If so, we merely undelay it.
-- We have a pretty bad kludge here. Suppose Rec is subtype
-- being defined in a subprogram that's created as part of
-- the freezing of Rec'Base. In that case, we know that
-- Comp'Base must have already been frozen by the time we
-- get to elaborate this because Gigi doesn't elaborate any
-- bodies until it has elaborated all of the declarative
-- part. But Is_Frozen will not be set at this point because
-- we are processing code in lexical order.
-- We detect this case by going up the Scope chain of Rec
-- and seeing if we have a subprogram scope before reaching
-- the top of the scope chain or that of Comp'Base. If we
-- do, then mark that Comp'Base will actually be frozen. If
-- so, we merely undelay it.
while Present (S) loop
if Is_Subprogram (S) then
......@@ -1873,12 +1864,23 @@ package body Freeze is
Next_Entity (Comp);
end loop;
-- Check for useless pragma Bit_Order
-- Deal with pragma Bit_Order
if Reverse_Bit_Order (Rec) and then Base_Type (Rec) = Rec then
if not Placed_Component then
ADC :=
Get_Attribute_Definition_Clause (Rec, Attribute_Bit_Order);
Error_Msg_N
("?Bit_Order specification has no effect", ADC);
Error_Msg_N
("\?since no component clauses were specified", ADC);
-- Here is where we do Ada 2005 processing for bit order (the
-- Ada 95 case was already taken care of above).
if not Placed_Component and then Reverse_Bit_Order (Rec) then
ADC := Get_Attribute_Definition_Clause (Rec, Attribute_Bit_Order);
Error_Msg_N ("?Bit_Order specification has no effect", ADC);
Error_Msg_N ("\?since no component clauses were specified", ADC);
elsif Ada_Version >= Ada_05 then
Adjust_Record_For_Reverse_Bit_Order (Rec);
end if;
end if;
-- Check for useless pragma Pack when all components placed. We only
......@@ -2017,6 +2019,8 @@ package body Freeze is
-- must be diagnosed (see e.g. 1522-005). If the enclosing subprogram
-- comes from source, or is a generic instance, then the freeze point
-- is the one mandated by the language. and we freze the entity.
-- A subprogram that is a child unit body that acts as a spec does not
-- have a spec that comes from source, but can only come from source.
elsif In_Open_Scopes (Scope (Test_E))
and then Scope (Test_E) /= Current_Scope
......@@ -2030,6 +2034,7 @@ package body Freeze is
if Is_Overloadable (S) then
if Comes_From_Source (S)
or else Is_Generic_Instance (S)
or else Is_Child_Unit (S)
then
exit;
else
......@@ -2320,17 +2325,6 @@ package body Freeze is
Freeze_And_Append (Alias (E), Loc, Result);
end if;
-- If the return type requires a transient scope, and we are on
-- a target allowing functions to return with a depressed stack
-- pointer, then we mark the function as requiring this treatment.
if Ekind (E) = E_Function
and then Functions_Return_By_DSP_On_Target
and then Requires_Transient_Scope (Etype (E))
then
Set_Function_Returns_With_DSP (E);
end if;
if not Is_Internal (E) then
Freeze_Subprogram (E);
end if;
......@@ -2766,10 +2760,17 @@ package body Freeze is
Freeze_And_Append (Packed_Array_Type (E), Loc, Result);
-- Size information of packed array type is copied to the
-- array type, since this is really the representation.
-- array type, since this is really the representation. But
-- do not override explicit existing size values.
if not Has_Size_Clause (E) then
Set_Esize (E, Esize (Packed_Array_Type (E)));
Set_RM_Size (E, RM_Size (Packed_Array_Type (E)));
end if;
Set_Size_Info (E, Packed_Array_Type (E));
Set_RM_Size (E, RM_Size (Packed_Array_Type (E)));
if not Has_Alignment_Clause (E) then
Set_Alignment (E, Alignment (Packed_Array_Type (E)));
end if;
end if;
-- For non-packed arrays set the alignment of the array
......@@ -2993,16 +2994,6 @@ package body Freeze is
Next_Formal (Formal);
end loop;
-- If the return type requires a transient scope, and we are on
-- a target allowing functions to return with a depressed stack
-- pointer, then we mark the function as requiring this treatment.
if Functions_Return_By_DSP_On_Target
and then Requires_Transient_Scope (Etype (E))
then
Set_Function_Returns_With_DSP (E);
end if;
Freeze_Subprogram (E);
-- Ada 2005 (AI-326): Check wrong use of tag incomplete type
......@@ -3022,7 +3013,7 @@ package body Freeze is
-- (however this is not set if we are not generating code or if this
-- is an anonymous type used just for resolution).
elsif Ekind (E) = E_Access_Protected_Subprogram_Type then
elsif Is_Access_Protected_Subprogram_Type (E) then
-- AI-326: Check wrong use of tagged incomplete types
......@@ -3192,10 +3183,6 @@ package body Freeze is
if Is_Concurrent_Type (Aux_E)
and then Present (Corresponding_Record_Type (Aux_E))
then
pragma Assert (not Is_Empty_Elmt_List
(Abstract_Interfaces
(Corresponding_Record_Type (Aux_E))));
Prim_List := Primitive_Operations
(Corresponding_Record_Type (Aux_E));
else
......@@ -4458,7 +4445,6 @@ package body Freeze is
elsif Is_Record_Type (Typ) then
C := First_Entity (Typ);
while Present (C) loop
if Ekind (C) = E_Discriminant
or else Ekind (C) = E_Component
......
gcc/ada/layout.adb
......@@ -2252,12 +2252,9 @@ package body Layout is
Prev_Comp := Empty;
Comp := First_Entity (E);
Comp := First_Component_Or_Discriminant (E);
while Present (Comp) loop
if (Ekind (Comp) = E_Component
or else Ekind (Comp) = E_Discriminant)
and then Present (Component_Clause (Comp))
then
if Present (Component_Clause (Comp)) then
if No (Prev_Comp)
or else
Component_Bit_Offset (Comp) >
......@@ -2267,7 +2264,7 @@ package body Layout is
end if;
end if;
Next_Entity (Comp);
Next_Component_Or_Discriminant (Comp);
end loop;
-- We have two separate circuits, one for non-variant records and
......@@ -2336,7 +2333,7 @@ package body Layout is
-- backend figure out what is needed (it may be some kind
-- of fat pointer, including the static link for example.
elsif Ekind (E) = E_Access_Protected_Subprogram_Type then
elsif Is_Access_Protected_Subprogram_Type (E) then
null;
-- For access subtypes, copy the size information from base type
......
gcc/ada/sem_attr.adb
......@@ -58,6 +58,8 @@ with Stand; use Stand;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
with Stringt; use Stringt;
with Style;
with Stylesw; use Stylesw;
with Targparm; use Targparm;
with Ttypes; use Ttypes;
with Ttypef; use Ttypef;
......@@ -353,19 +355,10 @@ package body Sem_Attr is
------------------------------
function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id is
Typ : Entity_Id;
Typ : constant Entity_Id :=
New_Internal_Entity
(E_Access_Attribute_Type, Current_Scope, Loc, 'A');
begin
if Aname = Name_Unrestricted_Access then
Typ :=
New_Internal_Entity
(E_Allocator_Type, Current_Scope, Loc, 'A');
else
Typ :=
New_Internal_Entity
(E_Access_Attribute_Type, Current_Scope, Loc, 'A');
end if;
Set_Etype (Typ, Typ);
Init_Size_Align (Typ);
Set_Is_Itype (Typ);
......@@ -841,6 +834,12 @@ package body Sem_Attr is
Error_Attr ("invalid dimension number for array type", E1);
end if;
end if;
if (Style_Check and Style_Check_Array_Attribute_Index)
and then Comes_From_Source (N)
then
Style.Check_Array_Attribute_Index (N, E1, D);
end if;
end Check_Array_Type;
-------------------------
......@@ -1394,7 +1393,7 @@ package body Sem_Attr is
-- Note: the double call to Root_Type here is needed because the
-- root type of a class-wide type is the corresponding type (e.g.
-- X for X'Class, and we really want to go to the root.
-- X for X'Class, and we really want to go to the root.)
if not Is_Access_Type (Etyp)
or else Root_Type (Root_Type (Designated_Type (Etyp))) /=
......@@ -1900,7 +1899,28 @@ package body Sem_Attr is
begin
if Is_Subprogram (Ent) then
if not Is_Library_Level_Entity (Ent) then
if not Is_Library_Level_Entity (Ent)
-- Do not take into account nodes generated by the
-- expander for the elaboration of the dispatch tables;
-- otherwise we erroneously generate warnings indicating
-- violation of restriction No_Implicit_Dynamic_Code
-- with those nodes.
and then not (Is_Dispatching_Operation (Ent)
and then Nkind (Parent (N)) = N_Assignment_Statement
and then Nkind (Name (Parent (N))) = N_Indexed_Component
and then Nkind (Prefix (Name (Parent (N)))) =
N_Selected_Component
and then Nkind (Selector_Name
(Prefix (Name (Parent (N))))) =
N_Identifier
and then Present (Entity (Selector_Name
(Prefix (Name (Parent (N))))))
and then Entity (Selector_Name
(Prefix (Name (Parent (N))))) =
RTE_Record_Component (RE_Prims_Ptr))
then
Check_Restriction (No_Implicit_Dynamic_Code, P);
end if;
......@@ -7044,18 +7064,16 @@ package body Sem_Attr is
if Is_Entity_Name (P) then
if Is_Overloaded (P) then
Get_First_Interp (P, Index, It);
while Present (It.Nam) loop
if Type_Conformant (Designated_Type (Typ), It.Nam) then
Set_Entity (P, It.Nam);
-- The prefix is definitely NOT overloaded anymore
-- at this point, so we reset the Is_Overloaded
-- flag to avoid any confusion when reanalyzing
-- the node.
-- The prefix is definitely NOT overloaded anymore at
-- this point, so we reset the Is_Overloaded flag to
-- avoid any confusion when reanalyzing the node.
Set_Is_Overloaded (P, False);
Set_Is_Overloaded (N, False);
Generate_Reference (Entity (P), P);
exit;
end if;
......@@ -7063,12 +7081,20 @@ package body Sem_Attr is
Get_Next_Interp (Index, It);
end loop;
-- If it is a subprogram name or a type, there is nothing
-- to resolve.
-- If Prefix is a subprogram name, it is frozen by this
-- reference:
--
-- If it is a type, there is nothing to resolve.
-- If it is an object, complete its resolution.
elsif not Is_Overloadable (Entity (P))
and then not Is_Type (Entity (P))
then
elsif Is_Overloadable (Entity (P)) then
if not In_Default_Expression then
Insert_Actions (N, Freeze_Entity (Entity (P), Loc));
end if;
elsif Is_Type (Entity (P)) then
null;
else
Resolve (P);
end if;
......@@ -7077,8 +7103,8 @@ package body Sem_Attr is
if not Is_Entity_Name (P) then
null;
elsif Is_Abstract (Entity (P))
and then Is_Overloadable (Entity (P))
elsif Is_Overloadable (Entity (P))
and then Is_Abstract_Subprogram (Entity (P))
then
Error_Msg_N ("prefix of % attribute cannot be abstract", P);
Set_Etype (N, Any_Type);
......@@ -7211,16 +7237,27 @@ package body Sem_Attr is
if Enclosing_Generic_Unit (Entity (P)) /=
Enclosing_Generic_Unit (Root_Type (Btyp))
then
Error_Msg_N
("''Access attribute not allowed in generic body",
N);
if Root_Type (Btyp) = Btyp then
Error_Msg_N
("access type must not be outside generic unit",
N);
Error_Msg_NE
("\because " &
"access type & is declared outside " &
"generic unit ('R'M 3.10.2(32))", N, Btyp);
else
Error_Msg_N
("ancestor access type must not be outside " &
"generic unit", N);
Error_Msg_NE
("\because ancestor of " &
"access type & is declared outside " &
"generic unit ('R'M 3.10.2(32))", N, Btyp);
end if;
Error_Msg_NE
("\move ''Access to private part, or " &
"(Ada 2005) use anonymous access type instead of &",
N, Btyp);
-- If the ultimate ancestor of the attribute's type is
-- a formal type, then the attribute is illegal because
-- the actual type might be declared at a higher level.
......@@ -7244,11 +7281,17 @@ package body Sem_Attr is
end if;
-- If this is a renaming, an inherited operation, or a
-- subprogram instance, use the original entity.
-- subprogram instance, use the original entity. This may make
-- the node type-inconsistent, so this transformation can only
-- be done if the node will not be reanalyzed. In particular,
-- if it is within a default expression, the transformation
-- must be delayed until the default subprogram is created for
-- it, when the enclosing subprogram is frozen.
if Is_Entity_Name (P)
and then Is_Overloadable (Entity (P))
and then Present (Alias (Entity (P)))
and then Expander_Active
then
Rewrite (P,
New_Occurrence_Of (Alias (Entity (P)), Sloc (P)));
......@@ -7520,7 +7563,6 @@ package body Sem_Attr is
elsif Object_Access_Level (P) > Type_Access_Level (Btyp)
and then Comes_From_Source (N)
and then Ekind (Btyp) = E_Access_Protected_Subprogram_Type
and then No (Original_Access_Type (Typ))
then
Accessibility_Message;
return;
......@@ -7940,6 +7982,15 @@ package body Sem_Attr is
when others => null;
end case;
-- If the prefix of the attribute is a class-wide type then it
-- will be expanded into a dispatching call to a predefined
-- primitive. Therefore we must check for potential violation
-- of such restriction.
if Is_Class_Wide_Type (Etype (P)) then
Check_Restriction (No_Dispatching_Calls, N);
end if;
end case;
-- Normally the Freezing is done by Resolve but sometimes the Prefix
......@@ -7978,7 +8029,7 @@ package body Sem_Attr is
end if;
if Nam = TSS_Stream_Input
and then Is_Abstract (Typ)
and then Is_Abstract_Type (Typ)
and then not Is_Class_Wide_Type (Typ)
then
return False;
......
gcc/ada/sem_ch3.adb
......@@ -104,7 +104,7 @@ package body Sem_Ch3 is
-- implicit derived full type for a type derived from a private type (in
-- that case the subprograms must only be derived for the private view of
-- the type).
--
-- ??? These flags need a bit of re-examination and re-documentation:
-- ??? are they both necessary (both seem related to the recursion)?
......@@ -227,6 +227,20 @@ package body Sem_Ch3 is
-- Needs a more complete spec--what are the parameters exactly, and what
-- exactly is the returned value, and how is Bound affected???
procedure Build_Itype_Reference
(Ityp : Entity_Id;
Nod : Node_Id);
-- Create a reference to an internal type, for use by Gigi. The back-end
-- elaborates itypes on demand, i.e. when their first use is seen. This
-- can lead to scope anomalies if the first use is within a scope that is
-- nested within the scope that contains the point of definition of the
-- itype. The Itype_Reference node forces the elaboration of the itype
-- in the proper scope. The node is inserted after Nod, which is the
-- enclosing declaration that generated Ityp.
-- A related mechanism is used during expansion, for itypes created in
-- branches of conditionals. See Ensure_Defined in exp_util.
-- Could both mechanisms be merged ???
procedure Build_Underlying_Full_View
(N : Node_Id;
Typ : Entity_Id;
......@@ -239,6 +253,9 @@ package body Sem_Ch3 is
-- view cannot itself have a full view (it would get clobbered during
-- view exchanges).
procedure Check_Abstract_Interfaces (N : Node_Id; Def : Node_Id);
-- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2)
procedure Check_Access_Discriminant_Requires_Limited
(D : Node_Id;
Loc : Node_Id);
......@@ -246,25 +263,39 @@ package body Sem_Ch3 is
-- belongs must be a concurrent type or a descendant of a type with
-- the reserved word 'limited' in its declaration.
procedure Check_Anonymous_Access_Components
(Typ_Decl : Node_Id;
Typ : Entity_Id;
Prev : Entity_Id;
Comp_List : Node_Id);
-- Ada 2005 AI-382: an access component in a record definition can refer to
-- the enclosing record, in which case it denotes the type itself, and not
-- the current instance of the type. We create an anonymous access type for
-- the component, and flag it as an access to a component, so accessibility
-- checks are properly performed on it. The declaration of the access type
-- is placed ahead of that of the record to prevent order-of-elaboration
-- circularity issues in Gigi. We create an incomplete type for the record
-- declaration, which is the designated type of the anonymous access.
procedure Check_Delta_Expression (E : Node_Id);
-- Check that the expression represented by E is suitable for use
-- as a delta expression, i.e. it is of real type and is static.
-- Check that the expression represented by E is suitable for use as a
-- delta expression, i.e. it is of real type and is static.
procedure Check_Digits_Expression (E : Node_Id);
-- Check that the expression represented by E is suitable for use as
-- a digits expression, i.e. it is of integer type, positive and static.
-- Check that the expression represented by E is suitable for use as a
-- digits expression, i.e. it is of integer type, positive and static.
procedure Check_Initialization (T : Entity_Id; Exp : Node_Id);
-- Validate the initialization of an object declaration. T is the
-- required type, and Exp is the initialization expression.
-- Validate the initialization of an object declaration. T is the required
-- type, and Exp is the initialization expression.
procedure Check_Or_Process_Discriminants
(N : Node_Id;
T : Entity_Id;
Prev : Entity_Id := Empty);
-- If T is the full declaration of an incomplete or private type, check
-- the conformance of the discriminants, otherwise process them. Prev
-- is the entity of the partial declaration, if any.
-- If T is the full declaration of an incomplete or private type, check the
-- conformance of the discriminants, otherwise process them. Prev is the
-- entity of the partial declaration, if any.
procedure Check_Real_Bound (Bound : Node_Id);
-- Check given bound for being of real type and static. If not, post an
......@@ -283,19 +314,17 @@ package body Sem_Ch3 is
Parent_Type : Entity_Id;
Derived_Type : Entity_Id;
Loc : Source_Ptr);
-- For derived scalar types, convert the bounds in the type definition
-- to the derived type, and complete their analysis. Given a constraint
-- of the form:
-- .. new T range Lo .. Hi;
-- Lo and Hi are analyzed and resolved with T'Base, the parent_type.
-- The bounds of the derived type (the anonymous base) are copies of
-- Lo and Hi. Finally, the bounds of the derived subtype are conversions
-- of those bounds to the derived_type, so that their typing is
-- consistent.
-- For derived scalar types, convert the bounds in the type definition to
-- the derived type, and complete their analysis. Given a constraint of the
-- form ".. new T range Lo .. Hi", Lo and Hi are analyzed and resolved with
-- T'Base, the parent_type. The bounds of the derived type (the anonymous
-- base) are copies of Lo and Hi. Finally, the bounds of the derived
-- subtype are conversions of those bounds to the derived_type, so that
-- their typing is consistent.
procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id);
-- Copies attributes from array base type T2 to array base type T1.
-- Copies only attributes that apply to base types, but not subtypes.
-- Copies attributes from array base type T2 to array base type T1. Copies
-- only attributes that apply to base types, but not subtypes.
procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id);
-- Copies attributes from array subtype T2 to array subtype T1. Copies
......@@ -308,12 +337,12 @@ package body Sem_Ch3 is
Constraints : Elist_Id);
-- Build the list of entities for a constrained discriminated record
-- subtype. If a component depends on a discriminant, replace its subtype
-- using the discriminant values in the discriminant constraint.
-- Subt is the defining identifier for the subtype whose list of
-- constrained entities we will create. Decl_Node is the type declaration
-- node where we will attach all the itypes created. Typ is the base
-- discriminated type for the subtype Subt. Constraints is the list of
-- discriminant constraints for Typ.
-- using the discriminant values in the discriminant constraint. Subt is
-- the defining identifier for the subtype whose list of constrained
-- entities we will create. Decl_Node is the type declaration node where we
-- will attach all the itypes created. Typ is the base discriminated type
-- for the subtype Subt. Constraints is the list of discriminant
-- constraints for Typ.
function Constrain_Component_Type
(Comp : Entity_Id;
......@@ -324,11 +353,12 @@ package body Sem_Ch3 is
-- Given a discriminated base type Typ, a list of discriminant constraint
-- Constraints for Typ and a component of Typ, with type Compon_Type,
-- create and return the type corresponding to Compon_type where all
-- discriminant references are replaced with the corresponding
-- constraint. If no discriminant references occur in Compon_Typ then
-- return it as is. Constrained_Typ is the final constrained subtype to
-- which the constrained Compon_Type belongs. Related_Node is the node
-- where we will attach all the itypes created.
-- discriminant references are replaced with the corresponding constraint.
-- If no discriminant references occur in Compon_Typ then return it as is.
-- Constrained_Typ is the final constrained subtype to which the
-- constrained Compon_Type belongs. Related_Node is the node where we will
-- attach all the itypes created.
-- Above description is confused, what is Compon_Type???
procedure Constrain_Access
(Def_Id : in out Entity_Id;
......@@ -418,10 +448,10 @@ package body Sem_Ch3 is
Suffix : Character;
Suffix_Index : Nat);
-- Process an index constraint in a constrained array declaration. The
-- constraint can be a subtype name, or a range with or without an
-- explicit subtype mark. The index is the corresponding index of the
-- unconstrained array. The Related_Id and Suffix parameters are used to
-- build the associated Implicit type name.
-- constraint can be a subtype name, or a range with or without an explicit
-- subtype mark. The index is the corresponding index of the unconstrained
-- array. The Related_Id and Suffix parameters are used to build the
-- associated Implicit type name.
procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id);
-- Build subtype of a signed or modular integer type
......@@ -431,9 +461,9 @@ package body Sem_Ch3 is
-- build an E_Ordinary_Fixed_Point_Subtype entity.
procedure Copy_And_Swap (Priv, Full : Entity_Id);
-- Copy the Priv entity into the entity of its full declaration
-- then swap the two entities in such a manner that the former private
-- type is now seen as a full type.
-- Copy the Priv entity into the entity of its full declaration then swap
-- the two entities in such a manner that the former private type is now
-- seen as a full type.
procedure Decimal_Fixed_Point_Type_Declaration
(T : Entity_Id;
......@@ -522,8 +552,8 @@ package body Sem_Ch3 is
--
-- Is_Tagged is set if we are dealing with tagged types
--
-- If Inherit_Discr is set, Derived_Base inherits its discriminants
-- from Parent_Base, otherwise no discriminants are inherited.
-- If Inherit_Discr is set, Derived_Base inherits its discriminants from
-- Parent_Base, otherwise no discriminants are inherited.
--
-- Discs gives the list of constraints that apply to Parent_Base in the
-- derived type declaration. If Discs is set to No_Elist, then we have
......@@ -542,8 +572,8 @@ package body Sem_Ch3 is
--
-- (Old_Component => New_Component),
--
-- where Old_Component is the Entity_Id of a component in Parent_Base
-- and New_Component is the Entity_Id of the corresponding component in
-- where Old_Component is the Entity_Id of a component in Parent_Base and
-- New_Component is the Entity_Id of the corresponding component in
-- Derived_Base. For untagged records, this association list is needed when
-- copying the record declaration for the derived base. In the tagged case
-- the value returned is irrelevant.
......@@ -684,6 +714,7 @@ package body Sem_Ch3 is
and then Is_Task_Type (Etype (Scope (Current_Scope)))
then
Error_Msg_N ("task entries cannot have access parameters", N);
return Empty;
end if;
-- Ada 2005: for an object declaration the corresponding anonymous
......@@ -701,24 +732,26 @@ package body Sem_Ch3 is
(E_Anonymous_Access_Type, Related_Nod,
Scope_Id => Current_Scope);
-- For the anonymous function result case, retrieve the scope of
-- the function specification's associated entity rather than using
-- the current scope. The current scope will be the function itself
-- if the formal part is currently being analyzed, but will be the
-- parent scope in the case of a parameterless function, and we
-- always want to use the function's parent scope.
-- For the anonymous function result case, retrieve the scope of the
-- function specification's associated entity rather than using the
-- current scope. The current scope will be the function itself if the
-- formal part is currently being analyzed, but will be the parent scope
-- in the case of a parameterless function, and we always want to use
-- the function's parent scope. Finally, if the function is a child
-- unit, we must traverse the the tree to retrieve the proper entity.
elsif Nkind (Related_Nod) = N_Function_Specification
and then Nkind (Parent (N)) /= N_Parameter_Specification
then
Anon_Type :=
Create_Itype
(E_Anonymous_Access_Type, Related_Nod,
Scope_Id => Scope (Defining_Unit_Name (Related_Nod)));
(E_Anonymous_Access_Type,
Related_Nod,
Scope_Id => Scope (Defining_Entity (Related_Nod)));
else
-- For access formals, access components, and access
-- discriminants, the scope is that of the enclosing declaration,
-- For access formals, access components, and access discriminants,
-- the scope is that of the enclosing declaration,
Anon_Type :=
Create_Itype
......@@ -732,8 +765,8 @@ package body Sem_Ch3 is
Error_Msg_N ("ALL is not permitted for anonymous access types", N);
end if;
-- Ada 2005 (AI-254): In case of anonymous access to subprograms
-- call the corresponding semantic routine
-- Ada 2005 (AI-254): In case of anonymous access to subprograms call
-- the corresponding semantic routine
if Present (Access_To_Subprogram_Definition (N)) then
Access_Subprogram_Declaration
......@@ -761,9 +794,8 @@ package body Sem_Ch3 is
Set_Depends_On_Private (Anon_Type, Has_Private_Component (Anon_Type));
-- Ada 2005 (AI-231): Ada 2005 semantics for anonymous access differs
-- from Ada 95 semantics. In Ada 2005, anonymous access must specify
-- if the null value is allowed. In Ada 95 the null value is never
-- allowed.
-- from Ada 95 semantics. In Ada 2005, anonymous access must specify if
-- the null value is allowed. In Ada 95 the null value is never allowed.
if Ada_Version >= Ada_05 then
Set_Can_Never_Be_Null (Anon_Type, Null_Exclusion_Present (N));
......@@ -804,9 +836,9 @@ package body Sem_Ch3 is
-- 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.
-- 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
......@@ -845,6 +877,16 @@ package body Sem_Ch3 is
end if;
end if;
-- For a private component of a protected type, it is imperative that
-- the back-end elaborate the type immediately after the protected
-- declaration, because this type will be used in the declarations
-- created for the component within each protected body, so we must
-- create an itype reference for it now.
if Nkind (Parent (Related_Nod)) = N_Protected_Definition then
Build_Itype_Reference (Anon_Type, Parent (Parent (Related_Nod)));
end if;
return Anon_Type;
end Access_Definition;
......@@ -864,8 +906,8 @@ package body Sem_Ch3 is
Create_Itype (E_Subprogram_Type, Parent (T_Def));
begin
-- Associate the Itype node with the inner full-type declaration
-- or subprogram spec. This is required to handle nested anonymous
-- Associate the Itype node with the inner full-type declaration or
-- subprogram spec. This is required to handle nested anonymous
-- declarations. For example:
-- procedure P
......@@ -1109,9 +1151,30 @@ package body Sem_Ch3 is
Last_Tag : Node_Id;
Comp : Node_Id;
procedure Add_Sync_Iface_Tags (T : Entity_Id);
-- Local subprogram used to recursively climb through the parents
-- of T to add the tags of all the progenitor interfaces.
procedure Add_Tag (Iface : Entity_Id);
-- Add tag for one of the progenitor interfaces
-------------------------
-- Add_Sync_Iface_Tags --
-------------------------
procedure Add_Sync_Iface_Tags (T : Entity_Id) is
begin
if Etype (T) /= T then
Add_Sync_Iface_Tags (Etype (T));
end if;
Elmt := First_Elmt (Abstract_Interfaces (T));
while Present (Elmt) loop
Add_Tag (Node (Elmt));
Next_Elmt (Elmt);
end loop;
end Add_Sync_Iface_Tags;
-------------
-- Add_Tag --
-------------
......@@ -1191,69 +1254,80 @@ package body Sem_Ch3 is
end if;
end Add_Tag;
-- Local variables
Iface_List : List_Id;
-- Start of processing for Add_Interface_Tag_Components
begin
if Ekind (Typ) /= E_Record_Type
or else No (Abstract_Interfaces (Typ))
or else Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
or else not RTE_Available (RE_Interface_Tag)
or else (Is_Concurrent_Record_Type (Typ)
and then Is_Empty_List (Abstract_Interface_List (Typ)))
or else (not Is_Concurrent_Record_Type (Typ)
and then No (Abstract_Interfaces (Typ))
and then Is_Empty_Elmt_List (Abstract_Interfaces (Typ)))
then
return;
end if;
if Present (Abstract_Interfaces (Typ)) then
-- Find the current last tag
if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then
Ext := Record_Extension_Part (Type_Definition (N));
else
pragma Assert (Nkind (Type_Definition (N)) = N_Record_Definition);
Ext := Type_Definition (N);
end if;
-- Find the current last tag
Last_Tag := Empty;
if not (Present (Component_List (Ext))) then
Set_Null_Present (Ext, False);
L := New_List;
Set_Component_List (Ext,
Make_Component_List (Loc,
Component_Items => L,
Null_Present => False));
else
if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then
Ext := Record_Extension_Part (Type_Definition (N));
L := Component_Items
(Component_List
(Record_Extension_Part
(Type_Definition (N))));
else
pragma Assert (Nkind (Type_Definition (N)) = N_Record_Definition);
Ext := Type_Definition (N);
L := Component_Items
(Component_List
(Type_Definition (N)));
end if;
Last_Tag := Empty;
-- Find the last tag component
if not (Present (Component_List (Ext))) then
Set_Null_Present (Ext, False);
L := New_List;
Set_Component_List (Ext,
Make_Component_List (Loc,
Component_Items => L,
Null_Present => False));
else
if Nkind (Type_Definition (N)) = N_Derived_Type_Definition then
L := Component_Items
(Component_List
(Record_Extension_Part
(Type_Definition (N))));
else
L := Component_Items
(Component_List
(Type_Definition (N)));
Comp := First (L);
while Present (Comp) loop
if Is_Tag (Defining_Identifier (Comp)) then
Last_Tag := Comp;
end if;
-- Find the last tag component
Comp := First (L);
while Present (Comp) loop
if Is_Tag (Defining_Identifier (Comp)) then
Last_Tag := Comp;
end if;
Next (Comp);
end loop;
end if;
Next (Comp);
end loop;
end if;
-- At this point L references the list of components and Last_Tag
-- references the current last tag (if any). Now we add the tag
-- corresponding with all the interfaces that are not implemented
-- by the parent.
-- At this point L references the list of components and Last_Tag
-- references the current last tag (if any). Now we add the tag
-- corresponding with all the interfaces that are not implemented
-- by the parent.
if Is_Concurrent_Record_Type (Typ) then
Iface_List := Abstract_Interface_List (Typ);
pragma Assert (Present
(First_Elmt (Abstract_Interfaces (Typ))));
if Is_Non_Empty_List (Iface_List) then
Add_Sync_Iface_Tags (Etype (First (Iface_List)));
end if;
end if;
if Present (Abstract_Interfaces (Typ)) then
Elmt := First_Elmt (Abstract_Interfaces (Typ));
while Present (Elmt) loop
Add_Tag (Node (Elmt));
......@@ -1396,7 +1470,7 @@ package body Sem_Ch3 is
(Access_Definition
(Component_Definition (N))))
then
T := Replace_Anonymous_Access_To_Protected_Subprogram (N, T);
T := Replace_Anonymous_Access_To_Protected_Subprogram (N);
end if;
end if;
......@@ -1485,7 +1559,7 @@ package body Sem_Ch3 is
-- Components cannot be abstract, except for the special case of
-- the _Parent field (case of extending an abstract tagged type)
elsif Is_Abstract (T) and then Chars (Id) /= Name_uParent then
elsif Is_Abstract_Type (T) and then Chars (Id) /= Name_uParent then
Error_Msg_N ("type of a component cannot be abstract", N);
end if;
......@@ -1674,11 +1748,19 @@ package body Sem_Ch3 is
end if;
-- If next node is a body then freeze all types before the body.
-- An exception occurs for expander generated bodies, which can
-- be recognized by their already being analyzed. The expander
-- ensures that all types needed by these bodies have been frozen
-- but it is not necessary to freeze all types (and would be wrong
-- since it would not correspond to an RM defined freeze point).
-- An exception occurs for some expander-generated bodies. If these
-- are generated at places where in general language rules would not
-- allow a freeze point, then we assume that the expander has
-- explicitly checked that all required types are properly frozen,
-- and we do not cause general freezing here. This special circuit
-- is used when the encountered body is marked as having already
-- been analyzed.
-- In all other cases (bodies that come from source, and expander
-- generated bodies that have not been analyzed yet), freeze all
-- types now. Note that in the latter case, the expander must take
-- care to attach the bodies at a proper place in the tree so as to
-- not cause unwanted freezing at that point.
elsif not Analyzed (Next_Node)
and then (Nkind (Next_Node) = N_Subprogram_Body
......@@ -1765,8 +1847,8 @@ package body Sem_Ch3 is
-- Type is abstract if full declaration carries keyword, or if
-- previous partial view did.
Set_Is_Abstract (T);
Set_Is_Interface (T);
Set_Is_Abstract_Type (T);
Set_Is_Interface (T);
Set_Is_Limited_Interface (T, Limited_Present (Def));
Set_Is_Protected_Interface (T, Protected_Present (Def));
......@@ -2061,6 +2143,15 @@ package body Sem_Ch3 is
T := Find_Type_Of_Object (Object_Definition (N), N);
if Nkind (Object_Definition (N)) = N_Access_Definition
and then Present
(Access_To_Subprogram_Definition (Object_Definition (N)))
and then Protected_Present
(Access_To_Subprogram_Definition (Object_Definition (N)))
then
T := Replace_Anonymous_Access_To_Protected_Subprogram (N);
end if;
if Error_Posted (Id) then
Set_Etype (Id, T);
Set_Ekind (Id, E_Variable);
......@@ -2241,7 +2332,7 @@ package body Sem_Ch3 is
-- x'class'input where x is abstract) where we legitimately
-- generate an abstract object.
if Is_Abstract (T) and then Comes_From_Source (N) then
if Is_Abstract_Type (T) and then Comes_From_Source (N) then
Error_Msg_N ("type of object cannot be abstract",
Object_Definition (N));
......@@ -3035,7 +3126,7 @@ package body Sem_Ch3 is
if Is_Tagged_Type (T) then
Set_Is_Tagged_Type (Id);
Set_Is_Abstract (Id, Is_Abstract (T));
Set_Is_Abstract_Type (Id, Is_Abstract_Type (T));
Set_Primitive_Operations
(Id, Primitive_Operations (T));
Set_Class_Wide_Type (Id, Class_Wide_Type (T));
......@@ -3053,11 +3144,10 @@ package body Sem_Ch3 is
(Id, Has_Unknown_Discriminants (T));
if Is_Tagged_Type (T) then
Set_Is_Tagged_Type (Id);
Set_Is_Abstract (Id, Is_Abstract (T));
Set_Primitive_Operations
(Id, Primitive_Operations (T));
Set_Class_Wide_Type (Id, Class_Wide_Type (T));
Set_Is_Tagged_Type (Id);
Set_Is_Abstract_Type (Id, Is_Abstract_Type (T));
Set_Primitive_Operations (Id, Primitive_Operations (T));
Set_Class_Wide_Type (Id, Class_Wide_Type (T));
end if;
-- In general the attributes of the subtype of a private type
......@@ -3275,6 +3365,7 @@ package body Sem_Ch3 is
if R /= Error then
Analyze (R);
Set_Etype (N, Etype (R));
Resolve (R, Entity (T));
else
Set_Error_Posted (R);
Set_Error_Posted (T);
......@@ -3293,10 +3384,9 @@ package body Sem_Ch3 is
Is_Remote : constant Boolean :=
(Is_Remote_Types (Current_Scope)
or else Is_Remote_Call_Interface (Current_Scope))
and then not (In_Private_Part (Current_Scope)
or else
In_Package_Body (Current_Scope));
or else Is_Remote_Call_Interface (Current_Scope))
and then not (In_Private_Part (Current_Scope)
or else In_Package_Body (Current_Scope));
procedure Check_Ops_From_Incomplete_Type;
-- If there is a tagged incomplete partial view of the type, transfer
......@@ -3351,11 +3441,24 @@ package body Sem_Ch3 is
-- Ada 2005 (AI-50217): If the type was previously decorated when
-- imported through a LIMITED WITH clause, it appears as incomplete
-- but has no full view.
-- If the incomplete view is tagged, a class_wide type has been
-- created already. Use it for the full view as well, to prevent
-- multiple incompatible class-wide types that may be created for
-- self-referential anonymous access components.
if Ekind (Prev) = E_Incomplete_Type
and then Present (Full_View (Prev))
then
T := Full_View (Prev);
if Is_Tagged_Type (Prev)
and then Present (Class_Wide_Type (Prev))
then
Set_Ekind (T, Ekind (Prev)); -- will be reset later
Set_Class_Wide_Type (T, Class_Wide_Type (Prev));
Set_Etype (Class_Wide_Type (T), T);
end if;
else
T := Prev;
end if;
......@@ -3517,7 +3620,18 @@ package body Sem_Ch3 is
-- made which is the "real" entity, i.e. the one swapped in,
-- and the second parameter provides the reference location.
Generate_Reference (T, T, 'c');
-- Also, we want to kill Has_Pragma_Unreferenced temporarily here
-- since we don't want a complaint about the full type being an
-- unwanted reference to the private type
declare
B : constant Boolean := Has_Pragma_Unreferenced (T);
begin
Set_Has_Pragma_Unreferenced (T, False);
Generate_Reference (T, T, 'c');
Set_Has_Pragma_Unreferenced (T, B);
end;
Set_Completion_Referenced (Def_Id);
-- For completion of incomplete type, process incomplete dependents
......@@ -3727,11 +3841,21 @@ package body Sem_Ch3 is
-- Ada 2005 (AI-230): Access Definition case
else pragma Assert (Present (Access_Definition (Component_Def)));
-- Indicate that the anonymous access type is created by the
-- array type declaration.
Element_Type := Access_Definition
(Related_Nod => Related_Id,
(Related_Nod => P,
N => Access_Definition (Component_Def));
Set_Is_Local_Anonymous_Access (Element_Type);
-- Propagate the parent. This field is needed if we have to generate
-- the master_id associated with an anonymous access to task type
-- component (see Expand_N_Full_Type_Declaration.Build_Master)
Set_Parent (Element_Type, Parent (T));
-- Ada 2005 (AI-230): In case of components that are anonymous
-- access types the level of accessibility depends on the enclosing
-- type declaration
......@@ -3747,8 +3871,7 @@ package body Sem_Ch3 is
begin
if Present (CD) and then Protected_Present (CD) then
Element_Type :=
Replace_Anonymous_Access_To_Protected_Subprogram
(Def, Element_Type);
Replace_Anonymous_Access_To_Protected_Subprogram (Def);
end if;
end;
end if;
......@@ -3782,18 +3905,19 @@ package body Sem_Ch3 is
-- Complete setup of implicit base type
Set_First_Index (Implicit_Base, First_Index (T));
Set_Component_Type (Implicit_Base, Element_Type);
Set_Has_Task (Implicit_Base, Has_Task (Element_Type));
Set_Component_Size (Implicit_Base, Uint_0);
Set_First_Index (Implicit_Base, First_Index (T));
Set_Component_Type (Implicit_Base, Element_Type);
Set_Has_Task (Implicit_Base, Has_Task (Element_Type));
Set_Component_Size (Implicit_Base, Uint_0);
Set_Packed_Array_Type (Implicit_Base, Empty);
Set_Has_Controlled_Component
(Implicit_Base, Has_Controlled_Component
(Element_Type)
or else
Is_Controlled (Element_Type));
(Implicit_Base, Has_Controlled_Component
(Element_Type)
or else Is_Controlled
(Element_Type));
Set_Finalize_Storage_Only
(Implicit_Base, Finalize_Storage_Only
(Element_Type));
(Implicit_Base, Finalize_Storage_Only
(Element_Type));
-- Unconstrained array case
......@@ -3815,7 +3939,10 @@ package body Sem_Ch3 is
(Element_Type));
end if;
-- Common attributes for both cases
Set_Component_Type (Base_Type (T), Element_Type);
Set_Packed_Array_Type (T, Empty);
if Aliased_Present (Component_Definition (Def)) then
Set_Has_Aliased_Components (Etype (T));
......@@ -3885,7 +4012,7 @@ package body Sem_Ch3 is
("unconstrained element type in array declaration",
Subtype_Indication (Component_Def));
elsif Is_Abstract (Element_Type) then
elsif Is_Abstract_Type (Element_Type) then
Error_Msg_N
("the type of a component cannot be abstract",
Subtype_Indication (Component_Def));
......@@ -3898,8 +4025,7 @@ package body Sem_Ch3 is
------------------------------------------------------
function Replace_Anonymous_Access_To_Protected_Subprogram
(N : Node_Id;
Prev_E : Entity_Id) return Entity_Id
(N : Node_Id) return Entity_Id
is
Loc : constant Source_Ptr := Sloc (N);
......@@ -3923,15 +4049,19 @@ package body Sem_Ch3 is
N_Unconstrained_Array_Definition |
N_Constrained_Array_Definition =>
Comp := Component_Definition (N);
Acc := Access_Definition (Component_Definition (N));
Acc := Access_Definition (Comp);
when N_Discriminant_Specification =>
Comp := Discriminant_Type (N);
Acc := Discriminant_Type (N);
Acc := Comp;
when N_Parameter_Specification =>
Comp := Parameter_Type (N);
Acc := Parameter_Type (N);
Acc := Comp;
when N_Object_Declaration =>
Comp := Object_Definition (N);
Acc := Comp;
when others =>
raise Program_Error;
......@@ -3969,6 +4099,11 @@ package body Sem_Ch3 is
Rewrite (Comp, New_Occurrence_Of (Anon, Loc));
Set_Etype (Defining_Identifier (N), Anon);
Set_Null_Exclusion_Present (N, False);
elsif Nkind (N) = N_Object_Declaration then
Rewrite (Comp, New_Occurrence_Of (Anon, Loc));
Set_Etype (Defining_Identifier (N), Anon);
else
Rewrite (Comp,
Make_Component_Definition (Loc,
......@@ -3980,11 +4115,15 @@ package body Sem_Ch3 is
-- Temporarily remove the current scope from the stack to add the new
-- declarations to the enclosing scope
Scope_Stack.Decrement_Last;
Analyze (Decl);
Scope_Stack.Append (Curr_Scope);
if Nkind (N) /= N_Object_Declaration then
Scope_Stack.Decrement_Last;
Analyze (Decl);
Scope_Stack.Append (Curr_Scope);
else
Analyze (Decl);
end if;
Set_Original_Access_Type (Anon, Prev_E);
Set_Ekind (Anon, E_Anonymous_Access_Protected_Subprogram_Type);
return Anon;
end Replace_Anonymous_Access_To_Protected_Subprogram;
......@@ -5134,32 +5273,25 @@ package body Sem_Ch3 is
-- be possibly non-private. We build a underlying full view that
-- will be installed when the enclosing child body is compiled.
declare
IR : constant Node_Id := Make_Itype_Reference (Sloc (N));
Full_Der :=
Make_Defining_Identifier (Sloc (Derived_Type),
Chars => Chars (Derived_Type));
Set_Is_Itype (Full_Der);
Build_Itype_Reference (Full_Der, N);
begin
Full_Der :=
Make_Defining_Identifier (Sloc (Derived_Type),
Chars (Derived_Type));
Set_Is_Itype (Full_Der);
Set_Itype (IR, Full_Der);
Insert_After (N, IR);
-- The full view will be used to swap entities on entry/exit
-- to the body, and must appear in the entity list for the
-- package.
Append_Entity (Full_Der, Scope (Derived_Type));
Set_Has_Private_Declaration (Full_Der);
Set_Has_Private_Declaration (Derived_Type);
Set_Associated_Node_For_Itype (Full_Der, N);
Set_Parent (Full_Der, Parent (Derived_Type));
Full_P := Full_View (Parent_Type);
Exchange_Declarations (Parent_Type);
Copy_And_Build;
Exchange_Declarations (Full_P);
Set_Underlying_Full_View (Derived_Type, Full_Der);
end;
-- The full view will be used to swap entities on entry/exit to
-- the body, and must appear in the entity list for the package.
Append_Entity (Full_Der, Scope (Derived_Type));
Set_Has_Private_Declaration (Full_Der);
Set_Has_Private_Declaration (Derived_Type);
Set_Associated_Node_For_Itype (Full_Der, N);
Set_Parent (Full_Der, Parent (Derived_Type));
Full_P := Full_View (Parent_Type);
Exchange_Declarations (Parent_Type);
Copy_And_Build;
Exchange_Declarations (Full_P);
Set_Underlying_Full_View (Derived_Type, Full_Der);
end if;
end if;
end Build_Derived_Private_Type;
......@@ -5179,12 +5311,12 @@ package body Sem_Ch3 is
-- type R (...) is [tagged] record ... end record;
-- type T (...) is new R (...) [with ...];
-- The representation clauses of T can specify a completely different
-- record layout from R's. Hence the same component can be placed in
-- two very different positions in objects of type T and R. If R and T
-- are tagged types, representation clauses for T can only specify the
-- layout of non inherited components, thus components that are common
-- in R and T have the same position in objects of type R and T.
-- The representation clauses for T can specify a completely different
-- record layout from R's. Hence the same component can be placed in two
-- very different positions in objects of type T and R. If R and are tagged
-- types, representation clauses for T can only specify the layout of non
-- inherited components, thus components that are common in R and T have
-- the same position in objects of type R and T.
-- This has two implications. The first is that the entire tree for R's
-- declaration needs to be copied for T in the untagged case, so that T
......@@ -5651,23 +5783,28 @@ package body Sem_Ch3 is
end if;
-- Before we start the previously documented transformations, here is
-- a little fix for size and alignment of tagged types. Normally when
-- we derive type D from type P, we copy the size and alignment of P
-- as the default for D, and in the absence of explicit representation
-- clauses for D, the size and alignment are indeed the same as the
-- parent.
-- little fix for size and alignment of tagged types. Normally when we
-- derive type D from type P, we copy the size and alignment of P as the
-- default for D, and in the absence of explicit representation clauses
-- for D, the size and alignment are indeed the same as the parent.
-- But this is wrong for tagged types, since fields may be added, and
-- the default size may need to be larger, and the default alignment may
-- need to be larger.
-- But this is wrong for tagged types, since fields may be added,
-- and the default size may need to be larger, and the default
-- alignment may need to be larger.
-- We therefore reset the size and alignment fields in the tagged case.
-- Note that the size and alignment will in any case be at least as
-- large as the parent type (since the derived type has a copy of the
-- parent type in the _parent field)
-- We therefore reset the size and alignment fields in the tagged
-- case. Note that the size and alignment will in any case be at
-- least as large as the parent type (since the derived type has
-- a copy of the parent type in the _parent field)
-- The type is also marked as being tagged here, which is needed when
-- processing components with a self-referential anonymous access type
-- in the call to Check_Anonymous_Access_Components below. Note that
-- this flag is also set later on for completeness.
if Is_Tagged then
Init_Size_Align (Derived_Type);
Set_Is_Tagged_Type (Derived_Type);
Init_Size_Align (Derived_Type);
end if;
-- STEP 0a: figure out what kind of derived type declaration we have
......@@ -5688,6 +5825,16 @@ package body Sem_Ch3 is
if Present (Record_Extension_Part (Type_Def)) then
Set_Ekind (Derived_Type, E_Record_Type);
-- Create internal access types for components with anonymous
-- access types.
if Ada_Version >= Ada_05 then
Check_Anonymous_Access_Components
(N, Derived_Type, Derived_Type,
Component_List (Record_Extension_Part (Type_Def)));
end if;
else
Set_Ekind (Derived_Type, Ekind (Parent_Base));
end if;
......@@ -5966,7 +6113,6 @@ package body Sem_Ch3 is
if Ada_Version = Ada_05
and then Is_Tagged
then
-- "The declaration of a specific descendant of an interface type
-- freezes the interface type" (RM 13.14).
......@@ -6198,7 +6344,10 @@ package body Sem_Ch3 is
and then Ekind (Derived_Type) /= E_Private_Type
and then Ekind (Derived_Type) /= E_Limited_Private_Type
then
Set_Is_Interface (Derived_Type, Interface_Present (Type_Def));
if Interface_Present (Type_Def) then
Analyze_Interface_Declaration (Derived_Type, Type_Def);
end if;
Set_Abstract_Interfaces (Derived_Type, No_Elist);
end if;
......@@ -6210,13 +6359,16 @@ package body Sem_Ch3 is
(Derived_Type, Has_Specified_Layout (Parent_Type));
Set_Is_Limited_Composite
(Derived_Type, Is_Limited_Composite (Parent_Type));
Set_Is_Limited_Record
(Derived_Type,
Is_Limited_Record (Parent_Type)
and then not Is_Interface (Parent_Type));
Set_Is_Private_Composite
(Derived_Type, Is_Private_Composite (Parent_Type));
if not Is_Limited_Record (Derived_Type) then
Set_Is_Limited_Record
(Derived_Type,
Is_Limited_Record (Parent_Type)
and then not Is_Interface (Parent_Type));
end if;
-- Fields inherited from the Parent_Base
Set_Has_Controlled_Component
......@@ -6278,7 +6430,7 @@ package body Sem_Ch3 is
end if;
Make_Class_Wide_Type (Derived_Type);
Set_Is_Abstract (Derived_Type, Abstract_Present (Type_Def));
Set_Is_Abstract_Type (Derived_Type, Abstract_Present (Type_Def));
if Has_Discriminants (Derived_Type)
and then Constraint_Present
......@@ -6287,13 +6439,17 @@ package body Sem_Ch3 is
(Derived_Type, Expand_To_Stored_Constraint (Parent_Base, Discs));
end if;
-- Ada 2005 (AI-251): Collect the list of progenitors that are not
-- already in the parents.
if Ada_Version >= Ada_05 then
declare
Ifaces_List : Elist_Id;
begin
-- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2)
Check_Abstract_Interfaces (N, Type_Def);
-- Ada 2005 (AI-251): Collect the list of progenitors that are
-- not already in the parents.
Collect_Abstract_Interfaces
(T => Derived_Type,
Ifaces_List => Ifaces_List,
......@@ -6395,7 +6551,9 @@ package body Sem_Ch3 is
-- Ada 2005 (AI-251): Addition of the Tag corresponding to all the
-- implemented interfaces if we are in expansion mode
if Expander_Active then
if Expander_Active
and then Has_Abstract_Interfaces (Derived_Type)
then
Add_Interface_Tag_Components (N, Derived_Type);
end if;
......@@ -7025,7 +7183,7 @@ package body Sem_Ch3 is
Set_Primitive_Operations (Def_Id, Primitive_Operations (T));
end if;
Set_Is_Abstract (Def_Id, Is_Abstract (T));
Set_Is_Abstract_Type (Def_Id, Is_Abstract_Type (T));
end if;
-- Subtypes introduced by component declarations do not need to be
......@@ -7059,6 +7217,20 @@ package body Sem_Ch3 is
end if;
end Build_Discriminated_Subtype;
---------------------------
-- Build_Itype_Reference --
---------------------------
procedure Build_Itype_Reference
(Ityp : Entity_Id;
Nod : Node_Id)
is
IR : constant Node_Id := Make_Itype_Reference (Sloc (Nod));
begin
Set_Itype (IR, Ityp);
Insert_After (Nod, IR);
end Build_Itype_Reference;
------------------------
-- Build_Scalar_Bound --
------------------------
......@@ -7207,6 +7379,131 @@ package body Sem_Ch3 is
end Build_Underlying_Full_View;
-------------------------------
-- Check_Abstract_Interfaces --
-------------------------------
procedure Check_Abstract_Interfaces (N : Node_Id; Def : Node_Id) is
procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id);
-- Local subprogram used to avoid code duplication. In case of error
-- the message will be associated to Error_Node.
------------------
-- Check_Ifaces --
------------------
procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id) is
begin
-- Ada 2005 (AI-345): Protected interfaces can only inherit from
-- limited, synchronized or protected interfaces.
if Protected_Present (Def) then
if Limited_Present (Iface_Def)
or else Synchronized_Present (Iface_Def)
or else Protected_Present (Iface_Def)
then
null;
elsif Task_Present (Iface_Def) then
Error_Msg_N ("(Ada 2005) protected interface cannot inherit"
& " from task interface", Error_Node);
else
Error_Msg_N ("(Ada 2005) protected interface cannot inherit"
& " from non-limited interface", Error_Node);
end if;
-- Ada 2005 (AI-345): Synchronized interfaces can only inherit from
-- limited and synchronized.
elsif Synchronized_Present (Def) then
if Limited_Present (Iface_Def)
or else Synchronized_Present (Iface_Def)
then
null;
elsif Protected_Present (Iface_Def) then
Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit"
& " from protected interface", Error_Node);
elsif Task_Present (Iface_Def) then
Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit"
& " from task interface", Error_Node);
else
Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit"
& " from non-limited interface", Error_Node);
end if;
-- Ada 2005 (AI-345): Task interfaces can only inherit from limited,
-- synchronized or task interfaces.
elsif Task_Present (Def) then
if Limited_Present (Iface_Def)
or else Synchronized_Present (Iface_Def)
or else Task_Present (Iface_Def)
then
null;
elsif Protected_Present (Iface_Def) then
Error_Msg_N ("(Ada 2005) task interface cannot inherit from"
& " protected interface", Error_Node);
else
Error_Msg_N ("(Ada 2005) task interface cannot inherit from"
& " non-limited interface", Error_Node);
end if;
end if;
end Check_Ifaces;
-- Local variables
Iface : Node_Id;
Iface_Def : Node_Id;
Iface_Typ : Entity_Id;
-- Start of processing for Check_Abstract_Interfaces
begin
-- Why is this still unsupported???
if Nkind (N) = N_Private_Extension_Declaration then
return;
end if;
-- Check the parent in case of derivation of interface type
if Nkind (Type_Definition (N)) = N_Derived_Type_Definition
and then Is_Interface (Etype (Defining_Identifier (N)))
then
Check_Ifaces
(Iface_Def => Type_Definition
(Parent (Etype (Defining_Identifier (N)))),
Error_Node => Subtype_Indication (Type_Definition (N)));
end if;
Iface := First (Interface_List (Def));
while Present (Iface) loop
Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
Iface_Def := Type_Definition (Parent (Iface_Typ));
if not Is_Interface (Iface_Typ) then
Error_Msg_NE ("(Ada 2005) & must be an interface",
Iface, Iface_Typ);
else
-- "The declaration of a specific descendant of an interface
-- type freezes the interface type" RM 13.14
Freeze_Before (N, Iface_Typ);
Check_Ifaces (Iface_Def, Error_Node => Iface);
end if;
Next (Iface);
end loop;
end Check_Abstract_Interfaces;
-------------------------------
-- Check_Abstract_Overriding --
-------------------------------
......@@ -7231,19 +7528,23 @@ package body Sem_Ch3 is
-- come from source, and the associated source location is the
-- location of the first subtype of the derived type.
-- Ada 2005 (AI-228): Apply the rules of RM-3.9.3(6/2) for
-- subprograms that "require overriding".
-- Special exception, do not complain about failure to override the
-- stream routines _Input and _Output, as well as the primitive
-- operations used in dispatching selects since we always provide
-- automatic overridings for these subprograms.
if (Is_Abstract (Subp)
or else (Has_Controlling_Result (Subp)
and then Present (Alias_Subp)
and then not Comes_From_Source (Subp)
and then Sloc (Subp) = Sloc (First_Subtype (T))))
if (Is_Abstract_Subprogram (Subp)
or else Requires_Overriding (Subp)
or else (Has_Controlling_Result (Subp)
and then Present (Alias_Subp)
and then not Comes_From_Source (Subp)
and then Sloc (Subp) = Sloc (First_Subtype (T))))
and then not Is_TSS (Subp, TSS_Stream_Input)
and then not Is_TSS (Subp, TSS_Stream_Output)
and then not Is_Abstract (T)
and then not Is_Abstract_Type (T)
and then Chars (Subp) /= Name_uDisp_Asynchronous_Select
and then Chars (Subp) /= Name_uDisp_Conditional_Select
and then Chars (Subp) /= Name_uDisp_Get_Prim_Op_Kind
......@@ -7280,7 +7581,8 @@ package body Sem_Ch3 is
or else not Is_Null_Extension (T)
or else Ekind (Subp) = E_Procedure
or else not Has_Controlling_Result (Subp)
or else Is_Abstract (Alias_Subp)
or else Is_Abstract_Subprogram (Alias_Subp)
or else Requires_Overriding (Subp)
or else Is_Access_Type (Etype (Subp)))
then
Error_Msg_NE
......@@ -7347,12 +7649,17 @@ package body Sem_Ch3 is
end if;
else
Error_Msg_NE
("abstract subprogram not allowed for type&",
Subp, T);
Error_Msg_NE
("nonabstract type has abstract subprogram&",
T, Subp);
Error_Msg_Node_2 := T;
Error_Msg_N
("abstract subprogram& not allowed for type&", Subp);
-- Also post unconditional warning on the type (unconditional
-- so that if there are more than one of these cases, we get
-- them all, and not just the first one).
Error_Msg_Node_2 := Subp;
Error_Msg_N
("nonabstract type& has abstract subprogram&!", T);
end if;
end if;
......@@ -7479,7 +7786,7 @@ package body Sem_Ch3 is
-- If a generated entity has no completion, then either previous
-- semantic errors have disabled the expansion phase, or else we had
-- missing subunits, or else we are compiling without expan- sion,
-- missing subunits, or else we are compiling without expansion,
-- or else something is very wrong.
if not Comes_From_Source (E) then
......@@ -7571,13 +7878,23 @@ package body Sem_Ch3 is
-- be flagged as requiring completion, because it is a
-- compilation unit.
-- Ignore missing completion for a subprogram that does not come from
-- source (including the _Call primitive operation of RAS types,
-- which has to have the flag Comes_From_Source for other purposes):
-- we assume that the expander will provide the missing completion.
elsif Ekind (E) = E_Function
or else Ekind (E) = E_Procedure
or else Ekind (E) = E_Generic_Function
or else Ekind (E) = E_Generic_Procedure
then
if not Has_Completion (E)
and then not Is_Abstract (E)
and then not (Is_Subprogram (E)
and then Is_Abstract_Subprogram (E))
and then not (Is_Subprogram (E)
and then
(not Comes_From_Source (E)
or else Chars (E) = Name_uCall))
and then Nkind (Parent (Unit_Declaration_Node (E))) /=
N_Compilation_Unit
and then Chars (E) /= Name_uSize
......@@ -8310,6 +8627,7 @@ package body Sem_Ch3 is
-- a derivation from a private type) has no discriminants.
-- (Defect Report 8652/0008, Technical Corrigendum 1, checked
-- by ACATS B371001).
-- Rule updated for Ada 2005: the private type is said to have
-- a constrained partial view, given that objects of the type
-- can be declared.
......@@ -8401,12 +8719,19 @@ package body Sem_Ch3 is
-- generic body, the rule is checked assuming that the actual type has
-- defaulted discriminants.
if Ada_Version >= Ada_05 then
if Ada_Version >= Ada_05 or else Warn_On_Ada_2005_Compatibility then
if Ekind (Base_Type (T)) = E_General_Access_Type
and then Has_Defaulted_Discriminants (Desig_Type)
then
Error_Msg_N
("access subype of general access type not allowed", S);
if Ada_Version < Ada_05 then
Error_Msg_N
("access subtype of general access type would not " &
"be allowed in Ada 2005?", S);
else
Error_Msg_N
("access subype of general access type not allowed", S);
end if;
Error_Msg_N ("\discriminants have defaults", S);
elsif Is_Access_Type (T)
......@@ -8414,7 +8739,15 @@ package body Sem_Ch3 is
and then Has_Discriminants (Desig_Type)
and then In_Package_Body (Current_Scope)
then
Error_Msg_N ("access subtype not allowed in generic body", S);
if Ada_Version < Ada_05 then
Error_Msg_N
("access subtype would not be allowed in generic body " &
"in Ada 2005?", S);
else
Error_Msg_N
("access subtype not allowed in generic body", S);
end if;
Error_Msg_N
("\designated type is a discriminated formal", S);
end if;
......@@ -9648,6 +9981,10 @@ package body Sem_Ch3 is
Set_Is_Public (Full, Is_Public (Priv));
Set_Is_Pure (Full, Is_Pure (Priv));
Set_Is_Tagged_Type (Full, Is_Tagged_Type (Priv));
Set_Has_Pragma_Unreferenced (Full, Has_Pragma_Unreferenced (Priv));
Set_Has_Pragma_Unreferenced_Objects
(Full, Has_Pragma_Unreferenced_Objects
(Priv));
Conditional_Delay (Full, Priv);
......@@ -10379,7 +10716,13 @@ package body Sem_Ch3 is
Subp := Node (Elmt);
Iface := Find_Dispatching_Type (Subp);
if not Is_Ancestor (Iface, Tagged_Type) then
if Is_Concurrent_Record_Type (Tagged_Type) then
if not Present (Abstract_Interface_Alias (Subp)) then
Derive_Subprogram (New_Subp, Subp, Tagged_Type, Iface);
Append_Elmt (New_Subp, Ifaces_List);
end if;
elsif not Is_Parent (Iface, Tagged_Type) then
Derive_Subprogram (New_Subp, Subp, Tagged_Type, Iface);
Append_Elmt (New_Subp, Ifaces_List);
end if;
......@@ -10441,7 +10784,8 @@ package body Sem_Ch3 is
Set_Is_Hidden (Iface_Subp);
Set_Abstract_Interface_Alias (Iface_Subp, Alias (Iface_Subp));
Set_Alias (Iface_Subp, E);
Set_Is_Abstract (Iface_Subp, Is_Abstract (E));
Set_Is_Abstract_Subprogram (Iface_Subp,
Is_Abstract_Subprogram (E));
Remove_Homonym (Iface_Subp);
Next_Elmt (Elmt);
......@@ -10527,7 +10871,6 @@ package body Sem_Ch3 is
procedure Replace_Type (Id, New_Id : Entity_Id) is
Acc_Type : Entity_Id;
IR : Node_Id;
Par : constant Node_Id := Parent (Derived_Type);
begin
......@@ -10578,10 +10921,7 @@ package body Sem_Ch3 is
Set_Scope (New_Id, New_Subp);
-- Create a reference to it
IR := Make_Itype_Reference (Sloc (Parent (Derived_Type)));
Set_Itype (IR, Acc_Type);
Insert_After (Parent (Derived_Type), IR);
Build_Itype_Reference (Acc_Type, Parent (Derived_Type));
else
Set_Etype (New_Id, Etype (Id));
......@@ -10802,16 +11142,42 @@ package body Sem_Ch3 is
-- function is not abstract unless the actual is.
if Is_Generic_Type (Derived_Type)
and then not Is_Abstract (Derived_Type)
and then not Is_Abstract_Type (Derived_Type)
then
null;
elsif Is_Abstract (Alias (New_Subp))
or else (Is_Tagged_Type (Derived_Type)
and then Etype (New_Subp) = Derived_Type
and then No (Actual_Subp))
-- Ada 2005 (AI-228): Calculate the "require overriding" and "abstract"
-- properties of the subprogram, as defined in RM-3.9.3(4/2-6/2).
elsif Ada_Version >= Ada_05
and then (Is_Abstract_Subprogram (Alias (New_Subp))
or else (Is_Tagged_Type (Derived_Type)
and then Etype (New_Subp) = Derived_Type
and then not Is_Null_Extension (Derived_Type))
or else (Is_Tagged_Type (Derived_Type)
and then Ekind (Etype (New_Subp)) =
E_Anonymous_Access_Type
and then Designated_Type (Etype (New_Subp)) =
Derived_Type
and then not Is_Null_Extension (Derived_Type)))
and then No (Actual_Subp)
then
if not Is_Tagged_Type (Derived_Type)
or else Is_Abstract_Type (Derived_Type)
or else Is_Abstract_Subprogram (Alias (New_Subp))
then
Set_Is_Abstract_Subprogram (New_Subp);
else
Set_Requires_Overriding (New_Subp);
end if;
elsif Ada_Version < Ada_05
and then (Is_Abstract_Subprogram (Alias (New_Subp))
or else (Is_Tagged_Type (Derived_Type)
and then Etype (New_Subp) = Derived_Type
and then No (Actual_Subp)))
then
Set_Is_Abstract (New_Subp);
Set_Is_Abstract_Subprogram (New_Subp);
-- Finally, if the parent type is abstract we must verify that all
-- inherited operations are either non-abstract or overridden, or
......@@ -10822,13 +11188,13 @@ package body Sem_Ch3 is
-- the parent type, in which case the abstractness of the inherited
-- operation is carried to the new subprogram.
elsif Is_Abstract (Parent_Type)
elsif Is_Abstract_Type (Parent_Type)
and then not In_Open_Scopes (Scope (Parent_Type))
and then Is_Private_Overriding
and then Is_Abstract (Visible_Subp)
and then Is_Abstract_Subprogram (Visible_Subp)
then
Set_Alias (New_Subp, Visible_Subp);
Set_Is_Abstract (New_Subp);
Set_Is_Abstract_Subprogram (New_Subp);
end if;
New_Overloaded_Entity (New_Subp, Derived_Type);
......@@ -10918,7 +11284,7 @@ package body Sem_Ch3 is
-- Ada 2005 (AI-251): Add the derivation of an abstract
-- interface primitive to the list of entities to which
-- we have to associate aliased entity.
-- we have to associate an aliased entity.
if Ada_Version >= Ada_05
and then Is_Dispatching_Operation (Subp)
......@@ -10939,7 +11305,11 @@ package body Sem_Ch3 is
Next_Elmt (Elmt);
end loop;
Derive_Interface_Subprograms (Parent_Type, Derived_Type, Ifaces_List);
if Ada_Version >= Ada_05
and then Is_Tagged_Type (Derived_Type)
then
Derive_Interface_Subprograms (Parent_Type, Derived_Type, Ifaces_List);
end if;
end Derive_Subprograms;
--------------------------------
......@@ -11116,16 +11486,19 @@ package body Sem_Ch3 is
null;
elsif Protected_Present (Iface_Def) then
Error_Msg_N ("(Ada 2005) non-limited interface cannot" &
" inherit from protected interface", Indic);
Error_Msg_N
("(Ada 2005) non-limited interface cannot " &
"inherit from protected interface", Indic);
elsif Synchronized_Present (Iface_Def) then
Error_Msg_N ("(Ada 2005) non-limited interface cannot" &
" inherit from synchronized interface", Indic);
Error_Msg_N
("(Ada 2005) non-limited interface cannot " &
"inherit from synchronized interface", Indic);
elsif Task_Present (Iface_Def) then
Error_Msg_N ("(Ada 2005) non-limited interface cannot" &
" inherit from task interface", Indic);
Error_Msg_N
("(Ada 2005) non-limited interface cannot " &
"inherit from task interface", Indic);
else
null;
......@@ -11134,6 +11507,16 @@ package body Sem_Ch3 is
end if;
end if;
if Is_Tagged_Type (Parent_Type)
and then Is_Concurrent_Type (Parent_Type)
and then not Is_Interface (Parent_Type)
and then not Is_Completion
then
Error_Msg_N ("parent type of a record extension cannot be " &
"a synchronized tagged type (3.9.1 (3/1)", N);
return;
end if;
-- Ada 2005 (AI-251): Decorate all the names in the list of ancestor
-- interfaces
......@@ -12681,21 +13064,24 @@ package body Sem_Ch3 is
-----------------------
function Is_Null_Extension (T : Entity_Id) return Boolean is
Full_Type_Decl : constant Node_Id := Parent (T);
Full_Type_Defn : constant Node_Id := Type_Definition (Full_Type_Decl);
Comp_List : Node_Id;
First_Comp : Node_Id;
Type_Decl : constant Node_Id := Parent (T);
Comp_List : Node_Id;
First_Comp : Node_Id;
begin
if not Is_Tagged_Type (T)
or else Nkind (Full_Type_Defn) /= N_Derived_Type_Definition
if Nkind (Type_Decl) /= N_Full_Type_Declaration
or else not Is_Tagged_Type (T)
or else Nkind (Type_Definition (Type_Decl)) /=
N_Derived_Type_Definition
or else No (Record_Extension_Part (Type_Definition (Type_Decl)))
then
return False;
end if;
Comp_List := Component_List (Record_Extension_Part (Full_Type_Defn));
Comp_List :=
Component_List (Record_Extension_Part (Type_Definition (Type_Decl)));
if Present (Discriminant_Specifications (Full_Type_Decl)) then
if Present (Discriminant_Specifications (Type_Decl)) then
return False;
elsif Present (Comp_List)
......@@ -12956,7 +13342,7 @@ package body Sem_Ch3 is
Set_Ekind (CW_Type, E_Class_Wide_Type);
Set_Is_Tagged_Type (CW_Type, True);
Set_Primitive_Operations (CW_Type, New_Elmt_List);
Set_Is_Abstract (CW_Type, False);
Set_Is_Abstract_Type (CW_Type, False);
Set_Is_Constrained (CW_Type, False);
Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T));
Init_Size_Align (CW_Type);
......@@ -13705,8 +14091,7 @@ package body Sem_Ch3 is
(Discriminant_Type (Discr)))
then
Discr_Type :=
Replace_Anonymous_Access_To_Protected_Subprogram
(Discr, Discr_Type);
Replace_Anonymous_Access_To_Protected_Subprogram (Discr);
end if;
else
......@@ -14080,7 +14465,9 @@ package body Sem_Ch3 is
("completion of nonlimited type cannot be limited", Full_T);
Explain_Limited_Type (Full_T, Full_T);
elsif Is_Abstract (Full_T) and then not Is_Abstract (Priv_T) then
elsif Is_Abstract_Type (Full_T)
and then not Is_Abstract_Type (Priv_T)
then
Error_Msg_N
("completion of nonabstract type cannot be abstract", Full_T);
......@@ -14105,13 +14492,12 @@ package body Sem_Ch3 is
-- Check that ancestor interfaces of private and full views are
-- consistent. We omit this check for synchronized types because
-- they are performed on thecorresponding record type when frozen.
-- they are performed on the corresponding record type when frozen.
if Ada_Version >= Ada_05
and then Is_Tagged_Type (Priv_T)
and then Is_Tagged_Type (Full_T)
and then Ekind (Full_T) /= E_Task_Type
and then Ekind (Full_T) /= E_Protected_Type
and then not Is_Concurrent_Type (Full_T)
then
declare
Iface : Entity_Id;
......@@ -14309,8 +14695,7 @@ package body Sem_Ch3 is
if Ada_Version >= Ada_05
and then Nkind (Parent (Priv_T)) = N_Private_Extension_Declaration
and then Synchronized_Present (Parent (Priv_T))
and then Ekind (Full_T) /= E_Task_Type
and then Ekind (Full_T) /= E_Protected_Type
and then not Is_Concurrent_Type (Full_T)
then
Error_Msg_N ("full view of synchronized extension must " &
"be synchronized type", N);
......@@ -14374,8 +14759,7 @@ package body Sem_Ch3 is
-- operations from the private view to the full view.
if Is_Tagged_Type (Full_T)
and then Ekind (Full_T) /= E_Task_Type
and then Ekind (Full_T) /= E_Protected_Type
and then not Is_Concurrent_Type (Full_T)
then
declare
Priv_List : Elist_Id;
......@@ -15079,6 +15463,15 @@ package body Sem_Ch3 is
when Access_Kind =>
Constrain_Access (Def_Id, S, Related_Nod);
if Expander_Active
and then Is_Itype (Designated_Type (Def_Id))
and then Nkind (Related_Nod) = N_Subtype_Declaration
and then not Is_Incomplete_Type (Designated_Type (Def_Id))
then
Build_Itype_Reference
(Designated_Type (Def_Id), Related_Nod);
end if;
when Array_Kind =>
Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix);
......@@ -15142,13 +15535,7 @@ package body Sem_Ch3 is
and then
Nkind (Parent (P)) = N_Full_Type_Declaration
then
declare
Ref_Node : Node_Id;
begin
Ref_Node := Make_Itype_Reference (Sloc (Related_Nod));
Set_Itype (Ref_Node, Def_Id);
Insert_After (Parent (P), Ref_Node);
end;
Build_Itype_Reference (Def_Id, Parent (P));
end if;
else
......@@ -15172,274 +15559,317 @@ package body Sem_Ch3 is
end if;
end Process_Subtype;
-----------------------------
-- Record_Type_Declaration --
-----------------------------
---------------------------------------
-- Check_Anonymous_Access_Components --
---------------------------------------
procedure Record_Type_Declaration
(T : Entity_Id;
N : Node_Id;
Prev : Entity_Id)
procedure Check_Anonymous_Access_Components
(Typ_Decl : Node_Id;
Typ : Entity_Id;
Prev : Entity_Id;
Comp_List : Node_Id)
is
Loc : constant Source_Ptr := Sloc (N);
Def : constant Node_Id := Type_Definition (N);
Inc_T : Entity_Id := Empty;
Is_Tagged : Boolean;
Tag_Comp : Entity_Id;
procedure Check_Anonymous_Access_Types (Comp_List : Node_Id);
-- Ada 2005 AI-382: an access component in a record declaration can
-- refer to the enclosing record, in which case it denotes the type
-- itself, and not the current instance of the type. We create an
-- anonymous access type for the component, and flag it as an access
-- to a component, so that accessibility checks are properly performed
-- on it. The declaration of the access type is placed ahead of that
-- of the record, to prevent circular order-of-elaboration issues in
-- Gigi. We create an incomplete type for the record declaration, which
-- is the designated type of the anonymous access.
procedure Make_Incomplete_Type_Declaration;
Loc : constant Source_Ptr := Sloc (Typ_Decl);
Anon_Access : Entity_Id;
Acc_Def : Node_Id;
Comp : Node_Id;
Comp_Def : Node_Id;
Decl : Node_Id;
Type_Def : Node_Id;
procedure Build_Incomplete_Type_Declaration;
-- If the record type contains components that include an access to the
-- current record, create an incomplete type declaration for the record,
-- to be used as the designated type of the anonymous access. This is
-- done only once, and only if there is no previous partial view of the
-- type.
----------------------------------
-- Check_Anonymous_Access_Types --
----------------------------------
-- current record, then create an incomplete type declaration for the
-- record, to be used as the designated type of the anonymous access.
-- This is done only once, and only if there is no previous partial
-- view of the type.
function Mentions_T (Acc_Def : Node_Id) return Boolean;
-- Check whether an access definition includes a reference to
-- the enclosing record type. The reference can be a subtype
-- mark in the access definition itself, or a 'Class attribute
-- reference, or recursively a reference appearing in a parameter
-- type in an access_to_subprogram definition.
procedure Check_Anonymous_Access_Types (Comp_List : Node_Id) is
Anon_Access : Entity_Id;
Acc_Def : Node_Id;
Comp : Node_Id;
Comp_Def : Node_Id;
Decl : Node_Id;
Type_Def : Node_Id;
--------------------------------------
-- Build_Incomplete_Type_Declaration --
--------------------------------------
function Mentions_T (Acc_Def : Node_Id) return Boolean;
-- Check whether an access definition includes a reference to
-- the enclosing record type. The reference can be a subtype
-- mark in the access definition itself, or a 'Class attribute
-- reference, or recursively a reference appearing in a parameter
-- type in an access_to_subprogram definition.
procedure Build_Incomplete_Type_Declaration is
Decl : Node_Id;
Inc_T : Entity_Id;
H : Entity_Id;
----------------
-- Mentions_T --
----------------
begin
-- If there is a previous partial view, no need to create a new one
-- If the partial view, given by Prev, is incomplete, If Prev is
-- a private declaration, full declaration is flagged accordingly.
function Mentions_T (Acc_Def : Node_Id) return Boolean is
Subt : Node_Id;
if Prev /= Typ then
if Tagged_Present (Type_Definition (Typ_Decl)) then
Make_Class_Wide_Type (Prev);
Set_Class_Wide_Type (Typ, Class_Wide_Type (Prev));
Set_Etype (Class_Wide_Type (Typ), Typ);
end if;
begin
if No (Access_To_Subprogram_Definition (Acc_Def)) then
Subt := Subtype_Mark (Acc_Def);
return;
if Nkind (Subt) = N_Identifier then
return Chars (Subt) = Chars (T);
elsif Has_Private_Declaration (Typ) then
return;
-- A reference to the current type may appear as the prefix
-- of a 'Class attribute.
-- If there was a previous anonymous access type, the incomplete
-- type declaration will have been created already.
elsif Nkind (Subt) = N_Attribute_Reference
and then Attribute_Name (Subt) = Name_Class
and then Is_Entity_Name (Prefix (Subt))
then
return (Chars (Prefix (Subt))) = Chars (T);
else
return False;
end if;
elsif Present (Current_Entity (Typ))
and then Ekind (Current_Entity (Typ)) = E_Incomplete_Type
and then Full_View (Current_Entity (Typ)) = Typ
then
return;
else
-- Component is an access_to_subprogram: examine its formals
else
Inc_T := Make_Defining_Identifier (Loc, Chars (Typ));
Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T);
declare
Param_Spec : Node_Id;
-- Type has already been inserted into the current scope.
-- Remove it, and add incomplete declaration for type, so
-- that subsequent anonymous access types can use it.
-- The entity is unchained from the homonym list and from
-- immediate visibility. After analysis, the entity in the
-- incomplete declaration becomes immediately visible in the
-- record declaration that follows.
begin
Param_Spec :=
First
(Parameter_Specifications
(Access_To_Subprogram_Definition (Acc_Def)));
while Present (Param_Spec) loop
if Nkind (Parameter_Type (Param_Spec))
= N_Access_Definition
and then Mentions_T (Parameter_Type (Param_Spec))
then
return True;
end if;
H := Current_Entity (Typ);
Next (Param_Spec);
end loop;
if H = Typ then
Set_Name_Entity_Id (Chars (Typ), Homonym (Typ));
else
while Present (H)
and then Homonym (H) /= Typ
loop
H := Homonym (Typ);
end loop;
return False;
end;
Set_Homonym (H, Homonym (Typ));
end if;
end Mentions_T;
-- Start of processing for Check_Anonymous_Access_Types
begin
if No (Comp_List) then
return;
end if;
Insert_Before (Typ_Decl, Decl);
Analyze (Decl);
Set_Full_View (Inc_T, Typ);
Comp := First (Component_Items (Comp_List));
while Present (Comp) loop
if Nkind (Comp) = N_Component_Declaration
and then Present
(Access_Definition (Component_Definition (Comp)))
and then
Mentions_T (Access_Definition (Component_Definition (Comp)))
if (Nkind (Type_Definition (Typ_Decl)) = N_Derived_Type_Definition
and then
Present
(Record_Extension_Part (Type_Definition (Typ_Decl))))
or else Tagged_Present (Type_Definition (Typ_Decl))
then
Comp_Def := Component_Definition (Comp);
Acc_Def :=
Access_To_Subprogram_Definition
(Access_Definition (Comp_Def));
-- Create a common class-wide type for both views, and set
-- the etype of the class-wide type to the full view.
Make_Incomplete_Type_Declaration;
Anon_Access :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('S'));
-- Create a declaration for the anonymous access type: either
-- an access_to_object or an access_to_subprogram.
if Present (Acc_Def) then
if Nkind (Acc_Def) = N_Access_Function_Definition then
Type_Def :=
Make_Access_Function_Definition (Loc,
Parameter_Specifications =>
Parameter_Specifications (Acc_Def),
Result_Definition => Result_Definition (Acc_Def));
else
Type_Def :=
Make_Access_Procedure_Definition (Loc,
Parameter_Specifications =>
Parameter_Specifications (Acc_Def));
end if;
Make_Class_Wide_Type (Inc_T);
Set_Class_Wide_Type (Typ, Class_Wide_Type (Inc_T));
Set_Etype (Class_Wide_Type (Typ), Typ);
end if;
end if;
end Build_Incomplete_Type_Declaration;
else
Type_Def :=
Make_Access_To_Object_Definition (Loc,
Subtype_Indication =>
Relocate_Node
(Subtype_Mark
(Access_Definition (Comp_Def))));
end if;
----------------
-- Mentions_T --
----------------
Decl := Make_Full_Type_Declaration (Loc,
Defining_Identifier => Anon_Access,
Type_Definition => Type_Def);
function Mentions_T (Acc_Def : Node_Id) return Boolean is
Subt : Node_Id;
Type_Id : constant Name_Id := Chars (Typ);
Insert_Before (N, Decl);
Analyze (Decl);
begin
if No (Access_To_Subprogram_Definition (Acc_Def)) then
Subt := Subtype_Mark (Acc_Def);
-- If an access to object, Preserve entity of designated type,
-- for ASIS use, before rewriting the component definition.
if Nkind (Subt) = N_Identifier then
return Chars (Subt) = Type_Id;
if No (Acc_Def) then
declare
Desig : Entity_Id;
-- Reference can be through an expanded name which has not been
-- analyzed yet, and designates enclosing scopes.
begin
Desig := Entity (Subtype_Indication (Type_Def));
elsif Nkind (Subt) = N_Selected_Component then
Analyze (Prefix (Subt));
-- If the access definition is to the current record,
-- the visible entity at this point is an incomplete
-- type. Retrieve the full view to simplify ASIS queries
if Chars (Selector_Name (Subt)) = Type_Id then
return Is_Entity_Name (Prefix (Subt))
and then Entity (Prefix (Subt)) = Current_Scope;
if Ekind (Desig) = E_Incomplete_Type then
Desig := Full_View (Desig);
end if;
-- The access definition may name a subtype of the enclosing
-- type, if there is a previous incomplete declaration for it.
Set_Entity
(Subtype_Mark (Access_Definition (Comp_Def)), Desig);
end;
else
Find_Selected_Component (Subt);
return
Is_Entity_Name (Subt)
and then Scope (Entity (Subt)) = Current_Scope
and then (Chars (Base_Type (Entity (Subt))) = Type_Id
or else
(Is_Class_Wide_Type (Entity (Subt))
and then
Chars (Etype (Base_Type (Entity (Subt))))
= Type_Id));
end if;
Rewrite (Comp_Def,
Make_Component_Definition (Loc,
Subtype_Indication =>
New_Occurrence_Of (Anon_Access, Loc)));
Set_Ekind (Anon_Access, E_Anonymous_Access_Type);
Set_Is_Local_Anonymous_Access (Anon_Access);
-- A reference to the current type may appear as the prefix of
-- a 'Class attribute.
elsif Nkind (Subt) = N_Attribute_Reference
and then Attribute_Name (Subt) = Name_Class
and then Is_Entity_Name (Prefix (Subt))
then
return (Chars (Prefix (Subt))) = Type_Id;
else
return False;
end if;
Next (Comp);
end loop;
else
-- Component is an access_to_subprogram: examine its formals
if Present (Variant_Part (Comp_List)) then
declare
V : Node_Id;
Param_Spec : Node_Id;
begin
V := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
while Present (V) loop
Check_Anonymous_Access_Types (Component_List (V));
Next_Non_Pragma (V);
Param_Spec :=
First
(Parameter_Specifications
(Access_To_Subprogram_Definition (Acc_Def)));
while Present (Param_Spec) loop
if Nkind (Parameter_Type (Param_Spec))
= N_Access_Definition
and then Mentions_T (Parameter_Type (Param_Spec))
then
return True;
end if;
Next (Param_Spec);
end loop;
return False;
end;
end if;
end Check_Anonymous_Access_Types;
end Mentions_T;
--------------------------------------
-- Make_Incomplete_Type_Declaration --
--------------------------------------
-- Start of processing for Check_Anonymous_Access_Components
procedure Make_Incomplete_Type_Declaration is
Decl : Node_Id;
H : Entity_Id;
begin
-- If there is a previous partial view, no need to create a new one
-- If the partial view is incomplete, it is given by Prev. If it is
-- a private declaration, full declaration is flagged accordingly.
begin
if No (Comp_List) then
return;
end if;
if Prev /= T
or else Has_Private_Declaration (T)
Comp := First (Component_Items (Comp_List));
while Present (Comp) loop
if Nkind (Comp) = N_Component_Declaration
and then Present
(Access_Definition (Component_Definition (Comp)))
and then
Mentions_T (Access_Definition (Component_Definition (Comp)))
then
return;
Comp_Def := Component_Definition (Comp);
Acc_Def :=
Access_To_Subprogram_Definition
(Access_Definition (Comp_Def));
elsif No (Inc_T) then
Inc_T := Make_Defining_Identifier (Loc, Chars (T));
Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T);
Build_Incomplete_Type_Declaration;
Anon_Access :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('S'));
-- Type has already been inserted into the current scope.
-- Remove it, and add incomplete declaration for type, so
-- that subsequent anonymous access types can use it.
-- The entity is unchained from the homonym list and from
-- immediate visibility. After analysis, the entity in the
-- incomplete declaration becomes immediately visible in the
-- record declaration that follows.
-- Create a declaration for the anonymous access type: either
-- an access_to_object or an access_to_subprogram.
H := Current_Entity (T);
if Present (Acc_Def) then
if Nkind (Acc_Def) = N_Access_Function_Definition then
Type_Def :=
Make_Access_Function_Definition (Loc,
Parameter_Specifications =>
Parameter_Specifications (Acc_Def),
Result_Definition => Result_Definition (Acc_Def));
else
Type_Def :=
Make_Access_Procedure_Definition (Loc,
Parameter_Specifications =>
Parameter_Specifications (Acc_Def));
end if;
if H = T then
Set_Name_Entity_Id (Chars (T), Homonym (T));
else
while Present (H)
and then Homonym (H) /= T
loop
H := Homonym (T);
end loop;
Set_Homonym (H, Homonym (T));
Type_Def :=
Make_Access_To_Object_Definition (Loc,
Subtype_Indication =>
Relocate_Node
(Subtype_Mark
(Access_Definition (Comp_Def))));
end if;
Insert_Before (N, Decl);
Decl := Make_Full_Type_Declaration (Loc,
Defining_Identifier => Anon_Access,
Type_Definition => Type_Def);
Insert_Before (Typ_Decl, Decl);
Analyze (Decl);
Set_Full_View (Inc_T, T);
if Tagged_Present (Def) then
Make_Class_Wide_Type (Inc_T);
Set_Class_Wide_Type (T, Class_Wide_Type (Inc_T));
Set_Etype (Class_Wide_Type (T), T);
-- If an access to object, Preserve entity of designated type,
-- for ASIS use, before rewriting the component definition.
if No (Acc_Def) then
declare
Desig : Entity_Id;
begin
Desig := Entity (Subtype_Indication (Type_Def));
-- If the access definition is to the current record,
-- the visible entity at this point is an incomplete
-- type. Retrieve the full view to simplify ASIS queries
if Ekind (Desig) = E_Incomplete_Type then
Desig := Full_View (Desig);
end if;
Set_Entity
(Subtype_Mark (Access_Definition (Comp_Def)), Desig);
end;
end if;
Rewrite (Comp_Def,
Make_Component_Definition (Loc,
Subtype_Indication =>
New_Occurrence_Of (Anon_Access, Loc)));
Set_Ekind (Anon_Access, E_Anonymous_Access_Type);
Set_Is_Local_Anonymous_Access (Anon_Access);
end if;
end Make_Incomplete_Type_Declaration;
-- Start of processing for Record_Type_Declaration
Next (Comp);
end loop;
if Present (Variant_Part (Comp_List)) then
declare
V : Node_Id;
begin
V := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
while Present (V) loop
Check_Anonymous_Access_Components
(Typ_Decl, Typ, Prev, Component_List (V));
Next_Non_Pragma (V);
end loop;
end;
end if;
end Check_Anonymous_Access_Components;
-----------------------------
-- Record_Type_Declaration --
-----------------------------
procedure Record_Type_Declaration
(T : Entity_Id;
N : Node_Id;
Prev : Entity_Id)
is
Def : constant Node_Id := Type_Definition (N);
Is_Tagged : Boolean;
Tag_Comp : Entity_Id;
begin
-- These flags must be initialized before calling Process_Discriminants
......@@ -15471,7 +15901,7 @@ package body Sem_Ch3 is
-- Type is abstract if full declaration carries keyword, or if
-- previous partial view did.
Set_Is_Abstract (T, Is_Abstract (T)
Set_Is_Abstract_Type (T, Is_Abstract_Type (T)
or else Abstract_Present (Def));
else
......@@ -15490,100 +15920,17 @@ package body Sem_Ch3 is
-- create the required anonymous access type declarations, and if
-- need be an incomplete type declaration for T itself.
Check_Anonymous_Access_Types (Component_List (Def));
Check_Anonymous_Access_Components (N, T, Prev, Component_List (Def));
if Ada_Version >= Ada_05
and then Present (Interface_List (Def))
then
Check_Abstract_Interfaces (N, Def);
declare
Iface : Node_Id;
Iface_Def : Node_Id;
Iface_Typ : Entity_Id;
Ifaces_List : Elist_Id;
begin
Iface := First (Interface_List (Def));
while Present (Iface) loop
Iface_Typ := Find_Type_Of_Subtype_Indic (Iface);
Iface_Def := Type_Definition (Parent (Iface_Typ));
if not Is_Interface (Iface_Typ) then
Error_Msg_NE ("(Ada 2005) & must be an interface",
Iface, Iface_Typ);
else
-- "The declaration of a specific descendant of an
-- interface type freezes the interface type" RM 13.14
Freeze_Before (N, Iface_Typ);
-- Ada 2005 (AI-345): Protected interfaces can only
-- inherit from limited, synchronized or protected
-- interfaces.
if Protected_Present (Def) then
if Limited_Present (Iface_Def)
or else Synchronized_Present (Iface_Def)
or else Protected_Present (Iface_Def)
then
null;
elsif Task_Present (Iface_Def) then
Error_Msg_N ("(Ada 2005) protected interface cannot"
& " inherit from task interface", Iface);
else
Error_Msg_N ("(Ada 2005) protected interface cannot"
& " inherit from non-limited interface", Iface);
end if;
-- Ada 2005 (AI-345): Synchronized interfaces can only
-- inherit from limited and synchronized.
elsif Synchronized_Present (Def) then
if Limited_Present (Iface_Def)
or else Synchronized_Present (Iface_Def)
then
null;
elsif Protected_Present (Iface_Def) then
Error_Msg_N ("(Ada 2005) synchronized interface " &
"cannot inherit from protected interface", Iface);
elsif Task_Present (Iface_Def) then
Error_Msg_N ("(Ada 2005) synchronized interface " &
"cannot inherit from task interface", Iface);
else
Error_Msg_N ("(Ada 2005) synchronized interface " &
"cannot inherit from non-limited interface",
Iface);
end if;
-- Ada 2005 (AI-345): Task interfaces can only inherit
-- from limited, synchronized or task interfaces.
elsif Task_Present (Def) then
if Limited_Present (Iface_Def)
or else Synchronized_Present (Iface_Def)
or else Task_Present (Iface_Def)
then
null;
elsif Protected_Present (Iface_Def) then
Error_Msg_N ("(Ada 2005) task interface cannot" &
" inherit from protected interface", Iface);
else
Error_Msg_N ("(Ada 2005) task interface cannot" &
" inherit from non-limited interface", Iface);
end if;
end if;
end if;
Next (Iface);
end loop;
-- Ada 2005 (AI-251): Collect the list of progenitors that are not
-- already in the parents.
......@@ -15637,9 +15984,11 @@ package body Sem_Ch3 is
Init_Component_Location (Tag_Comp);
-- Ada 2005 (AI-251): Addition of the Tag corresponding to all the
-- implemented interfaces
-- implemented interfaces.
Add_Interface_Tag_Components (N, T);
if Has_Abstract_Interfaces (T) then
Add_Interface_Tag_Components (N, T);
end if;
end if;
Make_Class_Wide_Type (T);
......@@ -15732,8 +16081,8 @@ package body Sem_Ch3 is
end if;
-- After completing the semantic analysis of the record definition,
-- record components, both new and inherited, are accessible. Set
-- their kind accordingly.
-- record components, both new and inherited, are accessible. Set their
-- kind accordingly.
Component := First_Entity (Current_Scope);
while Present (Component) loop
......@@ -15762,8 +16111,8 @@ package body Sem_Ch3 is
Next_Entity (Component);
end loop;
-- A type is Finalize_Storage_Only only if all its controlled
-- components are so.
-- A Type is Finalize_Storage_Only only if all its controlled components
-- are also.
if Ctrl_Components then
Set_Finalize_Storage_Only (T, Final_Storage_Only);
......@@ -15880,7 +16229,6 @@ package body Sem_Ch3 is
Make_Range (Loc,
Low_Bound => Make_Real_Literal (Loc, Lo),
High_Bound => Make_Real_Literal (Loc, Hi));
begin
Set_Scalar_Range (E, S);
Set_Parent (S, E);
......@@ -15916,7 +16264,6 @@ package body Sem_Ch3 is
Set_Ekind (Def_Id, E_Void);
Process_Range_Expr_In_Decl (R, Subt);
Set_Ekind (Def_Id, Kind);
end Set_Scalar_Range_For_Subtype;
--------------------------------------------------------
......
gcc/ada/sem_ch3.ads
......@@ -246,14 +246,12 @@ package Sem_Ch3 is
-- Prev is entity on the partial view, on which references are posted.
function Replace_Anonymous_Access_To_Protected_Subprogram
(N : Node_Id;
Prev_E : Entity_Id) return Entity_Id;
(N : Node_Id) return Entity_Id;
-- Ada 2005 (AI-254): Create and decorate an internal full type declaration
-- in the enclosing scope corresponding to an anonymous access to protected
-- subprogram. In addition, replace the anonymous access by an occurrence
-- of this internal type. Prev_Etype is used to link the new internal
-- entity with the anonymous entity. Return the entity of this type
-- declaration.
-- for an anonymous access to protected subprogram. For a record component
-- declaration, the type is created in the enclosing scope, for an array
-- type declaration or an object declaration it is simply placed ahead of
-- this declaration.
procedure Set_Completion_Referenced (E : Entity_Id);
-- If E is the completion of a private or incomplete type declaration,
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment