diff options
author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2008-04-08 06:50:04 +0000 |
---|---|---|
committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2008-04-08 06:50:04 +0000 |
commit | 177675a789607830e5aad49463cdfb3bef275a7b (patch) | |
tree | 3eb987e31cbb9c471a969036173a7789787d3095 /gcc/ada/sem_res.adb | |
parent | 40a5a4cbaac65746f08f8e124aaa29844fc94dbb (diff) | |
download | gcc-177675a789607830e5aad49463cdfb3bef275a7b.tar.gz |
2008-04-08 Hristian Kirtchev <kirtchev@adacore.com>
Ed Schonberg <schonberg@adacore.com>
Robert Dewar <dewar@adacore.com>
* 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
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@134027 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada/sem_res.adb')
-rw-r--r-- | gcc/ada/sem_res.adb | 581 |
1 files changed, 394 insertions, 187 deletions
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; + + <<Continue>> 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 <condition> 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. |