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 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);

332
gcc/ada/freeze.adb
View File

@ -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
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).
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
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
-- 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).
begin
Ind := First_Index (OCtyp);
while Present (Ind) loop
Indtyp := Etype (Ind);
if Present (Component_Clause (Comp)) then
Packed_Size_Known := 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);
-- 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;
begin
Ind := First_Index (OCtyp);
while Present (Ind) loop
Indtyp := Etype (Ind);
if Is_Enumeration_Type (Indtyp)
and then Has_Non_Standard_Rep (Indtyp)
if Is_Entity_Name (Lo)
and then Ekind (Entity (Lo)) = E_Discriminant
then
Lo := Type_Low_Bound (Indtyp);
Hi := Type_High_Bound (Indtyp);
return False;
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;
elsif Is_Entity_Name (Hi)
and then Ekind (Entity (Hi)) = E_Discriminant
then
return False;
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;
-- If we have a non-elementary type we can't figure
-- out the packed array size (alignment issues).
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;
-- 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 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.
-- 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 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);
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).
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.
Set_Size_Info (E, Packed_Array_Type (E));
Set_RM_Size (E, RM_Size (Packed_Array_Type (E)));
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;
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

11
gcc/ada/layout.adb
View File

@ -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

123
gcc/ada/sem_attr.adb
View File

@ -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;

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.
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,