OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

sem_ch7.ads, [...] (Inspect_Deferred_Constant_Completion): Move out of Analyze_Package_Declaration...

Browse Source 
2007-04-06  Ed Schonberg  <schonberg@adacore.com>
	    Thomas Quinot  <quinot@adacore.com>

	* sem_ch7.ads, sem_ch7.adb (Inspect_Deferred_Constant_Completion): Move
	out of Analyze_Package_Declaration, because processing must be applied
	to package bodies as well, for deferred constants completed by pragmas.
	(Analyze_Package_Declaration): When the package declaration being
	analyzed does not require an explicit body, call Check_Completion.
	(May_Need_Implicit_Body): An implicit body is required when a package
	spec contains the declaration of a remote access-to-classwide type.
	(Analyze_Package_Body): If the package contains RACWs, append the
	pending subprogram bodies generated by exp_dist at the end of the body.
	(New_Private_Type,Unit_Requires_Body): Split Is_Abstract flag into
	Is_Abstract_Subprogram and Is_Abstract_Type.
	(Preserve_Full_Attributes): The full entity list is not an attribute
	that must be preserved from full to partial view.

        * sem_dist.adb (Add_RAS_Dereference_TSS):
        Change primitive name to _Call so it cannot clash with any legal
        identifier, and be special-cased in Check_Completion.
        Mark the full view of the designated type for the RACW associated with
        a RAS as Comes_From_Source to get proper view switching when installing
        private declarations.
        Provite a placeholder nested package body along with the nested spec
        to have a place for Append_RACW_Bodies to generate the calling stubs
        and stream attributes.

From-SVN: r123596
This commit is contained in:
Ed Schonberg 2007-04-06 11:26:50 +02:00 committed by Arnaud Charlet
parent b6a1a16fbd
commit 13bbad84b1
3 changed files with 201 additions and 116 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

218
gcc/ada/sem_ch7.adb
View File

@ -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

9
gcc/ada/sem_ch7.ads
View File

@ -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

90
gcc/ada/sem_dist.adb
View File

@ -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