aboutsummaryrefslogtreecommitdiff
path: root/gcc/ada
diff options
context:
space:
mode:
authorEd Schonberg <schonberg@adacore.com>2007-08-14 10:38:20 +0200
committerArnaud Charlet <charlet@gcc.gnu.org>2007-08-14 10:38:20 +0200
commit5d37ba92f667fc076287b111dd3166b8d48012b8 (patch)
tree4d387c15f40b2718d420ab1768d7ccccf1af12ce /gcc/ada
parentb99282c4c10fcb8fb8a5cf30736e5b8a1a4e3cec (diff)
downloadgcc-5d37ba92f667fc076287b111dd3166b8d48012b8.zip
gcc-5d37ba92f667fc076287b111dd3166b8d48012b8.tar.gz
gcc-5d37ba92f667fc076287b111dd3166b8d48012b8.tar.bz2
einfo.ads, einfo.adb: Create a limited view of an incomplete type...
2007-08-14 Ed Schonberg <schonberg@adacore.com> Robert Dewar <dewar@adacore.com> Javier Miranda <miranda@adacore.com> Gary Dismukes <dismukes@adacore.com> * einfo.ads, einfo.adb: Create a limited view of an incomplete type, to make treatment of limited views uniform for all visible declarations in a limited_withed package. Improve warnings for in out parameters (Set_Related_Interaface/Related_Interface): Allow the use of this attribute with constants. (Write_Field26_Name): Handle attribute Related_Interface in constants. Warn on duplicate pragma Preelaborable_Initialialization * sem_ch6.ads, sem_ch6.adb (Analyze_Subprogram_Body): Force the generation of a freezing node to ensure proper management of null excluding access types in the backend. (Create_Extra_Formals): Test base type of the formal when checking for the need to add an extra accessibility-level formal. Pass the entity E on all calls to Add_Extra_Formal (rather than Scope (Formal) as was originally being done in a couple of cases), to ensure that the Extra_Formals list gets set on the entity E when the first entity is added. (Conforming_Types): Add missing calls to Base_Type to the code that handles anonymous access types. This is required to handle the general case because Process_Formals builds internal subtype entities to handle null-excluding access types. (Make_Controlling_Function_Wrappers): Create wrappers for constructor functions that need it, even when not marked Requires_Overriding. Improve warnings for in out parameters (Analyze_Function_Return): Warn for disallowed null return Warn on return from procedure with unset out parameter Ensure consistent use of # in error messages (Check_Overriding_Indicator): Add in parameter Is_Primitive. (Analyze_Function_Return): Move call to Apply_Constraint_Check before the implicit conversion of the expression done for anonymous access types. This is required to generate the code of the null excluding check (if required). * sem_warn.ads, sem_warn.adb (Check_References.Publicly_Referenceable): A formal parameter is never publicly referenceable outside of its body. (Check_References): For an unreferenced formal parameter in an accept statement, use the same warning circuitry as for subprogram formal parameters. (Warn_On_Unreferenced_Entity): New subprogram, taken from Output_Unreferenced_Messages, containing the part of that routine that is now reused for entry formals as described above. (Goto_Spec_Entity): New function (Check_References): Do not give IN OUT warning for dispatching operation Improve warnings for in out parameters (Test_Ref): Check that the entity is not undefinite before calling Scope_Within, in order to avoid infinite loops. Warn on return from procedure with unset out parameter Improved warnings for unused variables From-SVN: r127415
Diffstat (limited to 'gcc/ada')
-rw-r--r--gcc/ada/einfo.adb133
-rw-r--r--gcc/ada/einfo.ads132
-rw-r--r--gcc/ada/sem_ch6.adb967
-rw-r--r--gcc/ada/sem_ch6.ads4
4 files changed, 740 insertions, 496 deletions
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index 011a7ea..035cca1 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -474,15 +474,12 @@ package body Einfo is
-- Has_Up_Level_Access Flag215
-- Universal_Aliasing Flag216
-- Suppress_Value_Tracking_On_Call Flag217
+ -- Is_Primitive Flag218
+ -- Has_Initial_Value Flag219
+ -- Has_Dispatch_Table Flag220
- -- (unused) Flag77
-
- -- (unused) Flag218
- -- (unused) Flag219
- -- (unused) Flag220
-
- -- (unused) Flag221
- -- (unused) Flag222
+ -- Has_Pragma_Preelab_Init Flag221
+ -- Used_As_Generic_Actual Flag222
-- (unused) Flag223
-- (unused) Flag224
-- (unused) Flag225
@@ -1194,6 +1191,12 @@ package body Einfo is
return Flag5 (Id);
end Has_Discriminants;
+ function Has_Dispatch_Table (Id : E) return B is
+ begin
+ pragma Assert (Is_Tagged_Type (Id));
+ return Flag220 (Id);
+ end Has_Dispatch_Table;
+
function Has_Enumeration_Rep_Clause (Id : E) return B is
begin
pragma Assert (Is_Enumeration_Type (Id));
@@ -1231,6 +1234,13 @@ package body Einfo is
return Flag56 (Id);
end Has_Homonym;
+ function Has_Initial_Value (Id : E) return B is
+ begin
+ pragma Assert
+ (Ekind (Id) = E_Variable or else Is_Formal (Id));
+ return Flag219 (Id);
+ end Has_Initial_Value;
+
function Has_Machine_Radix_Clause (Id : E) return B is
begin
pragma Assert (Is_Decimal_Fixed_Point_Type (Id));
@@ -1297,6 +1307,11 @@ package body Einfo is
return Flag121 (Implementation_Base_Type (Id));
end Has_Pragma_Pack;
+ function Has_Pragma_Preelab_Init (Id : E) return B is
+ begin
+ return Flag221 (Id);
+ end Has_Pragma_Preelab_Init;
+
function Has_Pragma_Pure (Id : E) return B is
begin
return Flag203 (Id);
@@ -1830,6 +1845,15 @@ package body Einfo is
return Flag59 (Id);
end Is_Preelaborated;
+ function Is_Primitive (Id : E) return B is
+ begin
+ pragma Assert
+ (Is_Overloadable (Id)
+ or else Ekind (Id) = E_Generic_Function
+ or else Ekind (Id) = E_Generic_Procedure);
+ return Flag218 (Id);
+ end Is_Primitive;
+
function Is_Primitive_Wrapper (Id : E) return B is
begin
pragma Assert (Ekind (Id) = E_Procedure);
@@ -2297,7 +2321,8 @@ package body Einfo is
function Related_Interface (Id : E) return E is
begin
- pragma Assert (Ekind (Id) = E_Component);
+ pragma Assert
+ (Ekind (Id) = E_Component or else Ekind (Id) = E_Constant);
return Node26 (Id);
end Related_Interface;
@@ -2506,6 +2531,11 @@ package body Einfo is
return Node16 (Id);
end Unset_Reference;
+ function Used_As_Generic_Actual (Id : E) return B is
+ begin
+ return Flag222 (Id);
+ end Used_As_Generic_Actual;
+
function Uses_Sec_Stack (Id : E) return B is
begin
return Flag95 (Id);
@@ -3428,6 +3458,13 @@ package body Einfo is
Set_Flag5 (Id, V);
end Set_Has_Discriminants;
+ procedure Set_Has_Dispatch_Table (Id : E; V : B := True) is
+ begin
+ pragma Assert (Ekind (Id) = E_Record_Type
+ and then Is_Tagged_Type (Id));
+ Set_Flag220 (Id, V);
+ end Set_Has_Dispatch_Table;
+
procedure Set_Has_Enumeration_Rep_Clause (Id : E; V : B := True) is
begin
pragma Assert (Is_Enumeration_Type (Id));
@@ -3465,6 +3502,13 @@ package body Einfo is
Set_Flag56 (Id, V);
end Set_Has_Homonym;
+ procedure Set_Has_Initial_Value (Id : E; V : B := True) is
+ begin
+ pragma Assert
+ (Ekind (Id) = E_Variable or else Ekind (Id) = E_Out_Parameter);
+ Set_Flag219 (Id, V);
+ end Set_Has_Initial_Value;
+
procedure Set_Has_Machine_Radix_Clause (Id : E; V : B := True) is
begin
pragma Assert (Is_Decimal_Fixed_Point_Type (Id));
@@ -3542,6 +3586,11 @@ package body Einfo is
Set_Flag121 (Id, V);
end Set_Has_Pragma_Pack;
+ procedure Set_Has_Pragma_Preelab_Init (Id : E; V : B := True) is
+ begin
+ Set_Flag221 (Id, V);
+ end Set_Has_Pragma_Preelab_Init;
+
procedure Set_Has_Pragma_Pure (Id : E; V : B := True) is
begin
Set_Flag203 (Id, V);
@@ -4097,6 +4146,15 @@ package body Einfo is
Set_Flag59 (Id, V);
end Set_Is_Preelaborated;
+ procedure Set_Is_Primitive (Id : E; V : B := True) is
+ begin
+ pragma Assert
+ (Is_Overloadable (Id)
+ or else Ekind (Id) = E_Generic_Function
+ or else Ekind (Id) = E_Generic_Procedure);
+ Set_Flag218 (Id, V);
+ end Set_Is_Primitive;
+
procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Procedure);
@@ -4574,7 +4632,8 @@ package body Einfo is
procedure Set_Related_Interface (Id : E; V : E) is
begin
- pragma Assert (Ekind (Id) = E_Component);
+ pragma Assert
+ (Ekind (Id) = E_Component or else Ekind (Id) = E_Constant);
Set_Node26 (Id, V);
end Set_Related_Interface;
@@ -4793,6 +4852,11 @@ package body Einfo is
Set_Flag95 (Id, V);
end Set_Uses_Sec_Stack;
+ procedure Set_Used_As_Generic_Actual (Id : E; V : B := True) is
+ begin
+ Set_Flag222 (Id, V);
+ end Set_Used_As_Generic_Actual;
+
procedure Set_Vax_Float (Id : E; V : B := True) is
begin
pragma Assert (Id = Base_Type (Id));
@@ -4918,7 +4982,7 @@ package body Einfo is
begin
Set_Uint8 (Id, No_Uint); -- Normalized_First_Bit
Set_Uint10 (Id, No_Uint); -- Normalized_Position_Max
- Set_Uint11 (Id, No_Uint); -- Component_First_Bit
+ Set_Uint11 (Id, No_Uint); -- Component_Bit_Offset
Set_Uint12 (Id, Uint_0); -- Esize
Set_Uint14 (Id, No_Uint); -- Normalized_Position
end Init_Component_Location;
@@ -5161,7 +5225,10 @@ package body Einfo is
if Is_Incomplete_Type (Id)
and then Present (Non_Limited_View (Id))
then
- return Non_Limited_View (Id);
+ -- The non-limited view may itself be an incomplete type, in
+ -- which case get its full view.
+
+ return Get_Full_View (Non_Limited_View (Id));
elsif Is_Class_Wide_Type (Id)
and then Is_Incomplete_Type (Etype (Id))
@@ -5327,7 +5394,6 @@ package body Einfo is
P := Parent (P);
end if;
end loop;
-
end Declaration_Node;
---------------------
@@ -5681,6 +5747,28 @@ package body Einfo is
return Empty;
end Get_Attribute_Definition_Clause;
+ -------------------
+ -- Get_Full_View --
+ -------------------
+
+ function Get_Full_View (T : Entity_Id) return Entity_Id is
+ begin
+ if Ekind (T) = E_Incomplete_Type
+ and then Present (Full_View (T))
+ then
+ return Full_View (T);
+
+ elsif Is_Class_Wide_Type (T)
+ and then Ekind (Root_Type (T)) = E_Incomplete_Type
+ and then Present (Full_View (Root_Type (T)))
+ then
+ return Class_Wide_Type (Full_View (Root_Type (T)));
+
+ else
+ return T;
+ end if;
+ end Get_Full_View;
+
--------------------
-- Get_Rep_Pragma --
--------------------
@@ -6565,6 +6653,11 @@ package body Einfo is
elsif Ekind (T) = E_Class_Wide_Subtype then
return Etype (Base_Type (T));
+ -- ??? T comes from Base_Type, how can it be a subtype?
+ -- Also Base_Type is supposed to be idempotent, so either way
+ -- this is equivalent to "return Etype (T)" and should be merged
+ -- with the E_Class_Wide_Type case.
+
-- All other cases
else
@@ -7007,6 +7100,7 @@ package body Einfo is
W ("Has_Fully_Qualified_Name", Flag173 (Id));
W ("Has_Gigi_Rep_Item", Flag82 (Id));
W ("Has_Homonym", Flag56 (Id));
+ W ("Has_Initial_Value", Flag219 (Id));
W ("Has_Machine_Radix_Clause", Flag83 (Id));
W ("Has_Master_Entity", Flag21 (Id));
W ("Has_Missing_Return", Flag142 (Id));
@@ -7019,6 +7113,7 @@ package body Einfo is
W ("Has_Pragma_Elaborate_Body", Flag150 (Id));
W ("Has_Pragma_Inline", Flag157 (Id));
W ("Has_Pragma_Pack", Flag121 (Id));
+ W ("Has_Pragma_Preelab_Init", Flag221 (Id));
W ("Has_Pragma_Pure", Flag203 (Id));
W ("Has_Pragma_Pure_Function", Flag179 (Id));
W ("Has_Pragma_Unreferenced", Flag180 (Id));
@@ -7172,8 +7267,10 @@ package body Einfo is
W ("Suppress_Init_Proc", Flag105 (Id));
W ("Suppress_Style_Checks", Flag165 (Id));
W ("Suppress_Value_Tracking_On_Call", Flag217 (Id));
+ W ("Is_Primitive", Flag218 (Id));
W ("Treat_As_Volatile", Flag41 (Id));
W ("Universal_Aliasing", Flag216 (Id));
+ W ("Used_As_Generic_Actual", Flag222 (Id));
W ("Uses_Sec_Stack", Flag95 (Id));
W ("Vax_Float", Flag151 (Id));
W ("Warnings_Off", Flag96 (Id));
@@ -7741,9 +7838,9 @@ package body Einfo is
end case;
end Write_Field17_Name;
- -----------------------
+ ------------------------
-- Write_Field18_Name --
- -----------------------
+ ------------------------
procedure Write_Field18_Name (Id : Entity_Id) is
begin
@@ -7770,8 +7867,7 @@ package body Einfo is
when Fixed_Point_Kind =>
Write_Str ("Delta_Value");
- when E_Constant |
- E_Variable =>
+ when Object_Kind =>
Write_Str ("Renamed_Object");
when E_Exception |
@@ -8114,7 +8210,8 @@ package body Einfo is
procedure Write_Field26_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when E_Component =>
+ when E_Component |
+ E_Constant =>
Write_Str ("Related_Interface");
when E_Generic_Package |
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 9d4c2e0a..234caab 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -193,7 +193,7 @@ package Einfo is
-- Object_Size of this first-named subtype to the given value padded up
-- to an appropriate boundary. It is a consequence of the default rules
-- above that this Object_Size will apply to all further subtypes. On the
--- otyher hand, Value_Size is affected only for the first subtype, any
+-- other hand, Value_Size is affected only for the first subtype, any
-- dynamic subtypes obtained from it directly, and any statically matching
-- subtypes. The Value_Size of any other static subtypes is not affected.
@@ -245,6 +245,10 @@ package Einfo is
-- and Value_Size are the same (and equivalent to the RM attribute Size).
-- Only Size may be specified for such types.
+-- All size attributes are stored as Uint values. Negative values are used to
+-- reference GCC expressions for the case of non-static sizes, as explained
+-- in Repinfo.
+
-----------------------
-- Entity Attributes --
-----------------------
@@ -347,7 +351,8 @@ package Einfo is
-- Present in all entities. Set if the Address or Unrestricted_Access
-- attribute is applied directly to the entity, i.e. the entity is the
-- entity of the prefix of the attribute reference. Used by Gigi to
--- make sure that the address can be meaningfully taken.
+-- make sure that the address can be meaningfully taken, and also in
+-- the case of subprograms to control output of certain warnings.
-- Alias (Node18)
-- Present in overloaded entities (literals, subprograms, entries) and
@@ -1388,6 +1393,14 @@ package Einfo is
-- and incomplete types), indicates if the corresponding type or subtype
-- has a known discriminant part. Always false for all other types.
+-- Has_Dispatch_Table (Flag220)
+-- Present in E_Record_Types that are tagged. Set to indicate that the
+-- corresponding dispatch table is already built. This flag is used to
+-- avoid duplicate construction of library level dispatch tables (because
+-- the declaration of library level objects cause premature construction
+-- of the table); otherwise the code that builds the table is added at
+-- the end of the list of declarations of the package.
+
-- Has_Entries (synthesized)
-- Applies to concurrent types. True if any entries are declared
-- within the task or protected definition for the type.
@@ -1446,7 +1459,16 @@ package Einfo is
-- Has_Homonym (Flag56)
-- Present in all entities. Set if an entity has a homonym in the same
-- scope. Used by Gigi to generate unique names for such entities.
-
+--
+-- Has_Initial_Value (Flag219)
+-- Present in entities for variables and out parameters. Set if there
+-- is an explicit initial value expression in the declaration of the
+-- variable. Note that this is set only if this initial value is
+-- explicit, it is not set for the case of implicit initialization
+-- of access types or controlled types. Always set to False for out
+-- parameters. Also present in entities for in and in-out parameters,
+-- but always false in these cases.
+--
-- Has_Interrupt_Handler (synthesized)
-- Applies to all protected type entities. Set if the protected type
-- definition contains at least one procedure to which a pragma
@@ -1546,6 +1568,10 @@ package Einfo is
-- was given for the entity. In some cases, we need to test whether
-- Is_Pure was explicitly set using this pragma.
+-- Has_Pragma_Preelab_Init (Flag221)
+-- Present in type and subtype entities. If set indicates that a valid
+-- pragma Preelaborable_Initialization applies to the type.
+
-- Has_Pragma_Pure_Function (Flag179)
-- Present in all entities. If set, indicates that a valid pragma
-- Pure_Function was given for the entity. In some cases, we need to
@@ -2144,9 +2170,12 @@ package Einfo is
-- Is_Internal (Flag17)
-- Present in all entities. Set to indicate an entity created during
-- semantic processing (e.g. an implicit type, or a temporary). The
--- only current use of this flag is to indicate that temporaries
+-- current uses of this flag are: 1) to indicate that temporaries
-- generated for the result of an inlined function call need not be
--- initialized, even when scalars are initialized or normalized.
+-- initialized, even when scalars are initialized or normalized, and
+-- 2) to indicate object declarations generated by the expander that are
+-- implicitly imported or exported, so that they can be appropriately
+-- marked in Sprint output.
-- Is_Interrupt_Handler (Flag89)
-- Present in procedures. Set if a pragma Interrupt_Handler applies
@@ -2388,6 +2417,12 @@ package Einfo is
-- flag is set does not necesarily mean that no elaboration code is
-- generated for the package.
+-- Is_Primitive (Flag218)
+-- Present in overloadable entities and in generic subprograms. Set to
+-- indicate that this is a primitive operation of some type, which may be
+-- a tagged type or a non-tagged type. Used to verify overriding
+-- indicators in bodies.
+
-- Is_Primitive_Wrapper (Flag195)
-- Present in E_Procedures. Primitive wrappers are Expander-generated
-- procedures that wrap entries of protected or task types implementing
@@ -2757,13 +2792,15 @@ package Einfo is
-- entities when the return type is an array type, and a call can be
-- interpreted as an indexing of the result of the call. It is also
-- used to resolve various cases of entry calls.
-
+--
-- Never_Set_In_Source (Flag115)
-- Present in all entities, but relevant only for variables and
--- parameters. This flag is set if the object is never assigned
--- a value in user source code, either by assignment or by the
--- use of an initial value, or by some other means.
-
+-- parameters. This flag is set if the object is never assigned a value
+-- in user source code, either by assignment or by being used as an out
+-- or in out parameter. Note that this flag is not reset from using an
+-- initial value, so if you want to test for this case as well, test the
+-- Has_Initial_Value flag also.
+--
-- This flag is only for the purposes of issuing warnings, it must not
-- be used by the code generator to indicate that the variable is in
-- fact a constant, since some assignments in generated code do not
@@ -3095,15 +3132,15 @@ package Einfo is
-- Referenced (Flag156)
-- Present in all entities, set if the entity is referenced, except
--- for the case of an appearence of a simple variable that is not a
+-- for the case of an appearence of a simple variable, that is not a
-- renaming, as the left side of an assignment in which case the flag
-- Referenced_As_LHS is set instead.
--- Referenced_As_LHS (Flag36): This flag is set instead of
--- Referenced if a simple variable that is not a renaming appears as
--- the left side of an assignment. The reason we distinguish this kind
--- of reference is that we have a separate warning for variables that
--- are only assigned and never read.
+-- Referenced_As_LHS (Flag36):
+-- This flag is set instead of Referenced if a simple variable that is
+-- not a renaming appears as the left side of an assignment. The reason
+-- we distinguish this kind of reference is that we have a separate
+-- warning for variables that are only assigned and never read.
-- Referenced_Object (Node10)
-- Present in all type entities. Set non-Empty only for type entities
@@ -3132,9 +3169,8 @@ package Einfo is
-- must correspond to the name and scope of the related instance.
-- Related_Interface (Node26)
--- Present in components associated with secondary dispatch tables
--- (dispatch table pointers and offset components). Set to point to the
--- entity of the corresponding interface type.
+-- Present in components and constants associated with dispatch tables.
+-- Set to point to the entity of the associated interface type.
-- Renamed_Entity (Node18)
-- Present in exceptions, packages, subprograms and generic units. Set
@@ -3144,15 +3180,16 @@ package Einfo is
-- Renamed_Object (Node18)
-- Present in all objects (constants, variables, components, formal
--- parameters, generic formal parameters, and loop parameters). Set
--- non-Empty if the object was declared by a renaming declaration, in
--- which case it references the tree node for the name of the renamed
+-- parameters, generic formal parameters, and loop parameters).
+-- ??? Present in discriminants?
+-- Set non-Empty if the object was declared by a renaming declaration,
+-- in which case it references the tree node for the name of the renamed
-- object. This is only possible for the variable and constant cases.
-- For formal parameters, this field is used in the course of inline
-- expansion, to map the formals of a subprogram into the corresponding
-- actuals. For formals of a task entry, it denotes the local renaming
--- that replaces the actual within the accept statement.
--- The field is Empty otherwise.
+-- that replaces the actual within the accept statement. The field is
+-- Empty otherwise (it is always empty for loop parameters).
-- Renaming_Map (Uint9)
-- Present in generic subprograms, generic packages, and their
@@ -3474,6 +3511,10 @@ package Einfo is
-- is identified. This field is used to generate a warning message if
-- necessary (see Sem_Warn.Check_Unset_Reference).
+-- Used_As_Generic_Actual (Flag222)
+-- Present in all entities, set if the entity is used as an argument to
+-- a generic instantiation. Used to tune certain warning messages.
+
-- Uses_Sec_Stack (Flag95)
-- Present in scope entities (blocks,functions, procedures, tasks,
-- entries). Set to True when secondary stack is used in this scope and
@@ -4085,7 +4126,7 @@ package Einfo is
subtype Formal_Kind is Entity_Kind range
E_In_Parameter ..
-- E_Out_Parameter
- E_In_Out_Parameter;
+ E_In_Out_Parameter;
subtype Formal_Object_Kind is Entity_Kind range
E_Generic_In_Out_Parameter ..
@@ -4364,6 +4405,7 @@ package Einfo is
-- Suppress_Elaboration_Warnings (Flag148)
-- Suppress_Style_Checks (Flag165)
-- Suppress_Value_Tracking_On_Call (Flag217)
+ -- Used_As_Generic_Actual (Flag222)
-- Was_Hidden (Flag196)
-- Declaration_Node (synth)
@@ -4400,6 +4442,7 @@ package Einfo is
-- Has_Discriminants (Flag5)
-- Has_Non_Standard_Rep (Flag75) (base type only)
-- Has_Object_Size_Clause (Flag172)
+ -- Has_Pragma_Preelab_Init (Flag221)
-- Has_Pragma_Unreferenced_Objects (Flag212)
-- Has_Primitive_Operations (Flag120) (base type only)
-- Has_Size_Clause (Flag29)
@@ -4587,8 +4630,8 @@ package Einfo is
-- Actual_Subtype (Node17)
-- Renamed_Object (Node18)
-- Size_Check_Code (Node19) (constants only)
- -- In_Private_Part (Flag45)
-- Interface_Name (Node21)
+ -- Related_Interface (Node26) (constants only)
-- Has_Alignment_Clause (Flag46)
-- Has_Atomic_Components (Flag86)
-- Has_Biased_Representation (Flag139)
@@ -4596,6 +4639,7 @@ package Einfo is
-- Has_Size_Clause (Flag29)
-- Has_Up_Level_Access (Flag215)
-- Has_Volatile_Components (Flag87)
+ -- In_Private_Part (Flag45)
-- Is_Atomic (Flag85)
-- Is_Eliminated (Flag124)
-- Is_True_Constant (Flag163)
@@ -4763,6 +4807,7 @@ package Einfo is
-- Is_Intrinsic_Subprogram (Flag64)
-- Is_Machine_Code_Subprogram (Flag137) (non-generic case only)
-- Is_Overriding_Operation (Flag39) (non-generic case only)
+ -- Is_Primitive (Flag218)
-- Is_Private_Descendant (Flag53)
-- Is_Pure (Flag44)
-- Is_Visible_Child_Unit (Flag116)
@@ -4828,6 +4873,7 @@ package Einfo is
-- Default_Expr_Function (Node21)
-- Protected_Formal (Node22)
-- Extra_Constrained (Node23)
+ -- Has_Initial_Value (Flag219)
-- Is_Controlling_Formal (Flag97)
-- Is_Entry_Formal (Flag52)
-- Is_Optional_Parameter (Flag134)
@@ -4884,6 +4930,7 @@ package Einfo is
-- Is_Pure (Flag44)
-- Is_Intrinsic_Subprogram (Flag64)
-- Is_Overriding_Operation (Flag39)
+ -- Is_Primitive (Flag218)
-- Default_Expressions_Processed (Flag108)
-- E_Ordinary_Fixed_Point_Type
@@ -5018,6 +5065,7 @@ package Einfo is
-- Is_Machine_Code_Subprogram (Flag137) (non-generic case only)
-- Is_Null_Init_Proc (Flag178)
-- Is_Overriding_Operation (Flag39) (non-generic case only)
+ -- Is_Primitive (Flag218)
-- Is_Primitive_Wrapper (Flag195) (non-generic case only)
-- Is_Private_Descendant (Flag53)
-- Is_Pure (Flag44)
@@ -5073,6 +5121,7 @@ package Einfo is
-- Abstract_Interfaces (Elist25)
-- Component_Alignment (special) (base type only)
-- C_Pass_By_Copy (Flag125) (base type only)
+ -- Has_Dispatch_Table (Flag220) (base tagged type only)
-- Has_External_Tag_Rep_Clause (Flag110)
-- Has_Record_Rep_Clause (Flag65) (base type only)
-- Has_Static_Discriminants (Flag211) (subtype only)
@@ -5204,6 +5253,7 @@ package Einfo is
-- Has_Alignment_Clause (Flag46)
-- Has_Atomic_Components (Flag86)
-- Has_Biased_Representation (Flag139)
+ -- Has_Initial_Value (Flag219)
-- Has_Size_Clause (Flag29)
-- Has_Volatile_Components (Flag87)
-- In_Private_Part (Flag45)
@@ -5562,12 +5612,14 @@ package Einfo is
function Has_Convention_Pragma (Id : E) return B;
function Has_Delayed_Freeze (Id : E) return B;
function Has_Discriminants (Id : E) return B;
+ function Has_Dispatch_Table (Id : E) return B;
function Has_Enumeration_Rep_Clause (Id : E) return B;
function Has_Exit (Id : E) return B;
function Has_External_Tag_Rep_Clause (Id : E) return B;
function Has_Fully_Qualified_Name (Id : E) return B;
function Has_Gigi_Rep_Item (Id : E) return B;
function Has_Homonym (Id : E) return B;
+ function Has_Initial_Value (Id : E) return B;
function Has_Interrupt_Handler (Id : E) return B;
function Has_Machine_Radix_Clause (Id : E) return B;
function Has_Master_Entity (Id : E) return B;
@@ -5583,6 +5635,7 @@ package Einfo is
function Has_Pragma_Elaborate_Body (Id : E) return B;
function Has_Pragma_Inline (Id : E) return B;
function Has_Pragma_Pack (Id : E) return B;
+ function Has_Pragma_Preelab_Init (Id : E) return B;
function Has_Pragma_Pure (Id : E) return B;
function Has_Pragma_Pure_Function (Id : E) return B;
function Has_Pragma_Unreferenced (Id : E) return B;
@@ -5673,6 +5726,7 @@ package Einfo is
function Is_Packed_Array_Type (Id : E) return B;
function Is_Potentially_Use_Visible (Id : E) return B;
function Is_Preelaborated (Id : E) return B;
+ function Is_Primitive (Id : E) return B;
function Is_Primitive_Wrapper (Id : E) return B;
function Is_Private_Composite (Id : E) return B;
function Is_Private_Descendant (Id : E) return B;
@@ -5790,6 +5844,7 @@ package Einfo is
function Underlying_Full_View (Id : E) return E;
function Universal_Aliasing (Id : E) return B;
function Unset_Reference (Id : E) return N;
+ function Used_As_Generic_Actual (Id : E) return B;
function Uses_Sec_Stack (Id : E) return B;
function Vax_Float (Id : E) return B;
function Warnings_Off (Id : E) return B;
@@ -6088,12 +6143,14 @@ package Einfo is
procedure Set_Has_Convention_Pragma (Id : E; V : B := True);
procedure Set_Has_Delayed_Freeze (Id : E; V : B := True);
procedure Set_Has_Discriminants (Id : E; V : B := True);
+ procedure Set_Has_Dispatch_Table (Id : E; V : B := True);
procedure Set_Has_Enumeration_Rep_Clause (Id : E; V : B := True);
procedure Set_Has_Exit (Id : E; V : B := True);
procedure Set_Has_External_Tag_Rep_Clause (Id : E; V : B := True);
procedure Set_Has_Fully_Qualified_Name (Id : E; V : B := True);
procedure Set_Has_Gigi_Rep_Item (Id : E; V : B := True);
procedure Set_Has_Homonym (Id : E; V : B := True);
+ procedure Set_Has_Initial_Value (Id : E; V : B := True);
procedure Set_Has_Machine_Radix_Clause (Id : E; V : B := True);
procedure Set_Has_Master_Entity (Id : E; V : B := True);
procedure Set_Has_Missing_Return (Id : E; V : B := True);
@@ -6108,6 +6165,7 @@ package Einfo is
procedure Set_Has_Pragma_Elaborate_Body (Id : E; V : B := True);
procedure Set_Has_Pragma_Inline (Id : E; V : B := True);
procedure Set_Has_Pragma_Pack (Id : E; V : B := True);
+ procedure Set_Has_Pragma_Preelab_Init (Id : E; V : B := True);
procedure Set_Has_Pragma_Pure (Id : E; V : B := True);
procedure Set_Has_Pragma_Pure_Function (Id : E; V : B := True);
procedure Set_Has_Pragma_Unreferenced (Id : E; V : B := True);
@@ -6205,6 +6263,7 @@ package Einfo is
procedure Set_Is_Packed_Array_Type (Id : E; V : B := True);
procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True);
procedure Set_Is_Preelaborated (Id : E; V : B := True);
+ procedure Set_Is_Primitive (Id : E; V : B := True);
procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True);
procedure Set_Is_Private_Composite (Id : E; V : B := True);
procedure Set_Is_Private_Descendant (Id : E; V : B := True);
@@ -6322,6 +6381,7 @@ package Einfo is
procedure Set_Underlying_Full_View (Id : E; V : E);
procedure Set_Universal_Aliasing (Id : E; V : B := True);
procedure Set_Unset_Reference (Id : E; V : N);
+ procedure Set_Used_As_Generic_Actual (Id : E; V : B := True);
procedure Set_Uses_Sec_Stack (Id : E; V : B := True);
procedure Set_Vax_Float (Id : E; V : B := True);
procedure Set_Warnings_Off (Id : E; V : B := True);
@@ -6353,6 +6413,11 @@ package Einfo is
-- This is particularly true for the RM_Size field, where a value of zero
-- is legitimate and causes some kludges around the code.
+ -- Contrary to the corresponding Set procedures above, these routines
+ -- do NOT check the entity kind of their argument, instead they set the
+ -- underlying Uint fields directly (this allows them to be used for
+ -- entities whose Ekind has not been set yet).
+
procedure Init_Alignment (Id : E; V : Int);
procedure Init_Component_Size (Id : E; V : Int);
procedure Init_Component_Bit_Offset (Id : E; V : Int);
@@ -6489,6 +6554,11 @@ package Einfo is
procedure Append_Entity (Id : Entity_Id; V : Entity_Id);
-- Add an entity to the list of entities declared in the scope V
+ function Get_Full_View (T : Entity_Id) return Entity_Id;
+ -- If T is an incomplete type and the full declaration has been
+ -- seen, or is the name of a class_wide type whose root is incomplete.
+ -- return the corresponding full declaration.
+
function Is_Entity_Name (N : Node_Id) return Boolean;
-- Test if the node N is the name of an entity (i.e. is an identifier,
-- expanded name, or an attribute reference that returns an entity).
@@ -6666,12 +6736,14 @@ package Einfo is
pragma Inline (Has_Convention_Pragma);
pragma Inline (Has_Delayed_Freeze);
pragma Inline (Has_Discriminants);
+ pragma Inline (Has_Dispatch_Table);
pragma Inline (Has_Enumeration_Rep_Clause);
pragma Inline (Has_Exit);
pragma Inline (Has_External_Tag_Rep_Clause);
pragma Inline (Has_Fully_Qualified_Name);
pragma Inline (Has_Gigi_Rep_Item);
pragma Inline (Has_Homonym);
+ pragma Inline (Has_Initial_Value);
pragma Inline (Has_Machine_Radix_Clause);
pragma Inline (Has_Master_Entity);
pragma Inline (Has_Missing_Return);
@@ -6685,6 +6757,7 @@ package Einfo is
pragma Inline (Has_Pragma_Elaborate_Body);
pragma Inline (Has_Pragma_Inline);
pragma Inline (Has_Pragma_Pack);
+ pragma Inline (Has_Pragma_Preelab_Init);
pragma Inline (Has_Pragma_Pure);
pragma Inline (Has_Pragma_Pure_Function);
pragma Inline (Has_Pragma_Unreferenced);
@@ -6812,6 +6885,7 @@ package Einfo is
pragma Inline (Is_Packed_Array_Type);
pragma Inline (Is_Potentially_Use_Visible);
pragma Inline (Is_Preelaborated);
+ pragma Inline (Is_Primitive);
pragma Inline (Is_Primitive_Wrapper);
pragma Inline (Is_Private_Composite);
pragma Inline (Is_Private_Descendant);
@@ -6940,6 +7014,7 @@ package Einfo is
pragma Inline (Underlying_Full_View);
pragma Inline (Universal_Aliasing);
pragma Inline (Unset_Reference);
+ pragma Inline (Used_As_Generic_Actual);
pragma Inline (Uses_Sec_Stack);
pragma Inline (Vax_Float);
pragma Inline (Warnings_Off);
@@ -7061,12 +7136,14 @@ package Einfo is
pragma Inline (Set_Has_Convention_Pragma);
pragma Inline (Set_Has_Delayed_Freeze);
pragma Inline (Set_Has_Discriminants);
+ pragma Inline (Set_Has_Dispatch_Table);
pragma Inline (Set_Has_Enumeration_Rep_Clause);
pragma Inline (Set_Has_Exit);
pragma Inline (Set_Has_External_Tag_Rep_Clause);
pragma Inline (Set_Has_Fully_Qualified_Name);
pragma Inline (Set_Has_Gigi_Rep_Item);
pragma Inline (Set_Has_Homonym);
+ pragma Inline (Set_Has_Initial_Value);
pragma Inline (Set_Has_Machine_Radix_Clause);
pragma Inline (Set_Has_Master_Entity);
pragma Inline (Set_Has_Missing_Return);
@@ -7080,6 +7157,7 @@ package Einfo is
pragma Inline (Set_Has_Pragma_Elaborate_Body);
pragma Inline (Set_Has_Pragma_Inline);
pragma Inline (Set_Has_Pragma_Pack);
+ pragma Inline (Set_Has_Pragma_Preelab_Init);
pragma Inline (Set_Has_Pragma_Pure);
pragma Inline (Set_Has_Pragma_Pure_Function);
pragma Inline (Set_Has_Pragma_Unreferenced);
@@ -7178,6 +7256,7 @@ package Einfo is
pragma Inline (Set_Is_Packed_Array_Type);
pragma Inline (Set_Is_Potentially_Use_Visible);
pragma Inline (Set_Is_Preelaborated);
+ pragma Inline (Set_Is_Primitive);
pragma Inline (Set_Is_Primitive_Wrapper);
pragma Inline (Set_Is_Private_Composite);
pragma Inline (Set_Is_Private_Descendant);
@@ -7295,6 +7374,7 @@ package Einfo is
pragma Inline (Set_Underlying_Full_View);
pragma Inline (Set_Universal_Aliasing);
pragma Inline (Set_Unset_Reference);
+ pragma Inline (Set_Used_As_Generic_Actual);
pragma Inline (Set_Uses_Sec_Stack);
pragma Inline (Set_Vax_Float);
pragma Inline (Set_Warnings_Off);
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index d91365b..c5d36b3 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -80,12 +80,6 @@ with Validsw; use Validsw;
package body Sem_Ch6 is
- Enable_New_Return_Processing : constant Boolean := True;
- -- ??? This flag is temporary. False causes the compiler to use the old
- -- version of Analyze_Return_Statement; True, the new version, which does
- -- not yet work. You probably want this to match the corresponding thing
- -- in exp_ch5.adb.
-
May_Hide_Profile : Boolean := False;
-- This flag is used to indicate that two formals in two subprograms being
-- checked for conformance differ only in that one is an access parameter
@@ -99,11 +93,11 @@ package body Sem_Ch6 is
-- Local Subprograms --
-----------------------
- procedure Analyze_A_Return_Statement (N : Node_Id);
+ procedure Analyze_Return_Statement (N : Node_Id);
-- Common processing for simple_ and extended_return_statements
procedure Analyze_Function_Return (N : Node_Id);
- -- Subsidiary to Analyze_A_Return_Statement.
+ -- Subsidiary to Analyze_Return_Statement.
-- Called when the return statement applies to a [generic] function.
procedure Analyze_Return_Type (N : Node_Id);
@@ -147,11 +141,13 @@ package body Sem_Ch6 is
procedure Check_Overriding_Indicator
(Subp : Entity_Id;
- Overridden_Subp : Entity_Id := Empty);
+ Overridden_Subp : Entity_Id;
+ Is_Primitive : Boolean);
-- Verify the consistency of an overriding_indicator given for subprogram
- -- declaration, body, renaming, or instantiation. Overridden_Subp is set
- -- if the scope into which we are introducing the subprogram contains a
+ -- declaration, body, renaming, or instantiation. Overridden_Subp is set
+ -- if the scope where we are introducing the subprogram contains a
-- type-conformant subprogram that becomes hidden by the new subprogram.
+ -- Is_Primitive indicates whether the subprogram is primitive.
procedure Check_Subprogram_Order (N : Node_Id);
-- N is the N_Subprogram_Body node for a subprogram. This routine applies
@@ -212,36 +208,33 @@ package body Sem_Ch6 is
-- setting the proper validity status for this entity, which depends
-- on the kind of parameter and the validity checking mode.
- --------------------------------
- -- Analyze_A_Return_Statement --
- --------------------------------
+ ------------------------------
+ -- Analyze_Return_Statement --
+ ------------------------------
- procedure Analyze_A_Return_Statement (N : Node_Id) is
- -- ???This should be called Analyze_Return_Statement, and
- -- Analyze_Return_Statement should be called
- -- Analyze_Simple_Return_Statement!
+ procedure Analyze_Return_Statement (N : Node_Id) is
- pragma Assert (Nkind (N) = N_Return_Statement
- or else Nkind (N) = N_Extended_Return_Statement);
+ pragma Assert (Nkind (N) = N_Simple_Return_Statement
+ or else
+ Nkind (N) = N_Extended_Return_Statement);
Returns_Object : constant Boolean :=
- Nkind (N) = N_Extended_Return_Statement
- or else
- (Nkind (N) = N_Return_Statement and then Present (Expression (N)));
-
+ Nkind (N) = N_Extended_Return_Statement
+ or else
+ (Nkind (N) = N_Simple_Return_Statement
+ and then Present (Expression (N)));
-- True if we're returning something; that is, "return <expression>;"
- -- or "return Result : T [:= ...]". False for "return;".
- -- Used for error checking: If Returns_Object is True, N should apply
- -- to a function body; otherwise N should apply to a procedure body,
- -- entry body, accept statement, or extended return statement.
+ -- or "return Result : T [:= ...]". False for "return;". Used for error
+ -- checking: If Returns_Object is True, N should apply to a function
+ -- body; otherwise N should apply to a procedure body, entry body,
+ -- accept statement, or extended return statement.
function Find_What_It_Applies_To return Entity_Id;
-- Find the entity representing the innermost enclosing body, accept
- -- statement, or extended return statement. If the result is a
- -- callable construct or extended return statement, then this will be
- -- the value of the Return_Applies_To attribute. Otherwise, the program
- -- is illegal. See RM-6.5(4/2). I am disinclined to call this
- -- Find_The_Construct_To_Which_This_Return_Statement_Applies. ;-)
+ -- statement, or extended return statement. If the result is a callable
+ -- construct or extended return statement, then this will be the value
+ -- of the Return_Applies_To attribute. Otherwise, the program is
+ -- illegal. See RM-6.5(4/2).
-----------------------------
-- Find_What_It_Applies_To --
@@ -261,41 +254,45 @@ package body Sem_Ch6 is
pragma Assert (Present (Result));
return Result;
-
end Find_What_It_Applies_To;
+ -- Local declarations
+
Scope_Id : constant Entity_Id := Find_What_It_Applies_To;
Kind : constant Entity_Kind := Ekind (Scope_Id);
-
Loc : constant Source_Ptr := Sloc (N);
Stm_Entity : constant Entity_Id :=
New_Internal_Entity
(E_Return_Statement, Current_Scope, Loc, 'R');
- -- Start of processing for Analyze_A_Return_Statement
+ -- Start of processing for Analyze_Return_Statement
begin
-
Set_Return_Statement_Entity (N, Stm_Entity);
Set_Etype (Stm_Entity, Standard_Void_Type);
Set_Return_Applies_To (Stm_Entity, Scope_Id);
- -- Place the Return entity on scope stack, to simplify enforcement
- -- of 6.5 (4/2): an inner return statement will apply to this extended
- -- return.
+ -- Place Return entity on scope stack, to simplify enforcement of 6.5
+ -- (4/2): an inner return statement will apply to this extended return.
if Nkind (N) = N_Extended_Return_Statement then
Push_Scope (Stm_Entity);
end if;
- -- Check that pragma No_Return is obeyed:
+ -- Check that pragma No_Return is obeyed
if No_Return (Scope_Id) then
Error_Msg_N ("RETURN statement not allowed (No_Return)", N);
end if;
- -- Check that functions return objects, and other things do not:
+ -- Warn on any unassigned OUT parameters if in procedure
+
+ if Ekind (Scope_Id) = E_Procedure then
+ Warn_On_Unassigned_Out_Parameter (N, Scope_Id);
+ end if;
+
+ -- Check that functions return objects, and other things do not
if Kind = E_Function or else Kind = E_Generic_Function then
if not Returns_Object then
@@ -340,7 +337,7 @@ package body Sem_Ch6 is
end if;
Check_Unreachable_Code (N);
- end Analyze_A_Return_Statement;
+ end Analyze_Return_Statement;
---------------------------------------------
-- Analyze_Abstract_Subprogram_Declaration --
@@ -362,6 +359,19 @@ package body Sem_Ch6 is
if Ekind (Scope (Designator)) = E_Protected_Type then
Error_Msg_N
("abstract subprogram not allowed in protected type", N);
+
+ -- Issue a warning if the abstract subprogram is neither a dispatching
+ -- operation nor an operation that overrides an inherited subprogram or
+ -- predefined operator, since this most likely indicates a mistake.
+
+ elsif Warn_On_Redundant_Constructs
+ and then not Is_Dispatching_Operation (Designator)
+ and then not Is_Overriding_Operation (Designator)
+ and then (not Is_Operator_Symbol_Name (Chars (Designator))
+ or else Scop /= Scope (Etype (First_Formal (Designator))))
+ then
+ Error_Msg_N
+ ("?abstract subprogram is not dispatching or overriding", N);
end if;
Generate_Reference_To_Formals (Designator);
@@ -373,7 +383,7 @@ package body Sem_Ch6 is
procedure Analyze_Extended_Return_Statement (N : Node_Id) is
begin
- Analyze_A_Return_Statement (N);
+ Analyze_Return_Statement (N);
end Analyze_Extended_Return_Statement;
----------------------------
@@ -430,7 +440,7 @@ package body Sem_Ch6 is
Stm_Entity : constant Entity_Id := Return_Statement_Entity (N);
Scope_Id : constant Entity_Id := Return_Applies_To (Stm_Entity);
- R_Type : constant Entity_Id := Etype (Scope_Id);
+ R_Type : constant Entity_Id := Etype (Scope_Id);
-- Function result subtype
procedure Check_Limited_Return (Expr : Node_Id);
@@ -466,7 +476,7 @@ package body Sem_Ch6 is
then
Error_Msg_N
("(Ada 2005) cannot copy object of a limited type " &
- "('R'M'-2005 6.5(5.5/2))", Expr);
+ "(RM-2005 6.5(5.5/2))", Expr);
if Is_Inherently_Limited_Type (R_Type) then
Error_Msg_N
("\return by reference not permitted in Ada 2005", Expr);
@@ -482,11 +492,11 @@ package body Sem_Ch6 is
if Is_Inherently_Limited_Type (R_Type) then
Error_Msg_N
("return by reference not permitted in Ada 2005 " &
- "('R'M'-2005 6.5(5.5/2))?", Expr);
+ "(RM-2005 6.5(5.5/2))?", Expr);
else
Error_Msg_N
("cannot copy object of a limited type in Ada 2005 " &
- "('R'M'-2005 6.5(5.5/2))?", Expr);
+ "(RM-2005 6.5(5.5/2))?", Expr);
end if;
-- Ada 95 mode, compatibility warnings disabled
@@ -585,7 +595,8 @@ package body Sem_Ch6 is
-- needed. ???)
elsif Is_Class_Wide_Type (R_Type)
- and then R_Type = Etype (Object_Definition (Obj_Decl))
+ and then
+ R_Type = Etype (Object_Definition (Original_Node (Obj_Decl)))
then
null;
@@ -606,7 +617,7 @@ package body Sem_Ch6 is
begin
Set_Return_Present (Scope_Id);
- if Nkind (N) = N_Return_Statement then
+ if Nkind (N) = N_Simple_Return_Statement then
Expr := Expression (N);
Analyze_And_Resolve (Expr, R_Type);
Check_Limited_Return (Expr);
@@ -649,13 +660,21 @@ package body Sem_Ch6 is
end;
end if;
+ -- Case of Expr present (Etype check defends against previous errors)
+
if Present (Expr)
- and then Present (Etype (Expr)) -- Could be False in case of errors.
+ and then Present (Etype (Expr))
then
- -- Ada 2005 (AI-318-02): When the result type is an anonymous
- -- access type, apply an implicit conversion of the expression
- -- to that type to force appropriate static and run-time
- -- accessibility checks.
+ -- Apply constraint check. Note that this is done before the implicit
+ -- conversion of the expression done for anonymous access types to
+ -- ensure correct generation of the null-excluding check asssociated
+ -- with null-excluding expressions found in return statements.
+
+ Apply_Constraint_Check (Expr, R_Type);
+
+ -- Ada 2005 (AI-318-02): When the result type is an anonymous access
+ -- type, apply an implicit conversion of the expression to that type
+ -- to force appropriate static and run-time accessibility checks.
if Ada_Version >= Ada_05
and then Ekind (R_Type) = E_Anonymous_Access_Type
@@ -672,8 +691,6 @@ package body Sem_Ch6 is
("dynamically tagged expression not allowed!", Expr);
end if;
- Apply_Constraint_Check (Expr, R_Type);
-
-- ??? A real run-time accessibility check is needed in cases
-- involving dereferences of access parameters. For now we just
-- check the static cases.
@@ -694,6 +711,17 @@ package body Sem_Ch6 is
("\& will be raised at run time?",
N, Standard_Program_Error);
end if;
+
+ if Known_Null (Expr)
+ and then Nkind (Parent (Scope_Id)) = N_Function_Specification
+ and then Null_Exclusion_Present (Parent (Scope_Id))
+ then
+ Apply_Compile_Time_Constraint_Error
+ (N => Expr,
+ Msg => "(Ada 2005) null not allowed for "
+ & "null-excluding return?",
+ Reason => CE_Null_Not_Allowed);
+ end if;
end if;
end Analyze_Function_Return;
@@ -864,7 +892,10 @@ package body Sem_Ch6 is
Set_Ekind (Gen_Id, Kind);
Generate_Reference (Gen_Id, Body_Id, 'b', Set_Ref => False);
- Style.Check_Identifier (Body_Id, Gen_Id);
+
+ if Style_Check then
+ Style.Check_Identifier (Body_Id, Gen_Id);
+ end if;
End_Generic;
end Analyze_Generic_Subprogram_Body;
@@ -1127,142 +1158,18 @@ package body Sem_Ch6 is
end if;
end Analyze_Procedure_Call;
- ------------------------------
- -- Analyze_Return_Statement --
- ------------------------------
-
- procedure Analyze_Return_Statement (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Expr : Node_Id;
- Scope_Id : Entity_Id;
- Kind : Entity_Kind;
- R_Type : Entity_Id;
-
- Stm_Entity : constant Entity_Id :=
- New_Internal_Entity
- (E_Return_Statement, Current_Scope, Loc, 'R');
+ -------------------------------------
+ -- Analyze_Simple_Return_Statement --
+ -------------------------------------
+ procedure Analyze_Simple_Return_Statement (N : Node_Id) is
begin
- if Enable_New_Return_Processing then -- ???Temporary hack.
- Analyze_A_Return_Statement (N);
- return;
- end if;
-
- -- Find subprogram or accept statement enclosing the return statement
-
- Scope_Id := Empty;
- for J in reverse 0 .. Scope_Stack.Last loop
- Scope_Id := Scope_Stack.Table (J).Entity;
- exit when Ekind (Scope_Id) /= E_Block and then
- Ekind (Scope_Id) /= E_Loop;
- end loop;
-
- pragma Assert (Present (Scope_Id));
-
- Set_Return_Statement_Entity (N, Stm_Entity);
- Set_Return_Applies_To (Stm_Entity, Scope_Id);
-
- Kind := Ekind (Scope_Id);
- Expr := Expression (N);
-
- if Kind /= E_Function
- and then Kind /= E_Generic_Function
- and then Kind /= E_Procedure
- and then Kind /= E_Generic_Procedure
- and then Kind /= E_Entry
- and then Kind /= E_Entry_Family
- then
- Error_Msg_N ("illegal context for return statement", N);
-
- elsif Present (Expr) then
- if Kind = E_Function or else Kind = E_Generic_Function then
- Set_Return_Present (Scope_Id);
- R_Type := Etype (Scope_Id);
- Analyze_And_Resolve (Expr, R_Type);
-
- -- Ada 2005 (AI-318-02): When the result type is an anonymous
- -- access type, apply an implicit conversion of the expression
- -- to that type to force appropriate static and run-time
- -- accessibility checks.
-
- if Ada_Version >= Ada_05
- and then Ekind (R_Type) = E_Anonymous_Access_Type
- then
- Rewrite (Expr, Convert_To (R_Type, Relocate_Node (Expr)));
- Analyze_And_Resolve (Expr, R_Type);
- end if;
-
- if (Is_Class_Wide_Type (Etype (Expr))
- or else Is_Dynamically_Tagged (Expr))
- and then not Is_Class_Wide_Type (R_Type)
- then
- Error_Msg_N
- ("dynamically tagged expression not allowed!", Expr);
- end if;
-
- Apply_Constraint_Check (Expr, R_Type);
-
- -- Ada 2005 (AI-318-02): Return-by-reference types have been
- -- removed and replaced by anonymous access results. This is
- -- an incompatibility with Ada 95. Not clear whether this
- -- should be enforced yet or perhaps controllable with a
- -- special switch. ???
-
- -- if Ada_Version >= Ada_05
- -- and then Is_Limited_Type (R_Type)
- -- and then Nkind (Expr) /= N_Aggregate
- -- and then Nkind (Expr) /= N_Extension_Aggregate
- -- and then Nkind (Expr) /= N_Function_Call
- -- then
- -- Error_Msg_N
- -- ("(Ada 2005) illegal operand for limited return", N);
- -- end if;
-
- -- ??? A real run-time accessibility check is needed in cases
- -- involving dereferences of access parameters. For now we just
- -- check the static cases.
-
- if Is_Inherently_Limited_Type (Etype (Scope_Id))
- and then Object_Access_Level (Expr)
- > Subprogram_Access_Level (Scope_Id)
- then
- Rewrite (N,
- Make_Raise_Program_Error (Loc,
- Reason => PE_Accessibility_Check_Failed));
- Analyze (N);
-
- Error_Msg_N
- ("cannot return a local value by reference?", N);
- Error_Msg_NE
- ("\& will be raised at run time?",
- N, Standard_Program_Error);
- end if;
-
- elsif Kind = E_Procedure or else Kind = E_Generic_Procedure then
- Error_Msg_N ("procedure cannot return value (use function)", N);
-
- else
- Error_Msg_N ("accept statement cannot return value", N);
- end if;
-
- -- No expression present
-
- else
- if Kind = E_Function or Kind = E_Generic_Function then
- Error_Msg_N ("missing expression in return from function", N);
- end if;
-
- if (Ekind (Scope_Id) = E_Procedure
- or else Ekind (Scope_Id) = E_Generic_Procedure)
- and then No_Return (Scope_Id)
- then
- Error_Msg_N
- ("RETURN statement not allowed (No_Return)", N);
- end if;
+ if Present (Expression (N)) then
+ Mark_Coextensions (N, Expression (N));
end if;
- Check_Unreachable_Code (N);
- end Analyze_Return_Statement;
+ Analyze_Return_Statement (N);
+ end Analyze_Simple_Return_Statement;
-------------------------
-- Analyze_Return_Type --
@@ -1528,12 +1435,20 @@ package body Sem_Ch6 is
Error_Msg_NE
("subprogram& is not overriding", Body_Spec, Spec_Id);
- elsif Must_Not_Override (Body_Spec)
- and then Is_Overriding_Operation (Spec_Id)
- then
- Error_Msg_NE
- ("subprogram& overrides inherited operation",
- Body_Spec, Spec_Id);
+ elsif Must_Not_Override (Body_Spec) then
+ if Is_Overriding_Operation (Spec_Id) then
+ Error_Msg_NE
+ ("subprogram& overrides inherited operation",
+ Body_Spec, Spec_Id);
+
+ -- If this is not a primitive operation the overriding indicator
+ -- is altogether illegal.
+
+ elsif not Is_Primitive (Spec_Id) then
+ Error_Msg_N ("overriding indicator only allowed " &
+ "if subprogram is primitive",
+ Body_Spec);
+ end if;
end if;
end Verify_Overriding_Indicator;
@@ -1731,6 +1646,28 @@ package body Sem_Ch6 is
elsif Present (Spec_Id) then
Spec_Decl := Unit_Declaration_Node (Spec_Id);
Verify_Overriding_Indicator;
+
+ -- In general, the spec will be frozen when we start analyzing the
+ -- body. However, for internally generated operations, such as
+ -- wrapper functions for inherited operations with controlling
+ -- results, the spec may not have been frozen by the time we
+ -- expand the freeze actions that include the bodies. In particular,
+ -- extra formals for accessibility or for return-in-place may need
+ -- to be generated. Freeze nodes, if any, are inserted before the
+ -- current body.
+
+ if not Is_Frozen (Spec_Id)
+ and then Expander_Active
+ then
+ -- Force the generation of its freezing node to ensure proper
+ -- management of access types in the backend.
+
+ -- This is definitely needed for some cases, but it is not clear
+ -- why, to be investigated further???
+
+ Set_Has_Delayed_Freeze (Spec_Id);
+ Insert_Actions (N, Freeze_Entity (Spec_Id, Loc));
+ end if;
end if;
-- Place subprogram on scope stack, and make formals visible. If there
@@ -1808,22 +1745,41 @@ package body Sem_Ch6 is
if Nkind (N) /= N_Subprogram_Body_Stub then
Set_Corresponding_Spec (N, Spec_Id);
- -- Ada 2005 (AI-345): Restore the correct Etype: here we undo the
- -- work done by Analyze_Subprogram_Specification to allow the
- -- overriding of task, protected and interface primitives.
+ -- Ada 2005 (AI-345): If the operation is a primitive operation
+ -- of a concurrent type, the type of the first parameter has been
+ -- replaced with the corresponding record, which is the proper
+ -- run-time structure to use. However, within the body there may
+ -- be uses of the formals that depend on primitive operations
+ -- of the type (in particular calls in prefixed form) for which
+ -- we need the original concurrent type. The operation may have
+ -- several controlling formals, so the replacement must be done
+ -- for all of them.
if Comes_From_Source (Spec_Id)
and then Present (First_Entity (Spec_Id))
and then Ekind (Etype (First_Entity (Spec_Id))) = E_Record_Type
and then Is_Tagged_Type (Etype (First_Entity (Spec_Id)))
- and then Present (Abstract_Interfaces
- (Etype (First_Entity (Spec_Id))))
- and then Present (Corresponding_Concurrent_Type
- (Etype (First_Entity (Spec_Id))))
+ and then
+ Present (Abstract_Interfaces (Etype (First_Entity (Spec_Id))))
+ and then
+ Present
+ (Corresponding_Concurrent_Type
+ (Etype (First_Entity (Spec_Id))))
then
- Set_Etype (First_Entity (Spec_Id),
- Corresponding_Concurrent_Type
- (Etype (First_Entity (Spec_Id))));
+ declare
+ Typ : constant Entity_Id := Etype (First_Entity (Spec_Id));
+ Form : Entity_Id;
+
+ begin
+ Form := First_Formal (Spec_Id);
+ while Present (Form) loop
+ if Etype (Form) = Typ then
+ Set_Etype (Form, Corresponding_Concurrent_Type (Typ));
+ end if;
+
+ Next_Formal (Form);
+ end loop;
+ end;
end if;
-- Now make the formals visible, and place subprogram
@@ -2677,7 +2633,7 @@ package body Sem_Ch6 is
function Check_Return (N : Node_Id) return Traverse_Result is
begin
- if Nkind (N) = N_Return_Statement then
+ if Nkind (N) = N_Simple_Return_Statement then
if Present (Expression (N))
and then Is_Entity_Name (Expression (N))
then
@@ -3038,7 +2994,7 @@ package body Sem_Ch6 is
and then New_Type /= Standard_Void_Type
then
if not Conforming_Types (Old_Type, New_Type, Ctype, Get_Inst) then
- Conformance_Error ("return type does not match!", New_Id);
+ Conformance_Error ("\return type does not match!", New_Id);
return;
end if;
@@ -3053,7 +3009,7 @@ package body Sem_Ch6 is
or else Is_Access_Constant (Etype (Old_Type))
/= Is_Access_Constant (Etype (New_Type)))
then
- Conformance_Error ("return type does not match!", New_Id);
+ Conformance_Error ("\return type does not match!", New_Id);
return;
end if;
@@ -3062,7 +3018,7 @@ package body Sem_Ch6 is
elsif Old_Type /= Standard_Void_Type
or else New_Type /= Standard_Void_Type
then
- Conformance_Error ("functions can only match functions!", New_Id);
+ Conformance_Error ("\functions can only match functions!", New_Id);
return;
end if;
@@ -3086,10 +3042,10 @@ package body Sem_Ch6 is
Error_Msg_Name_2 :=
Name_Ada + Convention_Id'Pos (Convention (New_Id));
- Conformance_Error ("prior declaration for% has convention %!");
+ Conformance_Error ("\prior declaration for% has convention %!");
else
- Conformance_Error ("calling conventions do not match!");
+ Conformance_Error ("\calling conventions do not match!");
end if;
return;
@@ -3097,7 +3053,7 @@ package body Sem_Ch6 is
elsif Is_Formal_Subprogram (Old_Id)
or else Is_Formal_Subprogram (New_Id)
then
- Conformance_Error ("formal subprograms not allowed!");
+ Conformance_Error ("\formal subprograms not allowed!");
return;
end if;
end if;
@@ -3126,7 +3082,7 @@ package body Sem_Ch6 is
-- this before checking that the types of the formals match.
if Chars (Old_Formal) /= Chars (New_Formal) then
- Conformance_Error ("name & does not match!", New_Formal);
+ Conformance_Error ("\name & does not match!", New_Formal);
-- Set error posted flag on new formal as well to stop
-- junk cascaded messages in some cases.
@@ -3159,10 +3115,10 @@ package body Sem_Ch6 is
Access_Types_Match := Ada_Version >= Ada_05
-- Ensure that this rule is only applied when New_Id is a
- -- renaming of Old_Id
+ -- renaming of Old_Id.
- and then Nkind (Parent (Parent (New_Id)))
- = N_Subprogram_Renaming_Declaration
+ and then Nkind (Parent (Parent (New_Id))) =
+ N_Subprogram_Renaming_Declaration
and then Nkind (Name (Parent (Parent (New_Id)))) in N_Has_Entity
and then Present (Entity (Name (Parent (Parent (New_Id)))))
and then Entity (Name (Parent (Parent (New_Id)))) = Old_Id
@@ -3171,6 +3127,30 @@ package body Sem_Ch6 is
and then Is_Access_Type (Old_Formal_Base)
and then Is_Access_Type (New_Formal_Base)
+
+ -- The type kinds must match. The only exception occurs with
+ -- multiple generics of the form:
+
+ -- generic generic
+ -- type F is private; type A is private;
+ -- type F_Ptr is access F; type A_Ptr is access A;
+ -- with proc F_P (X : F_Ptr); with proc A_P (X : A_Ptr);
+ -- package F_Pack is ... package A_Pack is
+ -- package F_Inst is
+ -- new F_Pack (A, A_Ptr, A_P);
+
+ -- When checking for conformance between the parameters of A_P
+ -- and F_P, the type kinds of F_Ptr and A_Ptr will not match
+ -- because the compiler has transformed A_Ptr into a subtype of
+ -- F_Ptr. We catch this case in the code below.
+
+ and then (Ekind (Old_Formal_Base) = Ekind (New_Formal_Base)
+ or else
+ (Is_Generic_Type (Old_Formal_Base)
+ and then Is_Generic_Type (New_Formal_Base)
+ and then Is_Internal (New_Formal_Base)
+ and then Etype (Etype (New_Formal_Base)) =
+ Old_Formal_Base))
and then Directly_Designated_Type (Old_Formal_Base) =
Directly_Designated_Type (New_Formal_Base)
and then ((Is_Itype (Old_Formal_Base)
@@ -3193,28 +3173,39 @@ package body Sem_Ch6 is
Get_Inst => Get_Inst)
and then not Access_Types_Match
then
- Conformance_Error ("type of & does not match!", New_Formal);
+ Conformance_Error ("\type of & does not match!", New_Formal);
return;
end if;
elsif not Conforming_Types
- (T1 => Etype (Old_Formal),
- T2 => Etype (New_Formal),
+ (T1 => Old_Formal_Base,
+ T2 => New_Formal_Base,
Ctype => Ctype,
Get_Inst => Get_Inst)
and then not Access_Types_Match
then
- Conformance_Error ("type of & does not match!", New_Formal);
+ Conformance_Error ("\type of & does not match!", New_Formal);
return;
end if;
-- For mode conformance, mode must match
- if Ctype >= Mode_Conformant
- and then Parameter_Mode (Old_Formal) /= Parameter_Mode (New_Formal)
- then
- Conformance_Error ("mode of & does not match!", New_Formal);
- return;
+ if Ctype >= Mode_Conformant then
+ if Parameter_Mode (Old_Formal) /= Parameter_Mode (New_Formal) then
+ Conformance_Error ("\mode of & does not match!", New_Formal);
+ return;
+
+ -- Part of mode conformance for access types is having the same
+ -- constant modifier.
+
+ elsif Access_Types_Match
+ and then Is_Access_Constant (Old_Formal_Base) /=
+ Is_Access_Constant (New_Formal_Base)
+ then
+ Conformance_Error
+ ("\constant modifier does not match!", New_Formal);
+ return;
+ end if;
end if;
if Ctype >= Subtype_Conformant then
@@ -3246,7 +3237,7 @@ package body Sem_Ch6 is
and then TSS_Name /= TSS_Stream_Output
then
Conformance_Error
- ("type of & does not match!", New_Formal);
+ ("\type of & does not match!", New_Formal);
return;
end if;
end;
@@ -3289,7 +3280,7 @@ package body Sem_Ch6 is
Default_Value (New_Formal))
then
Conformance_Error
- ("default expression for & does not match!",
+ ("\default expression for & does not match!",
New_Formal);
return;
end if;
@@ -3320,7 +3311,7 @@ package body Sem_Ch6 is
and then Ctype = Fully_Conformant
then
Conformance_Error
- ("(Ada 83) IN must appear in both declarations",
+ ("\(Ada 83) IN must appear in both declarations",
New_Formal);
return;
end if;
@@ -3338,7 +3329,7 @@ package body Sem_Ch6 is
or else Prev_Ids (Old_Param) /= Prev_Ids (New_Param)
then
Conformance_Error
- ("grouping of & does not match!", New_Formal);
+ ("\grouping of & does not match!", New_Formal);
return;
end if;
end;
@@ -3353,11 +3344,11 @@ package body Sem_Ch6 is
end loop;
if Present (Old_Formal) then
- Conformance_Error ("too few parameters!");
+ Conformance_Error ("\too few parameters!");
return;
elsif Present (New_Formal) then
- Conformance_Error ("too many parameters!", New_Formal);
+ Conformance_Error ("\too many parameters!", New_Formal);
return;
end if;
end Check_Conformance;
@@ -3769,7 +3760,8 @@ package body Sem_Ch6 is
procedure Check_Overriding_Indicator
(Subp : Entity_Id;
- Overridden_Subp : Entity_Id := Empty)
+ Overridden_Subp : Entity_Id;
+ Is_Primitive : Boolean)
is
Decl : Node_Id;
Spec : Node_Id;
@@ -3807,47 +3799,59 @@ package body Sem_Ch6 is
Error_Msg_Sloc := Sloc (Overridden_Subp);
if Ekind (Subp) = E_Entry then
- Error_Msg_NE ("entry & overrides inherited operation #",
- Spec, Subp);
-
+ Error_Msg_NE
+ ("entry & overrides inherited operation #", Spec, Subp);
else
- Error_Msg_NE ("subprogram & overrides inherited operation #",
- Spec, Subp);
+ Error_Msg_NE
+ ("subprogram & overrides inherited operation #", Spec, Subp);
end if;
end if;
-- If Subp is an operator, it may override a predefined operation.
-- In that case overridden_subp is empty because of our implicit
- -- representation for predefined operators. We have to check whether
- -- the signature of Subp matches that of a predefined operator.
- -- Note that first argument provides the name of the operator, and
- -- the second argument the signature that may match that of a standard
- -- operation.
+ -- representation for predefined operators. We have to check whether the
+ -- signature of Subp matches that of a predefined operator. Note that
+ -- first argument provides the name of the operator, and the second
+ -- argument the signature that may match that of a standard operation.
elsif Nkind (Subp) = N_Defining_Operator_Symbol
and then Must_Not_Override (Spec)
then
if Operator_Matches_Spec (Subp, Subp) then
Error_Msg_NE
- ("subprogram & overrides predefined operation ",
+ ("subprogram & overrides predefined operator ",
Spec, Subp);
end if;
- else
- if Must_Override (Spec) then
- if Ekind (Subp) = E_Entry then
- Error_Msg_NE ("entry & is not overriding", Spec, Subp);
-
- elsif Nkind (Subp) = N_Defining_Operator_Symbol then
- if not Operator_Matches_Spec (Subp, Subp) then
- Error_Msg_NE
- ("subprogram & is not overriding", Spec, Subp);
- end if;
+ elsif Must_Override (Spec) then
+ if Ekind (Subp) = E_Entry then
+ Error_Msg_NE ("entry & is not overriding", Spec, Subp);
- else
- Error_Msg_NE ("subprogram & is not overriding", Spec, Subp);
+ elsif Nkind (Subp) = N_Defining_Operator_Symbol then
+ if not Operator_Matches_Spec (Subp, Subp) then
+ Error_Msg_NE
+ ("subprogram & is not overriding", Spec, Subp);
end if;
+
+ else
+ Error_Msg_NE ("subprogram & is not overriding", Spec, Subp);
end if;
+
+ -- If the operation is marked "not overriding" and it's not primitive
+ -- then an error is issued, unless this is an operation of a task or
+ -- protected type (RM05-8.3.1(3/2-4/2)). Error cases where "overriding"
+ -- has been specified have already been checked above.
+
+ elsif Must_Not_Override (Spec)
+ and then not Is_Primitive
+ and then Ekind (Subp) /= E_Entry
+ and then Ekind (Scope (Subp)) /= E_Protected_Type
+ then
+ Error_Msg_N
+ ("overriding indicator only allowed if subprogram is primitive",
+ Subp);
+
+ return;
end if;
end Check_Overriding_Indicator;
@@ -4177,10 +4181,10 @@ package body Sem_Ch6 is
if Mode = 'F' then
if not Raise_Exception_Call then
Error_Msg_N
- ("?RETURN statement missing following this statement",
+ ("?RETURN statement missing following this statement!",
Last_Stm);
Error_Msg_N
- ("\?Program_Error may be raised at run time",
+ ("\?Program_Error may be raised at run time!",
Last_Stm);
end if;
@@ -4375,6 +4379,12 @@ package body Sem_Ch6 is
-- spurious ambiguities in an instantiation that may arise if two
-- distinct generic types are instantiated with the same actual.
+ function Find_Designated_Type (T : Entity_Id) return Entity_Id;
+ -- An access parameter can designate an incomplete type. If the
+ -- incomplete type is the limited view of a type from a limited_
+ -- with_clause, check whether the non-limited view is available. If
+ -- it is a (non-limited) incomplete type, get the full view.
+
function Matches_Limited_With_View (T1, T2 : Entity_Id) return Boolean;
-- Returns True if and only if either T1 denotes a limited view of T2
-- or T2 denotes a limited view of T1. This can arise when the limited
@@ -4407,6 +4417,34 @@ package body Sem_Ch6 is
end if;
end Base_Types_Match;
+ --------------------------
+ -- Find_Designated_Type --
+ --------------------------
+
+ function Find_Designated_Type (T : Entity_Id) return Entity_Id is
+ Desig : Entity_Id;
+
+ begin
+ Desig := Directly_Designated_Type (T);
+
+ if Ekind (Desig) = E_Incomplete_Type then
+
+ -- If regular incomplete type, get full view if available
+
+ if Present (Full_View (Desig)) then
+ Desig := Full_View (Desig);
+
+ -- If limited view of a type, get non-limited view if available,
+ -- and check again for a regular incomplete type.
+
+ elsif Present (Non_Limited_View (Desig)) then
+ Desig := Get_Full_View (Non_Limited_View (Desig));
+ end if;
+ end if;
+
+ return Desig;
+ end Find_Designated_Type;
+
-------------------------------
-- Matches_Limited_With_View --
-------------------------------
@@ -4490,10 +4528,13 @@ package body Sem_Ch6 is
Ekind (Type_1) = E_Anonymous_Access_Protected_Subprogram_Type);
-- Test anonymous access type case. For this case, static subtype
- -- matching is required for mode conformance (RM 6.3.1(15))
+ -- matching is required for mode conformance (RM 6.3.1(15)). We check
+ -- the base types because we may have built internal subtype entities
+ -- to handle null-excluding types (see Process_Formals).
- if (Ekind (Type_1) = E_Anonymous_Access_Type
- and then Ekind (Type_2) = E_Anonymous_Access_Type)
+ if (Ekind (Base_Type (Type_1)) = E_Anonymous_Access_Type
+ and then
+ Ekind (Base_Type (Type_2)) = E_Anonymous_Access_Type)
or else Are_Anonymous_Access_To_Subprogram_Types -- Ada 2005 (AI-254)
then
declare
@@ -4501,33 +4542,22 @@ package body Sem_Ch6 is
Desig_2 : Entity_Id;
begin
- Desig_1 := Directly_Designated_Type (Type_1);
-
- -- An access parameter can designate an incomplete type
- -- If the incomplete type is the limited view of a type
- -- from a limited_with_clause, check whether the non-limited
- -- view is available.
-
- if Ekind (Desig_1) = E_Incomplete_Type then
- if Present (Full_View (Desig_1)) then
- Desig_1 := Full_View (Desig_1);
+ -- In Ada2005, access constant indicators must match for
+ -- subtype conformance.
- elsif Present (Non_Limited_View (Desig_1)) then
- Desig_1 := Non_Limited_View (Desig_1);
- end if;
+ if Ada_Version >= Ada_05
+ and then Ctype >= Subtype_Conformant
+ and then
+ Is_Access_Constant (Type_1) /= Is_Access_Constant (Type_2)
+ then
+ return False;
end if;
- Desig_2 := Directly_Designated_Type (Type_2);
+ Desig_1 := Find_Designated_Type (Type_1);
- if Ekind (Desig_2) = E_Incomplete_Type then
- if Present (Full_View (Desig_2)) then
- Desig_2 := Full_View (Desig_2);
- elsif Present (Non_Limited_View (Desig_2)) then
- Desig_2 := Non_Limited_View (Desig_2);
- end if;
- end if;
+ Desig_2 := Find_Designated_Type (Type_2);
- -- The context is an instance association for a formal
+ -- If the context is an instance association for a formal
-- access-to-subprogram type; formal access parameter designated
-- types require mapping because they may denote other formal
-- parameters of the generic unit.
@@ -4699,7 +4729,6 @@ package body Sem_Ch6 is
end if;
Formal := First_Formal (E);
-
while Present (Formal) loop
-- Create extra formal for supporting the attribute 'Constrained.
@@ -4733,9 +4762,7 @@ package body Sem_Ch6 is
and then not Is_Indefinite_Subtype (Formal_Type)
then
Set_Extra_Constrained
- (Formal,
- Add_Extra_Formal
- (Formal, Standard_Boolean, Scope (Formal), "F"));
+ (Formal, Add_Extra_Formal (Formal, Standard_Boolean, E, "F"));
end if;
end if;
@@ -4745,6 +4772,8 @@ package body Sem_Ch6 is
-- case can occur when Expand_Dispatching_Call creates a subprogram
-- type and substitutes the types of access-to-class-wide actuals
-- for the anonymous access-to-specific-type of controlling formals.
+ -- Base_Type is applied because in cases where there is a null
+ -- exclusion the formal may have an access subtype.
-- This is suppressed if we specifically suppress accessibility
-- checks at the package level for either the subprogram, or the
@@ -4754,9 +4783,9 @@ package body Sem_Ch6 is
-- different suppression setting. The explicit checks at the
-- package level are safe from this point of view.
- if (Ekind (Etype (Formal)) = E_Anonymous_Access_Type
+ if (Ekind (Base_Type (Etype (Formal))) = E_Anonymous_Access_Type
or else (Is_Controlling_Formal (Formal)
- and then Is_Access_Type (Etype (Formal))))
+ and then Is_Access_Type (Base_Type (Etype (Formal)))))
and then not
(Explicit_Suppress (E, Accessibility_Check)
or else
@@ -4773,9 +4802,7 @@ package body Sem_Ch6 is
and then Nkind (Parent (Parent (Parent (E)))) /= N_Protected_Body
then
Set_Extra_Accessibility
- (Formal,
- Add_Extra_Formal
- (Formal, Standard_Natural, Scope (Formal), "F"));
+ (Formal, Add_Extra_Formal (Formal, Standard_Natural, E, "F"));
end if;
end if;
@@ -4984,7 +5011,6 @@ package body Sem_Ch6 is
begin
E := Current_Entity (Designator);
-
while Present (E) loop
-- We are looking for a matching spec. It must have the same scope,
@@ -5059,10 +5085,9 @@ package body Sem_Ch6 is
and then
Nkind (Unit_Declaration_Node (Designator)) = N_Subprogram_Body
and then
- Nkind (Parent (Unit_Declaration_Node (Designator)))
- = N_Compilation_Unit
+ Nkind (Parent (Unit_Declaration_Node (Designator))) =
+ N_Compilation_Unit
then
-
-- Child units cannot be overloaded, so a conformance mismatch
-- between body and a previous spec is an error.
@@ -5482,6 +5507,10 @@ package body Sem_Ch6 is
function Conforming_Ranges (R1, R2 : Node_Id) return Boolean;
-- Check both bounds
+ -----------------------
+ -- Conforming_Bounds --
+ -----------------------
+
function Conforming_Bounds (B1, B2 : Node_Id) return Boolean is
begin
if Is_Entity_Name (B1)
@@ -5495,6 +5524,10 @@ package body Sem_Ch6 is
end if;
end Conforming_Bounds;
+ -----------------------
+ -- Conforming_Ranges --
+ -----------------------
+
function Conforming_Ranges (R1, R2 : Node_Id) return Boolean is
begin
return
@@ -5566,9 +5599,8 @@ package body Sem_Ch6 is
G_Typ : Entity_Id := Empty;
function Get_Generic_Parent_Type (F_Typ : Entity_Id) return Entity_Id;
- -- If F_Type is a derived type associated with a generic actual
- -- subtype, then return its Generic_Parent_Type attribute, else return
- -- Empty.
+ -- If F_Type is a derived type associated with a generic actual subtype,
+ -- then return its Generic_Parent_Type attribute, else return Empty.
function Types_Correspond
(P_Type : Entity_Id;
@@ -5793,9 +5825,9 @@ package body Sem_Ch6 is
Make_Defining_Identifier (Sloc (FF),
Chars => Chars (FF));
- B : constant Entity_Id :=
- Make_Defining_Identifier (Sloc (NF),
- Chars => Chars (NF));
+ B : constant Entity_Id :=
+ Make_Defining_Identifier (Sloc (NF),
+ Chars => Chars (NF));
begin
Op_Name := Make_Defining_Operator_Symbol (Loc, Name_Op_Ne);
@@ -5862,7 +5894,6 @@ package body Sem_Ch6 is
begin
F := First_Formal (Fun);
B := True;
-
while Present (F) loop
if No (Default_Value (F)) then
B := False;
@@ -5898,12 +5929,23 @@ package body Sem_Ch6 is
-- Set if the current scope has an operation that is type-conformant
-- with S, and becomes hidden by S.
+ Is_Primitive_Subp : Boolean;
+ -- Set to True if the new subprogram is primitive
+
E : Entity_Id;
-- Entity that S overrides
Prev_Vis : Entity_Id := Empty;
-- Predecessor of E in Homonym chain
+ procedure Check_For_Primitive_Subprogram
+ (Is_Primitive : out Boolean;
+ Is_Overriding : Boolean := False);
+ -- If the subprogram being analyzed is a primitive operation of the type
+ -- of a formal or result, set the Has_Primitive_Operations flag on the
+ -- type, and set Is_Primitive to True (otherwise set to False). Set the
+ -- corresponding flag on the entity itself for later use.
+
procedure Check_Synchronized_Overriding
(Def_Id : Entity_Id;
First_Hom : Entity_Id;
@@ -5921,130 +5963,14 @@ package body Sem_Ch6 is
-- set when freezing entities, so we must examine the place of the
-- declaration in the tree, and recognize wrapper packages as well.
- procedure Maybe_Primitive_Operation (Is_Overriding : Boolean := False);
- -- If the subprogram being analyzed is a primitive operation of
- -- the type of one of its formals, set the corresponding flag.
+ ------------------------------------
+ -- Check_For_Primitive_Subprogram --
+ ------------------------------------
- -----------------------------------
- -- Check_Synchronized_Overriding --
- -----------------------------------
-
- procedure Check_Synchronized_Overriding
- (Def_Id : Entity_Id;
- First_Hom : Entity_Id;
- Overridden_Subp : out Entity_Id)
+ procedure Check_For_Primitive_Subprogram
+ (Is_Primitive : out Boolean;
+ Is_Overriding : Boolean := False)
is
- Formal_Typ : Entity_Id;
- Ifaces_List : Elist_Id;
- In_Scope : Boolean;
- Typ : Entity_Id;
-
- begin
- Overridden_Subp := Empty;
-
- -- Def_Id must be an entry or a subprogram
-
- if Ekind (Def_Id) /= E_Entry
- and then Ekind (Def_Id) /= E_Function
- and then Ekind (Def_Id) /= E_Procedure
- then
- return;
- end if;
-
- -- Search for the concurrent declaration since it contains the list
- -- of all implemented interfaces. In this case, the subprogram is
- -- declared within the scope of a protected or a task type.
-
- if Present (Scope (Def_Id))
- and then Is_Concurrent_Type (Scope (Def_Id))
- and then not Is_Generic_Actual_Type (Scope (Def_Id))
- then
- Typ := Scope (Def_Id);
- In_Scope := True;
-
- -- The subprogram may be a primitive of a concurrent type
-
- elsif Present (First_Formal (Def_Id)) then
- Formal_Typ := Etype (First_Formal (Def_Id));
-
- if Is_Concurrent_Type (Formal_Typ)
- and then not Is_Generic_Actual_Type (Formal_Typ)
- then
- Typ := Formal_Typ;
- In_Scope := False;
-
- -- This case occurs when the concurrent type is declared within
- -- a generic unit. As a result the corresponding record has been
- -- built and used as the type of the first formal, we just have
- -- to retrieve the corresponding concurrent type.
-
- elsif Is_Concurrent_Record_Type (Formal_Typ)
- and then Present (Corresponding_Concurrent_Type (Formal_Typ))
- then
- Typ := Corresponding_Concurrent_Type (Formal_Typ);
- In_Scope := False;
-
- else
- return;
- end if;
- else
- return;
- end if;
-
- -- Gather all limited, protected and task interfaces that Typ
- -- implements. There is no overriding to check if is an inherited
- -- operation in a type derivation on for a generic actual.
-
- if Nkind (Parent (Typ)) /= N_Full_Type_Declaration
- and then Nkind (Parent (Def_Id)) /= N_Subtype_Declaration
- and then Nkind (Parent (Def_Id)) /= N_Task_Type_Declaration
- and then Nkind (Parent (Def_Id)) /= N_Protected_Type_Declaration
- then
- Collect_Abstract_Interfaces (Typ, Ifaces_List);
-
- if not Is_Empty_Elmt_List (Ifaces_List) then
- Overridden_Subp :=
- Find_Overridden_Synchronized_Primitive
- (Def_Id, First_Hom, Ifaces_List, In_Scope);
- end if;
- end if;
- end Check_Synchronized_Overriding;
-
- ----------------------------
- -- Is_Private_Declaration --
- ----------------------------
-
- function Is_Private_Declaration (E : Entity_Id) return Boolean is
- Priv_Decls : List_Id;
- Decl : constant Node_Id := Unit_Declaration_Node (E);
-
- begin
- if Is_Package_Or_Generic_Package (Current_Scope)
- and then In_Private_Part (Current_Scope)
- then
- Priv_Decls :=
- Private_Declarations (
- Specification (Unit_Declaration_Node (Current_Scope)));
-
- return In_Package_Body (Current_Scope)
- or else
- (Is_List_Member (Decl)
- and then List_Containing (Decl) = Priv_Decls)
- or else (Nkind (Parent (Decl)) = N_Package_Specification
- and then not Is_Compilation_Unit (
- Defining_Entity (Parent (Decl)))
- and then List_Containing (Parent (Parent (Decl)))
- = Priv_Decls);
- else
- return False;
- end if;
- end Is_Private_Declaration;
-
- -------------------------------
- -- Maybe_Primitive_Operation --
- -------------------------------
-
- procedure Maybe_Primitive_Operation (Is_Overriding : Boolean := False) is
Formal : Entity_Id;
F_Typ : Entity_Id;
B_Typ : Entity_Id;
@@ -6079,7 +6005,7 @@ package body Sem_Ch6 is
or else not Is_Abstract_Subprogram (E))
then
Error_Msg_N ("abstract subprograms must be visible "
- & "('R'M 3.9.3(10))!", S);
+ & "(RM 3.9.3(10))!", S);
elsif Ekind (S) = E_Function
and then Is_Tagged_Type (T)
@@ -6091,7 +6017,7 @@ package body Sem_Ch6 is
& " override visible-part function", S);
Error_Msg_N
("\move subprogram to the visible part"
- & " ('R'M 3.9.3(10))", S);
+ & " (RM 3.9.3(10))", S);
end if;
end if;
end Check_Private_Overriding;
@@ -6141,29 +6067,42 @@ package body Sem_Ch6 is
return False;
end Visible_Part_Type;
- -- Start of processing for Maybe_Primitive_Operation
+ -- Start of processing for Check_For_Primitive_Subprogram
begin
+ Is_Primitive := False;
+
if not Comes_From_Source (S) then
null;
- -- If the subprogram is at library level, it is not primitive
- -- operation.
+ -- If subprogram is at library level, it is not primitive operation
elsif Current_Scope = Standard_Standard then
null;
- elsif (Ekind (Current_Scope) = E_Package
+ elsif ((Ekind (Current_Scope) = E_Package
+ or else Ekind (Current_Scope) = E_Generic_Package)
and then not In_Package_Body (Current_Scope))
or else Is_Overriding
then
-- For function, check return type
if Ekind (S) = E_Function then
- B_Typ := Base_Type (Etype (S));
+ if Ekind (Etype (S)) = E_Anonymous_Access_Type then
+ F_Typ := Designated_Type (Etype (S));
+ else
+ F_Typ := Etype (S);
+ end if;
+
+ B_Typ := Base_Type (F_Typ);
- if Scope (B_Typ) = Current_Scope then
+ if Scope (B_Typ) = Current_Scope
+ and then not Is_Class_Wide_Type (B_Typ)
+ and then not Is_Generic_Type (B_Typ)
+ then
+ Is_Primitive := True;
Set_Has_Primitive_Operations (B_Typ);
+ Set_Is_Primitive (S);
Check_Private_Overriding (B_Typ);
end if;
end if;
@@ -6184,7 +6123,12 @@ package body Sem_Ch6 is
B_Typ := Base_Type (B_Typ);
end if;
- if Scope (B_Typ) = Current_Scope then
+ if Scope (B_Typ) = Current_Scope
+ and then not Is_Class_Wide_Type (B_Typ)
+ and then not Is_Generic_Type (B_Typ)
+ then
+ Is_Primitive := True;
+ Set_Is_Primitive (S);
Set_Has_Primitive_Operations (B_Typ);
Check_Private_Overriding (B_Typ);
end if;
@@ -6192,7 +6136,122 @@ package body Sem_Ch6 is
Next_Formal (Formal);
end loop;
end if;
- end Maybe_Primitive_Operation;
+ end Check_For_Primitive_Subprogram;
+
+ -----------------------------------
+ -- Check_Synchronized_Overriding --
+ -----------------------------------
+
+ procedure Check_Synchronized_Overriding
+ (Def_Id : Entity_Id;
+ First_Hom : Entity_Id;
+ Overridden_Subp : out Entity_Id)
+ is
+ Formal_Typ : Entity_Id;
+ Ifaces_List : Elist_Id;
+ In_Scope : Boolean;
+ Typ : Entity_Id;
+
+ begin
+ Overridden_Subp := Empty;
+
+ -- Def_Id must be an entry or a subprogram
+
+ if Ekind (Def_Id) /= E_Entry
+ and then Ekind (Def_Id) /= E_Function
+ and then Ekind (Def_Id) /= E_Procedure
+ then
+ return;
+ end if;
+
+ -- Search for the concurrent declaration since it contains the list
+ -- of all implemented interfaces. In this case, the subprogram is
+ -- declared within the scope of a protected or a task type.
+
+ if Present (Scope (Def_Id))
+ and then Is_Concurrent_Type (Scope (Def_Id))
+ and then not Is_Generic_Actual_Type (Scope (Def_Id))
+ then
+ Typ := Scope (Def_Id);
+ In_Scope := True;
+
+ -- The subprogram may be a primitive of a concurrent type
+
+ elsif Present (First_Formal (Def_Id)) then
+ Formal_Typ := Etype (First_Formal (Def_Id));
+
+ if Is_Concurrent_Type (Formal_Typ)
+ and then not Is_Generic_Actual_Type (Formal_Typ)
+ then
+ Typ := Formal_Typ;
+ In_Scope := False;
+
+ -- This case occurs when the concurrent type is declared within
+ -- a generic unit. As a result the corresponding record has been
+ -- built and used as the type of the first formal, we just have
+ -- to retrieve the corresponding concurrent type.
+
+ elsif Is_Concurrent_Record_Type (Formal_Typ)
+ and then Present (Corresponding_Concurrent_Type (Formal_Typ))
+ then
+ Typ := Corresponding_Concurrent_Type (Formal_Typ);
+ In_Scope := False;
+
+ else
+ return;
+ end if;
+ else
+ return;
+ end if;
+
+ -- Gather all limited, protected and task interfaces that Typ
+ -- implements. There is no overriding to check if is an inherited
+ -- operation in a type derivation on for a generic actual.
+
+ if Nkind (Parent (Typ)) /= N_Full_Type_Declaration
+ and then Nkind (Parent (Def_Id)) /= N_Subtype_Declaration
+ and then Nkind (Parent (Def_Id)) /= N_Task_Type_Declaration
+ and then Nkind (Parent (Def_Id)) /= N_Protected_Type_Declaration
+ then
+ Collect_Abstract_Interfaces (Typ, Ifaces_List);
+
+ if not Is_Empty_Elmt_List (Ifaces_List) then
+ Overridden_Subp :=
+ Find_Overridden_Synchronized_Primitive
+ (Def_Id, First_Hom, Ifaces_List, In_Scope);
+ end if;
+ end if;
+ end Check_Synchronized_Overriding;
+
+ ----------------------------
+ -- Is_Private_Declaration --
+ ----------------------------
+
+ function Is_Private_Declaration (E : Entity_Id) return Boolean is
+ Priv_Decls : List_Id;
+ Decl : constant Node_Id := Unit_Declaration_Node (E);
+
+ begin
+ if Is_Package_Or_Generic_Package (Current_Scope)
+ and then In_Private_Part (Current_Scope)
+ then
+ Priv_Decls :=
+ Private_Declarations (
+ Specification (Unit_Declaration_Node (Current_Scope)));
+
+ return In_Package_Body (Current_Scope)
+ or else
+ (Is_List_Member (Decl)
+ and then List_Containing (Decl) = Priv_Decls)
+ or else (Nkind (Parent (Decl)) = N_Package_Specification
+ and then not Is_Compilation_Unit (
+ Defining_Entity (Parent (Decl)))
+ and then List_Containing (Parent (Parent (Decl)))
+ = Priv_Decls);
+ else
+ return False;
+ end if;
+ end Is_Private_Declaration;
-- Start of processing for New_Overloaded_Entity
@@ -6208,14 +6267,15 @@ package body Sem_Ch6 is
if No (E) then
Enter_Overloaded_Entity (S);
Check_Dispatching_Operation (S, Empty);
- Maybe_Primitive_Operation;
+ Check_For_Primitive_Subprogram (Is_Primitive_Subp);
-- If subprogram has an explicit declaration, check whether it
-- has an overriding indicator.
if Comes_From_Source (S) then
Check_Synchronized_Overriding (S, Homonym (S), Overridden_Subp);
- Check_Overriding_Indicator (S, Overridden_Subp);
+ Check_Overriding_Indicator
+ (S, Overridden_Subp, Is_Primitive => Is_Primitive_Subp);
end if;
-- If there is a homonym that is not overloadable, then we have an
@@ -6241,7 +6301,7 @@ package body Sem_Ch6 is
Enter_Overloaded_Entity (S);
Set_Homonym (S, Homonym (E));
Check_Dispatching_Operation (S, Empty);
- Check_Overriding_Indicator (S, Empty);
+ Check_Overriding_Indicator (S, Empty, Is_Primitive => False);
-- If the subprogram is implicit it is hidden by the previous
-- declaration. However if it is dispatching, it must appear in the
@@ -6261,12 +6321,14 @@ package body Sem_Ch6 is
else
Error_Msg_Sloc := Sloc (E);
- Error_Msg_N ("& conflicts with declaration#", S);
- -- Useful additional warning
+ -- Generate message,with useful additionalwarning if in generic
if Is_Generic_Unit (E) then
- Error_Msg_N ("\previous generic unit cannot be overloaded", S);
+ Error_Msg_N ("previous generic unit cannot be overloaded", S);
+ Error_Msg_N ("\& conflicts with declaration#", S);
+ else
+ Error_Msg_N ("& conflicts with declaration#", S);
end if;
return;
@@ -6349,7 +6411,7 @@ package body Sem_Ch6 is
Set_Is_Overriding_Operation (E);
if Comes_From_Source (E) then
- Check_Overriding_Indicator (E, S);
+ Check_Overriding_Indicator (E, S, Is_Primitive => False);
-- Indicate that E overrides the operation from which
-- S is inherited.
@@ -6513,7 +6575,7 @@ package body Sem_Ch6 is
Enter_Overloaded_Entity (S);
Set_Is_Overriding_Operation (S);
- Check_Overriding_Indicator (S, E);
+ Check_Overriding_Indicator (S, E, Is_Primitive => True);
-- Indicate that S overrides the operation from which
-- E is inherited.
@@ -6539,7 +6601,8 @@ package body Sem_Ch6 is
Check_Dispatching_Operation (S, Empty);
end if;
- Maybe_Primitive_Operation (Is_Overriding => True);
+ Check_For_Primitive_Subprogram
+ (Is_Primitive_Subp, Is_Overriding => True);
goto Check_Inequality;
end;
@@ -6567,13 +6630,17 @@ package body Sem_Ch6 is
Set_Scope (S, Current_Scope);
- Error_Msg_N ("& conflicts with declaration#", S);
+ -- Generate error, with extra useful warning for the case
+ -- of a generic instance with no completion.
if Is_Generic_Instance (S)
and then not Has_Completion (E)
then
Error_Msg_N
- ("\instantiation cannot provide body for it", S);
+ ("instantiation cannot provide body for&", S);
+ Error_Msg_N ("\& conflicts with declaration#", S);
+ else
+ Error_Msg_N ("& conflicts with declaration#", S);
end if;
return;
@@ -6632,8 +6699,9 @@ package body Sem_Ch6 is
-- On exit, we know that S is a new entity
Enter_Overloaded_Entity (S);
- Maybe_Primitive_Operation;
- Check_Overriding_Indicator (S, Overridden_Subp);
+ Check_For_Primitive_Subprogram (Is_Primitive_Subp);
+ Check_Overriding_Indicator
+ (S, Overridden_Subp, Is_Primitive => Is_Primitive_Subp);
-- If S is a derived operation for an untagged type then by
-- definition it's not a dispatching operation (even if the parent
@@ -6701,10 +6769,9 @@ package body Sem_Ch6 is
-- analyzed. The Ekind is established in a separate loop at the end.
Param_Spec := First (T);
-
while Present (Param_Spec) loop
-
Formal := Defining_Identifier (Param_Spec);
+ Set_Never_Set_In_Source (Formal, True);
Enter_Name (Formal);
-- Case of ordinary parameters
diff --git a/gcc/ada/sem_ch6.ads b/gcc/ada/sem_ch6.ads
index f465c80..bbcc7bb 100644
--- a/gcc/ada/sem_ch6.ads
+++ b/gcc/ada/sem_ch6.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
@@ -39,7 +39,7 @@ package Sem_Ch6 is
procedure Analyze_Operator_Symbol (N : Node_Id);
procedure Analyze_Parameter_Association (N : Node_Id);
procedure Analyze_Procedure_Call (N : Node_Id);
- procedure Analyze_Return_Statement (N : Node_Id);
+ procedure Analyze_Simple_Return_Statement (N : Node_Id);
procedure Analyze_Subprogram_Declaration (N : Node_Id);
procedure Analyze_Subprogram_Body (N : Node_Id);
generated by cgit v1.1 at 2025-08-22 02:13:03 +0000