From 33b6091b36eeca2351781d479a67f4f9cb1731ee Mon Sep 17 00:00:00 2001 From: charlet Date: Wed, 15 Feb 2006 09:38:39 +0000 Subject: [PATCH] 2006-02-13 Ed Schonberg Javier Miranda Robert Dewar Gary Dismukes * exp_ch6.adb (Expand_Inlined_Call): Handle calls to functions that return unconstrained arrays. Update comments. (Expand_Call): An indirect call through an access parameter of a protected operation is not a protected call. Add circuit to raise CE in Ada 2005 mode following call to Raise_Exception. (Register_DT_Entry): Do nothing if the run-time does not give support to abstract interfaces. (Freeze_Subprogram): In case of dispatching operations, do not generate code to register the operation in the dispatch table if the source is compiled with No_Dispatching_Calls. (Register_Predefined_DT_Entry): Generate code that calls the new run-time subprogram Set_Predefined_Prim_Op_Address instead of Set_Prim_Op_Address. * sem_ch5.adb (Analyze_Assignment_Statement): Do not apply length checks on array assignments if the right-hand side is a function call that has been inlined. Check is performed on the assignment in the block. (Process_Bounds): If bounds and range are overloaded, apply preference rule for root operations to disambiguate, and diagnose true ambiguity. (Analyze_Assignment): Propagate the tag for a class-wide assignment with a tag-indeterminate right-hand side even when Expander_Active is True. Needed to ensure that dispatching calls to T'Input are allowed and get the tag of the target class-wide object. * sem_ch6.adb (New_Overloaded_Entity): Handle entities that override an inherited primitive operation that already overrides several abstract interface primitives. For transitivity, the new entity must also override all the abstract interface primitives covered by the inherited overriden primitive. Emit warning if new entity differs from homograph in same scope only in that one has an access parameter and the other one has a parameter of a general access type with the same designated type, at the same position in the signature. (Make_Inequality_Operator): Use source locations of parameters and subtype marks from corresponding equality operator when creating the tree structure for the implicit declaration of "/=". This does not change anything in behaviour except that the decoration of the components of the subtree created for "/=" allows ASIS to get the string images of the corresponding identifiers. (Analyze_Return_Statement): Remove '!' in warning message. (Check_Statement_Sequence): Likewise. (Analyze_Subprogram_Body): For an access parameter whose designated type is an incomplete type imported through a limited_with clause, use the type of the corresponding formal in the body. (Check_Returns): Implicit return in No_Return procedure now raises Program_Error with a compile time warning, instead of beging illegal. (Has_Single_Return): Function returning unconstrained type cannot be inlined if expression in unique return statement is not an identifier. (Build_Body_To_Inline): It is possible to inline a function call that returns an unconstrained type if all return statements in the function return the same local variable. Subsidiary procedure Has_Single_Return verifies that the body conforms to this restriction. * sem_res.adb (Resolve_Equality_Op): If the operands do not have the same type, and one of them is of an anonymous access type, convert the other operand to it, so that this is a valid binary operation for gigi. (Resolve_Type_Conversion): Handle subtypes of protected types and task types when accessing to the corresponding record type. (Resolve_Allocator): Add '\' in 2-line warning message. Remove '!' in warning message. (Resolve_Call): Add '\' in 2-line warning message. (Valid_Conversion): Likewise. (Resolve_Overloaded_Selected_Component): If disambiguation succeeds, the resulting type may be an access type with an implicit dereference. Obtain the proper component from the designated type. (Make_Call_Into_Operator): Handle properly a call to predefined equality given by an expanded name with prefix Standard, when the operands are of an anonymous access type. (Check_Fully_Declared_Prefix): New procedure, subsidiary of Resolve_ Explicit_Dereference and Resolve_Selected_Component, to verify that the prefix of the expression is not of an incomplete type. Allows full diagnoses of all semantic errors. (Resolve_Actuals): If the actual is an allocator whose directly designated type is a class-wide interface we build an anonymous access type to use it as the type of the allocator. Later, when the subprogram call is expanded, if the interface has a secondary dispatch table the expander will add a type conversion to force the displacement of the pointer. (Resolve_Call): If a function that returns an unconstrained type is marked Inlined_Always and inlined, the call will be inlined and does not require the creation of a transient scope. (Check_Direct_Boolean_Op): Removed (Resolve_Comparison_Op): Remove call to above (Resolve_Equality_Op): Remove call to above (Resolve_Logical_Op): Inline above, since this is only call. (Valid_Conversion): Handle properly conversions between arrays of convertible anonymous access types. PR ada/25885 (Set_Literal_String_Subtype): If the lower bound is not static, wrap the literal in an unchecked conversion, because GCC 4.x needs a static value for a string bound. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@111062 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/exp_ch6.adb | 251 ++++++++++++++++++++++++----- gcc/ada/sem_ch5.adb | 175 ++++++++++++++++---- gcc/ada/sem_ch6.adb | 372 ++++++++++++++++++++++++++++++++---------- gcc/ada/sem_res.adb | 453 +++++++++++++++++++++++++++++++++++----------------- 4 files changed, 950 insertions(+), 301 deletions(-) diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index bb9407c7ffb..c42b1f3c6cf 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -698,6 +698,11 @@ package body Exp_Ch6 is -- Processing for OUT or IN OUT parameter else + -- Kill current value indications for the temporary variable we + -- created, since we just passed it as an OUT parameter. + + Kill_Current_Values (Temp); + -- If type conversion, use reverse conversion on exit if Nkind (Actual) = N_Type_Conversion then @@ -1265,7 +1270,7 @@ package body Exp_Ch6 is Set_First_Named_Actual (N, Actual_Expr); if No (Prev) then - if not Present (Parameter_Associations (N)) then + if No (Parameter_Associations (N)) then Set_Parameter_Associations (N, New_List); Append (Insert_Param, Parameter_Associations (N)); end if; @@ -1830,11 +1835,10 @@ package body Exp_Ch6 is Check_Valid_Lvalue_Subscripts (Actual); end if; - -- Mark any scalar OUT parameter that is a simple variable - -- as no longer known to be valid (unless the type is always - -- valid). This reflects the fact that if an OUT parameter - -- is never set in a procedure, then it can become invalid - -- on return from the procedure. + -- Mark any scalar OUT parameter that is a simple variable as no + -- longer known to be valid (unless the type is always valid). This + -- reflects the fact that if an OUT parameter is never set in a + -- procedure, then it can become invalid on the procedure return. if Ekind (Formal) = E_Out_Parameter and then Is_Entity_Name (Actual) @@ -1844,14 +1848,15 @@ package body Exp_Ch6 is Set_Is_Known_Valid (Entity (Actual), False); end if; - -- For an OUT or IN OUT parameter of an access type, if the - -- actual is an entity, then it is no longer known to be non-null. + -- For an OUT or IN OUT parameter, if the actual is an entity, then + -- clear current values, since they can be clobbered. We are probably + -- doing this in more places than we need to, but better safe than + -- sorry when it comes to retaining bad current values! if Ekind (Formal) /= E_In_Parameter and then Is_Entity_Name (Actual) - and then Is_Access_Type (Etype (Actual)) then - Set_Is_Known_Non_Null (Entity (Actual), False); + Kill_Current_Values (Entity (Actual)); end if; -- If the formal is class wide and the actual is an aggregate, force @@ -1894,11 +1899,11 @@ package body Exp_Ch6 is Next_Formal (Formal); end loop; - -- If we are expanding a rhs of an assignement we need to check if - -- tag propagation is needed. This code belongs theorically in Analyze - -- Assignment but has to be done earlier (bottom-up) because the - -- assignment might be transformed into a declaration for an uncons- - -- trained value, if the expression is classwide. + -- If we are expanding a rhs of an assignment we need to check if tag + -- propagation is needed. You might expect this processing to be in + -- Analyze_Assignment but has to be done earlier (bottom-up) because the + -- assignment might be transformed to a declaration for an unconstrained + -- value if the expression is classwide. if Nkind (N) = N_Function_Call and then Is_Tag_Indeterminate (N) @@ -2016,6 +2021,8 @@ package body Exp_Ch6 is end loop; end if; + -- The below setting of Entity is suspect, see F109-018 discussion??? + Set_Entity (Name (N), Parent_Subp); if Is_Abstract (Parent_Subp) @@ -2337,10 +2344,16 @@ package body Exp_Ch6 is -- call, or a protected function call. Protected procedure calls are -- rewritten as entry calls and handled accordingly. + -- In Ada 2005, this may be an indirect call to an access parameter + -- that is an access_to_subprogram. In that case the anonymous type + -- has a scope that is a protected operation, but the call is a + -- regular one. + Scop := Scope (Subp); if Nkind (N) /= N_Entry_Call_Statement and then Is_Protected_Type (Scop) + and then Ekind (Subp) /= E_Subprogram_Type then -- If the call is an internal one, it is rewritten as a call to -- to the corresponding unprotected subprogram. @@ -2498,6 +2511,28 @@ package body Exp_Ch6 is end if; end; end if; + + -- Special processing for Ada 2005 AI-329, which requires a call to + -- Raise_Exception to raise Constraint_Error if the Exception_Id is + -- null. Note that we never need to do this in GNAT mode, or if the + -- parameter to Raise_Exception is a use of Identity, since in these + -- cases we know that the parameter is never null. + + if Ada_Version >= Ada_05 + and then not GNAT_Mode + and then Is_RTE (Subp, RE_Raise_Exception) + and then (Nkind (First_Actual (N)) /= N_Attribute_Reference + or else Attribute_Name (First_Actual (N)) /= Name_Identity) + then + declare + RCE : constant Node_Id := + Make_Raise_Constraint_Error (Loc, + Reason => CE_Null_Exception_Id); + begin + Insert_After (N, RCE); + Analyze (RCE); + end; + end if; end Expand_Call; -------------------------- @@ -2519,6 +2554,7 @@ package body Exp_Ch6 is Blk : Node_Id; Bod : Node_Id; Decl : Node_Id; + Decls : constant List_Id := New_List; Exit_Lab : Entity_Id := Empty; F : Entity_Id; A : Node_Id; @@ -2528,9 +2564,23 @@ package body Exp_Ch6 is Num_Ret : Int := 0; Ret_Type : Entity_Id; Targ : Node_Id; + Targ1 : Node_Id; Temp : Entity_Id; Temp_Typ : Entity_Id; + Is_Unc : constant Boolean := + Is_Array_Type (Etype (Subp)) + and then not Is_Constrained (Etype (Subp)); + -- If the type returned by the function is unconstrained and the + -- call can be inlined, special processing is required. + + procedure Find_Result; + -- For a function that returns an unconstrained type, retrieve the + -- name of the single variable that is the expression of a return + -- statement in the body of the function. Build_Body_To_Inline has + -- verified that this variable is unique, even in the presence of + -- multiple return statements. + procedure Make_Exit_Label; -- Build declaration for exit label to be used in Return statements @@ -2557,6 +2607,50 @@ package body Exp_Ch6 is function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean; -- Determine whether a formal parameter is used only once in Orig_Bod + ----------------- + -- Find_Result -- + ----------------- + + procedure Find_Result is + Decl : Node_Id; + Id : Node_Id; + + function Get_Return (N : Node_Id) return Traverse_Result; + -- Recursive function to locate return statements in body. + + function Get_Return (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Return_Statement then + Id := Expression (N); + return Abandon; + else + return OK; + end if; + end Get_Return; + + procedure Find_It is new Traverse_Proc (Get_Return); + + -- Start of processing for Find_Result + + begin + Find_It (Handled_Statement_Sequence (Orig_Bod)); + + -- At this point the body is unanalyzed. Traverse the list of + -- declarations to locate the defining_identifier for it. + + Decl := First (Declarations (Blk)); + + while Present (Decl) loop + if Chars (Defining_Identifier (Decl)) = Chars (Id) then + Targ1 := Defining_Identifier (Decl); + exit; + + else + Next (Decl); + end if; + end loop; + end Find_Result; + --------------------- -- Make_Exit_Label -- --------------------- @@ -2746,7 +2840,11 @@ package body Exp_Ch6 is Insert_After (Parent (Entity (N)), Blk); elsif Nkind (Parent (N)) = N_Assignment_Statement - and then Is_Entity_Name (Name (Parent (N))) + and then + (Is_Entity_Name (Name (Parent (N))) + or else + (Nkind (Name (Parent (N))) = N_Explicit_Dereference + and then Is_Entity_Name (Prefix (Name (Parent (N)))))) then -- Replace assignment with the block @@ -2770,6 +2868,9 @@ package body Exp_Ch6 is elsif Nkind (Parent (N)) = N_Object_Declaration then Set_Expression (Parent (N), Empty); Insert_After (Parent (N), Blk); + + elsif Is_Unc then + Insert_Before (Parent (N), Blk); end if; end Rewrite_Function_Call; @@ -2907,6 +3008,13 @@ package body Exp_Ch6 is Set_Declarations (Blk, New_List); end if; + -- For the unconstrained case, capture the name of the local + -- variable that holds the result. + + if Is_Unc then + Find_Result; + end if; + -- If this is a derived function, establish the proper return type if Present (Orig_Subp) @@ -3022,7 +3130,7 @@ package body Exp_Ch6 is Name => New_A); end if; - Prepend (Decl, Declarations (Blk)); + Append (Decl, Decls); Set_Renamed_Object (F, Temp); end if; @@ -3034,7 +3142,7 @@ package body Exp_Ch6 is -- declaration, create a temporary as a target. The declaration for -- the temporary may be subsequently optimized away if the body is a -- single expression, or if the left-hand side of the assignment is - -- simple enough. + -- simple enough, i.e. an entity or an explicit dereference of one. if Ekind (Subp) = E_Function then if Nkind (Parent (N)) = N_Assignment_Statement @@ -3042,6 +3150,12 @@ package body Exp_Ch6 is then Targ := Name (Parent (N)); + elsif Nkind (Parent (N)) = N_Assignment_Statement + and then Nkind (Name (Parent (N))) = N_Explicit_Dereference + and then Is_Entity_Name (Prefix (Name (Parent (N)))) + then + Targ := Name (Parent (N)); + else -- Replace call with temporary and create its declaration @@ -3049,19 +3163,39 @@ package body Exp_Ch6 is Make_Defining_Identifier (Loc, New_Internal_Name ('C')); Set_Is_Internal (Temp); - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Temp, - Object_Definition => - New_Occurrence_Of (Ret_Type, Loc)); + -- For the unconstrained case. the generated temporary has the + -- same constrained declaration as the result variable. + -- It may eventually be possible to remove that temporary and + -- use the result variable directly. + + if Is_Unc then + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => + New_Copy_Tree (Object_Definition (Parent (Targ1)))); + + Replace_Formals (Decl); + + else + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => + New_Occurrence_Of (Ret_Type, Loc)); + + Set_Etype (Temp, Ret_Type); + end if; Set_No_Initialization (Decl); - Insert_Action (N, Decl); + Append (Decl, Decls); Rewrite (N, New_Occurrence_Of (Temp, Loc)); Targ := Temp; end if; end if; + Insert_Actions (N, Decls); + -- Traverse the tree and replace formals with actuals or their thunks. -- Attach block to tree before analysis and rewriting. @@ -3122,6 +3256,18 @@ package body Exp_Ch6 is Rewrite_Procedure_Call (N, Blk); else Rewrite_Function_Call (N, Blk); + + -- For the unconstrained case, the replacement of the call has been + -- made prior to the complete analysis of the generated declarations. + -- Propagate the proper type now. + + if Is_Unc then + if Nkind (N) = N_Identifier then + Set_Etype (N, Etype (Entity (N))); + else + Set_Etype (N, Etype (Targ1)); + end if; + end if; end if; Restore_Env; @@ -3280,8 +3426,8 @@ package body Exp_Ch6 is Proc := Entity (Name (Parent (N))); - F := First_Formal (Proc); - A := First_Actual (Parent (N)); + F := First_Formal (Proc); + A := First_Actual (Parent (N)); while A /= N loop Next_Formal (F); Next_Actual (A); @@ -4133,8 +4279,7 @@ package body Exp_Ch6 is -- (Ada 2005): Register an interface primitive in a secondary dispatch -- table. If Prim overrides an ancestor primitive of its associated -- tagged-type then Ancestor_Iface_Prim indicates the entity of that - -- immediate ancestor associated with the interface; otherwise Prim and - -- Ancestor_Iface_Prim have the same info. + -- immediate ancestor associated with the interface. procedure Register_Predefined_DT_Entry (Prim : Entity_Id); -- (Ada 2005): Register a predefined primitive in all the secondary @@ -4192,7 +4337,7 @@ package body Exp_Ch6 is Skip_Controlling_Formals => True) and then DT_Position (Prim_Op) = DT_Position (E) and then Etype (DTC_Entity (Prim_Op)) = RTE (RE_Tag) - and then not Present (Abstract_Interface_Alias (Prim_Op)) + and then No (Abstract_Interface_Alias (Prim_Op)) then if Overriden_Op = Empty then Overriden_Op := Prim_Op; @@ -4268,7 +4413,14 @@ package body Exp_Ch6 is Thunk_Id : Entity_Id; begin - if not Present (Ancestor_Iface_Prim) then + -- Nothing to do if the run-time does not give support to abstract + -- interfaces. + + if not (RTE_Available (RE_Interface_Tag)) then + return; + end if; + + if No (Ancestor_Iface_Prim) then Prim_Typ := Scope (DTC_Entity (Alias (Prim))); Iface_Typ := Scope (DTC_Entity (Abstract_Interface_Alias (Prim))); @@ -4373,8 +4525,9 @@ package body Exp_Ch6 is begin Prim_Typ := Scope (DTC_Entity (Prim)); - if not Present (Access_Disp_Table (Prim_Typ)) - or else not Present (Abstract_Interfaces (Prim_Typ)) + if No (Access_Disp_Table (Prim_Typ)) + or else No (Abstract_Interfaces (Prim_Typ)) + or else not RTE_Available (RE_Interface_Tag) then return; end if; @@ -4404,7 +4557,7 @@ package body Exp_Ch6 is Insert_After (N, New_Thunk); Insert_After (New_Thunk, Make_DT_Access_Action (Node (Iface_Typ), - Action => Set_Prim_Op_Address, + Action => Set_Predefined_Prim_Op_Address, Args => New_List ( Unchecked_Convert_To (RTE (RE_Tag), New_Reference_To (Node (Iface_DT_Ptr), Loc)), @@ -4438,9 +4591,20 @@ package body Exp_Ch6 is then Check_Overriding_Operation (E); + -- Ada 95 case: Register the subprogram in the primary dispatch table + if Ada_Version < Ada_05 then - Insert_After (N, - Fill_DT_Entry (Sloc (N), Prim => E)); + + -- Do not register the subprogram in the dispatch table if we + -- are compiling with the No_Dispatching_Calls restriction. + + if not Restriction_Active (No_Dispatching_Calls) then + Insert_After (N, + Fill_DT_Entry (Sloc (N), Prim => E)); + end if; + + -- Ada 2005 case: Register the subprogram in the secondary dispatch + -- tables associated with abstract interfaces. else declare @@ -4448,8 +4612,8 @@ package body Exp_Ch6 is begin -- There is no dispatch table associated with abstract - -- interface types; each type implementing interfaces - -- will fill the associated secondary DT entries. + -- interface types. Each type implementing interfaces will + -- fill the associated secondary DT entries. if not Is_Interface (Typ) or else Present (Alias (E)) @@ -4465,12 +4629,15 @@ package body Exp_Ch6 is else -- Generate thunks for all the predefined operations - if Is_Predefined_Dispatching_Operation (E) then - Register_Predefined_DT_Entry (E); + if not Restriction_Active (No_Dispatching_Calls) then + if Is_Predefined_Dispatching_Operation (E) then + Register_Predefined_DT_Entry (E); + end if; + + Insert_After (N, + Fill_DT_Entry (Sloc (N), Prim => E)); end if; - Insert_After (N, - Fill_DT_Entry (Sloc (N), Prim => E)); Check_Overriding_Inherited_Interfaces (E); end if; end if; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 896a8fb7a9e..241b838eb7e 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -81,12 +81,17 @@ package body Sem_Ch5 is T1 : Entity_Id; T2 : Entity_Id; Decl : Node_Id; - Ent : Entity_Id; procedure Diagnose_Non_Variable_Lhs (N : Node_Id); -- N is the node for the left hand side of an assignment, and it -- is not a variable. This routine issues an appropriate diagnostic. + procedure Kill_Lhs; + -- This is called to kill current value settings of a simple variable + -- on the left hand side. We call it if we find any error in analyzing + -- the assignment, and at the end of processing before setting any new + -- current values in place. + procedure Set_Assignment_Type (Opnd : Node_Id; Opnd_Type : in out Entity_Id); @@ -159,6 +164,23 @@ package body Sem_Ch5 is end if; end Diagnose_Non_Variable_Lhs; + -------------- + -- Kill_LHS -- + -------------- + + procedure Kill_Lhs is + begin + if Is_Entity_Name (Lhs) then + declare + Ent : constant Entity_Id := Entity (Lhs); + begin + if Present (Ent) then + Kill_Current_Values (Ent); + end if; + end; + end if; + end Kill_Lhs; + ------------------------- -- Set_Assignment_Type -- ------------------------- @@ -225,6 +247,9 @@ package body Sem_Ch5 is begin Analyze (Rhs); Analyze (Lhs); + + -- Start type analysis for assignment + T1 := Etype (Lhs); -- In the most general case, both Lhs and Rhs can be overloaded, and we @@ -305,6 +330,7 @@ package body Sem_Ch5 is if T1 = Any_Type then Error_Msg_N ("no valid types for left-hand side for assignment", Lhs); + Kill_Lhs; return; end if; end if; @@ -350,6 +376,7 @@ package body Sem_Ch5 is and then Ekind (T1) = E_Incomplete_Type then Error_Msg_N ("invalid use of incomplete type", Lhs); + Kill_Lhs; return; end if; @@ -361,6 +388,7 @@ package body Sem_Ch5 is -- Remaining steps are skipped if Rhs was syntactically in error if Rhs = Error then + Kill_Lhs; return; end if; @@ -368,6 +396,7 @@ package body Sem_Ch5 is if not Covers (T1, T2) then Wrong_Type (Rhs, Etype (Lhs)); + Kill_Lhs; return; end if; @@ -395,6 +424,7 @@ package body Sem_Ch5 is end if; if T1 = Any_Type or else T2 = Any_Type then + Kill_Lhs; return; end if; @@ -411,13 +441,10 @@ package body Sem_Ch5 is Error_Msg_N ("dynamically tagged expression required!", Rhs); end if; - -- Tag propagation is done only in semantics mode only. If expansion - -- is on, the rhs tag indeterminate function call has been expanded - -- and tag propagation would have happened too late, so the - -- propagation take place in expand_call instead. + -- Propagate the tag from a class-wide target to the rhs when the rhs + -- is a tag-indeterminate call. - if not Expander_Active - and then Is_Class_Wide_Type (T1) + if Is_Class_Wide_Type (T1) and then Is_Tag_Indeterminate (Rhs) then Propagate_Tag (Lhs, Rhs); @@ -457,10 +484,18 @@ package body Sem_Ch5 is if Is_Scalar_Type (T1) then Apply_Scalar_Range_Check (Rhs, Etype (Lhs)); + -- For array types, verify that lengths match. If the right hand side + -- if a function call that has been inlined, the assignment has been + -- rewritten as a block, and the constraint check will be applied to the + -- assignment within the block. + elsif Is_Array_Type (T1) and then (Nkind (Rhs) /= N_Type_Conversion - or else Is_Constrained (Etype (Rhs))) + or else Is_Constrained (Etype (Rhs))) + and then + (Nkind (Rhs) /= N_Function_Call + or else Nkind (N) /= N_Block_Statement) then -- Assignment verifies that the length of the Lsh and Rhs are equal, -- but of course the indices do not have to match. If the right-hand @@ -520,33 +555,59 @@ package body Sem_Ch5 is Error_Msg_CRT ("composite assignment", N); end if; - -- One more step. Let's see if we have a simple assignment of a - -- known at compile time value to a simple variable. If so, we - -- can record the value as the current value providing that: + -- Final step. If left side is an entity, then we may be able to + -- reset the current tracked values to new safe values. We only have + -- something to do if the left side is an entity name, and expansion + -- has not modified the node into something other than an assignment, + -- and of course we only capture values if it is safe to do so. - -- We still have a simple assignment statement (no expansion - -- activity has modified it in some peculiar manner) + if Is_Entity_Name (Lhs) + and then Nkind (N) = N_Assignment_Statement + then + declare + Ent : constant Entity_Id := Entity (Lhs); - -- The type is a discrete type + begin + if Safe_To_Capture_Value (N, Ent) then - -- The assignment is to a named entity + -- If we are assigning an access type and the left side is an + -- entity, then make sure that the Is_Known_[Non_]Null flags + -- properly reflect the state of the entity after assignment. - -- The value is known at compile time + if Is_Access_Type (T1) then + if Known_Non_Null (Rhs) then + Set_Is_Known_Non_Null (Ent, True); - if Nkind (N) /= N_Assignment_Statement - or else not Is_Discrete_Type (T1) - or else not Is_Entity_Name (Lhs) - or else not Compile_Time_Known_Value (Rhs) - then - return; - end if; + elsif Known_Null (Rhs) + and then not Can_Never_Be_Null (Ent) + then + Set_Is_Known_Null (Ent, True); + + else + Set_Is_Known_Null (Ent, False); - Ent := Entity (Lhs); + if not Can_Never_Be_Null (Ent) then + Set_Is_Known_Non_Null (Ent, False); + end if; + end if; - -- Capture value if safe to do so + -- For discrete types, we may be able to set the current value + -- if the value is known at compile time. - if Safe_To_Capture_Value (N, Ent) then - Set_Current_Value (Ent, Rhs); + elsif Is_Discrete_Type (T1) + and then Compile_Time_Known_Value (Rhs) + then + Set_Current_Value (Ent, Rhs); + else + Set_Current_Value (Ent, Empty); + end if; + + -- If not safe to capture values, kill them + + else + Kill_Lhs; + end if; + end; end if; end Analyze_Assignment; @@ -1193,6 +1254,7 @@ package body Sem_Ch5 is New_Lo_Bound : Node_Id := Empty; New_Hi_Bound : Node_Id := Empty; Typ : Entity_Id; + Save_Analysis : Boolean; function One_Bound (Original_Bound : Node_Id; @@ -1268,9 +1330,64 @@ package body Sem_Ch5 is begin -- Determine expected type of range by analyzing separate copy + -- Do the analysis and resolution of the copy of the bounds with + -- expansion disabled, to prevent the generation of finalization + -- actions on each bound. This prevents memory leaks when the + -- bounds contain calls to functions returning controlled arrays. Set_Parent (R_Copy, Parent (R)); - Pre_Analyze_And_Resolve (R_Copy); + Save_Analysis := Full_Analysis; + Full_Analysis := False; + Expander_Mode_Save_And_Set (False); + + Analyze (R_Copy); + + if Is_Overloaded (R_Copy) then + + -- Apply preference rules for range of predefined integer types, + -- or diagnose true ambiguity. + + declare + I : Interp_Index; + It : Interp; + Found : Entity_Id := Empty; + + begin + Get_First_Interp (R_Copy, I, It); + while Present (It.Typ) loop + if Is_Discrete_Type (It.Typ) then + if No (Found) then + Found := It.Typ; + else + if Scope (Found) = Standard_Standard then + null; + + elsif Scope (It.Typ) = Standard_Standard then + Found := It.Typ; + + else + -- Both of them are user-defined + + Error_Msg_N + ("ambiguous bounds in range of iteration", + R_Copy); + Error_Msg_N ("\possible interpretations:", R_Copy); + Error_Msg_NE ("\} ", R_Copy, Found); + Error_Msg_NE ("\} ", R_Copy, It.Typ); + exit; + end if; + end if; + end if; + + Get_Next_Interp (I, It); + end loop; + end; + end if; + + Resolve (R_Copy); + Expander_Mode_Restore; + Full_Analysis := Save_Analysis; + Typ := Etype (R_Copy); -- If the type of the discrete range is Universal_Integer, then diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index b6c262b5ad4..66a24306a85 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -77,6 +77,16 @@ with Validsw; use Validsw; package body Sem_Ch6 is + -- The following flag is used to indicate that two formals in two + -- subprograms being checked for conformance differ only in that one is + -- an access parameter while the other is of a general access type with + -- the same designated type. In this case, if the rest of the signatures + -- match, a call to either subprogram may be ambiguous, which is worth + -- a warning. The flag is set in Compatible_Types, and the warning emitted + -- in New_Overloaded_Entity. + + May_Hide_Profile : Boolean := False; + ----------------------- -- Local Subprograms -- ----------------------- @@ -141,14 +151,17 @@ package body Sem_Ch6 is procedure Check_Returns (HSS : Node_Id; Mode : Character; - Err : out Boolean); - -- Called to check for missing return statements in a function body, or - -- for returns present in a procedure body which has No_Return set. L is - -- the handled statement sequence for the subprogram body. This procedure - -- checks all flow paths to make sure they either have return (Mode = 'F') - -- or do not have a return (Mode = 'P'). The flag Err is set if there are - -- any control paths not explicitly terminated by a return in the function - -- case, and is True otherwise. + Err : out Boolean; + Proc : Entity_Id := Empty); + -- Called to check for missing return statements in a function body, or for + -- returns present in a procedure body which has No_Return set. L is the + -- handled statement sequence for the subprogram body. This procedure + -- checks all flow paths to make sure they either have return (Mode = 'F', + -- used for functions) or do not have a return (Mode = 'P', used for + -- No_Return procedures). The flag Err is set if there are any control + -- paths not explicitly terminated by a return in the function case, and is + -- True otherwise. Proc is the entity for the procedure case and is used + -- in posting the warning message. function Conforming_Types (T1 : Entity_Id; @@ -790,7 +803,7 @@ package body Sem_Ch6 is Error_Msg_N ("cannot return a local value by reference?", N); Error_Msg_NE - ("& will be raised at run time?!", + ("\& will be raised at run time?", N, Standard_Program_Error); end if; @@ -1328,7 +1341,38 @@ package body Sem_Ch6 is (Etype (First_Entity (Spec_Id)))); end if; - -- Comment needed here, since this is not Ada 2005 stuff! ??? + -- Ada 2005: A formal that is an access parameter may have a + -- designated type imported through a limited_with clause, while + -- the body has a regular with clause. Update the types of the + -- formals accordingly, so that the non-limited view of each type + -- is available in the body. We have already verified that the + -- declarations are type-conformant. + + if Ada_Version >= Ada_05 then + declare + F_Spec : Entity_Id; + F_Body : Entity_Id; + + begin + F_Spec := First_Formal (Spec_Id); + F_Body := First_Formal (Body_Id); + + while Present (F_Spec) loop + if Ekind (Etype (F_Spec)) = E_Anonymous_Access_Type + and then + From_With_Type (Designated_Type (Etype (F_Spec))) + then + Set_Etype (F_Spec, Etype (F_Body)); + end if; + + Next_Formal (F_Spec); + Next_Formal (F_Body); + end loop; + end; + end if; + + -- Now make the formals visible, and place subprogram + -- on scope stack. Install_Formals (Spec_Id); Last_Formal := Last_Entity (Spec_Id); @@ -1508,7 +1552,7 @@ package body Sem_Ch6 is and then Present (Spec_Id) and then No_Return (Spec_Id) then - Check_Returns (HSS, 'P', Missing_Ret); + Check_Returns (HSS, 'P', Missing_Ret, Spec_Id); end if; -- Now we are going to check for variables that are never modified in @@ -1873,6 +1917,13 @@ package body Sem_Ch6 is -- conflict with subsequent inlinings, so that it is unsafe to try to -- inline in such a case. + function Has_Single_Return return Boolean; + -- In general we cannot inline functions that return unconstrained + -- type. However, we can handle such functions if all return statements + -- return a local variable that is the only declaration in the body + -- of the function. In that case the call can be replaced by that + -- local variable as is done for other inlined calls. + procedure Remove_Pragmas; -- A pragma Unreferenced that mentions a formal parameter has no -- meaning when the body is inlined and the formals are rewritten. @@ -2064,6 +2115,57 @@ package body Sem_Ch6 is return False; end Has_Pending_Instantiation; + ------------------------ + -- Has_Single_Return -- + ------------------------ + + function Has_Single_Return return Boolean is + Return_Statement : Node_Id := Empty; + + function Check_Return (N : Node_Id) return Traverse_Result; + + ------------------ + -- Check_Return -- + ------------------ + + function Check_Return (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Return_Statement then + if Present (Expression (N)) + and then Is_Entity_Name (Expression (N)) + then + if No (Return_Statement) then + Return_Statement := N; + return OK; + + elsif Chars (Expression (N)) = + Chars (Expression (Return_Statement)) + then + return OK; + + else + return Abandon; + end if; + + else + -- Expression has wrong form + + return Abandon; + end if; + + else + return OK; + end if; + end Check_Return; + + function Check_All_Returns is new Traverse_Func (Check_Return); + + -- Start of processing for Has_Single_Return + + begin + return Check_All_Returns (N) = OK; + end Has_Single_Return; + -------------------- -- Remove_Pragmas -- -------------------- @@ -2138,6 +2240,7 @@ package body Sem_Ch6 is and then not Is_Scalar_Type (Etype (Subp)) and then not Is_Access_Type (Etype (Subp)) and then not Is_Constrained (Etype (Subp)) + and then not Has_Single_Return then Cannot_Inline ("cannot inline & (unconstrained return type)?", N, Subp); @@ -2963,7 +3066,8 @@ package body Sem_Ch6 is procedure Check_Returns (HSS : Node_Id; Mode : Character; - Err : out Boolean) + Err : out Boolean; + Proc : Entity_Id := Empty) is Handler : Node_Id; @@ -3040,6 +3144,9 @@ package body Sem_Ch6 is -- missing return curious, and raising Program_Error does not -- seem such a bad behavior if this does occur. + -- Note that in the Ada 2005 case for Raise_Exception, the actual + -- behavior will be to raise Constraint_Error (see AI-329). + if Is_RTE (Entity (Name (Last_Stm)), RE_Raise_Exception) or else Is_RTE (Entity (Name (Last_Stm)), RE_Reraise_Occurrence) @@ -3208,10 +3315,9 @@ package body Sem_Ch6 is -- If we fall through, issue appropriate message 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", @@ -3225,10 +3331,24 @@ package body Sem_Ch6 is Err := True; + -- Otherwise we have the case of a procedure marked No_Return + else Error_Msg_N - ("implied return after this statement not allowed (No_Return)", + ("?implied return after this statement will raise Program_Error", Last_Stm); + Error_Msg_NE + ("?procedure & is marked as No_Return", + Last_Stm, Proc); + + declare + RE : constant Node_Id := + Make_Raise_Program_Error (Sloc (Last_Stm), + Reason => PE_Implicit_Return); + begin + Insert_After (Last_Stm, RE); + Analyze (RE); + end; end if; end Check_Statement_Sequence; @@ -3598,6 +3718,17 @@ package body Sem_Ch6 is -- Otherwise definitely no match else + if ((Ekind (Type_1) = E_Anonymous_Access_Type + and then Is_Access_Type (Type_2)) + or else (Ekind (Type_2) = E_Anonymous_Access_Type + and then Is_Access_Type (Type_1))) + and then + Conforming_Types + (Designated_Type (Type_1), Designated_Type (Type_2), Ctype) + then + May_Hide_Profile := True; + end if; + return False; end if; end Conforming_Types; @@ -3739,7 +3870,7 @@ package body Sem_Ch6 is or else Explicit_Suppress (Scope (E), Accessibility_Check)) and then - (not Present (P_Formal) + (No (P_Formal) or else Present (Extra_Accessibility (P_Formal))) then -- Temporary kludge: for now we avoid creating the extra formal @@ -4403,7 +4534,6 @@ package body Sem_Ch6 is procedure Install_Entity (E : Entity_Id) is Prev : constant Entity_Id := Current_Entity (E); - begin Set_Is_Immediately_Visible (E); Set_Current_Entity (E); @@ -4416,10 +4546,8 @@ package body Sem_Ch6 is procedure Install_Formals (Id : Entity_Id) is F : Entity_Id; - begin F := First_Formal (Id); - while Present (F) loop Install_Entity (F); Next_Formal (F); @@ -4555,7 +4683,7 @@ package body Sem_Ch6 is Next_Formal (Formal); end loop; - if not Present (G_Typ) and then Ekind (Prev_E) = E_Function then + if No (G_Typ) and then Ekind (Prev_E) = E_Function then G_Typ := Get_Generic_Parent_Type (Base_Type (Etype (Prev_E))); end if; @@ -4611,8 +4739,8 @@ package body Sem_Ch6 is -- formal ancestor type, so the new subprogram is -- overriding. - if not Present (P_Formal) - and then not Present (N_Formal) + if No (P_Formal) + and then No (N_Formal) and then (Ekind (New_E) /= E_Function or else Types_Correspond @@ -4651,67 +4779,77 @@ package body Sem_Ch6 is Formals : List_Id; Op_Name : Entity_Id; - A : Entity_Id; - B : Entity_Id; + FF : constant Entity_Id := First_Formal (S); + NF : constant Entity_Id := Next_Formal (FF); begin - -- Check that equality was properly defined + -- Check that equality was properly defined, ignore call if not - if No (Next_Formal (First_Formal (S))) then + if No (NF) then return; end if; - A := Make_Defining_Identifier (Loc, Chars (First_Formal (S))); - B := Make_Defining_Identifier (Loc, - Chars (Next_Formal (First_Formal (S)))); - - Op_Name := Make_Defining_Operator_Symbol (Loc, Name_Op_Ne); - - Formals := New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => A, - Parameter_Type => - New_Reference_To (Etype (First_Formal (S)), Loc)), - - Make_Parameter_Specification (Loc, - Defining_Identifier => B, - Parameter_Type => - New_Reference_To (Etype (Next_Formal (First_Formal (S))), Loc))); - - Decl := - Make_Subprogram_Declaration (Loc, - Specification => - Make_Function_Specification (Loc, - Defining_Unit_Name => Op_Name, - Parameter_Specifications => Formals, - Result_Definition => New_Reference_To (Standard_Boolean, Loc))); - - -- Insert inequality right after equality if it is explicit or after - -- the derived type when implicit. These entities are created only for - -- visibility purposes, and eventually replaced in the course of - -- expansion, so they do not need to be attached to the tree and seen - -- by the back-end. Keeping them internal also avoids spurious freezing - -- problems. The declaration is inserted in the tree for analysis, and - -- removed afterwards. If the equality operator comes from an explicit - -- declaration, attach the inequality immediately after. Else the - -- equality is inherited from a derived type declaration, so insert - -- inequality after that declaration. - - if No (Alias (S)) then - Insert_After (Unit_Declaration_Node (S), Decl); - elsif Is_List_Member (Parent (S)) then - Insert_After (Parent (S), Decl); - else - Insert_After (Parent (Etype (First_Formal (S))), Decl); - end if; + declare + A : constant Entity_Id := + Make_Defining_Identifier (Sloc (FF), + Chars => Chars (FF)); + + B : constant Entity_Id := + Make_Defining_Identifier (Sloc (NF), + Chars => Chars (NF)); + + begin + Op_Name := Make_Defining_Operator_Symbol (Loc, Name_Op_Ne); + + Formals := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => A, + Parameter_Type => + New_Reference_To (Etype (First_Formal (S)), + Sloc (Etype (First_Formal (S))))), + + Make_Parameter_Specification (Loc, + Defining_Identifier => B, + Parameter_Type => + New_Reference_To (Etype (Next_Formal (First_Formal (S))), + Sloc (Etype (Next_Formal (First_Formal (S))))))); + + Decl := + Make_Subprogram_Declaration (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Op_Name, + Parameter_Specifications => Formals, + Result_Definition => + New_Reference_To (Standard_Boolean, Loc))); + + -- Insert inequality right after equality if it is explicit or after + -- the derived type when implicit. These entities are created only + -- for visibility purposes, and eventually replaced in the course of + -- expansion, so they do not need to be attached to the tree and seen + -- by the back-end. Keeping them internal also avoids spurious + -- freezing problems. The declaration is inserted in the tree for + -- analysis, and removed afterwards. If the equality operator comes + -- from an explicit declaration, attach the inequality immediately + -- after. Else the equality is inherited from a derived type + -- declaration, so insert inequality after that declaration. + + if No (Alias (S)) then + Insert_After (Unit_Declaration_Node (S), Decl); + elsif Is_List_Member (Parent (S)) then + Insert_After (Parent (S), Decl); + else + Insert_After (Parent (Etype (First_Formal (S))), Decl); + end if; - Mark_Rewrite_Insertion (Decl); - Set_Is_Intrinsic_Subprogram (Op_Name); - Analyze (Decl); - Remove (Decl); - Set_Has_Completion (Op_Name); - Set_Corresponding_Equality (Op_Name, S); - Set_Is_Abstract (Op_Name, Is_Abstract (S)); + Mark_Rewrite_Insertion (Decl); + Set_Is_Intrinsic_Subprogram (Op_Name); + Analyze (Decl); + Remove (Decl); + Set_Has_Completion (Op_Name); + Set_Corresponding_Equality (Op_Name, S); + Set_Is_Abstract (Op_Name, Is_Abstract (S)); + end; end Make_Inequality_Operator; ---------------------- @@ -5074,6 +5212,14 @@ package body Sem_Ch6 is elsif not Is_Alias_Interface and then Type_Conformant (E, S) + + -- Ada 2005 (AI-251): Do not consider here entities that cover + -- abstract interface primitives. They will be handled after + -- the overriden entity is found (see comments bellow inside + -- this subprogram). + + and then not (Is_Subprogram (E) + and then Present (Abstract_Interface_Alias (E))) then -- If the old and new entities have the same profile and one -- is not the body of the other, then this is an error, unless @@ -5159,7 +5305,7 @@ package body Sem_Ch6 is if Is_Non_Overriding_Operation (E, S) then Enter_Overloaded_Entity (S); - if not Present (Derived_Type) + if No (Derived_Type) or else Is_Tagged_Type (Derived_Type) then Check_Dispatching_Operation (S, Empty); @@ -5289,7 +5435,7 @@ package body Sem_Ch6 is -- E is inherited. if Comes_From_Source (S) then - if Present (Alias (E)) then + if Present (Alias (E)) then Set_Overridden_Operation (S, Alias (E)); else Set_Overridden_Operation (S, E); @@ -5344,6 +5490,27 @@ package body Sem_Ch6 is Check_Dispatching_Operation (S, E); + -- AI-251: Handle the case in which the entity + -- overrides a primitive operation that covered + -- several abstract interface primitives. + + declare + E1 : Entity_Id; + begin + E1 := Current_Entity_In_Scope (S); + while Present (E1) loop + if Is_Subprogram (E1) + and then Present + (Abstract_Interface_Alias (E1)) + and then Alias (E1) = E + then + Set_Alias (E1, S); + end if; + + E1 := Homonym (E1); + end loop; + end; + else Check_Dispatching_Operation (S, Empty); end if; @@ -5389,7 +5556,48 @@ package body Sem_Ch6 is end if; else - null; + -- If one subprogram has an access parameter and the other + -- a parameter of an access type, calls to either might be + -- ambiguous. Verify that parameters match except for the + -- access parameter. + + if May_Hide_Profile then + declare + F1 : Entity_Id; + F2 : Entity_Id; + begin + F1 := First_Formal (S); + F2 := First_Formal (E); + while Present (F1) and then Present (F2) loop + if Is_Access_Type (Etype (F1)) then + if not Is_Access_Type (Etype (F2)) + or else not Conforming_Types + (Designated_Type (Etype (F1)), + Designated_Type (Etype (F2)), + Type_Conformant) + then + May_Hide_Profile := False; + end if; + + elsif + not Conforming_Types + (Etype (F1), Etype (F2), Type_Conformant) + then + May_Hide_Profile := False; + end if; + + Next_Formal (F1); + Next_Formal (F2); + end loop; + + if May_Hide_Profile + and then No (F1) + and then No (F2) + then + Error_Msg_NE ("calls to& may be ambiguous?", S, S); + end if; + end; + end if; end if; Prev_Vis := E; @@ -5407,7 +5615,7 @@ package body Sem_Ch6 is -- operation was dispatching), so we don't call -- Check_Dispatching_Operation in that case. - if not Present (Derived_Type) + if No (Derived_Type) or else Is_Tagged_Type (Derived_Type) then Check_Dispatching_Operation (S, Empty); @@ -5922,6 +6130,8 @@ package body Sem_Ch6 is is Result : Boolean; begin + May_Hide_Profile := False; + Check_Conformance (New_Id, Old_Id, Type_Conformant, False, Result, Skip_Controlling_Formals => Skip_Controlling_Formals); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 45e902bccff..1a8766ae864 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -90,11 +90,6 @@ package body Sem_Res is -- Give list of candidate interpretations when a character literal cannot -- be resolved. - procedure Check_Direct_Boolean_Op (N : Node_Id); - -- N is a binary operator node which may possibly operate on Boolean - -- operands. If the operator does have Boolean operands, then a call is - -- made to check the restriction No_Direct_Boolean_Operators. - procedure Check_Discriminant_Use (N : Node_Id); -- Enforce the restrictions on the use of discriminants when constraining -- a component of a discriminated type (record or concurrent type). @@ -105,6 +100,11 @@ package body Sem_Res is -- universal must be checked for visibility during resolution -- because their type is not determinable based on their operands. + procedure Check_Fully_Declared_Prefix + (Typ : Entity_Id; + Pref : Node_Id); + -- Check that the type of the prefix of a dereference is not incomplete + function Check_Infinite_Recursion (N : Node_Id) return Boolean; -- Given a call node, N, which is known to occur immediately within the -- subprogram being called, determines whether it is a detectable case of @@ -346,19 +346,6 @@ package body Sem_Res is end if; end Analyze_And_Resolve; - ----------------------------- - -- Check_Direct_Boolean_Op -- - ----------------------------- - - procedure Check_Direct_Boolean_Op (N : Node_Id) is - begin - if Nkind (N) in N_Op - and then Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean - then - Check_Restriction (No_Direct_Boolean_Operators, N); - end if; - end Check_Direct_Boolean_Op; - ---------------------------- -- Check_Discriminant_Use -- ---------------------------- @@ -472,7 +459,7 @@ package body Sem_Res is -- Check that it is the high bound if N /= High_Bound (PN) - or else not Present (Discriminant_Default_Value (Disc)) + or else No (Discriminant_Default_Value (Disc)) then goto No_Danger; end if; @@ -600,6 +587,54 @@ package body Sem_Res is end if; end Check_For_Visible_Operator; + ---------------------------------- + -- Check_Fully_Declared_Prefix -- + ---------------------------------- + + procedure Check_Fully_Declared_Prefix + (Typ : Entity_Id; + Pref : Node_Id) + is + begin + -- Check that the designated type of the prefix of a dereference is + -- not an incomplete type. This cannot be done unconditionally, because + -- dereferences of private types are legal in default expressions. This + -- case is taken care of in Check_Fully_Declared, called below. There + -- are also 2005 cases where it is legal for the prefix to be unfrozen. + + -- This consideration also applies to similar checks for allocators, + -- qualified expressions, and type conversions. + + -- An additional exception concerns other per-object expressions that + -- are not directly related to component declarations, in particular + -- representation pragmas for tasks. These will be per-object + -- expressions if they depend on discriminants or some global entity. + -- If the task has access discriminants, the designated type may be + -- incomplete at the point the expression is resolved. This resolution + -- takes place within the body of the initialization procedure, where + -- the discriminant is replaced by its discriminal. + + if Is_Entity_Name (Pref) + and then Ekind (Entity (Pref)) = E_In_Parameter + then + null; + + -- Ada 2005 (AI-326): Tagged incomplete types allowed. The wrong usages + -- are handled by Analyze_Access_Attribute, Analyze_Assignment, + -- Analyze_Object_Renaming, and Freeze_Entity. + + elsif Ada_Version >= Ada_05 + and then Is_Entity_Name (Pref) + and then Ekind (Directly_Designated_Type (Etype (Pref))) = + E_Incomplete_Type + and then Is_Tagged_Type (Directly_Designated_Type (Etype (Pref))) + then + null; + else + Check_Fully_Declared (Typ, Parent (Pref)); + end if; + end Check_Fully_Declared_Prefix; + ------------------------------ -- Check_Infinite_Recursion -- ------------------------------ @@ -1156,6 +1191,15 @@ package body Sem_Res is Error := True; end if; + -- Ada 2005, AI-420: Predefined equality on Universal_Access + -- is available. + + elsif Ada_Version >= Ada_05 + and then (Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne) + and then Ekind (Etype (Act1)) = E_Anonymous_Access_Type + then + null; + else Opnd_Type := Base_Type (Etype (Right_Opnd (Op_Node))); @@ -1899,7 +1943,7 @@ package body Sem_Res is -- Move to next interpretation - exit Interp_Loop when not Present (It.Typ); + exit Interp_Loop when No (It.Typ); Get_Next_Interp (I, It); end loop Interp_Loop; @@ -2512,7 +2556,7 @@ package body Sem_Res is Set_First_Named_Actual (N, Actval); if No (Prev) then - if not Present (Parameter_Associations (N)) then + if No (Parameter_Associations (N)) then Set_Parameter_Associations (N, New_List (Assoc)); else Append (Assoc, Parameter_Associations (N)); @@ -2594,7 +2638,7 @@ package body Sem_Res is -- the tag check to occur and no temporary will be needed (no -- representation change can occur) and the parameter is passed by -- reference, so we go ahead and resolve the type conversion. - -- Another excpetion is the case of reference to component or + -- Another exception is the case of reference to component or -- subcomponent of a bit-packed array, in which case we want to -- defer expansion to the point the in and out assignments are -- performed. @@ -2666,6 +2710,33 @@ package body Sem_Res is end if; end if; + -- (Ada 2005: AI-251): If the actual is an allocator whose + -- directly designated type is a class-wide interface, we build + -- an anonymous access type to use it as the type of the + -- allocator. Later, when the subprogram call is expanded, if + -- the interface has a secondary dispatch table the expander + -- will add a type conversion to force the correct displacement + -- of the pointer. + + if Nkind (A) = N_Allocator then + declare + DDT : constant Entity_Id := + Directly_Designated_Type (Base_Type (Etype (F))); + New_Itype : Entity_Id; + begin + if Is_Class_Wide_Type (DDT) + and then Is_Interface (DDT) + then + New_Itype := Create_Itype (E_Anonymous_Access_Type, A); + Set_Etype (New_Itype, Etype (A)); + Init_Size_Align (New_Itype); + Set_Directly_Designated_Type (New_Itype, + Directly_Designated_Type (Etype (A))); + Set_Etype (A, New_Itype); + end if; + end; + end if; + Resolve (A, Etype (F)); end if; @@ -3090,7 +3161,8 @@ package body Sem_Res is if In_Instance_Body then Error_Msg_N ("?type in allocator has deeper level than" & " designated class-wide type", E); - Error_Msg_N ("?Program_Error will be raised at run time", E); + Error_Msg_N ("\?Program_Error will be raised at run time", + E); Rewrite (N, Make_Raise_Program_Error (Sloc (N), Reason => PE_Accessibility_Check_Failed)); @@ -3109,8 +3181,8 @@ package body Sem_Res is declare Loc : constant Source_Ptr := Sloc (N); begin - Error_Msg_N ("?allocation from empty storage pool!", N); - Error_Msg_N ("?Storage_Error will be raised at run time!", N); + Error_Msg_N ("?allocation from empty storage pool", N); + Error_Msg_N ("\?Storage_Error will be raised at run time", N); Insert_Action (N, Make_Raise_Storage_Error (Loc, Reason => SE_Empty_Storage_Pool)); @@ -3708,8 +3780,7 @@ package body Sem_Res is and then not Is_Controlling_Limited_Procedure (Nam) then Error_Msg_N - ("entry call, entry renaming or dispatching primitive " & - "of limited or synchronized interface required", N); + ("entry call or dispatching primitive of interface required", N); end if; end if; @@ -3869,7 +3940,7 @@ package body Sem_Res is then Set_Has_Recursive_Call (Nam); Error_Msg_N ("possible infinite recursion?", N); - Error_Msg_N ("Storage_Error may be raised at run time?", N); + Error_Msg_N ("\Storage_Error may be raised at run time?", N); end if; exit; @@ -3909,7 +3980,18 @@ package body Sem_Res is -- for it, precisely because we will not do it within the init proc -- itself. - if Expander_Active + -- If the subprogram is marked Inlined_Always, then even if it returns + -- an unconstrained type the call does not require use of the secondary + -- stack. + + if Is_Inlined (Nam) + and then Present (First_Rep_Item (Nam)) + and then Nkind (First_Rep_Item (Nam)) = N_Pragma + and then Chars (First_Rep_Item (Nam)) = Name_Inline_Always + then + null; + + elsif Expander_Active and then Is_Type (Etype (Nam)) and then Requires_Transient_Scope (Etype (Nam)) and then Ekind (Nam) /= E_Enumeration_Literal @@ -4120,7 +4202,6 @@ package body Sem_Res is Check_Unset_Reference (R); Generate_Operator_Reference (N, T); Eval_Relational_Op (N); - Check_Direct_Boolean_Op (N); end if; end if; end Resolve_Comparison_Op; @@ -4875,7 +4956,31 @@ package body Sem_Res is Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N)); end if; - Check_Direct_Boolean_Op (N); + -- Ada 2005: If one operand is an anonymous access type, convert + -- the other operand to it, to ensure that the underlying types + -- match in the back-end. + -- We apply the same conversion in the case one of the operands is + -- a private subtype of the type of the other. + + if Ekind (T) = E_Anonymous_Access_Type + or else Is_Private_Type (T) + then + if Etype (L) /= T then + Rewrite (L, + Make_Unchecked_Type_Conversion (Sloc (L), + Subtype_Mark => New_Occurrence_Of (T, Sloc (L)), + Expression => Relocate_Node (L))); + Analyze_And_Resolve (L, T); + end if; + + if (Etype (R)) /= T then + Rewrite (R, + Make_Unchecked_Type_Conversion (Sloc (R), + Subtype_Mark => New_Occurrence_Of (Etype (L), Sloc (R)), + Expression => Relocate_Node (R))); + Analyze_And_Resolve (R, T); + end if; + end if; end if; end Resolve_Equality_Op; @@ -4891,42 +4996,7 @@ package body Sem_Res is It : Interp; begin - -- Now that we know the type, check that this is not dereference of an - -- uncompleted type. Note that this is not entirely correct, because - -- dereferences of private types are legal in default expressions. This - -- exception is taken care of in Check_Fully_Declared. - - -- This consideration also applies to similar checks for allocators, - -- qualified expressions, and type conversions. - - -- An additional exception concerns other per-object expressions that - -- are not directly related to component declarations, in particular - -- representation pragmas for tasks. These will be per-object - -- expressions if they depend on discriminants or some global entity. - -- If the task has access discriminants, the designated type may be - -- incomplete at the point the expression is resolved. This resolution - -- takes place within the body of the initialization procedure, where - -- the discriminant is replaced by its discriminal. - - if Is_Entity_Name (Prefix (N)) - and then Ekind (Entity (Prefix (N))) = E_In_Parameter - then - null; - - -- Ada 2005 (AI-326): Tagged incomplete types allowed. The wrong usages - -- are handled by Analyze_Access_Attribute, Analyze_Assignment, Analyze_ - -- Object_Renaming, and Freeze_Entity. - - elsif Ada_Version >= Ada_05 - and then Is_Entity_Name (Prefix (N)) - and then Ekind (Directly_Designated_Type (Etype (Prefix (N)))) - = E_Incomplete_Type - and then Is_Tagged_Type (Directly_Designated_Type (Etype (Prefix (N)))) - then - null; - else - Check_Fully_Declared (Typ, N); - end if; + Check_Fully_Declared_Prefix (Typ, P); if Is_Overloaded (P) then @@ -5239,6 +5309,7 @@ package body Sem_Res is procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id) is B_Typ : Entity_Id; + N_Opr : constant Node_Kind := Nkind (N); begin -- Predefined operations on scalar types yield the base type. On the @@ -5283,7 +5354,15 @@ package body Sem_Res is Set_Etype (N, B_Typ); Generate_Operator_Reference (N, B_Typ); Eval_Logical_Op (N); - Check_Direct_Boolean_Op (N); + + -- Check for violation of restriction No_Direct_Boolean_Operators + -- if the operator was not eliminated by the Eval_Logical_Op call. + + if Nkind (N) = N_Opr + and then Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean + then + Check_Restriction (No_Direct_Boolean_Operators, N); + end if; end Resolve_Logical_Op; --------------------------- @@ -5319,7 +5398,7 @@ package body Sem_Res is -- type I is interface; -- type T is tagged ... - -- function Test (O : in I'Class) is + -- function Test (O : I'Class) is -- begin -- return O in T'Class. -- end Test; @@ -5994,12 +6073,21 @@ package body Sem_Res is else It1 := It; - if Scope (Comp1) /= It1.Typ then + -- There may be an implicit dereference. Retrieve + -- designated record type. + + if Is_Access_Type (It1.Typ) then + T := Designated_Type (It1.Typ); + else + T := It1.Typ; + end if; + + if Scope (Comp1) /= T then -- Resolution chooses the new interpretation. -- Find the component with the right name. - Comp1 := First_Entity (It1.Typ); + Comp1 := First_Entity (T); while Present (Comp1) and then Chars (Comp1) /= Chars (S) loop @@ -6030,12 +6118,13 @@ package body Sem_Res is Resolve (P, T); end if; - -- If prefix is an access type, the node will be transformed into - -- an explicit dereference during expansion. The type of the node - -- is the designated type of that of the prefix. + -- If prefix is an access type, the node will be transformed into an + -- explicit dereference during expansion. The type of the node is the + -- designated type of that of the prefix. if Is_Access_Type (Etype (P)) then T := Designated_Type (Etype (P)); + Check_Fully_Declared_Prefix (T, P); else T := Etype (P); end if; @@ -6183,11 +6272,11 @@ package body Sem_Res is Apply_Access_Check (N); Array_Type := Designated_Type (Array_Type); - -- If the prefix is an access to an unconstrained array, we must - -- use the actual subtype of the object to perform the index checks. - -- The object denoted by the prefix is implicit in the node, so we - -- build an explicit representation for it in order to compute the - -- actual subtype. + -- If the prefix is an access to an unconstrained array, we must use + -- the actual subtype of the object to perform the index checks. The + -- object denoted by the prefix is implicit in the node, so we build + -- an explicit representation for it in order to compute the actual + -- subtype. if not Is_Constrained (Array_Type) then Remove_Side_Effects (Prefix (N)); @@ -6214,8 +6303,8 @@ package body Sem_Res is Set_Etype (N, Array_Type); - -- If the range is specified by a subtype mark, no resolution - -- is necessary. Else resolve the bounds, and apply needed checks. + -- If the range is specified by a subtype mark, no resolution is + -- necessary. Else resolve the bounds, and apply needed checks. if not Is_Entity_Name (Drange) then Index := First_Index (Array_Type); @@ -6246,13 +6335,13 @@ package body Sem_Res is begin -- For a string appearing in a concatenation, defer creation of the -- string_literal_subtype until the end of the resolution of the - -- concatenation, because the literal may be constant-folded away. - -- This is a useful optimization for long concatenation expressions. + -- concatenation, because the literal may be constant-folded away. This + -- is a useful optimization for long concatenation expressions. - -- If the string is an aggregate built for a single character (which + -- If the string is an aggregate built for a single character (which -- happens in a non-static context) or a is null string to which special - -- checks may apply, we build the subtype. Wide strings must also get - -- a string subtype if they come from a one character aggregate. Strings + -- checks may apply, we build the subtype. Wide strings must also get a + -- string subtype if they come from a one character aggregate. Strings -- generated by attributes might be static, but it is often hard to -- determine whether the enclosing context is static, so we generate -- subtypes for them as well, thus losing some rarer optimizations ??? @@ -6311,15 +6400,15 @@ package body Sem_Res is if Strlen = 0 then return; - -- Always accept string literal with component type Any_Character, - -- which occurs in error situations and in comparisons of literals, - -- both of which should accept all literals. + -- Always accept string literal with component type Any_Character, which + -- occurs in error situations and in comparisons of literals, both of + -- which should accept all literals. elsif R_Typ = Any_Character then return; - -- If the type is bit-packed, then we always tranform the string - -- literal into a full fledged aggregate. + -- If the type is bit-packed, then we always tranform the string literal + -- into a full fledged aggregate. elsif Is_Bit_Packed_Array (Typ) then null; @@ -6335,14 +6424,14 @@ package body Sem_Res is if R_Typ = Standard_Wide_Wide_Character then null; - -- For the case of Standard.String, or any other type whose - -- component type is Standard.Character, we must make sure that - -- there are no wide characters in the string, i.e. that it is - -- entirely composed of characters in range of type Character. + -- For the case of Standard.String, or any other type whose component + -- type is Standard.Character, we must make sure that there are no + -- wide characters in the string, i.e. that it is entirely composed + -- of characters in range of type Character. - -- If the string literal is the result of a static concatenation, - -- the test has already been performed on the components, and need - -- not be repeated. + -- If the string literal is the result of a static concatenation, the + -- test has already been performed on the components, and need not be + -- repeated. elsif R_Typ = Standard_Character and then Nkind (Original_Node (N)) /= N_Op_Concat @@ -6398,11 +6487,11 @@ package body Sem_Res is null; end if; - -- See if the component type of the array corresponding to the - -- string has compile time known bounds. If yes we can directly - -- check whether the evaluation of the string will raise constraint - -- error. Otherwise we need to transform the string literal into - -- the corresponding character aggregate and let the aggregate + -- See if the component type of the array corresponding to the string + -- has compile time known bounds. If yes we can directly check + -- whether the evaluation of the string will raise constraint error. + -- Otherwise we need to transform the string literal into the + -- corresponding character aggregate and let the aggregate -- code do the checking. if R_Typ = Standard_Character @@ -6457,9 +6546,9 @@ package body Sem_Res is C : Char_Code; begin - -- Build the character literals, we give them source locations - -- that correspond to the string positions, which is a bit tricky - -- given the possible presence of wide character escape sequences. + -- Build the character literals, we give them source locations that + -- correspond to the string positions, which is a bit tricky given + -- the possible presence of wide character escape sequences. for J in 1 .. Strlen loop C := Get_String_Char (Str, J); @@ -6666,6 +6755,14 @@ package body Sem_Res is Opnd_Type := Etype (Opnd_Type); end if; + -- Handle subtypes + + if Ekind (Opnd_Type) = E_Protected_Subtype + or else Ekind (Opnd_Type) = E_Task_Subtype + then + Opnd_Type := Etype (Opnd_Type); + end if; + if not Interface_Present_In_Ancestor (Typ => Opnd_Type, Iface => Target_Type) @@ -6686,20 +6783,7 @@ package body Sem_Res is end if; else - -- If a conversion to an interface type appears as an actual - -- in a source call, it will be expanded when the enclosing - -- call itself is examined in Expand_Interface_Formals. - -- Otherwise, generate the proper conversion code now, using - -- the tag of the interface. - - if (Nkind (Parent (N)) = N_Procedure_Call_Statement - or else Nkind (Parent (N)) = N_Function_Call) - and then Comes_From_Source (N) - then - null; - else - Expand_Interface_Conversion (N); - end if; + Expand_Interface_Conversion (N); end if; end; end if; @@ -6989,29 +7073,85 @@ package body Sem_Res is -------------------------------- procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + Low_Bound : constant Node_Id := + Type_Low_Bound (Etype (First_Index (Typ))); Subtype_Id : Entity_Id; begin if Nkind (N) /= N_String_Literal then return; - else - Subtype_Id := Create_Itype (E_String_Literal_Subtype, N); end if; + Subtype_Id := Create_Itype (E_String_Literal_Subtype, N); Set_String_Literal_Length (Subtype_Id, UI_From_Int (String_Length (Strval (N)))); - Set_Etype (Subtype_Id, Base_Type (Typ)); - Set_Is_Constrained (Subtype_Id); + Set_Etype (Subtype_Id, Base_Type (Typ)); + Set_Is_Constrained (Subtype_Id); + Set_Etype (N, Subtype_Id); + + if Is_OK_Static_Expression (Low_Bound) then -- The low bound is set from the low bound of the corresponding -- index type. Note that we do not store the high bound in the - -- string literal subtype, but it can be deduced if necssary + -- string literal subtype, but it can be deduced if necessary -- from the length and the low bound. - Set_String_Literal_Low_Bound - (Subtype_Id, Type_Low_Bound (Etype (First_Index (Typ)))); + Set_String_Literal_Low_Bound (Subtype_Id, Low_Bound); - Set_Etype (N, Subtype_Id); + else + Set_String_Literal_Low_Bound + (Subtype_Id, Make_Integer_Literal (Loc, 1)); + Set_Etype (String_Literal_Low_Bound (Subtype_Id), Standard_Positive); + + -- Build bona fide subtypes for the string, and wrap it in an + -- unchecked conversion, because the backend expects the + -- String_Literal_Subtype to have a static lower bound. + + declare + Index_List : constant List_Id := New_List; + Index_Type : constant Entity_Id := Etype (First_Index (Typ)); + High_Bound : constant Node_Id := + Make_Op_Add (Loc, + Left_Opnd => New_Copy_Tree (Low_Bound), + Right_Opnd => + Make_Integer_Literal (Loc, + String_Length (Strval (N)) - 1)); + Array_Subtype : Entity_Id; + Index_Subtype : Entity_Id; + Drange : Node_Id; + Index : Node_Id; + + begin + Index_Subtype := + Create_Itype (Subtype_Kind (Ekind (Index_Type)), N); + Drange := Make_Range (Loc, Low_Bound, High_Bound); + Set_Scalar_Range (Index_Subtype, Drange); + Set_Parent (Drange, N); + Analyze_And_Resolve (Drange, Index_Type); + + Set_Etype (Index_Subtype, Index_Type); + Set_Size_Info (Index_Subtype, Index_Type); + Set_RM_Size (Index_Subtype, RM_Size (Index_Type)); + + Array_Subtype := Create_Itype (E_Array_Subtype, N); + + Index := New_Occurrence_Of (Index_Subtype, Loc); + Set_Etype (Index, Index_Subtype); + Append (Index, Index_List); + + Set_First_Index (Array_Subtype, Index); + Set_Etype (Array_Subtype, Base_Type (Typ)); + Set_Is_Constrained (Array_Subtype, True); + Init_Size_Align (Array_Subtype); + + Rewrite (N, + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Array_Subtype, Loc), + Expression => Relocate_Node (N))); + Set_Etype (N, Array_Subtype); + end; + end if; end Set_String_Literal_Subtype; ----------------------------- @@ -7349,19 +7489,35 @@ package body Sem_Res is Next_Index (Opnd_Index); end loop; - if Base_Type (Target_Comp_Type) /= - Base_Type (Opnd_Comp_Type) - then - Error_Msg_N - ("incompatible component types for array conversion", - Operand); - return False; + declare + BT : constant Entity_Id := Base_Type (Target_Comp_Type); + BO : constant Entity_Id := Base_Type (Opnd_Comp_Type); - elsif - Is_Constrained (Target_Comp_Type) - /= Is_Constrained (Opnd_Comp_Type) - or else not Subtypes_Statically_Match - (Target_Comp_Type, Opnd_Comp_Type) + begin + if BT = BO then + null; + + elsif + (Ekind (BT) = E_Anonymous_Access_Type + or else Ekind (BT) = E_Anonymous_Access_Subprogram_Type) + and then Ekind (BO) = Ekind (BT) + and then Subtypes_Statically_Match + (Target_Comp_Type, Opnd_Comp_Type) + then + null; + + else + Error_Msg_N + ("incompatible component types for array conversion", + Operand); + return False; + end if; + end; + + if Is_Constrained (Target_Comp_Type) /= + Is_Constrained (Opnd_Comp_Type) + or else not Subtypes_Statically_Match + (Target_Comp_Type, Opnd_Comp_Type) then Error_Msg_N ("component subtypes must statically match", Operand); @@ -7396,8 +7552,7 @@ package body Sem_Res is ("?cannot convert local pointer to non-local access type", Operand); Error_Msg_N - ("?Program_Error will be raised at run time", Operand); - + ("\?Program_Error will be raised at run time", Operand); else Error_Msg_N ("cannot convert local pointer to non-local access type", @@ -7417,8 +7572,8 @@ package body Sem_Res is -- handles checking the prefix of the operand for this case.) if Nkind (Operand) = N_Selected_Component - and then Object_Access_Level (Operand) - > Type_Access_Level (Target_Type) + and then Object_Access_Level (Operand) > + Type_Access_Level (Target_Type) then -- In an instance, this is a run-time check, but one we -- know will fail, so generate an appropriate warning. @@ -7429,8 +7584,7 @@ package body Sem_Res is ("?cannot convert access discriminant to non-local" & " access type", Operand); Error_Msg_N - ("?Program_Error will be raised at run time", Operand); - + ("\?Program_Error will be raised at run time", Operand); else Error_Msg_N ("cannot convert access discriminant to non-local" & @@ -7499,7 +7653,7 @@ package body Sem_Res is ("?cannot convert local pointer to non-local access type", Operand); Error_Msg_N - ("?Program_Error will be raised at run time", Operand); + ("\?Program_Error will be raised at run time", Operand); else Error_Msg_N @@ -7533,7 +7687,8 @@ package body Sem_Res is ("?cannot convert access discriminant to non-local" & " access type", Operand); Error_Msg_N - ("?Program_Error will be raised at run time", Operand); + ("\?Program_Error will be raised at run time", + Operand); else Error_Msg_N -- 2.11.0