sem_aggr.adb (Analyze_N_Extension_Aggregate): Add legality checks for the ancestor part of an extension aggregate for a...
2008-04-08 Ed Schonberg <schonberg@adacore.com> Robert Dewar <dewar@adacore.com> * sem_aggr.adb (Analyze_N_Extension_Aggregate): Add legality checks for the ancestor part of an extension aggregate for a limited type. (Resolve_Array_Aggregate): Issue warning for sliding of aggregate with enumeration index bounds. (Resolve_Array_Aggregate): Add circuit for diagnosing missing choices when array is too short. (Check_Expr_OK_In_Limited_Aggregate): Move function Check_Non_Limited_Type from Resolve_Record_Aggregate to top level (and change name). (Resolve_Array_Aggregate.Resolve_Aggr_Expr): Check_Expr_OK_In_Limited_Aggregates called to check for illegal limited component associations. (Check_Non_Limited_Type): Moved to outer level and renamed. (Resolve_Record_Aggregate): In an extension aggregate, an association with a box initialization can only designate a component of the extension, not a component inherited from the given ancestor * sem_case.adb: Use new Is_Standard_Character_Type predicate From-SVN: r134049
This commit is contained in:
parent
f89b7956cb
commit
ca44152fc5
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- B o d y --
|
||||||
-- --
|
-- --
|
||||||
-- 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 --
|
-- 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- --
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||||
|
@ -89,6 +89,11 @@ package body Sem_Aggr is
|
||||||
--
|
--
|
||||||
-- It would be better to pass the proper type for Typ ???
|
-- It would be better to pass the proper type for Typ ???
|
||||||
|
|
||||||
|
procedure Check_Expr_OK_In_Limited_Aggregate (Expr : Node_Id);
|
||||||
|
-- Check that Expr is either not limited or else is one of the cases of
|
||||||
|
-- expressions allowed for a limited component association (namely, an
|
||||||
|
-- aggregate, function call, or <> notation). Report error for violations.
|
||||||
|
|
||||||
------------------------------------------------------
|
------------------------------------------------------
|
||||||
-- Subprograms used for RECORD AGGREGATE Processing --
|
-- Subprograms used for RECORD AGGREGATE Processing --
|
||||||
------------------------------------------------------
|
------------------------------------------------------
|
||||||
|
@ -215,10 +220,10 @@ package body Sem_Aggr is
|
||||||
Index : Node_Id;
|
Index : Node_Id;
|
||||||
Index_Constr : Node_Id;
|
Index_Constr : Node_Id;
|
||||||
Component_Typ : Entity_Id;
|
Component_Typ : Entity_Id;
|
||||||
Others_Allowed : Boolean)
|
Others_Allowed : Boolean) return Boolean;
|
||||||
return Boolean;
|
|
||||||
-- This procedure performs the semantic checks for an array aggregate.
|
-- This procedure performs the semantic checks for an array aggregate.
|
||||||
-- True is returned if the aggregate resolution succeeds.
|
-- True is returned if the aggregate resolution succeeds.
|
||||||
|
--
|
||||||
-- The procedure works by recursively checking each nested aggregate.
|
-- The procedure works by recursively checking each nested aggregate.
|
||||||
-- Specifically, after checking a sub-aggregate nested at the i-th level
|
-- Specifically, after checking a sub-aggregate nested at the i-th level
|
||||||
-- we recursively check all the subaggregates at the i+1-st level (if any).
|
-- we recursively check all the subaggregates at the i+1-st level (if any).
|
||||||
|
@ -412,7 +417,7 @@ package body Sem_Aggr is
|
||||||
-- This is really expansion activity, so make sure that expansion
|
-- This is really expansion activity, so make sure that expansion
|
||||||
-- is on and is allowed.
|
-- is on and is allowed.
|
||||||
|
|
||||||
if not Expander_Active or else In_Default_Expression then
|
if not Expander_Active or else In_Spec_Expression then
|
||||||
return;
|
return;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
@ -680,7 +685,6 @@ package body Sem_Aggr is
|
||||||
Set_First_Index (Itype, First (Index_Constraints));
|
Set_First_Index (Itype, First (Index_Constraints));
|
||||||
Set_Is_Constrained (Itype, True);
|
Set_Is_Constrained (Itype, True);
|
||||||
Set_Is_Internal (Itype, True);
|
Set_Is_Internal (Itype, True);
|
||||||
Init_Size_Align (Itype);
|
|
||||||
|
|
||||||
-- A simple optimization: purely positional aggregates of static
|
-- A simple optimization: purely positional aggregates of static
|
||||||
-- components should be passed to gigi unexpanded whenever possible,
|
-- components should be passed to gigi unexpanded whenever possible,
|
||||||
|
@ -698,7 +702,7 @@ package body Sem_Aggr is
|
||||||
-- and we must not generate a freeze node for the type, or else it
|
-- and we must not generate a freeze node for the type, or else it
|
||||||
-- will appear incomplete to gigi.
|
-- will appear incomplete to gigi.
|
||||||
|
|
||||||
if Is_Packed (Itype) and then not In_Default_Expression
|
if Is_Packed (Itype) and then not In_Spec_Expression
|
||||||
and then Expander_Active
|
and then Expander_Active
|
||||||
then
|
then
|
||||||
Freeze_Itype (Itype, N);
|
Freeze_Itype (Itype, N);
|
||||||
|
@ -762,6 +766,23 @@ package body Sem_Aggr is
|
||||||
end if;
|
end if;
|
||||||
end Check_Misspelled_Component;
|
end Check_Misspelled_Component;
|
||||||
|
|
||||||
|
----------------------------------------
|
||||||
|
-- Check_Expr_OK_In_Limited_Aggregate --
|
||||||
|
----------------------------------------
|
||||||
|
|
||||||
|
procedure Check_Expr_OK_In_Limited_Aggregate (Expr : Node_Id) is
|
||||||
|
begin
|
||||||
|
if Is_Limited_Type (Etype (Expr))
|
||||||
|
and then Comes_From_Source (Expr)
|
||||||
|
and then not In_Instance_Body
|
||||||
|
then
|
||||||
|
if not OK_For_Limited_Init (Expr) then
|
||||||
|
Error_Msg_N ("initialization not allowed for limited types", Expr);
|
||||||
|
Explain_Limited_Type (Etype (Expr), Expr);
|
||||||
|
end if;
|
||||||
|
end if;
|
||||||
|
end Check_Expr_OK_In_Limited_Aggregate;
|
||||||
|
|
||||||
----------------------------------------
|
----------------------------------------
|
||||||
-- Check_Static_Discriminated_Subtype --
|
-- Check_Static_Discriminated_Subtype --
|
||||||
----------------------------------------
|
----------------------------------------
|
||||||
|
@ -909,18 +930,14 @@ package body Sem_Aggr is
|
||||||
|
|
||||||
-- First a special test, for the case of a positional aggregate
|
-- First a special test, for the case of a positional aggregate
|
||||||
-- of characters which can be replaced by a string literal.
|
-- of characters which can be replaced by a string literal.
|
||||||
|
|
||||||
-- Do not perform this transformation if this was a string literal
|
-- Do not perform this transformation if this was a string literal
|
||||||
-- to start with, whose components needed constraint checks, or if
|
-- to start with, whose components needed constraint checks, or if
|
||||||
-- the component type is non-static, because it will require those
|
-- the component type is non-static, because it will require those
|
||||||
-- checks and be transformed back into an aggregate.
|
-- checks and be transformed back into an aggregate.
|
||||||
|
|
||||||
if Number_Dimensions (Typ) = 1
|
if Number_Dimensions (Typ) = 1
|
||||||
and then
|
and then Is_Standard_Character_Type (Component_Type (Typ))
|
||||||
(Root_Type (Component_Type (Typ)) = Standard_Character
|
|
||||||
or else
|
|
||||||
Root_Type (Component_Type (Typ)) = Standard_Wide_Character
|
|
||||||
or else
|
|
||||||
Root_Type (Component_Type (Typ)) = Standard_Wide_Wide_Character)
|
|
||||||
and then No (Component_Associations (N))
|
and then No (Component_Associations (N))
|
||||||
and then not Is_Limited_Composite (Typ)
|
and then not Is_Limited_Composite (Typ)
|
||||||
and then not Is_Private_Composite (Typ)
|
and then not Is_Private_Composite (Typ)
|
||||||
|
@ -1078,8 +1095,7 @@ package body Sem_Aggr is
|
||||||
Index : Node_Id;
|
Index : Node_Id;
|
||||||
Index_Constr : Node_Id;
|
Index_Constr : Node_Id;
|
||||||
Component_Typ : Entity_Id;
|
Component_Typ : Entity_Id;
|
||||||
Others_Allowed : Boolean)
|
Others_Allowed : Boolean) return Boolean
|
||||||
return Boolean
|
|
||||||
is
|
is
|
||||||
Loc : constant Source_Ptr := Sloc (N);
|
Loc : constant Source_Ptr := Sloc (N);
|
||||||
|
|
||||||
|
@ -1126,8 +1142,7 @@ package body Sem_Aggr is
|
||||||
|
|
||||||
function Resolve_Aggr_Expr
|
function Resolve_Aggr_Expr
|
||||||
(Expr : Node_Id;
|
(Expr : Node_Id;
|
||||||
Single_Elmt : Boolean)
|
Single_Elmt : Boolean) return Boolean;
|
||||||
return Boolean;
|
|
||||||
-- Resolves aggregate expression Expr. Returs False if resolution
|
-- Resolves aggregate expression Expr. Returs False if resolution
|
||||||
-- fails. If Single_Elmt is set to False, the expression Expr may be
|
-- fails. If Single_Elmt is set to False, the expression Expr may be
|
||||||
-- used to initialize several array aggregate elements (this can
|
-- used to initialize several array aggregate elements (this can
|
||||||
|
@ -1377,8 +1392,7 @@ package body Sem_Aggr is
|
||||||
|
|
||||||
function Resolve_Aggr_Expr
|
function Resolve_Aggr_Expr
|
||||||
(Expr : Node_Id;
|
(Expr : Node_Id;
|
||||||
Single_Elmt : Boolean)
|
Single_Elmt : Boolean) return Boolean
|
||||||
return Boolean
|
|
||||||
is
|
is
|
||||||
Nxt_Ind : constant Node_Id := Next_Index (Index);
|
Nxt_Ind : constant Node_Id := Next_Index (Index);
|
||||||
Nxt_Ind_Constr : constant Node_Id := Next_Index (Index_Constr);
|
Nxt_Ind_Constr : constant Node_Id := Next_Index (Index_Constr);
|
||||||
|
@ -1435,9 +1449,10 @@ package body Sem_Aggr is
|
||||||
|
|
||||||
elsif Single_Elmt
|
elsif Single_Elmt
|
||||||
or else not Expander_Active
|
or else not Expander_Active
|
||||||
or else In_Default_Expression
|
or else In_Spec_Expression
|
||||||
then
|
then
|
||||||
Analyze_And_Resolve (Expr, Component_Typ);
|
Analyze_And_Resolve (Expr, Component_Typ);
|
||||||
|
Check_Expr_OK_In_Limited_Aggregate (Expr);
|
||||||
Check_Non_Static_Context (Expr);
|
Check_Non_Static_Context (Expr);
|
||||||
Aggregate_Constraint_Checks (Expr, Component_Typ);
|
Aggregate_Constraint_Checks (Expr, Component_Typ);
|
||||||
Check_Unset_Reference (Expr);
|
Check_Unset_Reference (Expr);
|
||||||
|
@ -1560,7 +1575,6 @@ package body Sem_Aggr is
|
||||||
-- STEP 2: Process named components
|
-- STEP 2: Process named components
|
||||||
|
|
||||||
if No (Expressions (N)) then
|
if No (Expressions (N)) then
|
||||||
|
|
||||||
if Others_Present then
|
if Others_Present then
|
||||||
Case_Table_Size := Nb_Choices - 1;
|
Case_Table_Size := Nb_Choices - 1;
|
||||||
else
|
else
|
||||||
|
@ -1622,6 +1636,8 @@ package body Sem_Aggr is
|
||||||
return Failure;
|
return Failure;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
-- Case of subtype indication
|
||||||
|
|
||||||
elsif Nkind (Choice) = N_Subtype_Indication then
|
elsif Nkind (Choice) = N_Subtype_Indication then
|
||||||
Resolve_Discrete_Subtype_Indication (Choice, Index_Base);
|
Resolve_Discrete_Subtype_Indication (Choice, Index_Base);
|
||||||
|
|
||||||
|
@ -1631,7 +1647,9 @@ package body Sem_Aggr is
|
||||||
Get_Index_Bounds (Choice, Low, High);
|
Get_Index_Bounds (Choice, Low, High);
|
||||||
Check_Bounds (S_Low, S_High, Low, High);
|
Check_Bounds (S_Low, S_High, Low, High);
|
||||||
|
|
||||||
else -- Choice is a range or an expression
|
-- Case of range or expression
|
||||||
|
|
||||||
|
else
|
||||||
Resolve (Choice, Index_Base);
|
Resolve (Choice, Index_Base);
|
||||||
Check_Unset_Reference (Choice);
|
Check_Unset_Reference (Choice);
|
||||||
Check_Non_Static_Context (Choice);
|
Check_Non_Static_Context (Choice);
|
||||||
|
@ -1737,7 +1755,6 @@ package body Sem_Aggr is
|
||||||
return Failure;
|
return Failure;
|
||||||
|
|
||||||
elsif not Others_Present then
|
elsif not Others_Present then
|
||||||
|
|
||||||
Hi_Val := Expr_Value (Table (J).Choice_Hi);
|
Hi_Val := Expr_Value (Table (J).Choice_Hi);
|
||||||
Lo_Val := Expr_Value (Table (J + 1).Choice_Lo);
|
Lo_Val := Expr_Value (Table (J + 1).Choice_Lo);
|
||||||
|
|
||||||
|
@ -1805,10 +1822,123 @@ package body Sem_Aggr is
|
||||||
Choices_High := Table (Nb_Discrete_Choices).Choice_Hi;
|
Choices_High := Table (Nb_Discrete_Choices).Choice_Hi;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
-- If Others is present, then bounds of aggregate come from the
|
||||||
|
-- index constraint (not the choices in the aggregate itself).
|
||||||
|
|
||||||
if Others_Present then
|
if Others_Present then
|
||||||
Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High);
|
Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High);
|
||||||
|
|
||||||
|
-- No others clause present
|
||||||
|
|
||||||
else
|
else
|
||||||
|
-- Special processing if others allowed and not present. This
|
||||||
|
-- means that the bounds of the aggregate come from the index
|
||||||
|
-- constraint (and the length must match).
|
||||||
|
|
||||||
|
if Others_Allowed then
|
||||||
|
Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High);
|
||||||
|
|
||||||
|
-- If others allowed, and no others present, then the array
|
||||||
|
-- should cover all index values. If it does not, we will
|
||||||
|
-- get a length check warning, but there is two cases where
|
||||||
|
-- an additional warning is useful:
|
||||||
|
|
||||||
|
-- If we have no positional components, and the length is
|
||||||
|
-- wrong (which we can tell by others being allowed with
|
||||||
|
-- missing components), and the index type is an enumeration
|
||||||
|
-- type, then issue appropriate warnings about these missing
|
||||||
|
-- components. They are only warnings, since the aggregate
|
||||||
|
-- is fine, it's just the wrong length. We skip this check
|
||||||
|
-- for standard character types (since there are no literals
|
||||||
|
-- and it is too much trouble to concoct them), and also if
|
||||||
|
-- any of the bounds have not-known-at-compile-time values.
|
||||||
|
|
||||||
|
-- Another case warranting a warning is when the length is
|
||||||
|
-- right, but as above we have an index type that is an
|
||||||
|
-- enumeration, and the bounds do not match. This is a
|
||||||
|
-- case where dubious sliding is allowed and we generate
|
||||||
|
-- a warning that the bounds do not match.
|
||||||
|
|
||||||
|
if No (Expressions (N))
|
||||||
|
and then Nkind (Index) = N_Range
|
||||||
|
and then Is_Enumeration_Type (Etype (Index))
|
||||||
|
and then not Is_Standard_Character_Type (Etype (Index))
|
||||||
|
and then Compile_Time_Known_Value (Aggr_Low)
|
||||||
|
and then Compile_Time_Known_Value (Aggr_High)
|
||||||
|
and then Compile_Time_Known_Value (Choices_Low)
|
||||||
|
and then Compile_Time_Known_Value (Choices_High)
|
||||||
|
then
|
||||||
|
declare
|
||||||
|
ALo : constant Node_Id := Expr_Value_E (Aggr_Low);
|
||||||
|
AHi : constant Node_Id := Expr_Value_E (Aggr_High);
|
||||||
|
CLo : constant Node_Id := Expr_Value_E (Choices_Low);
|
||||||
|
CHi : constant Node_Id := Expr_Value_E (Choices_High);
|
||||||
|
|
||||||
|
Ent : Entity_Id;
|
||||||
|
|
||||||
|
begin
|
||||||
|
-- Warning case one, missing values at start/end. Only
|
||||||
|
-- do the check if the number of entries is too small.
|
||||||
|
|
||||||
|
if (Enumeration_Pos (CHi) - Enumeration_Pos (CLo))
|
||||||
|
<
|
||||||
|
(Enumeration_Pos (AHi) - Enumeration_Pos (ALo))
|
||||||
|
then
|
||||||
|
Error_Msg_N
|
||||||
|
("missing index value(s) in array aggregate?", N);
|
||||||
|
|
||||||
|
-- Output missing value(s) at start
|
||||||
|
|
||||||
|
if Chars (ALo) /= Chars (CLo) then
|
||||||
|
Ent := Prev (CLo);
|
||||||
|
|
||||||
|
if Chars (ALo) = Chars (Ent) then
|
||||||
|
Error_Msg_Name_1 := Chars (ALo);
|
||||||
|
Error_Msg_N ("\ %?", N);
|
||||||
|
else
|
||||||
|
Error_Msg_Name_1 := Chars (ALo);
|
||||||
|
Error_Msg_Name_2 := Chars (Ent);
|
||||||
|
Error_Msg_N ("\ % .. %?", N);
|
||||||
|
end if;
|
||||||
|
end if;
|
||||||
|
|
||||||
|
-- Output missing value(s) at end
|
||||||
|
|
||||||
|
if Chars (AHi) /= Chars (CHi) then
|
||||||
|
Ent := Next (CHi);
|
||||||
|
|
||||||
|
if Chars (AHi) = Chars (Ent) then
|
||||||
|
Error_Msg_Name_1 := Chars (Ent);
|
||||||
|
Error_Msg_N ("\ %?", N);
|
||||||
|
else
|
||||||
|
Error_Msg_Name_1 := Chars (Ent);
|
||||||
|
Error_Msg_Name_2 := Chars (AHi);
|
||||||
|
Error_Msg_N ("\ % .. %?", N);
|
||||||
|
end if;
|
||||||
|
end if;
|
||||||
|
|
||||||
|
-- Warning case 2, dubious sliding. The First_Subtype
|
||||||
|
-- test distinguishes between a constrained type where
|
||||||
|
-- sliding is not allowed (so we will get a warning
|
||||||
|
-- later that Constraint_Error will be raised), and
|
||||||
|
-- the unconstrained case where sliding is permitted.
|
||||||
|
|
||||||
|
elsif (Enumeration_Pos (CHi) - Enumeration_Pos (CLo))
|
||||||
|
=
|
||||||
|
(Enumeration_Pos (AHi) - Enumeration_Pos (ALo))
|
||||||
|
and then Chars (ALo) /= Chars (CLo)
|
||||||
|
and then
|
||||||
|
not Is_Constrained (First_Subtype (Etype (N)))
|
||||||
|
then
|
||||||
|
Error_Msg_N
|
||||||
|
("bounds of aggregate do not match target?", N);
|
||||||
|
end if;
|
||||||
|
end;
|
||||||
|
end if;
|
||||||
|
end if;
|
||||||
|
|
||||||
|
-- If no others, aggregate bounds come from aggegate
|
||||||
|
|
||||||
Aggr_Low := Choices_Low;
|
Aggr_Low := Choices_Low;
|
||||||
Aggr_High := Choices_High;
|
Aggr_High := Choices_High;
|
||||||
end if;
|
end if;
|
||||||
|
@ -1976,10 +2106,44 @@ package body Sem_Aggr is
|
||||||
I : Interp_Index;
|
I : Interp_Index;
|
||||||
It : Interp;
|
It : Interp;
|
||||||
|
|
||||||
|
function Valid_Limited_Ancestor (Anc : Node_Id) return Boolean;
|
||||||
|
-- If the type is limited, verify that the ancestor part is a legal
|
||||||
|
-- expression (aggregate or function call, including 'Input)) that
|
||||||
|
-- does not require a copy, as specified in 7.5 (2).
|
||||||
|
|
||||||
function Valid_Ancestor_Type return Boolean;
|
function Valid_Ancestor_Type return Boolean;
|
||||||
-- Verify that the type of the ancestor part is a non-private ancestor
|
-- Verify that the type of the ancestor part is a non-private ancestor
|
||||||
-- of the expected type.
|
-- of the expected type.
|
||||||
|
|
||||||
|
----------------------------
|
||||||
|
-- Valid_Limited_Ancestor --
|
||||||
|
----------------------------
|
||||||
|
|
||||||
|
function Valid_Limited_Ancestor (Anc : Node_Id) return Boolean is
|
||||||
|
begin
|
||||||
|
if Is_Entity_Name (Anc)
|
||||||
|
and then Is_Type (Entity (Anc))
|
||||||
|
then
|
||||||
|
return True;
|
||||||
|
|
||||||
|
elsif Nkind_In (Anc, N_Aggregate, N_Function_Call) then
|
||||||
|
return True;
|
||||||
|
|
||||||
|
elsif Nkind (Anc) = N_Attribute_Reference
|
||||||
|
and then Attribute_Name (Anc) = Name_Input
|
||||||
|
then
|
||||||
|
return True;
|
||||||
|
|
||||||
|
elsif
|
||||||
|
Nkind (Anc) = N_Qualified_Expression
|
||||||
|
then
|
||||||
|
return Valid_Limited_Ancestor (Expression (Anc));
|
||||||
|
|
||||||
|
else
|
||||||
|
return False;
|
||||||
|
end if;
|
||||||
|
end Valid_Limited_Ancestor;
|
||||||
|
|
||||||
-------------------------
|
-------------------------
|
||||||
-- Valid_Ancestor_Type --
|
-- Valid_Ancestor_Type --
|
||||||
-------------------------
|
-------------------------
|
||||||
|
@ -2020,6 +2184,13 @@ package body Sem_Aggr is
|
||||||
Error_Msg_N ("aggregate type cannot be limited", N);
|
Error_Msg_N ("aggregate type cannot be limited", N);
|
||||||
Explain_Limited_Type (Typ, N);
|
Explain_Limited_Type (Typ, N);
|
||||||
return;
|
return;
|
||||||
|
|
||||||
|
elsif Valid_Limited_Ancestor (A) then
|
||||||
|
null;
|
||||||
|
|
||||||
|
else
|
||||||
|
Error_Msg_N
|
||||||
|
("limited ancestor part must be aggregate or function call", A);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
elsif Is_Class_Wide_Type (Typ) then
|
elsif Is_Class_Wide_Type (Typ) then
|
||||||
|
@ -2429,31 +2600,6 @@ package body Sem_Aggr is
|
||||||
return Expr;
|
return Expr;
|
||||||
end Get_Value;
|
end Get_Value;
|
||||||
|
|
||||||
procedure Check_Non_Limited_Type (Expr : Node_Id);
|
|
||||||
-- Relax check to allow the default initialization of limited types.
|
|
||||||
-- For example:
|
|
||||||
-- record
|
|
||||||
-- C : Lim := (..., others => <>);
|
|
||||||
-- end record;
|
|
||||||
|
|
||||||
----------------------------
|
|
||||||
-- Check_Non_Limited_Type --
|
|
||||||
----------------------------
|
|
||||||
|
|
||||||
procedure Check_Non_Limited_Type (Expr : Node_Id) is
|
|
||||||
begin
|
|
||||||
if Is_Limited_Type (Etype (Expr))
|
|
||||||
and then Comes_From_Source (Expr)
|
|
||||||
and then not In_Instance_Body
|
|
||||||
then
|
|
||||||
if not OK_For_Limited_Init (Expr) then
|
|
||||||
Error_Msg_N
|
|
||||||
("initialization not allowed for limited types", N);
|
|
||||||
Explain_Limited_Type (Etype (Expr), Expr);
|
|
||||||
end if;
|
|
||||||
end if;
|
|
||||||
end Check_Non_Limited_Type;
|
|
||||||
|
|
||||||
-----------------------
|
-----------------------
|
||||||
-- Resolve_Aggr_Expr --
|
-- Resolve_Aggr_Expr --
|
||||||
-----------------------
|
-----------------------
|
||||||
|
@ -2574,7 +2720,7 @@ package body Sem_Aggr is
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
Analyze_And_Resolve (Expr, Expr_Type);
|
Analyze_And_Resolve (Expr, Expr_Type);
|
||||||
Check_Non_Limited_Type (Expr);
|
Check_Expr_OK_In_Limited_Aggregate (Expr);
|
||||||
Check_Non_Static_Context (Expr);
|
Check_Non_Static_Context (Expr);
|
||||||
Check_Unset_Reference (Expr);
|
Check_Unset_Reference (Expr);
|
||||||
|
|
||||||
|
@ -3246,7 +3392,18 @@ package body Sem_Aggr is
|
||||||
C := First_Component (Typ);
|
C := First_Component (Typ);
|
||||||
while Present (C) loop
|
while Present (C) loop
|
||||||
if Chars (C) = Chars (Selectr) then
|
if Chars (C) = Chars (Selectr) then
|
||||||
exit;
|
|
||||||
|
-- If the context is an extension aggregate,
|
||||||
|
-- the component must not be inherited from
|
||||||
|
-- the ancestor part of the aggregate.
|
||||||
|
|
||||||
|
if Nkind (N) /= N_Extension_Aggregate
|
||||||
|
or else
|
||||||
|
Scope (Original_Record_Component (C)) /=
|
||||||
|
Etype (Ancestor_Part (N))
|
||||||
|
then
|
||||||
|
exit;
|
||||||
|
end if;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
Next_Component (C);
|
Next_Component (C);
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
-- --
|
-- --
|
||||||
-- B o d y --
|
-- B o d y --
|
||||||
-- --
|
-- --
|
||||||
-- Copyright (C) 1996-2007, Free Software Foundation, Inc. --
|
-- Copyright (C) 1996-2008, Free Software Foundation, Inc. --
|
||||||
-- --
|
-- --
|
||||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
-- 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- --
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||||
|
@ -268,10 +268,7 @@ package body Sem_Case is
|
||||||
-- For character, or wide [wide] character. If 7-bit ASCII graphic
|
-- For character, or wide [wide] character. If 7-bit ASCII graphic
|
||||||
-- range, then build and return appropriate character literal name
|
-- range, then build and return appropriate character literal name
|
||||||
|
|
||||||
if Rtp = Standard_Character
|
if Is_Standard_Character_Type (Ctype) then
|
||||||
or else Rtp = Standard_Wide_Character
|
|
||||||
or else Rtp = Standard_Wide_Wide_Character
|
|
||||||
then
|
|
||||||
C := UI_To_Int (Value);
|
C := UI_To_Int (Value);
|
||||||
|
|
||||||
if C in 16#20# .. 16#7E# then
|
if C in 16#20# .. 16#7E# then
|
||||||
|
@ -425,12 +422,7 @@ package body Sem_Case is
|
||||||
-- of literals to search. Instead, a N_Character_Literal node
|
-- of literals to search. Instead, a N_Character_Literal node
|
||||||
-- is created with the appropriate Char_Code and Chars fields.
|
-- is created with the appropriate Char_Code and Chars fields.
|
||||||
|
|
||||||
if Root_Type (Choice_Type) = Standard_Character
|
if Is_Standard_Character_Type (Choice_Type) then
|
||||||
or else
|
|
||||||
Root_Type (Choice_Type) = Standard_Wide_Character
|
|
||||||
or else
|
|
||||||
Root_Type (Choice_Type) = Standard_Wide_Wide_Character
|
|
||||||
then
|
|
||||||
Set_Character_Literal_Name (Char_Code (UI_To_Int (Value)));
|
Set_Character_Literal_Name (Char_Code (UI_To_Int (Value)));
|
||||||
Lit := New_Node (N_Character_Literal, Loc);
|
Lit := New_Node (N_Character_Literal, Loc);
|
||||||
Set_Chars (Lit, Name_Find);
|
Set_Chars (Lit, Name_Find);
|
||||||
|
|
Loading…
Reference in New Issue