Skip to content

R
riscv-gcc-1
Commit 8a95f4e8 by Robert Dewar Committed by Arnaud Charlet
Options

sem_intr.adb, [...]: Minor reformatting. 

2010-06-17  Robert Dewar  <dewar@adacore.com>

	* sem_intr.adb, sem_prag.adb, sem_res.adb, sem_type.adb, sem_util.adb,
	sem_warn.adb, sem_eval.adb: Minor reformatting.  Use Ekind_In.
	(Set_Slice_Subtype): Explicitly freeze the slice's itype at the point
	where the slice's actions are inserted.
	(Decompose_Expr): Account for possible rewriting of slice bounds
	resulting from side effects suppression caused by the above freezing,
	so that folding of bounds is preserved by such rewriting.

2010-06-17  Robert Dewar  <dewar@adacore.com>

	* einfo.ads, einfo.adb (Get_Record_Representation_Clause): New function.
	* freeze.adb (Freeze_Record_Type): Add call to
	Check_Record_Representation_Clause.
	* sem_ch13.adb (Check_Record_Representation_Clause): New function
	(Analyze_Record_Representation_Clause): Split out overlap code into this
	new function.
	(Check_Component_Overlap): Moved inside
	Check_Record_Representation_Clause.
	* sem_ch13.ads (Check_Record_Representation_Clause): New function.

From-SVN: r160892
parent e1b871e9
Showing with 1112 additions and 883 deletions
gcc/ada/ChangeLog
2010-06-17 Robert Dewar <dewar@adacore.com>
* sem_intr.adb, sem_prag.adb, sem_res.adb, sem_type.adb, sem_util.adb,
sem_warn.adb, sem_eval.adb: Minor reformatting. Use Ekind_In.
(Set_Slice_Subtype): Explicitly freeze the slice's itype at the point
where the slice's actions are inserted.
(Decompose_Expr): Account for possible rewriting of slice bounds
resulting from side effects suppression caused by the above freezing,
so that folding of bounds is preserved by such rewriting.
2010-06-17 Robert Dewar <dewar@adacore.com>
* einfo.ads, einfo.adb (Get_Record_Representation_Clause): New function.
* freeze.adb (Freeze_Record_Type): Add call to
Check_Record_Representation_Clause.
* sem_ch13.adb (Check_Record_Representation_Clause): New function
(Analyze_Record_Representation_Clause): Split out overlap code into this
new function.
(Check_Component_Overlap): Moved inside
Check_Record_Representation_Clause.
* sem_ch13.ads (Check_Record_Representation_Clause): New function.
2010-06-17 Robert Dewar <dewar@adacore.com>
* back_end.adb, sem_res.adb, switch-c.adb, sem_scil.adb: Minor
reformatting.
* sem_attr.adb, sem_cat.adb, sem_disp.adb, sem_elab.adb, sem_elim.adb,
......
gcc/ada/einfo.adb
......@@ -5760,6 +5760,26 @@ package body Einfo is
end if;
end Get_Full_View;
--------------------------------------
-- Get_Record_Representation_Clause --
--------------------------------------
function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id is
N : Node_Id;
begin
N := First_Rep_Item (E);
while Present (N) loop
if Nkind (N) = N_Record_Representation_Clause then
return N;
end if;
Next_Rep_Item (N);
end loop;
return Empty;
end Get_Record_Representation_Clause;
--------------------
-- Get_Rep_Pragma --
--------------------
......
gcc/ada/einfo.ads
......@@ -6767,6 +6767,11 @@ package Einfo is
-- value returned is the N_Attribute_Definition_Clause node, otherwise
-- Empty is returned.
function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id;
-- Searches the Rep_Item chain for a given entyt E, for a record
-- representation clause, and if found, returns it. Returns Empty
-- if no such clause is found.
function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Node_Id;
-- Searches the Rep_Item chain for the given entity E, for an instance
-- a representation pragma with the given name Nam. If found then the
......
gcc/ada/freeze.adb
......@@ -1776,7 +1776,7 @@ package body Freeze is
Prev := Empty;
while Present (Comp) loop
-- First handle the (real) component case
-- First handle the component case
if Ekind (Comp) = E_Component
or else Ekind (Comp) = E_Discriminant
......@@ -1847,129 +1847,12 @@ package body Freeze is
Component_Name (Component_Clause (Comp)));
end if;
end if;
-- If component clause is present, then deal with the non-
-- default bit order case for Ada 95 mode. The required
-- processing for Ada 2005 mode is handled separately after
-- processing all components.
-- We only do this processing for the base type, and in
-- fact that's important, since otherwise if there are
-- record subtypes, we could reverse the bits once for
-- each subtype, which would be incorrect.
if Present (CC)
and then Reverse_Bit_Order (Rec)
and then Ekind (E) = E_Record_Type
and then Ada_Version <= Ada_95
then
declare
CFB : constant Uint := Component_Bit_Offset (Comp);
CSZ : constant Uint := Esize (Comp);
CLC : constant Node_Id := Component_Clause (Comp);
Pos : constant Node_Id := Position (CLC);
FB : constant Node_Id := First_Bit (CLC);
Storage_Unit_Offset : constant Uint :=
CFB / System_Storage_Unit;
Start_Bit : constant Uint :=
CFB mod System_Storage_Unit;
begin
-- Cases where field goes over storage unit boundary
if Start_Bit + CSZ > System_Storage_Unit then
-- Allow multi-byte field but generate warning
if Start_Bit mod System_Storage_Unit = 0
and then CSZ mod System_Storage_Unit = 0
then
Error_Msg_N
("multi-byte field specified with non-standard"
& " Bit_Order?", CLC);
if Bytes_Big_Endian then
Error_Msg_N
("bytes are not reversed "
& "(component is big-endian)?", CLC);
else
Error_Msg_N
("bytes are not reversed "
& "(component is little-endian)?", CLC);
end if;
-- Do not allow non-contiguous field
else
Error_Msg_N
("attempt to specify non-contiguous field "
& "not permitted", CLC);
Error_Msg_N
("\caused by non-standard Bit_Order "
& "specified", CLC);
Error_Msg_N
("\consider possibility of using "
& "Ada 2005 mode here", CLC);
end if;
-- Case where field fits in one storage unit
else
-- Give warning if suspicious component clause
if Intval (FB) >= System_Storage_Unit
and then Warn_On_Reverse_Bit_Order
then
Error_Msg_N
("?Bit_Order clause does not affect " &
"byte ordering", Pos);
Error_Msg_Uint_1 :=
Intval (Pos) + Intval (FB) /
System_Storage_Unit;
Error_Msg_N
("?position normalized to ^ before bit " &
"order interpreted", Pos);
end if;
-- Here is where we fix up the Component_Bit_Offset
-- value to account for the reverse bit order.
-- Some examples of what needs to be done are:
-- First_Bit .. Last_Bit Component_Bit_Offset
-- old new old new
-- 0 .. 0 7 .. 7 0 7
-- 0 .. 1 6 .. 7 0 6
-- 0 .. 2 5 .. 7 0 5
-- 0 .. 7 0 .. 7 0 4
-- 1 .. 1 6 .. 6 1 6
-- 1 .. 4 3 .. 6 1 3
-- 4 .. 7 0 .. 3 4 0
-- The general rule is that the first bit is
-- is obtained by subtracting the old ending bit
-- from storage_unit - 1.
Set_Component_Bit_Offset
(Comp,
(Storage_Unit_Offset * System_Storage_Unit) +
(System_Storage_Unit - 1) -
(Start_Bit + CSZ - 1));
Set_Normalized_First_Bit
(Comp,
Component_Bit_Offset (Comp) mod
System_Storage_Unit);
end if;
end;
end if;
end;
end if;
-- Gather data for possible Implicit_Packing later
-- Gather data for possible Implicit_Packing later. Note that at
-- this stage we might be dealing with a real component, or with
-- an implicit subtype declaration.
if not Is_Scalar_Type (Etype (Comp)) then
All_Scalar_Components := False;
......@@ -2118,7 +2001,7 @@ package body Freeze is
Next_Entity (Comp);
end loop;
-- Deal with pragma Bit_Order
-- Deal with pragma Bit_Order setting non-standard bit order
if Reverse_Bit_Order (Rec) and then Base_Type (Rec) = Rec then
if not Placed_Component then
......@@ -2129,14 +2012,25 @@ package body Freeze is
Error_Msg_N
("\?since no component clauses were specified", ADC);
-- Here is where we do Ada 2005 processing for bit order (the Ada
-- 95 case was already taken care of above).
-- Here is where we do the processing for reversed bit order
elsif Ada_Version >= Ada_05 then
else
Adjust_Record_For_Reverse_Bit_Order (Rec);
end if;
end if;
-- Complete error checking on record representation clause (e.g.
-- overlap of components). This is called after adjusting the
-- record for reverse bit order.
declare
RRC : constant Node_Id := Get_Record_Representation_Clause (Rec);
begin
if Present (RRC) then
Check_Record_Representation_Clause (RRC);
end if;
end;
-- Set OK_To_Reorder_Components depending on debug flags
if Rec = Base_Type (Rec)
......
gcc/ada/sem_ch13.adb
......@@ -73,10 +73,6 @@ package body Sem_Ch13 is
-- inherited from a derived type that is no longer appropriate for the
-- new Esize value. In this case, we reset the Alignment to unknown.
procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id);
-- Given two entities for record components or discriminants, checks
-- if they have overlapping component clauses and issues errors if so.
function Get_Alignment_Value (Expr : Node_Id) return Uint;
-- Given the expression for an alignment value, returns the corresponding
-- Uint value. If the value is inappropriate, then error messages are
......@@ -180,265 +176,421 @@ package body Sem_Ch13 is
-----------------------------------------
procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id) is
Max_Machine_Scalar_Size : constant Uint :=
UI_From_Int
(Standard_Long_Long_Integer_Size);
-- We use this as the maximum machine scalar size in the sense of AI-133
Num_CC : Natural;
Comp : Entity_Id;
SSU : constant Uint := UI_From_Int (System_Storage_Unit);
Comp : Node_Id;
CC : Node_Id;
begin
-- This first loop through components does two things. First it deals
-- with the case of components with component clauses whose length is
-- greater than the maximum machine scalar size (either accepting them
-- or rejecting as needed). Second, it counts the number of components
-- with component clauses whose length does not exceed this maximum for
-- later processing.
Num_CC := 0;
Comp := First_Component_Or_Discriminant (R);
while Present (Comp) loop
declare
CC : constant Node_Id := Component_Clause (Comp);
-- Processing depends on version of Ada
begin
if Present (CC) then
declare
Fbit : constant Uint := Static_Integer (First_Bit (CC));
case Ada_Version is
begin
-- Case of component with size > max machine scalar
-- For Ada 95, we just renumber bits within a storage unit. We do
-- the same for Ada 83 mode, since we recognize pragma Bit_Order
-- in Ada 83, and are free to add this extension.
if Esize (Comp) > Max_Machine_Scalar_Size then
when Ada_83 | Ada_95 =>
Comp := First_Component_Or_Discriminant (R);
while Present (Comp) loop
CC := Component_Clause (Comp);
-- Must begin on byte boundary
-- If component clause is present, then deal with the non-
-- default bit order case for Ada 95 mode.
if Fbit mod SSU /= 0 then
Error_Msg_N
("illegal first bit value for reverse bit order",
First_Bit (CC));
Error_Msg_Uint_1 := SSU;
Error_Msg_Uint_2 := Max_Machine_Scalar_Size;
-- We only do this processing for the base type, and in
-- fact that's important, since otherwise if there are
-- record subtypes, we could reverse the bits once for
-- each subtype, which would be incorrect.
Error_Msg_N
("\must be a multiple of ^ if size greater than ^",
First_Bit (CC));
if Present (CC)
and then Ekind (R) = E_Record_Type
then
declare
CFB : constant Uint := Component_Bit_Offset (Comp);
CSZ : constant Uint := Esize (Comp);
CLC : constant Node_Id := Component_Clause (Comp);
Pos : constant Node_Id := Position (CLC);
FB : constant Node_Id := First_Bit (CLC);
-- Must end on byte boundary
Storage_Unit_Offset : constant Uint :=
CFB / System_Storage_Unit;
elsif Esize (Comp) mod SSU /= 0 then
Error_Msg_N
("illegal last bit value for reverse bit order",
Last_Bit (CC));
Error_Msg_Uint_1 := SSU;
Error_Msg_Uint_2 := Max_Machine_Scalar_Size;
Start_Bit : constant Uint :=
CFB mod System_Storage_Unit;
Error_Msg_N
("\must be a multiple of ^ if size greater than ^",
Last_Bit (CC));
begin
-- Cases where field goes over storage unit boundary
-- OK, give warning if enabled
if Start_Bit + CSZ > System_Storage_Unit then
elsif Warn_On_Reverse_Bit_Order then
Error_Msg_N
("multi-byte field specified with non-standard"
& " Bit_Order?", CC);
-- Allow multi-byte field but generate warning
if Bytes_Big_Endian then
if Start_Bit mod System_Storage_Unit = 0
and then CSZ mod System_Storage_Unit = 0
then
Error_Msg_N
("\bytes are not reversed "
& "(component is big-endian)?", CC);
("multi-byte field specified with non-standard"
& " Bit_Order?", CLC);
if Bytes_Big_Endian then
Error_Msg_N
("bytes are not reversed "
& "(component is big-endian)?", CLC);
else
Error_Msg_N
("bytes are not reversed "
& "(component is little-endian)?", CLC);
end if;
-- Do not allow non-contiguous field
else
Error_Msg_N
("\bytes are not reversed "
& "(component is little-endian)?", CC);
("attempt to specify non-contiguous field "
& "not permitted", CLC);
Error_Msg_N
("\caused by non-standard Bit_Order "
& "specified", CLC);
Error_Msg_N
("\consider possibility of using "
& "Ada 2005 mode here", CLC);
end if;
end if;
-- Case where size is not greater than max machine
-- scalar. For now, we just count these.
-- Case where field fits in one storage unit
else
Num_CC := Num_CC + 1;
end if;
end;
end if;
end;
else
-- Give warning if suspicious component clause
Next_Component_Or_Discriminant (Comp);
end loop;
if Intval (FB) >= System_Storage_Unit
and then Warn_On_Reverse_Bit_Order
then
Error_Msg_N
("?Bit_Order clause does not affect " &
"byte ordering", Pos);
Error_Msg_Uint_1 :=
Intval (Pos) + Intval (FB) /
System_Storage_Unit;
Error_Msg_N
("?position normalized to ^ before bit " &
"order interpreted", Pos);
end if;
-- We need to sort the component clauses on the basis of the Position
-- values in the clause, so we can group clauses with the same Position.
-- together to determine the relevant machine scalar size.
-- Here is where we fix up the Component_Bit_Offset
-- value to account for the reverse bit order.
-- Some examples of what needs to be done are:
declare
Comps : array (0 .. Num_CC) of Entity_Id;
-- Array to collect component and discriminant entities. The data
-- starts at index 1, the 0'th entry is for the sort routine.
-- First_Bit .. Last_Bit Component_Bit_Offset
-- old new old new
function CP_Lt (Op1, Op2 : Natural) return Boolean;
-- Compare routine for Sort
-- 0 .. 0 7 .. 7 0 7
-- 0 .. 1 6 .. 7 0 6
-- 0 .. 2 5 .. 7 0 5
-- 0 .. 7 0 .. 7 0 4
procedure CP_Move (From : Natural; To : Natural);
-- Move routine for Sort
-- 1 .. 1 6 .. 6 1 6
-- 1 .. 4 3 .. 6 1 3
-- 4 .. 7 0 .. 3 4 0
package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt);
-- The general rule is that the first bit is
-- is obtained by subtracting the old ending bit
-- from storage_unit - 1.
Start : Natural;
Stop : Natural;
-- Start and stop positions in component list of set of components
-- with the same starting position (that constitute components in
-- a single machine scalar).
Set_Component_Bit_Offset
(Comp,
(Storage_Unit_Offset * System_Storage_Unit) +
(System_Storage_Unit - 1) -
(Start_Bit + CSZ - 1));
MaxL : Uint;
-- Maximum last bit value of any component in this set
Set_Normalized_First_Bit
(Comp,
Component_Bit_Offset (Comp) mod
System_Storage_Unit);
end if;
end;
end if;
MSS : Uint;
-- Corresponding machine scalar size
Next_Component_Or_Discriminant (Comp);
end loop;
-----------
-- CP_Lt --
-----------
-- For Ada 2005, we do machine scalar processing, as fully described
-- In AI-133. This involves gathering all components which start at
-- the same byte offset and processing them together
function CP_Lt (Op1, Op2 : Natural) return Boolean is
begin
return Position (Component_Clause (Comps (Op1))) <
Position (Component_Clause (Comps (Op2)));
end CP_Lt;
when Ada_05 =>
declare
Max_Machine_Scalar_Size : constant Uint :=
UI_From_Int
(Standard_Long_Long_Integer_Size);
-- We use this as the maximum machine scalar size
-------------
-- CP_Move --
-------------
Num_CC : Natural;
SSU : constant Uint := UI_From_Int (System_Storage_Unit);
procedure CP_Move (From : Natural; To : Natural) is
begin
Comps (To) := Comps (From);
end CP_Move;
begin
-- This first loop through components does two things. First it
-- deals with the case of components with component clauses
-- whose length is greater than the maximum machine scalar size
-- (either accepting them or rejecting as needed). Second, it
-- counts the number of components with component clauses whose
-- length does not exceed this maximum for later processing.
Num_CC := 0;
Comp := First_Component_Or_Discriminant (R);
while Present (Comp) loop
CC := Component_Clause (Comp);
begin
-- Collect the component clauses
if Present (CC) then
declare
Fbit : constant Uint :=
Static_Integer (First_Bit (CC));
Num_CC := 0;
Comp := First_Component_Or_Discriminant (R);
while Present (Comp) loop
if Present (Component_Clause (Comp))
and then Esize (Comp) <= Max_Machine_Scalar_Size
then
Num_CC := Num_CC + 1;
Comps (Num_CC) := Comp;
end if;
begin
-- Case of component with size > max machine scalar
if Esize (Comp) > Max_Machine_Scalar_Size then
-- Must begin on byte boundary
if Fbit mod SSU /= 0 then
Error_Msg_N
("illegal first bit value for "
& "reverse bit order",
First_Bit (CC));
Error_Msg_Uint_1 := SSU;
Error_Msg_Uint_2 := Max_Machine_Scalar_Size;
Error_Msg_N
("\must be a multiple of ^ "
& "if size greater than ^",
First_Bit (CC));
-- Must end on byte boundary
elsif Esize (Comp) mod SSU /= 0 then
Error_Msg_N
("illegal last bit value for "
& "reverse bit order",
Last_Bit (CC));
Error_Msg_Uint_1 := SSU;
Error_Msg_Uint_2 := Max_Machine_Scalar_Size;
Error_Msg_N
("\must be a multiple of ^ if size "
& "greater than ^",
Last_Bit (CC));
-- OK, give warning if enabled
elsif Warn_On_Reverse_Bit_Order then
Error_Msg_N
("multi-byte field specified with "
& " non-standard Bit_Order?", CC);
if Bytes_Big_Endian then
Error_Msg_N
("\bytes are not reversed "
& "(component is big-endian)?", CC);
else
Error_Msg_N
("\bytes are not reversed "
& "(component is little-endian)?", CC);
end if;
end if;
Next_Component_Or_Discriminant (Comp);
end loop;
-- Case where size is not greater than max machine
-- scalar. For now, we just count these.
-- Sort by ascending position number
Sorting.Sort (Num_CC);
-- We now have all the components whose size does not exceed the max
-- machine scalar value, sorted by starting position. In this loop
-- we gather groups of clauses starting at the same position, to
-- process them in accordance with Ada 2005 AI-133.
Stop := 0;
while Stop < Num_CC loop
Start := Stop + 1;
Stop := Start;
MaxL :=
Static_Integer (Last_Bit (Component_Clause (Comps (Start))));
while Stop < Num_CC loop
if Static_Integer
(Position (Component_Clause (Comps (Stop + 1)))) =
Static_Integer
(Position (Component_Clause (Comps (Stop))))
then
Stop := Stop + 1;
MaxL :=
UI_Max
(MaxL,
Static_Integer
(Last_Bit (Component_Clause (Comps (Stop)))));
else
exit;
end if;
end loop;
else
Num_CC := Num_CC + 1;
end if;
end;
end if;
-- Now we have a group of component clauses from Start to Stop
-- whose positions are identical, and MaxL is the maximum last bit
-- value of any of these components.
Next_Component_Or_Discriminant (Comp);
end loop;
-- We need to determine the corresponding machine scalar size.
-- This loop assumes that machine scalar sizes are even, and that
-- each possible machine scalar has twice as many bits as the
-- next smaller one.
-- We need to sort the component clauses on the basis of the
-- Position values in the clause, so we can group clauses with
-- the same Position. together to determine the relevant
-- machine scalar size.
MSS := Max_Machine_Scalar_Size;
while MSS mod 2 = 0
and then (MSS / 2) >= SSU
and then (MSS / 2) > MaxL
loop
MSS := MSS / 2;
end loop;
Sort_CC : declare
Comps : array (0 .. Num_CC) of Entity_Id;
-- Array to collect component and discriminant entities. The
-- data starts at index 1, the 0'th entry is for the sort
-- routine.
-- Here is where we fix up the Component_Bit_Offset value to
-- account for the reverse bit order. Some examples of what needs
-- to be done for the case of a machine scalar size of 8 are:
function CP_Lt (Op1, Op2 : Natural) return Boolean;
-- Compare routine for Sort
-- First_Bit .. Last_Bit Component_Bit_Offset
-- old new old new
procedure CP_Move (From : Natural; To : Natural);
-- Move routine for Sort
-- 0 .. 0 7 .. 7 0 7
-- 0 .. 1 6 .. 7 0 6
-- 0 .. 2 5 .. 7 0 5
-- 0 .. 7 0 .. 7 0 4
package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt);
-- 1 .. 1 6 .. 6 1 6
-- 1 .. 4 3 .. 6 1 3
-- 4 .. 7 0 .. 3 4 0
Start : Natural;
Stop : Natural;
-- Start and stop positions in component list of set of
-- components with the same starting position (that
-- constitute components in a single machine scalar).
-- The general rule is that the first bit is obtained by
-- subtracting the old ending bit from machine scalar size - 1.
MaxL : Uint;
-- Maximum last bit value of any component in this set
for C in Start .. Stop loop
declare
Comp : constant Entity_Id := Comps (C);
CC : constant Node_Id := Component_Clause (Comp);
LB : constant Uint := Static_Integer (Last_Bit (CC));
NFB : constant Uint := MSS - Uint_1 - LB;
NLB : constant Uint := NFB + Esize (Comp) - 1;
Pos : constant Uint := Static_Integer (Position (CC));
MSS : Uint;
-- Corresponding machine scalar size
-----------
-- CP_Lt --
-----------
function CP_Lt (Op1, Op2 : Natural) return Boolean is
begin
return Position (Component_Clause (Comps (Op1))) <
Position (Component_Clause (Comps (Op2)));
end CP_Lt;
-------------
-- CP_Move --
-------------
procedure CP_Move (From : Natural; To : Natural) is
begin
Comps (To) := Comps (From);
end CP_Move;
-- Start of processing for Sort_CC
begin
if Warn_On_Reverse_Bit_Order then
Error_Msg_Uint_1 := MSS;
Error_Msg_N
("info: reverse bit order in machine " &
"scalar of length^?", First_Bit (CC));
Error_Msg_Uint_1 := NFB;
Error_Msg_Uint_2 := NLB;
-- Collect the component clauses
if Bytes_Big_Endian then
Error_Msg_NE
("?\info: big-endian range for "
& "component & is ^ .. ^",
First_Bit (CC), Comp);
else
Error_Msg_NE
("?\info: little-endian range "
& "for component & is ^ .. ^",
First_Bit (CC), Comp);
Num_CC := 0;
Comp := First_Component_Or_Discriminant (R);
while Present (Comp) loop
if Present (Component_Clause (Comp))
and then Esize (Comp) <= Max_Machine_Scalar_Size
then
Num_CC := Num_CC + 1;
Comps (Num_CC) := Comp;
end if;
end if;
Set_Component_Bit_Offset (Comp, Pos * SSU + NFB);
Set_Normalized_First_Bit (Comp, NFB mod SSU);
end;
end loop;
end loop;
end;
Next_Component_Or_Discriminant (Comp);
end loop;
-- Sort by ascending position number
Sorting.Sort (Num_CC);
-- We now have all the components whose size does not exceed
-- the max machine scalar value, sorted by starting
-- position. In this loop we gather groups of clauses
-- starting at the same position, to process them in
-- accordance with Ada 2005 AI-133.
Stop := 0;
while Stop < Num_CC loop
Start := Stop + 1;
Stop := Start;
MaxL :=
Static_Integer
(Last_Bit (Component_Clause (Comps (Start))));
while Stop < Num_CC loop
if Static_Integer
(Position (Component_Clause (Comps (Stop + 1)))) =
Static_Integer
(Position (Component_Clause (Comps (Stop))))
then
Stop := Stop + 1;
MaxL :=
UI_Max
(MaxL,
Static_Integer
(Last_Bit
(Component_Clause (Comps (Stop)))));
else
exit;
end if;
end loop;
-- Now we have a group of component clauses from Start to
-- Stop whose positions are identical, and MaxL is the
-- maximum last bit value of any of these components.
-- We need to determine the corresponding machine scalar
-- size. This loop assumes that machine scalar sizes are
-- even, and that each possible machine scalar has twice
-- as many bits as the next smaller one.
MSS := Max_Machine_Scalar_Size;
while MSS mod 2 = 0
and then (MSS / 2) >= SSU
and then (MSS / 2) > MaxL
loop
MSS := MSS / 2;
end loop;
-- Here is where we fix up the Component_Bit_Offset value
-- to account for the reverse bit order. Some examples of
-- what needs to be done for the case of a machine scalar
-- size of 8 are:
-- First_Bit .. Last_Bit Component_Bit_Offset
-- old new old new
-- 0 .. 0 7 .. 7 0 7
-- 0 .. 1 6 .. 7 0 6
-- 0 .. 2 5 .. 7 0 5
-- 0 .. 7 0 .. 7 0 4
-- 1 .. 1 6 .. 6 1 6
-- 1 .. 4 3 .. 6 1 3
-- 4 .. 7 0 .. 3 4 0
-- The general rule is that the first bit is obtained by
-- subtracting the old ending bit from machine scalar
-- size - 1.
for C in Start .. Stop loop
declare
Comp : constant Entity_Id := Comps (C);
CC : constant Node_Id :=
Component_Clause (Comp);
LB : constant Uint :=
Static_Integer (Last_Bit (CC));
NFB : constant Uint := MSS - Uint_1 - LB;
NLB : constant Uint := NFB + Esize (Comp) - 1;
Pos : constant Uint :=
Static_Integer (Position (CC));
begin
if Warn_On_Reverse_Bit_Order then
Error_Msg_Uint_1 := MSS;
Error_Msg_N
("info: reverse bit order in machine " &
"scalar of length^?", First_Bit (CC));
Error_Msg_Uint_1 := NFB;
Error_Msg_Uint_2 := NLB;
if Bytes_Big_Endian then
Error_Msg_NE
("?\info: big-endian range for "
& "component & is ^ .. ^",
First_Bit (CC), Comp);
else
Error_Msg_NE
("?\info: little-endian range "
& "for component & is ^ .. ^",
First_Bit (CC), Comp);
end if;
end if;
Set_Component_Bit_Offset (Comp, Pos * SSU + NFB);
Set_Normalized_First_Bit (Comp, NFB mod SSU);
end;
end loop;
end loop;
end Sort_CC;
end;
end case;
end Adjust_Record_For_Reverse_Bit_Order;
--------------------------------------
......@@ -2233,11 +2385,16 @@ package body Sem_Ch13 is
-- Analyze_Record_Representation_Clause --
------------------------------------------
-- Note: we check as much as we can here, but we can't do any checks
-- based on the position values (e.g. overlap checks) until freeze time
-- because especially in Ada 2005 (machine scalar mode), the processing
-- for non-standard bit order can substantially change the positions.
-- See procedure Check_Record_Representation_Clause (called from Freeze)
-- for the remainder of this processing.
procedure Analyze_Record_Representation_Clause (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Ident : constant Node_Id := Identifier (N);
Rectype : Entity_Id;
Fent : Entity_Id;
CC : Node_Id;
Posit : Uint;
Fbit : Uint;
......@@ -2245,33 +2402,8 @@ package body Sem_Ch13 is
Hbit : Uint := Uint_0;
Comp : Entity_Id;
Ocomp : Entity_Id;
Pcomp : Entity_Id;
Biased : Boolean;
Max_Bit_So_Far : Uint;
-- Records the maximum bit position so far. If all field positions
-- are monotonically increasing, then we can skip the circuit for
-- checking for overlap, since no overlap is possible.
Tagged_Parent : Entity_Id := Empty;
-- This is set in the case of a derived tagged type for which we have
-- Is_Fully_Repped_Tagged_Type True (indicating that all components are
-- positioned by record representation clauses). In this case we must
-- check for overlap between components of this tagged type, and the
-- components of its parent. Tagged_Parent will point to this parent
-- type. For all other cases Tagged_Parent is left set to Empty.
Parent_Last_Bit : Uint;
-- Relevant only if Tagged_Parent is set, Parent_Last_Bit indicates the
-- last bit position for any field in the parent type. We only need to
-- check overlap for fields starting below this point.
Overlap_Check_Required : Boolean;
-- Used to keep track of whether or not an overlap check is required
Ccount : Natural := 0;
-- Number of component clauses in record rep clause
CR_Pragma : Node_Id := Empty;
-- Points to N_Pragma node if Complete_Representation pragma present
......@@ -2386,36 +2518,6 @@ package body Sem_Ch13 is
end loop;
end if;
-- See if we have a fully repped derived tagged type
declare
PS : constant Entity_Id := Parent_Subtype (Rectype);
begin
if Present (PS) and then Is_Fully_Repped_Tagged_Type (PS) then
Tagged_Parent := PS;
-- Find maximum bit of any component of the parent type
Parent_Last_Bit := UI_From_Int (System_Address_Size - 1);
Pcomp := First_Entity (Tagged_Parent);
while Present (Pcomp) loop
if Ekind_In (Pcomp, E_Discriminant, E_Component) then
if Component_Bit_Offset (Pcomp) /= No_Uint
and then Known_Static_Esize (Pcomp)
then
Parent_Last_Bit :=
UI_Max
(Parent_Last_Bit,
Component_Bit_Offset (Pcomp) + Esize (Pcomp) - 1);
end if;
Next_Entity (Pcomp);
end if;
end loop;
end if;
end;
-- All done if no component clauses
CC := First (Component_Clauses (N));
......@@ -2424,51 +2526,12 @@ package body Sem_Ch13 is
return;
end if;
-- If a tag is present, then create a component clause that places it
-- at the start of the record (otherwise gigi may place it after other
-- fields that have rep clauses).
Fent := First_Entity (Rectype);
if Nkind (Fent) = N_Defining_Identifier
and then Chars (Fent) = Name_uTag
then
Set_Component_Bit_Offset (Fent, Uint_0);
Set_Normalized_Position (Fent, Uint_0);
Set_Normalized_First_Bit (Fent, Uint_0);
Set_Normalized_Position_Max (Fent, Uint_0);
Init_Esize (Fent, System_Address_Size);
Set_Component_Clause (Fent,
Make_Component_Clause (Loc,
Component_Name =>
Make_Identifier (Loc,
Chars => Name_uTag),
Position =>
Make_Integer_Literal (Loc,
Intval => Uint_0),
First_Bit =>
Make_Integer_Literal (Loc,
Intval => Uint_0),
Last_Bit =>
Make_Integer_Literal (Loc,
UI_From_Int (System_Address_Size))));
Ccount := Ccount + 1;
end if;
-- A representation like this applies to the base type
Set_Has_Record_Rep_Clause (Base_Type (Rectype));
Set_Has_Non_Standard_Rep (Base_Type (Rectype));
Set_Has_Specified_Layout (Base_Type (Rectype));
Max_Bit_So_Far := Uint_Minus_1;
Overlap_Check_Required := False;
-- Process the component clauses
while Present (CC) loop
......@@ -2487,7 +2550,6 @@ package body Sem_Ch13 is
-- Processing for real component clause
else
Ccount := Ccount + 1;
Posit := Static_Integer (Position (CC));
Fbit := Static_Integer (First_Bit (CC));
Lbit := Static_Integer (Last_Bit (CC));
......@@ -2596,12 +2658,6 @@ package body Sem_Ch13 is
Fbit := Fbit + UI_From_Int (SSU) * Posit;
Lbit := Lbit + UI_From_Int (SSU) * Posit;
if Fbit <= Max_Bit_So_Far then
Overlap_Check_Required := True;
else
Max_Bit_So_Far := Lbit;
end if;
if Has_Size_Clause (Rectype)
and then Esize (Rectype) <= Lbit
then
......@@ -2615,17 +2671,6 @@ package body Sem_Ch13 is
Set_Normalized_First_Bit (Comp, Fbit mod SSU);
Set_Normalized_Position (Comp, Fbit / SSU);
Set_Normalized_Position_Max
(Fent, Normalized_Position (Fent));
if Is_Tagged_Type (Rectype)
and then Fbit < System_Address_Size
then
Error_Msg_NE
("component overlaps tag field of&",
Component_Name (CC), Rectype);
end if;
-- This information is also set in the corresponding
-- component of the base type, found by accessing the
-- Original_Record_Component link if it is present.
......@@ -2668,27 +2713,6 @@ package body Sem_Ch13 is
Error_Msg_N ("component size is negative", CC);
end if;
end if;
-- If OK component size, check parent type overlap if
-- this component might overlap a parent field.
if Present (Tagged_Parent)
and then Fbit <= Parent_Last_Bit
then
Pcomp := First_Entity (Tagged_Parent);
while Present (Pcomp) loop
if (Ekind (Pcomp) = E_Discriminant
or else
Ekind (Pcomp) = E_Component)
and then not Is_Tag (Pcomp)
and then Chars (Pcomp) /= Name_uParent
then
Check_Component_Overlap (Comp, Pcomp);
end if;
Next_Entity (Pcomp);
end loop;
end if;
end if;
end if;
end if;
......@@ -2697,266 +2721,20 @@ package body Sem_Ch13 is
Next (CC);
end loop;
-- Now that we have processed all the component clauses, check for
-- overlap. We have to leave this till last, since the components can
-- appear in any arbitrary order in the representation clause.
-- Check missing components if Complete_Representation pragma appeared
-- We do not need this check if all specified ranges were monotonic,
-- as recorded by Overlap_Check_Required being False at this stage.
if Present (CR_Pragma) then
Comp := First_Component_Or_Discriminant (Rectype);
while Present (Comp) loop
if No (Component_Clause (Comp)) then
Error_Msg_NE
("missing component clause for &", CR_Pragma, Comp);
end if;
-- This first section checks if there are any overlapping entries at
-- all. It does this by sorting all entries and then seeing if there are
-- any overlaps. If there are none, then that is decisive, but if there
-- are overlaps, they may still be OK (they may result from fields in
-- different variants).
Next_Component_Or_Discriminant (Comp);
end loop;
if Overlap_Check_Required then
Overlap_Check1 : declare
OC_Fbit : array (0 .. Ccount) of Uint;
-- First-bit values for component clauses, the value is the offset
-- of the first bit of the field from start of record. The zero
-- entry is for use in sorting.
OC_Lbit : array (0 .. Ccount) of Uint;
-- Last-bit values for component clauses, the value is the offset
-- of the last bit of the field from start of record. The zero
-- entry is for use in sorting.
OC_Count : Natural := 0;
-- Count of entries in OC_Fbit and OC_Lbit
function OC_Lt (Op1, Op2 : Natural) return Boolean;
-- Compare routine for Sort
procedure OC_Move (From : Natural; To : Natural);
-- Move routine for Sort
package Sorting is new GNAT.Heap_Sort_G (OC_Move, OC_Lt);
-----------
-- OC_Lt --
-----------
function OC_Lt (Op1, Op2 : Natural) return Boolean is
begin
return OC_Fbit (Op1) < OC_Fbit (Op2);
end OC_Lt;
-------------
-- OC_Move --
-------------
procedure OC_Move (From : Natural; To : Natural) is
begin
OC_Fbit (To) := OC_Fbit (From);
OC_Lbit (To) := OC_Lbit (From);
end OC_Move;
-- Start of processing for Overlap_Check
begin
CC := First (Component_Clauses (N));
while Present (CC) loop
if Nkind (CC) /= N_Pragma then
Posit := Static_Integer (Position (CC));
Fbit := Static_Integer (First_Bit (CC));
Lbit := Static_Integer (Last_Bit (CC));
if Posit /= No_Uint
and then Fbit /= No_Uint
and then Lbit /= No_Uint
then
OC_Count := OC_Count + 1;
Posit := Posit * SSU;
OC_Fbit (OC_Count) := Fbit + Posit;
OC_Lbit (OC_Count) := Lbit + Posit;
end if;
end if;
Next (CC);
end loop;
Sorting.Sort (OC_Count);
Overlap_Check_Required := False;
for J in 1 .. OC_Count - 1 loop
if OC_Lbit (J) >= OC_Fbit (J + 1) then
Overlap_Check_Required := True;
exit;
end if;
end loop;
end Overlap_Check1;
end if;
-- If Overlap_Check_Required is still True, then we have to do the full
-- scale overlap check, since we have at least two fields that do
-- overlap, and we need to know if that is OK since they are in
-- different variant, or whether we have a definite problem.
if Overlap_Check_Required then
Overlap_Check2 : declare
C1_Ent, C2_Ent : Entity_Id;
-- Entities of components being checked for overlap
Clist : Node_Id;
-- Component_List node whose Component_Items are being checked
Citem : Node_Id;
-- Component declaration for component being checked
begin
C1_Ent := First_Entity (Base_Type (Rectype));
-- Loop through all components in record. For each component check
-- for overlap with any of the preceding elements on the component
-- list containing the component and also, if the component is in
-- a variant, check against components outside the case structure.
-- This latter test is repeated recursively up the variant tree.
Main_Component_Loop : while Present (C1_Ent) loop
if not Ekind_In (C1_Ent, E_Component, E_Discriminant) then
goto Continue_Main_Component_Loop;
end if;
-- Skip overlap check if entity has no declaration node. This
-- happens with discriminants in constrained derived types.
-- Probably we are missing some checks as a result, but that
-- does not seem terribly serious ???
if No (Declaration_Node (C1_Ent)) then
goto Continue_Main_Component_Loop;
end if;
Clist := Parent (List_Containing (Declaration_Node (C1_Ent)));
-- Loop through component lists that need checking. Check the
-- current component list and all lists in variants above us.
Component_List_Loop : loop
-- If derived type definition, go to full declaration
-- If at outer level, check discriminants if there are any.
if Nkind (Clist) = N_Derived_Type_Definition then
Clist := Parent (Clist);
end if;
-- Outer level of record definition, check discriminants
if Nkind_In (Clist, N_Full_Type_Declaration,
N_Private_Type_Declaration)
then
if Has_Discriminants (Defining_Identifier (Clist)) then
C2_Ent :=
First_Discriminant (Defining_Identifier (Clist));
while Present (C2_Ent) loop
exit when C1_Ent = C2_Ent;
Check_Component_Overlap (C1_Ent, C2_Ent);
Next_Discriminant (C2_Ent);
end loop;
end if;
-- Record extension case
elsif Nkind (Clist) = N_Derived_Type_Definition then
Clist := Empty;
-- Otherwise check one component list
else
Citem := First (Component_Items (Clist));
while Present (Citem) loop
if Nkind (Citem) = N_Component_Declaration then
C2_Ent := Defining_Identifier (Citem);
exit when C1_Ent = C2_Ent;
Check_Component_Overlap (C1_Ent, C2_Ent);
end if;
Next (Citem);
end loop;
end if;
-- Check for variants above us (the parent of the Clist can
-- be a variant, in which case its parent is a variant part,
-- and the parent of the variant part is a component list
-- whose components must all be checked against the current
-- component for overlap).
if Nkind (Parent (Clist)) = N_Variant then
Clist := Parent (Parent (Parent (Clist)));
-- Check for possible discriminant part in record, this is
-- treated essentially as another level in the recursion.
-- For this case the parent of the component list is the
-- record definition, and its parent is the full type
-- declaration containing the discriminant specifications.
elsif Nkind (Parent (Clist)) = N_Record_Definition then
Clist := Parent (Parent ((Clist)));
-- If neither of these two cases, we are at the top of
-- the tree.
else
exit Component_List_Loop;
end if;
end loop Component_List_Loop;
<<Continue_Main_Component_Loop>>
Next_Entity (C1_Ent);
end loop Main_Component_Loop;
end Overlap_Check2;
end if;
-- For records that have component clauses for all components, and whose
-- size is less than or equal to 32, we need to know the size in the
-- front end to activate possible packed array processing where the
-- component type is a record.
-- At this stage Hbit + 1 represents the first unused bit from all the
-- component clauses processed, so if the component clauses are
-- complete, then this is the length of the record.
-- For records longer than System.Storage_Unit, and for those where not
-- all components have component clauses, the back end determines the
-- length (it may for example be appropriate to round up the size
-- to some convenient boundary, based on alignment considerations, etc).
if Unknown_RM_Size (Rectype) and then Hbit + 1 <= 32 then
-- Nothing to do if at least one component has no component clause
Comp := First_Component_Or_Discriminant (Rectype);
while Present (Comp) loop
exit when No (Component_Clause (Comp));
Next_Component_Or_Discriminant (Comp);
end loop;
-- If we fall out of loop, all components have component clauses
-- and so we can set the size to the maximum value.
if No (Comp) then
Set_RM_Size (Rectype, Hbit + 1);
end if;
end if;
-- Check missing components if Complete_Representation pragma appeared
if Present (CR_Pragma) then
Comp := First_Component_Or_Discriminant (Rectype);
while Present (Comp) loop
if No (Component_Clause (Comp)) then
Error_Msg_NE
("missing component clause for &", CR_Pragma, Comp);
end if;
Next_Component_Or_Discriminant (Comp);
end loop;
-- If no Complete_Representation pragma, warn if missing components
-- If no Complete_Representation pragma, warn if missing components
elsif Warn_On_Unrepped_Components then
declare
......@@ -2994,8 +2772,8 @@ package body Sem_Ch13 is
and then Comes_From_Source (Comp)
and then Present (Underlying_Type (Etype (Comp)))
and then (Is_Scalar_Type (Underlying_Type (Etype (Comp)))
or else Size_Known_At_Compile_Time
(Underlying_Type (Etype (Comp))))
or else Size_Known_At_Compile_Time
(Underlying_Type (Etype (Comp))))
and then not Has_Warnings_Off (Rectype)
then
Error_Msg_Sloc := Sloc (Comp);
......@@ -3011,50 +2789,6 @@ package body Sem_Ch13 is
end if;
end Analyze_Record_Representation_Clause;
-----------------------------
-- Check_Component_Overlap --
-----------------------------
procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id) is
begin
if Present (Component_Clause (C1_Ent))
and then Present (Component_Clause (C2_Ent))
then
-- Exclude odd case where we have two tag fields in the same record,
-- both at location zero. This seems a bit strange, but it seems to
-- happen in some circumstances ???
if Chars (C1_Ent) = Name_uTag
and then Chars (C2_Ent) = Name_uTag
then
return;
end if;
-- Here we check if the two fields overlap
declare
S1 : constant Uint := Component_Bit_Offset (C1_Ent);
S2 : constant Uint := Component_Bit_Offset (C2_Ent);
E1 : constant Uint := S1 + Esize (C1_Ent);
E2 : constant Uint := S2 + Esize (C2_Ent);
begin
if E2 <= S1 or else E1 <= S2 then
null;
else
Error_Msg_Node_2 :=
Component_Name (Component_Clause (C2_Ent));
Error_Msg_Sloc := Sloc (Error_Msg_Node_2);
Error_Msg_Node_1 :=
Component_Name (Component_Clause (C1_Ent));
Error_Msg_N
("component& overlaps & #",
Component_Name (Component_Clause (C1_Ent)));
end if;
end;
end if;
end Check_Component_Overlap;
-----------------------------------
-- Check_Constant_Address_Clause --
-----------------------------------
......@@ -3401,6 +3135,566 @@ package body Sem_Ch13 is
Check_Expr_Constants (Expr);
end Check_Constant_Address_Clause;
----------------------------------------
-- Check_Record_Representation_Clause --
----------------------------------------
procedure Check_Record_Representation_Clause (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Ident : constant Node_Id := Identifier (N);
Rectype : Entity_Id;
Fent : Entity_Id;
CC : Node_Id;
Fbit : Uint;
Lbit : Uint;
Hbit : Uint := Uint_0;
Comp : Entity_Id;
Pcomp : Entity_Id;
Max_Bit_So_Far : Uint;
-- Records the maximum bit position so far. If all field positions
-- are monotonically increasing, then we can skip the circuit for
-- checking for overlap, since no overlap is possible.
Tagged_Parent : Entity_Id := Empty;
-- This is set in the case of a derived tagged type for which we have
-- Is_Fully_Repped_Tagged_Type True (indicating that all components are
-- positioned by record representation clauses). In this case we must
-- check for overlap between components of this tagged type, and the
-- components of its parent. Tagged_Parent will point to this parent
-- type. For all other cases Tagged_Parent is left set to Empty.
Parent_Last_Bit : Uint;
-- Relevant only if Tagged_Parent is set, Parent_Last_Bit indicates the
-- last bit position for any field in the parent type. We only need to
-- check overlap for fields starting below this point.
Overlap_Check_Required : Boolean;
-- Used to keep track of whether or not an overlap check is required
Ccount : Natural := 0;
-- Number of component clauses in record rep clause
procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id);
-- Given two entities for record components or discriminants, checks
-- if they have overlapping component clauses and issues errors if so.
procedure Find_Component;
-- Finds component entity corresponding to current component clause (in
-- CC), and sets Comp to the entity, and Fbit/Lbit to the zero origin
-- start/stop bits for the field. If there is no matching component or
-- if the matching component does not have a component clause, then
-- that's an error and Comp is set to Empty, but no error message is
-- issued, since the message was already given. Comp is also set to
-- Empty if the current "component clause" is in fact a pragma.
-----------------------------
-- Check_Component_Overlap --
-----------------------------
procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id) is
CC1 : constant Node_Id := Component_Clause (C1_Ent);
CC2 : constant Node_Id := Component_Clause (C2_Ent);
begin
if Present (CC1) and then Present (CC2) then
-- Exclude odd case where we have two tag fields in the same
-- record, both at location zero. This seems a bit strange, but
-- it seems to happen in some circumstances, perhaps on an error.
if Chars (C1_Ent) = Name_uTag
and then
Chars (C2_Ent) = Name_uTag
then
return;
end if;
-- Here we check if the two fields overlap
declare
S1 : constant Uint := Component_Bit_Offset (C1_Ent);
S2 : constant Uint := Component_Bit_Offset (C2_Ent);
E1 : constant Uint := S1 + Esize (C1_Ent);
E2 : constant Uint := S2 + Esize (C2_Ent);
begin
if E2 <= S1 or else E1 <= S2 then
null;
else
Error_Msg_Node_2 := Component_Name (CC2);
Error_Msg_Sloc := Sloc (Error_Msg_Node_2);
Error_Msg_Node_1 := Component_Name (CC1);
Error_Msg_N
("component& overlaps & #", Component_Name (CC1));
end if;
end;
end if;
end Check_Component_Overlap;
--------------------
-- Find_Component --
--------------------
procedure Find_Component is
procedure Search_Component (R : Entity_Id);
-- Search components of R for a match. If found, Comp is set.
----------------------
-- Search_Component --
----------------------
procedure Search_Component (R : Entity_Id) is
begin
Comp := First_Component_Or_Discriminant (R);
while Present (Comp) loop
-- Ignore error of attribute name for component name (we
-- already gave an error message for this, so no need to
-- complain here)
if Nkind (Component_Name (CC)) = N_Attribute_Reference then
null;
else
exit when Chars (Comp) = Chars (Component_Name (CC));
end if;
Next_Component_Or_Discriminant (Comp);
end loop;
end Search_Component;
-- Start of processing for Find_Component
begin
-- Return with Comp set to Empty if we have a pragma
if Nkind (CC) = N_Pragma then
Comp := Empty;
return;
end if;
-- Search current record for matching component
Search_Component (Rectype);
-- If not found, maybe component of base type that is absent from
-- statically constrained first subtype.
if No (Comp) then
Search_Component (Base_Type (Rectype));
end if;
-- If no component, or the component does not reference the component
-- clause in question, then there was some previous error for which
-- we already gave a message, so just return with Comp Empty.
if No (Comp)
or else Component_Clause (Comp) /= CC
then
Comp := Empty;
-- Normal case where we have a component clause
else
Fbit := Component_Bit_Offset (Comp);
Lbit := Fbit + Esize (Comp) - 1;
end if;
end Find_Component;
-- Start of processing for Check_Record_Representation_Clause
begin
Find_Type (Ident);
Rectype := Entity (Ident);
if Rectype = Any_Type then
return;
else
Rectype := Underlying_Type (Rectype);
end if;
-- See if we have a fully repped derived tagged type
declare
PS : constant Entity_Id := Parent_Subtype (Rectype);
begin
if Present (PS) and then Is_Fully_Repped_Tagged_Type (PS) then
Tagged_Parent := PS;
-- Find maximum bit of any component of the parent type
Parent_Last_Bit := UI_From_Int (System_Address_Size - 1);
Pcomp := First_Entity (Tagged_Parent);
while Present (Pcomp) loop
if Ekind_In (Pcomp, E_Discriminant, E_Component) then
if Component_Bit_Offset (Pcomp) /= No_Uint
and then Known_Static_Esize (Pcomp)
then
Parent_Last_Bit :=
UI_Max
(Parent_Last_Bit,
Component_Bit_Offset (Pcomp) + Esize (Pcomp) - 1);
end if;
Next_Entity (Pcomp);
end if;
end loop;
end if;
end;
-- All done if no component clauses
CC := First (Component_Clauses (N));
if No (CC) then
return;
end if;
-- If a tag is present, then create a component clause that places it
-- at the start of the record (otherwise gigi may place it after other
-- fields that have rep clauses).
Fent := First_Entity (Rectype);
if Nkind (Fent) = N_Defining_Identifier
and then Chars (Fent) = Name_uTag
then
Set_Component_Bit_Offset (Fent, Uint_0);
Set_Normalized_Position (Fent, Uint_0);
Set_Normalized_First_Bit (Fent, Uint_0);
Set_Normalized_Position_Max (Fent, Uint_0);
Init_Esize (Fent, System_Address_Size);
Set_Component_Clause (Fent,
Make_Component_Clause (Loc,
Component_Name =>
Make_Identifier (Loc,
Chars => Name_uTag),
Position =>
Make_Integer_Literal (Loc,
Intval => Uint_0),
First_Bit =>
Make_Integer_Literal (Loc,
Intval => Uint_0),
Last_Bit =>
Make_Integer_Literal (Loc,
UI_From_Int (System_Address_Size))));
Ccount := Ccount + 1;
end if;
Max_Bit_So_Far := Uint_Minus_1;
Overlap_Check_Required := False;
-- Process the component clauses
while Present (CC) loop
Find_Component;
if Present (Comp) then
Ccount := Ccount + 1;
if Fbit <= Max_Bit_So_Far then
Overlap_Check_Required := True;
else
Max_Bit_So_Far := Lbit;
end if;
-- Check bit position out of range of specified size
if Has_Size_Clause (Rectype)
and then Esize (Rectype) <= Lbit
then
Error_Msg_N
("bit number out of range of specified size",
Last_Bit (CC));
-- Check for overlap with tag field
else
if Is_Tagged_Type (Rectype)
and then Fbit < System_Address_Size
then
Error_Msg_NE
("component overlaps tag field of&",
Component_Name (CC), Rectype);
end if;
if Hbit < Lbit then
Hbit := Lbit;
end if;
end if;
-- Check parent overlap if component might overlap parent field
if Present (Tagged_Parent)
and then Fbit <= Parent_Last_Bit
then
Pcomp := First_Component_Or_Discriminant (Tagged_Parent);
while Present (Pcomp) loop
if not Is_Tag (Pcomp)
and then Chars (Pcomp) /= Name_uParent
then
Check_Component_Overlap (Comp, Pcomp);
end if;
Next_Component_Or_Discriminant (Pcomp);
end loop;
end if;
end if;
Next (CC);
end loop;
-- Now that we have processed all the component clauses, check for
-- overlap. We have to leave this till last, since the components can
-- appear in any arbitrary order in the representation clause.
-- We do not need this check if all specified ranges were monotonic,
-- as recorded by Overlap_Check_Required being False at this stage.
-- This first section checks if there are any overlapping entries at
-- all. It does this by sorting all entries and then seeing if there are
-- any overlaps. If there are none, then that is decisive, but if there
-- are overlaps, they may still be OK (they may result from fields in
-- different variants).
if Overlap_Check_Required then
Overlap_Check1 : declare
OC_Fbit : array (0 .. Ccount) of Uint;
-- First-bit values for component clauses, the value is the offset
-- of the first bit of the field from start of record. The zero
-- entry is for use in sorting.
OC_Lbit : array (0 .. Ccount) of Uint;
-- Last-bit values for component clauses, the value is the offset
-- of the last bit of the field from start of record. The zero
-- entry is for use in sorting.
OC_Count : Natural := 0;
-- Count of entries in OC_Fbit and OC_Lbit
function OC_Lt (Op1, Op2 : Natural) return Boolean;
-- Compare routine for Sort
procedure OC_Move (From : Natural; To : Natural);
-- Move routine for Sort
package Sorting is new GNAT.Heap_Sort_G (OC_Move, OC_Lt);
-----------
-- OC_Lt --
-----------
function OC_Lt (Op1, Op2 : Natural) return Boolean is
begin
return OC_Fbit (Op1) < OC_Fbit (Op2);
end OC_Lt;
-------------
-- OC_Move --
-------------
procedure OC_Move (From : Natural; To : Natural) is
begin
OC_Fbit (To) := OC_Fbit (From);
OC_Lbit (To) := OC_Lbit (From);
end OC_Move;
-- Start of processing for Overlap_Check
begin
CC := First (Component_Clauses (N));
while Present (CC) loop
-- Exclude component clause already marked in error
if not Error_Posted (CC) then
Find_Component;
if Present (Comp) then
OC_Count := OC_Count + 1;
OC_Fbit (OC_Count) := Fbit;
OC_Lbit (OC_Count) := Lbit;
end if;
end if;
Next (CC);
end loop;
Sorting.Sort (OC_Count);
Overlap_Check_Required := False;
for J in 1 .. OC_Count - 1 loop
if OC_Lbit (J) >= OC_Fbit (J + 1) then
Overlap_Check_Required := True;
exit;
end if;
end loop;
end Overlap_Check1;
end if;
-- If Overlap_Check_Required is still True, then we have to do the full
-- scale overlap check, since we have at least two fields that do
-- overlap, and we need to know if that is OK since they are in
-- different variant, or whether we have a definite problem.
if Overlap_Check_Required then
Overlap_Check2 : declare
C1_Ent, C2_Ent : Entity_Id;
-- Entities of components being checked for overlap
Clist : Node_Id;
-- Component_List node whose Component_Items are being checked
Citem : Node_Id;
-- Component declaration for component being checked
begin
C1_Ent := First_Entity (Base_Type (Rectype));
-- Loop through all components in record. For each component check
-- for overlap with any of the preceding elements on the component
-- list containing the component and also, if the component is in
-- a variant, check against components outside the case structure.
-- This latter test is repeated recursively up the variant tree.
Main_Component_Loop : while Present (C1_Ent) loop
if not Ekind_In (C1_Ent, E_Component, E_Discriminant) then
goto Continue_Main_Component_Loop;
end if;
-- Skip overlap check if entity has no declaration node. This
-- happens with discriminants in constrained derived types.
-- Probably we are missing some checks as a result, but that
-- does not seem terribly serious ???
if No (Declaration_Node (C1_Ent)) then
goto Continue_Main_Component_Loop;
end if;
Clist := Parent (List_Containing (Declaration_Node (C1_Ent)));
-- Loop through component lists that need checking. Check the
-- current component list and all lists in variants above us.
Component_List_Loop : loop
-- If derived type definition, go to full declaration
-- If at outer level, check discriminants if there are any.
if Nkind (Clist) = N_Derived_Type_Definition then
Clist := Parent (Clist);
end if;
-- Outer level of record definition, check discriminants
if Nkind_In (Clist, N_Full_Type_Declaration,
N_Private_Type_Declaration)
then
if Has_Discriminants (Defining_Identifier (Clist)) then
C2_Ent :=
First_Discriminant (Defining_Identifier (Clist));
while Present (C2_Ent) loop
exit when C1_Ent = C2_Ent;
Check_Component_Overlap (C1_Ent, C2_Ent);
Next_Discriminant (C2_Ent);
end loop;
end if;
-- Record extension case
elsif Nkind (Clist) = N_Derived_Type_Definition then
Clist := Empty;
-- Otherwise check one component list
else
Citem := First (Component_Items (Clist));
while Present (Citem) loop
if Nkind (Citem) = N_Component_Declaration then
C2_Ent := Defining_Identifier (Citem);
exit when C1_Ent = C2_Ent;
Check_Component_Overlap (C1_Ent, C2_Ent);
end if;
Next (Citem);
end loop;
end if;
-- Check for variants above us (the parent of the Clist can
-- be a variant, in which case its parent is a variant part,
-- and the parent of the variant part is a component list
-- whose components must all be checked against the current
-- component for overlap).
if Nkind (Parent (Clist)) = N_Variant then
Clist := Parent (Parent (Parent (Clist)));
-- Check for possible discriminant part in record, this
-- is treated essentially as another level in the
-- recursion. For this case the parent of the component
-- list is the record definition, and its parent is the
-- full type declaration containing the discriminant
-- specifications.
elsif Nkind (Parent (Clist)) = N_Record_Definition then
Clist := Parent (Parent ((Clist)));
-- If neither of these two cases, we are at the top of
-- the tree.
else
exit Component_List_Loop;
end if;
end loop Component_List_Loop;
<<Continue_Main_Component_Loop>>
Next_Entity (C1_Ent);
end loop Main_Component_Loop;
end Overlap_Check2;
end if;
-- For records that have component clauses for all components, and whose
-- size is less than or equal to 32, we need to know the size in the
-- front end to activate possible packed array processing where the
-- component type is a record.
-- At this stage Hbit + 1 represents the first unused bit from all the
-- component clauses processed, so if the component clauses are
-- complete, then this is the length of the record.
-- For records longer than System.Storage_Unit, and for those where not
-- all components have component clauses, the back end determines the
-- length (it may for example be appropriate to round up the size
-- to some convenient boundary, based on alignment considerations, etc).
if Unknown_RM_Size (Rectype) and then Hbit + 1 <= 32 then
-- Nothing to do if at least one component has no component clause
Comp := First_Component_Or_Discriminant (Rectype);
while Present (Comp) loop
exit when No (Component_Clause (Comp));
Next_Component_Or_Discriminant (Comp);
end loop;
-- If we fall out of loop, all components have component clauses
-- and so we can set the size to the maximum value.
if No (Comp) then
Set_RM_Size (Rectype, Hbit + 1);
end if;
end if;
end Check_Record_Representation_Clause;
----------------
-- Check_Size --
----------------
......
gcc/ada/sem_ch13.ads
......@@ -38,9 +38,17 @@ package Sem_Ch13 is
procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id);
-- Called from Freeze where R is a record entity for which reverse bit
-- order is specified and there is at least one component clause. Adjusts
-- component positions according to Ada 2005 AI-133. Note that this is only
-- called in Ada 2005 mode. The Ada 95 handling for bit order is entirely
-- contained in Freeze.
-- component positions according to either Ada 95 or Ada 2005 (AI-133).
procedure Check_Record_Representation_Clause (N : Node_Id);
-- This procedure completes the analysis of a record representation clause
-- N. It is called at freeze time after adjustment of component clause bit
-- positions for possible non-standard bit order. In the case of Ada 2005
-- (machine scalar) mode, this adjustment can make substantial changes, so
-- some checks, in particular for component overlaps cannot be done at the
-- time the record representation clause is first seen, but must be delayed
-- till freeze time, and in particular is called after calling the above
-- procedure for adjusting record bit positions for reverse bit order.
procedure Initialize;
-- Initialize internal tables for new compilation
......
gcc/ada/sem_eval.adb
......@@ -2534,9 +2534,9 @@ package body Sem_Eval is
-- Eval_Relational_Op --
------------------------
-- Relational operations are static functions, so the result is static
-- if both operands are static (RM 4.9(7), 4.9(20)), except that for
-- strings, the result is never static, even if the operands are.
-- Relational operations are static functions, so the result is static if
-- both operands are static (RM 4.9(7), 4.9(20)), except that for strings,
-- the result is never static, even if the operands are.
procedure Eval_Relational_Op (N : Node_Id) is
Left : constant Node_Id := Left_Opnd (N);
......@@ -2650,17 +2650,37 @@ package body Sem_Eval is
if Nkind (Expr) = N_Op_Add
and then Compile_Time_Known_Value (Right_Opnd (Expr))
then
Exp := Left_Opnd (Expr);
Exp := Left_Opnd (Expr);
Cons := Expr_Value (Right_Opnd (Expr));
elsif Nkind (Expr) = N_Op_Subtract
and then Compile_Time_Known_Value (Right_Opnd (Expr))
then
Exp := Left_Opnd (Expr);
Exp := Left_Opnd (Expr);
Cons := -Expr_Value (Right_Opnd (Expr));
-- If the bound is a constant created to remove side
-- effects, recover original expression to see if it has
-- one of the recognizable forms.
elsif Nkind (Expr) = N_Identifier
and then not Comes_From_Source (Entity (Expr))
and then Ekind (Entity (Expr)) = E_Constant
and then
Nkind (Parent (Entity (Expr))) = N_Object_Declaration
then
Exp := Expression (Parent (Entity (Expr)));
Decompose_Expr (Exp, Ent, Kind, Cons);
-- If original expression includes an entity, create a
-- reference to it for use below.
if Present (Ent) then
Exp := New_Occurrence_Of (Ent, Sloc (Ent));
end if;
else
Exp := Expr;
Exp := Expr;
Cons := Uint_0;
end if;
......@@ -2669,8 +2689,10 @@ package body Sem_Eval is
if Nkind (Exp) = N_Attribute_Reference then
if Attribute_Name (Exp) = Name_First then
Kind := 'F';
elsif Attribute_Name (Exp) = Name_Last then
Kind := 'L';
else
Ent := Empty;
return;
......
gcc/ada/sem_intr.adb
......@@ -73,9 +73,7 @@ package body Sem_Intr is
procedure Check_Exception_Function (E : Entity_Id; N : Node_Id) is
begin
if Ekind (E) /= E_Function
and then Ekind (E) /= E_Generic_Function
then
if not Ekind_In (E, E_Function, E_Generic_Function) then
Errint
("intrinsic exception subprogram must be a function", E, N);
......@@ -374,9 +372,7 @@ package body Sem_Intr is
Ptyp2 : Node_Id;
begin
if Ekind (E) /= E_Function
and then Ekind (E) /= E_Generic_Function
then
if not Ekind_In (E, E_Function, E_Generic_Function) then
Errint ("intrinsic shift subprogram must be a function", E, N);
return;
end if;
......
gcc/ada/sem_prag.adb
......@@ -1846,7 +1846,8 @@ package body Sem_Prag is
Proc := Entity (Name);
if Ekind (Proc) /= E_Procedure
or else Present (First_Formal (Proc)) then
or else Present (First_Formal (Proc))
then
Error_Pragma_Arg
("argument of pragma% must be parameterless procedure", Arg);
end if;
......@@ -2516,10 +2517,7 @@ package body Sem_Prag is
-- Check that we are not applying this to a named constant
if Ekind (E) = E_Named_Integer
or else
Ekind (E) = E_Named_Real
then
if Ekind_In (E, E_Named_Integer, E_Named_Real) then
Error_Msg_Name_1 := Pname;
Error_Msg_N
("cannot apply pragma% to named constant!",
......@@ -2756,9 +2754,7 @@ package body Sem_Prag is
Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
Def_Id := Entity (Arg_Internal);
if Ekind (Def_Id) /= E_Constant
and then Ekind (Def_Id) /= E_Variable
then
if not Ekind_In (Def_Id, E_Constant, E_Variable) then
Error_Pragma_Arg
("pragma% must designate an object", Arg_Internal);
end if;
......@@ -3368,10 +3364,8 @@ package body Sem_Prag is
Kill_Size_Check_Code (Def_Id);
Note_Possible_Modification (Expression (Arg2), Sure => False);
if Ekind (Def_Id) = E_Variable
or else
Ekind (Def_Id) = E_Constant
then
if Ekind_In (Def_Id, E_Variable, E_Constant) then
-- We do not permit Import to apply to a renaming declaration
if Present (Renamed_Object (Def_Id)) then
......@@ -9131,9 +9125,7 @@ package body Sem_Prag is
while Present (E)
and then Scope (E) = Current_Scope
loop
if Ekind (E) = E_Procedure
or else Ekind (E) = E_Generic_Procedure
then
if Ekind_In (E, E_Procedure, E_Generic_Procedure) then
Set_No_Return (E);
-- Set flag on any alias as well
......@@ -10291,9 +10283,7 @@ package body Sem_Prag is
Def_Id := Entity (Internal);
if Ekind (Def_Id) /= E_Constant
and then Ekind (Def_Id) /= E_Variable
then
if not Ekind_In (Def_Id, E_Constant, E_Variable) then
Error_Pragma_Arg
("pragma% must designate an object", Internal);
end if;
......@@ -10459,9 +10449,9 @@ package body Sem_Prag is
loop
Def_Id := Get_Base_Subprogram (E);
if Ekind (Def_Id) /= E_Function
and then Ekind (Def_Id) /= E_Generic_Function
and then Ekind (Def_Id) /= E_Operator
if not Ekind_In (Def_Id, E_Function,
E_Generic_Function,
E_Operator)
then
Error_Pragma_Arg
("pragma% requires a function name", Arg1);
......
gcc/ada/sem_res.adb
......@@ -3534,9 +3534,7 @@ package body Sem_Res is
-- might not be done in the In Out case since Gigi does not do
-- any analysis. More thought required about this ???
if Ekind (F) = E_In_Parameter
or else Ekind (F) = E_In_Out_Parameter
then
if Ekind_In (F, E_In_Parameter, E_In_Out_Parameter) then
if Is_Scalar_Type (Etype (A)) then
Apply_Scalar_Range_Check (A, F_Typ);
......@@ -3582,9 +3580,7 @@ package body Sem_Res is
end if;
end if;
if Ekind (F) = E_Out_Parameter
or else Ekind (F) = E_In_Out_Parameter
then
if Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter) then
if Nkind (A) = N_Type_Conversion then
if Is_Scalar_Type (A_Typ) then
Apply_Scalar_Range_Check
......@@ -6163,9 +6159,7 @@ package body Sem_Res is
Resolve_Actuals (N, Nam);
Generate_Reference (Nam, Entry_Name);
if Ekind (Nam) = E_Entry
or else Ekind (Nam) = E_Entry_Family
then
if Ekind_In (Nam, E_Entry, E_Entry_Family) then
Check_Potentially_Blocking_Operation (N);
end if;
......@@ -8559,9 +8553,7 @@ package body Sem_Res is
-- Handle subtypes
if Ekind (Opnd) = E_Protected_Subtype
or else Ekind (Opnd) = E_Task_Subtype
then
if Ekind_In (Opnd, E_Protected_Subtype, E_Task_Subtype) then
Opnd := Etype (Opnd);
end if;
......@@ -8954,19 +8946,20 @@ package body Sem_Res is
Index_Subtype := Create_Itype (Subtype_Kind (Ekind (Index_Type)), N);
Set_Scalar_Range (Index_Subtype, Drange);
-- Take a new copy of Drange (where bounds have been rewritten to
-- reference side-effect-vree names). Using a separate tree ensures
-- that further expansion (e.g while rewriting a slice assignment
-- into a FOR loop) does not attempt to remove side effects on the
-- bounds again (which would cause the bounds in the index subtype
-- definition to refer to temporaries before they are defined) (the
-- reason is that some names are considered side effect free here
-- for the subtype, but not in the context of a loop iteration
-- scheme).
Set_Scalar_Range (Index_Subtype, New_Copy_Tree (Drange));
Set_Etype (Index_Subtype, Index_Type);
Set_Size_Info (Index_Subtype, Index_Type);
Set_RM_Size (Index_Subtype, RM_Size (Index_Type));
-- Now replace the discrete range in the slice with a reference to
-- its index subtype. This ensures that further expansion (e.g
-- while rewriting a slice assignment into a FOR loop) does not
-- attempt to remove side effects on the bounds again (which would
-- cause the bounds in the index subtype definition to refer to
-- temporaries before they are defined).
Set_Discrete_Range (N, New_Copy_Tree (Drange));
end if;
Slice_Subtype := Create_Itype (E_Array_Subtype, N);
......@@ -8979,15 +8972,26 @@ package body Sem_Res is
Set_Etype (Slice_Subtype, Base_Type (Etype (N)));
Set_Is_Constrained (Slice_Subtype, True);
Check_Compile_Time_Size (Slice_Subtype);
-- The Etype of the existing Slice node is reset to this slice subtype.
-- Its bounds are obtained from its first index.
Set_Etype (N, Slice_Subtype);
-- Always freeze subtype. This ensures that the slice subtype is
-- elaborated in the scope of the expression.
-- For packed slice subtypes, freeze immediately. Otherwise insert an
-- itype reference in the slice's actions so that the itype is frozen
-- at the proper place in the tree (i.e. at the point where actions
-- for the slice are analyzed). Note that this is different from
-- freezing the itype immediately, which might be premature (e.g. if
-- the slice is within a transient scope).
if Is_Packed (Slice_Subtype) and not In_Spec_Expression then
Freeze_Itype (Slice_Subtype, N);
Freeze_Itype (Slice_Subtype, N);
else
Ensure_Defined (Typ => Slice_Subtype, N => N);
end if;
end Set_Slice_Subtype;
--------------------------------
......@@ -9732,7 +9736,6 @@ package body Sem_Res is
elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type
and then not Is_Local_Anonymous_Access (Opnd_Type)
then
-- When the operand is a selected access discriminant the check
-- needs to be made against the level of the object denoted by
-- the prefix of the selected name (Object_Access_Level handles
......
gcc/ada/sem_type.adb
......@@ -362,7 +362,6 @@ package body Sem_Type is
-- performed, given that the operator was visible in the generic.
if Ekind (E) = E_Operator then
if Present (Opnd_Type) then
Vis_Type := Opnd_Type;
else
......@@ -803,8 +802,8 @@ package body Sem_Type is
then
return True;
-- The context may be class wide, and a class-wide type is
-- compatible with any member of the class.
-- The context may be class wide, and a class-wide type is compatible
-- with any member of the class.
elsif Is_Class_Wide_Type (T1)
and then Is_Ancestor (Root_Type (T1), T2)
......@@ -997,9 +996,7 @@ package body Sem_Type is
-- imposed by context.
elsif Ekind (T2) = E_Access_Attribute_Type
and then (Ekind (BT1) = E_General_Access_Type
or else
Ekind (BT1) = E_Access_Type)
and then Ekind_In (BT1, E_General_Access_Type, E_Access_Type)
and then Covers (Designated_Type (T1), Designated_Type (T2))
then
-- If the target type is a RACW type while the source is an access
......@@ -1677,9 +1674,8 @@ package body Sem_Type is
elsif Nkind (Parent (N)) = N_Object_Renaming_Declaration
and then Present (Access_Definition (Parent (N)))
then
if Ekind (It1.Typ) = E_Anonymous_Access_Type
or else
Ekind (It1.Typ) = E_Anonymous_Access_Subprogram_Type
if Ekind_In (It1.Typ, E_Anonymous_Access_Type,
E_Anonymous_Access_Subprogram_Type)
then
if Ekind (It2.Typ) = Ekind (It1.Typ) then
......@@ -1691,9 +1687,8 @@ package body Sem_Type is
return It1;
end if;
elsif Ekind (It2.Typ) = E_Anonymous_Access_Type
or else
Ekind (It2.Typ) = E_Anonymous_Access_Subprogram_Type
elsif Ekind_In (It2.Typ, E_Anonymous_Access_Type,
E_Anonymous_Access_Subprogram_Type)
then
return It2;
......@@ -1880,8 +1875,8 @@ package body Sem_Type is
if Ekind (Etype (Opnd)) = E_Anonymous_Access_Type
and then
List_Containing (Parent (Designated_Type (Etype (Opnd))))
= List_Containing (Unit_Declaration_Node (User_Subp))
List_Containing (Parent (Designated_Type (Etype (Opnd))))
= List_Containing (Unit_Declaration_Node (User_Subp))
then
if It2.Nam = Predef_Subp then
return It1;
......
gcc/ada/sem_util.adb
......@@ -2817,9 +2817,7 @@ package body Sem_Util is
-- Avoid cascaded messages with duplicate components in
-- derived types.
if Ekind (E) = E_Component
or else Ekind (E) = E_Discriminant
then
if Ekind_In (E, E_Component, E_Discriminant) then
return;
end if;
end if;
......@@ -2854,9 +2852,7 @@ package body Sem_Util is
-- midst of inheriting components in a derived record definition.
-- Preserve their Ekind and Etype.
if Ekind (Def_Id) = E_Discriminant
or else Ekind (Def_Id) = E_Component
then
if Ekind_In (Def_Id, E_Discriminant, E_Component) then
null;
-- If a type is already set, leave it alone (happens whey a type
......@@ -2876,8 +2872,7 @@ package body Sem_Util is
-- Inherited discriminants and components in derived record types are
-- immediately visible. Itypes are not.
if Ekind (Def_Id) = E_Discriminant
or else Ekind (Def_Id) = E_Component
if Ekind_In (Def_Id, E_Discriminant, E_Component)
or else (No (Corresponding_Remote_Type (Def_Id))
and then not Is_Itype (Def_Id))
then
......@@ -4848,10 +4843,8 @@ package body Sem_Util is
-- We are interested only in components and discriminants
if Ekind (Ent) = E_Component
or else
Ekind (Ent) = E_Discriminant
then
if Ekind_In (Ent, E_Component, E_Discriminant) then
-- Get default expression if any. If there is no declaration
-- node, it means we have an internal entity. The parent and
-- tag fields are examples of such entities. For these cases,
......@@ -6376,10 +6369,7 @@ package body Sem_Util is
Ent : constant Entity_Id := Entity (Expr);
Sub : constant Entity_Id := Enclosing_Subprogram (Ent);
begin
if Ekind (Ent) /= E_Variable
and then
Ekind (Ent) /= E_In_Out_Parameter
then
if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then
return False;
else
return Present (Sub) and then Sub = Current_Subprogram;
......@@ -8658,9 +8648,7 @@ package body Sem_Util is
-- If a record subtype is simply copied, the entity list will be
-- shared. Thus cloned_Subtype must be set to indicate the sharing.
if Ekind (Old_Itype) = E_Record_Subtype
or else Ekind (Old_Itype) = E_Class_Wide_Subtype
then
if Ekind_In (Old_Itype, E_Record_Subtype, E_Class_Wide_Subtype) then
Set_Cloned_Subtype (New_Itype, Old_Itype);
end if;
......@@ -10151,12 +10139,7 @@ package body Sem_Util is
while R_Scope /= Standard_Standard loop
exit when R_Scope = E_Scope;
if Ekind (R_Scope) /= E_Package
and then
Ekind (R_Scope) /= E_Block
and then
Ekind (R_Scope) /= E_Loop
then
if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then
return False;
else
R_Scope := Scope (R_Scope);
......
gcc/ada/sem_warn.adb
......@@ -1027,9 +1027,8 @@ package body Sem_Warn is
-- we exclude protected types, too complicated to worry about.
if Ekind (E1) = E_Variable
or else
((Ekind (E1) = E_Out_Parameter
or else Ekind (E1) = E_In_Out_Parameter)
or else
(Ekind_In (E1, E_Out_Parameter, E_In_Out_Parameter)
and then not Is_Protected_Type (Current_Scope))
then
-- Case of an unassigned variable
......@@ -1345,7 +1344,7 @@ package body Sem_Warn is
while Present (Comp) loop
if Ekind (Comp) = E_Component
and then Nkind (Parent (Comp)) =
N_Component_Declaration
N_Component_Declaration
and then No (Expression (Parent (Comp)))
then
Error_Msg_Node_2 := Comp;
......@@ -2883,9 +2882,7 @@ package body Sem_Warn is
-- Reference to obsolescent component
elsif Ekind (E) = E_Component
or else Ekind (E) = E_Discriminant
then
elsif Ekind_In (E, E_Component, E_Discriminant) then
Error_Msg_NE
("?reference to obsolescent component& declared#", N, E);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment