procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

2008-05-20 Javier Miranda <miranda@adacore.com>

Browse source 
Ed Schonberg  <schonberg@adacore.com>
	    Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_ch3.adb
	(Analyze_Object_Declaration): Fix over-conservative condition
	restricting use of predefined assignment with tagged types that have
	convention CPP.
	(Analyze_Object_Declaration): Relax the check regarding deferred
	constants declared in scopes other than packages since they can be
	completed with pragma Import.
	Add missing escaping of all-caps word 'CPP' in error messages.
	(Build_Discriminated_Subtype): Do not inherit representation clauses
	from parent type if subtype already carries them, because they are
	inherited earlier during derivation and already include those that may
	come from a partial view.

	* sem_ch9.adb, sem_ch5.adb, sem_ch6.adb (Analyze_Subprogram_Body):
	Check the declarations of a subprogram body for proper deferred
	constant completion.

	* sem_ch7.ads, sem_ch7.adb
	(Inspect_Deferred_Constant_Completion): Moved to sem_util.

From-SVN: r135638
This commit is contained in:
Javier Miranda 2008-05-20 14:50:03 +02:00 • committed by Arnaud Charlet
parent de5cd98e3b
commit 3393111257
6 changed files with 116 additions and 95 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

159
gcc/ada/sem_ch3.adb
View file

@ -2404,16 +2404,34 @@ package body Sem_Ch3 is
if Is_Imported (Defining_Identifier (N))
and then
(T = RTE (RE_Tag)
or else (Present (Full_View (T))
and then Full_View (T) = RTE (RE_Tag)))
(T = RTE (RE_Tag)
or else
(Present (Full_View (T))
and then Full_View (T) = RTE (RE_Tag)))
then
null;
elsif not Is_Package_Or_Generic_Package (Current_Scope) then
-- A deferred constant may appear in the declarative part of the
-- following constructs:
-- blocks
-- entry bodies
-- extended return statements
-- package specs
-- package bodies
-- subprogram bodies
-- task bodies
-- When declared inside a package spec, a deferred constant must be
-- completed by a full constant declaration or pragma Import. In all
-- other cases, the only proper completion is pragma Import. Extended
-- return statements are flagged as invalid contexts because they do
-- not have a declarative part and so cannot accommodate the pragma.
elsif Ekind (Current_Scope) = E_Return_Statement then
Error_Msg_N
("invalid context for deferred constant declaration (RM 7.4)",
N);
N);
Error_Msg_N
("\declaration requires an initialization expression",
N);
@ -2482,10 +2500,16 @@ package body Sem_Ch3 is
-- (primitive that is not available in CPP tagged types).
if Is_Class_Wide_Type (Act_T)
and then Convention (Act_T) = Convention_CPP
and then
(Is_CPP_Class (Root_Type (Etype (Act_T)))
or else
(Present (Full_View (Root_Type (Etype (Act_T))))
and then
Is_CPP_Class (Full_View (Root_Type (Etype (Act_T))))))
then
Error_Msg_N
("predefined assignment not available in CPP tagged types", E);
("predefined assignment not available for 'C'P'P tagged types",
E);
end if;
Mark_Coextensions (N, E);
@ -3844,8 +3868,9 @@ package body Sem_Ch3 is
Validate_Access_Type_Declaration (T, N);
-- If we are in a Remote_Call_Interface package and define
-- a RACW, Read and Write attribute must be added.
-- If we are in a Remote_Call_Interface package and define a
-- RACW, then calling stubs and specific stream attributes
-- must be added.
if Is_Remote
and then Is_Remote_Access_To_Class_Wide_Type (Def_Id)
@ -3908,10 +3933,10 @@ package body Sem_Ch3 is
B : constant Entity_Id := Base_Type (T);
begin
-- In the case where the base type is different from the first
-- subtype, we pre-allocate a freeze node, and set the proper link
-- to the first subtype. Freeze_Entity will use this preallocated
-- freeze node when it freezes the entity.
-- In the case where the base type differs from the first subtype, we
-- pre-allocate a freeze node, and set the proper link to the first
-- subtype. Freeze_Entity will use this preallocated freeze node when
-- it freezes the entity.
if B /= T then
Ensure_Freeze_Node (B);
@ -3929,11 +3954,11 @@ package body Sem_Ch3 is
if T /= Def_Id and then Is_Private_Type (Def_Id) then
Process_Full_View (N, T, Def_Id);
-- Record the reference. The form of this is a little strange,
-- since the full declaration has been swapped in. So the first
-- parameter here represents the entity to which a reference is
-- made which is the "real" entity, i.e. the one swapped in,
-- and the second parameter provides the reference location.
-- Record the reference. The form of this is a little strange, since
-- the full declaration has been swapped in. So the first parameter
-- here represents the entity to which a reference is made which is
-- the "real" entity, i.e. the one swapped in, and the second
-- parameter provides the reference location.
-- Also, we want to kill Has_Pragma_Unreferenced temporarily here
-- since we don't want a complaint about the full type being an
@ -3985,12 +4010,12 @@ package body Sem_Ch3 is
procedure Analyze_Variant_Part (N : Node_Id) is
procedure Non_Static_Choice_Error (Choice : Node_Id);
-- Error routine invoked by the generic instantiation below when
-- the variant part has a non static choice.
-- Error routine invoked by the generic instantiation below when the
-- variant part has a non static choice.
procedure Process_Declarations (Variant : Node_Id);
-- Analyzes all the declarations associated with a Variant.
-- Needed by the generic instantiation below.
-- Analyzes all the declarations associated with a Variant. Needed by
-- the generic instantiation below.
package Variant_Choices_Processing is new
Generic_Choices_Processing
@ -4097,9 +4122,9 @@ package body Sem_Ch3 is
Index := First (Subtype_Marks (Def));
end if;
-- Find proper names for the implicit types which may be public.
-- in case of anonymous arrays we use the name of the first object
-- of that type as prefix.
-- Find proper names for the implicit types which may be public. In case
-- of anonymous arrays we use the name of the first object of that type
-- as prefix.
if No (T) then
Related_Id := Defining_Identifier (P);
@ -4120,9 +4145,9 @@ package body Sem_Ch3 is
-- type Table is array (Index) of ...
-- end;
-- This is currently required by the expander to generate the
-- internally generated equality subprogram of records with variant
-- parts in which the etype of some component is such private type.
-- This is currently required by the expander for the internally
-- generated equality subprogram of records with variant parts in
-- which the etype of some component is such private type.
if Ekind (Current_Scope) = E_Package
and then In_Private_Part (Current_Scope)
@ -4195,9 +4220,9 @@ package body Sem_Ch3 is
Set_Parent (Element_Type, Parent (T));
-- Ada 2005 (AI-230): In case of components that are anonymous
-- access types the level of accessibility depends on the enclosing
-- type declaration
-- Ada 2005 (AI-230): In case of components that are anonymous access
-- types the level of accessibility depends on the enclosing type
-- declaration
Set_Scope (Element_Type, Current_Scope); -- Ada 2005 (AI-230)
@ -4296,8 +4321,8 @@ package body Sem_Ch3 is
if Null_Exclusion_Present (Component_Definition (Def))
-- No need to check itypes because in their case this check
-- was done at their point of creation
-- No need to check itypes because in their case this check was
-- done at their point of creation
and then not Is_Itype (Element_Type)
then
@ -4331,8 +4356,8 @@ package body Sem_Ch3 is
end if;
end if;
-- A syntax error in the declaration itself may lead to an empty
-- index list, in which case do a minimal patch.
-- A syntax error in the declaration itself may lead to an empty index
-- list, in which case do a minimal patch.
if No (First_Index (T)) then
Error_Msg_N ("missing index definition in array type declaration", T);
@ -7631,7 +7656,16 @@ package body Sem_Ch3 is
Set_First_Entity (Def_Id, First_Entity (T));
Set_Last_Entity (Def_Id, Last_Entity (T));
Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
-- If the subtype is the completion of a private declaration, there may
-- have been representation clauses for the partial view, and they must
-- be preserved. Build_Derived_Type chains the inherited clauses with
-- the ones appearing on the extension. If this comes from a subtype
-- declaration, all clauses are inherited.
if No (First_Rep_Item (Def_Id)) then
Set_First_Rep_Item (Def_Id, First_Rep_Item (T));
end if;
if Is_Tagged_Type (T) then
Set_Is_Tagged_Type (Def_Id);
@ -9922,7 +9956,7 @@ package body Sem_Ch3 is
-- discriminant is declared in the private entity.
or else (Is_Private_Type (Typ)
and then Chars (Discrim_Scope) = Chars (Typ))
and then Chars (Discrim_Scope) = Chars (Typ))
-- Or we are constrained the corresponding record of a
-- synchronized type that completes a private declaration.
@ -9935,7 +9969,7 @@ package body Sem_Ch3 is
-- discriminant found belongs to the root type.
or else (Is_Class_Wide_Type (Typ)
and then Etype (Typ) = Discrim_Scope));
and then Etype (Typ) = Discrim_Scope));
return True;
end if;
@ -12892,6 +12926,31 @@ package body Sem_Ch3 is
New_Id : Entity_Id;
Prev_Par : Node_Id;
procedure Tag_Mismatch;
-- Diagnose a tagged partial view whose full view is untagged;
-- We post the message on the full view, with a reference to
-- the previous partial view. The partial view can be private
-- or incomplete, and these are handled in a different manner,
-- so we determine the position of the error message from the
-- respective slocs of both.
------------------
-- Tag_Mismatch --
------------------
procedure Tag_Mismatch is
begin
if Sloc (Prev) < Sloc (Id) then
Error_Msg_NE
("full declaration of } must be a tagged type ", Id, Prev);
else
Error_Msg_NE
("full declaration of } must be a tagged type ", Prev, Id);
end if;
end Tag_Mismatch;
-- Start processing for Find_Type_Name
begin
-- Find incomplete declaration, if one was given
@ -13024,7 +13083,7 @@ package body Sem_Ch3 is
New_Id := Prev;
end if;
-- Verify that full declaration conforms to incomplete one
-- Verify that full declaration conforms to partial one
if Is_Incomplete_Or_Private_Type (Prev)
and then Present (Discriminant_Specifications (Prev_Par))
@ -13048,9 +13107,10 @@ package body Sem_Ch3 is
end if;
end if;
-- A prior untagged private type can have an associated class-wide
-- A prior untagged partial view can have an associated class-wide
-- type due to use of the class attribute, and in this case also the
-- full type is required to be tagged.
-- full type is required to be tagged. This Ada95 usage is deprecated
-- in favor of incomplete tagged declarations but we check for it.
if Is_Type (Prev)
and then (Is_Tagged_Type (Prev)
@ -13066,8 +13126,7 @@ package body Sem_Ch3 is
if No (Interface_List (N))
and then not Error_Posted (N)
then
Error_Msg_NE
("full declaration of } must be a tagged type ", Id, Prev);
Tag_Mismatch;
end if;
elsif Nkind (Type_Definition (N)) = N_Record_Definition then
@ -13076,8 +13135,7 @@ package body Sem_Ch3 is
-- or private declaration) requires the same on the full one.
if not Tagged_Present (Type_Definition (N)) then
Error_Msg_NE
("full declaration of } must be tagged", Prev, Id);
Tag_Mismatch;
Set_Is_Tagged_Type (Id);
Set_Primitive_Operations (Id, New_Elmt_List);
end if;
@ -13092,9 +13150,7 @@ package body Sem_Ch3 is
end if;
else
Error_Msg_NE
("full declaration of } must be a tagged type", Prev, Id);
Tag_Mismatch;
end if;
end if;
@ -17074,11 +17130,12 @@ package body Sem_Ch3 is
elsif Has_Controlled_Component (Etype (Component))
or else (Chars (Component) /= Name_uParent
and then Is_Controlled (Etype (Component)))
and then Is_Controlled (Etype (Component)))
then
Set_Has_Controlled_Component (T, True);
Final_Storage_Only := Final_Storage_Only
and then Finalize_Storage_Only (Etype (Component));
Final_Storage_Only :=
Final_Storage_Only
and then Finalize_Storage_Only (Etype (Component));
Ctrl_Components := True;
end if;

1
gcc/ada/sem_ch5.adb
View file

@ -870,6 +870,7 @@ package body Sem_Ch5 is
if Present (Decls) then
Analyze_Declarations (Decls);
Check_Completion;
Inspect_Deferred_Constant_Completion (Decls);
end if;
Analyze (HSS);

6
gcc/ada/sem_ch6.adb
View file

@ -1257,10 +1257,10 @@ package body Sem_Ch6 is
procedure Analyze_Subprogram_Body (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Body_Deleted : constant Boolean := False;
Body_Spec : constant Node_Id := Specification (N);
Body_Id : Entity_Id := Defining_Entity (Body_Spec);
Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id);
Body_Deleted : constant Boolean := False;
Conformant : Boolean;
HSS : Node_Id;
Missing_Ret : Boolean;
@ -1369,7 +1369,8 @@ package body Sem_Ch6 is
Plist : List_Id;
function Is_Inline_Pragma (N : Node_Id) return Boolean;
-- Simple predicate, used twice.
-- True when N is a pragma Inline or Inline_Awlays that applies
-- to this subprogram.
-----------------------
-- Is_Inline_Pragma --
@ -2045,6 +2046,7 @@ package body Sem_Ch6 is
-- Check completion, and analyze the statements
Check_Completion;
Inspect_Deferred_Constant_Completion (Declarations (N));
Analyze (HSS);
-- Deal with end of scope processing for the body

41
gcc/ada/sem_ch7.adb
View file

@ -100,12 +100,6 @@ package body Sem_Ch7 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);
-- Supporting procedure for Install_{Visible,Private}_Declarations.
-- Places one entity on its visibility chain, and recurses on the visible
@ -1604,41 +1598,6 @@ 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 --
----------------------------

2
gcc/ada/sem_ch7.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2008, 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- --

2
gcc/ada/sem_ch9.adb
View file

@ -795,6 +795,7 @@ package body Sem_Ch9 is
if Present (Decls) then
Analyze_Declarations (Decls);
Inspect_Deferred_Constant_Completion (Decls);
end if;
if Present (Stats) then
@ -1908,6 +1909,7 @@ package body Sem_Ch9 is
Last_E := Last_Entity (Spec_Id);
Analyze_Declarations (Decls);
Inspect_Deferred_Constant_Completion (Decls);
-- For visibility purposes, all entities in the body are private. Set
-- First_Private_Entity accordingly, if there was no private part in the