diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 2e03e1f7a45..9d62cbe8060 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -35,6 +35,7 @@ with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; with Exp_Disp; use Exp_Disp; +with Exp_Dist; use Exp_Dist; with Exp_Dbug; use Exp_Dbug; with Lib; use Lib; with Lib.Xref; use Lib.Xref; @@ -89,19 +90,25 @@ package body Sem_Ch7 is procedure Check_Anonymous_Access_Types (Spec_Id : Entity_Id; - P_Body : Node_Id); + P_Body : Node_Id); -- If the spec of a package has a limited_with_clause, it may declare - -- anonymous access types whose designated type is a limited view, such - -- an anonymous access return type for a function. This access type - -- cannot be elaborated in the spec itself, but it may need an itype - -- reference if it is used within a nested scope. In that case the itype - -- reference is created at the beginning of the corresponding package body - -- and inserted before other body declarations. + -- anonymous access types whose designated type is a limited view, such an + -- anonymous access return type for a function. This access type cannot be + -- elaborated in the spec itself, but it may need an itype reference if it + -- is used within a nested scope. In that case the itype reference is + -- created at the beginning of the corresponding package body and inserted + -- before other body declarations. + + procedure Inspect_Deferred_Constant_Completion (Decls : List_Id); + -- Examines the deferred constants in the private part of the package + -- specification, or in a package body. Emits the error message + -- "constant declaration requires initialization expression" if not + -- completed by an Import pragma. procedure Install_Package_Entity (Id : Entity_Id); - -- Basic procedure for the previous two. Places one entity on its - -- visibility chain, and recurses on the visible part if the entity - -- is an inner package. + -- Supporting procedure for Install_{Visible,Private}_Declarations. + -- Places one entity on its visibility chain, and recurses on the visible + -- part if the entity is an inner package. function Is_Private_Base_Type (E : Entity_Id) return Boolean; -- True for a private type that is not a subtype @@ -322,9 +329,9 @@ package body Sem_Ch7 is Set_Use (Visible_Declarations (Specification (Pack_Decl))); Set_Use (Private_Declarations (Specification (Pack_Decl))); - -- This is a nested package, so it may be necessary to declare - -- certain inherited subprograms that are not yet visible because - -- the parent type's subprograms are now visible. + -- This is a nested package, so it may be necessary to declare certain + -- inherited subprograms that are not yet visible because the parent + -- type's subprograms are now visible. if Ekind (Scope (Spec_Id)) = E_Package and then Scope (Spec_Id) /= Standard_Standard @@ -334,6 +341,18 @@ package body Sem_Ch7 is if Present (Declarations (N)) then Analyze_Declarations (Declarations (N)); + Inspect_Deferred_Constant_Completion (Declarations (N)); + end if; + + -- Analyze_Declarations has caused freezing of all types; now generate + -- bodies for RACW primitives and stream attributes, if any. + + if Ekind (Spec_Id) = E_Package and then Has_RACW (Spec_Id) then + + -- Attach subprogram bodies to support RACWs declared in spec + + Append_RACW_Bodies (Declarations (N), Spec_Id); + Analyze_List (Declarations (N)); end if; HSS := Handled_Statement_Sequence (N); @@ -630,7 +649,15 @@ package body Sem_Ch7 is procedure Analyze_Package_Declaration (N : Node_Id) is Id : constant Node_Id := Defining_Entity (N); + PF : Boolean; + -- True when in the context of a declared pure library unit + + Body_Required : Boolean; + -- True when this package declaration requires a corresponding body + + Comp_Unit : Boolean; + -- True when this package declaration is not a nested declaration begin -- Ada 2005 (AI-217): Check if the package has been erroneously named @@ -666,18 +693,43 @@ package body Sem_Ch7 is Analyze (Specification (N)); Validate_Categorization_Dependency (N, Id); - End_Package_Scope (Id); - -- For a compilation unit, indicate whether it needs a body, and - -- whether elaboration warnings may be meaningful on it. + Body_Required := Unit_Requires_Body (Id); - if Nkind (Parent (N)) = N_Compilation_Unit then - Set_Body_Required (Parent (N), Unit_Requires_Body (Id)); + -- When this spec does not require an explicit body, we know that + -- there are no entities requiring completion in the language sense; + -- we call Check_Completion here only to ensure that any nested package + -- declaration that requires an implicit body gets one. (In the case + -- where a body is required, Check_Completion is called at the end of + -- the body's declarative part.) - if not Body_Required (Parent (N)) then + if not Body_Required then + Check_Completion; + end if; + + Comp_Unit := Nkind (Parent (N)) = N_Compilation_Unit; + if Comp_Unit then + + -- Set Body_Required indication on the compilation unit node, and + -- determine whether elaboration warnings may be meaningful on it. + + Set_Body_Required (Parent (N), Body_Required); + + if not Body_Required then Set_Suppress_Elaboration_Warnings (Id); end if; + end if; + + End_Package_Scope (Id); + + -- For the declaration of a library unit that is a remote types package, + -- check legality rules regarding availability of stream attributes for + -- types that contain non-remote access values. This subprogram performs + -- visibility tests that rely on the fact that we have exited the scope + -- of Id. + + if Comp_Unit then Validate_RT_RAT_Component (N); end if; end Analyze_Package_Declaration; @@ -719,11 +771,6 @@ package body Sem_Ch7 is -- Child and Unit are entities of compilation units. True if Child -- is a public child of Parent as defined in 10.1.1 - procedure Inspect_Deferred_Constant_Completion; - -- Examines the deferred constants in the private part of the package - -- specification. Emits the error message "constant declaration requires - -- initialization expression " if not completed by an Import pragma. - procedure Inspect_Unchecked_Union_Completion (Decls : List_Id); -- Detects all incomplete or private type declarations having a known -- discriminant part that are completed by an Unchecked_Union. Emits @@ -847,41 +894,6 @@ package body Sem_Ch7 is end if; end Is_Public_Child; - ------------------------------------------ - -- Inspect_Deferred_Constant_Completion -- - ------------------------------------------ - - procedure Inspect_Deferred_Constant_Completion is - Decl : Node_Id; - - begin - Decl := First (Priv_Decls); - while Present (Decl) loop - - -- Deferred constant signature - - if Nkind (Decl) = N_Object_Declaration - and then Constant_Present (Decl) - and then No (Expression (Decl)) - - -- No need to check internally generated constants - - and then Comes_From_Source (Decl) - - -- The constant is not completed. A full object declaration - -- or a pragma Import complete a deferred constant. - - and then not Has_Completion (Defining_Identifier (Decl)) - then - Error_Msg_N - ("constant declaration requires initialization expression", - Defining_Identifier (Decl)); - end if; - - Decl := Next (Decl); - end loop; - end Inspect_Deferred_Constant_Completion; - ---------------------------------------- -- Inspect_Unchecked_Union_Completion -- ---------------------------------------- @@ -1130,7 +1142,7 @@ package body Sem_Ch7 is -- Check the private declarations for incomplete deferred constants - Inspect_Deferred_Constant_Completion; + Inspect_Deferred_Constant_Completion (Priv_Decls); -- The first private entity is the immediate follower of the last -- visible entity, if there was one. @@ -1514,6 +1526,41 @@ package body Sem_Ch7 is Set_Homonym (Full_Id, H2); end Exchange_Declarations; + ------------------------------------------ + -- Inspect_Deferred_Constant_Completion -- + ------------------------------------------ + + procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is + Decl : Node_Id; + + begin + Decl := First (Decls); + while Present (Decl) loop + + -- Deferred constant signature + + if Nkind (Decl) = N_Object_Declaration + and then Constant_Present (Decl) + and then No (Expression (Decl)) + + -- No need to check internally generated constants + + and then Comes_From_Source (Decl) + + -- The constant is not completed. A full object declaration + -- or a pragma Import complete a deferred constant. + + and then not Has_Completion (Defining_Identifier (Decl)) + then + Error_Msg_N + ("constant declaration requires initialization expression", + Defining_Identifier (Decl)); + end if; + + Decl := Next (Decl); + end loop; + end Inspect_Deferred_Constant_Completion; + ---------------------------- -- Install_Package_Entity -- ---------------------------- @@ -1723,7 +1770,7 @@ package body Sem_Ch7 is begin if not Has_Completion (E) and then Nkind (P) = N_Package_Declaration - and then Present (Activation_Chain_Entity (P)) + and then (Present (Activation_Chain_Entity (P)) or else Has_RACW (E)) then B := Make_Package_Body (Sloc (E), @@ -1792,7 +1839,7 @@ package body Sem_Ch7 is Set_Ekind (Id, E_Record_Type_With_Private); Make_Class_Wide_Type (Id); Set_Primitive_Operations (Id, New_Elmt_List); - Set_Is_Abstract (Id, Abstract_Present (Def)); + Set_Is_Abstract_Type (Id, Abstract_Present (Def)); Set_Is_Limited_Record (Id, Limited_Present (Def)); Set_Has_Delayed_Freeze (Id, True); @@ -1828,13 +1875,16 @@ package body Sem_Ch7 is begin Set_Size_Info (Priv, (Full)); - Set_RM_Size (Priv, RM_Size (Full)); - Set_Size_Known_At_Compile_Time (Priv, Size_Known_At_Compile_Time - (Full)); - Set_Is_Volatile (Priv, Is_Volatile (Full)); - Set_Treat_As_Volatile (Priv, Treat_As_Volatile (Full)); - Set_Is_Ada_2005_Only (Priv, Is_Ada_2005_Only (Full)); - + Set_RM_Size (Priv, RM_Size (Full)); + Set_Size_Known_At_Compile_Time + (Priv, Size_Known_At_Compile_Time (Full)); + Set_Is_Volatile (Priv, Is_Volatile (Full)); + Set_Treat_As_Volatile (Priv, Treat_As_Volatile (Full)); + Set_Is_Ada_2005_Only (Priv, Is_Ada_2005_Only (Full)); + Set_Has_Pragma_Unreferenced (Priv, Has_Pragma_Unreferenced (Full)); + Set_Has_Pragma_Unreferenced_Objects + (Priv, Has_Pragma_Unreferenced_Objects + (Full)); if Is_Unchecked_Union (Full) then Set_Is_Unchecked_Union (Base_Type (Priv)); end if; @@ -1892,8 +1942,22 @@ package body Sem_Ch7 is end if; end if; - Set_First_Entity (Priv, First_Entity (Full)); - Set_Last_Entity (Priv, Last_Entity (Full)); + if Is_Tagged_Type (Priv) then + + -- If the type is tagged, the tag itself must be available + -- on the partial view, for expansion purposes. + + Set_First_Entity (Priv, First_Entity (Full)); + + -- If there are discriminants in the partial view, these remain + -- visible. Otherwise only the tag itself is visible, and there + -- are no nameable components in the partial view. + + if No (Last_Entity (Priv)) then + Set_Last_Entity (Priv, First_Entity (Priv)); + end if; + end if; + Set_Has_Discriminants (Priv, Has_Discriminants (Full)); end if; end Preserve_Full_Attributes; @@ -1905,7 +1969,7 @@ package body Sem_Ch7 is function Type_In_Use (T : Entity_Id) return Boolean is begin return Scope (Base_Type (T)) = P - and then (In_Use (T) or else In_Use (Base_Type (T))); + and then (In_Use (T) or else In_Use (Base_Type (T))); end Type_In_Use; -- Start of processing for Uninstall_Declarations @@ -2206,13 +2270,17 @@ package body Sem_Ch7 is then null; - -- Otherwise test to see if entity requires a completion + -- Otherwise test to see if entity requires a completion. + -- Note that subprogram entities whose declaration does not come + -- from source are ignored here on the basis that we assume the + -- expander will provide an implicit completion at some point. elsif (Is_Overloadable (E) and then Ekind (E) /= E_Enumeration_Literal and then Ekind (E) /= E_Operator - and then not Is_Abstract (E) - and then not Has_Completion (E)) + and then not Is_Abstract_Subprogram (E) + and then not Has_Completion (E) + and then Comes_From_Source (Parent (E))) or else (Ekind (E) = E_Package diff --git a/gcc/ada/sem_ch7.ads b/gcc/ada/sem_ch7.ads index 44cca2769b4..7615fb89b81 100644 --- a/gcc/ada/sem_ch7.ads +++ b/gcc/ada/sem_ch7.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, 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- -- @@ -58,9 +58,10 @@ package Sem_Ch7 is -- if it contains declarations that require completion in a body. procedure May_Need_Implicit_Body (E : Entity_Id); - -- If a package declaration contains tasks and does not require a - -- body, create an implicit body at the end of the current declarative - -- part to activate those tasks. + -- If a package declaration contains tasks or RACWs and does not require + -- a body, create an implicit body at the end of the current declarative + -- part to activate those tasks or contain the bodies for the RACW + -- calling stubs. procedure New_Private_Type (N : Node_Id; Id : Entity_Id; Def : Node_Id); -- Common processing for private type declarations and for formal diff --git a/gcc/ada/sem_dist.adb b/gcc/ada/sem_dist.adb index 57998dbc485..9b161a96cfd 100644 --- a/gcc/ada/sem_dist.adb +++ b/gcc/ada/sem_dist.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, 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- -- @@ -116,7 +116,7 @@ package body Sem_Dist is Primitive_Spec : constant Node_Id := Copy_Specification (Loc, Spec => Subp_Spec, - New_Name => Name_Call); + New_Name => Name_uCall); Subtype_Mark_For_Self : Node_Id; @@ -142,9 +142,8 @@ package body Sem_Dist is Subtype_Mark => Subtype_Mark_For_Self))); - -- Trick later semantic analysis into considering this - -- operation as a primitive (dispatching) operation of - -- tagged type Obj_Type. + -- Trick later semantic analysis into considering this operation as a + -- primitive (dispatching) operation of tagged type Obj_Type. Set_Comes_From_Source ( Defining_Unit_Name (Primitive_Spec), True); @@ -398,45 +397,43 @@ package body Sem_Dist is ------------------------------------ procedure Process_Remote_AST_Declaration (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - User_Type : constant Node_Id := Defining_Identifier (N); - Scop : constant Entity_Id := Scope (User_Type); - Is_RCI : constant Boolean := - Is_Remote_Call_Interface (Scop); - Is_RT : constant Boolean := - Is_Remote_Types (Scop); - Type_Def : constant Node_Id := Type_Definition (N); + Loc : constant Source_Ptr := Sloc (N); + User_Type : constant Node_Id := Defining_Identifier (N); + Scop : constant Entity_Id := Scope (User_Type); + Is_RCI : constant Boolean := Is_Remote_Call_Interface (Scop); + Is_RT : constant Boolean := Is_Remote_Types (Scop); + Type_Def : constant Node_Id := Type_Definition (N); + Parameter : Node_Id; - Parameter : Node_Id; - Is_Degenerate : Boolean; + Is_Degenerate : Boolean; -- True iff this RAS has an access formal parameter (see -- Exp_Dist.Add_RAS_Dereference_TSS for details). - Subpkg : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('S')); - Subpkg_Decl : Node_Id; - Vis_Decls : constant List_Id := New_List; - Priv_Decls : constant List_Id := New_List; + Subpkg : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_Internal_Name ('S')); + Subpkg_Decl : Node_Id; + Subpkg_Body : Node_Id; + Vis_Decls : constant List_Id := New_List; + Priv_Decls : constant List_Id := New_List; - Obj_Type : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_External_Name ( - Chars (User_Type), 'R')); + Obj_Type : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (User_Type), 'R')); - Full_Obj_Type : constant Entity_Id := - Make_Defining_Identifier - (Loc, Chars (Obj_Type)); + Full_Obj_Type : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars (Obj_Type)); - RACW_Type : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_External_Name ( - Chars (User_Type), 'P')); + RACW_Type : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (User_Type), 'P')); - Fat_Type : constant Entity_Id := - Make_Defining_Identifier - (Loc, Chars (User_Type)); - Fat_Type_Decl : Node_Id; + Fat_Type : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars (User_Type)); + + Fat_Type_Decl : Node_Id; begin Is_Degenerate := False; @@ -461,6 +458,7 @@ package body Sem_Dist is -- anonymous access type is null, because it cannot be subtype- -- conformant with any legal remote subprogram declaration. In this -- case, we cannot generate a corresponding primitive operation. + end if; if Get_PCS_Name = Name_No_DSA then @@ -493,6 +491,11 @@ package body Sem_Dist is Null_Present => True, Component_List => Empty))); + -- Trick semantic analysis into swapping the public and full view when + -- freezing the public view. + + Set_Comes_From_Source (Full_Obj_Type, True); + if not Is_Degenerate then Append_To (Vis_Decls, Make_Abstract_Subprogram_Declaration (Loc, @@ -531,6 +534,19 @@ package body Sem_Dist is Set_Is_Remote_Types (Subpkg, Is_RT); Insert_After_And_Analyze (N, Subpkg_Decl); + -- Generate package body to receive RACW calling stubs + -- Note: Analyze_Declarations has an absolute requirement that + -- the declaration list be non-empty, so we provide a dummy null + -- statement here. + + Subpkg_Body := + Make_Package_Body (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Chars (Subpkg)), + Declarations => New_List ( + Make_Null_Statement (Loc))); + Insert_After_And_Analyze (Subpkg_Decl, Subpkg_Body); + -- Many parts of the analyzer and expander expect -- that the fat pointer type used to implement remote -- access to subprogram types be a record. @@ -556,7 +572,7 @@ package body Sem_Dist is New_Occurrence_Of (RACW_Type, Loc))))))); Set_Equivalent_Type (User_Type, Fat_Type); Set_Corresponding_Remote_Type (Fat_Type, User_Type); - Insert_After_And_Analyze (Subpkg_Decl, Fat_Type_Decl); + Insert_After_And_Analyze (Subpkg_Body, Fat_Type_Decl); -- The reason we suppress the initialization procedure is that we know -- that no initialization is required (even if Initialize_Scalars mode