From 45fc7ddb495d04c3170109f9717e927d73f18e2b Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Tue, 8 Apr 2008 08:50:04 +0200 Subject: [PATCH] exp_ch2.adb: Minor reformatting. 2008-04-08 Hristian Kirtchev Ed Schonberg Robert Dewar * exp_ch2.adb: Minor reformatting. (Expand_Entry_Index_Parameter): Set the type of the identifier. (Expand_Entry_Reference): Add call to Expand_Protected_Component. (Expand_Protected_Component): New routine. (Expand_Protected_Private): Removed. Add Sure parameter to Note_Possible_Modification calls * sem_ch12.ads, sem_ch12.adb (Analyze_Subprogram_Instantiation): The generated subprogram declaration must inherit the overriding indicator from the instantiation node. (Validate_Access_Type_Instance): If the designated type of the actual is a limited view, use the available view in all cases, not only if the type is an incomplete type. (Instantiate_Object): Actual is illegal if the formal is null-excluding and the actual subtype does not exclude null. (Process_Default): Handle properly abstract formal subprograms. (Check_Formal_Package_Instance): Handle properly defaulted formal subprograms in a partially parameterized formal package. Add Sure parameter to Note_Possible_Modification calls (Validate_Derived_Type_Instance): if the formal is non-limited, the actual cannot be limited. (Collect_Previous_Instances): Generate instance bodies for subprograms as well. * sem_ch13.adb (Analyze_Attribute_Definition_Clause, case Small): Don't try to set RM_Size. Add Sure parameter to Note_Possible_Modification calls (Analyze_At_Clause): Preserve Comes_From_Source on Rewrite call (Analyze_Attribute_Definition_Clause, case Attribute_Address): Check for constant overlaid by variable and issue warning. Use new Is_Standard_Character_Type predicate (Analyze_Record_Representation_Clause): Check that the specified Last_Bit is not less than First_Bit - 1. (Analyze_Attribute_Definition_Clause, case Address): Check for self-referential address clause * sem_ch5.ads, sem_ch5.adb (Diagnose_Non_Variable_Lhs): Rewrite the detection mechanism when the lhs is a prival. (Analyze_Assignment): Call Check_Unprotected_Access to detect assignment of a pointer to protected data, to an object declared outside of the protected object. (Analyze_Loop_Statement): Check for unreachable code after loop Add Sure parameter to Note_Possible_Modication calls Protect analysis from previous syntax error such as a scope mismatch or a missing begin. (Analyze_Assignment_Statement): The assignment is illegal if the left-hand is an interface. * sem_res.adb (Resolve_Arithmetic_Op): For mod/rem check violation of restriction No_Implicit_Conditionals Add Sure parameter to Note_Possible_Modication calls Use new Is_Standard_Character_Type predicate (Make_Call_Into_Operator): Preserve Comes_From_Source when rewriting call as operator. Fixes problems (e.g. validity checking) which come from the result looking as though it does not come from source). (Resolve_Call): Check case of name in named parameter if style checks are enabled. (Resolve_Call): Exclude calls to Current_Task as entry formal defaults from the checking that such calls should not occur from an entry body. (Resolve_Call): If the return type of an Inline_Always function requires the secondary stack, create a transient scope for the call if the body of the function is not available for inlining. (Resolve_Actuals): Apply Ada2005 checks to view conversions of arrays that are actuals for in-out formals. (Try_Object_Operation): If prefix is a tagged protected object,retrieve primitive operations from base type. (Analyze_Selected_Component): If the context is a call to a protected operation the parent may be an indexed component prior to expansion. (Resolve_Actuals): If an actual is of a protected subtype, use its base type to determine whether a conversion to the corresponding record is needed. (Resolve_Short_Circuit): Handle pragma Check * sem_eval.adb: Minor code reorganization (usea Is_Constant_Object) Use new Is_Standard_Character_Type predicate (Eval_Relational_Op): Catch more cases of string comparison From-SVN: r134027 --- gcc/ada/exp_ch2.adb | 161 +++++------- gcc/ada/sem_ch12.adb | 166 +++++++++---- gcc/ada/sem_ch12.ads | 8 +- gcc/ada/sem_ch13.adb | 81 ++++-- gcc/ada/sem_ch5.adb | 122 ++++++--- gcc/ada/sem_ch5.ads | 10 +- gcc/ada/sem_eval.adb | 170 ++++++++++--- gcc/ada/sem_res.adb | 581 +++++++++++++++++++++++++++++-------------- 8 files changed, 863 insertions(+), 436 deletions(-) diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb index 95291d49245..82ac5eea7f4 100644 --- a/gcc/ada/exp_ch2.adb +++ b/gcc/ada/exp_ch2.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -80,12 +80,12 @@ package body Exp_Ch2 is -- Dispatches to specific expansion procedures. procedure Expand_Entry_Index_Parameter (N : Node_Id); - -- A reference to the identifier in the entry index specification of - -- protected entry body is modified to a reference to a constant definition - -- equal to the index of the entry family member being called. This - -- constant is calculated as part of the elaboration of the expanded code - -- for the body, and is calculated from the object-wide entry index - -- returned by Next_Entry_Call. + -- A reference to the identifier in the entry index specification of an + -- entry body is modified to a reference to a constant definition equal to + -- the index of the entry family member being called. This constant is + -- calculated as part of the elaboration of the expanded code for the body, + -- and is calculated from the object-wide entry index returned by Next_ + -- Entry_Call. procedure Expand_Entry_Parameter (N : Node_Id); -- A reference to an entry parameter is modified to be a reference to the @@ -98,12 +98,10 @@ package body Exp_Ch2 is -- represent the operation within the protected object. In other cases -- Expand_Formal is a no-op. - procedure Expand_Protected_Private (N : Node_Id); - -- A reference to a private component of a protected type is expanded to a - -- component selected from the record used to implement the protected - -- object. Such a record is passed to all operations on a protected object - -- in a parameter named _object. This object is a constant in the body of a - -- function, and a variable within a procedure or entry body. + procedure Expand_Protected_Component (N : Node_Id); + -- A reference to a private component of a protected type is expanded into + -- a reference to the corresponding prival in the current protected entry + -- or subprogram. procedure Expand_Renaming (N : Node_Id); -- For renamings, just replace the identifier by the corresponding @@ -332,16 +330,12 @@ package body Exp_Ch2 is elsif Is_Entry_Formal (E) then Expand_Entry_Parameter (N); - elsif Ekind (E) = E_Component - and then Is_Protected_Private (E) - then - -- Protect against junk use of tasking in no run time mode - + elsif Is_Protected_Component (E) then if No_Run_Time_Mode then return; end if; - Expand_Protected_Private (N); + Expand_Protected_Component (N); elsif Ekind (E) = E_Entry_Index_Parameter then Expand_Entry_Index_Parameter (N); @@ -385,11 +379,7 @@ package body Exp_Ch2 is -- Interpret possible Current_Value for constant case - elsif (Ekind (E) = E_Constant - or else - Ekind (E) = E_In_Parameter - or else - Ekind (E) = E_Loop_Parameter) + elsif Is_Constant_Object (E) and then Present (Current_Value (E)) then Expand_Current_Value (N); @@ -401,8 +391,10 @@ package body Exp_Ch2 is ---------------------------------- procedure Expand_Entry_Index_Parameter (N : Node_Id) is + Index_Con : constant Entity_Id := Entry_Index_Constant (Entity (N)); begin - Set_Entity (N, Entry_Index_Constant (Entity (N))); + Set_Entity (N, Index_Con); + Set_Etype (N, Etype (Index_Con)); end Expand_Entry_Index_Parameter; ---------------------------- @@ -477,10 +469,14 @@ package body Exp_Ch2 is -- we also generate an extra parameter to hold the Constrained -- attribute of the actual. No renaming is generated for this flag. + -- Calling Node_Posssible_Modifications in the expander is dubious, + -- because this generates a cross-reference entry, and should be + -- done during semantic processing so it is called in -gnatc mode??? + if Ekind (Entity (N)) /= E_In_Parameter and then In_Assignment_Context (N) then - Note_Possible_Modification (N); + Note_Possible_Modification (N, Sure => True); end if; Rewrite (N, New_Occurrence_Of (Renamed_Object (Entity (N)), Loc)); @@ -564,93 +560,54 @@ package body Exp_Ch2 is end if; end Expand_N_Real_Literal; - ------------------------------ - -- Expand_Protected_Private -- - ------------------------------ + -------------------------------- + -- Expand_Protected_Component -- + -------------------------------- - procedure Expand_Protected_Private (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - E : constant Entity_Id := Entity (N); - Op : constant Node_Id := Protected_Operation (E); - Scop : Entity_Id; - Lo : Node_Id; - Hi : Node_Id; - D_Range : Node_Id; - - begin - if Nkind (Op) /= N_Subprogram_Body - or else Nkind (Specification (Op)) /= N_Function_Specification - then - Set_Ekind (Prival (E), E_Variable); - else - Set_Ekind (Prival (E), E_Constant); - end if; + procedure Expand_Protected_Component (N : Node_Id) is - -- If the private component appears in an assignment (either lhs or - -- rhs) and is a one-dimensional array constrained by a discriminant, - -- rewrite as P (Lo .. Hi) with an explicit range, so that discriminal - -- is directly visible. This solves delicate visibility problems. + function Inside_Eliminated_Body return Boolean; + -- Determine whether the current entity is inside a subprogram or an + -- entry which has been marked as eliminated. - if Comes_From_Source (N) - and then Is_Array_Type (Etype (E)) - and then Number_Dimensions (Etype (E)) = 1 - and then not Within_Init_Proc - then - Lo := Type_Low_Bound (Etype (First_Index (Etype (E)))); - Hi := Type_High_Bound (Etype (First_Index (Etype (E)))); - - if Nkind (Parent (N)) = N_Assignment_Statement - and then ((Is_Entity_Name (Lo) - and then Ekind (Entity (Lo)) = E_In_Parameter) - or else (Is_Entity_Name (Hi) - and then - Ekind (Entity (Hi)) = E_In_Parameter)) - then - D_Range := New_Node (N_Range, Loc); + ---------------------------- + -- Inside_Eliminated_Body -- + ---------------------------- - if Is_Entity_Name (Lo) - and then Ekind (Entity (Lo)) = E_In_Parameter - then - Set_Low_Bound (D_Range, - Make_Identifier (Loc, Chars (Entity (Lo)))); - else - Set_Low_Bound (D_Range, Duplicate_Subexpr (Lo)); - end if; + function Inside_Eliminated_Body return Boolean is + S : Entity_Id := Current_Scope; - if Is_Entity_Name (Hi) - and then Ekind (Entity (Hi)) = E_In_Parameter + begin + while Present (S) loop + if (Ekind (S) = E_Entry + or else Ekind (S) = E_Entry_Family + or else Ekind (S) = E_Function + or else Ekind (S) = E_Procedure) + and then Is_Eliminated (S) then - Set_High_Bound (D_Range, - Make_Identifier (Loc, Chars (Entity (Hi)))); - else - Set_High_Bound (D_Range, Duplicate_Subexpr (Hi)); + return True; end if; - Rewrite (N, - Make_Slice (Loc, - Prefix => New_Occurrence_Of (E, Loc), - Discrete_Range => D_Range)); - - Analyze_And_Resolve (N, Etype (E)); - return; - end if; - end if; - - -- The type of the reference is the type of the prival, which may differ - -- from that of the original component if it is an itype. - - Set_Entity (N, Prival (E)); - Set_Etype (N, Etype (Prival (E))); - Scop := Current_Scope; + S := Scope (S); + end loop; - -- Find entity for protected operation, which must be on scope stack + return False; + end Inside_Eliminated_Body; - while not Is_Protected_Type (Scope (Scop)) loop - Scop := Scope (Scop); - end loop; + -- Start of processing for Expand_Protected_Component - Append_Elmt (N, Privals_Chain (Scop)); - end Expand_Protected_Private; + begin + -- Eliminated bodies are not expanded and thus do not need privals + + if not Inside_Eliminated_Body then + declare + Priv : constant Entity_Id := Prival (Entity (N)); + begin + Set_Entity (N, Priv); + Set_Etype (N, Etype (Priv)); + end; + end if; + end Expand_Protected_Component; --------------------- -- Expand_Renaming -- diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index a2019a6e427..00c9f39ff21 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -488,11 +488,11 @@ package body Sem_Ch12 is -- and has already been flipped during this phase of instantiation. procedure Hide_Current_Scope; - -- When compiling a generic child unit, the parent context must be + -- When instantiating a generic child unit, the parent context must be -- present, but the instance and all entities that may be generated -- must be inserted in the current scope. We leave the current scope -- on the stack, but make its entities invisible to avoid visibility - -- problems. This is reversed at the end of instantiations. This is + -- problems. This is reversed at the end of the instantiation. This is -- not done for the instantiation of the bodies, which only require the -- instances of the generic parents to be in scope. @@ -685,7 +685,7 @@ package body Sem_Ch12 is -- at the end of the enclosing generic package, which is semantically -- neutral. - procedure Pre_Analyze_Actuals (N : Node_Id); + procedure Preanalyze_Actuals (N : Node_Id); -- Analyze actuals to perform name resolution. Full resolution is done -- later, when the expected types are known, but names have to be captured -- before installing parents of generics, that are not visible for the @@ -1027,6 +1027,8 @@ package body Sem_Ch12 is procedure Process_Default (F : Entity_Id) is Loc : constant Source_Ptr := Sloc (I_Node); + F_Id : constant Entity_Id := Defining_Entity (F); + Decl : Node_Id; Default : Node_Id; Id : Entity_Id; @@ -1036,17 +1038,12 @@ package body Sem_Ch12 is -- new defining identifier for it. Decl := New_Copy_Tree (F); + Id := Make_Defining_Identifier (Sloc (F_Id), Chars => Chars (F_Id)); - if Nkind (F) = N_Formal_Concrete_Subprogram_Declaration then - Id := - Make_Defining_Identifier (Sloc (Defining_Entity (F)), - Chars => Chars (Defining_Entity (F))); + if Nkind (F) in N_Formal_Subprogram_Declaration then Set_Defining_Unit_Name (Specification (Decl), Id); else - Id := - Make_Defining_Identifier (Sloc (Defining_Entity (F)), - Chars => Chars (Defining_Identifier (F))); Set_Defining_Identifier (Decl, Id); end if; @@ -1652,7 +1649,6 @@ package body Sem_Ch12 is Set_Size_Known_At_Compile_Time (T, Size_Known_At_Compile_Time (Entity (Subtype_Mark (Def)))); - end Analyze_Formal_Derived_Type; ---------------------------------- @@ -1855,7 +1851,7 @@ package body Sem_Ch12 is end if; if Present (E) then - Analyze_Per_Use_Expression (E, T); + Preanalyze_Spec_Expression (E, T); if Is_Limited_Type (T) and then not OK_For_Limited_Init (E) then Error_Msg_N @@ -2910,7 +2906,7 @@ package body Sem_Ch12 is end if; Generate_Definition (Act_Decl_Id); - Pre_Analyze_Actuals (N); + Preanalyze_Actuals (N); Init_Env; Env_Installed := True; @@ -3888,9 +3884,7 @@ package body Sem_Ch12 is -- subprogram will be frozen at the point the wrapper package is -- frozen, so it does not need its own freeze node. In fact, if one -- is created, it might conflict with the freezing actions from the - -- wrapper package (see 7206-013). - - -- Should not really reference non-public TN's in comments ??? + -- wrapper package. Set_Has_Delayed_Freeze (Anon_Id, False); @@ -3946,7 +3940,7 @@ package body Sem_Ch12 is -- Make node global for error reporting Instantiation_Node := N; - Pre_Analyze_Actuals (N); + Preanalyze_Actuals (N); Init_Env; Env_Installed := True; @@ -4038,12 +4032,16 @@ package body Sem_Ch12 is Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment); -- Copy original generic tree, to produce text for instantiation + -- Inherit overriding indicator from instance node. Act_Tree := Copy_Generic_Node (Original_Node (Gen_Decl), Empty, Instantiating => True); Act_Spec := Specification (Act_Tree); + Set_Must_Override (Act_Spec, Must_Override (N)); + Set_Must_Not_Override (Act_Spec, Must_Not_Override (N)); + Renaming_List := Analyze_Associations (N, @@ -4625,11 +4623,22 @@ package body Sem_Ch12 is elsif Is_Overloadable (E1) then - -- Verify that the names of the entities match. Note that actuals - -- that are attributes are rewritten as subprograms. + -- Verify that the actual subprograms match. Note that actuals + -- that are attributes are rewritten as subprograms. If the + -- subprogram in the formal package is defaulted, no check is + -- needed. Note that this can only happen in Ada2005 when the + -- formal package can be partially parametrized. - Check_Mismatch - (Ekind (E2) /= Ekind (E1) or else (Alias (E1)) /= Alias (E2)); + if Nkind (Unit_Declaration_Node (E1)) = + N_Subprogram_Renaming_Declaration + and then From_Default (Unit_Declaration_Node (E1)) + then + null; + + else + Check_Mismatch + (Ekind (E2) /= Ekind (E1) or else (Alias (E1)) /= Alias (E2)); + end if; else raise Program_Error; @@ -8226,7 +8235,7 @@ package body Sem_Ch12 is end if; end if; - Note_Possible_Modification (Actual); + Note_Possible_Modification (Actual, Sure => True); -- Check for instantiation of atomic/volatile actual for -- non-atomic/volatile formal (RM C.6 (12)). @@ -8280,7 +8289,7 @@ package body Sem_Ch12 is Append (Decl_Node, List); -- No need to repeat (pre-)analysis of some expression nodes - -- already handled in Pre_Analyze_Actuals. + -- already handled in Preanalyze_Actuals. if Nkind (Actual) /= N_Allocator then Analyze (Actual); @@ -8306,7 +8315,7 @@ package body Sem_Ch12 is -- a child unit. if Nkind (Actual) = N_Aggregate then - Pre_Analyze_And_Resolve (Actual, Typ); + Preanalyze_And_Resolve (Actual, Typ); end if; if Is_Limited_Type (Typ) @@ -8397,13 +8406,12 @@ package body Sem_Ch12 is Nkind_In (Actual_Decl, N_Formal_Object_Declaration, N_Object_Declaration) and then Nkind (Analyzed_Formal) = N_Formal_Object_Declaration - and then Has_Null_Exclusion (Actual_Decl) - and then not Has_Null_Exclusion (Analyzed_Formal) + and then not Has_Null_Exclusion (Actual_Decl) + and then Has_Null_Exclusion (Analyzed_Formal) then - Error_Msg_Sloc := Sloc (Actual_Decl); + Error_Msg_Sloc := Sloc (Analyzed_Formal); Error_Msg_N - ("`NOT NULL` required in formal, to match actual #", - Analyzed_Formal); + ("actual must exclude null to match generic formal#", Actual); end if; return List; @@ -8656,7 +8664,8 @@ package body Sem_Ch12 is --------------------------------- procedure Instantiate_Subprogram_Body - (Body_Info : Pending_Body_Info) + (Body_Info : Pending_Body_Info; + Body_Optional : Boolean := False) is Act_Decl : constant Node_Id := Body_Info.Act_Decl; Inst_Node : constant Node_Id := Body_Info.Inst_Node; @@ -8709,7 +8718,8 @@ package body Sem_Ch12 is -- For other cases, commpile the body else - Load_Parent_Of_Generic (Inst_Node, Specification (Gen_Decl)); + Load_Parent_Of_Generic + (Inst_Node, Specification (Gen_Decl), Body_Optional); Gen_Body_Id := Corresponding_Body (Gen_Decl); end if; end if; @@ -8875,7 +8885,10 @@ package body Sem_Ch12 is elsif Serious_Errors_Detected = 0 and then Nkind (Parent (Inst_Node)) /= N_Compilation_Unit then - if Ekind (Anon_Id) = E_Procedure then + if Body_Optional then + return; + + elsif Ekind (Anon_Id) = E_Procedure then Act_Body := Make_Subprogram_Body (Loc, Specification => @@ -9074,11 +9087,10 @@ package body Sem_Ch12 is Desig_Act := Designated_Type (Base_Type (Act_T)); -- The designated type may have been introduced through a limited_ - -- with clause, in which case retrieve the non-limited view. + -- with clause, in which case retrieve the non-limited view. This + -- applies to incomplete types as well as to class-wide types. - if Ekind (Desig_Act) = E_Incomplete_Type - and then From_With_Type (Desig_Act) - then + if From_With_Type (Desig_Act) then Desig_Act := Available_View (Desig_Act); end if; @@ -9760,6 +9772,22 @@ package body Sem_Ch12 is end loop; end Check_Abstract_Primitives; end if; + + -- Verify that limitedness matches. If parent is a limited + -- interface then the generic formal is not unless declared + -- explicitly so. If not declared limited, the actual cannot be + -- limited (see AI05-0087). + + if Is_Limited_Type (Act_T) + and then not Is_Limited_Type (A_Gen_T) + and then False + then + Error_Msg_NE + ("actual for non-limited & cannot be a limited type", Actual, + Gen_T); + Explain_Limited_Type (Act_T, Actual); + Abandon_Instantiation (Actual); + end if; end Validate_Derived_Type_Instance; -------------------------------------- @@ -10256,7 +10284,8 @@ package body Sem_Ch12 is -- instantiations are available, we must analyze them, to ensure that -- the public symbols generated are the same when the unit is compiled -- to generate code, and when it is compiled in the context of a unit - -- that needs a particular nested instance. + -- that needs a particular nested instance. This process is applied + -- to both package and subprogram instances. -------------------------------- -- Collect_Previous_Instances -- @@ -10284,6 +10313,16 @@ package body Sem_Ch12 is then Append_Elmt (Decl, Previous_Instances); + -- For a subprogram instantiation, omit instantiations of + -- intrinsic operations (Unchecked_Conversions, etc.) that + -- have no bodies. + + elsif Nkind_In (Decl, N_Function_Instantiation, + N_Procedure_Instantiation) + and then not Is_Intrinsic_Subprogram (Entity (Name (Decl))) + then + Append_Elmt (Decl, Previous_Instances); + elsif Nkind (Decl) = N_Package_Declaration then Collect_Previous_Instances (Visible_Declarations (Specification (Decl))); @@ -10416,6 +10455,7 @@ package body Sem_Ch12 is then declare Decl : Elmt_Id; + Info : Pending_Body_Info; Par : Node_Id; begin @@ -10446,18 +10486,40 @@ package body Sem_Ch12 is Decl := First_Elmt (Previous_Instances); while Present (Decl) loop - Instantiate_Package_Body - (Body_Info => - ((Inst_Node => Node (Decl), - Act_Decl => - Instance_Spec (Node (Decl)), - Expander_Status => Exp_Status, - Current_Sem_Unit => - Get_Code_Unit (Sloc (Node (Decl))), - Scope_Suppress => Scope_Suppress, - Local_Suppress_Stack_Top => - Local_Suppress_Stack_Top)), - Body_Optional => True); + Info := + (Inst_Node => Node (Decl), + Act_Decl => + Instance_Spec (Node (Decl)), + Expander_Status => Exp_Status, + Current_Sem_Unit => + Get_Code_Unit (Sloc (Node (Decl))), + Scope_Suppress => Scope_Suppress, + Local_Suppress_Stack_Top => + Local_Suppress_Stack_Top); + + -- Package instance + + if + Nkind (Node (Decl)) = N_Package_Instantiation + then + Instantiate_Package_Body + (Info, Body_Optional => True); + + -- Subprogram instance + + else + -- The instance_spec is the wrapper package, + -- and the subprogram declaration is the last + -- declaration in the wrapper. + + Info.Act_Decl := + Last + (Visible_Declarations + (Specification (Info.Act_Decl))); + + Instantiate_Subprogram_Body + (Info, Body_Optional => True); + end if; Next_Elmt (Decl); end loop; @@ -10474,7 +10536,7 @@ package body Sem_Ch12 is Scope_Suppress => Scope_Suppress, Local_Suppress_Stack_Top => Local_Suppress_Stack_Top)), - Body_Optional => Body_Optional); + Body_Optional => Body_Optional); end; end if; @@ -10634,7 +10696,7 @@ package body Sem_Ch12 is -- Preanalyze_Actuals -- ------------------------ - procedure Pre_Analyze_Actuals (N : Node_Id) is + procedure Preanalyze_Actuals (N : Node_Id) is Assoc : Node_Id; Act : Node_Id; Errs : constant Int := Serious_Errors_Detected; @@ -10724,7 +10786,7 @@ package body Sem_Ch12 is Next (Assoc); end loop; - end Pre_Analyze_Actuals; + end Preanalyze_Actuals; ------------------- -- Remove_Parent -- diff --git a/gcc/ada/sem_ch12.ads b/gcc/ada/sem_ch12.ads index b81d998560e..689e597b1ce 100644 --- a/gcc/ada/sem_ch12.ads +++ b/gcc/ada/sem_ch12.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -100,9 +100,11 @@ package Sem_Ch12 is -- between the current procedure and Load_Parent_Of_Generic. procedure Instantiate_Subprogram_Body - (Body_Info : Pending_Body_Info); + (Body_Info : Pending_Body_Info; + Body_Optional : Boolean := False); -- Called after semantic analysis, to complete the instantiation of - -- function and procedure instances. + -- function and procedure instances. The flag Body_Optional has the + -- same purpose as described for Instantiate_Package_Body. procedure Save_Global_References (N : Node_Id); -- Traverse the original generic unit, and capture all references to diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index c678d987808..1b6eece5782 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -29,7 +29,6 @@ with Einfo; use Einfo; with Errout; use Errout; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; -with Layout; use Layout; with Lib; use Lib; with Lib.Xref; use Lib.Xref; with Namet; use Namet; @@ -485,7 +484,11 @@ package body Sem_Ch13 is -- definition clause that is the preferred approach in Ada 95. procedure Analyze_At_Clause (N : Node_Id) is + CS : constant Boolean := Comes_From_Source (N); + begin + -- This is an obsolescent feature + Check_Restriction (No_Obsolescent_Features, N); if Warn_On_Obsolescent_Feature then @@ -495,11 +498,21 @@ package body Sem_Ch13 is ("\use address attribute definition clause instead?", N); end if; + -- Rewrite as address clause + Rewrite (N, Make_Attribute_Definition_Clause (Sloc (N), Name => Identifier (N), Chars => Name_Address, Expression => Expression (N))); + + -- We preserve Comes_From_Source, since logically the clause still + -- comes from the source program even though it is changed in form. + + Set_Comes_From_Source (N, CS); + + -- Analyze rewritten clause + Analyze_Attribute_Definition_Clause (N); end Analyze_At_Clause; @@ -529,6 +542,10 @@ package body Sem_Ch13 is -- Common processing for 'Read, 'Write, 'Input and 'Output attribute -- definition clauses. + ----------------------------------- + -- Analyze_Stream_TSS_Definition -- + ----------------------------------- + procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type) is Subp : Entity_Id := Empty; I : Interp_Index; @@ -588,7 +605,6 @@ package body Sem_Ch13 is return Base_Type (Typ) = Base_Type (Ent) and then No (Next_Formal (F)); - end Has_Good_Profile; -- Start of processing for Analyze_Stream_TSS_Definition @@ -739,6 +755,22 @@ package body Sem_Ch13 is -- Address attribute definition clause when Attribute_Address => Address : begin + + -- A little error check, catch for X'Address use X'Address; + + if Nkind (Nam) = N_Identifier + and then Nkind (Expr) = N_Attribute_Reference + and then Attribute_Name (Expr) = Name_Address + and then Nkind (Prefix (Expr)) = N_Identifier + and then Chars (Nam) = Chars (Prefix (Expr)) + then + Error_Msg_NE + ("address for & is self-referencing", Prefix (Expr), Ent); + return; + end if; + + -- Not that special case, carry on with analysis of expression + Analyze_And_Resolve (Expr, RTE (RE_Address)); if Present (Address_Clause (U_Ent)) then @@ -875,7 +907,7 @@ package body Sem_Ch13 is -- We mark a possible modification of a variable with an -- address clause, since it is likely aliasing is occurring. - Note_Possible_Modification (Nam); + Note_Possible_Modification (Nam, Sure => False); -- Here we are checking for explicit overlap of one variable -- by another, and if we find this then mark the overlapped @@ -920,22 +952,25 @@ package body Sem_Ch13 is -- If the address clause is of the form: - -- for X'Address use Y'Address + -- for Y'Address use X'Address -- or - -- Const : constant Address := Y'Address; + -- Const : constant Address := X'Address; -- ... - -- for X'Address use Const; + -- for Y'Address use Const; -- then we make an entry in the table for checking the size and -- alignment of the overlaying variable. We defer this check -- till after code generation to take full advantage of the -- annotation done by the back end. This entry is only made if -- we have not already posted a warning about size/alignment - -- (some warnings of this type are posted in Checks). + -- (some warnings of this type are posted in Checks), and if + -- the address clause comes from source. - if Address_Clause_Overlay_Warnings then + if Address_Clause_Overlay_Warnings + and then Comes_From_Source (N) + then declare Ent_X : Entity_Id := Empty; Ent_Y : Entity_Id := Empty; @@ -945,7 +980,18 @@ package body Sem_Ch13 is if Present (Ent_Y) and then Is_Entity_Name (Name (N)) then Ent_X := Entity (Name (N)); - Address_Clause_Checks.Append ((N, Ent_X, Ent_Y)); + Address_Clause_Checks.Append ((N, Ent_X, Ent_Y)); + + -- If variable overlays a constant view, and we are + -- warning on overlays, then mark the variable as + -- overlaying a constant (we will give warnings later + -- if this variable is assigned). + + if Is_Constant_Object (Ent_Y) + and then Ekind (Ent_X) = E_Variable + then + Set_Overlays_Constant (Ent_X); + end if; end if; end; end if; @@ -1391,10 +1437,6 @@ package body Sem_Ch13 is Set_Has_Small_Clause (U_Ent); Set_Has_Small_Clause (Implicit_Base); Set_Has_Non_Standard_Rep (Implicit_Base); - - -- Recompute RM_Size, but shouldn't this be done in Freeze??? - - Set_Discrete_RM_Size (U_Ent); end if; end Small; @@ -1857,10 +1899,7 @@ package body Sem_Ch13 is -- Don't allow rep clause for standard [wide_[wide_]]character - elsif Root_Type (Enumtype) = Standard_Character - or else Root_Type (Enumtype) = Standard_Wide_Character - or else Root_Type (Enumtype) = Standard_Wide_Wide_Character - then + elsif Is_Standard_Character_Type (Enumtype) then Error_Msg_N ("enumeration rep clause not allowed for this type", N); return; @@ -2310,6 +2349,14 @@ package body Sem_Ch13 is Error_Msg_N ("first bit cannot be negative", First_Bit (CC)); + -- The Last_Bit specified in a component clause must not be + -- less than the First_Bit minus one (RM-13.5.1(10)). + + elsif Lbit < Fbit - 1 then + Error_Msg_N + ("last bit cannot be less than first bit minus one", + Last_Bit (CC)); + -- Values look OK, so find the corresponding record component -- Even though the syntax allows an attribute reference for -- implementation-defined components, GNAT does not allow the diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 3f39aca1307..c569a281845 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -118,31 +118,40 @@ package body Sem_Ch5 is -- Some special bad cases of entity names elsif Is_Entity_Name (N) then - if Ekind (Entity (N)) = E_In_Parameter then - Error_Msg_N - ("assignment to IN mode parameter not allowed", N); - - -- Private declarations in a protected object are turned into - -- constants when compiling a protected function. + declare + Ent : constant Entity_Id := Entity (N); - elsif Present (Scope (Entity (N))) - and then Is_Protected_Type (Scope (Entity (N))) - and then - (Ekind (Current_Scope) = E_Function - or else - Ekind (Enclosing_Dynamic_Scope (Current_Scope)) = E_Function) - then - Error_Msg_N - ("protected function cannot modify protected object", N); + begin + if Ekind (Ent) = E_In_Parameter then + Error_Msg_N + ("assignment to IN mode parameter not allowed", N); + + -- Renamings of protected private components are turned into + -- constants when compiling a protected function. In the case + -- of single protected types, the private component appears + -- directly. + + elsif (Is_Prival (Ent) + and then + (Ekind (Current_Scope) = E_Function + or else Ekind (Enclosing_Dynamic_Scope ( + Current_Scope)) = E_Function)) + or else + (Ekind (Ent) = E_Component + and then Is_Protected_Type (Scope (Ent))) + then + Error_Msg_N + ("protected function cannot modify protected object", N); - elsif Ekind (Entity (N)) = E_Loop_Parameter then - Error_Msg_N - ("assignment to loop parameter not allowed", N); + elsif Ekind (Ent) = E_Loop_Parameter then + Error_Msg_N + ("assignment to loop parameter not allowed", N); - else - Error_Msg_N - ("left hand side of assignment must be a variable", N); - end if; + else + Error_Msg_N + ("left hand side of assignment must be a variable", N); + end if; + end; -- For indexed components or selected components, test prefix @@ -430,6 +439,15 @@ package body Sem_Ch5 is ("left hand of assignment must not be limited type", Lhs); Explain_Limited_Type (T1, Lhs); return; + + -- Enforce RM 3.9.3 (8): left-hand side cannot be abstract + + elsif Is_Interface (T1) + and then not Is_Class_Wide_Type (T1) + then + Error_Msg_N + ("target of assignment operation may not be abstract", Lhs); + return; end if; -- Resolution may have updated the subtype, in case the left-hand @@ -469,6 +487,7 @@ package body Sem_Ch5 is -- This is the point at which we check for an unset reference Check_Unset_Reference (Rhs); + Check_Unprotected_Access (Lhs, Rhs); -- Remaining steps are skipped if Rhs was syntactically in error @@ -588,7 +607,7 @@ package body Sem_Ch5 is -- We still mark this as a possible modification, that's necessary -- to reset Is_True_Constant, and desirable for xref purposes. - Note_Possible_Modification (Lhs); + Note_Possible_Modification (Lhs, Sure => True); return; -- If we know the right hand side is non-null, then we convert to the @@ -635,7 +654,7 @@ package body Sem_Ch5 is -- Note: modifications of the Lhs may only be recorded after -- checks have been applied. - Note_Possible_Modification (Lhs); + Note_Possible_Modification (Lhs, Sure => True); -- ??? a real accessibility check is needed when ??? @@ -1901,20 +1920,36 @@ package body Sem_Ch5 is Analyze (Id); Ent := Entity (Id); - Generate_Reference (Ent, Loop_Statement, ' '); - Generate_Definition (Ent); - -- If we found a label, mark its type. If not, ignore it, since it - -- means we have a conflicting declaration, which would already have - -- been diagnosed at declaration time. Set Label_Construct of the - -- implicit label declaration, which is not created by the parser - -- for generic units. + -- Guard against serious error (typically, a scope mismatch when + -- semantic analysis is requested) by creating loop entity to + -- continue analysis. - if Ekind (Ent) = E_Label then - Set_Ekind (Ent, E_Loop); + if No (Ent) then + if Total_Errors_Detected /= 0 then + Ent := + New_Internal_Entity + (E_Loop, Current_Scope, Sloc (Loop_Statement), 'L'); + else + raise Program_Error; + end if; + + else + Generate_Reference (Ent, Loop_Statement, ' '); + Generate_Definition (Ent); - if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then - Set_Label_Construct (Parent (Ent), Loop_Statement); + -- If we found a label, mark its type. If not, ignore it, since it + -- means we have a conflicting declaration, which would already + -- have been diagnosed at declaration time. Set Label_Construct + -- of the implicit label declaration, which is not created by the + -- parser for generic units. + + if Ekind (Ent) = E_Label then + Set_Ekind (Ent, E_Loop); + + if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then + Set_Label_Construct (Parent (Ent), Loop_Statement); + end if; end if; end if; @@ -1928,10 +1963,10 @@ package body Sem_Ch5 is Set_Parent (Ent, Loop_Statement); end if; - -- Kill current values on entry to loop, since statements in body - -- of loop may have been executed before the loop is entered. - -- Similarly we kill values after the loop, since we do not know - -- that the body of the loop was executed. + -- Kill current values on entry to loop, since statements in body of + -- loop may have been executed before the loop is entered. Similarly we + -- kill values after the loop, since we do not know that the body of the + -- loop was executed. Kill_Current_Values; Push_Scope (Ent); @@ -1941,6 +1976,13 @@ package body Sem_Ch5 is End_Scope; Kill_Current_Values; Check_Infinite_Loop_Warning (N); + + -- Code after loop is unreachable if the loop has no WHILE or FOR + -- and contains no EXIT statements within the body of the loop. + + if No (Iter) and then not Has_Exit (Ent) then + Check_Unreachable_Code (N); + end if; end Analyze_Loop_Statement; ---------------------------- diff --git a/gcc/ada/sem_ch5.ads b/gcc/ada/sem_ch5.ads index 3f8d2dfb990..4fa2246bee9 100644 --- a/gcc/ada/sem_ch5.ads +++ b/gcc/ada/sem_ch5.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -47,9 +47,9 @@ package Sem_Ch5 is -- be assumed to be reachable. procedure Check_Unreachable_Code (N : Node_Id); - -- This procedure is called with N being the node for a statement that - -- is an unconditional transfer of control. It checks to see if the - -- statement is followed by some other statement, and if so generates - -- an appropriate warning for unreachable code. + -- This procedure is called with N being the node for a statement that is + -- an unconditional transfer of control or an apparent infinite loop. It + -- checks to see if the statement is followed by some other statement, and + -- if so generates an appropriate warning for unreachable code. end Sem_Ch5; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index d7acaa7d884..7b38241006f 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -578,9 +578,7 @@ package body Sem_Eval is if Nkind (Lf) = N_Identifier and then Nkind (Rf) = N_Identifier and then Entity (Lf) = Entity (Rf) and then not Is_Floating_Point_Type (Etype (L)) - and then (Ekind (Entity (Lf)) = E_Constant or else - Ekind (Entity (Lf)) = E_In_Parameter or else - Ekind (Entity (Lf)) = E_Loop_Parameter) + and then Is_Constant_Object (Entity (Lf)) then return True; @@ -1432,9 +1430,7 @@ package body Sem_Eval is Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold); - if (C_Typ = Standard_Character - or else C_Typ = Standard_Wide_Character - or else C_Typ = Standard_Wide_Wide_Character) + if Is_Standard_Character_Type (C_Typ) and then Fold then null; @@ -2269,14 +2265,13 @@ package body Sem_Eval is Fold : Boolean; begin - -- One special case to deal with first. If we can tell that - -- the result will be false because the lengths of one or - -- more index subtypes are compile time known and different, - -- then we can replace the entire result by False. We only - -- do this for one dimensional arrays, because the case of - -- multi-dimensional arrays is rare and too much trouble! - -- If one of the operands is an illegal aggregate, its type - -- might still be an arbitrary composite type, so nothing to do. + -- One special case to deal with first. If we can tell that the result + -- will be false because the lengths of one or more index subtypes are + -- compile time known and different, then we can replace the entire + -- result by False. We only do this for one dimensional arrays, because + -- the case of multi-dimensional arrays is rare and too much trouble! If + -- one of the operands is an illegal aggregate, its type might still be + -- an arbitrary composite type, so nothing to do. if Is_Array_Type (Typ) and then Typ /= Any_Composite @@ -2289,7 +2284,9 @@ package body Sem_Eval is return; end if; - declare + -- OK, we have the case where we may be able to do this fold + + Length_Mismatch : declare procedure Get_Static_Length (Op : Node_Id; Len : out Uint); -- If Op is an expression for a constrained array with a known -- at compile time length, then Len is set to this (non-negative @@ -2303,33 +2300,145 @@ package body Sem_Eval is T : Entity_Id; begin + -- First easy case string literal + if Nkind (Op) = N_String_Literal then Len := UI_From_Int (String_Length (Strval (Op))); + return; + end if; + + -- Second easy case, not constrained subtype, so no length - elsif not Is_Constrained (Etype (Op)) then + if not Is_Constrained (Etype (Op)) then Len := Uint_Minus_1; + return; + end if; - else - T := Etype (First_Index (Etype (Op))); + -- General case - if Is_Discrete_Type (T) - and then - Compile_Time_Known_Value (Type_Low_Bound (T)) - and then - Compile_Time_Known_Value (Type_High_Bound (T)) + T := Etype (First_Index (Etype (Op))); + + -- The simple case, both bounds are known at compile time + + if Is_Discrete_Type (T) + and then + Compile_Time_Known_Value (Type_Low_Bound (T)) + and then + Compile_Time_Known_Value (Type_High_Bound (T)) + then + Len := UI_Max (Uint_0, + Expr_Value (Type_High_Bound (T)) - + Expr_Value (Type_Low_Bound (T)) + 1); + return; + end if; + + -- A more complex case, where the bounds are of the form + -- X [+/- K1] .. X [+/- K2]), where X is an expression that is + -- either A'First or A'Last (with A an entity name), or X is an + -- entity name, and the two X's are the same and K1 and K2 are + -- known at compile time, in this case, the length can also be + -- computed at compile time, even though the bounds are not + -- known. A common case of this is e.g. (X'First..X'First+5). + + Extract_Length : declare + procedure Decompose_Expr + (Expr : Node_Id; + Ent : out Entity_Id; + Kind : out Character; + Cons : out Uint); + -- Given an expression, see if is of the form above, + -- X [+/- K]. If so Ent is set to the entity in X, + -- Kind is 'F','L','E' for 'First/'Last/simple entity, + -- and Cons is the value of K. If the expression is + -- not of the required form, Ent is set to Empty. + + -------------------- + -- Decompose_Expr -- + -------------------- + + procedure Decompose_Expr + (Expr : Node_Id; + Ent : out Entity_Id; + Kind : out Character; + Cons : out Uint) + is + Exp : Node_Id; + + begin + if Nkind (Expr) = N_Op_Add + and then Compile_Time_Known_Value (Right_Opnd (Expr)) + then + Exp := Left_Opnd (Expr); + Cons := Expr_Value (Right_Opnd (Expr)); + + elsif Nkind (Expr) = N_Op_Subtract + and then Compile_Time_Known_Value (Right_Opnd (Expr)) + then + Exp := Left_Opnd (Expr); + Cons := -Expr_Value (Right_Opnd (Expr)); + + else + Exp := Expr; + Cons := Uint_0; + end if; + + -- At this stage Exp is set to the potential X + + if Nkind (Exp) = N_Attribute_Reference then + if Attribute_Name (Exp) = Name_First then + Kind := 'F'; + elsif Attribute_Name (Exp) = Name_Last then + Kind := 'L'; + else + Ent := Empty; + return; + end if; + + Exp := Prefix (Exp); + + else + Kind := 'E'; + end if; + + if Is_Entity_Name (Exp) + and then Present (Entity (Exp)) + then + Ent := Entity (Exp); + else + Ent := Empty; + end if; + end Decompose_Expr; + + -- Local Variables + + Ent1, Ent2 : Entity_Id; + Kind1, Kind2 : Character; + Cons1, Cons2 : Uint; + + -- Start of processing for Extract_Length + + begin + Decompose_Expr (Type_Low_Bound (T), Ent1, Kind1, Cons1); + Decompose_Expr (Type_High_Bound (T), Ent2, Kind2, Cons2); + + if Present (Ent1) + and then Kind1 = Kind2 + and then Ent1 = Ent2 then - Len := UI_Max (Uint_0, - Expr_Value (Type_High_Bound (T)) - - Expr_Value (Type_Low_Bound (T)) + 1); + Len := Cons2 - Cons1 + 1; else Len := Uint_Minus_1; end if; - end if; + end Extract_Length; end Get_Static_Length; + -- Local Variables + Len_L : Uint; Len_R : Uint; + -- Start of processing for Length_Mismatch + begin Get_Static_Length (Left, Len_L); Get_Static_Length (Right, Len_R); @@ -2342,12 +2451,13 @@ package body Sem_Eval is Warn_On_Known_Condition (N); return; end if; - end; + end Length_Mismatch; + end if; -- Another special case: comparisons of access types, where one or both -- operands are known to be null, so the result can be determined. - elsif Is_Access_Type (Typ) then + if Is_Access_Type (Typ) then if Known_Null (Left) then if Known_Null (Right) then Fold_Uint (N, Test (Nkind (N) = N_Op_Eq), False); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 9e8687daad6..b9ef016a498 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -68,6 +68,7 @@ with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; +with Style; use Style; with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -395,9 +396,9 @@ package body Sem_Res is D : Node_Id; begin - -- Any use in a default expression is legal + -- Any use in a a spec-expression is legal - if In_Default_Expression then + if In_Spec_Expression then null; elsif Nkind (PN) = N_Range then @@ -434,10 +435,9 @@ package body Sem_Res is and then Scope (Disc) = Current_Scope and then not (Nkind (Parent (P)) = N_Subtype_Indication - and then - (Nkind (Parent (Parent (P))) = N_Component_Definition - or else - Nkind (Parent (Parent (P))) = N_Subtype_Declaration) + and then + Nkind_In (Parent (Parent (P)), N_Component_Definition, + N_Subtype_Declaration) and then Paren_Count (N) = 0) then Error_Msg_N @@ -554,8 +554,8 @@ package body Sem_Res is -- Legal case is in index or discriminant constraint - elsif Nkind (PN) = N_Index_Or_Discriminant_Constraint - or else Nkind (PN) = N_Discriminant_Association + elsif Nkind_In (PN, N_Index_Or_Discriminant_Constraint, + N_Discriminant_Association) then if Paren_Count (N) > 0 then Error_Msg_N @@ -576,9 +576,9 @@ package body Sem_Res is else D := PN; P := Parent (PN); - while Nkind (P) /= N_Component_Declaration - and then Nkind (P) /= N_Subtype_Indication - and then Nkind (P) /= N_Entry_Declaration + while not Nkind_In (P, N_Component_Declaration, + N_Subtype_Indication, + N_Entry_Declaration) loop D := P; P := Parent (P); @@ -591,10 +591,8 @@ package body Sem_Res is -- is of course a double fault. if (Nkind (P) = N_Subtype_Indication - and then - (Nkind (Parent (P)) = N_Component_Definition - or else - Nkind (Parent (P)) = N_Derived_Type_Definition) + and then Nkind_In (Parent (P), N_Component_Definition, + N_Derived_Type_Definition) and then D = Constraint (P)) -- The constraint itself may be given by a subtype indication, @@ -753,11 +751,10 @@ package body Sem_Res is loop P := Parent (C); exit when Nkind (P) = N_Subprogram_Body; - - if Nkind (P) = N_Or_Else or else - Nkind (P) = N_And_Then or else - Nkind (P) = N_If_Statement or else - Nkind (P) = N_Case_Statement + if Nkind_In (P, N_Or_Else, + N_And_Then, + N_If_Statement, + N_Case_Statement) then return False; @@ -963,25 +960,24 @@ package body Sem_Res is Require_Entity (N); end if; - -- If the context expects a value, and the name is a procedure, - -- this is most likely a missing 'Access. Do not try to resolve - -- the parameterless call, error will be caught when the outer - -- call is analyzed. + -- If the context expects a value, and the name is a procedure, this is + -- most likely a missing 'Access. Don't try to resolve the parameterless + -- call, error will be caught when the outer call is analyzed. if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Procedure and then not Is_Overloaded (N) and then - (Nkind (Parent (N)) = N_Parameter_Association - or else Nkind (Parent (N)) = N_Function_Call - or else Nkind (Parent (N)) = N_Procedure_Call_Statement) + Nkind_In (Parent (N), N_Parameter_Association, + N_Function_Call, + N_Procedure_Call_Statement) then return; end if; - -- Rewrite as call if overloadable entity that is (or could be, in - -- the overloaded case) a function call. If we know for sure that - -- the entity is an enumeration literal, we do not rewrite it. + -- Rewrite as call if overloadable entity that is (or could be, in the + -- overloaded case) a function call. If we know for sure that the entity + -- is an enumeration literal, we do not rewrite it. if (Is_Entity_Name (N) and then Is_Overloadable (Entity (N)) @@ -1386,7 +1382,19 @@ package body Sem_Res is Set_Entity (Op_Node, Op_Id); Generate_Reference (Op_Id, N, ' '); - Rewrite (N, Op_Node); + + -- Do rewrite setting Comes_From_Source on the result if the original + -- call came from source. Although it is not strictly the case that the + -- operator as such comes from the source, logically it corresponds + -- exactly to the function call in the source, so it should be marked + -- this way (e.g. to make sure that validity checks work fine). + + declare + CS : constant Boolean := Comes_From_Source (N); + begin + Rewrite (N, Op_Node); + Set_Comes_From_Source (N, CS); + end; -- If this is an arithmetic operator and the result type is private, -- the operands and the result must be wrapped in conversion to @@ -1487,11 +1495,11 @@ package body Sem_Res is return Kind; end Operator_Kind; - ----------------------------- - -- Pre_Analyze_And_Resolve -- - ----------------------------- + ---------------------------- + -- Preanalyze_And_Resolve -- + ---------------------------- - procedure Pre_Analyze_And_Resolve (N : Node_Id; T : Entity_Id) is + procedure Preanalyze_And_Resolve (N : Node_Id; T : Entity_Id) is Save_Full_Analysis : constant Boolean := Full_Analysis; begin @@ -1506,11 +1514,11 @@ package body Sem_Res is Expander_Mode_Restore; Full_Analysis := Save_Full_Analysis; - end Pre_Analyze_And_Resolve; + end Preanalyze_And_Resolve; -- Version without context type - procedure Pre_Analyze_And_Resolve (N : Node_Id) is + procedure Preanalyze_And_Resolve (N : Node_Id) is Save_Full_Analysis : constant Boolean := Full_Analysis; begin @@ -1522,7 +1530,7 @@ package body Sem_Res is Expander_Mode_Restore; Full_Analysis := Save_Full_Analysis; - end Pre_Analyze_And_Resolve; + end Preanalyze_And_Resolve; ---------------------------------- -- Replace_Actual_Discriminants -- @@ -1647,6 +1655,7 @@ package body Sem_Res is Intval => UR_To_Uint (Realval (N)))); Set_Etype (N, Universal_Integer); Set_Is_Static_Expression (N); + elsif Nkind (N) = N_String_Literal and then Is_Character_Type (Typ) then @@ -1909,8 +1918,8 @@ package body Sem_Res is -- of the arguments is Any_Type, and if so, suppress -- the message, since it is a cascaded error. - if Nkind (N) = N_Function_Call - or else Nkind (N) = N_Procedure_Call_Statement + if Nkind_In (N, N_Function_Call, + N_Procedure_Call_Statement) then declare A : Node_Id; @@ -2079,14 +2088,14 @@ package body Sem_Res is -- with a name that is an explicit dereference, there is -- nothing to be done at this point. - elsif Nkind (N) = N_Explicit_Dereference - or else Nkind (N) = N_Attribute_Reference - or else Nkind (N) = N_And_Then - or else Nkind (N) = N_Indexed_Component - or else Nkind (N) = N_Or_Else - or else Nkind (N) = N_Range - or else Nkind (N) = N_Selected_Component - or else Nkind (N) = N_Slice + elsif Nkind_In (N, N_Explicit_Dereference, + N_Attribute_Reference, + N_And_Then, + N_Indexed_Component, + N_Or_Else, + N_Range, + N_Selected_Component, + N_Slice) or else Nkind (Name (N)) = N_Explicit_Dereference then null; @@ -2094,8 +2103,7 @@ package body Sem_Res is -- For procedure or function calls, set the type of the name, -- and also the entity pointer for the prefix - elsif (Nkind (N) = N_Procedure_Call_Statement - or else Nkind (N) = N_Function_Call) + elsif Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call) and then (Is_Entity_Name (Name (N)) or else Nkind (Name (N)) = N_Operator_Symbol) then @@ -2398,8 +2406,8 @@ package body Sem_Res is elsif Present (Alias (Entity (N))) and then - Nkind (Parent (Parent (Entity (N)))) - = N_Subprogram_Renaming_Declaration + Nkind (Parent (Parent (Entity (N)))) = + N_Subprogram_Renaming_Declaration then Rewrite_Renamed_Operator (N, Alias (Entity (N)), Typ); @@ -2613,6 +2621,11 @@ package body Sem_Res is Prev : Node_Id := Empty; Orig_A : Node_Id; + procedure Check_Argument_Order; + -- Performs a check for the case where the actuals are all simple + -- identifiers that correspond to the formal names, but in the wrong + -- order, which is considered suspicious and cause for a warning. + procedure Check_Prefixed_Call; -- If the original node is an overloaded call in prefix notation, -- insert an 'Access or a dereference as needed over the first actual. @@ -2630,6 +2643,119 @@ package body Sem_Res is -- common type. Used to enforce the restrictions on array conversions -- of AI95-00246. + -------------------------- + -- Check_Argument_Order -- + -------------------------- + + procedure Check_Argument_Order is + begin + -- Nothing to do if no parameters, or original node is neither a + -- function call nor a procedure call statement (happens in the + -- operator-transformed-to-function call case), or the call does + -- not come from source, or this warning is off. + + if not Warn_On_Parameter_Order + or else + No (Parameter_Associations (N)) + or else + not Nkind_In (Original_Node (N), N_Procedure_Call_Statement, + N_Function_Call) + or else + not Comes_From_Source (N) + then + return; + end if; + + declare + Nargs : constant Nat := List_Length (Parameter_Associations (N)); + + begin + -- Nothing to do if only one parameter + + if Nargs < 2 then + return; + end if; + + -- Here if at least two arguments + + declare + Actuals : array (1 .. Nargs) of Node_Id; + Actual : Node_Id; + Formal : Node_Id; + + Wrong_Order : Boolean := False; + -- Set True if an out of order case is found + + begin + -- Collect identifier names of actuals, fail if any actual is + -- not a simple identifier, and record max length of name. + + Actual := First (Parameter_Associations (N)); + for J in Actuals'Range loop + if Nkind (Actual) /= N_Identifier then + return; + else + Actuals (J) := Actual; + Next (Actual); + end if; + end loop; + + -- If we got this far, all actuals are identifiers and the list + -- of their names is stored in the Actuals array. + + Formal := First_Formal (Nam); + for J in Actuals'Range loop + + -- If we ran out of formals, that's odd, probably an error + -- which will be detected elsewhere, but abandon the search. + + if No (Formal) then + return; + end if; + + -- If name matches and is in order OK + + if Chars (Formal) = Chars (Actuals (J)) then + null; + + else + -- If no match, see if it is elsewhere in list and if so + -- flag potential wrong order if type is compatible. + + for K in Actuals'Range loop + if Chars (Formal) = Chars (Actuals (K)) + and then + Has_Compatible_Type (Actuals (K), Etype (Formal)) + then + Wrong_Order := True; + goto Continue; + end if; + end loop; + + -- No match + + return; + end if; + + <> Next_Formal (Formal); + end loop; + + -- If Formals left over, also probably an error, skip warning + + if Present (Formal) then + return; + end if; + + -- Here we give the warning if something was out of order + + if Wrong_Order then + Error_Msg_N + ("actuals for this call may be in wrong order?", N); + end if; + end; + end; + end Check_Argument_Order; + ------------------------- -- Check_Prefixed_Call -- ------------------------- @@ -2866,6 +2992,8 @@ package body Sem_Res is -- Start of processing for Resolve_Actuals begin + Check_Argument_Order; + if Present (First_Actual (N)) then Check_Prefixed_Call; end if; @@ -2889,7 +3017,7 @@ package body Sem_Res is -- Case where actual is present - -- If the actual is an entity, generate a reference to it now. We + -- If the actual is an entity, generate a reference to it now. We -- do this before the actual is resolved, because a formal of some -- protected subprogram, or a task discriminant, will be rewritten -- during expansion, and the reference to the source entity may @@ -2906,7 +3034,6 @@ package body Sem_Res is and then Ekind (F) /= E_In_Parameter then Generate_Reference (Orig_A, A, 'm'); - elsif not Is_Overloaded (A) then Generate_Reference (Orig_A, A); end if; @@ -2918,6 +3045,14 @@ package body Sem_Res is or else Chars (Selector_Name (Parent (A))) = Chars (F)) then + -- If style checking mode on, check match of formal name + + if Style_Check then + if Nkind (Parent (A)) = N_Parameter_Association then + Check_Identifier (Selector_Name (Parent (A)), F); + end if; + end if; + -- If the formal is Out or In_Out, do not resolve and expand the -- conversion, because it is subsequently expanded into explicit -- temporaries and assignments. However, the object of the @@ -2941,32 +3076,51 @@ package body Sem_Res is if Has_Aliased_Components (Etype (Expression (A))) /= Has_Aliased_Components (Etype (F)) then - if Ada_Version < Ada_05 then - Error_Msg_N - ("both component types in a view conversion must be" - & " aliased, or neither", A); - -- Ada 2005: rule is relaxed (see AI-363) + -- In a view conversion, the conversion must be legal in + -- both directions, and thus both component types must be + -- aliased, or neither (4.6 (8)). - elsif Has_Aliased_Components (Etype (F)) - and then - not Has_Aliased_Components (Etype (Expression (A))) + -- The additional rule 4.6 (24.9.2) seems unduly + -- restrictive: the privacy requirement should not + -- apply to generic types, and should be checked in + -- an instance. ARG query is in order. + + Error_Msg_N + ("both component types in a view conversion must be" + & " aliased, or neither", A); + + elsif + not Same_Ancestor (Etype (F), Etype (Expression (A))) + then + if Is_By_Reference_Type (Etype (F)) + or else Is_By_Reference_Type (Etype (Expression (A))) then Error_Msg_N - ("view conversion operand must have aliased " & - "components", N); - Error_Msg_N - ("\since target type has aliased components", N); + ("view conversion between unrelated by reference " & + "array types not allowed (\'A'I-00246)", A); + else + declare + Comp_Type : constant Entity_Id := + Component_Type + (Etype (Expression (A))); + begin + if Comes_From_Source (A) + and then Ada_Version >= Ada_05 + and then + ((Is_Private_Type (Comp_Type) + and then not Is_Generic_Type (Comp_Type)) + or else Is_Tagged_Type (Comp_Type) + or else Is_Volatile (Comp_Type)) + then + Error_Msg_N + ("component type of a view conversion cannot" + & " be private, tagged, or volatile" + & " (RM 4.6 (24))", + Expression (A)); + end if; + end; end if; - - elsif not Same_Ancestor (Etype (F), Etype (Expression (A))) - and then - (Is_By_Reference_Type (Etype (F)) - or else Is_By_Reference_Type (Etype (Expression (A)))) - then - Error_Msg_N - ("view conversion between unrelated by reference " & - "array types not allowed (\'A'I-00246)", A); end if; end if; @@ -3024,14 +3178,15 @@ package body Sem_Res is 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_Etype (New_Itype, Etype (A)); Set_Directly_Designated_Type (New_Itype, Directly_Designated_Type (Etype (A))); Set_Etype (A, New_Itype); @@ -3043,8 +3198,7 @@ package body Sem_Res is -- enabled only, otherwise the transient scope will not -- be removed in the expansion of the wrapped construct. - if (Is_Controlled (DDT) - or else Has_Task (DDT)) + if (Is_Controlled (DDT) or else Has_Task (DDT)) and then Expander_Active then Establish_Transient_Scope (A, False); @@ -3056,9 +3210,13 @@ package body Sem_Res is -- a tagged synchronized type, declared outside of the type. -- In this case the controlling actual must be converted to -- its corresponding record type, which is the formal type. + -- The actual may be a subtype, either because of a constraint + -- or because it is a generic actual, so use base type to + -- locate concurrent type. if Is_Concurrent_Type (Etype (A)) - and then Etype (F) = Corresponding_Record_Type (Etype (A)) + and then Etype (F) = + Corresponding_Record_Type (Base_Type (Etype (A))) then Rewrite (A, Unchecked_Convert_To @@ -3130,14 +3288,14 @@ package body Sem_Res is if Ekind (F) /= E_In_Parameter then -- For an Out parameter, check for useless assignment. Note - -- that we can't set Last_Assignment this early, because we - -- may kill current values in Resolve_Call, and that call - -- would clobber the Last_Assignment field. + -- that we can't set Last_Assignment this early, because we may + -- kill current values in Resolve_Call, and that call would + -- clobber the Last_Assignment field. - -- Note: call Warn_On_Useless_Assignment before doing the - -- check below for Is_OK_Variable_For_Out_Formal so that the - -- setting of Referenced_As_LHS/Referenced_As_Out_Formal - -- properly reflects the last assignment, not this one! + -- Note: call Warn_On_Useless_Assignment before doing the check + -- below for Is_OK_Variable_For_Out_Formal so that the setting + -- of Referenced_As_LHS/Referenced_As_Out_Formal properly + -- reflects the last assignment, not this one! if Ekind (F) = E_Out_Parameter then if Warn_On_Modified_As_Out_Parameter (F) @@ -3258,8 +3416,8 @@ package body Sem_Res is end if; -- An actual associated with an access parameter is implicitly - -- converted to the anonymous access type of the formal and - -- must satisfy the legality checks for access conversions. + -- converted to the anonymous access type of the formal and must + -- satisfy the legality checks for access conversions. if Ekind (F_Typ) = E_Anonymous_Access_Type then if not Valid_Conversion (A, F_Typ, A) then @@ -3500,8 +3658,7 @@ package body Sem_Res is function In_Dispatching_Context return Boolean is Par : constant Node_Id := Parent (N); begin - return (Nkind (Par) = N_Function_Call - or else Nkind (Par) = N_Procedure_Call_Statement) + return Nkind_In (Par, N_Function_Call, N_Procedure_Call_Statement) and then Is_Entity_Name (Name (Par)) and then Is_Dispatching_Operation (Entity (Name (Par))); end In_Dispatching_Context; @@ -3691,10 +3848,7 @@ package body Sem_Res is Aggr := Original_Node (Expression (E)); if Has_Discriminants (Subtyp) - and then - (Nkind (Aggr) = N_Aggregate - or else - Nkind (Aggr) = N_Extension_Aggregate) + and then Nkind_In (Aggr, N_Aggregate, N_Extension_Aggregate) then Discrim := First_Discriminant (Base_Type (Subtyp)); @@ -3938,18 +4092,18 @@ package body Sem_Res is -- N is the expression after "delta" in a fixed_point_definition; -- see RM-3.5.9(6): - return Nkind (Parent (N)) = N_Ordinary_Fixed_Point_Definition - or else Nkind (Parent (N)) = N_Decimal_Fixed_Point_Definition + return Nkind_In (Parent (N), N_Ordinary_Fixed_Point_Definition, + N_Decimal_Fixed_Point_Definition, -- N is one of the bounds in a real_range_specification; -- see RM-3.5.7(5): - or else Nkind (Parent (N)) = N_Real_Range_Specification + N_Real_Range_Specification, -- N is the expression of a delta_constraint; -- see RM-J.3(3): - or else Nkind (Parent (N)) = N_Delta_Constraint; + N_Delta_Constraint); end Expected_Type_Is_Any_Real; ----------------------------- @@ -4143,8 +4297,7 @@ package body Sem_Res is -- conversion to a specific fixed-point type (instead the expander -- takes care of the case). - elsif (B_Typ = Universal_Integer - or else B_Typ = Universal_Real) + elsif (B_Typ = Universal_Integer or else B_Typ = Universal_Real) and then Present (Universal_Interpretation (L)) and then Present (Universal_Interpretation (R)) then @@ -4153,15 +4306,14 @@ package body Sem_Res is Set_Etype (N, B_Typ); elsif (B_Typ = Universal_Real - or else Etype (N) = Universal_Fixed - or else (Etype (N) = Any_Fixed - and then Is_Fixed_Point_Type (B_Typ)) - or else (Is_Fixed_Point_Type (B_Typ) - and then (Is_Integer_Or_Universal (L) - or else - Is_Integer_Or_Universal (R)))) - and then (Nkind (N) = N_Op_Multiply or else - Nkind (N) = N_Op_Divide) + or else Etype (N) = Universal_Fixed + or else (Etype (N) = Any_Fixed + and then Is_Fixed_Point_Type (B_Typ)) + or else (Is_Fixed_Point_Type (B_Typ) + and then (Is_Integer_Or_Universal (L) + or else + Is_Integer_Or_Universal (R)))) + and then Nkind_In (N, N_Op_Multiply, N_Op_Divide) then if TL = Universal_Integer or else TR = Universal_Integer then Check_For_Visible_Operator (N, B_Typ); @@ -4189,38 +4341,36 @@ package body Sem_Res is Set_Mixed_Mode_Operand (R, TL); end if; - -- Check the rule in RM05-4.5.5(19.1/2) disallowing the - -- universal_fixed multiplying operators from being used when the - -- expected type is also universal_fixed. Note that B_Typ will be - -- Universal_Fixed in some cases where the expected type is actually - -- Any_Real; Expected_Type_Is_Any_Real takes care of that case. + -- Check the rule in RM05-4.5.5(19.1/2) disallowing universal_fixed + -- multiplying operators from being used when the expected type is + -- also universal_fixed. Note that B_Typ will be Universal_Fixed in + -- some cases where the expected type is actually Any_Real; + -- Expected_Type_Is_Any_Real takes care of that case. if Etype (N) = Universal_Fixed or else Etype (N) = Any_Fixed then if B_Typ = Universal_Fixed and then not Expected_Type_Is_Any_Real (N) - and then Nkind (Parent (N)) /= N_Type_Conversion - and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion + and then not Nkind_In (Parent (N), N_Type_Conversion, + N_Unchecked_Type_Conversion) then - Error_Msg_N - ("type cannot be determined from context!", N); - Error_Msg_N - ("\explicit conversion to result type required", N); + Error_Msg_N ("type cannot be determined from context!", N); + Error_Msg_N ("\explicit conversion to result type required", N); Set_Etype (L, Any_Type); Set_Etype (R, Any_Type); else if Ada_Version = Ada_83 - and then Etype (N) = Universal_Fixed - and then Nkind (Parent (N)) /= N_Type_Conversion - and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion + and then Etype (N) = Universal_Fixed + and then not + Nkind_In (Parent (N), N_Type_Conversion, + N_Unchecked_Type_Conversion) then Error_Msg_N - ("(Ada 83) fixed-point operation " & - "needs explicit conversion", - N); + ("(Ada 83) fixed-point operation " + & "needs explicit conversion", N); end if; -- The expected type is "any real type" in contexts like @@ -4239,8 +4389,7 @@ package body Sem_Res is and then (Is_Integer_Or_Universal (L) or else Nkind (L) = N_Real_Literal or else Nkind (R) = N_Real_Literal - or else - Is_Integer_Or_Universal (R)) + or else Is_Integer_Or_Universal (R)) then Set_Etype (N, B_Typ); @@ -4254,7 +4403,8 @@ package body Sem_Res is else if (TL = Universal_Integer or else TL = Universal_Real) - and then (TR = Universal_Integer or else TR = Universal_Real) + and then + (TR = Universal_Integer or else TR = Universal_Real) then Check_For_Visible_Operator (N, B_Typ); end if; @@ -4263,9 +4413,7 @@ package body Sem_Res is -- universal fixed, this is an error, unless there is only one -- applicable fixed_point type (usually duration). - if B_Typ = Universal_Fixed - and then Etype (L) = Universal_Fixed - then + if B_Typ = Universal_Fixed and then Etype (L) = Universal_Fixed then T := Unique_Fixed_Point_Type (N); if T = Any_Type then @@ -4306,19 +4454,17 @@ package body Sem_Res is -- Give warning if explicit division by zero - if (Nkind (N) = N_Op_Divide - or else Nkind (N) = N_Op_Rem - or else Nkind (N) = N_Op_Mod) + if Nkind_In (N, N_Op_Divide, N_Op_Rem, N_Op_Mod) and then not Division_Checks_Suppressed (Etype (N)) then Rop := Right_Opnd (N); if Compile_Time_Known_Value (Rop) and then ((Is_Integer_Type (Etype (Rop)) - and then Expr_Value (Rop) = Uint_0) + and then Expr_Value (Rop) = Uint_0) or else (Is_Real_Type (Etype (Rop)) - and then Expr_Value_R (Rop) = Ureal_0)) + and then Expr_Value_R (Rop) = Ureal_0)) then -- Specialize the warning message according to the operation @@ -4351,6 +4497,38 @@ package body Sem_Res is Activate_Division_Check (N); end if; end if; + + -- If Restriction No_Implicit_Conditionals is active, then it is + -- violated if either operand can be negative for mod, or for rem + -- if both operands can be negative. + + if Restrictions.Set (No_Implicit_Conditionals) + and then Nkind_In (N, N_Op_Rem, N_Op_Mod) + then + declare + Lo : Uint; + Hi : Uint; + OK : Boolean; + + LNeg : Boolean; + RNeg : Boolean; + -- Set if corresponding operand might be negative + + begin + Determine_Range (Left_Opnd (N), OK, Lo, Hi); + LNeg := (not OK) or else Lo < 0; + + Determine_Range (Right_Opnd (N), OK, Lo, Hi); + RNeg := (not OK) or else Lo < 0; + + if (Nkind (N) = N_Op_Rem and then (LNeg and RNeg)) + or else + (Nkind (N) = N_Op_Mod and then (LNeg or RNeg)) + then + Check_Restriction (No_Implicit_Conditionals, N); + end if; + end; + end if; end if; Check_Unset_Reference (L); @@ -4426,8 +4604,7 @@ package body Sem_Res is -- operations use the same circuitry because the name in the call -- can be an arbitrary expression with special resolution rules. - elsif Nkind (Subp) = N_Selected_Component - or else Nkind (Subp) = N_Indexed_Component + elsif Nkind_In (Subp, N_Selected_Component, N_Indexed_Component) or else (Is_Entity_Name (Subp) and then Ekind (Entity (Subp)) = E_Entry) then @@ -4474,11 +4651,16 @@ package body Sem_Res is P := N; loop P := Parent (P); - exit when No (P); + + -- Exclude calls that occur within the default of a formal + -- parameter of the entry, since those are evaluated outside + -- of the body. + + exit when No (P) or else Nkind (P) = N_Parameter_Specification; if Nkind (P) = N_Entry_Body or else (Nkind (P) = N_Subprogram_Body - and then Is_Entry_Barrier_Function (P)) + and then Is_Entry_Barrier_Function (P)) then Rtype := Etype (N); Error_Msg_NE @@ -4540,7 +4722,7 @@ package body Sem_Res is Error_Msg_N ("\cannot call operation that may modify it", N); end if; - -- Freeze the subprogram name if not in default expression. Note that we + -- Freeze the subprogram name if not in a spec-expression. Note that we -- freeze procedure calls as well as function calls. Procedure calls are -- not frozen according to the rules (RM 13.14(14)) because it is -- impossible to have a procedure call to a non-frozen procedure in pure @@ -4548,7 +4730,7 @@ package body Sem_Res is -- needs extending because we can generate procedure calls that need -- freezing. - if Is_Entity_Name (Subp) and then not In_Default_Expression then + if Is_Entity_Name (Subp) and then not In_Spec_Expression then Freeze_Expression (Subp); end if; @@ -4803,12 +4985,14 @@ package body Sem_Res is -- If the subprogram is marked Inline_Always, then even if it returns -- an unconstrained type the call does not require use of the secondary - -- stack. + -- stack. However, inlining will only take place if the body to inline + -- is already present. It may not be available if e.g. the subprogram is + -- declared in a child instance. if Is_Inlined (Nam) - and then Present (First_Rep_Item (Nam)) - and then Nkind (First_Rep_Item (Nam)) = N_Pragma - and then Pragma_Name (First_Rep_Item (Nam)) = Name_Inline_Always + and then Has_Pragma_Inline_Always (Nam) + and then Nkind (Unit_Declaration_Node (Nam)) = N_Subprogram_Declaration + and then Present (Body_To_Inline (Unit_Declaration_Node (Nam))) then null; @@ -4883,8 +5067,14 @@ package body Sem_Res is -- way we still take advantage of the current value information while -- scanning the actuals. - if (not Is_Library_Level_Entity (Nam) - or else Suppress_Value_Tracking_On_Call (Current_Scope)) + -- We suppress killing values if we are processing the nodes associated + -- with N_Freeze_Entity nodes. Otherwise the declaration of a tagged + -- type kills all the values as part of analyzing the code that + -- initializes the dispatch tables. + + if Inside_Freezing_Actions = 0 + and then (not Is_Library_Level_Entity (Nam) + or else Suppress_Value_Tracking_On_Call (Current_Scope)) and then (Comes_From_Source (Nam) or else (Present (Alias (Nam)) and then Comes_From_Source (Alias (Nam)))) @@ -5291,7 +5481,7 @@ package body Sem_Res is and then Comes_From_Source (E) and then No (Constant_Value (E)) and then Is_Frozen (Etype (E)) - and then not In_Default_Expression + and then not In_Spec_Expression and then not Is_Imported (E) then @@ -5852,6 +6042,7 @@ package body Sem_Res is (Corresponding_Equality (Entity (N))) then Eval_Relational_Op (N); + elsif Nkind (N) = N_Op_Ne and then Is_Abstract_Subprogram (Entity (N)) then @@ -6382,9 +6573,8 @@ package body Sem_Res is -- In the common case of a call which uses an explicitly null -- value for an access parameter, give specialized error msg - if Nkind (Parent (N)) = N_Procedure_Call_Statement - or else - Nkind (Parent (N)) = N_Function_Call + if Nkind_In (Parent (N), N_Procedure_Call_Statement, + N_Function_Call) then Error_Msg_N ("null is not allowed as argument for an access parameter", N); @@ -6999,7 +7189,7 @@ package body Sem_Res is -- sequences that otherwise fail to notice the modification. if Is_Entity_Name (P) and then Treat_As_Volatile (Entity (P)) then - Note_Possible_Modification (P); + Note_Possible_Modification (P, Sure => False); end if; end Resolve_Reference; @@ -7223,8 +7413,8 @@ package body Sem_Res is Resolve (L, B_Typ); Resolve (R, B_Typ); - -- Check for issuing warning for always False assert, this happens - -- when assertions are turned off, in which case the pragma Assert + -- Check for issuing warning for always False assert/check, this happens + -- when assertions are turned off, in which case the pragma Assert/Check -- was transformed into: -- if False and then then ... @@ -7241,6 +7431,7 @@ package body Sem_Res is then declare Orig : constant Node_Id := Original_Node (Parent (N)); + begin if Nkind (Orig) = N_Pragma and then Pragma_Name (Orig) = Name_Assert @@ -7269,6 +7460,29 @@ package body Sem_Res is Error_Msg_N ("?assertion would fail at run-time", Orig); end if; end; + + -- Similar processing for Check pragma + + elsif Nkind (Orig) = N_Pragma + and then Pragma_Name (Orig) = Name_Check + then + -- Don't want to warn if original condition is explicit False + + declare + Expr : constant Node_Id := + Original_Node + (Expression + (Next (First + (Pragma_Argument_Associations (Orig))))); + begin + if Is_Entity_Name (Expr) + and then Entity (Expr) = Standard_False + then + null; + else + Error_Msg_N ("?check would fail at run-time", Orig); + end if; + end; end if; end; end if; @@ -7477,16 +7691,17 @@ package body Sem_Res is elsif Nkind (Parent (N)) = N_Op_Concat and then not Need_Check - and then Nkind (Original_Node (N)) /= N_Character_Literal - and then Nkind (Original_Node (N)) /= N_Attribute_Reference - and then Nkind (Original_Node (N)) /= N_Qualified_Expression - and then Nkind (Original_Node (N)) /= N_Type_Conversion + and then not Nkind_In (Original_Node (N), N_Character_Literal, + N_Attribute_Reference, + N_Qualified_Expression, + N_Type_Conversion) then Subtype_Id := Typ; -- Otherwise we must create a string literal subtype. Note that the -- whole idea of string literal subtypes is simply to avoid the need -- for building a full fledged array subtype for each literal. + else Set_String_Literal_Subtype (N, Typ); Subtype_Id := Etype (N); @@ -7607,10 +7822,8 @@ package body Sem_Res is -- corresponding character aggregate and let the aggregate -- code do the checking. - if R_Typ = Standard_Character - or else R_Typ = Standard_Wide_Character - or else R_Typ = Standard_Wide_Wide_Character - then + if Is_Standard_Character_Type (R_Typ) then + -- Check for the case of full range, where we are definitely OK if Component_Type (Typ) = Base_Type (Component_Type (Typ)) then @@ -7730,10 +7943,10 @@ package body Sem_Res is Set_Etype (Operand, Universal_Real); elsif Is_Numeric_Type (Typ) - and then (Nkind (Operand) = N_Op_Multiply - or else Nkind (Operand) = N_Op_Divide) + and then Nkind_In (Operand, N_Op_Multiply, N_Op_Divide) and then (Etype (Right_Opnd (Operand)) = Universal_Real - or else Etype (Left_Opnd (Operand)) = Universal_Real) + or else + Etype (Left_Opnd (Operand)) = Universal_Real) then -- Return if expression is ambiguous @@ -8043,11 +8256,7 @@ package body Sem_Res is -- mod. These are the cases where the grouping can affect results. if Paren_Count (Rorig) = 0 - and then (Nkind (Rorig) = N_Op_Mod - or else - Nkind (Rorig) = N_Op_Multiply - or else - Nkind (Rorig) = N_Op_Divide) + and then Nkind_In (Rorig, N_Op_Mod, N_Op_Multiply, N_Op_Divide) then -- For mod, we always give the warning, since the value is -- affected by the parenthesization (e.g. (-5) mod 315 /= @@ -8129,9 +8338,7 @@ package body Sem_Res is -- overflow is impossible (divisor > 1) or we have a case of -- division by zero in any case. - if (Nkind (Rorig) = N_Op_Divide - or else - Nkind (Rorig) = N_Op_Rem) + if Nkind_In (Rorig, N_Op_Divide, N_Op_Rem) and then Compile_Time_Known_Value (Right_Opnd (Rorig)) and then UI_Abs (Expr_Value (Right_Opnd (Rorig))) /= 1 then @@ -8334,7 +8541,6 @@ package body Sem_Res is Set_First_Index (Slice_Subtype, Index); Set_Etype (Slice_Subtype, Base_Type (Etype (N))); Set_Is_Constrained (Slice_Subtype, True); - Init_Size_Align (Slice_Subtype); Check_Compile_Time_Size (Slice_Subtype); @@ -8349,7 +8555,9 @@ package body Sem_Res is -- call to Check_Compile_Time_Size could be eliminated, which would -- be nice, because then that routine could be made private to Freeze. - if Is_Packed (Slice_Subtype) and not In_Default_Expression then + -- Why the test for In_Spec_Expression here ??? + + if Is_Packed (Slice_Subtype) and not In_Spec_Expression then Freeze_Itype (Slice_Subtype, N); end if; @@ -8435,7 +8643,6 @@ package body Sem_Res is 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, @@ -8573,7 +8780,6 @@ package body Sem_Res is if Nkind (N) = N_Real_Literal then Error_Msg_NE ("?real literal interpreted as }!", N, T1); - else Error_Msg_NE ("?universal_fixed expression interpreted as }!", N, T1); end if; @@ -8736,11 +8942,12 @@ package body Sem_Res is return False; end if; - -- Check that component subtypes statically match + -- Check that component subtypes statically match. For numeric + -- types this means that both must be either constrained or + -- unconstrained. For enumeration types the bounds must match. + -- All of this is checked in Subtypes_Statically_Match. - if Is_Constrained (Target_Comp_Type) /= - Is_Constrained (Opnd_Comp_Type) - or else not Subtypes_Statically_Match + if not Subtypes_Statically_Match (Target_Comp_Type, Opnd_Comp_Type) then Error_Msg_N @@ -8993,7 +9200,7 @@ package body Sem_Res is if Nkind (Operand) = N_Selected_Component and then Object_Access_Level (Operand) > - Type_Access_Level (Target_Type) + 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. @@ -9102,8 +9309,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. -- 2.30.2