with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Itypes; use Itypes;
with Lib.Xref; use Lib.Xref;
with Namet; use Namet;
with Nmake; use Nmake;
with Nlists; use Nlists;
with Opt; use Opt;
with Sem; use Sem;
with Sem_Cat; use Sem_Cat;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sem_Type; use Sem_Type;
with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stringt; use Stringt;
with Stand; use Stand;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
package body Sem_Aggr is
type Case_Bounds is record
Choice_Lo : Node_Id;
Choice_Hi : Node_Id;
Choice_Node : Node_Id;
end record;
type Case_Table_Type is array (Nat range <>) of Case_Bounds;
procedure Sort_Case_Table (Case_Table : in out Case_Table_Type);
procedure Check_Can_Never_Be_Null (Typ : Entity_Id; Expr : Node_Id);
procedure Resolve_Record_Aggregate (N : Node_Id; Typ : Entity_Id);
procedure Check_Misspelled_Component
(Elements : Elist_Id;
Component : Node_Id);
procedure Check_Static_Discriminated_Subtype (T : Entity_Id; V : Node_Id);
function Resolve_Array_Aggregate
(N : Node_Id;
Index : Node_Id;
Index_Constr : Node_Id;
Component_Typ : Entity_Id;
Others_Allowed : Boolean)
return Boolean;
function Array_Aggr_Subtype (N : Node_Id; Typ : Node_Id) return Entity_Id;
procedure Aggregate_Constraint_Checks
(Exp : Node_Id;
Check_Typ : Entity_Id);
procedure Make_String_Into_Aggregate (N : Node_Id);
procedure Aggregate_Constraint_Checks
(Exp : Node_Id;
Check_Typ : Entity_Id)
is
Exp_Typ : constant Entity_Id := Etype (Exp);
begin
if Raises_Constraint_Error (Exp) then
return;
end if;
if not Expander_Active or else In_Default_Expression then
return;
end if;
if Has_Discriminants (Exp_Typ) then
Apply_Discriminant_Check (Exp, Check_Typ);
elsif Is_Array_Type (Exp_Typ) then
Apply_Length_Check (Exp, Check_Typ);
elsif Is_Scalar_Type (Exp_Typ)
and then Compile_Time_Known_Value (Exp)
then
if Is_Out_Of_Range (Exp, Base_Type (Check_Typ)) then
Apply_Compile_Time_Constraint_Error
(Exp, "value not in range of}?", CE_Range_Check_Failed,
Ent => Base_Type (Check_Typ),
Typ => Base_Type (Check_Typ));
elsif Is_Out_Of_Range (Exp, Check_Typ) then
Apply_Compile_Time_Constraint_Error
(Exp, "value not in range of}?", CE_Range_Check_Failed,
Ent => Check_Typ,
Typ => Check_Typ);
elsif not Range_Checks_Suppressed (Check_Typ) then
Apply_Scalar_Range_Check (Exp, Check_Typ);
end if;
elsif (Is_Scalar_Type (Exp_Typ)
or else Nkind (Exp) = N_String_Literal)
and then Exp_Typ /= Check_Typ
then
if Is_Entity_Name (Exp)
and then Ekind (Entity (Exp)) = E_Constant
then
if (Is_Entity_Name (Type_Low_Bound (Check_Typ))
and then Entity (Exp) = Entity (Type_Low_Bound (Check_Typ)))
or else (Is_Entity_Name (Type_High_Bound (Check_Typ))
and then Entity (Exp) = Entity (Type_High_Bound (Check_Typ)))
then
return;
else
Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
Analyze_And_Resolve (Exp, Check_Typ);
Check_Unset_Reference (Exp);
end if;
else
Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
Analyze_And_Resolve (Exp, Check_Typ);
Check_Unset_Reference (Exp);
end if;
elsif Is_Access_Type (Check_Typ)
and then ((Is_Local_Anonymous_Access (Check_Typ))
or else (Can_Never_Be_Null (Check_Typ)
and then not Can_Never_Be_Null (Exp_Typ)))
then
Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
Analyze_And_Resolve (Exp, Check_Typ);
Check_Unset_Reference (Exp);
end if;
end Aggregate_Constraint_Checks;
function Array_Aggr_Subtype
(N : Node_Id;
Typ : Entity_Id)
return Entity_Id
is
Aggr_Dimension : constant Pos := Number_Dimensions (Typ);
Aggr_Range : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty);
Aggr_Low : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty);
Aggr_High : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty);
Is_Fully_Positional : Boolean := True;
procedure Collect_Aggr_Bounds (N : Node_Id; Dim : Pos);
procedure Collect_Aggr_Bounds (N : Node_Id; Dim : Pos) is
This_Range : constant Node_Id := Aggregate_Bounds (N);
This_Low : constant Node_Id := Low_Bound (Aggregate_Bounds (N));
This_High : constant Node_Id := High_Bound (Aggregate_Bounds (N));
Assoc : Node_Id;
Expr : Node_Id;
begin
if No (Aggr_Range (Dim)) then
Aggr_Low (Dim) := This_Low;
Aggr_High (Dim) := This_High;
Aggr_Range (Dim) := This_Range;
else
if Compile_Time_Known_Value (This_Low) then
if not Compile_Time_Known_Value (Aggr_Low (Dim)) then
Aggr_Low (Dim) := This_Low;
elsif Expr_Value (This_Low) /= Expr_Value (Aggr_Low (Dim)) then
Set_Raises_Constraint_Error (N);
Error_Msg_N ("sub-aggregate low bound mismatch?", N);
Error_Msg_N
("\Constraint_Error will be raised at run-time?", N);
end if;
end if;
if Compile_Time_Known_Value (This_High) then
if not Compile_Time_Known_Value (Aggr_High (Dim)) then
Aggr_High (Dim) := This_High;
elsif
Expr_Value (This_High) /= Expr_Value (Aggr_High (Dim))
then
Set_Raises_Constraint_Error (N);
Error_Msg_N ("sub-aggregate high bound mismatch?", N);
Error_Msg_N
("\Constraint_Error will be raised at run-time?", N);
end if;
end if;
end if;
if Dim < Aggr_Dimension then
if Present (Expressions (N)) then
Expr := First (Expressions (N));
while Present (Expr) loop
Collect_Aggr_Bounds (Expr, Dim + 1);
Next (Expr);
end loop;
end if;
if Present (Component_Associations (N)) then
Is_Fully_Positional := False;
Assoc := First (Component_Associations (N));
while Present (Assoc) loop
Expr := Expression (Assoc);
Collect_Aggr_Bounds (Expr, Dim + 1);
Next (Assoc);
end loop;
end if;
end if;
end Collect_Aggr_Bounds;
Itype : Entity_Id;
Index_Constraints : constant List_Id := New_List;
begin
Set_Parent (Index_Constraints, N);
Collect_Aggr_Bounds (N, 1);
for J in 1 .. Aggr_Dimension loop
Create_Index : declare
Index_Base : constant Entity_Id :=
Base_Type (Etype (Aggr_Range (J)));
Index_Typ : Entity_Id;
begin
Index_Typ := Create_Itype (Subtype_Kind (Ekind (Index_Base)), N);
Set_Etype (Index_Typ, Index_Base);
if Is_Character_Type (Index_Base) then
Set_Is_Character_Type (Index_Typ);
end if;
Set_Size_Info (Index_Typ, (Index_Base));
Set_RM_Size (Index_Typ, RM_Size (Index_Base));
Set_First_Rep_Item (Index_Typ, First_Rep_Item (Index_Base));
Set_Scalar_Range (Index_Typ, Aggr_Range (J));
if Is_Discrete_Or_Fixed_Point_Type (Index_Typ) then
Set_RM_Size (Index_Typ, UI_From_Int (Minimum_Size (Index_Typ)));
end if;
Set_Etype (Aggr_Range (J), Index_Typ);
Append (Aggr_Range (J), To => Index_Constraints);
end Create_Index;
end loop;
Itype := Create_Itype (E_Array_Subtype, N);
Set_First_Rep_Item (Itype, First_Rep_Item (Typ));
Set_Convention (Itype, Convention (Typ));
Set_Depends_On_Private (Itype, Has_Private_Component (Typ));
Set_Etype (Itype, Base_Type (Typ));
Set_Has_Alignment_Clause (Itype, Has_Alignment_Clause (Typ));
Set_Is_Aliased (Itype, Is_Aliased (Typ));
Set_Depends_On_Private (Itype, Depends_On_Private (Typ));
Copy_Suppress_Status (Index_Check, Typ, Itype);
Copy_Suppress_Status (Length_Check, Typ, Itype);
Set_First_Index (Itype, First (Index_Constraints));
Set_Is_Constrained (Itype, True);
Set_Is_Internal (Itype, True);
Init_Size_Align (Itype);
Set_Size_Known_At_Compile_Time (Itype,
Is_Fully_Positional
and then Comes_From_Source (N)
and then Size_Known_At_Compile_Time (Component_Type (Typ)));
if Is_Packed (Itype) and then not In_Default_Expression
and then Expander_Active
then
Freeze_Itype (Itype, N);
end if;
return Itype;
end Array_Aggr_Subtype;
procedure Check_Misspelled_Component
(Elements : Elist_Id;
Component : Node_Id)
is
Max_Suggestions : constant := 2;
Nr_Of_Suggestions : Natural := 0;
Suggestion_1 : Entity_Id := Empty;
Suggestion_2 : Entity_Id := Empty;
Component_Elmt : Elmt_Id;
begin
Get_Name_String (Chars (Component));
declare
S : constant String (1 .. Name_Len) :=
Name_Buffer (1 .. Name_Len);
begin
Component_Elmt := First_Elmt (Elements);
while Nr_Of_Suggestions <= Max_Suggestions
and then Present (Component_Elmt)
loop
Get_Name_String (Chars (Node (Component_Elmt)));
if Is_Bad_Spelling_Of (Name_Buffer (1 .. Name_Len), S) then
Nr_Of_Suggestions := Nr_Of_Suggestions + 1;
case Nr_Of_Suggestions is
when 1 => Suggestion_1 := Node (Component_Elmt);
when 2 => Suggestion_2 := Node (Component_Elmt);
when others => exit;
end case;
end if;
Next_Elmt (Component_Elmt);
end loop;
if Nr_Of_Suggestions = 1 then
Error_Msg_NE ("\possible misspelling of&",
Component, Suggestion_1);
elsif Nr_Of_Suggestions = 2 then
Error_Msg_Node_2 := Suggestion_2;
Error_Msg_NE ("\possible misspelling of& or&",
Component, Suggestion_1);
end if;
end;
end Check_Misspelled_Component;
procedure Check_Static_Discriminated_Subtype (T : Entity_Id; V : Node_Id) is
Disc : constant Entity_Id := First_Discriminant (T);
Comp : Entity_Id;
Ind : Entity_Id;
begin
if Has_Record_Rep_Clause (T) then
return;
elsif Present (Next_Discriminant (Disc)) then
return;
elsif Nkind (V) /= N_Integer_Literal then
return;
elsif Is_Access_Type (Etype (Disc)) then
null;
elsif not
(Compile_Time_Known_Value (Type_Low_Bound (Etype (Disc)))
and then
Compile_Time_Known_Value (Type_High_Bound (Etype (Disc))))
then
return;
end if;
Comp := First_Component (T);
while Present (Comp) loop
if Is_Scalar_Type (Etype (Comp)) then
null;
elsif Is_Private_Type (Etype (Comp))
and then Present (Full_View (Etype (Comp)))
and then Is_Scalar_Type (Full_View (Etype (Comp)))
then
null;
elsif Is_Array_Type (Etype (Comp)) then
if Is_Bit_Packed_Array (Etype (Comp)) then
return;
end if;
Ind := First_Index (Etype (Comp));
while Present (Ind) loop
if Nkind (Ind) /= N_Range
or else Nkind (Low_Bound (Ind)) /= N_Integer_Literal
or else Nkind (High_Bound (Ind)) /= N_Integer_Literal
then
return;
end if;
Next_Index (Ind);
end loop;
else
return;
end if;
Next_Component (Comp);
end loop;
Set_Size_Known_At_Compile_Time (T);
end Check_Static_Discriminated_Subtype;
procedure Make_String_Into_Aggregate (N : Node_Id) is
Exprs : constant List_Id := New_List;
Loc : constant Source_Ptr := Sloc (N);
Str : constant String_Id := Strval (N);
Strlen : constant Nat := String_Length (Str);
C : Char_Code;
C_Node : Node_Id;
New_N : Node_Id;
P : Source_Ptr;
begin
P := Loc + 1;
for J in 1 .. Strlen loop
C := Get_String_Char (Str, J);
Set_Character_Literal_Name (C);
C_Node :=
Make_Character_Literal (P,
Chars => Name_Find,
Char_Literal_Value => UI_From_CC (C));
Set_Etype (C_Node, Any_Character);
Append_To (Exprs, C_Node);
P := P + 1;
end loop;
New_N := Make_Aggregate (Loc, Expressions => Exprs);
Set_Analyzed (New_N);
Set_Etype (New_N, Any_Composite);
Rewrite (N, New_N);
end Make_String_Into_Aggregate;
procedure Resolve_Aggregate (N : Node_Id; Typ : Entity_Id) is
Pkind : constant Node_Kind := Nkind (Parent (N));
Aggr_Subtyp : Entity_Id;
begin
if not Support_Aggregates_On_Target
and then Comes_From_Source (N)
and then (not Known_Static_Esize (Typ) or else Esize (Typ) > 64)
then
Error_Msg_CRT ("aggregate", N);
end if;
if Is_Limited_Composite (Typ) then
Error_Msg_N ("aggregate type cannot have limited component", N);
Explain_Limited_Type (Typ, N);
elsif Is_Limited_Type (Typ)
and Ada_Version < Ada_05
then
Error_Msg_N ("aggregate type cannot be limited", N);
Explain_Limited_Type (Typ, N);
elsif Is_Class_Wide_Type (Typ) then
Error_Msg_N ("type of aggregate cannot be class-wide", N);
elsif Typ = Any_String
or else Typ = Any_Composite
then
Error_Msg_N ("no unique type for aggregate", N);
Set_Etype (N, Any_Composite);
elsif Is_Array_Type (Typ) and then Null_Record_Present (N) then
Error_Msg_N ("null record forbidden in array aggregate", N);
elsif Is_Record_Type (Typ) then
Resolve_Record_Aggregate (N, Typ);
elsif Is_Array_Type (Typ) then
if Number_Dimensions (Typ) = 1
and then
(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 not Is_Limited_Composite (Typ)
and then not Is_Private_Composite (Typ)
and then not Is_Bit_Packed_Array (Typ)
and then Nkind (Original_Node (Parent (N))) /= N_String_Literal
and then Is_Static_Subtype (Component_Type (Typ))
then
declare
Expr : Node_Id;
begin
Expr := First (Expressions (N));
while Present (Expr) loop
exit when Nkind (Expr) /= N_Character_Literal;
Next (Expr);
end loop;
if No (Expr) then
Start_String;
Expr := First (Expressions (N));
while Present (Expr) loop
Store_String_Char (UI_To_CC (Char_Literal_Value (Expr)));
Next (Expr);
end loop;
Rewrite (N,
Make_String_Literal (Sloc (N), End_String));
Analyze_And_Resolve (N, Typ);
return;
end if;
end;
end if;
Array_Aggregate : declare
Aggr_Resolved : Boolean;
Aggr_Typ : constant Entity_Id := Etype (Typ);
begin
Set_Etype (N, Aggr_Typ);
if Is_Constrained (Typ) and then
(Pkind = N_Assignment_Statement or else
Pkind = N_Parameter_Association or else
Pkind = N_Function_Call or else
Pkind = N_Procedure_Call_Statement or else
Pkind = N_Generic_Association or else
Pkind = N_Formal_Object_Declaration or else
Pkind = N_Return_Statement or else
Pkind = N_Object_Declaration or else
Pkind = N_Component_Declaration or else
Pkind = N_Parameter_Specification or else
Pkind = N_Qualified_Expression or else
Pkind = N_Aggregate or else
Pkind = N_Extension_Aggregate or else
Pkind = N_Component_Association)
then
Aggr_Resolved :=
Resolve_Array_Aggregate
(N,
Index => First_Index (Aggr_Typ),
Index_Constr => First_Index (Typ),
Component_Typ => Component_Type (Typ),
Others_Allowed => True);
elsif not Expander_Active
and then Pkind = N_Assignment_Statement
then
Aggr_Resolved :=
Resolve_Array_Aggregate
(N,
Index => First_Index (Aggr_Typ),
Index_Constr => First_Index (Typ),
Component_Typ => Component_Type (Typ),
Others_Allowed => True);
else
Aggr_Resolved :=
Resolve_Array_Aggregate
(N,
Index => First_Index (Aggr_Typ),
Index_Constr => First_Index (Aggr_Typ),
Component_Typ => Component_Type (Typ),
Others_Allowed => False);
end if;
if not Aggr_Resolved then
Aggr_Subtyp := Any_Composite;
else
Aggr_Subtyp := Array_Aggr_Subtype (N, Typ);
end if;
Set_Etype (N, Aggr_Subtyp);
end Array_Aggregate;
elsif Is_Private_Type (Typ)
and then Present (Full_View (Typ))
and then In_Inlined_Body
and then Is_Composite_Type (Full_View (Typ))
then
Resolve (N, Full_View (Typ));
else
Error_Msg_N ("illegal context for aggregate", N);
end if;
if Raises_Constraint_Error (N) then
Aggr_Subtyp := Etype (N);
Rewrite (N,
Make_Raise_Constraint_Error (Sloc (N),
Reason => CE_Range_Check_Failed));
Set_Raises_Constraint_Error (N);
Set_Etype (N, Aggr_Subtyp);
Set_Analyzed (N);
end if;
end Resolve_Aggregate;
function Resolve_Array_Aggregate
(N : Node_Id;
Index : Node_Id;
Index_Constr : Node_Id;
Component_Typ : Entity_Id;
Others_Allowed : Boolean)
return Boolean
is
Loc : constant Source_Ptr := Sloc (N);
Failure : constant Boolean := False;
Success : constant Boolean := True;
Index_Typ : constant Entity_Id := Etype (Index);
Index_Typ_Low : constant Node_Id := Type_Low_Bound (Index_Typ);
Index_Typ_High : constant Node_Id := Type_High_Bound (Index_Typ);
Index_Base : constant Entity_Id := Base_Type (Index_Typ);
Index_Base_Low : constant Node_Id := Type_Low_Bound (Index_Base);
Index_Base_High : constant Node_Id := Type_High_Bound (Index_Base);
function Add (Val : Uint; To : Node_Id) return Node_Id;
procedure Check_Bound (BH : Node_Id; AH : in out Node_Id);
procedure Check_Bounds (L, H : Node_Id; AL, AH : Node_Id);
procedure Check_Length (L, H : Node_Id; Len : Uint);
function Dynamic_Or_Null_Range (L, H : Node_Id) return Boolean;
procedure Get (Value : out Uint; From : Node_Id; OK : out Boolean);
function Resolve_Aggr_Expr
(Expr : Node_Id;
Single_Elmt : Boolean)
return Boolean;
function Add (Val : Uint; To : Node_Id) return Node_Id is
Expr_Pos : Node_Id;
Expr : Node_Id;
To_Pos : Node_Id;
begin
if Raises_Constraint_Error (To) then
return To;
end if;
if Compile_Time_Known_Value (To)
or else Nkind (To) = N_Integer_Literal
then
Expr_Pos := Make_Integer_Literal (Loc, Expr_Value (To) + Val);
Set_Is_Static_Expression (Expr_Pos);
Set_Etype (Expr_Pos, Etype (To));
Set_Analyzed (Expr_Pos, Analyzed (To));
if not Is_Enumeration_Type (Index_Typ) then
Expr := Expr_Pos;
else
Expr :=
Make_Attribute_Reference
(Loc,
Prefix => New_Reference_To (Index_Typ, Loc),
Attribute_Name => Name_Val,
Expressions => New_List (Expr_Pos));
end if;
return Expr;
end if;
if not Is_Enumeration_Type (Index_Base) then
Expr :=
Make_Op_Add (Loc,
Left_Opnd => Duplicate_Subexpr (To),
Right_Opnd => Make_Integer_Literal (Loc, Val));
else
To_Pos :=
Make_Attribute_Reference
(Loc,
Prefix => New_Reference_To (Index_Typ, Loc),
Attribute_Name => Name_Pos,
Expressions => New_List (Duplicate_Subexpr (To)));
Expr_Pos :=
Make_Op_Add (Loc,
Left_Opnd => To_Pos,
Right_Opnd => Make_Integer_Literal (Loc, Val));
Expr :=
Make_Attribute_Reference
(Loc,
Prefix => New_Reference_To (Index_Typ, Loc),
Attribute_Name => Name_Val,
Expressions => New_List (Expr_Pos));
end if;
return Expr;
end Add;
procedure Check_Bound (BH : Node_Id; AH : in out Node_Id) is
Val_BH : Uint;
Val_AH : Uint;
OK_BH : Boolean;
OK_AH : Boolean;
begin
Get (Value => Val_BH, From => BH, OK => OK_BH);
Get (Value => Val_AH, From => AH, OK => OK_AH);
if OK_BH and then OK_AH and then Val_BH < Val_AH then
Set_Raises_Constraint_Error (N);
Error_Msg_N ("upper bound out of range?", AH);
Error_Msg_N ("\Constraint_Error will be raised at run-time?", AH);
AH := Duplicate_Subexpr (BH);
end if;
end Check_Bound;
procedure Check_Bounds (L, H : Node_Id; AL, AH : Node_Id) is
Val_L : Uint;
Val_H : Uint;
Val_AL : Uint;
Val_AH : Uint;
OK_L : Boolean;
OK_H : Boolean;
OK_AL : Boolean;
OK_AH : Boolean;
begin
if Raises_Constraint_Error (N)
or else Dynamic_Or_Null_Range (AL, AH)
then
return;
end if;
Get (Value => Val_L, From => L, OK => OK_L);
Get (Value => Val_H, From => H, OK => OK_H);
Get (Value => Val_AL, From => AL, OK => OK_AL);
Get (Value => Val_AH, From => AH, OK => OK_AH);
if OK_L and then Val_L > Val_AL then
Set_Raises_Constraint_Error (N);
Error_Msg_N ("lower bound of aggregate out of range?", N);
Error_Msg_N ("\Constraint_Error will be raised at run-time?", N);
end if;
if OK_H and then Val_H < Val_AH then
Set_Raises_Constraint_Error (N);
Error_Msg_N ("upper bound of aggregate out of range?", N);
Error_Msg_N ("\Constraint_Error will be raised at run-time?", N);
end if;
end Check_Bounds;
procedure Check_Length (L, H : Node_Id; Len : Uint) is
Val_L : Uint;
Val_H : Uint;
OK_L : Boolean;
OK_H : Boolean;
Range_Len : Uint;
begin
if Raises_Constraint_Error (N) then
return;
end if;
Get (Value => Val_L, From => L, OK => OK_L);
Get (Value => Val_H, From => H, OK => OK_H);
if not OK_L or else not OK_H then
return;
end if;
if Val_L > Val_H then
Range_Len := Uint_0;
else
Range_Len := Val_H - Val_L + 1;
end if;
if Range_Len < Len then
Set_Raises_Constraint_Error (N);
Error_Msg_N ("too many elements?", N);
Error_Msg_N ("\Constraint_Error will be raised at run-time?", N);
end if;
end Check_Length;
function Dynamic_Or_Null_Range (L, H : Node_Id) return Boolean is
Val_L : Uint;
Val_H : Uint;
OK_L : Boolean;
OK_H : Boolean;
begin
Get (Value => Val_L, From => L, OK => OK_L);
Get (Value => Val_H, From => H, OK => OK_H);
return not OK_L or else not OK_H
or else not Is_OK_Static_Expression (L)
or else not Is_OK_Static_Expression (H)
or else Val_L > Val_H;
end Dynamic_Or_Null_Range;
procedure Get (Value : out Uint; From : Node_Id; OK : out Boolean) is
begin
OK := True;
if Compile_Time_Known_Value (From) then
Value := Expr_Value (From);
elsif Nkind (From) = N_Attribute_Reference
and then Attribute_Name (From) = Name_Val
and then Compile_Time_Known_Value (First (Expressions (From)))
then
Value := Expr_Value (First (Expressions (From)));
else
Value := Uint_0;
OK := False;
end if;
end Get;
function Resolve_Aggr_Expr
(Expr : Node_Id;
Single_Elmt : Boolean)
return Boolean
is
Nxt_Ind : constant Node_Id := Next_Index (Index);
Nxt_Ind_Constr : constant Node_Id := Next_Index (Index_Constr);
Resolution_OK : Boolean := True;
begin
if Present (Nxt_Ind) then
if Nkind (Expr) /= N_Aggregate then
if Is_Character_Type (Component_Typ)
and then No (Next_Index (Nxt_Ind))
and then (Nkind (Expr) = N_String_Literal
or else Nkind (Expr) = N_Operator_Symbol)
then
if Paren_Count (Expr) /= 0 then
Error_Msg_N ("no parenthesis allowed here", Expr);
end if;
Make_String_Into_Aggregate (Expr);
else
Error_Msg_N ("nested array aggregate expected", Expr);
return Failure;
end if;
end if;
Set_Etype (Expr, Etype (N));
Resolution_OK := Resolve_Array_Aggregate
(Expr, Nxt_Ind, Nxt_Ind_Constr, Component_Typ, Others_Allowed);
elsif Single_Elmt
or else not Expander_Active
or else In_Default_Expression
then
Analyze_And_Resolve (Expr, Component_Typ);
Check_Non_Static_Context (Expr);
Aggregate_Constraint_Checks (Expr, Component_Typ);
Check_Unset_Reference (Expr);
end if;
if Raises_Constraint_Error (Expr)
and then Nkind (Parent (Expr)) /= N_Component_Association
then
Set_Raises_Constraint_Error (N);
end if;
return Resolution_OK;
end Resolve_Aggr_Expr;
Assoc : Node_Id;
Choice : Node_Id;
Expr : Node_Id;
Who_Cares : Node_Id;
Aggr_Low : Node_Id := Empty;
Aggr_High : Node_Id := Empty;
Choices_Low : Node_Id := Empty;
Choices_High : Node_Id := Empty;
Nb_Elements : Uint := Uint_0;
Others_Present : Boolean := False;
Nb_Choices : Nat := 0;
Nb_Discrete_Choices : Nat := 0;
Case_Table_Size : Nat;
begin
if Present (Component_Associations (N)) then
Assoc := First (Component_Associations (N));
while Present (Assoc) loop
Choice := First (Choices (Assoc));
while Present (Choice) loop
if Nkind (Choice) = N_Others_Choice then
Others_Present := True;
if Choice /= First (Choices (Assoc))
or else Present (Next (Choice))
then
Error_Msg_N
("OTHERS must appear alone in a choice list", Choice);
return Failure;
end if;
if Present (Next (Assoc)) then
Error_Msg_N
("OTHERS must appear last in an aggregate", Choice);
return Failure;
end if;
if Ada_Version = Ada_83
and then Assoc /= First (Component_Associations (N))
and then (Nkind (Parent (N)) = N_Assignment_Statement
or else
Nkind (Parent (N)) = N_Object_Declaration)
then
Error_Msg_N
("(Ada 83) illegal context for OTHERS choice", N);
end if;
end if;
Nb_Choices := Nb_Choices + 1;
Next (Choice);
end loop;
Next (Assoc);
end loop;
end if;
if Present (Expressions (N))
and then (Nb_Choices > 1
or else (Nb_Choices = 1 and then not Others_Present))
then
Error_Msg_N
("named association cannot follow positional association",
First (Choices (First (Component_Associations (N)))));
return Failure;
end if;
if Others_Present and then not Others_Allowed then
Error_Msg_N
("OTHERS choice not allowed here",
First (Choices (First (Component_Associations (N)))));
return Failure;
end if;
if Etype (Index_Typ) = Any_Type then
return Failure;
end if;
if No (Expressions (N)) then
if Others_Present then
Case_Table_Size := Nb_Choices - 1;
else
Case_Table_Size := Nb_Choices;
end if;
Step_2 : declare
Low : Node_Id;
High : Node_Id;
Hi_Val : Uint;
Lo_Val : Uint;
Missing_Values : Boolean;
S_Low : Node_Id := Empty;
S_High : Node_Id := Empty;
Table : Case_Table_Type (1 .. Case_Table_Size);
Single_Choice : Boolean;
Prev_Nb_Discrete_Choices : Nat;
begin
Assoc := First (Component_Associations (N));
while Present (Assoc) loop
Prev_Nb_Discrete_Choices := Nb_Discrete_Choices;
Choice := First (Choices (Assoc));
loop
Analyze (Choice);
if Nkind (Choice) = N_Others_Choice then
Single_Choice := False;
exit;
elsif Is_Entity_Name (Choice) and then
Is_Type (Entity (Choice))
then
if Base_Type (Entity (Choice)) /= Index_Base then
Error_Msg_N
("invalid subtype mark in aggregate choice",
Choice);
return Failure;
end if;
elsif Nkind (Choice) = N_Subtype_Indication then
Resolve_Discrete_Subtype_Indication (Choice, Index_Base);
Get_Index_Bounds (Subtype_Mark (Choice), S_Low, S_High);
Get_Index_Bounds (Choice, Low, High);
Check_Bounds (S_Low, S_High, Low, High);
else Resolve (Choice, Index_Base);
Check_Unset_Reference (Choice);
Check_Non_Static_Context (Choice);
Set_Do_Range_Check (Choice, False);
end if;
if Etype (Choice) = Any_Type then
return Failure;
elsif Nkind (Choice) = N_Raise_Constraint_Error then
Set_Raises_Constraint_Error (N);
Get_Index_Bounds (Original_Node (Choice), Low, High);
else
Get_Index_Bounds (Choice, Low, High);
end if;
if (Dynamic_Or_Null_Range (Low, High)
or else (Nkind (Choice) = N_Subtype_Indication
and then
Dynamic_Or_Null_Range (S_Low, S_High)))
and then Nb_Choices /= 1
then
Error_Msg_N
("dynamic or empty choice in aggregate " &
"must be the only choice", Choice);
return Failure;
end if;
Nb_Discrete_Choices := Nb_Discrete_Choices + 1;
Table (Nb_Discrete_Choices).Choice_Lo := Low;
Table (Nb_Discrete_Choices).Choice_Hi := High;
Next (Choice);
if No (Choice) then
Single_Choice :=
(Nb_Discrete_Choices = Prev_Nb_Discrete_Choices + 1)
and then (Low = High);
exit;
end if;
end loop;
if Ada_Version >= Ada_05
and then Nkind (Expression (Assoc)) = N_Null
then
Check_Can_Never_Be_Null (Etype (N), Expression (Assoc));
end if;
if Box_Present (Assoc) then
null;
elsif not Resolve_Aggr_Expr (Expression (Assoc),
Single_Elmt => Single_Choice)
then
return Failure;
end if;
Next (Assoc);
end loop;
if Nb_Discrete_Choices > 1 then
Sort_Case_Table (Table);
Missing_Values := False;
Outer : for J in 1 .. Nb_Discrete_Choices - 1 loop
if Expr_Value (Table (J).Choice_Hi) >=
Expr_Value (Table (J + 1).Choice_Lo)
then
Error_Msg_N
("duplicate choice values in array aggregate",
Table (J).Choice_Hi);
return Failure;
elsif not Others_Present then
Hi_Val := Expr_Value (Table (J).Choice_Hi);
Lo_Val := Expr_Value (Table (J + 1).Choice_Lo);
if Lo_Val - Hi_Val > 1 then
if not Missing_Values then
Error_Msg_N
("missing index value(s) in array aggregate", N);
Missing_Values := True;
end if;
Lo_Val := Lo_Val - 1;
Hi_Val := Hi_Val + 1;
if Is_Enumeration_Type (Index_Typ) then
Error_Msg_Name_1 :=
Chars
(Get_Enum_Lit_From_Pos
(Index_Typ, Hi_Val, Loc));
if Lo_Val = Hi_Val then
Error_Msg_N ("\ %", N);
else
Error_Msg_Name_2 :=
Chars
(Get_Enum_Lit_From_Pos
(Index_Typ, Lo_Val, Loc));
Error_Msg_N ("\ % .. %", N);
end if;
else
Error_Msg_Uint_1 := Hi_Val;
if Lo_Val = Hi_Val then
Error_Msg_N ("\ ^", N);
else
Error_Msg_Uint_2 := Lo_Val;
Error_Msg_N ("\ ^ .. ^", N);
end if;
end if;
end if;
end if;
end loop Outer;
if Missing_Values then
Set_Etype (N, Any_Composite);
return Failure;
end if;
end if;
if Nb_Discrete_Choices > 0 then
Choices_Low := Table (1).Choice_Lo;
Choices_High := Table (Nb_Discrete_Choices).Choice_Hi;
end if;
if Others_Present then
Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High);
else
Aggr_Low := Choices_Low;
Aggr_High := Choices_High;
end if;
end Step_2;
else
Expr := First (Expressions (N));
Nb_Elements := Uint_0;
while Present (Expr) loop
Nb_Elements := Nb_Elements + 1;
if Ada_Version >= Ada_05
and then Nkind (Expr) = N_Null
then
Check_Can_Never_Be_Null (Etype (N), Expr);
end if;
if not Resolve_Aggr_Expr (Expr, Single_Elmt => True) then
return Failure;
end if;
Next (Expr);
end loop;
if Others_Present then
Assoc := Last (Component_Associations (N));
if Ada_Version >= Ada_05
and then Nkind (Assoc) = N_Null
then
Check_Can_Never_Be_Null (Etype (N), Expression (Assoc));
end if;
if Box_Present (Assoc) then
null;
elsif not Resolve_Aggr_Expr (Expression (Assoc),
Single_Elmt => False)
then
return Failure;
end if;
end if;
if Others_Present then
Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High);
else
if Others_Allowed then
Get_Index_Bounds (Index_Constr, Aggr_Low, Who_Cares);
else
Aggr_Low := Index_Typ_Low;
end if;
Aggr_High := Add (Nb_Elements - 1, To => Aggr_Low);
Check_Bound (Index_Base_High, Aggr_High);
end if;
end if;
Check_Bounds (Index_Typ_Low, Index_Typ_High, Aggr_Low, Aggr_High);
Check_Bounds (Index_Base_Low, Index_Base_High, Aggr_Low, Aggr_High);
if Others_Present and then Nb_Discrete_Choices > 0 then
Check_Bounds (Aggr_Low, Aggr_High, Choices_Low, Choices_High);
Check_Bounds (Index_Typ_Low, Index_Typ_High,
Choices_Low, Choices_High);
Check_Bounds (Index_Base_Low, Index_Base_High,
Choices_Low, Choices_High);
elsif Others_Present and then Nb_Elements > 0 then
Check_Length (Aggr_Low, Aggr_High, Nb_Elements);
Check_Length (Index_Typ_Low, Index_Typ_High, Nb_Elements);
Check_Length (Index_Base_Low, Index_Base_High, Nb_Elements);
end if;
if Raises_Constraint_Error (Aggr_Low)
or else Raises_Constraint_Error (Aggr_High)
then
Set_Raises_Constraint_Error (N);
end if;
Aggr_Low := Duplicate_Subexpr (Aggr_Low);
if Others_Present or else Nb_Discrete_Choices > 0 then
Aggr_High := Duplicate_Subexpr (Aggr_High);
if Etype (Aggr_High) = Universal_Integer then
Set_Analyzed (Aggr_High, False);
end if;
end if;
Set_Aggregate_Bounds
(N, Make_Range (Loc, Low_Bound => Aggr_Low, High_Bound => Aggr_High));
Set_Parent (Aggregate_Bounds (N), N);
Analyze_And_Resolve (Aggregate_Bounds (N), Index_Typ);
Check_Unset_Reference (Aggregate_Bounds (N));
if not Others_Present and then Nb_Discrete_Choices = 0 then
Set_High_Bound (Aggregate_Bounds (N),
Duplicate_Subexpr (High_Bound (Aggregate_Bounds (N))));
end if;
return Success;
end Resolve_Array_Aggregate;
procedure Resolve_Extension_Aggregate (N : Node_Id; Typ : Entity_Id) is
A : constant Node_Id := Ancestor_Part (N);
A_Type : Entity_Id;
I : Interp_Index;
It : Interp;
function Valid_Ancestor_Type return Boolean;
function Valid_Ancestor_Type return Boolean is
Imm_Type : Entity_Id;
begin
Imm_Type := Base_Type (Typ);
while Is_Derived_Type (Imm_Type)
and then Etype (Imm_Type) /= Base_Type (A_Type)
loop
Imm_Type := Etype (Base_Type (Imm_Type));
end loop;
if Etype (Imm_Type) /= Base_Type (A_Type) then
Error_Msg_NE ("expect ancestor type of &", A, Typ);
return False;
else
return True;
end if;
end Valid_Ancestor_Type;
begin
Analyze (A);
if not Is_Tagged_Type (Typ) then
Error_Msg_N ("type of extension aggregate must be tagged", N);
return;
elsif Is_Limited_Type (Typ) then
if Ada_Version < Ada_05 then
Error_Msg_N ("aggregate type cannot be limited", N);
Explain_Limited_Type (Typ, N);
return;
end if;
elsif Is_Class_Wide_Type (Typ) then
Error_Msg_N ("aggregate cannot be of a class-wide type", N);
return;
end if;
if Is_Entity_Name (A)
and then Is_Type (Entity (A))
then
A_Type := Get_Full_View (Entity (A));
if Valid_Ancestor_Type then
Set_Entity (A, A_Type);
Set_Etype (A, A_Type);
Validate_Ancestor_Part (N);
Resolve_Record_Aggregate (N, Typ);
end if;
elsif Nkind (A) /= N_Aggregate then
if Is_Overloaded (A) then
A_Type := Any_Type;
Get_First_Interp (A, I, It);
while Present (It.Typ) loop
if Is_Tagged_Type (It.Typ)
and then not Is_Limited_Type (It.Typ)
then
if A_Type /= Any_Type then
Error_Msg_N ("cannot resolve expression", A);
return;
else
A_Type := It.Typ;
end if;
end if;
Get_Next_Interp (I, It);
end loop;
if A_Type = Any_Type then
Error_Msg_N
("ancestor part must be non-limited tagged type", A);
return;
end if;
else
A_Type := Etype (A);
end if;
if Valid_Ancestor_Type then
Resolve (A, A_Type);
Check_Unset_Reference (A);
Check_Non_Static_Context (A);
if Is_Class_Wide_Type (Etype (A))
and then Nkind (Original_Node (A)) = N_Function_Call
then
Error_Msg_N ("ancestor part must be statically tagged", A);
else
Resolve_Record_Aggregate (N, Typ);
end if;
end if;
else
Error_Msg_N (" No unique type for this aggregate", A);
end if;
end Resolve_Extension_Aggregate;
procedure Resolve_Record_Aggregate (N : Node_Id; Typ : Entity_Id) is
Assoc : Node_Id;
Expr : Node_Id;
Positional_Expr : Node_Id;
Component : Entity_Id;
Component_Elmt : Elmt_Id;
Components : constant Elist_Id := New_Elmt_List;
New_Assoc_List : constant List_Id := New_List;
New_Assoc : Node_Id;
Others_Etype : Entity_Id := Empty;
Is_Box_Present : Boolean := False;
Others_Box : Boolean := False;
procedure Add_Association
(Component : Entity_Id;
Expr : Node_Id;
Is_Box_Present : Boolean := False);
function Discr_Present (Discr : Entity_Id) return Boolean;
function Get_Value
(Compon : Node_Id;
From : List_Id;
Consider_Others_Choice : Boolean := False)
return Node_Id;
procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Node_Id);
procedure Add_Association
(Component : Entity_Id;
Expr : Node_Id;
Is_Box_Present : Boolean := False)
is
Choice_List : constant List_Id := New_List;
New_Assoc : Node_Id;
begin
Append (New_Occurrence_Of (Component, Sloc (Expr)), Choice_List);
New_Assoc :=
Make_Component_Association (Sloc (Expr),
Choices => Choice_List,
Expression => Expr,
Box_Present => Is_Box_Present);
Append (New_Assoc, New_Assoc_List);
end Add_Association;
function Discr_Present (Discr : Entity_Id) return Boolean is
Regular_Aggr : constant Boolean := Nkind (N) /= N_Extension_Aggregate;
Loc : Source_Ptr;
Ancestor : Node_Id;
Discr_Expr : Node_Id;
Ancestor_Typ : Entity_Id;
Orig_Discr : Entity_Id;
D : Entity_Id;
D_Val : Elmt_Id := No_Elmt;
Ancestor_Is_Subtyp : Boolean;
begin
if Regular_Aggr then
return True;
end if;
Ancestor := Ancestor_Part (N);
Ancestor_Typ := Etype (Ancestor);
Loc := Sloc (Ancestor);
Ancestor_Is_Subtyp :=
Is_Entity_Name (Ancestor) and then Is_Type (Entity (Ancestor));
if not Has_Discriminants (Ancestor_Typ) then
return True;
elsif Ancestor_Is_Subtyp
and then not Is_Constrained (Entity (Ancestor))
then
return True;
end if;
if Ancestor_Is_Subtyp then
D_Val := First_Elmt (Discriminant_Constraint (Entity (Ancestor)));
end if;
Orig_Discr := Original_Record_Component (Discr);
D := First_Discriminant (Ancestor_Typ);
while Present (D) loop
if Original_Record_Component (D) = Orig_Discr then
if Ancestor_Is_Subtyp then
Discr_Expr := New_Copy_Tree (Node (D_Val));
else
Discr_Expr :=
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Ancestor),
Selector_Name => New_Occurrence_Of (Discr, Loc));
end if;
Resolve_Aggr_Expr (Discr_Expr, Discr);
return False;
end if;
Next_Discriminant (D);
if Ancestor_Is_Subtyp then
Next_Elmt (D_Val);
end if;
end loop;
return True;
end Discr_Present;
function Get_Value
(Compon : Node_Id;
From : List_Id;
Consider_Others_Choice : Boolean := False)
return Node_Id
is
Assoc : Node_Id;
Expr : Node_Id := Empty;
Selector_Name : Node_Id;
procedure Check_Non_Limited_Type;
procedure Check_Non_Limited_Type is
begin
if Is_Limited_Type (Etype (Compon))
and then Comes_From_Source (Compon)
and then not In_Instance_Body
then
if Ada_Version >= Ada_05
and then Present (Expression (Assoc))
and then Nkind (Expression (Assoc)) = N_Aggregate
then
null;
else
Error_Msg_N
("initialization not allowed for limited types", N);
Explain_Limited_Type (Etype (Compon), Compon);
end if;
end if;
end Check_Non_Limited_Type;
begin
Is_Box_Present := False;
if Present (From) then
Assoc := First (From);
else
return Empty;
end if;
while Present (Assoc) loop
Selector_Name := First (Choices (Assoc));
while Present (Selector_Name) loop
if Nkind (Selector_Name) = N_Others_Choice then
if Consider_Others_Choice and then No (Expr) then
if Box_Present (Assoc) then
Others_Box := True;
Is_Box_Present := True;
if Expander_Active then
return New_Copy_Tree (Expression (Parent (Compon)));
else
return Expression (Parent (Compon));
end if;
else
Check_Non_Limited_Type;
if Present (Others_Etype) and then
Base_Type (Others_Etype) /= Base_Type (Etype
(Compon))
then
Error_Msg_N ("components in OTHERS choice must " &
"have same type", Selector_Name);
end if;
Others_Etype := Etype (Compon);
if Expander_Active then
return New_Copy_Tree (Expression (Assoc));
else
return Expression (Assoc);
end if;
end if;
end if;
elsif Chars (Compon) = Chars (Selector_Name) then
if No (Expr) then
if Ada_Version >= Ada_05
and then Nkind (Expression (Assoc)) = N_Null
then
Check_Can_Never_Be_Null (Compon, Expression (Assoc));
end if;
if Box_Present (Assoc) then
Is_Box_Present := True;
if Present (Next (Selector_Name)) then
Expr :=
New_Copy_Tree (Expression (Parent (Compon)));
else
Expr := Expression (Parent (Compon));
end if;
else
Check_Non_Limited_Type;
if Present (Next (Selector_Name)) then
Expr := New_Copy_Tree (Expression (Assoc));
else
Expr := Expression (Assoc);
end if;
end if;
Generate_Reference (Compon, Selector_Name);
else
Error_Msg_NE
("more than one value supplied for &",
Selector_Name, Compon);
end if;
end if;
Next (Selector_Name);
end loop;
Next (Assoc);
end loop;
return Expr;
end Get_Value;
procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Node_Id) is
New_C : Entity_Id := Component;
Expr_Type : Entity_Id := Empty;
function Has_Expansion_Delayed (Expr : Node_Id) return Boolean;
Relocate : Boolean;
function Has_Expansion_Delayed (Expr : Node_Id) return Boolean is
Kind : constant Node_Kind := Nkind (Expr);
begin
return ((Kind = N_Aggregate
or else Kind = N_Extension_Aggregate)
and then Present (Etype (Expr))
and then Is_Record_Type (Etype (Expr))
and then Expansion_Delayed (Expr))
or else (Kind = N_Qualified_Expression
and then Has_Expansion_Delayed (Expression (Expr)));
end Has_Expansion_Delayed;
begin
if Is_Elementary_Type (Etype (Component))
or else not Has_Discriminants (Etype (N))
then
Expr_Type := Etype (Component);
else
New_C := First_Component (Etype (N));
while Present (New_C) loop
if Chars (New_C) = Chars (Component) then
Expr_Type := Etype (New_C);
exit;
end if;
Next_Component (New_C);
end loop;
pragma Assert (Present (Expr_Type));
if Is_Array_Type (Expr_Type) then
declare
Index : Node_Id;
Orig_Index : Node_Id := First_Index (Etype (Component));
Unconstr_Index : Node_Id := First_Index (Etype (Expr_Type));
begin
Index := First_Index (Expr_Type);
while Present (Index) loop
if Depends_On_Discriminant (Orig_Index) then
Apply_Range_Check (Index, Etype (Unconstr_Index));
end if;
Next_Index (Index);
Next_Index (Orig_Index);
Next_Index (Unconstr_Index);
end loop;
end;
end if;
end if;
if No (Parent (Expr)) then
Set_Parent (Expr, N);
Relocate := False;
else
Relocate := True;
end if;
Analyze_And_Resolve (Expr, Expr_Type);
Check_Non_Static_Context (Expr);
Check_Unset_Reference (Expr);
if not Has_Expansion_Delayed (Expr) then
Aggregate_Constraint_Checks (Expr, Expr_Type);
end if;
if Raises_Constraint_Error (Expr) then
Set_Raises_Constraint_Error (N);
end if;
if Relocate then
Add_Association (New_C, Relocate_Node (Expr));
else
Add_Association (New_C, Expr);
end if;
end Resolve_Aggr_Expr;
begin
Set_Parent (New_Assoc_List, N);
if Is_Abstract (Typ) then
Error_Msg_N ("type of aggregate cannot be abstract", N);
end if;
if No (First_Entity (Typ)) and then Null_Record_Present (N) then
Set_Etype (N, Typ);
return;
elsif Present (First_Entity (Typ))
and then Null_Record_Present (N)
and then not Is_Tagged_Type (Typ)
then
Error_Msg_N ("record aggregate cannot be null", N);
return;
elsif No (First_Entity (Typ)) then
Error_Msg_N ("record aggregate must be null", N);
return;
end if;
Step_2 : declare
Selector_Name : Node_Id;
Bad_Aggregate : Boolean := False;
begin
if Present (Component_Associations (N)) then
Assoc := First (Component_Associations (N));
else
Assoc := Empty;
end if;
while Present (Assoc) loop
Selector_Name := First (Choices (Assoc));
while Present (Selector_Name) loop
if Nkind (Selector_Name) = N_Identifier then
null;
elsif Nkind (Selector_Name) = N_Others_Choice then
if Selector_Name /= First (Choices (Assoc))
or else Present (Next (Selector_Name))
then
Error_Msg_N ("OTHERS must appear alone in a choice list",
Selector_Name);
return;
elsif Present (Next (Assoc)) then
Error_Msg_N ("OTHERS must appear last in an aggregate",
Selector_Name);
return;
end if;
else
Error_Msg_N
("selector name should be identifier or OTHERS",
Selector_Name);
Bad_Aggregate := True;
end if;
Next (Selector_Name);
end loop;
Next (Assoc);
end loop;
if Bad_Aggregate then
return;
end if;
end Step_2;
Step_3 : declare
Discrim : Entity_Id;
Missing_Discriminants : Boolean := False;
begin
if Present (Expressions (N)) then
Positional_Expr := First (Expressions (N));
else
Positional_Expr := Empty;
end if;
if Has_Discriminants (Typ) then
Discrim := First_Discriminant (Typ);
else
Discrim := Empty;
end if;
while Present (Discrim) and then Present (Positional_Expr) loop
if Discr_Present (Discrim) then
Resolve_Aggr_Expr (Positional_Expr, Discrim);
if Ada_Version >= Ada_05
and then Nkind (Positional_Expr) = N_Null
then
Check_Can_Never_Be_Null (Discrim, Positional_Expr);
end if;
Next (Positional_Expr);
end if;
if Present (Get_Value (Discrim, Component_Associations (N))) then
Error_Msg_NE
("more than one value supplied for discriminant&",
N, Discrim);
end if;
Next_Discriminant (Discrim);
end loop;
while Present (Discrim) loop
Expr := Get_Value (Discrim, Component_Associations (N), True);
if not Discr_Present (Discrim) then
if Present (Expr) then
Error_Msg_NE
("more than one value supplied for discriminant&",
N, Discrim);
end if;
elsif No (Expr) then
Error_Msg_NE
("no value supplied for discriminant &", N, Discrim);
Missing_Discriminants := True;
else
Resolve_Aggr_Expr (Expr, Discrim);
end if;
Next_Discriminant (Discrim);
end loop;
if Missing_Discriminants then
return;
end if;
end Step_3;
if Has_Discriminants (Typ) then
Build_Constrained_Itype : declare
Loc : constant Source_Ptr := Sloc (N);
Indic : Node_Id;
Subtyp_Decl : Node_Id;
Def_Id : Entity_Id;
C : constant List_Id := New_List;
begin
New_Assoc := First (New_Assoc_List);
while Present (New_Assoc) loop
Append (Duplicate_Subexpr (Expression (New_Assoc)), To => C);
Next (New_Assoc);
end loop;
Indic :=
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Occurrence_Of (Base_Type (Typ), Loc),
Constraint => Make_Index_Or_Discriminant_Constraint (Loc, C));
Def_Id := Create_Itype (Ekind (Typ), N);
Subtyp_Decl :=
Make_Subtype_Declaration (Loc,
Defining_Identifier => Def_Id,
Subtype_Indication => Indic);
Set_Parent (Subtyp_Decl, Parent (N));
Analyze (Subtyp_Decl, Suppress => All_Checks);
Set_Etype (N, Def_Id);
Check_Static_Discriminated_Subtype
(Def_Id, Expression (First (New_Assoc_List)));
end Build_Constrained_Itype;
else
Set_Etype (N, Typ);
end if;
Step_5 : declare
Record_Def : Node_Id;
Parent_Typ : Entity_Id;
Root_Typ : Entity_Id;
Parent_Typ_List : Elist_Id;
Parent_Elmt : Elmt_Id;
Errors_Found : Boolean := False;
Dnode : Node_Id;
begin
if Is_Derived_Type (Typ) and then Is_Tagged_Type (Typ) then
Parent_Typ_List := New_Elmt_List;
if Nkind (N) = N_Extension_Aggregate then
Root_Typ := Base_Type (Etype (Ancestor_Part (N)));
else
Root_Typ := Root_Type (Typ);
if Nkind (Parent (Base_Type (Root_Typ)))
= N_Private_Type_Declaration
then
Error_Msg_NE
("type of aggregate has private ancestor&!",
N, Root_Typ);
Error_Msg_N ("must use extension aggregate!", N);
return;
end if;
Dnode := Declaration_Node (Base_Type (Root_Typ));
if Nkind (Dnode) = N_Full_Type_Declaration then
Record_Def := Type_Definition (Dnode);
Gather_Components (Base_Type (Typ),
Component_List (Record_Def),
Governed_By => New_Assoc_List,
Into => Components,
Report_Errors => Errors_Found);
end if;
end if;
Parent_Typ := Base_Type (Typ);
while Parent_Typ /= Root_Typ loop
Prepend_Elmt (Parent_Typ, To => Parent_Typ_List);
Parent_Typ := Etype (Parent_Typ);
if Nkind (Parent (Base_Type (Parent_Typ))) =
N_Private_Type_Declaration
or else Nkind (Parent (Base_Type (Parent_Typ))) =
N_Private_Extension_Declaration
then
if Nkind (N) /= N_Extension_Aggregate then
Error_Msg_NE
("type of aggregate has private ancestor&!",
N, Parent_Typ);
Error_Msg_N ("must use extension aggregate!", N);
return;
elsif Parent_Typ /= Root_Typ then
Error_Msg_NE
("ancestor part of aggregate must be private type&",
Ancestor_Part (N), Parent_Typ);
return;
end if;
end if;
end loop;
Parent_Elmt := First_Elmt (Parent_Typ_List);
while Present (Parent_Elmt) loop
Parent_Typ := Node (Parent_Elmt);
Record_Def := Type_Definition (Parent (Base_Type (Parent_Typ)));
Gather_Components (Empty,
Component_List (Record_Extension_Part (Record_Def)),
Governed_By => New_Assoc_List,
Into => Components,
Report_Errors => Errors_Found);
Next_Elmt (Parent_Elmt);
end loop;
else
Record_Def := Type_Definition (Parent (Base_Type (Typ)));
if Null_Present (Record_Def) then
null;
else
Gather_Components (Base_Type (Typ),
Component_List (Record_Def),
Governed_By => New_Assoc_List,
Into => Components,
Report_Errors => Errors_Found);
end if;
end if;
if Errors_Found then
return;
end if;
end Step_5;
Component := Empty;
Component_Elmt := First_Elmt (Components);
while Present (Positional_Expr) and then Present (Component_Elmt) loop
Component := Node (Component_Elmt);
Resolve_Aggr_Expr (Positional_Expr, Component);
if Ada_Version >= Ada_05
and then Nkind (Positional_Expr) = N_Null
then
Check_Can_Never_Be_Null (Component, Positional_Expr);
end if;
if Present (Get_Value (Component, Component_Associations (N))) then
Error_Msg_NE
("more than one value supplied for Component &", N, Component);
end if;
Next (Positional_Expr);
Next_Elmt (Component_Elmt);
end loop;
if Present (Positional_Expr) then
Error_Msg_N
("too many components for record aggregate", Positional_Expr);
end if;
while Present (Component_Elmt) loop
Component := Node (Component_Elmt);
Expr := Get_Value (Component, Component_Associations (N), True);
if Is_Box_Present then
declare
Is_Array_Subtype : constant Boolean :=
Ekind (Etype (Component)) =
E_Array_Subtype;
Ctyp : Entity_Id;
begin
if Is_Array_Subtype then
Ctyp := Component_Type (Base_Type (Etype (Component)));
else
Ctyp := Etype (Component);
end if;
if Has_Non_Null_Base_Init_Proc (Ctyp) then
Add_Association
(Component => Component,
Expr => Empty,
Is_Box_Present => True);
elsif Present (Expr)
and then
((not Is_Array_Subtype
and then Is_Partially_Initialized_Type (Component))
or else
(Is_Array_Subtype
and then Is_Partially_Initialized_Type (Ctyp)))
then
Resolve_Aggr_Expr (Expr, Component);
end if;
end;
elsif No (Expr) then
Error_Msg_NE ("no value supplied for component &!", N, Component);
else
Resolve_Aggr_Expr (Expr, Component);
end if;
Next_Elmt (Component_Elmt);
end loop;
Step_7 : declare
Selectr : Node_Id;
Typech : Entity_Id;
begin
if Present (Component_Associations (N)) then
Assoc := First (Component_Associations (N));
else
Assoc := Empty;
end if;
Verification : while Present (Assoc) loop
Selectr := First (Choices (Assoc));
Typech := Empty;
if Nkind (Selectr) = N_Others_Choice then
if No (Others_Etype)
and then not Others_Box
then
Error_Msg_N
("OTHERS must represent at least one component", Selectr);
end if;
exit Verification;
end if;
while Present (Selectr) loop
New_Assoc := First (New_Assoc_List);
while Present (New_Assoc) loop
Component := First (Choices (New_Assoc));
exit when Chars (Selectr) = Chars (Component);
Next (New_Assoc);
end loop;
if No (New_Assoc) then
if Box_Present (Parent (Selectr)) then
null;
elsif Chars (Selectr) /= Name_uTag
and then Chars (Selectr) /= Name_uParent
and then Chars (Selectr) /= Name_uController
then
if not Has_Discriminants (Typ) then
Error_Msg_Node_2 := Typ;
Error_Msg_N
("& is not a component of}",
Selectr);
else
Error_Msg_N
("& is not a component of the aggregate subtype",
Selectr);
end if;
Check_Misspelled_Component (Components, Selectr);
end if;
elsif No (Typech) then
Typech := Base_Type (Etype (Component));
elsif Typech /= Base_Type (Etype (Component)) then
if not Box_Present (Parent (Selectr)) then
Error_Msg_N
("components in choice list must have same type",
Selectr);
end if;
end if;
Next (Selectr);
end loop;
Next (Assoc);
end loop Verification;
end Step_7;
Step_8 : declare
New_Aggregate : constant Node_Id := New_Copy (N);
begin
Set_Expressions (New_Aggregate, No_List);
Set_Etype (New_Aggregate, Etype (N));
Set_Component_Associations (New_Aggregate, New_Assoc_List);
Rewrite (N, New_Aggregate);
end Step_8;
end Resolve_Record_Aggregate;
procedure Check_Can_Never_Be_Null (Typ : Entity_Id; Expr : Node_Id) is
Comp_Typ : Entity_Id;
begin
pragma Assert
(Ada_Version >= Ada_05
and then Present (Expr)
and then Nkind (Expr) = N_Null);
case Ekind (Typ) is
when E_Array_Type =>
Comp_Typ := Component_Type (Typ);
when E_Component |
E_Discriminant =>
Comp_Typ := Etype (Typ);
when others =>
return;
end case;
if Can_Never_Be_Null (Comp_Typ) then
Insert_Action
(Compile_Time_Constraint_Error
(Expr,
"(Ada 2005) NULL not allowed in null-excluding components?"),
Make_Raise_Constraint_Error (Sloc (Expr),
Reason => CE_Access_Check_Failed));
Set_Etype (Expr, Comp_Typ);
Set_Analyzed (Expr);
end if;
end Check_Can_Never_Be_Null;
procedure Sort_Case_Table (Case_Table : in out Case_Table_Type) is
L : constant Int := Case_Table'First;
U : constant Int := Case_Table'Last;
K : Int;
J : Int;
T : Case_Bounds;
begin
K := L;
while K /= U loop
T := Case_Table (K + 1);
J := K + 1;
while J /= L
and then Expr_Value (Case_Table (J - 1).Choice_Lo) >
Expr_Value (T.Choice_Lo)
loop
Case_Table (J) := Case_Table (J - 1);
J := J - 1;
end loop;
Case_Table (J) := T;
K := K + 1;
end loop;
end Sort_Case_Table;
end Sem_Aggr;