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

sem_ch3.adb (Access_Subprogram_Definition): Additional checks on illegal uses of incomplete types in formal parts and...

Browse Source 
2009-04-17  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb (Access_Subprogram_Definition): Additional checks on
	illegal uses of incomplete types in formal parts and return types.

	* sem_ch6.adb (Process_Formals): Taft-amendment types are legal in
	access to subprograms.

	* sem_ch7.adb (Uninstall_Declarations): diagnose attempts to use
	Taft-amendment types as the return type of an access_to_function type.

	* freeze.adb (Freeze_Entity): Remove tests on formals of an incomplete
	type for access_to_subprograms. The check is performed on package exit.

From-SVN: r146229
This commit is contained in:
Ed Schonberg 2009-04-17 11:36:05 +02:00 committed by Arnaud Charlet
parent 618fb570b9
commit cec2913559
4 changed files with 202 additions and 206 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
gcc/ada/freeze.adb
View File

@ -3497,50 +3497,11 @@ package body Freeze is
Freeze_Subprogram (E);
-- Ada 2005 (AI-326): Check wrong use of tag incomplete type
-- type T; -- tagged or untagged, may be from limited view
-- type Acc is access function (X : T) return T; -- ERROR
if Ekind (Etype (E)) = E_Incomplete_Type
and then No (Full_View (Etype (E)))
and then not Is_Value_Type (Etype (E))
then
Error_Msg_NE
("invalid use of incomplete type&", E, Etype (E));
end if;
-- For access to a protected subprogram, freeze the equivalent type
-- (however this is not set if we are not generating code or if this
-- is an anonymous type used just for resolution).
elsif Is_Access_Protected_Subprogram_Type (E) then
-- AI-326: Check wrong use of tagged incomplete types
-- type T is tagged;
-- type As3D is access protected
-- function (X : Float) return T; -- ERROR
declare
Etyp : Entity_Id;
begin
Etyp := Etype (Directly_Designated_Type (E));
if Is_Class_Wide_Type (Etyp) then
Etyp := Etype (Etyp);
end if;
if Ekind (Etyp) = E_Incomplete_Type
and then No (Full_View (Etyp))
and then not Is_Value_Type (Etype (E))
then
Error_Msg_NE
("invalid use of incomplete type&", E, Etyp);
end if;
end;
if Present (Equivalent_Type (E)) then
Freeze_And_Append (Equivalent_Type (E), Loc, Result);
end if;

20
gcc/ada/sem_ch3.adb
View File

@ -1135,7 +1135,27 @@ package body Sem_Ch3 is
(T => Typ,
Related_Nod => T_Def,
Scope_Id => Current_Scope));
else
if From_With_Type (Typ) then
Error_Msg_NE
("illegal use of incomplete type&",
Result_Definition (T_Def), Typ);
elsif Ekind (Current_Scope) = E_Package
and then In_Private_Part (Current_Scope)
then
if Ekind (Typ) = E_Incomplete_Type then
Append_Elmt (Desig_Type, Private_Dependents (Typ));
elsif Is_Class_Wide_Type (Typ)
and then Ekind (Etype (Typ)) = E_Incomplete_Type
then
Append_Elmt
(Desig_Type, Private_Dependents (Etype (Typ)));
end if;
end if;
Set_Etype (Desig_Type, Typ);
end if;
end;

14
gcc/ada/sem_ch6.adb
View File

@ -7716,7 +7716,8 @@ package body Sem_Ch6 is
-- primitive operations, as long as their completion is
-- in the same declarative part. If in the private part
-- this means that the type cannot be a Taft-amendment type.
-- Check is done on package exit.
-- Check is done on package exit. For access to subprograms,
-- the use is legal for Taft-amendment types.
if Is_Tagged_Type (Formal_Type) then
if Ekind (Scope (Current_Scope)) = E_Package
@ -7724,9 +7725,14 @@ package body Sem_Ch6 is
and then not From_With_Type (Formal_Type)
and then not Is_Class_Wide_Type (Formal_Type)
then
Append_Elmt
(Current_Scope,
Private_Dependents (Base_Type (Formal_Type)));
if not Nkind_In
(Parent (T), N_Access_Function_Definition,
N_Access_Procedure_Definition)
then
Append_Elmt
(Current_Scope,
Private_Dependents (Base_Type (Formal_Type)));
end if;
end if;
-- Special handling of Value_Type for CIL case

335
gcc/ada/sem_ch7.adb
View File

@ -25,8 +25,8 @@
-- This package contains the routines to process package specifications and
-- bodies. The most important semantic aspects of package processing are the
-- handling of private and full declarations, and the construction of
-- dispatch tables for tagged types.
-- handling of private and full declarations, and the construction of dispatch
-- tables for tagged types.
with Atree; use Atree;
with Debug; use Debug;
@ -102,9 +102,9 @@ package body Sem_Ch7 is
-- before other body declarations.
procedure Install_Package_Entity (Id : Entity_Id);
-- 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.
-- 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
@ -144,10 +144,10 @@ package body Sem_Ch7 is
Pack_Decl : Node_Id;
procedure Install_Composite_Operations (P : Entity_Id);
-- Composite types declared in the current scope may depend on
-- types that were private at the point of declaration, and whose
-- full view is now in scope. Indicate that the corresponding
-- operations on the composite type are available.
-- Composite types declared in the current scope may depend on types
-- that were private at the point of declaration, and whose full view
-- is now in scope. Indicate that the corresponding operations on the
-- composite type are available.
----------------------------------
-- Install_Composite_Operations --
@ -175,12 +175,12 @@ package body Sem_Ch7 is
-- Start of processing for Analyze_Package_Body
begin
-- Find corresponding package specification, and establish the
-- current scope. The visible defining entity for the package is the
-- defining occurrence in the spec. On exit from the package body, all
-- body declarations are attached to the defining entity for the body,
-- but the later is never used for name resolution. In this fashion
-- there is only one visible entity that denotes the package.
-- Find corresponding package specification, and establish the current
-- scope. The visible defining entity for the package is the defining
-- occurrence in the spec. On exit from the package body, all body
-- declarations are attached to the defining entity for the body, but
-- the later is never used for name resolution. In this fashion there
-- is only one visible entity that denotes the package.
if Debug_Flag_C then
Write_Str ("==== Compiling package body ");
@ -190,15 +190,15 @@ package body Sem_Ch7 is
Write_Eol;
end if;
-- Set Body_Id. Note that this Will be reset to point to the
-- generic copy later on in the generic case.
-- Set Body_Id. Note that this Will be reset to point to the generic
-- copy later on in the generic case.
Body_Id := Defining_Entity (N);
if Present (Corresponding_Spec (N)) then
-- Body is body of package instantiation. Corresponding spec
-- has already been set.
-- Body is body of package instantiation. Corresponding spec has
-- already been set.
Spec_Id := Corresponding_Spec (N);
Pack_Decl := Unit_Declaration_Node (Spec_Id);
@ -257,8 +257,8 @@ package body Sem_Ch7 is
if Ekind (Spec_Id) = E_Generic_Package then
-- Disable expansion and perform semantic analysis on copy.
-- The unannotated body will be used in all instantiations.
-- Disable expansion and perform semantic analysis on copy. The
-- unannotated body will be used in all instantiations.
Body_Id := Defining_Entity (N);
Set_Ekind (Body_Id, E_Package_Body);
@ -270,23 +270,23 @@ package body Sem_Ch7 is
New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
Rewrite (N, New_N);
-- Update Body_Id to point to the copied node for the remainder
-- of the processing.
-- Update Body_Id to point to the copied node for the remainder of
-- the processing.
Body_Id := Defining_Entity (N);
Start_Generic;
end if;
-- The Body_Id is that of the copied node in the generic case, the
-- current node otherwise. Note that N was rewritten above, so we
-- must be sure to get the latest Body_Id value.
-- current node otherwise. Note that N was rewritten above, so we must
-- be sure to get the latest Body_Id value.
Set_Ekind (Body_Id, E_Package_Body);
Set_Body_Entity (Spec_Id, Body_Id);
Set_Spec_Entity (Body_Id, Spec_Id);
-- Defining name for the package body is not a visible entity: Only
-- the defining name for the declaration is visible.
-- Defining name for the package body is not a visible entity: Only the
-- defining name for the declaration is visible.
Set_Etype (Body_Id, Standard_Void_Type);
Set_Scope (Body_Id, Scope (Spec_Id));
@ -340,7 +340,7 @@ package body Sem_Ch7 is
Inspect_Deferred_Constant_Completion (Declarations (N));
end if;
-- Analyze_Declarations has caused freezing of all types; now generate
-- 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
@ -416,9 +416,8 @@ package body Sem_Ch7 is
Set_Is_Potentially_Use_Visible (E, False);
Set_Is_Hidden (E);
-- Child units may appear on the entity list (for example if
-- they appear in the context of a subunit) but they are not
-- body entities.
-- Child units may appear on the entity list (e.g. if they appear
-- in the context of a subunit) but they are not body entities.
if not Is_Child_Unit (E) then
Set_Is_Package_Body_Entity (E);
@ -444,9 +443,9 @@ package body Sem_Ch7 is
-- following loop runs backwards from the end of the entities of the
-- package body making these entities invisible until we reach a
-- referencer, i.e. a declaration that could reference a previous
-- declaration, a generic body or an inlined body, or a stub (which
-- may contain either of these). This is of course an approximation,
-- but it is conservative and definitely correct.
-- declaration, a generic body or an inlined body, or a stub (which may
-- contain either of these). This is of course an approximation, but it
-- is conservative and definitely correct.
-- We only do this at the outer (library) level non-generic packages.
-- The reason is simply to cut down on the number of external symbols
@ -464,16 +463,15 @@ package body Sem_Ch7 is
Outer : Boolean)
return Boolean;
-- Traverse the given list of declarations in reverse order.
-- Return True as soon as a referencer is reached. Return
-- False if none is found. The Outer parameter is True for
-- the outer level call, and False for inner level calls for
-- nested packages. If Outer is True, then any entities up
-- to the point of hitting a referencer get their Is_Public
-- flag cleared, so that the entities will be treated as
-- static entities in the C sense, and need not have fully
-- qualified names. For inner levels, we need all names to
-- be fully qualified to deal with the same name appearing
-- in parallel packages (right now this is tied to their
-- Return True as soon as a referencer is reached. Return False if
-- none is found. The Outer parameter is True for the outer level
-- call, and False for inner level calls for nested packages. If
-- Outer is True, then any entities up to the point of hitting a
-- referencer get their Is_Public flag cleared, so that the
-- entities will be treated as static entities in the C sense, and
-- need not have fully qualified names. For inner levels, we need
-- all names to be fully qualified to deal with the same name
-- appearing in parallel packages (right now this is tied to their
-- being external).
--------------------
@ -512,10 +510,10 @@ package body Sem_Ch7 is
-- Note that we test Has_Pragma_Inline here rather
-- than Is_Inlined. We are compiling this for a
-- client, and it is the client who will decide
-- if actual inlining should occur, so we need to
-- assume that the procedure could be inlined for
-- the purpose of accessing global entities.
-- client, and it is the client who will decide if
-- actual inlining should occur, so we need to assume
-- that the procedure could be inlined for the purpose
-- of accessing global entities.
if Has_Pragma_Inline (E) then
return True;
@ -542,20 +540,19 @@ package body Sem_Ch7 is
then
E := Corresponding_Spec (D);
-- Generic package body is a referencer. It would
-- seem that we only have to consider generics that
-- can be exported, i.e. where the corresponding spec
-- is the spec of the current package, but because of
-- nested instantiations, a fully private generic
-- body may export other private body entities.
-- Generic package body is a referencer. It would seem
-- that we only have to consider generics that can be
-- exported, i.e. where the corresponding spec is the
-- spec of the current package, but because of nested
-- instantiations, a fully private generic body may
-- export other private body entities.
if Is_Generic_Unit (E) then
return True;
-- For non-generic package body, recurse into body
-- unless this is an instance, we ignore instances
-- since they cannot have references that affect
-- outer entities.
-- For non-generic package body, recurse into body unless
-- this is an instance, we ignore instances since they
-- cannot have references that affect outer entities.
elsif not Is_Generic_Instance (E) then
if Has_Referencer
@ -583,10 +580,10 @@ package body Sem_Ch7 is
end if;
end if;
-- Objects and exceptions need not be public if we have
-- not encountered a referencer so far. We only reset
-- the flag for outer level entities that are not
-- imported/exported, and which have no interface name.
-- Objects and exceptions need not be public if we have not
-- encountered a referencer so far. We only reset the flag
-- for outer level entities that are not imported/exported,
-- and which have no interface name.
elsif Nkind_In (K, N_Object_Declaration,
N_Exception_Declaration,
@ -623,10 +620,10 @@ package body Sem_Ch7 is
end if;
-- If expander is not active, then here is where we turn off the
-- In_Package_Body flag, otherwise it is turned off at the end of
-- the corresponding expansion routine. If this is an instance body,
-- we need to qualify names of local entities, because the body may
-- have been compiled as a preliminary to another instantiation.
-- In_Package_Body flag, otherwise it is turned off at the end of the
-- corresponding expansion routine. If this is an instance body, we need
-- to qualify names of local entities, because the body may have been
-- compiled as a preliminary to another instantiation.
if not Expander_Active then
Set_In_Package_Body (Spec_Id, False);
@ -692,9 +689,9 @@ package body Sem_Ch7 is
Body_Required := 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
-- 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.)
@ -734,8 +731,8 @@ package body Sem_Ch7 is
-- Analyze_Package_Specification --
-----------------------------------
-- Note that this code is shared for the analysis of generic package
-- specs (see Sem_Ch12.Analyze_Generic_Package_Declaration for details).
-- Note that this code is shared for the analysis of generic package specs
-- (see Sem_Ch12.Analyze_Generic_Package_Declaration for details).
procedure Analyze_Package_Specification (N : Node_Id) is
Id : constant Entity_Id := Defining_Entity (N);
@ -760,10 +757,10 @@ package body Sem_Ch7 is
-- visibility analysis for preconditions and postconditions in specs.
procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id);
-- Clears constant indications (Never_Set_In_Source, Constant_Value,
-- and Is_True_Constant) on all variables that are entities of Id,
-- and on the chain whose first element is FE. A recursive call is
-- made for all packages and generic packages.
-- Clears constant indications (Never_Set_In_Source, Constant_Value, and
-- Is_True_Constant) on all variables that are entities of Id, and on
-- the chain whose first element is FE. A recursive call is made for all
-- packages and generic packages.
procedure Generate_Parent_References;
-- For a child unit, generate references to parent units, for
@ -822,18 +819,17 @@ package body Sem_Ch7 is
E : Entity_Id;
begin
-- Ignore package renamings, not interesting and they can
-- cause self referential loops in the code below.
-- Ignore package renamings, not interesting and they can cause self
-- referential loops in the code below.
if Nkind (Parent (Id)) = N_Package_Renaming_Declaration then
return;
end if;
-- Note: in the loop below, the check for Next_Entity pointing
-- back to the package entity may seem odd, but it is needed,
-- because a package can contain a renaming declaration to itself,
-- and such renamings are generated automatically within package
-- instances.
-- Note: in the loop below, the check for Next_Entity pointing back
-- to the package entity may seem odd, but it is needed, because a
-- package can contain a renaming declaration to itself, and such
-- renamings are generated automatically within package instances.
E := FE;
while Present (E) and then E /= Id loop
@ -873,8 +869,8 @@ package body Sem_Ch7 is
elsif not Nkind_In (Unit (Cunit (Main_Unit)), N_Subprogram_Body,
N_Subunit)
then
-- If current unit is an ancestor of main unit, generate
-- a reference to its own parent.
-- If current unit is an ancestor of main unit, generate a
-- reference to its own parent.
declare
U : Node_Id;
@ -1065,11 +1061,11 @@ package body Sem_Ch7 is
Validate_RCI_Declarations (Id);
end if;
-- Save global references in the visible declarations, before
-- installing private declarations of parent unit if there is one,
-- because the privacy status of types defined in the parent will
-- change. This is only relevant for generic child units, but is
-- done in all cases for uniformity.
-- Save global references in the visible declarations, before installing
-- private declarations of parent unit if there is one, because the
-- privacy status of types defined in the parent will change. This is
-- only relevant for generic child units, but is done in all cases for
-- uniformity.
if Ekind (Id) = E_Generic_Package
and then Nkind (Orig_Decl) = N_Generic_Package_Declaration
@ -1360,8 +1356,8 @@ package body Sem_Ch7 is
procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id) is
function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean;
-- Check whether an inherited subprogram is an operation of an
-- untagged derived type.
-- Check whether an inherited subprogram is an operation of an untagged
-- derived type.
---------------------
-- Is_Primitive_Of --
@ -1371,9 +1367,9 @@ package body Sem_Ch7 is
Formal : Entity_Id;
begin
-- If the full view is a scalar type, the type is the anonymous
-- base type, but the operation mentions the first subtype, so
-- check the signature against the base type.
-- If the full view is a scalar type, the type is the anonymous base
-- type, but the operation mentions the first subtype, so check the
-- signature against the base type.
if Base_Type (Etype (S)) = Base_Type (T) then
return True;
@ -1409,10 +1405,10 @@ package body Sem_Ch7 is
E := First_Entity (Id);
while Present (E) loop
-- If the entity is a nonprivate type extension whose parent
-- type is declared in an open scope, then the type may have
-- inherited operations that now need to be made visible.
-- Ditto if the entity is a formal derived type in a child unit.
-- If the entity is a nonprivate type extension whose parent type
-- is declared in an open scope, then the type may have inherited
-- operations that now need to be made visible. Ditto if the entity
-- is a formal derived type in a child unit.
if ((Is_Derived_Type (E) and then not Is_Private_Type (E))
or else
@ -1498,16 +1494,15 @@ package body Sem_Ch7 is
(Is_Dispatching_Operation (New_Op)
and then Node (Last_Elmt (Op_List)) = New_Op);
-- Substitute the new operation for the old one
-- in the type's primitive operations list. Since
-- the new operation was also just added to the end
-- of list, the last element must be removed.
-- Substitute the new operation for the old one in the
-- type's primitive operations list. Since the new
-- operation was also just added to the end of list,
-- the last element must be removed.
-- (Question: is there a simpler way of declaring
-- the operation, say by just replacing the name
-- of the earlier operation, reentering it in the
-- in the symbol table (how?), and marking it as
-- private???)
-- (Question: is there a simpler way of declaring the
-- operation, say by just replacing the name of the
-- earlier operation, reentering it in the in the symbol
-- table (how?), and marking it as private???)
Replace_Elmt (Op_Elmt, New_Op);
Remove_Last_Elmt (Op_List);
@ -1524,8 +1519,8 @@ package body Sem_Ch7 is
end if;
else
-- Non-tagged type, scan forward to locate
-- inherited hidden operations.
-- Non-tagged type, scan forward to locate inherited hidden
-- operations.
Prim_Op := Next_Entity (E);
while Present (Prim_Op) loop
@ -1581,8 +1576,8 @@ package body Sem_Ch7 is
Next2 := Next_Entity (Full_Id);
H2 := Homonym (Full_Id);
-- Reset full declaration pointer to reflect the switched entities
-- and readjust the next entity chains.
-- Reset full declaration pointer to reflect the switched entities and
-- readjust the next entity chains.
Exchange_Entities (Id, Full_Id);
@ -1625,13 +1620,13 @@ package body Sem_Ch7 is
Full : Entity_Id;
begin
-- First exchange declarations for private types, so that the
-- full declaration is visible. For each private type, we check
-- its Private_Dependents list and also exchange any subtypes of
-- or derived types from it. Finally, if this is a Taft amendment
-- type, the incomplete declaration is irrelevant, and we want to
-- link the eventual full declaration with the original private
-- one so we also skip the exchange.
-- First exchange declarations for private types, so that the full
-- declaration is visible. For each private type, we check its
-- Private_Dependents list and also exchange any subtypes of or derived
-- types from it. Finally, if this is a Taft amendment type, the
-- incomplete declaration is irrelevant, and we want to link the
-- eventual full declaration with the original private one so we also
-- skip the exchange.
Id := First_Entity (P);
while Present (Id) and then Id /= First_Private_Entity (P) loop
@ -1659,12 +1654,12 @@ package body Sem_Ch7 is
-- can only happen in a package nested within a child package,
-- when the parent type is defined in the parent unit. At this
-- point the current type is not private either, and we have to
-- install the underlying full view, which is now visible.
-- Save the current full view as well, so that all views can
-- be restored on exit. It may seem that after compiling the
-- child body there are not environments to restore, but the
-- back-end expects those links to be valid, and freeze nodes
-- depend on them.
-- install the underlying full view, which is now visible. Save
-- the current full view as well, so that all views can be
-- restored on exit. It may seem that after compiling the child
-- body there are not environments to restore, but the back-end
-- expects those links to be valid, and freeze nodes depend on
-- them.
if No (Full_View (Full))
and then Present (Underlying_Full_View (Full))
@ -1686,8 +1681,8 @@ package body Sem_Ch7 is
Priv := Node (Priv_Elmt);
-- Before the exchange, verify that the presence of the
-- Full_View field. It will be empty if the entity
-- has already been installed due to a previous call.
-- Full_View field. It will be empty if the entity has already
-- been installed due to a previous call.
if Present (Full_View (Priv))
and then Is_Visible_Dependent (Priv)
@ -1772,8 +1767,7 @@ package body Sem_Ch7 is
S : constant Entity_Id := Scope (Dep);
begin
-- Renamings created for actual types have the visibility of the
-- actual.
-- Renamings created for actual types have the visibility of the actual
if Ekind (S) = E_Package
and then Is_Generic_Instance (S)
@ -1785,9 +1779,9 @@ package body Sem_Ch7 is
elsif not (Is_Derived_Type (Dep))
and then Is_Derived_Type (Full_View (Dep))
then
-- When instantiating a package body, the scope stack is empty,
-- so check instead whether the dependent type is defined in
-- the same scope as the instance itself.
-- When instantiating a package body, the scope stack is empty, so
-- check instead whether the dependent type is defined in the same
-- scope as the instance itself.
return In_Open_Scopes (S)
or else (Is_Generic_Instance (Current_Scope)
@ -1856,8 +1850,8 @@ package body Sem_Ch7 is
No (Discriminant_Specifications (N))
and then not Unknown_Discriminants_Present (N));
-- Set tagged flag before processing discriminants, to catch
-- illegal usage.
-- Set tagged flag before processing discriminants, to catch illegal
-- usage.
Set_Is_Tagged_Type (Id, Tagged_Present (Def));
@ -1900,8 +1894,8 @@ package body Sem_Ch7 is
Priv_Sub : Entity_Id;
procedure Preserve_Full_Attributes (Priv, Full : Entity_Id);
-- Copy to the private declaration the attributes of the full view
-- that need to be available for the partial view also.
-- Copy to the private declaration the attributes of the full view that
-- need to be available for the partial view also.
function Type_In_Use (T : Entity_Id) return Boolean;
-- Check whether type or base type appear in an active use_type clause
@ -1951,8 +1945,8 @@ package body Sem_Ch7 is
then
if Priv_Is_Base_Type then
-- Ada 2005 (AI-345): The full view of a type implementing
-- an interface can be a task type.
-- Ada 2005 (AI-345): The full view of a type implementing an
-- interface can be a task type.
-- type T is new I with private;
-- private
@ -1984,8 +1978,8 @@ package body Sem_Ch7 is
if Is_Tagged_Type (Priv) then
-- If the type is tagged, the tag itself must be available
-- on the partial view, for expansion purposes.
-- 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));
@ -2156,8 +2150,8 @@ package body Sem_Ch7 is
end if;
-- Make private entities invisible and exchange full and private
-- declarations for private types. Id is now the first private
-- entity in the package.
-- declarations for private types. Id is now the first private entity
-- in the package.
while Present (Id) loop
if Debug_Flag_E then
@ -2178,10 +2172,10 @@ package body Sem_Ch7 is
then
Full := Full_View (Id);
-- If the partial view is not declared in the visible part
-- of the package (as is the case when it is a type derived
-- from some other private type in the private part of the
-- current package), no exchange takes place.
-- If the partial view is not declared in the visible part of the
-- package (as is the case when it is a type derived from some
-- other private type in the private part of the current package),
-- no exchange takes place.
if No (Parent (Id))
or else List_Containing (Parent (Id))
@ -2192,10 +2186,10 @@ package body Sem_Ch7 is
-- The entry in the private part points to the full declaration,
-- which is currently visible. Exchange them so only the private
-- type declaration remains accessible, and link private and
-- full declaration in the opposite direction. Before the actual
-- exchange, we copy back attributes of the full view that
-- must be available to the partial view too.
-- type declaration remains accessible, and link private and full
-- declaration in the opposite direction. Before the actual
-- exchange, we copy back attributes of the full view that must
-- be available to the partial view too.
Preserve_Full_Attributes (Id, Full);
@ -2213,10 +2207,10 @@ package body Sem_Ch7 is
-- Swap out the subtypes and derived types of Id that were
-- compiled in this scope, or installed previously by
-- Install_Private_Declarations.
-- Before we do the swap, we verify the presence of the
-- Full_View field which may be empty due to a swap by
-- a previous call to End_Package_Scope (e.g. from the
-- freezing mechanism).
-- Before we do the swap, we verify the presence of the Full_View
-- field which may be empty due to a swap by a previous call to
-- End_Package_Scope (e.g. from the freezing mechanism).
while Present (Priv_Elmt) loop
Priv_Sub := Node (Priv_Elmt);
@ -2244,10 +2238,11 @@ package body Sem_Ch7 is
Exchange_Declarations (Id);
-- If we have installed an underlying full view for a type
-- derived from a private type in a child unit, restore the
-- proper views of private and full view. See corresponding
-- code in Install_Private_Declarations.
-- If we have installed an underlying full view for a type derived
-- from a private type in a child unit, restore the proper views
-- of private and full view. See corresponding code in
-- Install_Private_Declarations.
-- After the exchange, Full denotes the private type in the
-- visible part of the package.
@ -2264,9 +2259,8 @@ package body Sem_Ch7 is
and then Comes_From_Source (Id)
and then No (Full_View (Id))
then
-- Mark Taft amendment types. Verify that there are no
-- primitive operations declared for the type (3.10.1 (9)).
-- Mark Taft amendment types. Verify that there are no primitive
-- operations declared for the type (3.10.1 (9)).
Set_Has_Completion_In_Body (Id);
@ -2278,10 +2272,25 @@ package body Sem_Ch7 is
Elmt := First_Elmt (Private_Dependents (Id));
while Present (Elmt) loop
Subp := Node (Elmt);
if Is_Overloadable (Subp) then
Error_Msg_NE
("type& must be completed in the private part",
Parent (Subp), Id);
-- The return type of an access_to_function cannot be a
-- Taft-amendment type.
elsif Ekind (Subp) = E_Subprogram_Type then
if Etype (Subp) = Id
or else
(Is_Class_Wide_Type (Etype (Subp))
and then Etype (Etype (Subp)) = Id)
then
Error_Msg_NE
("type& must be completed in the private part",
Associated_Node_For_Itype (Subp), Id);
end if;
end if;
Next_Elmt (Elmt);
@ -2309,9 +2318,9 @@ package body Sem_Ch7 is
E : Entity_Id;
begin
-- Imported entity never requires body. Right now, only
-- subprograms can be imported, but perhaps in the future
-- we will allow import of packages.
-- Imported entity never requires body. Right now, only subprograms can
-- be imported, but perhaps in the future we will allow import of
-- packages.
if Is_Imported (P) then
return False;