with Atree; use Atree;
with Einfo; use Einfo;
with Errout; use Errout;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Sem; use Sem;
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 Snames; use Snames;
with Stand; use Stand;
with Sinfo; use Sinfo;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
package body Sem_Case is
type Sort_Choice_Table_Type is array (Nat range <>) of Choice_Bounds;
procedure Check_Choices
(Choice_Table : in out Sort_Choice_Table_Type;
Bounds_Type : Entity_Id;
Others_Present : Boolean;
Msg_Sloc : Source_Ptr);
function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id;
procedure Expand_Others_Choice
(Case_Table : Choice_Table_Type;
Others_Choice : Node_Id;
Choice_Type : Entity_Id);
procedure Check_Choices
(Choice_Table : in out Sort_Choice_Table_Type;
Bounds_Type : Entity_Id;
Others_Present : Boolean;
Msg_Sloc : Source_Ptr)
is
function Lt_Choice (C1, C2 : Natural) return Boolean;
procedure Move_Choice (From : Natural; To : Natural);
procedure Issue_Msg (Value1 : Node_Id; Value2 : Node_Id);
procedure Issue_Msg (Value1 : Node_Id; Value2 : Uint);
procedure Issue_Msg (Value1 : Uint; Value2 : Node_Id);
procedure Issue_Msg (Value1 : Uint; Value2 : Uint);
procedure Issue_Msg (Value1 : Node_Id; Value2 : Node_Id) is
begin
Issue_Msg (Expr_Value (Value1), Expr_Value (Value2));
end Issue_Msg;
procedure Issue_Msg (Value1 : Node_Id; Value2 : Uint) is
begin
Issue_Msg (Expr_Value (Value1), Value2);
end Issue_Msg;
procedure Issue_Msg (Value1 : Uint; Value2 : Node_Id) is
begin
Issue_Msg (Value1, Expr_Value (Value2));
end Issue_Msg;
procedure Issue_Msg (Value1 : Uint; Value2 : Uint) is
begin
if Value1 > Value2 then
return;
end if;
if Value1 = Value2 then
if Is_Integer_Type (Bounds_Type) then
Error_Msg_Uint_1 := Value1;
Error_Msg ("missing case value: ^!", Msg_Sloc);
else
Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type);
Error_Msg ("missing case value: %!", Msg_Sloc);
end if;
else
if Is_Integer_Type (Bounds_Type) then
Error_Msg_Uint_1 := Value1;
Error_Msg_Uint_2 := Value2;
Error_Msg ("missing case values: ^ .. ^!", Msg_Sloc);
else
Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type);
Error_Msg_Name_2 := Choice_Image (Value2, Bounds_Type);
Error_Msg ("missing case values: % .. %!", Msg_Sloc);
end if;
end if;
end Issue_Msg;
function Lt_Choice (C1, C2 : Natural) return Boolean is
begin
return
Expr_Value (Choice_Table (Nat (C1)).Lo)
<
Expr_Value (Choice_Table (Nat (C2)).Lo);
end Lt_Choice;
procedure Move_Choice (From : Natural; To : Natural) is
begin
Choice_Table (Nat (To)) := Choice_Table (Nat (From));
end Move_Choice;
Choice : Node_Id;
Bounds_Lo : constant Node_Id := Type_Low_Bound (Bounds_Type);
Bounds_Hi : constant Node_Id := Type_High_Bound (Bounds_Type);
Prev_Choice : Node_Id;
Hi : Uint;
Lo : Uint;
Prev_Hi : Uint;
begin
pragma Assert (Choice_Table'First = 0);
if Choice_Table'Last = 0 then
if not Others_Present then
Issue_Msg (Bounds_Lo, Bounds_Hi);
end if;
return;
end if;
Sort
(Positive (Choice_Table'Last),
Move_Choice'Unrestricted_Access,
Lt_Choice'Unrestricted_Access);
Lo := Expr_Value (Choice_Table (1).Lo);
Hi := Expr_Value (Choice_Table (1).Hi);
Prev_Hi := Hi;
if not Others_Present and then Expr_Value (Bounds_Lo) < Lo then
Issue_Msg (Bounds_Lo, Lo - 1);
end if;
for J in 2 .. Choice_Table'Last loop
Lo := Expr_Value (Choice_Table (J).Lo);
Hi := Expr_Value (Choice_Table (J).Hi);
if Lo <= Prev_Hi then
Prev_Choice := Choice_Table (J - 1).Node;
Choice := Choice_Table (J).Node;
if Sloc (Prev_Choice) <= Sloc (Choice) then
Error_Msg_Sloc := Sloc (Prev_Choice);
Error_Msg_N ("duplication of choice value#", Choice);
else
Error_Msg_Sloc := Sloc (Choice);
Error_Msg_N ("duplication of choice value#", Prev_Choice);
end if;
elsif not Others_Present and then Lo /= Prev_Hi + 1 then
Issue_Msg (Prev_Hi + 1, Lo - 1);
end if;
Prev_Hi := Hi;
end loop;
if not Others_Present and then Expr_Value (Bounds_Hi) > Hi then
Issue_Msg (Hi + 1, Bounds_Hi);
end if;
end Check_Choices;
function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id is
Rtp : constant Entity_Id := Root_Type (Ctype);
Lit : Entity_Id;
C : Int;
begin
if Rtp = Standard_Character
or else Rtp = Standard_Wide_Character
or else Rtp = Standard_Wide_Wide_Character
then
C := UI_To_Int (Value);
if C in 16#20# .. 16#7E# then
Set_Character_Literal_Name (Char_Code (UI_To_Int (Value)));
return Name_Find;
end if;
else
Lit := First_Literal (Rtp);
for J in 1 .. UI_To_Int (Value) loop
Next_Literal (Lit);
end loop;
if Nkind (Lit) = N_Defining_Identifier then
return Chars (Lit);
else
Get_Decoded_Name_String (Chars (Lit));
if Name_Len = 3
and then Name_Buffer (2) in
Character'Val (16#20#) .. Character'Val (16#7E#)
then
return Chars (Lit);
end if;
end if;
end if;
Get_Name_String (Chars (First_Subtype (Ctype)));
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := ''';
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := 'v';
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := 'a';
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := 'l';
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := '(';
UI_Image (Value);
for J in 1 .. UI_Image_Length loop
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := UI_Image_Buffer (J);
end loop;
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := ')';
return Name_Find;
end Choice_Image;
procedure Expand_Others_Choice
(Case_Table : Choice_Table_Type;
Others_Choice : Node_Id;
Choice_Type : Entity_Id)
is
Loc : constant Source_Ptr := Sloc (Others_Choice);
Choice_List : constant List_Id := New_List;
Choice : Node_Id;
Exp_Lo : Node_Id;
Exp_Hi : Node_Id;
Hi : Uint;
Lo : Uint;
Previous_Hi : Uint;
function Build_Choice (Value1, Value2 : Uint) return Node_Id;
function Lit_Of (Value : Uint) return Node_Id;
function Build_Choice (Value1, Value2 : Uint) return Node_Id is
Lit_Node : Node_Id;
Lo, Hi : Node_Id;
begin
if (Value2 - Value1) = 0 then
if Is_Integer_Type (Choice_Type) then
Lit_Node := Make_Integer_Literal (Loc, Value1);
Set_Etype (Lit_Node, Choice_Type);
else
Lit_Node := Lit_Of (Value1);
end if;
else
if Is_Integer_Type (Choice_Type) then
Lo := Make_Integer_Literal (Loc, Value1);
Set_Etype (Lo, Choice_Type);
Hi := Make_Integer_Literal (Loc, Value2);
Set_Etype (Hi, Choice_Type);
Lit_Node :=
Make_Range (Loc,
Low_Bound => Lo,
High_Bound => Hi);
else
Lit_Node :=
Make_Range (Loc,
Low_Bound => Lit_Of (Value1),
High_Bound => Lit_Of (Value2));
end if;
end if;
return Lit_Node;
end Build_Choice;
function Lit_Of (Value : Uint) return Node_Id is
Lit : Entity_Id;
begin
if Root_Type (Choice_Type) = Standard_Character
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)));
Lit := New_Node (N_Character_Literal, Loc);
Set_Chars (Lit, Name_Find);
Set_Char_Literal_Value (Lit, Value);
Set_Etype (Lit, Choice_Type);
Set_Is_Static_Expression (Lit, True);
return Lit;
else
Lit := First_Literal (Choice_Type);
for J in 1 .. UI_To_Int (Value) loop
Next_Literal (Lit);
end loop;
return New_Occurrence_Of (Lit, Loc);
end if;
end Lit_Of;
begin
if Case_Table'Length = 0 then
if Is_Static_Subtype (Choice_Type) then
Choice := New_Occurrence_Of (Choice_Type, Loc);
else
Choice := New_Occurrence_Of (Base_Type (Choice_Type), Loc);
end if;
Set_Others_Discrete_Choices (Others_Choice, New_List (Choice));
return;
end if;
if Is_OK_Static_Subtype (Choice_Type) then
Exp_Lo := Type_Low_Bound (Choice_Type);
Exp_Hi := Type_High_Bound (Choice_Type);
else
Exp_Lo := Type_Low_Bound (Base_Type (Choice_Type));
Exp_Hi := Type_High_Bound (Base_Type (Choice_Type));
end if;
Lo := Expr_Value (Case_Table (Case_Table'First).Lo);
Hi := Expr_Value (Case_Table (Case_Table'First).Hi);
Previous_Hi := Expr_Value (Case_Table (Case_Table'First).Hi);
if Expr_Value (Exp_Lo) < Lo then
Append (Build_Choice (Expr_Value (Exp_Lo), Lo - 1), Choice_List);
end if;
for J in Case_Table'First + 1 .. Case_Table'Last loop
Lo := Expr_Value (Case_Table (J).Lo);
Hi := Expr_Value (Case_Table (J).Hi);
if Lo /= (Previous_Hi + 1) then
Append_To (Choice_List, Build_Choice (Previous_Hi + 1, Lo - 1));
end if;
Previous_Hi := Hi;
end loop;
if Expr_Value (Exp_Hi) > Hi then
Append (Build_Choice (Hi + 1, Expr_Value (Exp_Hi)), Choice_List);
end if;
Set_Others_Discrete_Choices (Others_Choice, Choice_List);
if Warn_On_Redundant_Constructs
and then Comes_From_Source (Others_Choice)
and then Is_Empty_List (Choice_List)
then
Error_Msg_N ("?others choice is empty", Others_Choice);
end if;
end Expand_Others_Choice;
procedure No_OP (C : Node_Id) is
pragma Warnings (Off, C);
begin
null;
end No_OP;
package body Generic_Choices_Processing is
procedure Analyze_Choices
(N : Node_Id;
Subtyp : Entity_Id;
Choice_Table : out Choice_Table_Type;
Last_Choice : out Nat;
Raises_CE : out Boolean;
Others_Present : out Boolean)
is
E : Entity_Id;
Enode : Node_Id;
Nb_Choices : constant Nat := Choice_Table'Length;
Sort_Choice_Table : Sort_Choice_Table_Type (0 .. Nb_Choices);
Choice_Type : constant Entity_Id := Base_Type (Subtyp);
Bounds_Type : Entity_Id;
Bounds_Lo : Uint;
Bounds_Hi : Uint;
Expected_Type : Entity_Id;
Alt : Node_Id;
Choice : Node_Id;
Kind : Node_Kind;
Others_Choice : Node_Id := Empty;
procedure Check (Choice : Node_Id; Lo, Hi : Node_Id);
procedure Check (Choice : Node_Id; Lo, Hi : Node_Id) is
Lo_Val : Uint;
Hi_Val : Uint;
begin
if Etype (Lo) = Any_Type or else Etype (Hi) = Any_Type then
return;
elsif not Is_Static_Expression (Lo)
or else not Is_Static_Expression (Hi)
then
Process_Non_Static_Choice (Choice);
return;
elsif Raises_Constraint_Error (Lo)
or else Raises_Constraint_Error (Hi)
then
Raises_CE := True;
return;
else
Lo_Val := Expr_Value (Lo);
Hi_Val := Expr_Value (Hi);
if Lo_Val > Hi_Val then
Process_Empty_Choice (Choice);
return;
end if;
end if;
if Lo_Val < Bounds_Lo then
if Is_Entity_Name (Choice) then
Enode := Choice;
else
Enode := Lo;
end if;
if Is_Integer_Type (Bounds_Type) then
Error_Msg_Uint_1 := Bounds_Lo;
Error_Msg_N ("minimum allowed choice value is^", Enode);
else
Error_Msg_Name_1 := Choice_Image (Bounds_Lo, Bounds_Type);
Error_Msg_N ("minimum allowed choice value is%", Enode);
end if;
end if;
if Hi_Val > Bounds_Hi then
if Is_Entity_Name (Choice) then
Enode := Choice;
else
Enode := Hi;
end if;
if Is_Integer_Type (Bounds_Type) then
Error_Msg_Uint_1 := Bounds_Hi;
Error_Msg_N ("maximum allowed choice value is^", Enode);
else
Error_Msg_Name_1 := Choice_Image (Bounds_Hi, Bounds_Type);
Error_Msg_N ("maximum allowed choice value is%", Enode);
end if;
end if;
Last_Choice := Last_Choice + 1;
Sort_Choice_Table (Last_Choice).Lo := Lo;
Sort_Choice_Table (Last_Choice).Hi := Hi;
Sort_Choice_Table (Last_Choice).Node := Choice;
end Check;
begin
Last_Choice := 0;
Raises_CE := False;
Others_Present := False;
if Is_OK_Static_Subtype (Subtyp) then
Bounds_Type := Subtyp;
else
Bounds_Type := Choice_Type;
end if;
if not Is_Generic_Type (Root_Type (Bounds_Type))
or else Ekind (Bounds_Type) /= E_Enumeration_Type
then
Bounds_Lo := Expr_Value (Type_Low_Bound (Bounds_Type));
Bounds_Hi := Expr_Value (Type_High_Bound (Bounds_Type));
end if;
if Choice_Type = Universal_Integer then
Expected_Type := Any_Integer;
else
Expected_Type := Choice_Type;
end if;
Alt := First (Get_Alternatives (N));
while Present (Alt) loop
if Nkind (Alt) = N_Pragma then
Analyze (Alt);
else
Choice := First (Get_Choices (Alt));
while Present (Choice) loop
Analyze (Choice);
Kind := Nkind (Choice);
if Kind = N_Range
or else (Kind = N_Attribute_Reference
and then Attribute_Name (Choice) = Name_Range)
then
Resolve (Choice, Expected_Type);
Check (Choice, Low_Bound (Choice), High_Bound (Choice));
elsif Is_Entity_Name (Choice)
and then Is_Type (Entity (Choice))
then
if not Covers (Expected_Type, Etype (Choice)) then
Wrong_Type (Choice, Choice_Type);
else
E := Entity (Choice);
if not Is_Static_Subtype (E) then
Process_Non_Static_Choice (Choice);
else
Check
(Choice, Type_Low_Bound (E), Type_High_Bound (E));
end if;
end if;
elsif Kind = N_Subtype_Indication then
Resolve_Discrete_Subtype_Indication
(Choice, Expected_Type);
if Etype (Choice) /= Any_Type then
declare
C : constant Node_Id := Constraint (Choice);
R : constant Node_Id := Range_Expression (C);
L : constant Node_Id := Low_Bound (R);
H : constant Node_Id := High_Bound (R);
begin
E := Entity (Subtype_Mark (Choice));
if not Is_Static_Subtype (E) then
Process_Non_Static_Choice (Choice);
else
if Is_OK_Static_Expression (L)
and then Is_OK_Static_Expression (H)
then
if Expr_Value (L) > Expr_Value (H) then
Process_Empty_Choice (Choice);
else
if Is_Out_Of_Range (L, E) then
Apply_Compile_Time_Constraint_Error
(L, "static value out of range",
CE_Range_Check_Failed);
end if;
if Is_Out_Of_Range (H, E) then
Apply_Compile_Time_Constraint_Error
(H, "static value out of range",
CE_Range_Check_Failed);
end if;
end if;
end if;
Check (Choice, L, H);
end if;
end;
end if;
elsif Kind = N_Others_Choice then
if not (Choice = First (Get_Choices (Alt))
and then Choice = Last (Get_Choices (Alt))
and then Alt = Last (Get_Alternatives (N)))
then
Error_Msg_N
("the choice OTHERS must appear alone and last",
Choice);
return;
end if;
Others_Present := True;
Others_Choice := Choice;
else
Resolve (Choice, Expected_Type);
Check (Choice, Choice, Choice);
end if;
Next (Choice);
end loop;
Process_Associated_Node (Alt);
end if;
Next (Alt);
end loop;
Check_Choices
(Sort_Choice_Table (0 .. Last_Choice),
Bounds_Type,
Others_Present or else (Choice_Type = Universal_Integer),
Sloc (N));
for J in 1 .. Last_Choice loop
Choice_Table (Choice_Table'First - 1 + J) := Sort_Choice_Table (J);
end loop;
if Others_Present and not Raises_CE then
Expand_Others_Choice
(Case_Table => Choice_Table (1 .. Last_Choice),
Others_Choice => Others_Choice,
Choice_Type => Bounds_Type);
end if;
end Analyze_Choices;
function Number_Of_Choices (N : Node_Id) return Nat is
Alt : Node_Id;
Choice : Node_Id;
Count : Nat := 0;
begin
if not Present (Get_Alternatives (N)) then
return 0;
end if;
Alt := First_Non_Pragma (Get_Alternatives (N));
while Present (Alt) loop
Choice := First (Get_Choices (Alt));
while Present (Choice) loop
if Nkind (Choice) /= N_Others_Choice then
Count := Count + 1;
end if;
Next (Choice);
end loop;
Next_Non_Pragma (Alt);
end loop;
return Count;
end Number_Of_Choices;
end Generic_Choices_Processing;
end Sem_Case;