diff options
Diffstat (limited to 'gcc/ada/sem_ch4.adb')
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 1048 |
1 files changed, 633 insertions, 415 deletions
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 5910112..c92fb06 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2019, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2020, 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- -- @@ -171,6 +171,7 @@ package body Sem_Ch4 is -- being called. The caller will have verified that the object is legal -- for the call. If the remaining parameters match, the first parameter -- will rewritten as a dereference if needed, prior to completing analysis. + procedure Check_Misspelled_Selector (Prefix : Entity_Id; Sel : Node_Id); @@ -276,20 +277,6 @@ package body Sem_Ch4 is -- type is not directly visible. The routine uses this type to emit a more -- informative message. - function Process_Implicit_Dereference_Prefix - (E : Entity_Id; - P : Node_Id) return Entity_Id; - -- Called when P is the prefix of an implicit dereference, denoting an - -- object E. The function returns the designated type of the prefix, taking - -- into account that the designated type of an anonymous access type may be - -- a limited view, when the nonlimited view is visible. - -- - -- If in semantics only mode (-gnatc or generic), the function also records - -- that the prefix is a reference to E, if any. Normally, such a reference - -- is generated only when the implicit dereference is expanded into an - -- explicit one, but for consistency we must generate the reference when - -- expansion is disabled as well. - procedure Remove_Abstract_Operations (N : Node_Id); -- Ada 2005: implementation of AI-310. An abstract non-dispatching -- operation is not a candidate interpretation. @@ -299,6 +286,7 @@ package body Sem_Ch4 is Prefix : Node_Id; Exprs : List_Id) return Boolean; -- AI05-0139: Generalized indexing to support iterators over containers + -- ??? Need to provide a more detailed spec of what this function does function Try_Indexed_Call (N : Node_Id; @@ -392,7 +380,7 @@ package body Sem_Ch4 is if Nkind (N) in N_Membership_Test then Error_Msg_N ("ambiguous operands for membership", N); - elsif Nkind_In (N, N_Op_Eq, N_Op_Ne) then + elsif Nkind (N) in N_Op_Eq | N_Op_Ne then Error_Msg_N ("ambiguous operands for equality", N); else @@ -469,8 +457,6 @@ package body Sem_Ch4 is Onode : Node_Id; begin - Check_SPARK_05_Restriction ("allocator is not allowed", N); - -- Deal with allocator restrictions -- In accordance with H.4(7), the No_Allocators restriction only applies @@ -680,7 +666,7 @@ package body Sem_Ch4 is -- that outside of spec expressions, otherwise the declaration -- cannot be inserted and analyzed. In such a case, GNATprove -- later rejects the allocator as it is not used here in - -- a non-interfering context (SPARK 4.8(2) and 7.1.3(12)). + -- a non-interfering context (SPARK 4.8(2) and 7.1.3(10)). if Expander_Active or else (GNATprove_Mode and then not In_Spec_Expression) @@ -935,16 +921,8 @@ package body Sem_Ch4 is if Present (Op_Id) then if Ekind (Op_Id) = E_Operator then - - if Nkind_In (N, N_Op_Divide, N_Op_Mod, N_Op_Multiply, N_Op_Rem) - and then Treat_Fixed_As_Integer (N) - then - null; - else - Set_Etype (N, Any_Type); - Find_Arithmetic_Types (L, R, Op_Id, N); - end if; - + Set_Etype (N, Any_Type); + Find_Arithmetic_Types (L, R, Op_Id, N); else Set_Etype (N, Any_Type); Add_One_Interp (N, Op_Id, Etype (Op_Id)); @@ -1005,10 +983,6 @@ package body Sem_Ch4 is -- Flag indicates whether an interpretation of the prefix is a -- parameterless call that returns an access_to_subprogram. - procedure Check_Mixed_Parameter_And_Named_Associations; - -- Check that parameter and named associations are not mixed. This is - -- a restriction in SPARK mode. - procedure Check_Writable_Actuals (N : Node_Id); -- If the call has out or in-out parameters then mark its outermost -- enclosing construct as a node on which the writable actuals check @@ -1024,36 +998,6 @@ package body Sem_Ch4 is procedure No_Interpretation; -- Output error message when no valid interpretation exists - -------------------------------------------------- - -- Check_Mixed_Parameter_And_Named_Associations -- - -------------------------------------------------- - - procedure Check_Mixed_Parameter_And_Named_Associations is - Actual : Node_Id; - Named_Seen : Boolean; - - begin - Named_Seen := False; - - Actual := First (Actuals); - while Present (Actual) loop - case Nkind (Actual) is - when N_Parameter_Association => - if Named_Seen then - Check_SPARK_05_Restriction - ("named association cannot follow positional one", - Actual); - exit; - end if; - - when others => - Named_Seen := True; - end case; - - Next (Actual); - end loop; - end Check_Mixed_Parameter_And_Named_Associations; - ---------------------------- -- Check_Writable_Actuals -- ---------------------------- @@ -1119,8 +1063,8 @@ package body Sem_Ch4 is -- performing the writable actuals check. if Has_Arbitrary_Evaluation_Order (Nkind (P)) - and then not Nkind_In (P, N_Assignment_Statement, - N_Object_Declaration) + and then Nkind (P) not in + N_Assignment_Statement | N_Object_Declaration then Outermost := P; end if; @@ -1129,8 +1073,8 @@ package body Sem_Ch4 is exit when Stop_Subtree_Climbing (Nkind (P)) or else (Nkind (P) = N_Range - and then not - Nkind_In (Parent (P), N_In, N_Not_In)); + and then + Nkind (Parent (P)) not in N_In | N_Not_In); P := Parent (P); end loop; @@ -1180,8 +1124,7 @@ package body Sem_Ch4 is -- Check for tasking cases where only an entry call will do elsif not L - and then Nkind_In (K, N_Entry_Call_Alternative, - N_Triggering_Alternative) + and then K in N_Entry_Call_Alternative | N_Triggering_Alternative then Error_Msg_N ("entry name expected", Nam); @@ -1195,10 +1138,6 @@ package body Sem_Ch4 is -- Start of processing for Analyze_Call begin - if Restriction_Check_Required (SPARK_05) then - Check_Mixed_Parameter_And_Named_Associations; - end if; - -- Initialize the type of the result of the call to the error type, -- which will be reset if the type is successfully resolved. @@ -1224,8 +1163,7 @@ package body Sem_Ch4 is -- type is an array, F (X) cannot be interpreted as an indirect call -- through the result of the call to F. - elsif Is_Access_Type (Etype (Nam)) - and then Ekind (Designated_Type (Etype (Nam))) = E_Subprogram_Type + elsif Is_Access_Subprogram_Type (Base_Type (Etype (Nam))) and then (not Name_Denotes_Function or else Nkind (N) = N_Procedure_Call_Statement @@ -1246,10 +1184,10 @@ package body Sem_Ch4 is elsif Nkind (Nam) = N_Selected_Component then Nam_Ent := Entity (Selector_Name (Nam)); - if not Ekind_In (Nam_Ent, E_Entry, - E_Entry_Family, - E_Function, - E_Procedure) + if Ekind (Nam_Ent) not in E_Entry + | E_Entry_Family + | E_Function + | E_Procedure then Error_Msg_N ("name in call is not a callable entity", Nam); Set_Etype (N, Any_Type); @@ -1424,7 +1362,7 @@ package body Sem_Ch4 is Set_Etype (Nam, It.Typ); end if; - elsif Nkind_In (Name (N), N_Function_Call, N_Selected_Component) + elsif Nkind (Name (N)) in N_Function_Call | N_Selected_Component then Remove_Interp (X); end if; @@ -2100,13 +2038,6 @@ package body Sem_Ch4 is -- Start of processing for Analyze_Explicit_Dereference begin - -- If source node, check SPARK restriction. We guard this with the - -- source node check, because ??? - - if Comes_From_Source (N) then - Check_SPARK_05_Restriction ("explicit dereference is not allowed", N); - end if; - -- In formal verification mode, keep track of all reads and writes -- through explicit dereferences. @@ -2286,17 +2217,91 @@ package body Sem_Ch4 is ------------------------------------- procedure Analyze_Expression_With_Actions (N : Node_Id) is + + procedure Check_Action_OK (A : Node_Id); + -- Check that the action is something that is allows as a declare_item + -- of a declare_expression, except the checks are suppressed for + -- generated code. + + procedure Check_Action_OK (A : Node_Id) is + begin + if not Comes_From_Source (N) or else not Comes_From_Source (A) then + return; -- Allow anything in generated code + end if; + + case Nkind (A) is + when N_Object_Declaration => + if Nkind (Object_Definition (A)) = N_Access_Definition then + Error_Msg_N + ("anonymous access type not allowed in declare_expression", + Object_Definition (A)); + end if; + + if Aliased_Present (A) then + Error_Msg_N ("aliased not allowed in declare_expression", A); + end if; + + if Constant_Present (A) + and then not Is_Limited_Type (Etype (Defining_Identifier (A))) + then + return; -- nonlimited constants are OK + end if; + + when N_Object_Renaming_Declaration => + if Present (Access_Definition (A)) then + Error_Msg_N + ("anonymous access type not allowed in declare_expression", + Access_Definition (A)); + end if; + + if not Is_Limited_Type (Etype (Defining_Identifier (A))) then + return; -- ???For now; the RM rule is a bit more complicated + end if; + + when others => + null; -- Nothing else allowed, not even pragmas + end case; + + Error_Msg_N ("object renaming or constant declaration expected", A); + end Check_Action_OK; + A : Node_Id; + EWA_Scop : Entity_Id; + + -- Start of processing for Analyze_Expression_With_Actions begin + -- Create a scope, which is needed to provide proper visibility of the + -- declare_items. + + EWA_Scop := New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B'); + Set_Etype (EWA_Scop, Standard_Void_Type); + Set_Scope (EWA_Scop, Current_Scope); + Set_Parent (EWA_Scop, N); + Push_Scope (EWA_Scop); + + -- If this Expression_With_Actions node comes from source, then it + -- represents a declare_expression; increment the counter to take note + -- of that. + + if Comes_From_Source (N) then + In_Declare_Expr := In_Declare_Expr + 1; + end if; + A := First (Actions (N)); while Present (A) loop Analyze (A); + Check_Action_OK (A); Next (A); end loop; Analyze_Expression (Expression (N)); Set_Etype (N, Etype (Expression (N))); + End_Scope; + + if Comes_From_Source (N) then + In_Declare_Expr := In_Declare_Expr - 1; + end if; end Analyze_Expression_With_Actions; --------------------------- @@ -2326,10 +2331,6 @@ package body Sem_Ch4 is Else_Expr := Next (Then_Expr); if Comes_From_Source (N) then - Check_SPARK_05_Restriction ("if expression is not allowed", N); - end if; - - if Comes_From_Source (N) then Check_Compiler_Unit ("if expression", N); end if; @@ -2411,7 +2412,10 @@ package body Sem_Ch4 is procedure Process_Function_Call; -- Prefix in indexed component form is an overloadable entity, so the - -- node is a function call. Reformat it as such. + -- node is very likely a function call; reformat it as such. The only + -- exception is a call to a parameterless function that returns an + -- array type, or an access type thereof, in which case this will be + -- undone later by Resolve_Call or Resolve_Entry_Call. procedure Process_Indexed_Component; -- Prefix in indexed component form is actually an indexed component. @@ -2522,7 +2526,7 @@ package body Sem_Ch4 is if Is_Access_Type (Array_Type) then Error_Msg_NW (Warn_On_Dereference, "?d?implicit dereference", N); - Array_Type := Process_Implicit_Dereference_Prefix (Pent, P); + Array_Type := Implicitly_Designated_Type (Array_Type); end if; if Is_Array_Type (Array_Type) then @@ -2829,18 +2833,6 @@ package body Sem_Ch4 is and then Is_Overloadable (Entity (Selector_Name (P))) then Process_Function_Call; - - -- In ASIS mode within a generic, a prefixed call is analyzed and - -- partially rewritten but the original indexed component has not - -- yet been rewritten as a call. Perform the replacement now. - - elsif Nkind (P) = N_Selected_Component - and then Nkind (Parent (P)) = N_Function_Call - and then ASIS_Mode - then - Rewrite (N, Parent (P)); - Analyze (N); - else -- Indexed component, slice, or a call to a member of a family -- entry, which will be converted to an entry call later. @@ -3047,6 +3039,8 @@ package body Sem_Ch4 is end if; end Analyze_Set_Membership; + Op : Node_Id; + -- Start of processing for Analyze_Membership_Op begin @@ -3093,17 +3087,20 @@ package body Sem_Ch4 is and then Has_Compatible_Type (R, Etype (L)) then if Nkind (N) = N_In then - Rewrite (N, - Make_Op_Eq (Loc, - Left_Opnd => L, - Right_Opnd => R)); + Op := Make_Op_Eq (Loc, Left_Opnd => L, Right_Opnd => R); else - Rewrite (N, - Make_Op_Ne (Loc, - Left_Opnd => L, - Right_Opnd => R)); + Op := Make_Op_Ne (Loc, Left_Opnd => L, Right_Opnd => R); + end if; + + if Is_Record_Or_Limited_Type (Etype (L)) then + + -- We reset the Entity in order to use the primitive equality + -- of the type, as per RM 4.5.2 (28.1/4). + + Set_Entity (Op, Empty); end if; + Rewrite (N, Op); Analyze (N); return; @@ -3202,8 +3199,6 @@ package body Sem_Ch4 is procedure Analyze_Null (N : Node_Id) is begin - Check_SPARK_05_Restriction ("null is not allowed", N); - Set_Etype (N, Any_Access); end Analyze_Null; @@ -3282,7 +3277,7 @@ package body Sem_Ch4 is -- When the type Address is a visible integer type, and the DEC -- system extension is visible, the predefined operator may be -- hidden as well, by one of the address operations in auxdec. - -- Finally, The abstract operations on address do not hide the + -- Finally, the abstract operations on address do not hide the -- predefined operator (this is the purpose of making them abstract). ----------------------------------- @@ -3294,20 +3289,30 @@ package body Sem_Ch4 is T2 : Entity_Id) return Boolean is function Common_Type (T : Entity_Id) return Entity_Id; - -- Find non-private full view if any, without going to ancestor type - -- (as opposed to Underlying_Type). + -- Find non-private underlying full view if any, without going to + -- ancestor type (as opposed to Underlying_Type). ----------------- -- Common_Type -- ----------------- function Common_Type (T : Entity_Id) return Entity_Id is + CT : Entity_Id; + begin - if Is_Private_Type (T) and then Present (Full_View (T)) then - return Base_Type (Full_View (T)); - else - return Base_Type (T); + CT := T; + + if Is_Private_Type (CT) and then Present (Full_View (CT)) then + CT := Full_View (CT); + end if; + + if Is_Private_Type (CT) + and then Present (Underlying_Full_View (CT)) + then + CT := Underlying_Full_View (CT); end if; + + return Base_Type (CT); end Common_Type; -- Start of processing for Compatible_Types_In_Predicate @@ -3770,22 +3775,23 @@ package body Sem_Ch4 is -- To avoid breaking privacy, Is_Hidden gets set elsewhere on such -- primitives, but we still need to verify that Nam is indeed a - -- controlled subprogram. So, we do that here and issue the - -- appropriate error. + -- non-visible controlled subprogram. So, we do that here and issue + -- the appropriate error. if Is_Hidden (Nam) and then not In_Instance and then not Comes_From_Source (Nam) and then Comes_From_Source (N) - -- Verify Nam is a controlled primitive + -- Verify Nam is a non-visible controlled primitive - and then Nam_In (Chars (Nam), Name_Adjust, - Name_Finalize, - Name_Initialize) + and then Chars (Nam) in Name_Adjust + | Name_Finalize + | Name_Initialize and then Ekind (Nam) = E_Procedure and then Is_Controlled (Etype (First_Form)) and then No (Next_Formal (First_Form)) + and then not Is_Visibly_Controlled (Etype (First_Form)) then Error_Msg_Node_2 := Etype (First_Form); Error_Msg_NE ("call to non-visible controlled primitive & on type" @@ -3921,15 +3927,13 @@ package body Sem_Ch4 is and then Is_Visible_Component (Comp, Sel) then - -- AI05-105: if the context is an object renaming with + -- AI05-105: if the context is an object renaming with -- an anonymous access type, the expected type of the -- object must be anonymous. This is a name resolution rule. if Nkind (Parent (N)) /= N_Object_Renaming_Declaration or else No (Access_Definition (Parent (N))) - or else Ekind (Etype (Comp)) = E_Anonymous_Access_Type - or else - Ekind (Etype (Comp)) = E_Anonymous_Access_Subprogram_Type + or else Is_Anonymous_Access_Type (Etype (Comp)) then Set_Entity (Sel, Comp); Set_Etype (Sel, Etype (Comp)); @@ -3971,18 +3975,6 @@ package body Sem_Ch4 is Set_Etype (Sel, Etype (Comp)); Set_Etype (N, Etype (Comp)); Set_Etype (Nam, It.Typ); - - -- For access type case, introduce explicit dereference for - -- more uniform treatment of entry calls. Do this only once - -- if several interpretations yield an access type. - - if Is_Access_Type (Etype (Nam)) - and then Nkind (Nam) /= N_Explicit_Dereference - then - Insert_Explicit_Dereference (Nam); - Error_Msg_NW - (Warn_On_Dereference, "?d?implicit dereference", N); - end if; end if; Next_Entity (Comp); @@ -4021,14 +4013,15 @@ package body Sem_Ch4 is Find_Type (Mark); T := Entity (Mark); - if Nkind_In (Enclosing_Declaration (N), N_Formal_Type_Declaration, - N_Full_Type_Declaration, - N_Incomplete_Type_Declaration, - N_Protected_Type_Declaration, - N_Private_Extension_Declaration, - N_Private_Type_Declaration, - N_Subtype_Declaration, - N_Task_Type_Declaration) + if Nkind (Enclosing_Declaration (N)) in + N_Formal_Type_Declaration | + N_Full_Type_Declaration | + N_Incomplete_Type_Declaration | + N_Protected_Type_Declaration | + N_Private_Extension_Declaration | + N_Private_Type_Declaration | + N_Subtype_Declaration | + N_Task_Type_Declaration and then T = Defining_Identifier (Enclosing_Declaration (N)) then Error_Msg_N ("current instance not allowed", Mark); @@ -4151,8 +4144,6 @@ package body Sem_Ch4 is -- Start of processing for Analyze_Quantified_Expression begin - Check_SPARK_05_Restriction ("quantified expression is not allowed", N); - -- Create a scope to emulate the loop-like behavior of the quantified -- expression. The scope is needed to provide proper visibility of the -- loop variable. @@ -4197,6 +4188,7 @@ package body Sem_Ch4 is -- reflect the right kind. This is needed for proper ASIS -- navigation. If expansion is enabled, the transformation is -- performed when the expression is rewritten as a loop. + -- Is this still needed??? Set_Iterator_Specification (N, New_Copy_Tree (Iterator_Specification (Parent (Loop_Par)))); @@ -4453,7 +4445,6 @@ package body Sem_Ch4 is In_Scope : Boolean; Is_Private_Op : Boolean; Parent_N : Node_Id; - Pent : Entity_Id := Empty; Prefix_Type : Entity_Id; Type_To_Use : Entity_Id; @@ -4482,7 +4473,15 @@ package body Sem_Ch4 is -- indexed component rather than a function call. function Has_Dereference (Nod : Node_Id) return Boolean; - -- Check whether prefix includes a dereference at any level. + -- Check whether prefix includes a dereference, explicit or implicit, + -- at any recursive level. + + function Try_By_Protected_Procedure_Prefixed_View return Boolean; + -- Return True if N is an access attribute whose prefix is a prefixed + -- class-wide (synchronized or protected) interface view for which some + -- interpretation is a procedure with synchronization kind By_Protected + -- _Procedure, and collect all its interpretations (since it may be an + -- overloaded interface primitive); otherwise return False. -------------------------------- -- Find_Component_In_Instance -- @@ -4594,14 +4593,10 @@ package body Sem_Ch4 is if Nkind (Nod) = N_Explicit_Dereference then return True; - -- When expansion is disabled an explicit dereference may not have - -- been inserted, but if this is an access type the indirection makes - -- the call safe. - elsif Is_Access_Type (Etype (Nod)) then return True; - elsif Nkind_In (Nod, N_Indexed_Component, N_Selected_Component) then + elsif Nkind (Nod) in N_Indexed_Component | N_Selected_Component then return Has_Dereference (Prefix (Nod)); else @@ -4609,6 +4604,65 @@ package body Sem_Ch4 is end if; end Has_Dereference; + ---------------------------------------------- + -- Try_By_Protected_Procedure_Prefixed_View -- + ---------------------------------------------- + + function Try_By_Protected_Procedure_Prefixed_View return Boolean is + Candidate : Node_Id := Empty; + Elmt : Elmt_Id; + Prim : Node_Id; + + begin + if Nkind (Parent (N)) = N_Attribute_Reference + and then Attribute_Name (Parent (N)) in + Name_Access + | Name_Unchecked_Access + | Name_Unrestricted_Access + and then Is_Class_Wide_Type (Prefix_Type) + and then (Is_Synchronized_Interface (Prefix_Type) + or else Is_Protected_Interface (Prefix_Type)) + then + -- If we have not found yet any interpretation then mark this + -- one as the first interpretation (cf. Add_One_Interp). + + if No (Etype (Sel)) then + Set_Etype (Sel, Any_Type); + end if; + + Elmt := First_Elmt (Primitive_Operations (Etype (Prefix_Type))); + while Present (Elmt) loop + Prim := Node (Elmt); + + if Chars (Prim) = Chars (Sel) + and then Is_By_Protected_Procedure (Prim) + then + Candidate := New_Copy (Prim); + + -- Skip the controlling formal; required to check type + -- conformance of the target access to protected type + -- (see Conforming_Types). + + Set_First_Entity (Candidate, + Next_Entity (First_Entity (Prim))); + + Add_One_Interp (Sel, Candidate, Etype (Prim)); + Set_Etype (N, Etype (Prim)); + end if; + + Next_Elmt (Elmt); + end loop; + end if; + + -- Propagate overloaded attribute + + if Present (Candidate) and then Is_Overloaded (Sel) then + Set_Is_Overloaded (N); + end if; + + return Present (Candidate); + end Try_By_Protected_Procedure_Prefixed_View; + -- Start of processing for Analyze_Selected_Component begin @@ -4650,16 +4704,7 @@ package body Sem_Ch4 is else Error_Msg_NW (Warn_On_Dereference, "?d?implicit dereference", N); - - if Is_Entity_Name (Name) then - Pent := Entity (Name); - elsif Nkind (Name) = N_Selected_Component - and then Is_Entity_Name (Selector_Name (Name)) - then - Pent := Entity (Selector_Name (Name)); - end if; - - Prefix_Type := Process_Implicit_Dereference_Prefix (Pent, Name); + Prefix_Type := Implicitly_Designated_Type (Prefix_Type); end if; -- If we have an explicit dereference of a remote access-to-class-wide @@ -4747,11 +4792,6 @@ package body Sem_Ch4 is Set_Etype (N, Etype (Comp)); Check_Implicit_Dereference (N, Etype (Comp)); - if Is_Access_Type (Etype (Name)) then - Insert_Explicit_Dereference (Name); - Error_Msg_NW (Warn_On_Dereference, "?d?implicit dereference", N); - end if; - elsif Is_Record_Type (Prefix_Type) then -- Find component with given name. In an instance, if the node is @@ -4833,10 +4873,10 @@ package body Sem_Ch4 is or else (Nkind (Parent_N) = N_Attribute_Reference and then - Nam_In (Attribute_Name (Parent_N), Name_First, - Name_Last, - Name_Length, - Name_Range))) + Attribute_Name (Parent_N) in Name_First + | Name_Last + | Name_Length + | Name_Range)) then Set_Etype (N, Etype (Comp)); @@ -4918,6 +4958,9 @@ package body Sem_Ch4 is return; end if; + elsif Try_By_Protected_Procedure_Prefixed_View then + return; + elsif Try_Object_Operation (N) then return; end if; @@ -5014,9 +5057,9 @@ package body Sem_Ch4 is -- a visible entity is found. if Is_Tagged_Type (Prefix_Type) - and then Nkind_In (Parent (N), N_Function_Call, - N_Indexed_Component, - N_Procedure_Call_Statement) + and then Nkind (Parent (N)) in N_Function_Call + | N_Indexed_Component + | N_Procedure_Call_Statement and then Has_Mode_Conformant_Spec (Comp) then Has_Candidate := True; @@ -5025,7 +5068,7 @@ package body Sem_Ch4 is -- Note: a selected component may not denote a component of a -- protected type (4.1.3(7)). - elsif Ekind_In (Comp, E_Discriminant, E_Entry_Family) + elsif Ekind (Comp) in E_Discriminant | E_Entry_Family or else (In_Scope and then not Is_Protected_Type (Prefix_Type) and then Is_Entity_Name (Name)) @@ -5052,15 +5095,6 @@ package body Sem_Ch4 is if Ekind (Comp) = E_Discriminant then Set_Original_Discriminant (Sel, Comp); end if; - - -- For access type case, introduce explicit dereference for - -- more uniform treatment of entry calls. - - if Is_Access_Type (Etype (Name)) then - Insert_Explicit_Dereference (Name); - Error_Msg_NW - (Warn_On_Dereference, "?d?implicit dereference", N); - end if; end if; <<Next_Comp>> @@ -5112,7 +5146,7 @@ package body Sem_Ch4 is then if Is_Task_Type (Prefix_Type) and then Present (Entity (Sel)) - and then Ekind_In (Entity (Sel), E_Entry, E_Entry_Family) + and then Is_Entry (Entity (Sel)) then null; @@ -5302,24 +5336,21 @@ package body Sem_Ch4 is end loop; -- Another special case: the type is an extension of a private - -- type T, is an actual in an instance, and we are in the body - -- of the instance, so the generic body had a full view of the - -- type declaration for T or of some ancestor that defines the - -- component in question. + -- type T, either is an actual in an instance or is immediately + -- visible, and we are in the body of the instance, which means + -- the generic body had a full view of the type declaration for + -- T or some ancestor that defines the component in question. + -- This happens because Is_Visible_Component returned False on + -- this component, as T or the ancestor is still private since + -- the Has_Private_View mechanism is bypassed because T or the + -- ancestor is not directly referenced in the generic body. elsif Is_Derived_Type (Type_To_Use) - and then Used_As_Generic_Actual (Type_To_Use) + and then (Used_As_Generic_Actual (Type_To_Use) + or else Is_Immediately_Visible (Type_To_Use)) and then In_Instance_Body then Find_Component_In_Instance (Parent_Subtype (Type_To_Use)); - - -- In ASIS mode the generic parent type may be absent. Examine - -- the parent type directly for a component that may have been - -- visible in a parent generic unit. - - elsif Is_Derived_Type (Prefix_Type) then - Par := Etype (Prefix_Type); - Find_Component_In_Instance (Par); end if; end; @@ -5517,10 +5548,6 @@ package body Sem_Ch4 is -- Start of processing for Analyze_Slice begin - if Comes_From_Source (N) then - Check_SPARK_05_Restriction ("slice is not allowed", N); - end if; - Analyze (P); Analyze (D); @@ -5532,8 +5559,8 @@ package body Sem_Ch4 is Set_Etype (N, Any_Type); if Is_Access_Type (Array_Type) then - Array_Type := Designated_Type (Array_Type); Error_Msg_NW (Warn_On_Dereference, "?d?implicit dereference", N); + Array_Type := Implicitly_Designated_Type (Array_Type); end if; if not Is_Array_Type (Array_Type) then @@ -5630,9 +5657,9 @@ package body Sem_Ch4 is end if; elsif Nkind (Expr) = N_Attribute_Reference - and then Nam_In (Attribute_Name (Expr), Name_Access, - Name_Unchecked_Access, - Name_Unrestricted_Access) + and then Attribute_Name (Expr) in Name_Access + | Name_Unchecked_Access + | Name_Unrestricted_Access then Error_Msg_N ("argument of conversion cannot be access", N); Error_Msg_N ("\use qualified expression instead", N); @@ -5721,54 +5748,47 @@ package body Sem_Ch4 is procedure Analyze_User_Defined_Binary_Op (N : Node_Id; - Op_Id : Entity_Id) - is + Op_Id : Entity_Id) is begin - -- Only do analysis if the operator Comes_From_Source, since otherwise - -- the operator was generated by the expander, and all such operators - -- always refer to the operators in package Standard. - - if Comes_From_Source (N) then - declare - F1 : constant Entity_Id := First_Formal (Op_Id); - F2 : constant Entity_Id := Next_Formal (F1); - - begin - -- Verify that Op_Id is a visible binary function. Note that since - -- we know Op_Id is overloaded, potentially use visible means use - -- visible for sure (RM 9.4(11)). + declare + F1 : constant Entity_Id := First_Formal (Op_Id); + F2 : constant Entity_Id := Next_Formal (F1); - if Ekind (Op_Id) = E_Function - and then Present (F2) - and then (Is_Immediately_Visible (Op_Id) - or else Is_Potentially_Use_Visible (Op_Id)) - and then Has_Compatible_Type (Left_Opnd (N), Etype (F1)) - and then Has_Compatible_Type (Right_Opnd (N), Etype (F2)) - then - Add_One_Interp (N, Op_Id, Etype (Op_Id)); + begin + -- Verify that Op_Id is a visible binary function. Note that since + -- we know Op_Id is overloaded, potentially use visible means use + -- visible for sure (RM 9.4(11)). + + if Ekind (Op_Id) = E_Function + and then Present (F2) + and then (Is_Immediately_Visible (Op_Id) + or else Is_Potentially_Use_Visible (Op_Id)) + and then Has_Compatible_Type (Left_Opnd (N), Etype (F1)) + and then Has_Compatible_Type (Right_Opnd (N), Etype (F2)) + then + Add_One_Interp (N, Op_Id, Etype (Op_Id)); - -- If the left operand is overloaded, indicate that the current - -- type is a viable candidate. This is redundant in most cases, - -- but for equality and comparison operators where the context - -- does not impose a type on the operands, setting the proper - -- type is necessary to avoid subsequent ambiguities during - -- resolution, when both user-defined and predefined operators - -- may be candidates. + -- If the left operand is overloaded, indicate that the current + -- type is a viable candidate. This is redundant in most cases, + -- but for equality and comparison operators where the context + -- does not impose a type on the operands, setting the proper + -- type is necessary to avoid subsequent ambiguities during + -- resolution, when both user-defined and predefined operators + -- may be candidates. - if Is_Overloaded (Left_Opnd (N)) then - Set_Etype (Left_Opnd (N), Etype (F1)); - end if; + if Is_Overloaded (Left_Opnd (N)) then + Set_Etype (Left_Opnd (N), Etype (F1)); + end if; - if Debug_Flag_E then - Write_Str ("user defined operator "); - Write_Name (Chars (Op_Id)); - Write_Str (" on node "); - Write_Int (Int (N)); - Write_Eol; - end if; + if Debug_Flag_E then + Write_Str ("user defined operator "); + Write_Name (Chars (Op_Id)); + Write_Str (" on node "); + Write_Int (Int (N)); + Write_Eol; end if; - end; - end if; + end if; + end; end Analyze_User_Defined_Binary_Op; ----------------------------------- @@ -5901,7 +5921,7 @@ package body Sem_Ch4 is -- Start of processing for Check_Arithmetic_Pair begin - if Nam_In (Op_Name, Name_Op_Add, Name_Op_Subtract) then + if Op_Name in Name_Op_Add | Name_Op_Subtract then if Is_Numeric_Type (T1) and then Is_Numeric_Type (T2) and then (Covers (T1 => T1, T2 => T2) @@ -5911,29 +5931,19 @@ package body Sem_Ch4 is Add_One_Interp (N, Op_Id, Specific_Type (T1, T2)); end if; - elsif Nam_In (Op_Name, Name_Op_Multiply, Name_Op_Divide) then + elsif Op_Name in Name_Op_Multiply | Name_Op_Divide then if Is_Fixed_Point_Type (T1) and then (Is_Fixed_Point_Type (T2) or else T2 = Universal_Real) then - -- If Treat_Fixed_As_Integer is set then the Etype is already set - -- and no further processing is required (this is the case of an - -- operator constructed by Exp_Fixd for a fixed point operation) - -- Otherwise add one interpretation with universal fixed result - -- If the operator is given in functional notation, it comes - -- from source and Fixed_As_Integer cannot apply. - - if (Nkind (N) not in N_Op - or else not Treat_Fixed_As_Integer (N)) - and then - (not Has_Fixed_Op (T1, Op_Id) - or else Nkind (Parent (N)) = N_Type_Conversion) + -- Add one interpretation with universal fixed result + + if not Has_Fixed_Op (T1, Op_Id) + or else Nkind (Parent (N)) = N_Type_Conversion then Add_One_Interp (N, Op_Id, Universal_Fixed); end if; elsif Is_Fixed_Point_Type (T2) - and then (Nkind (N) not in N_Op - or else not Treat_Fixed_As_Integer (N)) and then T1 = Universal_Real and then (not Has_Fixed_Op (T1, Op_Id) @@ -5985,10 +5995,6 @@ package body Sem_Ch4 is elsif Op_Name = Name_Op_Mod or else Op_Name = Name_Op_Rem then - -- Note: The fixed-point operands case with Treat_Fixed_As_Integer - -- set does not require any special processing, since the Etype is - -- already set (case of operation constructed by Exp_Fixed). - if Is_Integer_Type (T1) and then (Covers (T1 => T1, T2 => T2) or else @@ -6051,7 +6057,7 @@ package body Sem_Ch4 is return; end if; - Comp := First_Entity (Prefix); + Comp := First_Entity (Prefix); while Nr_Of_Suggestions <= Max_Suggestions and then Present (Comp) loop if Is_Visible_Component (Comp, Sel) then if Is_Bad_Spelling_Of (Chars (Comp), Chars (Sel)) then @@ -6065,7 +6071,7 @@ package body Sem_Ch4 is end if; end if; - Comp := Next_Entity (Comp); + Next_Entity (Comp); end loop; -- Report at most two suggestions @@ -6223,7 +6229,7 @@ package body Sem_Ch4 is else while Present (It.Nam) loop - if Ekind_In (It.Nam, E_Function, E_Operator) then + if Ekind (It.Nam) in E_Function | E_Operator then return; else Get_Next_Interp (X, It); @@ -6598,12 +6604,44 @@ package body Sem_Ch4 is Op_Id : Entity_Id; N : Node_Id) is - Index : Interp_Index; - It : Interp; - Found : Boolean := False; - I_F : Interp_Index; - T_F : Entity_Id; - Scop : Entity_Id := Empty; + Index : Interp_Index := 0; + It : Interp; + Found : Boolean := False; + Is_Universal_Access : Boolean := False; + I_F : Interp_Index; + T_F : Entity_Id; + Scop : Entity_Id := Empty; + + procedure Check_Access_Attribute (N : Node_Id); + -- For any object, '[Unchecked_]Access of such object can never be + -- passed as a parameter of a call to the Universal_Access equality + -- operator. + -- This is because the expected type for Obj'Access in a call to + -- the Standard."=" operator whose formals are of type + -- Universal_Access is Universal_Integer, and Universal_Access + -- doesn't have a designated type. For more detail see RM 6.4.1(3) + -- and 3.10.2. + -- This procedure assumes that the context is a universal_access. + + function Check_Access_Object_Types + (N : Node_Id; Typ : Entity_Id) return Boolean; + -- Check for RM 4.5.2 (9.6/2): When both are of access-to-object types, + -- the designated types shall be the same or one shall cover the other, + -- and if the designated types are elementary or array types, then the + -- designated subtypes shall statically match. + -- If N is not overloaded, then its unique type must be compatible as + -- per above. Otherwise iterate through the interpretations of N looking + -- for a compatible one. + + procedure Check_Compatible_Profiles (N : Node_Id; Typ : Entity_Id); + -- Check for RM 4.5.2(9.7/2): When both are of access-to-subprogram + -- types, the designated profiles shall be subtype conformant. + + function References_Anonymous_Access_Type + (N : Node_Id; Typ : Entity_Id) return Boolean; + -- Return True either if N is not overloaded and its Etype is an + -- anonymous access type or if one of the interpretations of N refers + -- to an anonymous access type compatible with Typ. procedure Try_One_Interp (T1 : Entity_Id); -- The context of the equality operator plays no role in resolving the @@ -6612,12 +6650,198 @@ package body Sem_Ch4 is -- and an error can be emitted now, after trying to disambiguate, i.e. -- applying preference rules. + ---------------------------- + -- Check_Access_Attribute -- + ---------------------------- + + procedure Check_Access_Attribute (N : Node_Id) is + begin + if Nkind (N) = N_Attribute_Reference + and then Attribute_Name (N) in Name_Access | Name_Unchecked_Access + then + Error_Msg_N + ("access attribute cannot be used as actual for " + & "universal_access equality", N); + end if; + end Check_Access_Attribute; + + ------------------------------- + -- Check_Access_Object_Types -- + ------------------------------- + + function Check_Access_Object_Types + (N : Node_Id; Typ : Entity_Id) return Boolean + is + function Check_Designated_Types (DT1, DT2 : Entity_Id) return Boolean; + -- Check RM 4.5.2 (9.6/2) on the given designated types. + + ---------------------------- + -- Check_Designated_Types -- + ---------------------------- + + function Check_Designated_Types + (DT1, DT2 : Entity_Id) return Boolean is + begin + -- If the designated types are elementary or array types, then + -- the designated subtypes shall statically match. + + if Is_Elementary_Type (DT1) or else Is_Array_Type (DT1) then + if Base_Type (DT1) /= Base_Type (DT2) then + return False; + else + return Subtypes_Statically_Match (DT1, DT2); + end if; + + -- Otherwise, the designated types shall be the same or one + -- shall cover the other. + + else + return DT1 = DT2 + or else Covers (DT1, DT2) + or else Covers (DT2, DT1); + end if; + end Check_Designated_Types; + + -- Start of processing for Check_Access_Object_Types + + begin + -- Return immediately with no checks if Typ is not an + -- access-to-object type. + + if not Is_Access_Object_Type (Typ) then + return True; + + -- Any_Type is compatible with all types in this context, and is used + -- in particular for the designated type of a 'null' value. + + elsif Directly_Designated_Type (Typ) = Any_Type + or else Nkind (N) = N_Null + then + return True; + end if; + + if not Is_Overloaded (N) then + if Is_Access_Object_Type (Etype (N)) then + return Check_Designated_Types + (Designated_Type (Typ), Designated_Type (Etype (N))); + end if; + else + declare + Typ_Is_Anonymous : constant Boolean := + Is_Anonymous_Access_Type (Typ); + + I : Interp_Index; + It : Interp; + + begin + Get_First_Interp (N, I, It); + while Present (It.Typ) loop + + -- The check on designated types if only relevant when one + -- of the types is anonymous, ignore other (non relevant) + -- types. + + if (Typ_Is_Anonymous + or else Is_Anonymous_Access_Type (It.Typ)) + and then Is_Access_Object_Type (It.Typ) + then + if Check_Designated_Types + (Designated_Type (Typ), Designated_Type (It.Typ)) + then + return True; + end if; + end if; + + Get_Next_Interp (I, It); + end loop; + end; + end if; + + return False; + end Check_Access_Object_Types; + + ------------------------------- + -- Check_Compatible_Profiles -- + ------------------------------- + + procedure Check_Compatible_Profiles (N : Node_Id; Typ : Entity_Id) is + I : Interp_Index; + It : Interp; + I1 : Interp_Index := 0; + Found : Boolean := False; + Tmp : Entity_Id := Empty; + + begin + if not Is_Overloaded (N) then + Check_Subtype_Conformant + (Designated_Type (Etype (N)), Designated_Type (Typ), N); + else + Get_First_Interp (N, I, It); + while Present (It.Typ) loop + if Is_Access_Subprogram_Type (It.Typ) then + if not Found then + Found := True; + Tmp := It.Typ; + I1 := I; + + else + It := Disambiguate (N, I1, I, Any_Type); + + if It /= No_Interp then + Tmp := It.Typ; + I1 := I; + else + Found := False; + exit; + end if; + end if; + end if; + + Get_Next_Interp (I, It); + end loop; + + if Found then + Check_Subtype_Conformant + (Designated_Type (Tmp), Designated_Type (Typ), N); + end if; + end if; + end Check_Compatible_Profiles; + + -------------------------------------- + -- References_Anonymous_Access_Type -- + -------------------------------------- + + function References_Anonymous_Access_Type + (N : Node_Id; Typ : Entity_Id) return Boolean + is + I : Interp_Index; + It : Interp; + begin + if not Is_Overloaded (N) then + return Is_Anonymous_Access_Type (Etype (N)); + else + Get_First_Interp (N, I, It); + while Present (It.Typ) loop + if Is_Anonymous_Access_Type (It.Typ) + and then (Covers (It.Typ, Typ) or else Covers (Typ, It.Typ)) + then + return True; + end if; + + Get_Next_Interp (I, It); + end loop; + + return False; + end if; + end References_Anonymous_Access_Type; + -------------------- -- Try_One_Interp -- -------------------- procedure Try_One_Interp (T1 : Entity_Id) is - Bas : Entity_Id; + Universal_Access : Boolean; + Bas : Entity_Id; begin -- Perform a sanity check in case of previous errors @@ -6637,6 +6861,9 @@ package body Sem_Ch4 is -- In Ada 2005, the equality operator for anonymous access types -- is declared in Standard, and preference rules apply to it. + Universal_Access := Is_Anonymous_Access_Type (T1) + or else References_Anonymous_Access_Type (R, T1); + if Present (Scop) then -- Note that we avoid returning if we are currently within a @@ -6657,48 +6884,28 @@ package body Sem_Ch4 is then null; - elsif Ekind (T1) = E_Anonymous_Access_Type - and then Scop = Standard_Standard - then - null; + elsif Scop /= Standard_Standard or else not Universal_Access then - else -- The scope does not contain an operator for the type return; end if; -- If we have infix notation, the operator must be usable. Within - -- an instance, if the type is already established we know it is - -- correct. If an operand is universal it is compatible with any - -- numeric type. + -- an instance, the type may have been immediately visible if the + -- types are compatible. elsif In_Open_Scopes (Scope (Bas)) or else Is_Potentially_Use_Visible (Bas) or else In_Use (Bas) or else (In_Use (Scope (Bas)) and then not Is_Hidden (Bas)) - - -- In an instance, the type may have been immediately visible. - -- Either the types are compatible, or one operand is universal - -- (numeric or null). - or else ((In_Instance or else In_Inlined_Body) - and then - (First_Subtype (T1) = First_Subtype (Etype (R)) - or else Nkind (R) = N_Null - or else - (Is_Numeric_Type (T1) - and then Is_Universal_Numeric_Type (Etype (R))))) - - -- In Ada 2005, the equality on anonymous access types is declared - -- in Standard, and is always visible. - - or else Ekind (T1) = E_Anonymous_Access_Type + and then Has_Compatible_Type (R, T1)) then null; - else + elsif not Universal_Access then -- Save candidate type for subsequent error message, if any if not Is_Limited_Type (T1) then @@ -6711,9 +6918,7 @@ package body Sem_Ch4 is -- Ada 2005 (AI-230): Keep restriction imposed by Ada 83 and 95: -- Do not allow anonymous access types in equality operators. - if Ada_Version < Ada_2005 - and then Ekind (T1) = E_Anonymous_Access_Type - then + if Ada_Version < Ada_2005 and then Universal_Access then return; end if; @@ -6725,15 +6930,16 @@ package body Sem_Ch4 is -- in Standard to be chosen, and the "/=" will be rewritten as a -- negation of "=" (see the end of Analyze_Equality_Op). This ensures -- that rewriting happens during analysis rather than being - -- delayed until expansion (this is needed for ASIS, which only sees - -- the unexpanded tree). Note that if the node is N_Op_Ne, but Op_Id + -- delayed until expansion (is this still needed now that ASIS mode + -- is gone???). Note that if the node is N_Op_Ne, but Op_Id -- is Name_Op_Eq then we still proceed with the interpretation, -- because that indicates the potential rewriting case where the -- interpretation to consider is actually "=" and the node may be -- about to be rewritten by Analyze_Equality_Op. + -- Finally, also check for RM 4.5.2 (9.6/2). if T1 /= Standard_Void_Type - and then Has_Compatible_Type (R, T1) + and then (Universal_Access or else Has_Compatible_Type (R, T1)) and then ((not Is_Limited_Type (T1) @@ -6748,6 +6954,9 @@ package body Sem_Ch4 is (Nkind (N) /= N_Op_Ne or else not Is_Tagged_Type (T1) or else Chars (Op_Id) = Name_Op_Eq) + + and then (not Universal_Access + or else Check_Access_Object_Types (R, T1)) then if Found and then Base_Type (T1) /= Base_Type (T_F) @@ -6761,12 +6970,14 @@ package body Sem_Ch4 is else T_F := It.Typ; + Is_Universal_Access := Universal_Access; end if; else Found := True; T_F := T1; I_F := Index; + Is_Universal_Access := Universal_Access; end if; if not Analyzed (L) then @@ -6780,11 +6991,6 @@ package body Sem_Ch4 is if Etype (N) = Any_Type then Found := False; end if; - - elsif Scop = Standard_Standard - and then Ekind (T1) = E_Anonymous_Access_Type - then - Found := True; end if; end Try_One_Interp; @@ -6819,7 +7025,6 @@ package body Sem_Ch4 is if not Is_Overloaded (L) then Try_One_Interp (Etype (L)); - else Get_First_Interp (L, Index, It); while Present (It.Typ) loop @@ -6827,6 +7032,18 @@ package body Sem_Ch4 is Get_Next_Interp (Index, It); end loop; end if; + + if Is_Universal_Access then + if Is_Access_Subprogram_Type (Etype (L)) + and then Nkind (L) /= N_Null + and then Nkind (R) /= N_Null + then + Check_Compatible_Profiles (R, Etype (L)); + end if; + + Check_Access_Attribute (R); + Check_Access_Attribute (L); + end if; end Find_Equality_Types; ------------------------- @@ -7182,7 +7399,7 @@ package body Sem_Ch4 is -- pretty much know that the other operand should be Boolean, so -- resolve it that way (generating an error). - elsif Nkind_In (N, N_Op_And, N_Op_Or, N_Op_Xor) then + elsif Nkind (N) in N_Op_And | N_Op_Or | N_Op_Xor then if Etype (L) = Standard_Boolean then Resolve (R, Standard_Boolean); return; @@ -7196,17 +7413,16 @@ package body Sem_Ch4 is -- is not the same numeric type. If it is a non-numeric type, -- then probably it is intended to match the other operand. - elsif Nkind_In (N, N_Op_Add, - N_Op_Divide, - N_Op_Ge, - N_Op_Gt, - N_Op_Le) - or else - Nkind_In (N, N_Op_Lt, - N_Op_Mod, - N_Op_Multiply, - N_Op_Rem, - N_Op_Subtract) + elsif Nkind (N) in N_Op_Add + | N_Op_Divide + | N_Op_Ge + | N_Op_Gt + | N_Op_Le + | N_Op_Lt + | N_Op_Mod + | N_Op_Multiply + | N_Op_Rem + | N_Op_Subtract then -- If Allow_Integer_Address is active, check whether the -- operation becomes legal after converting an operand. @@ -7215,10 +7431,14 @@ package body Sem_Ch4 is and then not Is_Numeric_Type (Etype (R)) then if Address_Integer_Convert_OK (Etype (R), Etype (L)) then + Rewrite (L, + Unchecked_Convert_To ( + Standard_Address, Relocate_Node (L))); Rewrite (R, - Unchecked_Convert_To (Etype (L), Relocate_Node (R))); + Unchecked_Convert_To ( + Standard_Address, Relocate_Node (R))); - if Nkind_In (N, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt) then + if Nkind (N) in N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt then Analyze_Comparison_Op (N); else Analyze_Arithmetic_Op (N); @@ -7234,9 +7454,13 @@ package body Sem_Ch4 is then if Address_Integer_Convert_OK (Etype (L), Etype (R)) then Rewrite (L, - Unchecked_Convert_To (Etype (R), Relocate_Node (L))); + Unchecked_Convert_To ( + Standard_Address, Relocate_Node (L))); + Rewrite (R, + Unchecked_Convert_To ( + Standard_Address, Relocate_Node (R))); - if Nkind_In (N, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt) then + if Nkind (N) in N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt then Analyze_Comparison_Op (N); else Analyze_Arithmetic_Op (N); @@ -7261,12 +7485,12 @@ package body Sem_Ch4 is begin Rewrite (L, Unchecked_Convert_To ( - Standard_Integer, Relocate_Node (L))); + Standard_Address, Relocate_Node (L))); Rewrite (R, Unchecked_Convert_To ( - Standard_Integer, Relocate_Node (R))); + Standard_Address, Relocate_Node (R))); - if Nkind_In (N, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt) then + if Nkind (N) in N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt then Analyze_Comparison_Op (N); else Analyze_Arithmetic_Op (N); @@ -7290,7 +7514,7 @@ package body Sem_Ch4 is elsif Null_To_Null_Address_Convert_OK (N) then Replace_Null_By_Null_Address (N); - if Nkind_In (N, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt) then + if Nkind (N) in N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt then Analyze_Comparison_Op (N); else Analyze_Arithmetic_Op (N); @@ -7302,7 +7526,7 @@ package body Sem_Ch4 is -- Comparisons on A'Access are common enough to deserve a -- special message. - elsif Nkind_In (N, N_Op_Eq, N_Op_Ne) + elsif Nkind (N) in N_Op_Eq | N_Op_Ne and then Ekind (Etype (L)) = E_Access_Attribute_Type and then Ekind (Etype (R)) = E_Access_Attribute_Type then @@ -7360,10 +7584,14 @@ package body Sem_Ch4 is return; - elsif Nkind_In (N, N_Op_Eq, N_Op_Ne) then + elsif Nkind (N) in N_Op_Eq | N_Op_Ne then if Address_Integer_Convert_OK (Etype (R), Etype (L)) then + Rewrite (L, + Unchecked_Convert_To ( + Standard_Address, Relocate_Node (L))); Rewrite (R, - Unchecked_Convert_To (Etype (L), Relocate_Node (R))); + Unchecked_Convert_To ( + Standard_Address, Relocate_Node (R))); Analyze_Equality_Op (N); return; @@ -7447,7 +7675,7 @@ package body Sem_Ch4 is -- indicate that the integer operand should be of -- type Integer. - if Nkind_In (N, N_Op_Multiply, N_Op_Divide) + if Nkind (N) in N_Op_Multiply | N_Op_Divide and then Is_Fixed_Point_Type (Etype (L)) and then Is_Integer_Type (Etype (R)) then @@ -7481,48 +7709,6 @@ package body Sem_Ch4 is end if; end Operator_Check; - ----------------------------------------- - -- Process_Implicit_Dereference_Prefix -- - ----------------------------------------- - - function Process_Implicit_Dereference_Prefix - (E : Entity_Id; - P : Entity_Id) return Entity_Id - is - Ref : Node_Id; - Typ : constant Entity_Id := Designated_Type (Etype (P)); - - begin - if Present (E) - and then (Operating_Mode = Check_Semantics or else not Expander_Active) - then - -- We create a dummy reference to E to ensure that the reference is - -- not considered as part of an assignment (an implicit dereference - -- can never assign to its prefix). The Comes_From_Source attribute - -- needs to be propagated for accurate warnings. - - Ref := New_Occurrence_Of (E, Sloc (P)); - Set_Comes_From_Source (Ref, Comes_From_Source (P)); - Generate_Reference (E, Ref); - end if; - - -- An implicit dereference is a legal occurrence of an incomplete type - -- imported through a limited_with clause, if the full view is visible. - - if From_Limited_With (Typ) - and then not From_Limited_With (Scope (Typ)) - and then - (Is_Immediately_Visible (Scope (Typ)) - or else - (Is_Child_Unit (Scope (Typ)) - and then Is_Visible_Lib_Unit (Scope (Typ)))) - then - return Available_View (Typ); - else - return Typ; - end if; - end Process_Implicit_Dereference_Prefix; - -------------------------------- -- Remove_Abstract_Operations -- -------------------------------- @@ -7563,7 +7749,7 @@ package body Sem_Ch4 is Formal := First_Entity (It.Nam); if Op = Second_Op then - Formal := Next_Entity (Formal); + Next_Entity (Formal); end if; if Is_Descendant_Of_Address (Etype (Formal)) then @@ -7791,7 +7977,7 @@ package body Sem_Ch4 is Prefix : Node_Id; Exprs : List_Id) return Boolean is - Pref_Typ : constant Entity_Id := Etype (Prefix); + Pref_Typ : Entity_Id := Etype (Prefix); function Constant_Indexing_OK return Boolean; -- Constant_Indexing is legal if there is no Variable_Indexing defined @@ -7842,8 +8028,8 @@ package body Sem_Ch4 is -- resolution does not depend on the type of the parameter that -- includes the indexing operation. - elsif Nkind_In (Parent (Par), N_Function_Call, - N_Procedure_Call_Statement) + elsif Nkind (Parent (Par)) in + N_Function_Call | N_Procedure_Call_Statement and then Is_Entity_Name (Name (Parent (Par))) then declare @@ -8227,6 +8413,25 @@ package body Sem_Ch4 is return True; end if; + -- An explicit dereference needs to be created in the case of a prefix + -- that's an access. + + -- It seems that this should be done elsewhere, but not clear where that + -- should happen. Normally Insert_Explicit_Dereference is called via + -- Resolve_Implicit_Dereference, called from Resolve_Indexed_Component, + -- but that won't be called in this case because we transform the + -- indexing to a call. Resolve_Call.Check_Prefixed_Call takes care of + -- implicit dereferencing and referencing on prefixed calls, but that + -- would be too late, even if we expanded to a prefix call, because + -- Process_Indexed_Component will flag an error before the resolution + -- happens. ??? + + if Is_Access_Type (Pref_Typ) then + Pref_Typ := Implicitly_Designated_Type (Pref_Typ); + Insert_Explicit_Dereference (Prefix); + Error_Msg_NW (Warn_On_Dereference, "?d?implicit dereference", N); + end if; + C_Type := Pref_Typ; -- If indexing a class-wide container, obtain indexing primitive from @@ -8268,7 +8473,8 @@ package body Sem_Ch4 is -- as such and retry. if Has_Implicit_Dereference (Pref_Typ) then - Build_Explicit_Dereference (Prefix, First_Discriminant (Pref_Typ)); + Build_Explicit_Dereference + (Prefix, Get_Reference_Discriminant (Pref_Typ)); return Try_Container_Indexing (N, Prefix, Exprs); -- Otherwise this is definitely not container indexing @@ -8290,8 +8496,8 @@ package body Sem_Ch4 is -- the Controlled types. The code below is motivated by containers that -- are derived from other types with a Reference aspect. -- Note as well that we need to examine the base type, given that - -- the container object may be a constrained subtype or itype which - -- does not have an explicit declaration, + -- the container object may be a constrained subtype or itype that + -- does not have an explicit declaration. elsif Is_Derived_Type (C_Type) and then Etype (First_Formal (Entity (Func_Name))) /= Pref_Typ @@ -8348,6 +8554,12 @@ package body Sem_Ch4 is if not Is_Overloaded (Func_Name) then Func := Entity (Func_Name); + -- Can happen in case of e.g. cascaded errors + + if No (Func) then + return False; + end if; + Indexing := Make_Function_Call (Loc, Name => New_Occurrence_Of (Func, Loc), @@ -8630,7 +8842,9 @@ package body Sem_Ch4 is -- Transform Obj.Operation (X, Y, ...) into Operation (Obj, X, Y ...). -- Call_Node is the resulting subprogram call, Node_To_Replace is -- either N or the parent of N, and Subprog is a reference to the - -- subprogram we are trying to match. + -- subprogram we are trying to match. Note that the transformation + -- may be partially destructive for the parent of N, so it needs to + -- be undone in the case where Try_Object_Operation returns false. function Try_Class_Wide_Operation (Call_Node : Node_Id; @@ -8888,14 +9102,6 @@ package body Sem_Ch4 is Actuals : List_Id; begin - -- Obj may already have been rewritten if it involves an implicit - -- dereference (e.g. if it is an access to a limited view). Preserve - -- a link to the original node for ASIS use. - - if not Comes_From_Source (Obj) then - Set_Original_Node (Dummy, Original_Node (Obj)); - end if; - -- Common case covering 1) Call to a procedure and 2) Call to a -- function that has some additional actuals. @@ -8909,7 +9115,7 @@ package body Sem_Ch4 is -- example: -- Some_Subprogram (..., Obj.Operation, ...) - and then Name (Parent_Node) = N + and then N = Name (Parent_Node) then Node_To_Replace := Parent_Node; @@ -9058,7 +9264,7 @@ package body Sem_Ch4 is Hom := Current_Entity (Subprog); while Present (Hom) loop - if Ekind_In (Hom, E_Procedure, E_Function) + if Ekind (Hom) in E_Procedure | E_Function and then Present (Renamed_Entity (Hom)) and then Is_Generic_Actual_Subprogram (Hom) and then In_Open_Scopes (Scope (Hom)) @@ -9068,7 +9274,7 @@ package body Sem_Ch4 is Candidate := Hom; end if; - if Ekind_In (Candidate, E_Function, E_Procedure) + if Ekind (Candidate) in E_Function | E_Procedure and then (not Is_Hidden (Candidate) or else In_Instance) and then Scope (Candidate) = Scope (Base_Type (Anc_Type)) and then First_Formal_Match (Candidate, CW_Typ) @@ -9246,8 +9452,8 @@ package body Sem_Ch4 is Obj_Type := Designated_Type (Obj_Type); end if; - if Ekind_In (Obj_Type, E_Private_Subtype, - E_Record_Subtype_With_Private) + if Ekind (Obj_Type) + in E_Private_Subtype | E_Record_Subtype_With_Private then Obj_Type := Base_Type (Obj_Type); end if; @@ -9417,7 +9623,7 @@ package body Sem_Ch4 is if Is_Derived_Type (T) then return Primitive_Operations (T); - elsif Ekind_In (Scope (T), E_Procedure, E_Function) then + elsif Ekind (Scope (T)) in E_Procedure | E_Function then -- Scan the list of generic formals to find subprograms -- that may have a first controlling formal of the type. @@ -9480,7 +9686,7 @@ package body Sem_Ch4 is Type_Scope : constant Entity_Id := Scope (T); Op_List : Elist_Id := Primitive_Operations (T); begin - if Ekind_In (Type_Scope, E_Package, E_Generic_Package) + if Is_Package_Or_Generic_Package (Type_Scope) and then ((In_Package_Body (Type_Scope) and then In_Open_Scopes (Type_Scope)) or else In_Instance_Body) then @@ -9947,8 +10153,20 @@ package body Sem_Ch4 is return True; else - -- There was no candidate operation, so report it as an error - -- in the caller: Analyze_Selected_Component. + -- There was no candidate operation, but Analyze_Selected_Component + -- may continue the analysis so we need to undo the change possibly + -- made to the Parent of N earlier by Transform_Object_Operation. + + declare + Parent_Node : constant Node_Id := Parent (N); + + begin + if Node_To_Replace = Parent_Node then + Remove (First (Parameter_Associations (New_Call_Node))); + Set_Parent + (Parameter_Associations (New_Call_Node), Parent_Node); + end if; + end; return False; end if; |