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 97 additions and 51 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/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.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