diff options
Diffstat (limited to 'gcc/ada/sem_ch5.adb')
| -rw-r--r-- | gcc/ada/sem_ch5.adb | 172 |
1 files changed, 97 insertions, 75 deletions
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index b06bff7..8c92669 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -141,72 +141,6 @@ package body Sem_Ch5 is -- assignment statements that are really initializations. These are -- marked No_Ctrl_Actions. - function Should_Transform_BIP_Assignment - (Typ : Entity_Id) return Boolean - is - Result : Boolean; - begin - if Expander_Active - and then not Is_Limited_View (Typ) - and then Is_Build_In_Place_Result_Type (Typ) - and then not No_Ctrl_Actions (N) - then - -- This function is called early, before name resolution is - -- complete, so we have to deal with things that might turn into - -- function calls later. N_Function_Call and N_Op nodes are the - -- obvious case. An N_Identifier or N_Expanded_Name is a - -- parameterless function call if it denotes a function. - -- Finally, an attribute reference can be a function call. - - case Nkind (Unqual_Conv (Rhs)) is - when N_Function_Call | N_Op => - Result := True; - when N_Identifier | N_Expanded_Name => - case Ekind (Entity (Unqual_Conv (Rhs))) is - when E_Function | E_Operator => - Result := True; - when others => - Result := False; - end case; - when N_Attribute_Reference => - Result := Attribute_Name (Unqual_Conv (Rhs)) = Name_Input; - -- T'Input will turn into a call whose result type is T - when others => - Result := False; - end case; - else - Result := False; - end if; - return Result; - end Should_Transform_BIP_Assignment; - - procedure Transform_BIP_Assignment (Typ : Entity_Id) is - -- Tranform "X : [constant] T := F (...);" into: - -- - -- Temp : constant T := F (...); - -- X := Temp; - - Loc : constant Source_Ptr := Sloc (N); - Def_Id : constant Entity_Id := Make_Temporary (Loc, 'Y', Rhs); - Obj_Decl : constant Node_Id := - Make_Object_Declaration - (Loc, - Defining_Identifier => Def_Id, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (Typ, Loc), - Expression => Rhs, - Has_Init_Expression => True); - begin - Set_Etype (Def_Id, Typ); - Set_Expression (N, New_Occurrence_Of (Def_Id, Loc)); - - -- At this point, Rhs is no longer equal to Expression (N), so: - - Rhs := Expression (N); - - Insert_Action (N, Obj_Decl); - end Transform_BIP_Assignment; - ------------------------------- -- Diagnose_Non_Variable_Lhs -- ------------------------------- @@ -314,6 +248,7 @@ package body Sem_Ch5 is Opnd_Type : in out Entity_Id) is Decl : Node_Id; + begin Require_Entity (Opnd); @@ -331,9 +266,9 @@ package body Sem_Ch5 is or else (Ekind (Entity (Opnd)) = E_Variable and then Nkind (Parent (Entity (Opnd))) = - N_Object_Renaming_Declaration + N_Object_Renaming_Declaration and then Nkind (Parent (Parent (Entity (Opnd)))) = - N_Accept_Statement)) + N_Accept_Statement)) then Opnd_Type := Get_Actual_Subtype (Opnd); @@ -364,6 +299,93 @@ package body Sem_Ch5 is end if; end Set_Assignment_Type; + ------------------------------------- + -- Should_Transform_BIP_Assignment -- + ------------------------------------- + + function Should_Transform_BIP_Assignment + (Typ : Entity_Id) return Boolean + is + Result : Boolean; + + begin + if Expander_Active + and then not Is_Limited_View (Typ) + and then Is_Build_In_Place_Result_Type (Typ) + and then not No_Ctrl_Actions (N) + then + -- This function is called early, before name resolution is + -- complete, so we have to deal with things that might turn into + -- function calls later. N_Function_Call and N_Op nodes are the + -- obvious case. An N_Identifier or N_Expanded_Name is a + -- parameterless function call if it denotes a function. + -- Finally, an attribute reference can be a function call. + + case Nkind (Unqual_Conv (Rhs)) is + when N_Function_Call + | N_Op + => + Result := True; + + when N_Expanded_Name + | N_Identifier + => + case Ekind (Entity (Unqual_Conv (Rhs))) is + when E_Function + | E_Operator + => + Result := True; + + when others => + Result := False; + end case; + + when N_Attribute_Reference => + Result := Attribute_Name (Unqual_Conv (Rhs)) = Name_Input; + -- T'Input will turn into a call whose result type is T + + when others => + Result := False; + end case; + else + Result := False; + end if; + + return Result; + end Should_Transform_BIP_Assignment; + + ------------------------------ + -- Transform_BIP_Assignment -- + ------------------------------ + + procedure Transform_BIP_Assignment (Typ : Entity_Id) is + + -- Tranform "X : [constant] T := F (...);" into: + -- + -- Temp : constant T := F (...); + -- X := Temp; + + Loc : constant Source_Ptr := Sloc (N); + Def_Id : constant Entity_Id := Make_Temporary (Loc, 'Y', Rhs); + Obj_Decl : constant Node_Id := + Make_Object_Declaration (Loc, + Defining_Identifier => Def_Id, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Typ, Loc), + Expression => Rhs, + Has_Init_Expression => True); + + begin + Set_Etype (Def_Id, Typ); + Set_Expression (N, New_Occurrence_Of (Def_Id, Loc)); + + -- At this point, Rhs is no longer equal to Expression (N), so: + + Rhs := Expression (N); + + Insert_Action (N, Obj_Decl); + end Transform_BIP_Assignment; + -- Local variables T1 : Entity_Id; @@ -524,13 +546,14 @@ package body Sem_Ch5 is end if; end if; - -- Deal with build-in-place calls for nonlimited types. - -- We don't do this later, because resolving the rhs - -- tranforms it incorrectly for build-in-place. + -- Deal with build-in-place calls for nonlimited types. We don't do this + -- later, because resolving the rhs tranforms it incorrectly for build- + -- in-place. if Should_Transform_BIP_Assignment (Typ => T1) then Transform_BIP_Assignment (Typ => T1); end if; + pragma Assert (not Should_Transform_BIP_Assignment (Typ => T1)); -- The resulting assignment type is T1, so now we will resolve the left @@ -538,8 +561,6 @@ package body Sem_Ch5 is Resolve (Lhs, T1); - -- Cases where Lhs is not a variable - -- Cases where Lhs is not a variable. In an instance or an inlined body -- no need for further check because assignment was legal in template. @@ -1941,8 +1962,9 @@ package body Sem_Ch5 is if Is_Array_Type (Typ) or else Is_Reversible_Iterator (Typ) or else - (Present (Find_Aspect (Typ, Aspect_Iterable)) - and then Present + (Present (Find_Aspect (Typ, Aspect_Iterable)) + and then + Present (Get_Iterable_Type_Primitive (Typ, Name_Previous))) then null; |