[Ada] Fix comptation of size of array
Arnaud Charlet
charlet@adacore.com
Wed Feb 15 10:20:00 GMT 2006
Tested on i686-linux, committed on trunk
This change fixes an incorrect computation of the size of an array that
needs to be as big as the scope stack depth. The incorrect computation
caused index checks to fail in some cases when the compiler was built
with checks enabled.
These changes bring the implementation of Unchecked_Union in conformance
with the text of AI-216.
This patch introduces pragma Ada_2005 as a synonym for the
existing pragma Ada_05. The following program must compile quietly:
pragma Ada_2005;
procedure K is
type R is not null access Integer;
begin
null;
end;
This patch allows multiple arguments for the No_Return pragma. This will
be required in Ada 2005 (AI 329), and there is no reason not to backport
this upwards compatible enhancement to Ada 95 mode (since this is a GNAT
pragma in Ada 95).
A test case is:
procedure K is
procedure A;
procedure B;
pragma No_Return (A, B);
procedure A is begin B; end;
procedure B is begin raise Constraint_Error; end;
begin
null;
end;
this should compile quietly
Finally, Ada 2005 AI-419 specifies that limitedness is not inherited from a
limited interface, so that a type that implements a limited interface
and has limited components must be declared explicitly limited, using
new syntax. The corresponding legality check was missing.
The package p.ads, compiled with -gnat05, must yield:
--
gcc -c -gnat05 p.ads
p.ads:8:06: extension of nonlimited type cannot have limited components
p.ads:8:06: limitedness is not inherited from limited interface
p.ads:8:06: add explicit limited to type indication
--
package P is
type Lim is limited interface;
type Rec is private;
type OK is limited private;
task type Tsk;
private
type Rec is new Lim with record
T : Tsk; -- Error
end record;
--
type Ok is limited new Lim with record
T : Tsk;
end record;
end;
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.
-------------- next part --------------
Index: sem_ch12.adb
===================================================================
--- sem_ch12.adb (revision 110833)
+++ sem_ch12.adb (working copy)
@@ -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 @@
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 @@
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 @@
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 @@
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 @@
-- 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 @@
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);
- end if;
+ begin
+ -- Retrieve the actual given in the formal package declaration
- Act_Pkg := Act_Ent;
+ Actual := Entity (Name (Original_Node (Formal_Node)));
- -- 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.
+ -- 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.
- while Ekind (Act_Pkg) /= E_Package loop
- Act_Pkg := Next_Entity (Act_Pkg);
- end loop;
+ if Present (Renamed_Entity (Actual)) then
+ Gen_Decl := Unit_Declaration_Node (Renamed_Entity (Actual));
+ else
+ Gen_Decl := Unit_Declaration_Node (Actual);
+ end if;
- declare
- Actual_Ent : Entity_Id := First_Entity (Act_Pkg);
- Formal_Node : Node_Id;
- Formal_Ent : Entity_Id;
+ Formals := Generic_Formal_Declarations (Gen_Decl);
- Gen_Decl : Node_Id;
- Formals : List_Id;
+ if Present (Formals) then
+ F_Node := First_Non_Pragma (Formals);
+ else
+ F_Node := Empty;
+ end if;
- 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.
+ 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 (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;
+ if Present (F_Ent) then
- Formals := Generic_Formal_Declarations (Gen_Decl);
+ -- This is a formal of the original package. Record
+ -- association and recurse.
- if Present (Formals) then
- Formal_Node := First_Non_Pragma (Formals);
- else
- Formal_Node := Empty;
+ Find_Matching_Actual (F_Node, A_Ent);
+ Match_Formal_Entity (F_Node, F_Ent, A_Ent);
+ Next_Entity (A_Ent);
end if;
- 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));
+ Next_Non_Pragma (F_Node);
+ end loop;
+ end;
+ end if;
+ end Match_Formal_Entity;
- 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);
+ -----------------------
+ -- Get_Formal_Entity --
+ -----------------------
- Next_Entity (Actual_Ent);
- end loop;
- end;
+ 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);
- return Defining_Identifier (Orig_Node);
+ when N_Formal_Type_Declaration =>
+ return Defining_Identifier (N);
- when N_Use_Package_Clause =>
- return Empty;
+ when N_Formal_Subprogram_Declaration =>
+ return Defining_Unit_Name (Specification (N));
- when N_Use_Type_Clause =>
- return Empty;
+ when N_Formal_Package_Declaration =>
+ return Defining_Identifier (Original_Node (N));
- -- 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 N_Generic_Package_Declaration =>
+ return Defining_Identifier (Original_Node (N));
- when others =>
+ -- All other declarations are introduced by semantic analysis
+ -- and have no match in the actual.
+
+ when others =>
return Empty;
-
end case;
- end Formal_Entity;
+ end Get_Formal_Entity;
--------------------
-- Is_Instance_Of --
@@ -6987,11 +6992,12 @@
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 @@
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 @@
(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);
Index: sem_prag.adb
===================================================================
--- sem_prag.adb (revision 110833)
+++ sem_prag.adb (working copy)
@@ -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 @@
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 @@
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 @@
" 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 @@
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 @@
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 @@
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 @@
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 @@
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 @@
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 @@
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 @@
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 @@
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 @@
("only tagged records can contain vtable pointers", Arg1);
end if;
- -- Case of tagged type with no vtable ptr
+ -- 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.
- -- What is test for Typ = Root_Typ (Typ) about here ???
-
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 @@
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 @@
-- 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);
+ if not Is_Entity_Name (Id) then
+ Error_Pragma_Arg ("entity name required", Arg);
+ end if;
- 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 Etype (Id) = Any_Type then
+ raise Pragma_Exit;
end if;
- E := Homonym (E);
+ -- 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;
-
- if not Found then
- Error_Pragma ("no procedures found for pragma%");
- end if;
end No_Return;
------------------------
@@ -8181,7 +8215,7 @@
-- 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 @@
-- 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 @@
Ent := Find_Lib_Unit_Name;
Set_Is_Pure (Ent);
+ Set_Has_Pragma_Pure (Ent);
Set_Suppress_Elaboration_Warnings (Ent);
end Pure;
@@ -10146,19 +10183,15 @@
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;
+ 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;
- if No (Discriminant_Default_Value (Discr)) then
- Error_Msg_N
- ("Unchecked_Union discriminant must have default value",
- Discr);
- end if;
-
Tdef := Type_Definition (Declaration_Node (Typ));
Clist := Component_List (Tdef);
@@ -10686,6 +10719,7 @@
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,
Index: sem_ch3.ads
===================================================================
--- sem_ch3.ads (revision 110833)
+++ sem_ch3.ads (working copy)
@@ -157,6 +157,11 @@
-- 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
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 110833)
+++ sem_ch3.adb (working copy)
@@ -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 @@
(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 @@
(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 @@
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 @@
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 @@
-------------
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 @@
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 @@
-- 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 @@
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 @@
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 @@
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 @@
-- 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 @@
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 @@
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 @@
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 @@
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 @@
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 @@
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 @@
-------------------------------
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 @@
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 @@
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 @@
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 @@
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 @@
-- 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 @@
-- 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 @@
(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 @@
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 @@
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 @@
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 @@
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 @@
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 @@
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 @@
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 @@
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 @@
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 @@
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 @@
-- 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 @@
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 @@
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 @@
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 @@
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)
More information about the Gcc-patches
mailing list