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

sem_ch3.adb (OK_For_Limited_Init_In_05): Allow calls to 'Input to initialize a limited object.

Browse Source 
2007-08-16  Gary Dismukes  <dismukes@adacore.com>
	    Javier Miranda  <miranda@adacore.com>

	* sem_ch3.adb (OK_For_Limited_Init_In_05): Allow calls to 'Input to
	initialize a limited object.
	(Build_Derived_Record_Type): Add missing check of rules ARM 3.9.4
	13/2 and 14/2.
	Make sure Has_Complex_Representation is inherited by derived type.

From-SVN: r127547
This commit is contained in:
Gary Dismukes 2007-08-16 14:20:13 +02:00 committed by Arnaud Charlet
parent 369925233a
commit c6fe3827df
1 changed files with 95 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

157
gcc/ada/sem_ch3.adb
View File

@ -4148,9 +4148,9 @@ package body Sem_Ch3 is
end; end;
end if; end if;
-- Create a concatenation operator for the new type. Internal -- Create a concatenation operator for the new type. Internal array
-- array types created for packed entities do not need such, they -- types created for packed entities do not need such, they are
-- are compatible with the user-defined type. -- compatible with the user-defined type.
if Number_Dimensions (T) = 1 if Number_Dimensions (T) = 1
and then not Is_Packed_Array_Type (T) and then not Is_Packed_Array_Type (T)
@ -4158,9 +4158,9 @@ package body Sem_Ch3 is
New_Concatenation_Op (T); New_Concatenation_Op (T);
end if; end if;
-- In the case of an unconstrained array the parser has already -- In the case of an unconstrained array the parser has already verified
-- verified that all the indices are unconstrained but we still -- that all the indices are unconstrained but we still need to make sure
-- need to make sure that the element type is constrained. -- that the element type is constrained.
if Is_Indefinite_Subtype (Element_Type) then if Is_Indefinite_Subtype (Element_Type) then
Error_Msg_N Error_Msg_N
@ -4180,7 +4180,7 @@ package body Sem_Ch3 is
------------------------------------------------------ ------------------------------------------------------
function Replace_Anonymous_Access_To_Protected_Subprogram function Replace_Anonymous_Access_To_Protected_Subprogram
(N : Node_Id) return Entity_Id (N : Node_Id) return Entity_Id
is is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
@ -4311,9 +4311,9 @@ package body Sem_Ch3 is
Subt : Entity_Id; Subt : Entity_Id;
begin begin
-- Set the designated type so it is available in case this is -- Set the designated type so it is available in case this is an access
-- an access to a self-referential type, e.g. a standard list -- to a self-referential type, e.g. a standard list type with a next
-- type with a next pointer. Will be reset after subtype is built. -- pointer. Will be reset after subtype is built.
Set_Directly_Designated_Type Set_Directly_Designated_Type
(Derived_Type, Designated_Type (Parent_Type)); (Derived_Type, Designated_Type (Parent_Type));
@ -4370,8 +4370,8 @@ package body Sem_Ch3 is
Set_Can_Never_Be_Null (Derived_Type); Set_Can_Never_Be_Null (Derived_Type);
end if; end if;
-- Note: we do not copy the Storage_Size_Variable, since -- Note: we do not copy the Storage_Size_Variable, since we always go to
-- we always go to the root type for this information. -- the root type for this information.
-- Apply range checks to discriminants for derived record case -- Apply range checks to discriminants for derived record case
-- ??? THIS CODE SHOULD NOT BE HERE REALLY. -- ??? THIS CODE SHOULD NOT BE HERE REALLY.
@ -4411,8 +4411,8 @@ package body Sem_Ch3 is
New_Indic : Node_Id; New_Indic : Node_Id;
procedure Make_Implicit_Base; procedure Make_Implicit_Base;
-- If the parent subtype is constrained, the derived type is a -- If the parent subtype is constrained, the derived type is a subtype
-- subtype of an implicit base type derived from the parent base. -- of an implicit base type derived from the parent base.
------------------------ ------------------------
-- Make_Implicit_Base -- -- Make_Implicit_Base --
@ -4720,13 +4720,12 @@ package body Sem_Ch3 is
Analyze (High_Bound (Range_Expression (Constraint (Indic)))); Analyze (High_Bound (Range_Expression (Constraint (Indic))));
end if; end if;
-- Introduce an implicit base type for the derived type even -- Introduce an implicit base type for the derived type even if there
-- if there is no constraint attached to it, since this seems -- is no constraint attached to it, since this seems closer to the
-- closer to the Ada semantics. Build a full type declaration -- Ada semantics. Build a full type declaration tree for the derived
-- tree for the derived type using the implicit base type as -- type using the implicit base type as the defining identifier. The
-- the defining identifier. The build a subtype declaration -- build a subtype declaration tree which applies the constraint (if
-- tree which applies the constraint (if any) have it replace -- any) have it replace the derived type declaration.
-- the derived type declaration.
Literal := First_Literal (Parent_Type); Literal := First_Literal (Parent_Type);
Literals_List := New_List; Literals_List := New_List;
@ -4762,10 +4761,10 @@ package body Sem_Ch3 is
Make_Defining_Identifier (Sloc (Derived_Type), Make_Defining_Identifier (Sloc (Derived_Type),
New_External_Name (Chars (Derived_Type), 'B')); New_External_Name (Chars (Derived_Type), 'B'));
-- Indicate the proper nature of the derived type. This must -- Indicate the proper nature of the derived type. This must be done
-- be done before analysis of the literals, to recognize cases -- before analysis of the literals, to recognize cases when a literal
-- when a literal may be hidden by a previous explicit function -- may be hidden by a previous explicit function definition (cf.
-- definition (cf. c83031a). -- c83031a).
Set_Ekind (Derived_Type, E_Enumeration_Subtype); Set_Ekind (Derived_Type, E_Enumeration_Subtype);
Set_Etype (Derived_Type, Implicit_Base); Set_Etype (Derived_Type, Implicit_Base);
@ -4796,9 +4795,9 @@ package body Sem_Ch3 is
(Parent_Type)); (Parent_Type));
Set_Has_Delayed_Freeze (Implicit_Base); Set_Has_Delayed_Freeze (Implicit_Base);
-- Process the subtype indication including a validation check -- Process the subtype indication including a validation check on the
-- on the constraint, if any. If a constraint is given, its bounds -- constraint, if any. If a constraint is given, its bounds must be
-- must be implicitly converted to the new type. -- implicitly converted to the new type.
if Nkind (Indic) = N_Subtype_Indication then if Nkind (Indic) = N_Subtype_Indication then
declare declare
@ -4813,9 +4812,9 @@ package body Sem_Ch3 is
(Low_Bound (R), Parent_Type, Implicit_Base); (Low_Bound (R), Parent_Type, Implicit_Base);
else else
-- Constraint is a Range attribute. Replace with the -- Constraint is a Range attribute. Replace with explicit
-- explicit mention of the bounds of the prefix, which must -- mention of the bounds of the prefix, which must be a
-- be a subtype. -- subtype.
Analyze (Prefix (R)); Analyze (Prefix (R));
Hi := Hi :=
@ -4872,8 +4871,8 @@ package body Sem_Ch3 is
Analyze (N); Analyze (N);
-- If pragma Discard_Names applies on the first subtype of the -- If pragma Discard_Names applies on the first subtype of the parent
-- parent type, then it must be applied on this subtype as well. -- type, then it must be applied on this subtype as well.
if Einfo.Discard_Names (First_Subtype (Parent_Type)) then if Einfo.Discard_Names (First_Subtype (Parent_Type)) then
Set_Discard_Names (Derived_Type); Set_Discard_Names (Derived_Type);
@ -5916,15 +5915,15 @@ package body Sem_Ch3 is
Last_Discrim : Entity_Id; Last_Discrim : Entity_Id;
Constrs : Elist_Id; Constrs : Elist_Id;
Discs : Elist_Id := New_Elmt_List; Discs : Elist_Id := New_Elmt_List;
-- An empty Discs list means that there were no constraints in the -- An empty Discs list means that there were no constraints in the
-- subtype indication or that there was an error processing it. -- subtype indication or that there was an error processing it.
Assoc_List : Elist_Id; Assoc_List : Elist_Id;
New_Discrs : Elist_Id; New_Discrs : Elist_Id;
New_Base : Entity_Id; New_Base : Entity_Id;
New_Decl : Node_Id; New_Decl : Node_Id;
New_Indic : Node_Id; New_Indic : Node_Id;
Is_Tagged : constant Boolean := Is_Tagged_Type (Parent_Type); Is_Tagged : constant Boolean := Is_Tagged_Type (Parent_Type);
Discriminant_Specs : constant Boolean := Discriminant_Specs : constant Boolean :=
@ -5932,11 +5931,11 @@ package body Sem_Ch3 is
Private_Extension : constant Boolean := Private_Extension : constant Boolean :=
(Nkind (N) = N_Private_Extension_Declaration); (Nkind (N) = N_Private_Extension_Declaration);
Constraint_Present : Boolean; Constraint_Present : Boolean;
Inherit_Discrims : Boolean := False; Inherit_Discrims : Boolean := False;
Save_Etype : Entity_Id; Save_Etype : Entity_Id;
Save_Discr_Constr : Elist_Id; Save_Discr_Constr : Elist_Id;
Save_Next_Entity : Entity_Id; Save_Next_Entity : Entity_Id;
begin begin
if Ekind (Parent_Type) = E_Record_Type_With_Private if Ekind (Parent_Type) = E_Record_Type_With_Private
@ -5982,7 +5981,7 @@ package body Sem_Ch3 is
else else
Type_Def := Type_Definition (N); Type_Def := Type_Definition (N);
-- Ekind (Parent_Base) in not necessarily E_Record_Type since -- Ekind (Parent_Base) is not necessarily E_Record_Type since
-- Parent_Base can be a private type or private extension. However, -- Parent_Base can be a private type or private extension. However,
-- for tagged types with an extension the newly added fields are -- for tagged types with an extension the newly added fields are
-- visible and hence the Derived_Type is always an E_Record_Type. -- visible and hence the Derived_Type is always an E_Record_Type.
@ -6527,13 +6526,13 @@ package body Sem_Ch3 is
-- Fields inherited from the Parent_Type -- Fields inherited from the Parent_Type
Set_Discard_Names Set_Discard_Names
(Derived_Type, Einfo.Discard_Names (Parent_Type)); (Derived_Type, Einfo.Discard_Names (Parent_Type));
Set_Has_Specified_Layout Set_Has_Specified_Layout
(Derived_Type, Has_Specified_Layout (Parent_Type)); (Derived_Type, Has_Specified_Layout (Parent_Type));
Set_Is_Limited_Composite Set_Is_Limited_Composite
(Derived_Type, Is_Limited_Composite (Parent_Type)); (Derived_Type, Is_Limited_Composite (Parent_Type));
Set_Is_Private_Composite Set_Is_Private_Composite
(Derived_Type, Is_Private_Composite (Parent_Type)); (Derived_Type, Is_Private_Composite (Parent_Type));
-- Fields inherited from the Parent_Base -- Fields inherited from the Parent_Base
@ -6544,9 +6543,16 @@ package body Sem_Ch3 is
Set_Has_Primitive_Operations Set_Has_Primitive_Operations
(Derived_Type, Has_Primitive_Operations (Parent_Base)); (Derived_Type, Has_Primitive_Operations (Parent_Base));
-- For non-private case, we also inherit Has_Complex_Representation
if Ekind (Derived_Type) = E_Record_Type then
Set_Has_Complex_Representation
(Derived_Type, Has_Complex_Representation (Parent_Base));
end if;
-- Direct controlled types do not inherit Finalize_Storage_Only flag -- Direct controlled types do not inherit Finalize_Storage_Only flag
if not Is_Controlled (Parent_Type) then if not Is_Controlled (Parent_Type) then
Set_Finalize_Storage_Only Set_Finalize_Storage_Only
(Derived_Type, Finalize_Storage_Only (Parent_Type)); (Derived_Type, Finalize_Storage_Only (Parent_Type));
end if; end if;
@ -6608,7 +6614,27 @@ package body Sem_Ch3 is
if Ada_Version >= Ada_05 then if Ada_Version >= Ada_05 then
declare declare
Ifaces_List : Elist_Id; Ifaces_List : Elist_Id;
begin begin
-- Checks rules 3.9.4 (13/2 and 14/2)
if Comes_From_Source (Derived_Type)
and then not Is_Private_Type (Derived_Type)
and then Is_Interface (Parent_Type)
and then not Is_Interface (Derived_Type)
then
if Is_Task_Interface (Parent_Type) then
Error_Msg_N
("(Ada 2005) task type required (RM 3.9.4 (13.2))",
Derived_Type);
elsif Is_Protected_Interface (Parent_Type) then
Error_Msg_N
("(Ada 2005) protected type required (RM 3.9.4 (14.2))",
Derived_Type);
end if;
end if;
-- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2) -- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2)
Check_Abstract_Interfaces (N, Type_Def); Check_Abstract_Interfaces (N, Type_Def);
@ -6820,16 +6846,16 @@ package body Sem_Ch3 is
begin begin
-- Set common attributes -- Set common attributes
Set_Scope (Derived_Type, Current_Scope); Set_Scope (Derived_Type, Current_Scope);
Set_Ekind (Derived_Type, Ekind (Parent_Base)); Set_Ekind (Derived_Type, Ekind (Parent_Base));
Set_Etype (Derived_Type, Parent_Base); Set_Etype (Derived_Type, Parent_Base);
Set_Has_Task (Derived_Type, Has_Task (Parent_Base)); Set_Has_Task (Derived_Type, Has_Task (Parent_Base));
Set_Size_Info (Derived_Type, Parent_Type); Set_Size_Info (Derived_Type, Parent_Type);
Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
Set_Convention (Derived_Type, Convention (Parent_Type)); Set_Convention (Derived_Type, Convention (Parent_Type));
Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type)); Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type));
-- The derived type inherits the representation clauses of the parent. -- The derived type inherits the representation clauses of the parent.
-- However, for a private type that is completed by a derivation, there -- However, for a private type that is completed by a derivation, there
@ -14200,9 +14226,9 @@ package body Sem_Ch3 is
return True; return True;
end if; end if;
-- Ada 2005 (AI-287, AI-318): Relax the strictness of the front-end in -- Ada 2005 (AI-287, AI-318): Relax the strictness of the front end in
-- case of limited aggregates (including extension aggregates), -- case of limited aggregates (including extension aggregates), and
-- and function calls. The function call may have been give in prefixed -- function calls. The function call may have been give in prefixed
-- notation, in which case the original node is an indexed component. -- notation, in which case the original node is an indexed component.
case Nkind (Original_Node (Exp)) is case Nkind (Original_Node (Exp)) is
@ -14210,7 +14236,7 @@ package body Sem_Ch3 is
return True; return True;
-- Ada 2005 (AI-251): If a class-wide interface object is initialized -- Ada 2005 (AI-251): If a class-wide interface object is initialized
-- with a function call, the expander has rewriten the call into an -- with a function call, the expander has rewritten the call into an
-- N_Type_Conversion node to force displacement of the pointer to -- N_Type_Conversion node to force displacement of the pointer to
-- reference the component containing the secondary dispatch table. -- reference the component containing the secondary dispatch table.
@ -14221,6 +14247,13 @@ package body Sem_Ch3 is
when N_Indexed_Component | N_Selected_Component => when N_Indexed_Component | N_Selected_Component =>
return Nkind (Exp) = N_Function_Call; return Nkind (Exp) = N_Function_Call;
-- A use of 'Input is a function call, hence allowed. Normally the
-- attribute will be changed to a call, but the attribute by itself
-- can occur with -gnatc.
when N_Attribute_Reference =>
return Attribute_Name (Original_Node (Exp)) = Name_Input;
when others => when others =>
return False; return False;
end case; end case;