mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-05 05:30:26 +08:00
Code Issues Packages Projects Releases Wiki Activity

sem_ch12.adb (Inline_Instance_Body): Remove erroneous assumption that Scope_Stack.First = 1.

Browse Source 
2006-02-13  Thomas Quinot  <quinot@adacore.com>
	    Robert Dewar  <dewar@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Javier Miranda  <miranda@adacore.com>

	* sem_ch12.adb (Inline_Instance_Body): Remove erroneous assumption
	that Scope_Stack.First = 1.
	Properly handle Ada_Version_Explicit and Ada_Version_Config, which
	were not always properly handled previously.
	(Formal_Entity): Complete rewrite, to handle properly some complex case
	with multiple levels of parametrization by formal packages.
	(Analyze_Formal_Derived_Type): Propagate Ada 2005 "limited" indicator
	to the corresponding derived type declaration for proper semantics.

	* sem_prag.adb (Analyze_Pragma): Remove '!' in warning message.
	(Check_Component): Enforce restriction on components of
	unchecked_unions: a component in a variant cannot contain tasks or
	controlled types.
	(Unchecked_Union): Allow nested variants and multiple discriminants, to
	conform to AI-216.
	Add pragma Ada_2005 (synonym for Ada_05)
	Properly handle Ada_Version_Explicit and Ada_Version_Config, which
	were not always properly handled previously.
	Document that pragma Propagate_Exceptions has no effect
	(Analyze_Pragma, case Pure): Set new flag Has_Pragma_Pure
	(Set_Convention_From_Pragma): Check that if a convention is
	specified for a dispatching operation, then it must be
	consistent with the existing convention for the operation.
	(CPP_Class): Because of the C++ ABI compatibility, the programmer is no
	longer required to specify an vtable-ptr component in the record. For
	compatibility reasons we leave the support for the previous definition.
	(Analyze_Pragma, case No_Return): Allow multiple arguments

	* sem_ch3.ads, sem_ch3.adb (Check_Abstract_Overriding): Flag a
	non-overrideen inherited operation with a controlling result as
	illegal only its implicit declaration comes from the derived type
	declaration of its result's type.
	(Check_Possible_Deferred_Completion): Relocate the object definition
	node of the subtype indication of a deferred constant completion rather
	than directly analyzing it. The analysis of the generated subtype will
	correctly decorate the GNAT tree.
	(Record_Type_Declaration): Check whether this is a declaration for a
	limited derived record before analyzing components.
	(Analyze_Component_Declaration): Diagnose record types  not explicitly
	declared limited when a component has a limited type.
	(Build_Derived_Record_Type): Code reorganization to check if some of
	the inherited subprograms of a tagged type cover interface primitives.
	This check was missing in case of a full-type associated with a private
	type declaration.
	(Constant_Redeclaration): Check that the subtypes of the partial and the
	full view of a constrained deferred constant statically match.
	(Mentions_T): A reference to the current type in an anonymous access
	component declaration  must be an entity name.
	(Make_Incomplete_Type_Declaration): If type is tagged, set type of
	class_wide type to refer to full type, not to the incomplete one.
	(Add_Interface_Tag_Components): Do nothing if RE_Interface_Tag is not
	available. Required to give support to the certified run-time.
	(Analyze_Component_Declaration): In case of anonymous access components
	perform missing checks for AARM 3.9.2(9) and 3.10.2 (12.2).
	(Process_Discriminants): For an access discriminant, use the
	discriminant specification as the associated_node_for_itype, to
	simplify accessibility checks.

From-SVN: r111091
This commit is contained in:
Thomas Quinot 2006-02-15 10:44:24 +01:00 committed by Arnaud Charlet
parent 561d9139e3
commit 57193e0924
4 changed files with 666 additions and 357 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

215
gcc/ada/sem_ch12.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -1351,6 +1351,7 @@ package body Sem_Ch12 is
Subtype_Indication => Subtype_Mark (Def));
Set_Abstract_Present (New_N, Abstract_Present (Def));
Set_Limited_Present (New_N, Limited_Present (Def));
else
New_N :=
@ -1364,6 +1365,8 @@ package body Sem_Ch12 is
Set_Abstract_Present
(Type_Definition (New_N), Abstract_Present (Def));
Set_Limited_Present
(Type_Definition (New_N), Limited_Present (Def));
end if;
Rewrite (N, New_N);
@ -1894,7 +1897,7 @@ package body Sem_Ch12 is
Ctrl_Type : constant Entity_Id := Find_Dispatching_Type (Nam);
begin
if not Present (Ctrl_Type) then
if No (Ctrl_Type) then
Error_Msg_N
("abstract formal subprogram must have a controlling type",
N);
@ -3030,9 +3033,13 @@ package body Sem_Ch12 is
Cunit_Entity (Current_Sem_Unit);
Removed : Boolean := False;
Num_Scopes : Int := 0;
Use_Clauses : array (1 .. Scope_Stack.Last) of Node_Id;
Instances : array (1 .. Scope_Stack.Last) of Entity_Id;
Inner_Scopes : array (1 .. Scope_Stack.Last) of Entity_Id;
Scope_Stack_Depth : constant Int :=
Scope_Stack.Last - Scope_Stack.First + 1;
Use_Clauses : array (1 .. Scope_Stack_Depth) of Node_Id;
Instances : array (1 .. Scope_Stack_Depth) of Entity_Id;
Inner_Scopes : array (1 .. Scope_Stack_Depth) of Entity_Id;
Num_Inner : Int := 0;
N_Instances : Int := 0;
S : Entity_Id;
@ -6568,16 +6575,23 @@ package body Sem_Ch12 is
-- because each actual has the same name as the formal, and they do
-- appear in the same order.
function Formal_Entity
(F : Node_Id;
Act_Ent : Entity_Id) return Entity_Id;
-- Returns the entity associated with the given formal F. In the
-- case where F is a formal package, this function will iterate
-- through all of F's formals and enter map associations from the
function Get_Formal_Entity (N : Node_Id) return Entity_Id;
-- Retrieve entity of defining entity of generic formal parameter.
-- Only the declarations of formals need to be considered when
-- linking them to actuals, but the declarative list may include
-- internal entities generated during analysis, and those are ignored.
procedure Match_Formal_Entity
(Formal_Node : Node_Id;
Formal_Ent : Entity_Id;
Actual_Ent : Entity_Id);
-- Associates the formal entity with the actual. In the case
-- where Formal_Ent is a formal package, this procedure iterates
-- through all of its formals and enters associations betwen the
-- actuals occurring in the formal package's corresponding actual
-- package (obtained via Act_Ent) to the formal package's formal
-- parameters. This function is called recursively for arbitrary
-- levels of formal packages.
-- package (given by Actual_Ent) and the formal package's formal
-- parameters. This procedure recurses if any of the parameters is
-- itself a package.
function Is_Instance_Of
(Act_Spec : Entity_Id;
@ -6641,118 +6655,109 @@ package body Sem_Ch12 is
end case;
end Find_Matching_Actual;
-------------------
-- Formal_Entity --
-------------------
-------------------------
-- Match_Formal_Entity --
-------------------------
function Formal_Entity
(F : Node_Id;
Act_Ent : Entity_Id) return Entity_Id
procedure Match_Formal_Entity
(Formal_Node : Node_Id;
Formal_Ent : Entity_Id;
Actual_Ent : Entity_Id)
is
Orig_Node : Node_Id := F;
Act_Pkg : Entity_Id;
begin
case Nkind (Original_Node (F)) is
when N_Formal_Object_Declaration =>
return Defining_Identifier (F);
Set_Instance_Of (Formal_Ent, Actual_Ent);
when N_Formal_Type_Declaration =>
return Defining_Identifier (F);
if Ekind (Actual_Ent) = E_Package then
-- Record associations for each parameter
when N_Formal_Subprogram_Declaration =>
return Defining_Unit_Name (Specification (F));
Act_Pkg := Actual_Ent;
when N_Package_Declaration =>
return Defining_Unit_Name (Specification (F));
declare
A_Ent : Entity_Id := First_Entity (Act_Pkg);
F_Ent : Entity_Id;
F_Node : Node_Id;
when N_Formal_Package_Declaration |
N_Generic_Package_Declaration =>
Gen_Decl : Node_Id;
Formals : List_Id;
Actual : Entity_Id;
if Nkind (F) = N_Generic_Package_Declaration then
Orig_Node := Original_Node (F);
begin
-- Retrieve the actual given in the formal package declaration
Actual := Entity (Name (Original_Node (Formal_Node)));
-- The actual in the formal package declaration may be a
-- renamed generic package, in which case we want to retrieve
-- the original generic in order to traverse its formal part.
if Present (Renamed_Entity (Actual)) then
Gen_Decl := Unit_Declaration_Node (Renamed_Entity (Actual));
else
Gen_Decl := Unit_Declaration_Node (Actual);
end if;
Act_Pkg := Act_Ent;
Formals := Generic_Formal_Declarations (Gen_Decl);
-- Find matching actual package, skipping over itypes and
-- other entities generated when analyzing the formal. We
-- know that if the instantiation is legal then there is
-- a matching package for the formal.
if Present (Formals) then
F_Node := First_Non_Pragma (Formals);
else
F_Node := Empty;
end if;
while Ekind (Act_Pkg) /= E_Package loop
Act_Pkg := Next_Entity (Act_Pkg);
while Present (A_Ent)
and then Present (F_Node)
and then A_Ent /= First_Private_Entity (Act_Pkg)
loop
F_Ent := Get_Formal_Entity (F_Node);
if Present (F_Ent) then
-- This is a formal of the original package. Record
-- association and recurse.
Find_Matching_Actual (F_Node, A_Ent);
Match_Formal_Entity (F_Node, F_Ent, A_Ent);
Next_Entity (A_Ent);
end if;
Next_Non_Pragma (F_Node);
end loop;
end;
end if;
end Match_Formal_Entity;
declare
Actual_Ent : Entity_Id := First_Entity (Act_Pkg);
Formal_Node : Node_Id;
Formal_Ent : Entity_Id;
-----------------------
-- Get_Formal_Entity --
-----------------------
Gen_Decl : Node_Id;
Formals : List_Id;
function Get_Formal_Entity (N : Node_Id) return Entity_Id is
Kind : constant Node_Kind := Nkind (Original_Node (N));
begin
case Kind is
when N_Formal_Object_Declaration =>
return Defining_Identifier (N);
begin
-- The actual may be a renamed generic package, in which
-- case we want to retrieve the original generic in order
-- to traverse its formal part.
when N_Formal_Type_Declaration =>
return Defining_Identifier (N);
if Present (Renamed_Entity (Entity (Name (Orig_Node)))) then
Gen_Decl :=
Unit_Declaration_Node (
Renamed_Entity (Entity (Name (Orig_Node))));
else
Gen_Decl :=
Unit_Declaration_Node (Entity (Name (Orig_Node)));
end if;
when N_Formal_Subprogram_Declaration =>
return Defining_Unit_Name (Specification (N));
Formals := Generic_Formal_Declarations (Gen_Decl);
when N_Formal_Package_Declaration =>
return Defining_Identifier (Original_Node (N));
if Present (Formals) then
Formal_Node := First_Non_Pragma (Formals);
else
Formal_Node := Empty;
end if;
when N_Generic_Package_Declaration =>
return Defining_Identifier (Original_Node (N));
while Present (Actual_Ent)
and then Present (Formal_Node)
and then Actual_Ent /= First_Private_Entity (Act_Pkg)
loop
-- ??? Are the following calls also needed here:
--
-- Set_Is_Hidden (Actual_Ent, False);
-- Set_Is_Potentially_Use_Visible
-- (Actual_Ent, In_Use (Act_Ent));
-- All other declarations are introduced by semantic analysis
-- and have no match in the actual.
Formal_Ent := Formal_Entity (Formal_Node, Actual_Ent);
if Present (Formal_Ent) then
Set_Instance_Of (Formal_Ent, Actual_Ent);
end if;
Next_Non_Pragma (Formal_Node);
Next_Entity (Actual_Ent);
end loop;
end;
return Defining_Identifier (Orig_Node);
when N_Use_Package_Clause =>
when others =>
return Empty;
when N_Use_Type_Clause =>
return Empty;
-- We return Empty for all other encountered forms of
-- declarations because there are some cases of nonformal
-- sorts of declaration that can show up (e.g., when array
-- formals are present). Since it's not clear what kinds
-- can appear among the formals, we won't raise failure here.
when others =>
return Empty;
end case;
end Formal_Entity;
end Get_Formal_Entity;
--------------------
-- Is_Instance_Of --
@ -6987,11 +6992,12 @@ package body Sem_Ch12 is
end if;
if Present (Formal_Node) then
Formal_Ent := Formal_Entity (Formal_Node, Actual_Ent);
Formal_Ent := Get_Formal_Entity (Formal_Node);
if Present (Formal_Ent) then
Find_Matching_Actual (Formal_Node, Actual_Ent);
Set_Instance_Of (Formal_Ent, Actual_Ent);
Match_Formal_Entity
(Formal_Node, Formal_Ent, Actual_Ent);
end if;
Next_Non_Pragma (Formal_Node);
@ -8529,7 +8535,7 @@ package body Sem_Ch12 is
and then Present (Ancestor_Discr)
loop
if Base_Type (Act_T) /= Base_Type (Ancestor) and then
not Present (Corresponding_Discriminant (Actual_Discr))
No (Corresponding_Discriminant (Actual_Discr))
then
Error_Msg_NE
("discriminant & does not correspond " &
@ -10444,7 +10450,6 @@ package body Sem_Ch12 is
(Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)),
Renamings_Included => True) then
Ada_Version := Ada_Version_Type'Last;
Ada_Version_Explicit := Ada_Version_Explicit_Config;
end if;
Current_Instantiated_Parent := (Gen_Unit, Act_Unit, Assoc_Null);

627
gcc/ada/sem_ch3.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -658,10 +658,10 @@ package body Sem_Ch3 is
(Def_Id : Entity_Id;
R : Node_Id;
Subt : Entity_Id);
-- This routine is used to set the scalar range field for a subtype
-- given Def_Id, the entity for the subtype, and R, the range expression
-- for the scalar range. Subt provides the parent subtype to be used
-- to analyze, resolve, and check the given range.
-- This routine is used to set the scalar range field for a subtype given
-- Def_Id, the entity for the subtype, and R, the range expression for the
-- scalar range. Subt provides the parent subtype to be used to analyze,
-- resolve, and check the given range.
procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id);
-- Create a new signed integer entity, and apply the constraint to obtain
@ -680,9 +680,7 @@ package body Sem_Ch3 is
(Related_Nod : Node_Id;
N : Node_Id) return Entity_Id
is
Anon_Type : constant Entity_Id :=
Create_Itype (E_Anonymous_Access_Type, Related_Nod,
Scope_Id => Scope (Current_Scope));
Anon_Type : Entity_Id;
Desig_Type : Entity_Id;
begin
@ -692,16 +690,14 @@ package body Sem_Ch3 is
Error_Msg_N ("task entries cannot have access parameters", N);
end if;
-- Ada 2005: for an object declaration or function with an anonymous
-- access result, the corresponding anonymous type is declared in the
-- current scope. For access formals, access components, and access
-- discriminants, the scope is that of the enclosing declaration,
-- as set above. This special-case handling of resetting the scope
-- is awkward, and it might be better to pass in the required scope
-- as a parameter. ???
-- Ada 2005: for an object declaration the corresponding anonymous
-- type is declared in the current scope.
if Nkind (Related_Nod) = N_Object_Declaration then
Set_Scope (Anon_Type, Current_Scope);
Anon_Type :=
Create_Itype
(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
@ -713,7 +709,19 @@ package body Sem_Ch3 is
elsif Nkind (Related_Nod) = N_Function_Specification
and then Nkind (Parent (N)) /= N_Parameter_Specification
then
Set_Scope (Anon_Type, Scope (Defining_Unit_Name (Related_Nod)));
Anon_Type :=
Create_Itype
(E_Anonymous_Access_Type, Related_Nod,
Scope_Id => Scope (Defining_Unit_Name (Related_Nod)));
else
-- For access formals, access components, and access
-- discriminants, the scope is that of the enclosing declaration,
Anon_Type :=
Create_Itype
(E_Anonymous_Access_Type, Related_Nod,
Scope_Id => Scope (Current_Scope));
end if;
if All_Present (N)
@ -1081,9 +1089,10 @@ package body Sem_Ch3 is
-------------
procedure Add_Tag (Iface : Entity_Id) is
Def : Node_Id;
Tag : Entity_Id;
Decl : Node_Id;
Decl : Node_Id;
Def : Node_Id;
Tag : Entity_Id;
Offset : Entity_Id;
begin
pragma Assert (Is_Tagged_Type (Iface)
@ -1115,21 +1124,52 @@ package body Sem_Ch3 is
Set_DT_Entry_Count (Tag,
DT_Entry_Count (First_Entity (Iface)));
if not Present (Last_Tag) then
if No (Last_Tag) then
Prepend (Decl, L);
else
Insert_After (Last_Tag, Decl);
end if;
Last_Tag := Decl;
-- If the ancestor has discriminants we need to give special support
-- to store the offset_to_top value of the secondary dispatch tables.
-- For this purpose we add a supplementary component just after the
-- field that contains the tag associated with each secondary DT.
if Typ /= Etype (Typ)
and then Has_Discriminants (Etype (Typ))
then
Def :=
Make_Component_Definition (Loc,
Subtype_Indication =>
New_Occurrence_Of (RTE (RE_Storage_Offset), Loc));
Offset :=
Make_Defining_Identifier (Loc, New_Internal_Name ('V'));
Decl :=
Make_Component_Declaration (Loc,
Defining_Identifier => Offset,
Component_Definition => Def);
Analyze_Component_Declaration (Decl);
Set_Analyzed (Decl);
Set_Ekind (Offset, E_Component);
Init_Component_Location (Offset);
Insert_After (Last_Tag, Decl);
Last_Tag := Decl;
end if;
end Add_Tag;
-- Start of processing for Add_Interface_Tag_Components
begin
if Ekind (Typ) /= E_Record_Type
or else not Present (Abstract_Interfaces (Typ))
or else No (Abstract_Interfaces (Typ))
or else Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
or else not RTE_Available (RE_Interface_Tag)
then
return;
end if;
@ -1207,6 +1247,13 @@ package body Sem_Ch3 is
-- Determines whether a constraint uses the discriminant of a record
-- type thus becoming a per-object constraint (POC).
function Is_Known_Limited (Typ : Entity_Id) return Boolean;
-- Check whether enclosing record is limited, to validate declaration
-- of components with limited types.
-- This seems a wrong description to me???
-- What is Typ? For sure it can return a result without checking
-- the enclosing record (enclosing what???)
------------------
-- Contains_POC --
------------------
@ -1259,6 +1306,41 @@ package body Sem_Ch3 is
end case;
end Contains_POC;
----------------------
-- Is_Known_Limited --
----------------------
function Is_Known_Limited (Typ : Entity_Id) return Boolean is
P : constant Entity_Id := Etype (Typ);
R : constant Entity_Id := Root_Type (Typ);
begin
if Is_Limited_Record (Typ) then
return True;
-- If the root type is limited (and not a limited interface)
-- so is the current type
elsif Is_Limited_Record (R)
and then
(not Is_Interface (R)
or else not Is_Limited_Interface (R))
then
return True;
-- Else the type may have a limited interface progenitor, but a
-- limited record parent.
elsif R /= P
and then Is_Limited_Record (P)
then
return True;
else
return False;
end if;
end Is_Known_Limited;
-- Start of processing for Analyze_Component_Declaration
begin
@ -1321,6 +1403,40 @@ package body Sem_Ch3 is
if Present (Expression (N)) then
Analyze_Per_Use_Expression (Expression (N), T);
Check_Initialization (T, Expression (N));
if Ada_Version >= Ada_05
and then Is_Access_Type (T)
and then Ekind (T) = E_Anonymous_Access_Type
then
-- Check RM 3.9.2(9): "if the expected type for an expression is
-- an anonymous access-to-specific tagged type, then the object
-- designated by the expression shall not be dynamically tagged
-- unless it is a controlling operand in a call on a dispatching
-- operation"
if Is_Tagged_Type (Directly_Designated_Type (T))
and then
Ekind (Directly_Designated_Type (T)) /= E_Class_Wide_Type
and then
Ekind (Directly_Designated_Type (Etype (Expression (N)))) =
E_Class_Wide_Type
then
Error_Msg_N
("access to specific tagged type required ('R'M 3.9.2(9))",
Expression (N));
end if;
-- (Ada 2005: AI-230): Accessibility check for anonymous
-- components
if Type_Access_Level (Etype (Expression (N))) >
Type_Access_Level (T)
then
Error_Msg_N
("expression has deeper access level than component " &
"('R'M 3.10.2 (12.2))", Expression (N));
end if;
end if;
end if;
-- The parent type may be a private view with unknown discriminants,
@ -1406,11 +1522,19 @@ package body Sem_Ch3 is
and then Is_Tagged_Type (Current_Scope)
then
if Is_Derived_Type (Current_Scope)
and then not Is_Limited_Record (Root_Type (Current_Scope))
and then not Is_Known_Limited (Current_Scope)
then
Error_Msg_N
("extension of nonlimited type cannot have limited components",
N);
if Is_Interface (Root_Type (Current_Scope)) then
Error_Msg_N
("\limitedness is not inherited from limited interface", N);
Error_Msg_N
("\add LIMITED to type indication", N);
end if;
Explain_Limited_Type (T, N);
Set_Etype (Id, Any_Type);
Set_Is_Limited_Composite (Current_Scope, False);
@ -2067,7 +2191,7 @@ package body Sem_Ch3 is
-- In case of errors detected in the analysis of the expression,
-- decorate it with the expected type to avoid cascade errors
if not Present (Etype (E)) then
if No (Etype (E)) then
Set_Etype (E, T);
end if;
@ -2660,7 +2784,11 @@ package body Sem_Ch3 is
if Limited_Present (N) then
Set_Is_Limited_Record (T);
if not Is_Limited_Type (Parent_Type) then
if not Is_Limited_Type (Parent_Type)
and then
(not Is_Interface (Parent_Type)
or else not Is_Limited_Interface (Parent_Type))
then
Error_Msg_NE ("parent type& of limited extension must be limited",
N, Parent_Type);
end if;
@ -5332,7 +5460,6 @@ package body Sem_Ch3 is
Constraint_Present : Boolean;
Has_Interfaces : Boolean := False;
Inherit_Discrims : Boolean := False;
Last_Inherited_Prim_Op : Elmt_Id;
Tagged_Partial_View : Entity_Id;
Save_Etype : Entity_Id;
Save_Discr_Constr : Elist_Id;
@ -5768,7 +5895,7 @@ package body Sem_Ch3 is
Discrim := First_Discriminant (Derived_Type);
while Present (Discrim) loop
if not Is_Tagged
and then not Present (Corresponding_Discriminant (Discrim))
and then No (Corresponding_Discriminant (Discrim))
then
Error_Msg_N
("new discriminants must constrain old ones", Discrim);
@ -6006,40 +6133,6 @@ package body Sem_Ch3 is
else
Collect_Interfaces (Type_Definition (N), Derived_Type);
end if;
-- Ada 2005 (AI-251): The progenitor types specified in a private
-- extension declaration and the progenitor types specified in the
-- corresponding declaration of a record extension given in the
-- private part need not be the same; the only requirement is that
-- the private extension must be descended from each interface
-- from which the record extension is descended (AARM 7.3, 20.1/2)
if Has_Private_Declaration (Derived_Type) then
declare
N_Partial : constant Node_Id := Parent (Tagged_Partial_View);
Iface_Partial : Entity_Id;
begin
if Nkind (N_Partial) = N_Private_Extension_Declaration
and then not Is_Empty_List (Interface_List (N_Partial))
then
Iface_Partial := First (Interface_List (N_Partial));
while Present (Iface_Partial) loop
if not Interface_Present_In_Ancestor
(Derived_Type, Etype (Iface_Partial))
then
Error_Msg_N
("(Ada 2005) full type and private extension must"
& " have the same progenitors", Derived_Type);
exit;
end if;
Next (Iface_Partial);
end loop;
end if;
end;
end if;
end if;
else
@ -6060,8 +6153,9 @@ package body Sem_Ch3 is
Constrs := Discriminant_Constraint (Parent_Type);
end if;
Assoc_List := Inherit_Components (N,
Parent_Base, Derived_Type, Is_Tagged, Inherit_Discrims, Constrs);
Assoc_List :=
Inherit_Components
(N, Parent_Base, Derived_Type, Is_Tagged, Inherit_Discrims, Constrs);
-- STEP 5a: Copy the parent record declaration for untagged types
@ -6208,116 +6302,103 @@ package body Sem_Ch3 is
end;
end if;
-- Ada 2005 (AI-251): Keep separate the management of tagged types
-- implementing interfaces
Derive_Subprograms (Parent_Type, Derived_Type);
if not Is_Tagged_Type (Derived_Type)
or else not Has_Interfaces
-- Ada 2005 (AI-251): Handle tagged types implementing interfaces
if Is_Tagged_Type (Derived_Type)
and then Has_Interfaces
then
Derive_Subprograms (Parent_Type, Derived_Type);
-- Ada 2005 (AI-251): If we are analyzing a full view that has
-- no partial view we derive the abstract interface Subprograms
else
-- Ada 2005 (AI-251): Complete the decoration of tagged private
-- types that implement interfaces
if No (Tagged_Partial_View) then
Derive_Interface_Subprograms (Derived_Type);
if Present (Tagged_Partial_View) then
Derive_Subprograms
(Parent_Type, Derived_Type);
-- Ada 2005 (AI-251): if we are analyzing a full view that has
-- a partial view we complete the derivation of the subprograms
else
Complete_Subprograms_Derivation
(Partial_View => Tagged_Partial_View,
Derived_Type => Derived_Type);
end if;
-- Ada 2005 (AI-251): Derive the interface subprograms of all the
-- implemented interfaces and check if some of the subprograms
-- inherited from the ancestor cover some interface subprogram.
-- Ada 2005 (AI-251): In both cases we check if some of the
-- inherited subprograms cover interface primitives.
else
Derive_Subprograms (Parent_Type, Derived_Type);
declare
Iface_Subp : Entity_Id;
Iface_Subp_Elmt : Elmt_Id;
Prev_Alias : Entity_Id;
Subp : Entity_Id;
Subp_Elmt : Elmt_Id;
declare
Subp_Elmt : Elmt_Id;
First_Iface_Elmt : Elmt_Id;
Iface_Subp_Elmt : Elmt_Id;
Subp : Entity_Id;
Iface_Subp : Entity_Id;
Is_Interface_Subp : Boolean;
begin
Iface_Subp_Elmt :=
First_Elmt (Primitive_Operations (Derived_Type));
while Present (Iface_Subp_Elmt) loop
Iface_Subp := Node (Iface_Subp_Elmt);
begin
-- Ada 2005 (AI-251): Remember the entity corresponding to
-- the last inherited primitive operation. This is required
-- to check if some of the inherited subprograms covers some
-- of the new interfaces.
-- Look for an abstract interface subprogram
Last_Inherited_Prim_Op := No_Elmt;
if Is_Abstract (Iface_Subp)
and then Present (Alias (Iface_Subp))
and then Present (DTC_Entity (Alias (Iface_Subp)))
and then Is_Interface
(Scope (DTC_Entity (Alias (Iface_Subp))))
then
-- Look for candidate primitive subprograms of the tagged
-- type that can cover this interface subprogram.
Subp_Elmt :=
First_Elmt (Primitive_Operations (Derived_Type));
while Present (Subp_Elmt) loop
Last_Inherited_Prim_Op := Subp_Elmt;
Next_Elmt (Subp_Elmt);
end loop;
Subp_Elmt :=
First_Elmt (Primitive_Operations (Derived_Type));
while Present (Subp_Elmt) loop
Subp := Node (Subp_Elmt);
-- Ada 2005 (AI-251): Derive subprograms in abstract
-- interfaces.
if not Is_Abstract (Subp)
and then Chars (Subp) = Chars (Iface_Subp)
and then Type_Conformant (Iface_Subp, Subp)
then
Prev_Alias := Alias (Iface_Subp);
Derive_Interface_Subprograms (Derived_Type);
Check_Dispatching_Operation
(Subp => Subp,
Old_Subp => Iface_Subp);
-- Ada 2005 (AI-251): Check if some of the inherited
-- subprograms cover some of the new interfaces.
pragma Assert
(Alias (Iface_Subp) = Subp);
pragma Assert
(Abstract_Interface_Alias (Iface_Subp)
= Prev_Alias);
if Present (Last_Inherited_Prim_Op) then
First_Iface_Elmt := Next_Elmt (Last_Inherited_Prim_Op);
Iface_Subp_Elmt := First_Iface_Elmt;
while Present (Iface_Subp_Elmt) loop
Subp_Elmt := First_Elmt (Primitive_Operations
(Derived_Type));
while Subp_Elmt /= First_Iface_Elmt loop
Subp := Node (Subp_Elmt);
Iface_Subp := Node (Iface_Subp_Elmt);
-- Traverse the list of aliased subprograms to link
-- subp with its ultimate aliased subprogram. This
-- avoids problems with the backend.
Is_Interface_Subp :=
Present (Alias (Subp))
and then Present (DTC_Entity (Alias (Subp)))
and then Is_Interface (Scope
(DTC_Entity
(Alias (Subp))));
declare
E : Entity_Id;
if Chars (Subp) = Chars (Iface_Subp)
and then not Is_Interface_Subp
and then not Is_Abstract (Subp)
and then Type_Conformant (Iface_Subp, Subp)
then
Check_Dispatching_Operation
(Subp => Subp,
Old_Subp => Iface_Subp);
begin
E := Alias (Subp);
while Present (Alias (E)) loop
E := Alias (E);
end loop;
-- Traverse the list of aliased subprograms
Set_Alias (Subp, E);
end;
declare
E : Entity_Id;
Set_Has_Delayed_Freeze (Subp);
exit;
end if;
begin
E := Alias (Subp);
while Present (Alias (E)) loop
E := Alias (E);
end loop;
Set_Alias (Subp, E);
end;
Set_Has_Delayed_Freeze (Subp);
exit;
end if;
Next_Elmt (Subp_Elmt);
end loop;
Next_Elmt (Iface_Subp_Elmt);
Next_Elmt (Subp_Elmt);
end loop;
end if;
end;
end if;
Next_Elmt (Iface_Subp_Elmt);
end loop;
end;
end if;
end if;
@ -7092,10 +7173,11 @@ package body Sem_Ch3 is
-------------------------------
procedure Check_Abstract_Overriding (T : Entity_Id) is
Op_List : Elist_Id;
Elmt : Elmt_Id;
Subp : Entity_Id;
Type_Def : Node_Id;
Op_List : Elist_Id;
Elmt : Elmt_Id;
Subp : Entity_Id;
Alias_Subp : Entity_Id;
Type_Def : Node_Id;
begin
Op_List := Primitive_Operations (T);
@ -7105,13 +7187,22 @@ package body Sem_Ch3 is
Elmt := First_Elmt (Op_List);
while Present (Elmt) loop
Subp := Node (Elmt);
Alias_Subp := Alias (Subp);
-- Inherited subprograms are identified by the fact that they do not
-- come from source, and the associated source location is the
-- location of the first subtype of the derived type.
-- 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)
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))))
and then not Is_TSS (Subp, TSS_Stream_Input)
and then not Is_TSS (Subp, TSS_Stream_Output)
and then not Is_Abstract (T)
@ -7120,31 +7211,44 @@ package body Sem_Ch3 is
and then Chars (Subp) /= Name_uDisp_Get_Prim_Op_Kind
and then Chars (Subp) /= Name_uDisp_Timed_Select
then
if Present (Alias (Subp)) then
if Present (Alias_Subp) then
-- Only perform the check for a derived subprogram when
-- the type has an explicit record extension. This avoids
-- incorrectly flagging abstract subprograms for the case
-- of a type without an extension derived from a formal type
-- with a tagged actual (can occur within a private part).
-- Only perform the check for a derived subprogram when the
-- type has an explicit record extension. This avoids
-- incorrectly flagging abstract subprograms for the case of a
-- type without an extension derived from a formal type with a
-- tagged actual (can occur within a private part).
-- Ada 2005 (AI-391): In the case of an inherited function with
-- a controlling result of the type, the rule does not apply if
-- the type is a null extension (unless the parent function
-- itself is abstract, in which case the function must still be
-- be overridden). The expander will generate an overriding
-- wrapper function calling the parent subprogram (see
-- Exp_Ch3.Make_Controlling_Wrapper_Functions).
Type_Def := Type_Definition (Parent (T));
if Nkind (Type_Def) = N_Derived_Type_Definition
and then Present (Record_Extension_Part (Type_Def))
and then
(Ada_Version < Ada_05
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_Access_Type (Etype (Subp)))
then
Error_Msg_NE
("type must be declared abstract or & overridden",
T, Subp);
-- Traverse the whole chain of aliased subprograms to
-- complete the error notification. This is useful for
-- traceability of the chain of entities when the subprogram
-- corresponds with interface subprogram (that may be
-- defined in another package)
-- complete the error notification. This is especially
-- useful for traceability of the chain of entities when the
-- subprogram corresponds with an interface subprogram
-- (which might be defined in another package)
if Ada_Version >= Ada_05
and then Present (Alias (Subp))
then
if Present (Alias_Subp) then
declare
E : Entity_Id;
@ -7657,7 +7761,7 @@ package body Sem_Ch3 is
Next_Elmt (Elmt);
end loop;
if not Present (Elmt) then
if No (Elmt) then
Append_Elmt (Node => Iface,
To => Abstract_Interfaces (Derived_Type));
end if;
@ -8018,6 +8122,15 @@ package body Sem_Ch3 is
Obj_Def : constant Node_Id := Object_Definition (N);
New_T : Entity_Id;
procedure Check_Possible_Deferred_Completion
(Prev_Id : Entity_Id;
Prev_Obj_Def : Node_Id;
Curr_Obj_Def : Node_Id);
-- Determine whether the two object definitions describe the partial
-- and the full view of a constrained deferred constant. Generate
-- a subtype for the full view and verify that it statically matches
-- the subtype of the partial view.
procedure Check_Recursive_Declaration (Typ : Entity_Id);
-- If deferred constant is an access type initialized with an allocator,
-- check whether there is an illegal recursion in the definition,
@ -8025,6 +8138,46 @@ package body Sem_Ch3 is
-- detected when generating init procs, but requires this additional
-- mechanism when expansion is disabled.
----------------------------------------
-- Check_Possible_Deferred_Completion --
----------------------------------------
procedure Check_Possible_Deferred_Completion
(Prev_Id : Entity_Id;
Prev_Obj_Def : Node_Id;
Curr_Obj_Def : Node_Id)
is
begin
if Nkind (Prev_Obj_Def) = N_Subtype_Indication
and then Present (Constraint (Prev_Obj_Def))
and then Nkind (Curr_Obj_Def) = N_Subtype_Indication
and then Present (Constraint (Curr_Obj_Def))
then
declare
Loc : constant Source_Ptr := Sloc (N);
Def_Id : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('S'));
Decl : constant Node_Id :=
Make_Subtype_Declaration (Loc,
Defining_Identifier =>
Def_Id,
Subtype_Indication =>
Relocate_Node (Curr_Obj_Def));
begin
Insert_Before_And_Analyze (N, Decl);
Set_Etype (Id, Def_Id);
if not Subtypes_Statically_Match (Etype (Prev_Id), Def_Id) then
Error_Msg_Sloc := Sloc (Prev_Id);
Error_Msg_N ("subtype does not statically match deferred " &
"declaration#", N);
end if;
end;
end if;
end Check_Possible_Deferred_Completion;
---------------------------------
-- Check_Recursive_Declaration --
---------------------------------
@ -8124,6 +8277,16 @@ package body Sem_Ch3 is
-- If so, process the full constant declaration
else
-- RM 7.4 (6): If the subtype defined by the subtype_indication in
-- the deferred declaration is constrained, then the subtype defined
-- by the subtype_indication in the full declaration shall match it
-- statically.
Check_Possible_Deferred_Completion
(Prev_Id => Prev,
Prev_Obj_Def => Object_Definition (Parent (Prev)),
Curr_Obj_Def => Obj_Def);
Set_Full_View (Prev, Id);
Set_Is_Public (Id, Is_Public (Prev));
Set_Is_Internal (Id);
@ -10413,6 +10576,13 @@ package body Sem_Ch3 is
(New_Subp, Is_Valued_Procedure (Parent_Subp));
end if;
-- No_Return must be inherited properly. If this is overridden in the
-- case of a dispatching operation, then a check is made in Sem_Disp
-- that the overriding operation is also No_Return (no such check is
-- required for the case of non-dispatching operation.
Set_No_Return (New_Subp, No_Return (Parent_Subp));
-- A derived function with a controlling result is abstract. If the
-- Derived_Type is a nonabstract formal generic derived type, then
-- inherited operations are not abstract: the required check is done at
@ -10845,7 +11015,7 @@ package body Sem_Ch3 is
Partial_View := First_Entity (Current_Scope);
loop
exit when not Present (Partial_View)
exit when No (Partial_View)
or else (Has_Private_Declaration (Partial_View)
and then Full_View (Partial_View) = T);
@ -11020,13 +11190,15 @@ package body Sem_Ch3 is
Build_Derived_Type (N, Parent_Type, T, Is_Completion);
-- AI-419: the parent type of an explicitly limited derived type must
-- be limited. Interface progenitors were checked earlier.
-- be a limited type or a limited interface.
if Limited_Present (Def) then
Set_Is_Limited_Record (T);
if not Is_Limited_Type (Parent_Type)
and then not Is_Interface (Parent_Type)
and then
(not Is_Interface (Parent_Type)
or else not Is_Limited_Interface (Parent_Type))
then
Error_Msg_NE ("parent type& of limited type must be limited",
N, Parent_Type);
@ -11273,6 +11445,21 @@ package body Sem_Ch3 is
then
Error_Msg_N
("completion of nonlimited type cannot be limited", N);
elsif Ekind (Prev) = E_Record_Type_With_Private
and then
(Nkind (N) = N_Task_Type_Declaration
or else Nkind (N) = N_Protected_Type_Declaration)
then
if not Is_Limited_Record (Prev) then
Error_Msg_N
("completion of nonlimited type cannot be limited", N);
elsif No (Interface_List (N)) then
Error_Msg_N
("completion of tagged private type must be tagged",
N);
end if;
end if;
-- Ada 2005 (AI-251): Private extension declaration of a
@ -12144,6 +12331,7 @@ package body Sem_Ch3 is
if Ekind (Component) = E_Component
and then Is_Tag (Component)
and then RTE_Available (RE_Interface_Tag)
and then Etype (Component) = RTE (RE_Interface_Tag)
then
null;
@ -12191,6 +12379,41 @@ package body Sem_Ch3 is
return Assoc_List;
end Inherit_Components;
-----------------------
-- Is_Null_Extension --
-----------------------
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;
begin
if not Is_Tagged_Type (T)
or else Nkind (Full_Type_Defn) /= N_Derived_Type_Definition
then
return False;
end if;
Comp_List := Component_List (Record_Extension_Part (Full_Type_Defn));
if Present (Discriminant_Specifications (Full_Type_Decl)) then
return False;
elsif Present (Comp_List)
and then Is_Non_Empty_List (Component_Items (Comp_List))
then
First_Comp := First (Component_Items (Comp_List));
return Chars (Defining_Identifier (First_Comp)) = Name_uParent
and then No (Next (First_Comp));
else
return True;
end if;
end Is_Null_Extension;
------------------------------
-- Is_Valid_Constraint_Kind --
------------------------------
@ -13111,7 +13334,7 @@ package body Sem_Ch3 is
end if;
if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then
Discr_Type := Access_Definition (N, Discriminant_Type (Discr));
Discr_Type := Access_Definition (Discr, Discriminant_Type (Discr));
-- Ada 2005 (AI-230): Access discriminants are now allowed for
-- nonlimited types, and are treated like other components of
@ -13344,6 +13567,14 @@ package body Sem_Ch3 is
Iface_Elmt : Elmt_Id;
begin
-- Abstract interfaces are only associated with tagged record types
if not Is_Tagged_Type (Typ)
or else not Is_Record_Type (Typ)
then
return;
end if;
-- Implementations of the form:
-- type Typ is new Iface ...
@ -13361,10 +13592,11 @@ package body Sem_Ch3 is
while Present (Iface_Elmt) loop
Iface := Node (Iface_Elmt);
if Is_Interface (Iface)
and then not Contain_Interface (Iface, Ifaces)
then
pragma Assert (Is_Interface (Iface));
if not Contain_Interface (Iface, Ifaces) then
Append_Elmt (Iface, Ifaces);
Collect_Implemented_Interfaces (Iface, Ifaces);
end if;
Next_Elmt (Iface_Elmt);
@ -13495,15 +13727,22 @@ package body Sem_Ch3 is
Collect_Implemented_Interfaces (Priv_T, Priv_T_Ifaces);
Collect_Implemented_Interfaces (Full_T, Full_T_Ifaces);
-- Ada 2005 (AI-396): The partial view shall be a descendant of
-- an interface type if and only if the full view is a descendant
-- of the interface type.
-- Ada 2005 (AI-251): The partial view shall be a descendant of
-- an interface type if and only if the full type is descendant
-- of the interface type (AARM 7.3 (7.3/2).
Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces);
if Present (Iface) then
Error_Msg_NE ("interface & not implemented by full type " &
"('R'M'-2005 7.3 (7.3/2))", Priv_T, Iface);
end if;
Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces);
if Present (Iface) then
Error_Msg_NE ("interface & not implemented by partial view " &
"('R'M'-2005 7.3(9))", Full_T, Iface);
"('R'M'-2005 7.3 (7.3/2))", Full_T, Iface);
end if;
end;
end if;
@ -13543,7 +13782,14 @@ package body Sem_Ch3 is
then
null;
elsif not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent) then
-- Ada 2005 (AI-251): If the parent of the private type declaration
-- is an interface there is no need to check that it is an ancestor
-- of the associated full type declaration. The required tests for
-- this case case are performed by Build_Derived_Record_Type.
elsif not Is_Interface (Base_Type (Priv_Parent))
and then not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent)
then
Error_Msg_N
("parent of full type must descend from parent"
& " of private extension", Full_Indic);
@ -13554,7 +13800,7 @@ package body Sem_Ch3 is
-- subtype of the full type must be constrained if and only if
-- the ancestor subtype of the private extension is constrained.
elsif not Present (Discriminant_Specifications (Parent (Priv_T)))
elsif No (Discriminant_Specifications (Parent (Priv_T)))
and then not Has_Unknown_Discriminants (Priv_T)
and then Has_Discriminants (Base_Type (Priv_Parent))
then
@ -14512,8 +14758,13 @@ package body Sem_Ch3 is
if Nkind (Subt) = N_Identifier then
return Chars (Subt) = Chars (T);
-- 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))) = Chars (T);
else
@ -14638,8 +14889,12 @@ package body Sem_Ch3 is
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.
if Prev /= T then
if Prev /= T
or else Has_Private_Declaration (T)
then
return;
elsif No (Inc_T) then
@ -14671,6 +14926,7 @@ package body Sem_Ch3 is
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);
end if;
end if;
end Make_Incomplete_Type_Declaration;
@ -14915,6 +15171,15 @@ package body Sem_Ch3 is
Final_Storage_Only := not Is_Controlled (T);
-- Ada 2005: check whether an explicit Limited is present in a derived
-- type declaration.
if Nkind (Parent (Def)) = N_Derived_Type_Definition
and then Limited_Present (Parent (Def))
then
Set_Is_Limited_Record (T);
end if;
-- If the component list of a record type is defined by the reserved
-- word null and there is no discriminant part, then the record type has
-- no components and all records of the type are null records (RM 3.7)

5
gcc/ada/sem_ch3.ads
View File

@ -157,6 +157,11 @@ package Sem_Ch3 is
-- Given a discriminant somewhere in the Typ_For_Constraint tree
-- and a Constraint, return the value of that discriminant.
function Is_Null_Extension (T : Entity_Id) return Boolean;
-- Returns True if the tagged type T has an N_Full_Type_Declaration that
-- is a null extension, meaning that it has an extension part without any
-- components and does not have a known discriminant part.
function Is_Visible_Component (C : Entity_Id) return Boolean;
-- Determines if a record component C is visible in the present context.
-- Note that even though component C could appear in the entity chain

176
gcc/ada/sem_prag.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -341,7 +341,7 @@ package body Sem_Prag is
procedure Check_Component (Comp : Node_Id);
-- Examine Unchecked_Union component for correct use of per-object
-- constrained subtypes.
-- constrained subtypes, and for restrictions on finalizable components.
procedure Check_Duplicated_Export_Name (Nam : Node_Id);
-- Nam is an N_String_Literal node containing the external name set
@ -988,7 +988,8 @@ package body Sem_Prag is
declare
Sindic : constant Node_Id :=
Subtype_Indication (Component_Definition (Comp));
Typ : constant Entity_Id :=
Etype (Defining_Identifier (Comp));
begin
if Nkind (Sindic) = N_Subtype_Indication then
@ -1004,6 +1005,15 @@ package body Sem_Prag is
" constraint must be an Unchecked_Union", Comp);
end if;
end if;
if Is_Controlled (Typ) then
Error_Msg_N
("component of unchecked union cannot be controlled", Comp);
elsif Has_Task (Typ) then
Error_Msg_N
("component of unchecked union cannot have tasks", Comp);
end if;
end;
end if;
end Check_Component;
@ -1440,12 +1450,6 @@ package body Sem_Prag is
Comp : Node_Id;
begin
if Present (Variant_Part (Clist)) then
Error_Msg_N
("Unchecked_Union may not have nested variants",
Variant_Part (Clist));
end if;
if not Is_Non_Empty_List (Component_Items (Clist)) then
Error_Msg_N
("Unchecked_Union may not have empty component list",
@ -1957,6 +1961,24 @@ package body Sem_Prag is
procedure Set_Convention_From_Pragma (E : Entity_Id) is
begin
-- Check invalid attempt to change convention for an overridden
-- dispatching operation. This is Ada 2005 AI 430. Technically
-- this is an amendment and should only be done in Ada 2005 mode.
-- However, this is clearly a mistake, since the problem that is
-- addressed by this AI is that there is a clear gap in the RM!
if Is_Dispatching_Operation (E)
and then Present (Overridden_Operation (E))
and then C /= Convention (Overridden_Operation (E))
then
Error_Pragma_Arg
("cannot change convention for " &
"overridden dispatching operation",
Arg1);
end if;
-- Set the convention
Set_Convention (E, C);
Set_Has_Convention_Pragma (E);
@ -2862,7 +2884,7 @@ package body Sem_Prag is
else
Dval := Default_Value (Formal);
if not Present (Dval) then
if No (Dval) then
Error_Msg_NE
("optional formal& does not have default value!",
Arg_First_Optional_Parameter, Formal);
@ -4222,9 +4244,9 @@ package body Sem_Prag is
Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
-- Set the FIFO_Within_Priorities policy, but always
-- preserve System_Location since we like the error
-- message with the run time name.
-- Set the FIFO_Within_Priorities policy, but always preserve
-- System_Location since we like the error message with the run time
-- name.
else
Task_Dispatching_Policy := 'F';
@ -4242,9 +4264,8 @@ package body Sem_Prag is
Error_Msg_Sloc := Locking_Policy_Sloc;
Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
-- Set the Ceiling_Locking policy, but always preserve
-- System_Location since we like the error message with the
-- run time name.
-- Set the Ceiling_Locking policy, but preserve System_Location since
-- we like the error message with the run time name.
else
Locking_Policy := 'C';
@ -4268,7 +4289,7 @@ package body Sem_Prag is
begin
if not Is_Pragma_Name (Chars (N)) then
if Warn_On_Unrecognized_Pragma then
Error_Pragma ("unrecognized pragma%!?");
Error_Pragma ("unrecognized pragma%?");
else
return;
end if;
@ -4368,17 +4389,20 @@ package body Sem_Prag is
Ada_Version_Explicit := Ada_Version;
Check_Arg_Count (0);
------------
-- Ada_05 --
------------
---------------------
-- Ada_05/Ada_2005 --
---------------------
-- pragma Ada_05;
-- pragma Ada_05 (LOCAL_NAME);
-- Note: this pragma also has some specific processing in Par.Prag
-- pragma Ada_2005;
-- pragma Ada_2005 (LOCAL_NAME):
-- Note: these pragma also have some specific processing in Par.Prag
-- because we want to set the Ada 2005 version mode during parsing.
when Pragma_Ada_05 => declare
when Pragma_Ada_05 | Pragma_Ada_2005 => declare
E_Id : Node_Id;
begin
@ -4397,7 +4421,7 @@ package body Sem_Prag is
else
Check_Arg_Count (0);
Ada_Version := Ada_05;
Ada_Version_Explicit := Ada_Version;
Ada_Version_Explicit := Ada_05;
end if;
end;
@ -4618,7 +4642,7 @@ package body Sem_Prag is
procedure Process_Async_Pragma is
begin
if not Present (L) then
if No (L) then
Set_Is_Asynchronous (Nm);
return;
end if;
@ -5255,16 +5279,15 @@ package body Sem_Prag is
("only tagged records can contain vtable pointers", Arg1);
end if;
-- Case of tagged type with no vtable ptr
-- What is test for Typ = Root_Typ (Typ) about here ???
-- Case of tagged type with no user-defined vtable ptr. In this
-- case, because of our C++ ABI compatibility, the programmer
-- does not need to specify the tag component.
elsif Is_Tagged_Type (Typ)
and then Typ = Root_Type (Typ)
and then No (Default_DTC)
then
Error_Pragma_Arg
("a cpp_class must contain a vtable pointer", Arg1);
Set_Is_CPP_Class (Typ);
Set_Is_Limited_Record (Typ);
-- Tagged type that has a vtable ptr
@ -5438,6 +5461,8 @@ package body Sem_Prag is
Next_Component (DTC);
end loop;
-- Case of tagged type with no user-defined vtable ptr
if No (DTC) then
Error_Msg_NE ("must be a& component name", Arg, Typ);
raise Pragma_Exit;
@ -8101,48 +8126,57 @@ package body Sem_Prag is
-- No_Return --
---------------
-- pragma No_Return (procedure_LOCAL_NAME);
-- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
when Pragma_No_Return => No_Return : declare
Id : Node_Id;
E : Entity_Id;
Found : Boolean;
Arg : Node_Id;
begin
GNAT_Pragma;
Check_Arg_Count (1);
Check_No_Identifiers;
Check_Arg_Is_Local_Name (Arg1);
Id := Expression (Arg1);
Analyze (Id);
Check_At_Least_N_Arguments (1);
if not Is_Entity_Name (Id) then
Error_Pragma_Arg ("entity name required", Arg1);
end if;
-- Loop through arguments of pragma
if Etype (Id) = Any_Type then
raise Pragma_Exit;
end if;
Arg := Arg1;
while Present (Arg) loop
Check_Arg_Is_Local_Name (Arg);
Id := Expression (Arg);
Analyze (Id);
E := Entity (Id);
Found := False;
while Present (E)
and then Scope (E) = Current_Scope
loop
if Ekind (E) = E_Procedure
or else Ekind (E) = E_Generic_Procedure
then
Set_No_Return (E);
Found := True;
if not Is_Entity_Name (Id) then
Error_Pragma_Arg ("entity name required", Arg);
end if;
E := Homonym (E);
end loop;
if Etype (Id) = Any_Type then
raise Pragma_Exit;
end if;
if not Found then
Error_Pragma ("no procedures found for pragma%");
end if;
-- Loop to find matching procedures
E := Entity (Id);
Found := False;
while Present (E)
and then Scope (E) = Current_Scope
loop
if Ekind (E) = E_Procedure
or else Ekind (E) = E_Generic_Procedure
then
Set_No_Return (E);
Found := True;
end if;
E := Homonym (E);
end loop;
if not Found then
Error_Pragma_Arg ("no procedure & found for pragma%", Arg);
end if;
Next (Arg);
end loop;
end No_Return;
------------------------
@ -8181,7 +8215,7 @@ package body Sem_Prag is
-- Obsolescent --
-----------------
-- pragma Obsolescent [(static_string_EXPRESSION [, Ada_05])];
-- pragma Obsolescent [(static_string_EXPRESSION [, Ada_05])];
when Pragma_Obsolescent => Obsolescent : declare
Subp : Node_Or_Entity_Id;
@ -8789,6 +8823,8 @@ package body Sem_Prag is
-- pragma Propagate_Exceptions;
-- Note: this pragma is obsolete and has no effect
when Pragma_Propagate_Exceptions =>
GNAT_Pragma;
Check_Arg_Count (0);
@ -8956,6 +8992,7 @@ package body Sem_Prag is
Ent := Find_Lib_Unit_Name;
Set_Is_Pure (Ent);
Set_Has_Pragma_Pure (Ent);
Set_Suppress_Elaboration_Warnings (Ent);
end Pure;
@ -10146,18 +10183,14 @@ package body Sem_Prag is
Discr := First_Discriminant (Typ);
if Present (Next_Discriminant (Discr)) then
Error_Msg_N
("Unchecked_Union must have exactly one discriminant",
Next_Discriminant (Discr));
return;
end if;
if No (Discriminant_Default_Value (Discr)) then
Error_Msg_N
("Unchecked_Union discriminant must have default value",
Discr);
end if;
while Present (Discr) loop
if No (Discriminant_Default_Value (Discr)) then
Error_Msg_N
("Unchecked_Union discriminant must have default value",
Discr);
end if;
Next_Discriminant (Discr);
end loop;
Tdef := Type_Definition (Declaration_Node (Typ));
Clist := Component_List (Tdef);
@ -10686,6 +10719,7 @@ package body Sem_Prag is
Pragma_Ada_83 => -1,
Pragma_Ada_95 => -1,
Pragma_Ada_05 => -1,
Pragma_Ada_2005 => -1,
Pragma_All_Calls_Remote => -1,
Pragma_Annotate => -1,
Pragma_Assert => -1,