From: Gary Dismukes Date: Tue, 8 Apr 2008 06:49:47 +0000 (+0200) Subject: sem_cat.adb (Validate_RCI_Subprogram_Declaration): Add tests of Has_Stream_Attribute_... X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=b459216877b3af65054492a9827769e50c687a49;p=gcc.git sem_cat.adb (Validate_RCI_Subprogram_Declaration): Add tests of Has_Stream_Attribute_ Definition when... 2008-04-08 Gary Dismukes Ed Schonberg Robert Dewar * sem_cat.adb (Validate_RCI_Subprogram_Declaration): Add tests of Has_Stream_Attribute_ Definition when checking for available stream attributes on parameters of a limited type in Ada 2005. Necessary for proper recognition of visible stream attribute clauses. (Has_Stream_Attribute_Definition): If the type is derived from a private type, then use the derived type's underlying type for checking whether it has stream attributes. (Validate_Object_Declaration): The check for a user-defined Initialize procedure applies also to types with controlled components or a controlled ancestor. Reject an object declaration in a preelaborated unit if the type is a controlled type with an overriding Initialize procedure. (Validate_Remote_Access_To_Class_Wide_Type): Return without further checking when the parent of a dereference is a selected component and the name has not been analyzed. * sem_ch4.adb (Analyze_Selected_Component): Add checking for selected prefixes that are invalid explicit dereferences of remote access-to-class-wide values, first checking whether the selected component is a prefixed form of call to a tagged operation. (Analyze_Call): Remove code that issues an error for limited function calls in illegal contexts, as we now support all of the contexts that were forbidden here. Allow a function call that returns a task.and appears as the prefix of a selected component. (Analyze_Reference): Give error message if we try to make a 'Reference for an object that is atomic/aliased without its type having the corresponding attribute. (Analyze_Call): Remove condition checking for attributes to allow calls to functions with inherently limited results as prefixes of attributes. Remove related comment about Class attributes. (Analyze_Selected_Component): If the prefix is a remote type, check whether this is a prefixed call before reporting an error. (Complete_Object_Operation): If the controlling formal is an access to variable reject an actual that is a constant or an access to one. (Try_Object_Operation): If prefix is a tagged protected object,retrieve primitive operations from base type. * exp_ch4.adb (Expand_N_Indexed_Component): Test for prefix that is a build-in-place function call and call Make_Build_In_Place_Call_In_Anonymous_Context. (Expand_N_Selected_Component): Test for prefix that is a build-in-place function call and call Make_Build_In_Place_Call_In_Anonymous_Context. (Expand_N_Slice): Test for prefix that is a build-in-place function call and call Make_Build_In_Place_Call_In_Anonymous_Context. (Analyze_Call): Remove code that issues an error for limited function calls in illegal contexts, as we now support all of the contexts that were forbidden here. New calling sequence for Get_Simple_Init_Val (Expand_Boolean_Operator): Add call to Silly_Boolean_Array_Xor_Test (Expand_N_Op_Not): Add call to Silly_Boolan_Array_Not_Test From-SVN: r134026 --- diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 0473fc0fb68..ee440f14424 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -1852,6 +1852,10 @@ package body Exp_Ch4 is Ensure_Defined (Etype (R), N); Apply_Length_Check (R, Etype (L)); + if Nkind (N) = N_Op_Xor then + Silly_Boolean_Array_Xor_Test (N, Etype (L)); + end if; + if Nkind (Parent (N)) = N_Assignment_Statement and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R) then @@ -1860,7 +1864,7 @@ package body Exp_Ch4 is elsif Nkind (Parent (N)) = N_Op_Not and then Nkind (N) = N_Op_And and then - Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R) + Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R) then return; else @@ -2812,7 +2816,7 @@ package body Exp_Ch4 is function Needs_Initialization_Call (N : Node_Id) return Boolean; -- Determine whether node N is a subtype indicator allocator which - -- asts a coextension. Such coextensions need initialization. + -- acts a coextension. Such coextensions need initialization. ------------------------------- -- Inside_A_Return_Statement -- @@ -2943,27 +2947,34 @@ package body Exp_Ch4 is Ref := New_Copy_Tree (Coext); end if; - -- Generate: - -- initialize (Ref) - -- attach_to_final_list (Ref, Flist, 2) + -- No initialization call if not allowed - if Needs_Initialization_Call (Coext) then - Insert_Actions (N, - Make_Init_Call ( - Ref => Ref, - Typ => Etype (Coext), - Flist_Ref => Flist, - With_Attach => Make_Integer_Literal (Loc, Uint_2))); + Check_Restriction (No_Default_Initialization, N); - -- Generate: - -- attach_to_final_list (Ref, Flist, 2) + if not Restriction_Active (No_Default_Initialization) then - else - Insert_Action (N, - Make_Attach_Call ( - Obj_Ref => Ref, - Flist_Ref => New_Copy_Tree (Flist), - With_Attach => Make_Integer_Literal (Loc, Uint_2))); + -- Generate: + -- initialize (Ref) + -- attach_to_final_list (Ref, Flist, 2) + + if Needs_Initialization_Call (Coext) then + Insert_Actions (N, + Make_Init_Call ( + Ref => Ref, + Typ => Etype (Coext), + Flist_Ref => Flist, + With_Attach => Make_Integer_Literal (Loc, Uint_2))); + + -- Generate: + -- attach_to_final_list (Ref, Flist, 2) + + else + Insert_Action (N, + Make_Attach_Call ( + Obj_Ref => Ref, + Flist_Ref => New_Copy_Tree (Flist), + With_Attach => Make_Integer_Literal (Loc, Uint_2))); + end if; end if; Next_Elmt (Coext_Elmt); @@ -3174,10 +3185,11 @@ package body Exp_Ch4 is -- Case of simple initialization required if Needs_Simple_Initialization (T) then + Check_Restriction (No_Default_Initialization, N); Rewrite (Expression (N), Make_Qualified_Expression (Loc, Subtype_Mark => New_Occurrence_Of (T, Loc), - Expression => Get_Simple_Init_Val (T, Loc))); + Expression => Get_Simple_Init_Val (T, N))); Analyze_And_Resolve (Expression (Expression (N)), T); Analyze_And_Resolve (Expression (N), T); @@ -3193,292 +3205,299 @@ package body Exp_Ch4 is -- Case of initialization procedure present, must be called else - Init := Base_Init_Proc (T); - Nod := N; - Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); - - -- Construct argument list for the initialization routine call - - Arg1 := - Make_Explicit_Dereference (Loc, - Prefix => New_Reference_To (Temp, Loc)); - Set_Assignment_OK (Arg1); - Temp_Type := PtrT; + Check_Restriction (No_Default_Initialization, N); - -- The initialization procedure expects a specific type. if the - -- context is access to class wide, indicate that the object being - -- allocated has the right specific type. + if not Restriction_Active (No_Default_Initialization) then + Init := Base_Init_Proc (T); + Nod := N; + Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); - if Is_Class_Wide_Type (Dtyp) then - Arg1 := Unchecked_Convert_To (T, Arg1); - end if; - - -- If designated type is a concurrent type or if it is private - -- type whose definition is a concurrent type, the first argument - -- in the Init routine has to be unchecked conversion to the - -- corresponding record type. If the designated type is a derived - -- type, we also convert the argument to its root type. - - if Is_Concurrent_Type (T) then - Arg1 := - Unchecked_Convert_To (Corresponding_Record_Type (T), Arg1); + -- Construct argument list for the initialization routine call - elsif Is_Private_Type (T) - and then Present (Full_View (T)) - and then Is_Concurrent_Type (Full_View (T)) - then Arg1 := - Unchecked_Convert_To - (Corresponding_Record_Type (Full_View (T)), Arg1); - - elsif Etype (First_Formal (Init)) /= Base_Type (T) then - declare - Ftyp : constant Entity_Id := Etype (First_Formal (Init)); + Make_Explicit_Dereference (Loc, + Prefix => New_Reference_To (Temp, Loc)); + Set_Assignment_OK (Arg1); + Temp_Type := PtrT; - begin - Arg1 := OK_Convert_To (Etype (Ftyp), Arg1); - Set_Etype (Arg1, Ftyp); - end; - end if; + -- The initialization procedure expects a specific type. if the + -- context is access to class wide, indicate that the object + -- being allocated has the right specific type. - Args := New_List (Arg1); + if Is_Class_Wide_Type (Dtyp) then + Arg1 := Unchecked_Convert_To (T, Arg1); + end if; - -- For the task case, pass the Master_Id of the access type as - -- the value of the _Master parameter, and _Chain as the value - -- of the _Chain parameter (_Chain will be defined as part of - -- the generated code for the allocator). + -- If designated type is a concurrent type or if it is private + -- type whose definition is a concurrent type, the first + -- argument in the Init routine has to be unchecked conversion + -- to the corresponding record type. If the designated type is + -- a derived type, we also convert the argument to its root + -- type. - -- In Ada 2005, the context may be a function that returns an - -- anonymous access type. In that case the Master_Id has been - -- created when expanding the function declaration. + if Is_Concurrent_Type (T) then + Arg1 := + Unchecked_Convert_To (Corresponding_Record_Type (T), Arg1); - if Has_Task (T) then - if No (Master_Id (Base_Type (PtrT))) then + elsif Is_Private_Type (T) + and then Present (Full_View (T)) + and then Is_Concurrent_Type (Full_View (T)) + then + Arg1 := + Unchecked_Convert_To + (Corresponding_Record_Type (Full_View (T)), Arg1); - -- If we have a non-library level task with the restriction - -- No_Task_Hierarchy set, then no point in expanding. + elsif Etype (First_Formal (Init)) /= Base_Type (T) then + declare + Ftyp : constant Entity_Id := Etype (First_Formal (Init)); + begin + Arg1 := OK_Convert_To (Etype (Ftyp), Arg1); + Set_Etype (Arg1, Ftyp); + end; + end if; - if not Is_Library_Level_Entity (T) - and then Restriction_Active (No_Task_Hierarchy) - then - return; - end if; + Args := New_List (Arg1); - -- The designated type was an incomplete type, and the - -- access type did not get expanded. Salvage it now. + -- For the task case, pass the Master_Id of the access type as + -- the value of the _Master parameter, and _Chain as the value + -- of the _Chain parameter (_Chain will be defined as part of + -- the generated code for the allocator). - pragma Assert (Present (Parent (Base_Type (PtrT)))); - Expand_N_Full_Type_Declaration (Parent (Base_Type (PtrT))); - end if; + -- In Ada 2005, the context may be a function that returns an + -- anonymous access type. In that case the Master_Id has been + -- created when expanding the function declaration. - -- If the context of the allocator is a declaration or an - -- assignment, we can generate a meaningful image for it, - -- even though subsequent assignments might remove the - -- connection between task and entity. We build this image - -- when the left-hand side is a simple variable, a simple - -- indexed assignment or a simple selected component. + if Has_Task (T) then + if No (Master_Id (Base_Type (PtrT))) then - if Nkind (Parent (N)) = N_Assignment_Statement then - declare - Nam : constant Node_Id := Name (Parent (N)); + -- If we have a non-library level task with restriction + -- No_Task_Hierarchy set, then no point in expanding. - begin - if Is_Entity_Name (Nam) then - Decls := - Build_Task_Image_Decls ( - Loc, - New_Occurrence_Of - (Entity (Nam), Sloc (Nam)), T); - - elsif Nkind_In - (Nam, N_Indexed_Component, N_Selected_Component) - and then Is_Entity_Name (Prefix (Nam)) + if not Is_Library_Level_Entity (T) + and then Restriction_Active (No_Task_Hierarchy) then - Decls := - Build_Task_Image_Decls - (Loc, Nam, Etype (Prefix (Nam))); - else - Decls := Build_Task_Image_Decls (Loc, T, T); + return; end if; - end; - elsif Nkind (Parent (N)) = N_Object_Declaration then - Decls := - Build_Task_Image_Decls ( - Loc, Defining_Identifier (Parent (N)), T); + -- The designated type was an incomplete type, and the + -- access type did not get expanded. Salvage it now. - else - Decls := Build_Task_Image_Decls (Loc, T, T); - end if; - - Append_To (Args, - New_Reference_To - (Master_Id (Base_Type (Root_Type (PtrT))), Loc)); - Append_To (Args, Make_Identifier (Loc, Name_uChain)); + pragma Assert (Present (Parent (Base_Type (PtrT)))); + Expand_N_Full_Type_Declaration + (Parent (Base_Type (PtrT))); + end if; - Decl := Last (Decls); - Append_To (Args, - New_Occurrence_Of (Defining_Identifier (Decl), Loc)); + -- If the context of the allocator is a declaration or an + -- assignment, we can generate a meaningful image for it, + -- even though subsequent assignments might remove the + -- connection between task and entity. We build this image + -- when the left-hand side is a simple variable, a simple + -- indexed assignment or a simple selected component. + + if Nkind (Parent (N)) = N_Assignment_Statement then + declare + Nam : constant Node_Id := Name (Parent (N)); + + begin + if Is_Entity_Name (Nam) then + Decls := + Build_Task_Image_Decls + (Loc, + New_Occurrence_Of + (Entity (Nam), Sloc (Nam)), T); + + elsif Nkind_In + (Nam, N_Indexed_Component, N_Selected_Component) + and then Is_Entity_Name (Prefix (Nam)) + then + Decls := + Build_Task_Image_Decls + (Loc, Nam, Etype (Prefix (Nam))); + else + Decls := Build_Task_Image_Decls (Loc, T, T); + end if; + end; - -- Has_Task is false, Decls not used + elsif Nkind (Parent (N)) = N_Object_Declaration then + Decls := + Build_Task_Image_Decls + (Loc, Defining_Identifier (Parent (N)), T); - else - Decls := No_List; - end if; + else + Decls := Build_Task_Image_Decls (Loc, T, T); + end if; - -- Add discriminants if discriminated type + Append_To (Args, + New_Reference_To + (Master_Id (Base_Type (Root_Type (PtrT))), Loc)); + Append_To (Args, Make_Identifier (Loc, Name_uChain)); - declare - Dis : Boolean := False; - Typ : Entity_Id; + Decl := Last (Decls); + Append_To (Args, + New_Occurrence_Of (Defining_Identifier (Decl), Loc)); - begin - if Has_Discriminants (T) then - Dis := True; - Typ := T; + -- Has_Task is false, Decls not used - elsif Is_Private_Type (T) - and then Present (Full_View (T)) - and then Has_Discriminants (Full_View (T)) - then - Dis := True; - Typ := Full_View (T); + else + Decls := No_List; end if; - if Dis then - -- If the allocated object will be constrained by the - -- default values for discriminants, then build a - -- subtype with those defaults, and change the allocated - -- subtype to that. Note that this happens in fewer - -- cases in Ada 2005 (AI-363). - - if not Is_Constrained (Typ) - and then Present (Discriminant_Default_Value - (First_Discriminant (Typ))) - and then (Ada_Version < Ada_05 - or else not Has_Constrained_Partial_View (Typ)) + -- Add discriminants if discriminated type + + declare + Dis : Boolean := False; + Typ : Entity_Id; + + begin + if Has_Discriminants (T) then + Dis := True; + Typ := T; + + elsif Is_Private_Type (T) + and then Present (Full_View (T)) + and then Has_Discriminants (Full_View (T)) then - Typ := Build_Default_Subtype (Typ, N); - Set_Expression (N, New_Reference_To (Typ, Loc)); + Dis := True; + Typ := Full_View (T); end if; - Discr := First_Elmt (Discriminant_Constraint (Typ)); - while Present (Discr) loop - Nod := Node (Discr); - Append (New_Copy_Tree (Node (Discr)), Args); + if Dis then - -- AI-416: when the discriminant constraint is an - -- anonymous access type make sure an accessibility - -- check is inserted if necessary (3.10.2(22.q/2)) + -- If the allocated object will be constrained by the + -- default values for discriminants, then build a + -- subtype with those defaults, and change the allocated + -- subtype to that. Note that this happens in fewer + -- cases in Ada 2005 (AI-363). - if Ada_Version >= Ada_05 - and then Ekind (Etype (Nod)) = E_Anonymous_Access_Type + if not Is_Constrained (Typ) + and then Present (Discriminant_Default_Value + (First_Discriminant (Typ))) + and then (Ada_Version < Ada_05 + or else + not Has_Constrained_Partial_View (Typ)) then - Apply_Accessibility_Check (Nod, Typ); + Typ := Build_Default_Subtype (Typ, N); + Set_Expression (N, New_Reference_To (Typ, Loc)); end if; - Next_Elmt (Discr); - end loop; - end if; - end; + Discr := First_Elmt (Discriminant_Constraint (Typ)); + while Present (Discr) loop + Nod := Node (Discr); + Append (New_Copy_Tree (Node (Discr)), Args); - -- We set the allocator as analyzed so that when we analyze the - -- expression actions node, we do not get an unwanted recursive - -- expansion of the allocator expression. + -- AI-416: when the discriminant constraint is an + -- anonymous access type make sure an accessibility + -- check is inserted if necessary (3.10.2(22.q/2)) - Set_Analyzed (N, True); - Nod := Relocate_Node (N); + if Ada_Version >= Ada_05 + and then + Ekind (Etype (Nod)) = E_Anonymous_Access_Type + then + Apply_Accessibility_Check (Nod, Typ); + end if; - -- Here is the transformation: - -- input: new T - -- output: Temp : constant ptr_T := new T; - -- Init (Temp.all, ...); - -- Attach_To_Final_List (Finalizable (Temp.all)); - -- Initialize (Finalizable (Temp.all)); + Next_Elmt (Discr); + end loop; + end if; + end; - -- Here ptr_T is the pointer type for the allocator, and is the - -- subtype of the allocator. + -- We set the allocator as analyzed so that when we analyze the + -- expression actions node, we do not get an unwanted recursive + -- expansion of the allocator expression. - Temp_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Temp, - Constant_Present => True, - Object_Definition => New_Reference_To (Temp_Type, Loc), - Expression => Nod); + Set_Analyzed (N, True); + Nod := Relocate_Node (N); - Set_Assignment_OK (Temp_Decl); - Insert_Action (N, Temp_Decl, Suppress => All_Checks); + -- Here is the transformation: + -- input: new T + -- output: Temp : constant ptr_T := new T; + -- Init (Temp.all, ...); + -- Attach_To_Final_List (Finalizable (Temp.all)); + -- Initialize (Finalizable (Temp.all)); - -- If the designated type is a task type or contains tasks, - -- create block to activate created tasks, and insert - -- declaration for Task_Image variable ahead of call. + -- Here ptr_T is the pointer type for the allocator, and is the + -- subtype of the allocator. - if Has_Task (T) then - declare - L : constant List_Id := New_List; - Blk : Node_Id; + Temp_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Constant_Present => True, + Object_Definition => New_Reference_To (Temp_Type, Loc), + Expression => Nod); - begin - Build_Task_Allocate_Block (L, Nod, Args); - Blk := Last (L); + Set_Assignment_OK (Temp_Decl); + Insert_Action (N, Temp_Decl, Suppress => All_Checks); - Insert_List_Before (First (Declarations (Blk)), Decls); - Insert_Actions (N, L); - end; + -- If the designated type is a task type or contains tasks, + -- create block to activate created tasks, and insert + -- declaration for Task_Image variable ahead of call. - else - Insert_Action (N, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (Init, Loc), - Parameter_Associations => Args)); - end if; + if Has_Task (T) then + declare + L : constant List_Id := New_List; + Blk : Node_Id; + begin + Build_Task_Allocate_Block (L, Nod, Args); + Blk := Last (L); + Insert_List_Before (First (Declarations (Blk)), Decls); + Insert_Actions (N, L); + end; - if Controlled_Type (T) then + else + Insert_Action (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Init, Loc), + Parameter_Associations => Args)); + end if; - -- Postpone the generation of a finalization call for the - -- current allocator if it acts as a coextension. + if Controlled_Type (T) then - if Is_Dynamic_Coextension (N) then - if No (Coextensions (N)) then - Set_Coextensions (N, New_Elmt_List); - end if; + -- Postpone the generation of a finalization call for the + -- current allocator if it acts as a coextension. - Append_Elmt (New_Copy_Tree (Arg1), Coextensions (N)); + if Is_Dynamic_Coextension (N) then + if No (Coextensions (N)) then + Set_Coextensions (N, New_Elmt_List); + end if; - else - Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT); + Append_Elmt (New_Copy_Tree (Arg1), Coextensions (N)); + + else + Flist := + Get_Allocator_Final_List (N, Base_Type (T), PtrT); - -- Anonymous access types created for access parameters - -- are attached to an explicitly constructed controller, - -- which ensures that they can be finalized properly, even - -- if their deallocation might not happen. The list - -- associated with the controller is doubly-linked. For - -- other anonymous access types, the object may end up - -- on the global final list which is singly-linked. - -- Work needed for access discriminants in Ada 2005 ??? + -- Anonymous access types created for access parameters + -- are attached to an explicitly constructed controller, + -- which ensures that they can be finalized properly, + -- even if their deallocation might not happen. The list + -- associated with the controller is doubly-linked. For + -- other anonymous access types, the object may end up + -- on the global final list which is singly-linked. + -- Work needed for access discriminants in Ada 2005 ??? - if Ekind (PtrT) = E_Anonymous_Access_Type + if Ekind (PtrT) = E_Anonymous_Access_Type and then Nkind (Associated_Node_For_Itype (PtrT)) - not in N_Subprogram_Specification - then - Attach_Level := Uint_1; - else - Attach_Level := Uint_2; - end if; + not in N_Subprogram_Specification + then + Attach_Level := Uint_1; + else + Attach_Level := Uint_2; + end if; - Insert_Actions (N, - Make_Init_Call ( - Ref => New_Copy_Tree (Arg1), - Typ => T, - Flist_Ref => Flist, - With_Attach => Make_Integer_Literal - (Loc, Attach_Level))); + Insert_Actions (N, + Make_Init_Call ( + Ref => New_Copy_Tree (Arg1), + Typ => T, + Flist_Ref => Flist, + With_Attach => Make_Integer_Literal (Loc, + Intval => Attach_Level))); + end if; end if; - end if; - Rewrite (N, New_Reference_To (Temp, Loc)); - Analyze_And_Resolve (N, PtrT); + Rewrite (N, New_Reference_To (Temp, Loc)); + Analyze_And_Resolve (N, PtrT); + end if; end if; end; @@ -4110,6 +4129,15 @@ package body Exp_Ch4 is return; end if; + -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place + -- function, then additional actuals must be passed. + + if Ada_Version >= Ada_05 + and then Is_Build_In_Place_Function_Call (P) + then + Make_Build_In_Place_Call_In_Anonymous_Context (P); + end if; + -- If the prefix is an access type, then we unconditionally rewrite -- if as an explicit deference. This simplifies processing for several -- cases, including packed array cases and certain cases in which @@ -6236,6 +6264,7 @@ package body Exp_Ch4 is Convert_To_Actual_Subtype (Opnd); Arr := Etype (Opnd); Ensure_Defined (Arr, N); + Silly_Boolean_Array_Not_Test (N, Arr); if Nkind (Parent (N)) = N_Assignment_Statement then if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then @@ -6758,6 +6787,15 @@ package body Exp_Ch4 is Generate_Discriminant_Check (N); end if; + -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place + -- function, then additional actuals must be passed. + + if Ada_Version >= Ada_05 + and then Is_Build_In_Place_Function_Call (P) + then + Make_Build_In_Place_Call_In_Anonymous_Context (P); + end if; + -- Gigi cannot handle unchecked conversions that are the prefix of a -- selected component with discriminants. This must be checked during -- expansion, because during analysis the type of the selector is not @@ -7025,6 +7063,15 @@ package body Exp_Ch4 is Analyze_And_Resolve (Pfx, Ptp); end if; + -- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place + -- function, then additional actuals must be passed. + + if Ada_Version >= Ada_05 + and then Is_Build_In_Place_Function_Call (Pfx) + then + Make_Build_In_Place_Call_In_Anonymous_Context (Pfx); + end if; + -- Range checks are potentially also needed for cases involving -- a slice indexed by a subtype indication, but Do_Range_Check -- can currently only be set for expressions ??? @@ -9072,7 +9119,8 @@ package body Exp_Ch4 is -- configurable run time setting. if not RTE_Available (RE_IW_Membership) then - Error_Msg_CRT ("abstract interface types", N); + Error_Msg_CRT + ("dynamic membership test on interface types", N); return Empty; end if; diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index b9dbfb18f94..e790e553d07 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.adb @@ -219,7 +219,7 @@ package body Sem_Cat is -- unit generating the message is an internal unit. This is the -- situation in which such messages would be ignored in any case, -- so it is convenient not to generate them (since it causes - -- annoying inteference with debugging) + -- annoying interference with debugging). if Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)) and then not Is_Internal_File_Name (Unit_File_Name (Main_Unit)) @@ -332,8 +332,21 @@ package body Sem_Cat is Nam : TSS_Name_Type; At_Any_Place : Boolean := False) return Boolean is - Rep_Item : Node_Id; + Rep_Item : Node_Id; + Full_Type : Entity_Id := Typ; + begin + -- In the case of a type derived from a private view, any specified + -- stream attributes will be attached to the derived type's underlying + -- type rather the derived type entity itself (which is itself private). + + if Is_Private_Type (Typ) + and then Is_Derived_Type (Typ) + and then Present (Full_View (Typ)) + then + Full_Type := Underlying_Type (Typ); + end if; + -- We start from the declaration node and then loop until the end of -- the list until we find the requested attribute definition clause. -- In Ada 2005 mode, clauses are ignored if they are not currently @@ -341,7 +354,7 @@ package body Sem_Cat is -- inserted by the expander at the point where the clause occurs), -- unless At_Any_Place is true. - Rep_Item := First_Rep_Item (Typ); + Rep_Item := First_Rep_Item (Full_Type); while Present (Rep_Item) loop if Nkind (Rep_Item) = N_Attribute_Definition_Clause then case Chars (Rep_Item) is @@ -1251,7 +1264,9 @@ package body Sem_Cat is end; end if; - -- Non-static discriminant not allowed in preelaborayted unit + -- Non-static discriminant not allowed in preelaborated unit + -- Controlled object of a type with a user-defined Initialize + -- is forbidden as well. if Is_Record_Type (Etype (Id)) then declare @@ -1274,7 +1289,14 @@ package body Sem_Cat is PEE); end if; end if; + + if Has_Overriding_Initialize (ET) then + Error_Msg_NE + ("controlled type& does not have" + & " preelaborable initialization", N, ET); + end if; end; + end if; end if; @@ -1552,9 +1574,9 @@ package body Sem_Cat is Error_Node); end if; - -- For limited private type parameter, we check only the private + -- For a limited private type parameter, we check only the private -- declaration and ignore full type declaration, unless this is - -- the only declaration for the type, eg. as a limited record. + -- the only declaration for the type, e.g., as a limited record. elsif Is_Limited_Type (Param_Type) and then (Nkind (Type_Decl) = N_Private_Type_Declaration @@ -1569,7 +1591,7 @@ package body Sem_Cat is if No (Full_View (Param_Type)) and then Ekind (Param_Type) /= E_Record_Type then - -- Type does not have completion yet, so if declared in in + -- Type does not have completion yet, so if declared in -- the current RCI scope it is illegal, and will be flagged -- subsequently. @@ -1585,7 +1607,11 @@ package body Sem_Cat is -- contract model for privacy, but we support both semantics -- for now for compatibility (note that ACATS test BXE2009 -- checks a case that conforms to the Ada 95 rules but is - -- illegal in Ada 2005). + -- illegal in Ada 2005). In the Ada 2005 case we check for the + -- possibilities of visible TSS stream subprograms or explicit + -- stream attribute definitions because the TSS subprograms + -- can be hidden in the private part while the attribute + -- definitions are still be available from the visible part. Base_Param_Type := Base_Type (Param_Type); Base_Under_Type := Base_Type (Underlying_Type @@ -1609,7 +1635,13 @@ package body Sem_Cat is or else Is_Hidden (TSS (Base_Param_Type, TSS_Stream_Read)) or else - Is_Hidden (TSS (Base_Param_Type, TSS_Stream_Write)))) + Is_Hidden (TSS (Base_Param_Type, TSS_Stream_Write))) + and then + (not Has_Stream_Attribute_Definition + (Base_Param_Type, TSS_Stream_Read) + or else + not Has_Stream_Attribute_Definition + (Base_Param_Type, TSS_Stream_Write))) then if K = N_Subprogram_Declaration then Error_Node := Param_Spec; @@ -1761,12 +1793,15 @@ package body Sem_Cat is -- This subprogram also enforces the checks in E.2.2(13). A value of -- such type must not be dereferenced unless as controlling operand of - -- a dispatching call. + -- a dispatching call. Explicit dereferences not coming from source are + -- exempted from this checking because the expander produces them in + -- some cases (such as for tag checks on dispatching calls with multiple + -- controlling operands). However we do check in the case of an implicit + -- dereference that is expanded to an explicit dereference (hence the + -- test of whether Original_Node (N) comes from source). elsif K = N_Explicit_Dereference - and then (Comes_From_Source (N) - or else (Nkind (Original_Node (N)) = N_Selected_Component - and then Comes_From_Source (Original_Node (N)))) + and then Comes_From_Source (Original_Node (N)) then E := Etype (Prefix (N)); @@ -1788,9 +1823,12 @@ package body Sem_Cat is -- If we are just within a procedure or function call and the -- dereference has not been analyzed, return because this procedure - -- will be called again from sem_res Resolve_Actuals. + -- will be called again from sem_res Resolve_Actuals. The same can + -- apply in the case of dereference that is the prefix of a selected + -- component, which can be a call given in prefixed form. - if Is_Actual_Parameter (N) + if (Is_Actual_Parameter (N) + or else PK = N_Selected_Component) and then not Analyzed (N) then return; @@ -1806,25 +1844,8 @@ package body Sem_Cat is return; end if; - -- The following code is needed for expansion of RACW Write - -- attribute, since such expressions can appear in the expanded - -- code. - - if not Comes_From_Source (N) - and then - (PK = N_In - or else PK = N_Attribute_Reference - or else - (PK = N_Type_Conversion - and then Present (Parent (N)) - and then Present (Parent (Parent (N))) - and then - Nkind (Parent (Parent (N))) = N_Selected_Component)) - then - return; - end if; - - Error_Msg_N ("incorrect dereference of remote type", N); + Error_Msg_N + ("invalid dereference of a remote access-to-class-wide value", N); end if; end Validate_Remote_Access_To_Class_Wide_Type; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index e3d45f9e942..224639983b5 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -73,7 +73,7 @@ package body Sem_Ch4 is -- function, and if so must be converted into an explicit call node -- and analyzed as such. This deproceduring must be done during the first -- pass of overload resolution, because otherwise a procedure call with - -- overloaded actuals may fail to resolve. See 4327-001 for an example. + -- overloaded actuals may fail to resolve. procedure Analyze_Operator_Call (N : Node_Id; Op_Id : Entity_Id); -- Analyze a call of the form "+"(x, y), etc. The prefix of the call @@ -268,6 +268,11 @@ package body Sem_Ch4 is function Try_Object_Operation (N : Node_Id) return Boolean; -- Ada 2005 (AI-252): Support the object.operation notation + procedure wpo (T : Entity_Id); + pragma Warnings (Off, wpo); + -- Used for debugging: obtain list of primitive operations even if + -- type is not frozen and dispatch table is not built yet. + ------------------------ -- Ambiguous_Operands -- ------------------------ @@ -366,7 +371,6 @@ package body Sem_Ch4 is if Nkind (E) = N_Qualified_Expression then Acc_Type := Create_Itype (E_Allocator_Type, N); Set_Etype (Acc_Type, Acc_Type); - Init_Size_Align (Acc_Type); Find_Type (Subtype_Mark (E)); -- Analyze the qualified expression, and apply the name resolution @@ -491,7 +495,6 @@ package body Sem_Ch4 is Type_Id := Process_Subtype (E, N); Acc_Type := Create_Itype (E_Allocator_Type, N); Set_Etype (Acc_Type, Acc_Type); - Init_Size_Align (Acc_Type); Set_Directly_Designated_Type (Acc_Type, Type_Id); Check_Fully_Declared (Type_Id, N); @@ -971,26 +974,6 @@ package body Sem_Ch4 is End_Interp_List; end if; - - -- Check for not-yet-implemented cases of AI-318. We only need to check - -- for inherently limited types, because other limited types will be - -- returned by copy, which works just fine. - -- If the context is an attribute reference 'Class, this is really a - -- type conversion, which is illegal, and will be caught elsewhere. - - if Ada_Version >= Ada_05 - and then not Debug_Flag_Dot_L - and then Is_Inherently_Limited_Type (Etype (N)) - and then (Nkind_In (Parent (N), N_Selected_Component, - N_Indexed_Component, - N_Slice) - or else - (Nkind (Parent (N)) = N_Attribute_Reference - and then Attribute_Name (Parent (N)) /= Name_Class)) - then - Error_Msg_N ("(Ada 2005) limited function call in this context" & - " is not yet implemented", N); - end if; end Analyze_Call; --------------------------- @@ -1444,7 +1427,6 @@ package body Sem_Ch4 is -- where the prefix might include functions that return access to -- subprograms and others that return a regular type. Disambiguation -- of those has to take place in Resolve. - -- See e.g. 7117-014 and E317-001. New_N := Make_Function_Call (Loc, @@ -2716,7 +2698,10 @@ package body Sem_Ch4 is procedure Check_Common_Type (T1, T2 : Entity_Id) is begin - if Covers (T1, T2) or else Covers (T2, T1) then + if Covers (T1 => T1, T2 => T2) + or else + Covers (T1 => T2, T2 => T1) + then if T1 = Universal_Integer or else T1 = Universal_Real or else T1 = Any_Character @@ -2808,12 +2793,50 @@ package body Sem_Ch4 is procedure Analyze_Reference (N : Node_Id) is P : constant Node_Id := Prefix (N); + E : Entity_Id; + T : Entity_Id; Acc_Type : Entity_Id; + begin Analyze (P); + + -- An interesting error check, if we take the 'Reference of an object + -- for which a pragma Atomic or Volatile has been given, and the type + -- of the object is not Atomic or Volatile, then we are in trouble. The + -- problem is that no trace of the atomic/volatile status will remain + -- for the backend to respect when it deals with the resulting pointer, + -- since the pointer type will not be marked atomic (it is a pointer to + -- the base type of the object). + + -- It is not clear if that can ever occur, but in case it does, we will + -- generate an error message. Not clear if this message can ever be + -- generated, and pretty clear that it represents a bug if it is, still + -- seems worth checking! + + T := Etype (P); + + if Is_Entity_Name (P) + and then Is_Object_Reference (P) + then + E := Entity (P); + T := Etype (P); + + if (Has_Atomic_Components (E) + and then not Has_Atomic_Components (T)) + or else + (Has_Volatile_Components (E) + and then not Has_Volatile_Components (T)) + or else (Is_Atomic (E) and then not Is_Atomic (T)) + or else (Is_Volatile (E) and then not Is_Volatile (T)) + then + Error_Msg_N ("cannot take reference to Atomic/Volatile object", N); + end if; + end if; + + -- Carry on with normal processing + Acc_Type := Create_Itype (E_Allocator_Type, N); - Set_Etype (Acc_Type, Acc_Type); - Init_Size_Align (Acc_Type); + Set_Etype (Acc_Type, Acc_Type); Set_Directly_Designated_Type (Acc_Type, Etype (P)); Set_Etype (N, Acc_Type); end Analyze_Reference; @@ -2845,7 +2868,8 @@ package body Sem_Ch4 is -- It is known that the parent of N denotes a subprogram call. Comp -- is an overloadable component of the concurrent type of the prefix. -- Determine whether all formals of the parent of N and Comp are mode - -- conformant. + -- conformant. If the parent node is not analyzed yet it may be an + -- indexed component rather than a function call. ------------------------------ -- Has_Mode_Conformant_Spec -- @@ -2858,7 +2882,13 @@ package body Sem_Ch4 is begin Comp_Param := First_Formal (Comp); - Param := First (Parameter_Associations (Parent (N))); + + if Nkind (Parent (N)) = N_Indexed_Component then + Param := First (Expressions (Parent (N))); + else + Param := First (Parameter_Associations (Parent (N))); + end if; + while Present (Comp_Param) and then Present (Param) loop @@ -2908,14 +2938,19 @@ package body Sem_Ch4 is -- A RACW object can never be used as prefix of a selected -- component since that means it is dereferenced without -- being a controlling operand of a dispatching operation - -- (RM E.2.2(15)). + -- (RM E.2.2(16/1)). Before reporting an error, we must check + -- whether this is actually a dispatching call in prefix form. if Is_Remote_Access_To_Class_Wide_Type (Prefix_Type) and then Comes_From_Source (N) then - Error_Msg_N - ("invalid dereference of a remote access to class-wide value", - N); + if Try_Object_Operation (N) then + return; + else + Error_Msg_N + ("invalid dereference of a remote access-to-class-wide value", + N); + end if; -- Normal case of selected component applied to access type @@ -2932,6 +2967,27 @@ package body Sem_Ch4 is Prefix_Type := Process_Implicit_Dereference_Prefix (Pent, Name); end if; + + -- If we have an explicit dereference of a remote access-to-class-wide + -- value, then issue an error (see RM-E.2.2(16/1)). However we first + -- have to check for the case of a prefix that is a controlling operand + -- of a prefixed dispatching call, as the dereference is legal in that + -- case. Normally this condition is checked in Validate_Remote_Access_ + -- To_Class_Wide_Type, but we have to defer the checking for selected + -- component prefixes because of the prefixed dispatching call case. + -- Note that implicit dereferences are checked for this just above. + + elsif Nkind (Name) = N_Explicit_Dereference + and then Is_Remote_Access_To_Class_Wide_Type (Etype (Prefix (Name))) + and then Comes_From_Source (N) + then + if Try_Object_Operation (N) then + return; + else + Error_Msg_N + ("invalid dereference of a remote access-to-class-wide value", + N); + end if; end if; -- (Ada 2005): if the prefix is the limited view of a type, and @@ -3256,7 +3312,8 @@ package body Sem_Ch4 is if Is_Tagged_Type (Prefix_Type) and then Nkind_In (Parent (N), N_Procedure_Call_Statement, - N_Function_Call) + N_Function_Call, + N_Indexed_Component) and then Has_Mode_Conformant_Spec (Comp) then Has_Candidate := True; @@ -3322,6 +3379,7 @@ package body Sem_Ch4 is -- the controlling formal is implicit ??? elsif Nkind (Parent (N)) /= N_Procedure_Call_Statement + and then Nkind (Parent (N)) /= N_Indexed_Component and then Try_Object_Operation (N) then return; @@ -3899,7 +3957,9 @@ package body Sem_Ch4 is if Is_Numeric_Type (T1) and then Is_Numeric_Type (T2) - and then (Covers (T1, T2) or else Covers (T2, T1)) + and then (Covers (T1 => T1, T2 => T2) + or else + Covers (T1 => T2, T2 => T1)) then Add_One_Interp (N, Op_Id, Specific_Type (T1, T2)); end if; @@ -3938,7 +3998,9 @@ package body Sem_Ch4 is elsif Is_Numeric_Type (T1) and then Is_Numeric_Type (T2) - and then (Covers (T1, T2) or else Covers (T2, T1)) + and then (Covers (T1 => T1, T2 => T2) + or else + Covers (T1 => T2, T2 => T1)) then Add_One_Interp (N, Op_Id, Specific_Type (T1, T2)); @@ -3983,7 +4045,9 @@ package body Sem_Ch4 is -- already set (case of operation constructed by Exp_Fixed). if Is_Integer_Type (T1) - and then (Covers (T1, T2) or else Covers (T2, T1)) + and then (Covers (T1 => T1, T2 => T2) + or else + Covers (T1 => T2, T2 => T1)) then Add_One_Interp (N, Op_Id, Specific_Type (T1, T2)); end if; @@ -4414,7 +4478,7 @@ package body Sem_Ch4 is if Nkind (L) = N_Aggregate and then Nkind (R) /= N_Aggregate then - Find_Comparison_Types (R, L, Op_Id, N); + Find_Comparison_Types (L => R, R => L, Op_Id => Op_Id, N => N); return; end if; @@ -4632,7 +4696,7 @@ package body Sem_Ch4 is if Nkind (L) = N_Aggregate and then Nkind (R) /= N_Aggregate then - Find_Equality_Types (R, L, Op_Id, N); + Find_Equality_Types (L => R, R => L, Op_Id => Op_Id, N => N); return; end if; @@ -5653,8 +5717,8 @@ package body Sem_Ch4 is (Call_Node : Node_Id; Node_To_Replace : Node_Id) is - Formal_Type : constant Entity_Id := - Etype (First_Formal (Entity (Subprog))); + Control : constant Entity_Id := First_Formal (Entity (Subprog)); + Formal_Type : constant Entity_Id := Etype (Control); First_Actual : Node_Id; begin @@ -5716,6 +5780,19 @@ package body Sem_Ch4 is elsif Is_Access_Type (Formal_Type) and then not Is_Access_Type (Etype (Obj)) then + -- A special case: A.all'access is illegal if A is an access to a + -- constant and the context requires an access to a variable. + + if not Is_Access_Constant (Formal_Type) then + if (Nkind (Obj) = N_Explicit_Dereference + and then Is_Access_Constant (Etype (Prefix (Obj)))) + or else not Is_Variable (Obj) + then + Error_Msg_NE + ("actual for& must be a variable", Obj, Control); + end if; + end if; + Rewrite (First_Actual, Make_Attribute_Reference (Loc, Attribute_Name => Name_Access, @@ -6288,10 +6365,10 @@ package body Sem_Ch4 is -- must be identical, and the kind of call indicates the expected -- kind of operation (function or procedure). If the type is a -- (tagged) synchronized type, the primitive ops are attached to the - -- corresponding record type. + -- corresponding record (base) type. if Is_Concurrent_Type (Obj_Type) then - Corr_Type := Corresponding_Record_Type (Obj_Type); + Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type)); Elmt := First_Elmt (Primitive_Operations (Corr_Type)); elsif not Is_Generic_Type (Obj_Type) then @@ -6480,4 +6557,30 @@ package body Sem_Ch4 is end if; end Try_Object_Operation; + --------- + -- wpo -- + --------- + + procedure wpo (T : Entity_Id) is + Op : Entity_Id; + E : Elmt_Id; + + begin + if not Is_Tagged_Type (T) then + return; + end if; + + E := First_Elmt (Primitive_Operations (Base_Type (T))); + while Present (E) loop + Op := Node (E); + Write_Int (Int (Op)); + Write_Str (" === "); + Write_Name (Chars (Op)); + Write_Str (" in "); + Write_Name (Chars (Scope (Op))); + Next_Elmt (E); + Write_Eol; + end loop; + end wpo; + end Sem_Ch4;