OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

errout.adb (Unwind_Internal_Type): Use predicate Is_Access__Protected_Subprogram_Type.

Browse Source 
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
This commit is contained in:
Ed Schonberg 2007-04-06 11:19:23 +02:00 committed by Arnaud Charlet
parent f937473fe9
commit fea9e956ec
6 changed files with 1197 additions and 818 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
gcc/ada/errout.adb
View File

@ -2706,7 +2706,7 @@ package body Errout is
if Is_Access_Type (Ent) then if Is_Access_Type (Ent) then
if Ekind (Ent) = E_Access_Subprogram_Type if Ekind (Ent) = E_Access_Subprogram_Type
or else Ekind (Ent) = E_Anonymous_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 then
Ent := Directly_Designated_Type (Ent); Ent := Directly_Designated_Type (Ent);

332
gcc/ada/freeze.adb
View File

@ -727,144 +727,132 @@ package body Freeze is
-- Loop through components -- Loop through components
Comp := First_Entity (T); Comp := First_Component_Or_Discriminant (T);
while Present (Comp) loop while Present (Comp) loop
if Ekind (Comp) = E_Component Ctyp := Etype (Comp);
or else
Ekind (Comp) = E_Discriminant -- 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;
-- 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 then
Ctyp := Etype (Comp); 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 do not know the packed size if there is a begin
-- component clause present (we possibly could, Ind := First_Index (OCtyp);
-- but this would only help in the case of a record while Present (Ind) loop
-- with partial rep clauses. That's because in the Indtyp := Etype (Ind);
-- case of full rep clauses, the size gets figured
-- out anyway by a different circuit).
if Present (Component_Clause (Comp)) then if Is_Enumeration_Type (Indtyp)
Packed_Size_Known := False; and then Has_Non_Standard_Rep (Indtyp)
end if; then
Lo := Type_Low_Bound (Indtyp);
Hi := Type_High_Bound (Indtyp);
-- We need to identify a component that is an array if Is_Entity_Name (Lo)
-- where the index type is an enumeration type with and then Ekind (Entity (Lo)) = E_Discriminant
-- 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;
begin
Ind := First_Index (OCtyp);
while Present (Ind) loop
Indtyp := Etype (Ind);
if Is_Enumeration_Type (Indtyp)
and then Has_Non_Standard_Rep (Indtyp)
then then
Lo := Type_Low_Bound (Indtyp); return False;
Hi := Type_High_Bound (Indtyp);
if Is_Entity_Name (Lo) elsif Is_Entity_Name (Hi)
and then and then Ekind (Entity (Hi)) = E_Discriminant
Ekind (Entity (Lo)) = E_Discriminant then
then return False;
return False;
elsif Is_Entity_Name (Hi)
and then
Ekind (Entity (Hi)) = E_Discriminant
then
return False;
end if;
end if; end if;
Next_Index (Ind);
end loop;
end;
end if;
-- Clearly size of record is not known if the size of
-- one of the components is not known.
if not Size_Known (Ctyp) then
return False;
end if;
-- Accumulate packed size if possible
if Packed_Size_Known then
-- 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.
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 Known_Static_RM_Size (Ctyp) then
-- 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 field whose RM_Size is not known
-- then we can't figure out the packed size here.
else
Packed_Size_Known := False;
end if; end if;
-- If we have a non-elementary type we can't figure Next_Index (Ind);
-- out the packed array size (alignment issues). end loop;
end;
end if;
-- Clearly size of record is not known if the size of
-- one of the components is not known.
if not Size_Known (Ctyp) then
return False;
end if;
-- Accumulate packed size if possible
if Packed_Size_Known then
-- 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.
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 Known_Static_RM_Size (Ctyp) then
-- 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 field whose RM_Size is not known then
-- we can't figure out the packed size here.
else else
Packed_Size_Known := False; Packed_Size_Known := False;
end if; 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;
end if; end if;
Next_Entity (Comp); Next_Component_Or_Discriminant (Comp);
end loop; end loop;
if Packed_Size_Known then if Packed_Size_Known then
@ -1627,9 +1615,9 @@ package body Freeze is
end if; end if;
-- If component clause is present, then deal with the -- If component clause is present, then deal with the
-- non-default bit order case. We cannot do this before -- non-default bit order case for Ada 95 mode. The required
-- the freeze point, because there is no required order -- processing for Ada 2005 mode is handled separately after
-- for the component clause and the bit_order clause. -- processing all components.
-- We only do this processing for the base type, and in -- We only do this processing for the base type, and in
-- fact that's important, since otherwise if there are -- fact that's important, since otherwise if there are
@ -1639,6 +1627,7 @@ package body Freeze is
if Present (CC) if Present (CC)
and then Reverse_Bit_Order (Rec) and then Reverse_Bit_Order (Rec)
and then Ekind (E) = E_Record_Type and then Ekind (E) = E_Record_Type
and then Ada_Version <= Ada_95
then then
declare declare
CFB : constant Uint := Component_Bit_Offset (Comp); CFB : constant Uint := Component_Bit_Offset (Comp);
@ -1693,7 +1682,9 @@ package body Freeze is
else else
-- Give warning if suspicious component clause -- 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 Error_Msg_N
("?Bit_Order clause does not affect " & ("?Bit_Order clause does not affect " &
"byte ordering", Pos); "byte ordering", Pos);
@ -1762,20 +1753,20 @@ package body Freeze is
S : Entity_Id := Scope (Rec); S : Entity_Id := Scope (Rec);
begin begin
-- We have a pretty bad kludge here. Suppose Rec is a -- We have a pretty bad kludge here. Suppose Rec is subtype
-- subtype being defined in a subprogram that's created -- being defined in a subprogram that's created as part of
-- as part of the freezing of Rec'Base. In that case, -- the freezing of Rec'Base. In that case, we know that
-- we know that Comp'Base must have already been frozen by -- Comp'Base must have already been frozen by the time we
-- the time we get to elaborate this because Gigi doesn't -- get to elaborate this because Gigi doesn't elaborate any
-- elaborate any bodies until it has elaborated all of the -- bodies until it has elaborated all of the declarative
-- declarative part. But Is_Frozen will not be set at this -- part. But Is_Frozen will not be set at this point because
-- point because we are processing code in lexical order. -- we are processing code in lexical order.
-- We detect this case by going up the Scope chain of -- We detect this case by going up the Scope chain of Rec
-- Rec and seeing if we have a subprogram scope before -- and seeing if we have a subprogram scope before reaching
-- reaching the top of the scope chain or that of Comp'Base. -- the top of the scope chain or that of Comp'Base. If we
-- If we do, then mark that Comp'Base will actually be -- do, then mark that Comp'Base will actually be frozen. If
-- frozen. If so, we merely undelay it. -- so, we merely undelay it.
while Present (S) loop while Present (S) loop
if Is_Subprogram (S) then if Is_Subprogram (S) then
@ -1873,12 +1864,23 @@ package body Freeze is
Next_Entity (Comp); Next_Entity (Comp);
end loop; end loop;
-- Check for useless pragma Bit_Order -- Deal with pragma Bit_Order
if not Placed_Component and then Reverse_Bit_Order (Rec) then if Reverse_Bit_Order (Rec) and then Base_Type (Rec) = Rec then
ADC := Get_Attribute_Definition_Clause (Rec, Attribute_Bit_Order); if not Placed_Component then
Error_Msg_N ("?Bit_Order specification has no effect", ADC); ADC :=
Error_Msg_N ("\?since no component clauses were specified", 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).
elsif Ada_Version >= Ada_05 then
Adjust_Record_For_Reverse_Bit_Order (Rec);
end if;
end if; end if;
-- Check for useless pragma Pack when all components placed. We only -- 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 -- must be diagnosed (see e.g. 1522-005). If the enclosing subprogram
-- comes from source, or is a generic instance, then the freeze point -- comes from source, or is a generic instance, then the freeze point
-- is the one mandated by the language. and we freze the entity. -- 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)) elsif In_Open_Scopes (Scope (Test_E))
and then Scope (Test_E) /= Current_Scope and then Scope (Test_E) /= Current_Scope
@ -2030,6 +2034,7 @@ package body Freeze is
if Is_Overloadable (S) then if Is_Overloadable (S) then
if Comes_From_Source (S) if Comes_From_Source (S)
or else Is_Generic_Instance (S) or else Is_Generic_Instance (S)
or else Is_Child_Unit (S)
then then
exit; exit;
else else
@ -2320,17 +2325,6 @@ package body Freeze is
Freeze_And_Append (Alias (E), Loc, Result); Freeze_And_Append (Alias (E), Loc, Result);
end if; 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 if not Is_Internal (E) then
Freeze_Subprogram (E); Freeze_Subprogram (E);
end if; end if;
@ -2766,10 +2760,17 @@ package body Freeze is
Freeze_And_Append (Packed_Array_Type (E), Loc, Result); Freeze_And_Append (Packed_Array_Type (E), Loc, Result);
-- Size information of packed array type is copied to the -- 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.
Set_Size_Info (E, Packed_Array_Type (E)); if not Has_Size_Clause (E) then
Set_RM_Size (E, RM_Size (Packed_Array_Type (E))); Set_Esize (E, Esize (Packed_Array_Type (E)));
Set_RM_Size (E, RM_Size (Packed_Array_Type (E)));
end if;
if not Has_Alignment_Clause (E) then
Set_Alignment (E, Alignment (Packed_Array_Type (E)));
end if;
end if; end if;
-- For non-packed arrays set the alignment of the array -- For non-packed arrays set the alignment of the array
@ -2993,16 +2994,6 @@ package body Freeze is
Next_Formal (Formal); Next_Formal (Formal);
end loop; 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); Freeze_Subprogram (E);
-- Ada 2005 (AI-326): Check wrong use of tag incomplete type -- 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 -- (however this is not set if we are not generating code or if this
-- is an anonymous type used just for resolution). -- 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 -- AI-326: Check wrong use of tagged incomplete types
@ -3192,10 +3183,6 @@ package body Freeze is
if Is_Concurrent_Type (Aux_E) if Is_Concurrent_Type (Aux_E)
and then Present (Corresponding_Record_Type (Aux_E)) and then Present (Corresponding_Record_Type (Aux_E))
then then
pragma Assert (not Is_Empty_Elmt_List
(Abstract_Interfaces
(Corresponding_Record_Type (Aux_E))));
Prim_List := Primitive_Operations Prim_List := Primitive_Operations
(Corresponding_Record_Type (Aux_E)); (Corresponding_Record_Type (Aux_E));
else else
@ -4458,7 +4445,6 @@ package body Freeze is
elsif Is_Record_Type (Typ) then elsif Is_Record_Type (Typ) then
C := First_Entity (Typ); C := First_Entity (Typ);
while Present (C) loop while Present (C) loop
if Ekind (C) = E_Discriminant if Ekind (C) = E_Discriminant
or else Ekind (C) = E_Component or else Ekind (C) = E_Component

11
gcc/ada/layout.adb
View File

@ -2252,12 +2252,9 @@ package body Layout is
Prev_Comp := Empty; Prev_Comp := Empty;
Comp := First_Entity (E); Comp := First_Component_Or_Discriminant (E);
while Present (Comp) loop while Present (Comp) loop
if (Ekind (Comp) = E_Component if Present (Component_Clause (Comp)) then
or else Ekind (Comp) = E_Discriminant)
and then Present (Component_Clause (Comp))
then
if No (Prev_Comp) if No (Prev_Comp)
or else or else
Component_Bit_Offset (Comp) > Component_Bit_Offset (Comp) >
@ -2267,7 +2264,7 @@ package body Layout is
end if; end if;
end if; end if;
Next_Entity (Comp); Next_Component_Or_Discriminant (Comp);
end loop; end loop;
-- We have two separate circuits, one for non-variant records and -- 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 -- backend figure out what is needed (it may be some kind
-- of fat pointer, including the static link for example. -- 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; null;
-- For access subtypes, copy the size information from base type -- For access subtypes, copy the size information from base type

123
gcc/ada/sem_attr.adb
View File

@ -58,6 +58,8 @@ with Stand; use Stand;
with Sinfo; use Sinfo; with Sinfo; use Sinfo;
with Sinput; use Sinput; with Sinput; use Sinput;
with Stringt; use Stringt; with Stringt; use Stringt;
with Style;
with Stylesw; use Stylesw;
with Targparm; use Targparm; with Targparm; use Targparm;
with Ttypes; use Ttypes; with Ttypes; use Ttypes;
with Ttypef; use Ttypef; 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 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 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); Set_Etype (Typ, Typ);
Init_Size_Align (Typ); Init_Size_Align (Typ);
Set_Is_Itype (Typ); Set_Is_Itype (Typ);
@ -841,6 +834,12 @@ package body Sem_Attr is
Error_Attr ("invalid dimension number for array type", E1); Error_Attr ("invalid dimension number for array type", E1);
end if; end if;
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; 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 -- 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. -- 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) if not Is_Access_Type (Etyp)
or else Root_Type (Root_Type (Designated_Type (Etyp))) /= or else Root_Type (Root_Type (Designated_Type (Etyp))) /=
@ -1900,7 +1899,28 @@ package body Sem_Attr is
begin begin
if Is_Subprogram (Ent) then 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); Check_Restriction (No_Implicit_Dynamic_Code, P);
end if; end if;
@ -7044,18 +7064,16 @@ package body Sem_Attr is
if Is_Entity_Name (P) then if Is_Entity_Name (P) then
if Is_Overloaded (P) then if Is_Overloaded (P) then
Get_First_Interp (P, Index, It); Get_First_Interp (P, Index, It);
while Present (It.Nam) loop while Present (It.Nam) loop
if Type_Conformant (Designated_Type (Typ), It.Nam) then if Type_Conformant (Designated_Type (Typ), It.Nam) then
Set_Entity (P, It.Nam); Set_Entity (P, It.Nam);
-- The prefix is definitely NOT overloaded anymore -- The prefix is definitely NOT overloaded anymore at
-- at this point, so we reset the Is_Overloaded -- this point, so we reset the Is_Overloaded flag to
-- flag to avoid any confusion when reanalyzing -- avoid any confusion when reanalyzing the node.
-- the node.
Set_Is_Overloaded (P, False); Set_Is_Overloaded (P, False);
Set_Is_Overloaded (N, False);
Generate_Reference (Entity (P), P); Generate_Reference (Entity (P), P);
exit; exit;
end if; end if;
@ -7063,12 +7081,20 @@ package body Sem_Attr is
Get_Next_Interp (Index, It); Get_Next_Interp (Index, It);
end loop; end loop;
-- If it is a subprogram name or a type, there is nothing -- If Prefix is a subprogram name, it is frozen by this
-- to resolve. -- 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)) elsif Is_Overloadable (Entity (P)) then
and then not Is_Type (Entity (P)) if not In_Default_Expression then
then Insert_Actions (N, Freeze_Entity (Entity (P), Loc));
end if;
elsif Is_Type (Entity (P)) then
null;
else
Resolve (P); Resolve (P);
end if; end if;
@ -7077,8 +7103,8 @@ package body Sem_Attr is
if not Is_Entity_Name (P) then if not Is_Entity_Name (P) then
null; null;
elsif Is_Abstract (Entity (P)) elsif Is_Overloadable (Entity (P))
and then Is_Overloadable (Entity (P)) and then Is_Abstract_Subprogram (Entity (P))
then then
Error_Msg_N ("prefix of % attribute cannot be abstract", P); Error_Msg_N ("prefix of % attribute cannot be abstract", P);
Set_Etype (N, Any_Type); Set_Etype (N, Any_Type);
@ -7211,16 +7237,27 @@ package body Sem_Attr is
if Enclosing_Generic_Unit (Entity (P)) /= if Enclosing_Generic_Unit (Entity (P)) /=
Enclosing_Generic_Unit (Root_Type (Btyp)) Enclosing_Generic_Unit (Root_Type (Btyp))
then then
Error_Msg_N
("''Access attribute not allowed in generic body",
N);
if Root_Type (Btyp) = Btyp then if Root_Type (Btyp) = Btyp then
Error_Msg_N Error_Msg_NE
("access type must not be outside generic unit", ("\because " &
N); "access type & is declared outside " &
"generic unit ('R'M 3.10.2(32))", N, Btyp);
else else
Error_Msg_N Error_Msg_NE
("ancestor access type must not be outside " & ("\because ancestor of " &
"generic unit", N); "access type & is declared outside " &
"generic unit ('R'M 3.10.2(32))", N, Btyp);
end if; 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 -- If the ultimate ancestor of the attribute's type is
-- a formal type, then the attribute is illegal because -- a formal type, then the attribute is illegal because
-- the actual type might be declared at a higher level. -- the actual type might be declared at a higher level.
@ -7244,11 +7281,17 @@ package body Sem_Attr is
end if; end if;
-- If this is a renaming, an inherited operation, or a -- 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) if Is_Entity_Name (P)
and then Is_Overloadable (Entity (P)) and then Is_Overloadable (Entity (P))
and then Present (Alias (Entity (P))) and then Present (Alias (Entity (P)))
and then Expander_Active
then then
Rewrite (P, Rewrite (P,
New_Occurrence_Of (Alias (Entity (P)), Sloc (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) elsif Object_Access_Level (P) > Type_Access_Level (Btyp)
and then Comes_From_Source (N) and then Comes_From_Source (N)
and then Ekind (Btyp) = E_Access_Protected_Subprogram_Type and then Ekind (Btyp) = E_Access_Protected_Subprogram_Type
and then No (Original_Access_Type (Typ))
then then
Accessibility_Message; Accessibility_Message;
return; return;
@ -7940,6 +7982,15 @@ package body Sem_Attr is
when others => null; when others => null;
end case; 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; end case;
-- Normally the Freezing is done by Resolve but sometimes the Prefix -- Normally the Freezing is done by Resolve but sometimes the Prefix
@ -7978,7 +8029,7 @@ package body Sem_Attr is
end if; end if;
if Nam = TSS_Stream_Input if Nam = TSS_Stream_Input
and then Is_Abstract (Typ) and then Is_Abstract_Type (Typ)
and then not Is_Class_Wide_Type (Typ) and then not Is_Class_Wide_Type (Typ)
then then
return False; return False;

1535
gcc/ada/sem_ch3.adb
View File

File diff suppressed because it is too large Load Diff

12
gcc/ada/sem_ch3.ads
View File

@ -246,14 +246,12 @@ package Sem_Ch3 is
-- Prev is entity on the partial view, on which references are posted. -- Prev is entity on the partial view, on which references are posted.
function Replace_Anonymous_Access_To_Protected_Subprogram function Replace_Anonymous_Access_To_Protected_Subprogram
(N : Node_Id; (N : Node_Id) return Entity_Id;
Prev_E : Entity_Id) return Entity_Id;
-- Ada 2005 (AI-254): Create and decorate an internal full type declaration -- Ada 2005 (AI-254): Create and decorate an internal full type declaration
-- in the enclosing scope corresponding to an anonymous access to protected -- for an anonymous access to protected subprogram. For a record component
-- subprogram. In addition, replace the anonymous access by an occurrence -- declaration, the type is created in the enclosing scope, for an array
-- of this internal type. Prev_Etype is used to link the new internal -- type declaration or an object declaration it is simply placed ahead of
-- entity with the anonymous entity. Return the entity of this type -- this declaration.
-- declaration.
procedure Set_Completion_Referenced (E : Entity_Id); procedure Set_Completion_Referenced (E : Entity_Id);
-- If E is the completion of a private or incomplete type declaration, -- If E is the completion of a private or incomplete type declaration,