From a9bd21a1729de00c2bd0b4e8f370f1c233777584 Mon Sep 17 00:00:00 2001 From: charlet Date: Tue, 14 Aug 2007 08:38:20 +0000 Subject: [PATCH] 2007-08-14 Ed Schonberg Robert Dewar Javier Miranda Gary Dismukes * 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 git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@127415 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/einfo.adb | 133 +++++++- gcc/ada/einfo.ads | 132 +++++-- gcc/ada/sem_ch6.adb | 967 ++++++++++++++++++++++++++++------------------------ gcc/ada/sem_ch6.ads | 4 +- 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 9d4c2e0..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 ;" - -- 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); -- 2.7.4