diff options
author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2005-09-05 08:03:17 +0000 |
---|---|---|
committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2005-09-05 08:03:17 +0000 |
commit | a7aeea04fa7ff54c52c6d697e1128cce300eee18 (patch) | |
tree | 4663bbbd134b9b4ba2e686e242037c12cbd32abe /gcc/ada/sem_res.adb | |
parent | 7c7c3694d58d8a54028292b68e62363ff4f2aded (diff) | |
download | gcc-a7aeea04fa7ff54c52c6d697e1128cce300eee18.tar.gz |
2005-09-01 Javier Miranda <miranda@adacore.com>
Ed Schonberg <schonberg@adacore.com>
Gary Dismukes <dismukes@adacore.com>
* sem_res.adb (Resolve_Membership_Op): In case of the membership test
"Iface_CW_Typ in T'Class" we have nothing else to do in the frontend;
the expander will generate the corresponding run-time check to evaluate
the expression.
(Resolve_Call): Check for legal type of procedure name or prefix that
appears as a trigger in a triggering alternative.
(Valid_Conversion): If expression is ambiguous and the context involves
an extension of System, remove System.Address interpretations.
(Resolve_Qualified_Expression): Reject the case of a specific-type
qualification applied to a class-wide argument. Enhance comment
to explain checking of Original_Node.
(Resolve_Type_Conversion): The location of the error message was not
general enough to handle the general case and hence it has been removed.
In addition, this patch improves the text of the message.
(Resolve_Type_Conversion): Add missing support for access to interface
types.
(Resolve_Type_Conversion): If the target is a class-wide interface type,
do not expand if the expression is the actual in a call, because proper
expansion will take place when the call itself is expanded.
(Resolve_Allocator): If the context is an unchecked conversion, the
allocator inherits its storage pool, if any, from the target type of
the conversion.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@103886 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada/sem_res.adb')
-rw-r--r-- | gcc/ada/sem_res.adb | 198 |
1 files changed, 115 insertions, 83 deletions
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 285ab115a08..e1e9b7b4ec3 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -244,14 +244,10 @@ package body Sem_Res is ("\possible interpretations: Character, Wide_Character!", C); E := Current_Entity (C); - - if Present (E) then - - while Present (E) loop - Error_Msg_NE ("\possible interpretation:}!", C, Etype (E)); - E := Homonym (E); - end loop; - end if; + while Present (E) loop + Error_Msg_NE ("\possible interpretation:}!", C, Etype (E)); + E := Homonym (E); + end loop; end if; end Ambiguous_Character; @@ -557,7 +553,6 @@ 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 @@ -742,9 +737,7 @@ package body Sem_Res is elsif Is_Record_Type (T) then Comp := First_Component (T); - while Present (Comp) loop - if Ekind (Comp) = E_Component and then Nkind (Parent (Comp)) = N_Component_Declaration then @@ -996,9 +989,7 @@ package body Sem_Res is else Get_First_Interp (Nod, I, It); - while Present (It.Typ) loop - if Scope (Base_Type (It.Typ)) = S then return True; end if; @@ -1066,9 +1057,7 @@ package body Sem_Res is else E := First_Entity (Pack); - while Present (E) loop - if Test (E) and then not In_Decl then @@ -1672,10 +1661,9 @@ package body Sem_Res is -- is compatible with the context (i.e. the type passed to Resolve) else - Get_First_Interp (N, I, It); - -- Loop through possible interpretations + Get_First_Interp (N, I, It); Interp_Loop : while Present (It.Typ) loop -- We are only interested in interpretations that are compatible @@ -1726,10 +1714,11 @@ package body Sem_Res is or else Nkind (N) = N_Procedure_Call_Statement then declare - A : Node_Id := First_Actual (N); + A : Node_Id; E : Node_Id; begin + A := First_Actual (N); while Present (A) loop E := A; @@ -2076,10 +2065,9 @@ package body Sem_Res is begin Error_Msg_N ("\possible interpretations:", N); - Get_First_Interp (Name (N), Index, It); + Get_First_Interp (Name (N), Index, It); while Present (It.Nam) loop - Error_Msg_Sloc := Sloc (It.Nam); Error_Msg_Node_2 := It.Typ; Error_Msg_NE ("\& declared#, type&", @@ -2769,16 +2757,14 @@ package body Sem_Res is if Ada_Version >= Ada_05 and then Is_Access_Type (F_Typ) - and then (Can_Never_Be_Null (F) - or else Can_Never_Be_Null (F_Typ)) + and then Can_Never_Be_Null (F_Typ) + and then Nkind (A) = N_Null then - if Nkind (A) = N_Null then - Apply_Compile_Time_Constraint_Error - (N => A, - Msg => "(Ada 2005) NULL not allowed in " - & "null-excluding formal?", - Reason => CE_Null_Not_Allowed); - end if; + Apply_Compile_Time_Constraint_Error + (N => A, + Msg => "(Ada 2005) NULL not allowed in " + & "null-excluding formal?", + Reason => CE_Null_Not_Allowed); end if; end if; @@ -3013,7 +2999,6 @@ package body Sem_Res is if Has_Discriminants (Subtyp) then Discrim := First_Discriminant (Base_Type (Subtyp)); Constr := First (Constraints (Constraint (Original_Node (E)))); - while Present (Discrim) and then Present (Constr) loop if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then if Nkind (Constr) = N_Discriminant_Association then @@ -3104,7 +3089,6 @@ package body Sem_Res is if No_Pool_Assigned (Typ) then declare Loc : constant Source_Ptr := Sloc (N); - begin Error_Msg_N ("?allocation from empty storage pool!", N); Error_Msg_N ("?Storage_Error will be raised at run time!", N); @@ -3112,6 +3096,17 @@ package body Sem_Res is Make_Raise_Storage_Error (Loc, Reason => SE_Empty_Storage_Pool)); end; + + -- If the context is an unchecked conversion, as may happen within + -- an inlined subprogram, the allocator is being resolved with its + -- own anonymous type. In that case, if the target type has a specific + -- storage pool, it must be inherited explicitly by the allocator type. + + elsif Nkind (Parent (N)) = N_Unchecked_Type_Conversion + and then No (Associated_Storage_Pool (Typ)) + then + Set_Associated_Storage_Pool + (Typ, Associated_Storage_Pool (Etype (Parent (N)))); end if; end Resolve_Allocator; @@ -3161,9 +3156,7 @@ package body Sem_Res is or else T = Universal_Real; else Get_First_Interp (N, Index, It); - while Present (It.Typ) loop - if Base_Type (It.Typ) = Base_Type (Standard_Integer) or else It.Typ = Universal_Integer or else It.Typ = Universal_Real @@ -3251,7 +3244,6 @@ package body Sem_Res is -- interpretation or an integer interpretation, but not both. Get_First_Interp (N, Index, It); - while Present (It.Typ) loop if Base_Type (It.Typ) = Base_Type (Standard_Integer) then @@ -3548,9 +3540,9 @@ package body Sem_Res is -- return type that is compatible with the context. Analysis of -- the node has established that one exists. - Get_First_Interp (Subp, I, It); Nam := Empty; + Get_First_Interp (Subp, I, It); while Present (It.Typ) loop if Covers (Typ, Etype (It.Typ)) then Nam := It.Typ; @@ -3609,10 +3601,9 @@ package body Sem_Res is else pragma Assert (Is_Overloaded (Subp)); - Nam := Empty; -- We know that it will be assigned in loop below. + Nam := Empty; -- We know that it will be assigned in loop below Get_First_Interp (Subp, I, It); - while Present (It.Typ) loop if Covers (Typ, It.Typ) then Nam := It.Nam; @@ -3714,7 +3705,23 @@ package body Sem_Res is and then Nkind (N) /= N_Entry_Call_Statement and then Entry_Call_Statement (Parent (N)) = N then - Error_Msg_N ("entry call required in select statement", N); + if Ada_Version < Ada_05 then + Error_Msg_N ("entry call required in select statement", N); + + -- Ada 2005 (AI-345): If a procedure_call_statement is used + -- for a procedure_or_entry_call, the procedure_name or pro- + -- cedure_prefix of the procedure_call_statement shall denote + -- an entry renamed by a procedure, or (a view of) a primitive + -- subprogram of a limited interface whose first parameter is + -- a controlling parameter. + + elsif Nkind (N) = N_Procedure_Call_Statement + and then not Is_Renamed_Entry (Nam) + and then not Is_Controlling_Limited_Procedure (Nam) + then + Error_Msg_N + ("procedure or entry call required in select statement", N); + end if; end if; -- Check that this is not a call to a protected procedure or @@ -4050,7 +4057,6 @@ package body Sem_Res is else C := Current_Entity (N); - while Present (C) loop if Etype (C) = B_Typ then Set_Entity_With_Style_Check (N, C); @@ -4092,6 +4098,7 @@ package body Sem_Res is if Scope (Entity (N)) /= Standard_Standard then T := Etype (First_Entity (Entity (N))); + else T := Find_Unique_Type (L, R); @@ -4475,7 +4482,6 @@ package body Sem_Res is -- the type in the same declarative part. Tsk := Next_Entity (S); - while Etype (Tsk) /= S loop Next_Entity (Tsk); end loop; @@ -4515,9 +4521,7 @@ package body Sem_Res is begin Get_First_Interp (Pref, I, It); - while Present (It.Typ) loop - if Scope (Ent) = It.Typ then Set_Etype (Pref, It.Typ); exit; @@ -4586,9 +4590,7 @@ package body Sem_Res is begin Get_First_Interp (Selector_Name (Entry_Name), I, It); - while Present (It.Typ) loop - if Covers (Typ, It.Typ) then Set_Entity (Selector_Name (Entry_Name), It.Nam); Set_Etype (Entry_Name, It.Typ); @@ -4740,7 +4742,7 @@ package body Sem_Res is Set_Analyzed (N, True); -- Protected functions can return on the secondary stack, in which - -- case we must trigger the transient scope mechanism + -- case we must trigger the transient scope mechanism. elsif Expander_Active and then Requires_Transient_Scope (Etype (Nam)) @@ -4780,7 +4782,7 @@ package body Sem_Res is function Find_Unique_Access_Type return Entity_Id is Acc : Entity_Id; E : Entity_Id; - S : Entity_Id := Current_Scope; + S : Entity_Id; begin if Ekind (Etype (R)) = E_Allocator_Type then @@ -4793,11 +4795,10 @@ package body Sem_Res is return Empty; end if; + S := Current_Scope; while S /= Standard_Standard loop E := First_Entity (S); - while Present (E) loop - if Is_Type (E) and then Is_Access_Type (E) and then Ekind (E) /= E_Allocator_Type @@ -4826,12 +4827,10 @@ package body Sem_Res is end if; if T /= Any_Type then - if T = Any_String or else T = Any_Composite or else T = Any_Character then - if T = Any_Character then Ambiguous_Character (L); else @@ -4936,7 +4935,6 @@ package body Sem_Res is and then Is_Tagged_Type (Directly_Designated_Type (Etype (Prefix (N)))) then null; - else Check_Fully_Declared (Typ, N); end if; @@ -4950,7 +4948,6 @@ package body Sem_Res is while Present (It.Typ) loop exit when Is_Access_Type (It.Typ) and then Covers (Typ, Designated_Type (It.Typ)); - Get_Next_Interp (I, It); end loop; @@ -5044,12 +5041,7 @@ package body Sem_Res is begin Get_First_Interp (P, I, It); - - -- the task has access discriminants, the designated type may be - -- incomplete at the point the expression is resolved. This resolution - -- takes place within the body of the initialization proc while Present (It.Typ) loop - if (Is_Array_Type (It.Typ) and then Covers (Typ, Component_Type (It.Typ))) or else (Is_Access_Type (It.Typ) @@ -5153,7 +5145,6 @@ package body Sem_Res is begin Op := Entity (N); - while Scope (Op) /= Standard_Standard loop Op := Homonym (Op); pragma Assert (Present (Op)); @@ -5231,7 +5222,6 @@ package body Sem_Res is begin Op := Entity (N); - while Scope (Op) /= Standard_Standard loop Op := Homonym (Op); pragma Assert (Present (Op)); @@ -5334,6 +5324,28 @@ package body Sem_Res is and then Is_Overloaded (L) then T := Etype (R); + + -- Ada 2005 (AI-251): Give support to the following case: + + -- type I is interface; + -- type T is tagged ... + + -- function Test (O : in I'Class) is + -- begin + -- return O in T'Class. + -- end Test; + + -- In this case we have nothing else to do; the membership test will be + -- done at run-time. + + elsif Ada_Version >= Ada_05 + and then Is_Class_Wide_Type (Etype (L)) + and then Is_Interface (Etype (L)) + and then Is_Class_Wide_Type (Etype (R)) + and then not Is_Interface (Etype (R)) + then + return; + else T := Intersect_Types (L, R); end if; @@ -5465,9 +5477,7 @@ package body Sem_Res is begin Get_First_Interp (Arg, I, It); - while Present (It.Nam) loop - if Base_Type (Etype (It.Nam)) = Base_Type (Typ) or else Base_Type (Etype (It.Nam)) = Base_Type (Component_Type (Typ)) @@ -5725,9 +5735,16 @@ package body Sem_Res is Resolve (Expr, Target_Typ); -- A qualified expression requires an exact match of the type, - -- class-wide matching is not allowed. - - if Is_Class_Wide_Type (Target_Typ) + -- class-wide matching is not allowed. However, if the qualifying + -- type is specific and the expression has a class-wide type, it + -- may still be okay, since it can be the result of the expansion + -- of a call to a dispatching function, so we also have to check + -- class-wideness of the type of the expression's original node. + + if (Is_Class_Wide_Type (Target_Typ) + or else + (Is_Class_Wide_Type (Etype (Expr)) + and then Is_Class_Wide_Type (Etype (Original_Node (Expr))))) and then Base_Type (Etype (Expr)) /= Base_Type (Target_Typ) then Wrong_Type (Expr, Target_Typ); @@ -5944,9 +5961,7 @@ package body Sem_Res is if Is_Record_Type (T) then Comp := First_Entity (T); - while Present (Comp) loop - if Chars (Comp) = Chars (S) and then Covers (Etype (Comp), Typ) then @@ -5974,7 +5989,6 @@ package body Sem_Res is -- Find the component with the right name. Comp1 := First_Entity (It1.Typ); - while Present (Comp1) and then Chars (Comp1) /= Chars (S) loop @@ -6118,9 +6132,7 @@ package body Sem_Res is begin Get_First_Interp (P, I, It); - while Present (It.Typ) loop - if (Is_Array_Type (It.Typ) and then Covers (Typ, It.Typ)) or else (Is_Access_Type (It.Typ) @@ -6630,6 +6642,10 @@ package body Sem_Res is end if; if Is_Interface (Target_Type) then + if Is_Access_Type (Opnd_Type) then + Opnd_Type := Directly_Designated_Type (Opnd_Type); + end if; + if Is_Class_Wide_Type (Opnd_Type) then Opnd_Type := Etype (Opnd_Type); end if; @@ -6638,19 +6654,25 @@ package body Sem_Res is (Typ => Opnd_Type, Iface => Target_Type) then - if Nkind (Operand) = N_Attribute_Reference then - Error_Msg_Name_1 := Chars (Prefix (Operand)); - else - Error_Msg_Name_1 := Chars (Operand); - end if; - - Error_Msg_Name_2 := Chars (Target_Type); Error_Msg_NE - ("(Ada 2005) % does not implement interface %", + ("(Ada 2005) does not implement interface }", Operand, Target_Type); else - Expand_Interface_Conversion (N); + -- If a conversion to an interface type appears as an actual in + -- a source call, it will be expanded when the enclosing call + -- itself is examined in Expand_Interface_Formals. Otherwise, + -- generate the proper conversion code now, using the tag of + -- the interface. + + if (Nkind (Parent (N)) = N_Procedure_Call_Statement + or else Nkind (Parent (N)) = N_Function_Call) + and then Comes_From_Source (N) + then + null; + else + Expand_Interface_Conversion (N); + end if; end if; end if; end if; @@ -7000,7 +7022,6 @@ package body Sem_Res is Scop := Current_Scope; while Scop /= Standard_Standard loop T2 := First_Entity (Scop); - while Present (T2) loop if Is_Fixed_Point_Type (T2) and then Current_Entity (T2) = T2 @@ -7027,7 +7048,6 @@ package body Sem_Res is if Nkind (Item) = N_With_Clause then Scop := Entity (Name (Item)); T2 := First_Entity (Scop); - while Present (T2) loop if Is_Fixed_Point_Type (T2) and then Scope (Base_Type (T2)) = Scop @@ -7160,14 +7180,26 @@ package body Sem_Res is -- in this context, but which cannot be removed by type checking, -- because the context does not impose a type. + -- When compiling for VMS, spurious ambiguities can be produced + -- when arithmetic operations have a literal operand and return + -- System.Address or a descendant of it. These ambiguities are + -- otherwise resolved by the context, but for conversions there + -- is no context type and the removal of the spurious operations + -- must be done explicitly here. + Get_First_Interp (Operand, I, It); while Present (It.Typ) loop - if It.Typ = Standard_Void_Type then Remove_Interp (I); end if; + if Present (System_Aux_Id) + and then Is_Descendent_Of_Address (It.Typ) + then + Remove_Interp (I); + end if; + Get_Next_Interp (I, It); end loop; @@ -7557,10 +7589,10 @@ package body Sem_Res is O_Gen : constant Node_Id := Enclosing_Generic_Body (Opnd_Type); - T_Gen : Node_Id := - Enclosing_Generic_Body (Target_Type); + T_Gen : Node_Id; begin + T_Gen := Enclosing_Generic_Body (Target_Type); while Present (T_Gen) and then T_Gen /= O_Gen loop T_Gen := Enclosing_Generic_Body (T_Gen); end loop; |