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> 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 * back_end.adb, sem_res.adb, switch-c.adb, sem_scil.adb: Minor
reformatting. reformatting.
* sem_attr.adb, sem_cat.adb, sem_disp.adb, sem_elab.adb, sem_elim.adb, * 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 ...@@ -5760,6 +5760,26 @@ package body Einfo is
end if; end if;
end Get_Full_View; 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 -- -- Get_Rep_Pragma --
-------------------- --------------------
......
gcc/ada/einfo.ads
...@@ -6767,6 +6767,11 @@ package Einfo is ...@@ -6767,6 +6767,11 @@ package Einfo is
-- value returned is the N_Attribute_Definition_Clause node, otherwise -- value returned is the N_Attribute_Definition_Clause node, otherwise
-- Empty is returned. -- 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; 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 -- 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 -- a representation pragma with the given name Nam. If found then the
......
gcc/ada/freeze.adb
...@@ -1776,7 +1776,7 @@ package body Freeze is ...@@ -1776,7 +1776,7 @@ package body Freeze is
Prev := Empty; Prev := Empty;
while Present (Comp) loop while Present (Comp) loop
-- First handle the (real) component case -- First handle the component case
if Ekind (Comp) = E_Component if Ekind (Comp) = E_Component
or else Ekind (Comp) = E_Discriminant or else Ekind (Comp) = E_Discriminant
...@@ -1847,129 +1847,12 @@ package body Freeze is ...@@ -1847,129 +1847,12 @@ package body Freeze is
Component_Name (Component_Clause (Comp))); Component_Name (Component_Clause (Comp)));
end if; end if;
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;
end if; 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 if not Is_Scalar_Type (Etype (Comp)) then
All_Scalar_Components := False; All_Scalar_Components := False;
...@@ -2118,7 +2001,7 @@ package body Freeze is ...@@ -2118,7 +2001,7 @@ package body Freeze is
Next_Entity (Comp); Next_Entity (Comp);
end loop; 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 Reverse_Bit_Order (Rec) and then Base_Type (Rec) = Rec then
if not Placed_Component then if not Placed_Component then
...@@ -2129,14 +2012,25 @@ package body Freeze is ...@@ -2129,14 +2012,25 @@ package body Freeze is
Error_Msg_N Error_Msg_N
("\?since no component clauses were specified", ADC); ("\?since no component clauses were specified", ADC);
-- Here is where we do Ada 2005 processing for bit order (the Ada -- Here is where we do the processing for reversed bit order
-- 95 case was already taken care of above).
elsif Ada_Version >= Ada_05 then else
Adjust_Record_For_Reverse_Bit_Order (Rec); Adjust_Record_For_Reverse_Bit_Order (Rec);
end if; end if;
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 -- Set OK_To_Reorder_Components depending on debug flags
if Rec = Base_Type (Rec) if Rec = Base_Type (Rec)
......
gcc/ada/sem_ch13.adb
...@@ -73,10 +73,6 @@ package body Sem_Ch13 is ...@@ -73,10 +73,6 @@ package body Sem_Ch13 is
-- inherited from a derived type that is no longer appropriate for the -- inherited from a derived type that is no longer appropriate for the
-- new Esize value. In this case, we reset the Alignment to unknown. -- 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; function Get_Alignment_Value (Expr : Node_Id) return Uint;
-- Given the expression for an alignment value, returns the corresponding -- Given the expression for an alignment value, returns the corresponding
-- Uint value. If the value is inappropriate, then error messages are -- Uint value. If the value is inappropriate, then error messages are
...@@ -180,265 +176,421 @@ package body Sem_Ch13 is ...@@ -180,265 +176,421 @@ package body Sem_Ch13 is
----------------------------------------- -----------------------------------------
procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id) is procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id) is
Max_Machine_Scalar_Size : constant Uint := Comp : Node_Id;
UI_From_Int CC : Node_Id;
(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);
begin begin
-- This first loop through components does two things. First it deals -- Processing depends on version of Ada
-- 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);
begin case Ada_Version is
if Present (CC) then
declare
Fbit : constant Uint := Static_Integer (First_Bit (CC));
begin -- For Ada 95, we just renumber bits within a storage unit. We do
-- Case of component with size > max machine scalar -- 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 -- We only do this processing for the base type, and in
Error_Msg_N -- fact that's important, since otherwise if there are
("illegal first bit value for reverse bit order", -- record subtypes, we could reverse the bits once for
First_Bit (CC)); -- each subtype, which would be incorrect.
Error_Msg_Uint_1 := SSU;
Error_Msg_Uint_2 := Max_Machine_Scalar_Size;
Error_Msg_N if Present (CC)
("\must be a multiple of ^ if size greater than ^", and then Ekind (R) = E_Record_Type
First_Bit (CC)); 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 Start_Bit : constant Uint :=
Error_Msg_N CFB mod System_Storage_Unit;
("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 begin
("\must be a multiple of ^ if size greater than ^", -- Cases where field goes over storage unit boundary
Last_Bit (CC));
-- OK, give warning if enabled if Start_Bit + CSZ > System_Storage_Unit then
elsif Warn_On_Reverse_Bit_Order then -- Allow multi-byte field but generate warning
Error_Msg_N
("multi-byte field specified with non-standard"
& " Bit_Order?", CC);
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 Error_Msg_N
("\bytes are not reversed " ("multi-byte field specified with non-standard"
& "(component is big-endian)?", CC); & " 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 else
Error_Msg_N Error_Msg_N
("\bytes are not reversed " ("attempt to specify non-contiguous field "
& "(component is little-endian)?", CC); & "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;
end if;
-- Case where size is not greater than max machine -- Case where field fits in one storage unit
-- scalar. For now, we just count these.
else else
Num_CC := Num_CC + 1; -- Give warning if suspicious component clause
end if;
end;
end if;
end;
Next_Component_Or_Discriminant (Comp); if Intval (FB) >= System_Storage_Unit
end loop; 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 -- Here is where we fix up the Component_Bit_Offset
-- values in the clause, so we can group clauses with the same Position. -- value to account for the reverse bit order.
-- together to determine the relevant machine scalar size. -- Some examples of what needs to be done are:
declare -- First_Bit .. Last_Bit Component_Bit_Offset
Comps : array (0 .. Num_CC) of Entity_Id; -- old new old new
-- Array to collect component and discriminant entities. The data
-- starts at index 1, the 0'th entry is for the sort routine.
function CP_Lt (Op1, Op2 : Natural) return Boolean; -- 0 .. 0 7 .. 7 0 7
-- Compare routine for Sort -- 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); -- 1 .. 1 6 .. 6 1 6
-- Move routine for Sort -- 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; Set_Component_Bit_Offset
Stop : Natural; (Comp,
-- Start and stop positions in component list of set of components (Storage_Unit_Offset * System_Storage_Unit) +
-- with the same starting position (that constitute components in (System_Storage_Unit - 1) -
-- a single machine scalar). (Start_Bit + CSZ - 1));
MaxL : Uint; Set_Normalized_First_Bit
-- Maximum last bit value of any component in this set (Comp,
Component_Bit_Offset (Comp) mod
System_Storage_Unit);
end if;
end;
end if;
MSS : Uint; Next_Component_Or_Discriminant (Comp);
-- Corresponding machine scalar size end loop;
----------- -- For Ada 2005, we do machine scalar processing, as fully described
-- CP_Lt -- -- 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 when Ada_05 =>
begin declare
return Position (Component_Clause (Comps (Op1))) < Max_Machine_Scalar_Size : constant Uint :=
Position (Component_Clause (Comps (Op2))); UI_From_Int
end CP_Lt; (Standard_Long_Long_Integer_Size);
-- We use this as the maximum machine scalar size
------------- Num_CC : Natural;
-- CP_Move -- SSU : constant Uint := UI_From_Int (System_Storage_Unit);
-------------
procedure CP_Move (From : Natural; To : Natural) is begin
begin -- This first loop through components does two things. First it
Comps (To) := Comps (From); -- deals with the case of components with component clauses
end CP_Move; -- 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 if Present (CC) then
-- Collect the component clauses declare
Fbit : constant Uint :=
Static_Integer (First_Bit (CC));
Num_CC := 0; begin
Comp := First_Component_Or_Discriminant (R); -- Case of component with size > max machine scalar
while Present (Comp) loop
if Present (Component_Clause (Comp)) if Esize (Comp) > Max_Machine_Scalar_Size then
and then Esize (Comp) <= Max_Machine_Scalar_Size
then -- Must begin on byte boundary
Num_CC := Num_CC + 1;
Comps (Num_CC) := Comp; if Fbit mod SSU /= 0 then
end if; 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); -- Case where size is not greater than max machine
end loop; -- scalar. For now, we just count these.
-- Sort by ascending position number else
Num_CC := Num_CC + 1;
Sorting.Sort (Num_CC); end if;
end;
-- We now have all the components whose size does not exceed the max end if;
-- 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 Next_Component_Or_Discriminant (Comp);
-- whose positions are identical, and MaxL is the maximum last bit end loop;
-- value of any of these components.
-- We need to determine the corresponding machine scalar size. -- We need to sort the component clauses on the basis of the
-- This loop assumes that machine scalar sizes are even, and that -- Position values in the clause, so we can group clauses with
-- each possible machine scalar has twice as many bits as the -- the same Position. together to determine the relevant
-- next smaller one. -- machine scalar size.
MSS := Max_Machine_Scalar_Size; Sort_CC : declare
while MSS mod 2 = 0 Comps : array (0 .. Num_CC) of Entity_Id;
and then (MSS / 2) >= SSU -- Array to collect component and discriminant entities. The
and then (MSS / 2) > MaxL -- data starts at index 1, the 0'th entry is for the sort
loop -- routine.
MSS := MSS / 2;
end loop;
-- Here is where we fix up the Component_Bit_Offset value to function CP_Lt (Op1, Op2 : Natural) return Boolean;
-- account for the reverse bit order. Some examples of what needs -- Compare routine for Sort
-- to be done for the case of a machine scalar size of 8 are:
-- First_Bit .. Last_Bit Component_Bit_Offset procedure CP_Move (From : Natural; To : Natural);
-- old new old new -- Move routine for Sort
-- 0 .. 0 7 .. 7 0 7 package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt);
-- 0 .. 1 6 .. 7 0 6
-- 0 .. 2 5 .. 7 0 5
-- 0 .. 7 0 .. 7 0 4
-- 1 .. 1 6 .. 6 1 6 Start : Natural;
-- 1 .. 4 3 .. 6 1 3 Stop : Natural;
-- 4 .. 7 0 .. 3 4 0 -- 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 MaxL : Uint;
-- subtracting the old ending bit from machine scalar size - 1. -- Maximum last bit value of any component in this set
for C in Start .. Stop loop MSS : Uint;
declare -- Corresponding machine scalar size
Comp : constant Entity_Id := Comps (C);
CC : constant Node_Id := Component_Clause (Comp); -----------
LB : constant Uint := Static_Integer (Last_Bit (CC)); -- CP_Lt --
NFB : constant Uint := MSS - Uint_1 - LB; -----------
NLB : constant Uint := NFB + Esize (Comp) - 1;
Pos : constant Uint := Static_Integer (Position (CC)); 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 begin
if Warn_On_Reverse_Bit_Order then -- Collect the component clauses
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 Num_CC := 0;
Error_Msg_NE Comp := First_Component_Or_Discriminant (R);
("?\info: big-endian range for " while Present (Comp) loop
& "component & is ^ .. ^", if Present (Component_Clause (Comp))
First_Bit (CC), Comp); and then Esize (Comp) <= Max_Machine_Scalar_Size
else then
Error_Msg_NE Num_CC := Num_CC + 1;
("?\info: little-endian range " Comps (Num_CC) := Comp;
& "for component & is ^ .. ^",
First_Bit (CC), Comp);
end if; end if;
end if;
Set_Component_Bit_Offset (Comp, Pos * SSU + NFB); Next_Component_Or_Discriminant (Comp);
Set_Normalized_First_Bit (Comp, NFB mod SSU); end loop;
end;
end loop; -- Sort by ascending position number
end loop;
end; 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; end Adjust_Record_For_Reverse_Bit_Order;
-------------------------------------- --------------------------------------
...@@ -2233,11 +2385,16 @@ package body Sem_Ch13 is ...@@ -2233,11 +2385,16 @@ package body Sem_Ch13 is
-- Analyze_Record_Representation_Clause -- -- 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 procedure Analyze_Record_Representation_Clause (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Ident : constant Node_Id := Identifier (N); Ident : constant Node_Id := Identifier (N);
Rectype : Entity_Id; Rectype : Entity_Id;
Fent : Entity_Id;
CC : Node_Id; CC : Node_Id;
Posit : Uint; Posit : Uint;
Fbit : Uint; Fbit : Uint;
...@@ -2245,33 +2402,8 @@ package body Sem_Ch13 is ...@@ -2245,33 +2402,8 @@ package body Sem_Ch13 is
Hbit : Uint := Uint_0; Hbit : Uint := Uint_0;
Comp : Entity_Id; Comp : Entity_Id;
Ocomp : Entity_Id; Ocomp : Entity_Id;
Pcomp : Entity_Id;
Biased : Boolean; 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; CR_Pragma : Node_Id := Empty;
-- Points to N_Pragma node if Complete_Representation pragma present -- Points to N_Pragma node if Complete_Representation pragma present
...@@ -2386,36 +2518,6 @@ package body Sem_Ch13 is ...@@ -2386,36 +2518,6 @@ package body Sem_Ch13 is
end loop; end loop;
end if; 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 -- All done if no component clauses
CC := First (Component_Clauses (N)); CC := First (Component_Clauses (N));
...@@ -2424,51 +2526,12 @@ package body Sem_Ch13 is ...@@ -2424,51 +2526,12 @@ package body Sem_Ch13 is
return; return;
end if; 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 -- A representation like this applies to the base type
Set_Has_Record_Rep_Clause (Base_Type (Rectype)); Set_Has_Record_Rep_Clause (Base_Type (Rectype));
Set_Has_Non_Standard_Rep (Base_Type (Rectype)); Set_Has_Non_Standard_Rep (Base_Type (Rectype));
Set_Has_Specified_Layout (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 -- Process the component clauses
while Present (CC) loop while Present (CC) loop
...@@ -2487,7 +2550,6 @@ package body Sem_Ch13 is ...@@ -2487,7 +2550,6 @@ package body Sem_Ch13 is
-- Processing for real component clause -- Processing for real component clause
else else
Ccount := Ccount + 1;
Posit := Static_Integer (Position (CC)); Posit := Static_Integer (Position (CC));
Fbit := Static_Integer (First_Bit (CC)); Fbit := Static_Integer (First_Bit (CC));
Lbit := Static_Integer (Last_Bit (CC)); Lbit := Static_Integer (Last_Bit (CC));
...@@ -2596,12 +2658,6 @@ package body Sem_Ch13 is ...@@ -2596,12 +2658,6 @@ package body Sem_Ch13 is
Fbit := Fbit + UI_From_Int (SSU) * Posit; Fbit := Fbit + UI_From_Int (SSU) * Posit;
Lbit := Lbit + 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) if Has_Size_Clause (Rectype)
and then Esize (Rectype) <= Lbit and then Esize (Rectype) <= Lbit
then then
...@@ -2615,17 +2671,6 @@ package body Sem_Ch13 is ...@@ -2615,17 +2671,6 @@ package body Sem_Ch13 is
Set_Normalized_First_Bit (Comp, Fbit mod SSU); Set_Normalized_First_Bit (Comp, Fbit mod SSU);
Set_Normalized_Position (Comp, Fbit / 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 -- This information is also set in the corresponding
-- component of the base type, found by accessing the -- component of the base type, found by accessing the
-- Original_Record_Component link if it is present. -- Original_Record_Component link if it is present.
...@@ -2668,27 +2713,6 @@ package body Sem_Ch13 is ...@@ -2668,27 +2713,6 @@ package body Sem_Ch13 is
Error_Msg_N ("component size is negative", CC); Error_Msg_N ("component size is negative", CC);
end if; end if;
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; end if;
end if; end if;
...@@ -2697,266 +2721,20 @@ package body Sem_Ch13 is ...@@ -2697,266 +2721,20 @@ package body Sem_Ch13 is
Next (CC); Next (CC);
end loop; end loop;
-- Now that we have processed all the component clauses, check for -- Check missing components if Complete_Representation pragma appeared
-- 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, if Present (CR_Pragma) then
-- as recorded by Overlap_Check_Required being False at this stage. 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 Next_Component_Or_Discriminant (Comp);
-- all. It does this by sorting all entries and then seeing if there are end loop;
-- 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 -- If no Complete_Representation pragma, warn if missing components
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
elsif Warn_On_Unrepped_Components then elsif Warn_On_Unrepped_Components then
declare declare
...@@ -2994,8 +2772,8 @@ package body Sem_Ch13 is ...@@ -2994,8 +2772,8 @@ package body Sem_Ch13 is
and then Comes_From_Source (Comp) and then Comes_From_Source (Comp)
and then Present (Underlying_Type (Etype (Comp))) and then Present (Underlying_Type (Etype (Comp)))
and then (Is_Scalar_Type (Underlying_Type (Etype (Comp))) and then (Is_Scalar_Type (Underlying_Type (Etype (Comp)))
or else Size_Known_At_Compile_Time or else Size_Known_At_Compile_Time
(Underlying_Type (Etype (Comp)))) (Underlying_Type (Etype (Comp))))
and then not Has_Warnings_Off (Rectype) and then not Has_Warnings_Off (Rectype)
then then
Error_Msg_Sloc := Sloc (Comp); Error_Msg_Sloc := Sloc (Comp);
...@@ -3011,50 +2789,6 @@ package body Sem_Ch13 is ...@@ -3011,50 +2789,6 @@ package body Sem_Ch13 is
end if; end if;
end Analyze_Record_Representation_Clause; 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 -- -- Check_Constant_Address_Clause --
----------------------------------- -----------------------------------
...@@ -3401,6 +3135,566 @@ package body Sem_Ch13 is ...@@ -3401,6 +3135,566 @@ package body Sem_Ch13 is
Check_Expr_Constants (Expr); Check_Expr_Constants (Expr);
end Check_Constant_Address_Clause; 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 -- -- Check_Size --
---------------- ----------------
......
gcc/ada/sem_ch13.ads
...@@ -38,9 +38,17 @@ package Sem_Ch13 is ...@@ -38,9 +38,17 @@ package Sem_Ch13 is
procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id); procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id);
-- Called from Freeze where R is a record entity for which reverse bit -- 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 -- 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 -- component positions according to either Ada 95 or Ada 2005 (AI-133).
-- called in Ada 2005 mode. The Ada 95 handling for bit order is entirely
-- contained in Freeze. 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; procedure Initialize;
-- Initialize internal tables for new compilation -- Initialize internal tables for new compilation
......
gcc/ada/sem_eval.adb
...@@ -2534,9 +2534,9 @@ package body Sem_Eval is ...@@ -2534,9 +2534,9 @@ package body Sem_Eval is
-- Eval_Relational_Op -- -- Eval_Relational_Op --
------------------------ ------------------------
-- Relational operations are static functions, so the result is static -- Relational operations are static functions, so the result is static if
-- if both operands are static (RM 4.9(7), 4.9(20)), except that for -- both operands are static (RM 4.9(7), 4.9(20)), except that for strings,
-- strings, the result is never static, even if the operands are. -- the result is never static, even if the operands are.
procedure Eval_Relational_Op (N : Node_Id) is procedure Eval_Relational_Op (N : Node_Id) is
Left : constant Node_Id := Left_Opnd (N); Left : constant Node_Id := Left_Opnd (N);
...@@ -2650,17 +2650,37 @@ package body Sem_Eval is ...@@ -2650,17 +2650,37 @@ package body Sem_Eval is
if Nkind (Expr) = N_Op_Add if Nkind (Expr) = N_Op_Add
and then Compile_Time_Known_Value (Right_Opnd (Expr)) and then Compile_Time_Known_Value (Right_Opnd (Expr))
then then
Exp := Left_Opnd (Expr); Exp := Left_Opnd (Expr);
Cons := Expr_Value (Right_Opnd (Expr)); Cons := Expr_Value (Right_Opnd (Expr));
elsif Nkind (Expr) = N_Op_Subtract elsif Nkind (Expr) = N_Op_Subtract
and then Compile_Time_Known_Value (Right_Opnd (Expr)) and then Compile_Time_Known_Value (Right_Opnd (Expr))
then then
Exp := Left_Opnd (Expr); Exp := Left_Opnd (Expr);
Cons := -Expr_Value (Right_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 else
Exp := Expr; Exp := Expr;
Cons := Uint_0; Cons := Uint_0;
end if; end if;
...@@ -2669,8 +2689,10 @@ package body Sem_Eval is ...@@ -2669,8 +2689,10 @@ package body Sem_Eval is
if Nkind (Exp) = N_Attribute_Reference then if Nkind (Exp) = N_Attribute_Reference then
if Attribute_Name (Exp) = Name_First then if Attribute_Name (Exp) = Name_First then
Kind := 'F'; Kind := 'F';
elsif Attribute_Name (Exp) = Name_Last then elsif Attribute_Name (Exp) = Name_Last then
Kind := 'L'; Kind := 'L';
else else
Ent := Empty; Ent := Empty;
return; return;
......
gcc/ada/sem_intr.adb
...@@ -73,9 +73,7 @@ package body Sem_Intr is ...@@ -73,9 +73,7 @@ package body Sem_Intr is
procedure Check_Exception_Function (E : Entity_Id; N : Node_Id) is procedure Check_Exception_Function (E : Entity_Id; N : Node_Id) is
begin begin
if Ekind (E) /= E_Function if not Ekind_In (E, E_Function, E_Generic_Function) then
and then Ekind (E) /= E_Generic_Function
then
Errint Errint
("intrinsic exception subprogram must be a function", E, N); ("intrinsic exception subprogram must be a function", E, N);
...@@ -374,9 +372,7 @@ package body Sem_Intr is ...@@ -374,9 +372,7 @@ package body Sem_Intr is
Ptyp2 : Node_Id; Ptyp2 : Node_Id;
begin begin
if Ekind (E) /= E_Function if not Ekind_In (E, E_Function, E_Generic_Function) then
and then Ekind (E) /= E_Generic_Function
then
Errint ("intrinsic shift subprogram must be a function", E, N); Errint ("intrinsic shift subprogram must be a function", E, N);
return; return;
end if; end if;
......
gcc/ada/sem_prag.adb
...@@ -1846,7 +1846,8 @@ package body Sem_Prag is ...@@ -1846,7 +1846,8 @@ package body Sem_Prag is
Proc := Entity (Name); Proc := Entity (Name);
if Ekind (Proc) /= E_Procedure if Ekind (Proc) /= E_Procedure
or else Present (First_Formal (Proc)) then or else Present (First_Formal (Proc))
then
Error_Pragma_Arg Error_Pragma_Arg
("argument of pragma% must be parameterless procedure", Arg); ("argument of pragma% must be parameterless procedure", Arg);
end if; end if;
...@@ -2516,10 +2517,7 @@ package body Sem_Prag is ...@@ -2516,10 +2517,7 @@ package body Sem_Prag is
-- Check that we are not applying this to a named constant -- Check that we are not applying this to a named constant
if Ekind (E) = E_Named_Integer if Ekind_In (E, E_Named_Integer, E_Named_Real) then
or else
Ekind (E) = E_Named_Real
then
Error_Msg_Name_1 := Pname; Error_Msg_Name_1 := Pname;
Error_Msg_N Error_Msg_N
("cannot apply pragma% to named constant!", ("cannot apply pragma% to named constant!",
...@@ -2756,9 +2754,7 @@ package body Sem_Prag is ...@@ -2756,9 +2754,7 @@ package body Sem_Prag is
Process_Extended_Import_Export_Internal_Arg (Arg_Internal); Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
Def_Id := Entity (Arg_Internal); Def_Id := Entity (Arg_Internal);
if Ekind (Def_Id) /= E_Constant if not Ekind_In (Def_Id, E_Constant, E_Variable) then
and then Ekind (Def_Id) /= E_Variable
then
Error_Pragma_Arg Error_Pragma_Arg
("pragma% must designate an object", Arg_Internal); ("pragma% must designate an object", Arg_Internal);
end if; end if;
...@@ -3368,10 +3364,8 @@ package body Sem_Prag is ...@@ -3368,10 +3364,8 @@ package body Sem_Prag is
Kill_Size_Check_Code (Def_Id); Kill_Size_Check_Code (Def_Id);
Note_Possible_Modification (Expression (Arg2), Sure => False); Note_Possible_Modification (Expression (Arg2), Sure => False);
if Ekind (Def_Id) = E_Variable if Ekind_In (Def_Id, E_Variable, E_Constant) then
or else
Ekind (Def_Id) = E_Constant
then
-- We do not permit Import to apply to a renaming declaration -- We do not permit Import to apply to a renaming declaration
if Present (Renamed_Object (Def_Id)) then if Present (Renamed_Object (Def_Id)) then
...@@ -9131,9 +9125,7 @@ package body Sem_Prag is ...@@ -9131,9 +9125,7 @@ package body Sem_Prag is
while Present (E) while Present (E)
and then Scope (E) = Current_Scope and then Scope (E) = Current_Scope
loop loop
if Ekind (E) = E_Procedure if Ekind_In (E, E_Procedure, E_Generic_Procedure) then
or else Ekind (E) = E_Generic_Procedure
then
Set_No_Return (E); Set_No_Return (E);
-- Set flag on any alias as well -- Set flag on any alias as well
...@@ -10291,9 +10283,7 @@ package body Sem_Prag is ...@@ -10291,9 +10283,7 @@ package body Sem_Prag is
Def_Id := Entity (Internal); Def_Id := Entity (Internal);
if Ekind (Def_Id) /= E_Constant if not Ekind_In (Def_Id, E_Constant, E_Variable) then
and then Ekind (Def_Id) /= E_Variable
then
Error_Pragma_Arg Error_Pragma_Arg
("pragma% must designate an object", Internal); ("pragma% must designate an object", Internal);
end if; end if;
...@@ -10459,9 +10449,9 @@ package body Sem_Prag is ...@@ -10459,9 +10449,9 @@ package body Sem_Prag is
loop loop
Def_Id := Get_Base_Subprogram (E); Def_Id := Get_Base_Subprogram (E);
if Ekind (Def_Id) /= E_Function if not Ekind_In (Def_Id, E_Function,
and then Ekind (Def_Id) /= E_Generic_Function E_Generic_Function,
and then Ekind (Def_Id) /= E_Operator E_Operator)
then then
Error_Pragma_Arg Error_Pragma_Arg
("pragma% requires a function name", Arg1); ("pragma% requires a function name", Arg1);
......
gcc/ada/sem_res.adb
...@@ -3534,9 +3534,7 @@ package body Sem_Res is ...@@ -3534,9 +3534,7 @@ package body Sem_Res is
-- might not be done in the In Out case since Gigi does not do -- might not be done in the In Out case since Gigi does not do
-- any analysis. More thought required about this ??? -- any analysis. More thought required about this ???
if Ekind (F) = E_In_Parameter if Ekind_In (F, E_In_Parameter, E_In_Out_Parameter) then
or else Ekind (F) = E_In_Out_Parameter
then
if Is_Scalar_Type (Etype (A)) then if Is_Scalar_Type (Etype (A)) then
Apply_Scalar_Range_Check (A, F_Typ); Apply_Scalar_Range_Check (A, F_Typ);
...@@ -3582,9 +3580,7 @@ package body Sem_Res is ...@@ -3582,9 +3580,7 @@ package body Sem_Res is
end if; end if;
end if; end if;
if Ekind (F) = E_Out_Parameter if Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter) then
or else Ekind (F) = E_In_Out_Parameter
then
if Nkind (A) = N_Type_Conversion then if Nkind (A) = N_Type_Conversion then
if Is_Scalar_Type (A_Typ) then if Is_Scalar_Type (A_Typ) then
Apply_Scalar_Range_Check Apply_Scalar_Range_Check
...@@ -6163,9 +6159,7 @@ package body Sem_Res is ...@@ -6163,9 +6159,7 @@ package body Sem_Res is
Resolve_Actuals (N, Nam); Resolve_Actuals (N, Nam);
Generate_Reference (Nam, Entry_Name); Generate_Reference (Nam, Entry_Name);
if Ekind (Nam) = E_Entry if Ekind_In (Nam, E_Entry, E_Entry_Family) then
or else Ekind (Nam) = E_Entry_Family
then
Check_Potentially_Blocking_Operation (N); Check_Potentially_Blocking_Operation (N);
end if; end if;
...@@ -8559,9 +8553,7 @@ package body Sem_Res is ...@@ -8559,9 +8553,7 @@ package body Sem_Res is
-- Handle subtypes -- Handle subtypes
if Ekind (Opnd) = E_Protected_Subtype if Ekind_In (Opnd, E_Protected_Subtype, E_Task_Subtype) then
or else Ekind (Opnd) = E_Task_Subtype
then
Opnd := Etype (Opnd); Opnd := Etype (Opnd);
end if; end if;
...@@ -8954,19 +8946,20 @@ package body Sem_Res is ...@@ -8954,19 +8946,20 @@ package body Sem_Res is
Index_Subtype := Create_Itype (Subtype_Kind (Ekind (Index_Type)), N); 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_Etype (Index_Subtype, Index_Type);
Set_Size_Info (Index_Subtype, Index_Type); Set_Size_Info (Index_Subtype, Index_Type);
Set_RM_Size (Index_Subtype, RM_Size (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; end if;
Slice_Subtype := Create_Itype (E_Array_Subtype, N); Slice_Subtype := Create_Itype (E_Array_Subtype, N);
...@@ -8979,15 +8972,26 @@ package body Sem_Res is ...@@ -8979,15 +8972,26 @@ package body Sem_Res is
Set_Etype (Slice_Subtype, Base_Type (Etype (N))); Set_Etype (Slice_Subtype, Base_Type (Etype (N)));
Set_Is_Constrained (Slice_Subtype, True); 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. -- The Etype of the existing Slice node is reset to this slice subtype.
-- Its bounds are obtained from its first index. -- Its bounds are obtained from its first index.
Set_Etype (N, Slice_Subtype); Set_Etype (N, Slice_Subtype);
-- Always freeze subtype. This ensures that the slice subtype is -- For packed slice subtypes, freeze immediately. Otherwise insert an
-- elaborated in the scope of the expression. -- 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; end Set_Slice_Subtype;
-------------------------------- --------------------------------
...@@ -9732,7 +9736,6 @@ package body Sem_Res is ...@@ -9732,7 +9736,6 @@ package body Sem_Res is
elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type
and then not Is_Local_Anonymous_Access (Opnd_Type) and then not Is_Local_Anonymous_Access (Opnd_Type)
then then
-- When the operand is a selected access discriminant the check -- When the operand is a selected access discriminant the check
-- needs to be made against the level of the object denoted by -- needs to be made against the level of the object denoted by
-- the prefix of the selected name (Object_Access_Level handles -- the prefix of the selected name (Object_Access_Level handles
......
gcc/ada/sem_type.adb
...@@ -362,7 +362,6 @@ package body Sem_Type is ...@@ -362,7 +362,6 @@ package body Sem_Type is
-- performed, given that the operator was visible in the generic. -- performed, given that the operator was visible in the generic.
if Ekind (E) = E_Operator then if Ekind (E) = E_Operator then
if Present (Opnd_Type) then if Present (Opnd_Type) then
Vis_Type := Opnd_Type; Vis_Type := Opnd_Type;
else else
...@@ -803,8 +802,8 @@ package body Sem_Type is ...@@ -803,8 +802,8 @@ package body Sem_Type is
then then
return True; return True;
-- The context may be class wide, and a class-wide type is -- The context may be class wide, and a class-wide type is compatible
-- compatible with any member of the class. -- with any member of the class.
elsif Is_Class_Wide_Type (T1) elsif Is_Class_Wide_Type (T1)
and then Is_Ancestor (Root_Type (T1), T2) and then Is_Ancestor (Root_Type (T1), T2)
...@@ -997,9 +996,7 @@ package body Sem_Type is ...@@ -997,9 +996,7 @@ package body Sem_Type is
-- imposed by context. -- imposed by context.
elsif Ekind (T2) = E_Access_Attribute_Type elsif Ekind (T2) = E_Access_Attribute_Type
and then (Ekind (BT1) = E_General_Access_Type and then Ekind_In (BT1, E_General_Access_Type, E_Access_Type)
or else
Ekind (BT1) = E_Access_Type)
and then Covers (Designated_Type (T1), Designated_Type (T2)) and then Covers (Designated_Type (T1), Designated_Type (T2))
then then
-- If the target type is a RACW type while the source is an access -- If the target type is a RACW type while the source is an access
...@@ -1677,9 +1674,8 @@ package body Sem_Type is ...@@ -1677,9 +1674,8 @@ package body Sem_Type is
elsif Nkind (Parent (N)) = N_Object_Renaming_Declaration elsif Nkind (Parent (N)) = N_Object_Renaming_Declaration
and then Present (Access_Definition (Parent (N))) and then Present (Access_Definition (Parent (N)))
then then
if Ekind (It1.Typ) = E_Anonymous_Access_Type if Ekind_In (It1.Typ, E_Anonymous_Access_Type,
or else E_Anonymous_Access_Subprogram_Type)
Ekind (It1.Typ) = E_Anonymous_Access_Subprogram_Type
then then
if Ekind (It2.Typ) = Ekind (It1.Typ) then if Ekind (It2.Typ) = Ekind (It1.Typ) then
...@@ -1691,9 +1687,8 @@ package body Sem_Type is ...@@ -1691,9 +1687,8 @@ package body Sem_Type is
return It1; return It1;
end if; end if;
elsif Ekind (It2.Typ) = E_Anonymous_Access_Type elsif Ekind_In (It2.Typ, E_Anonymous_Access_Type,
or else E_Anonymous_Access_Subprogram_Type)
Ekind (It2.Typ) = E_Anonymous_Access_Subprogram_Type
then then
return It2; return It2;
...@@ -1880,8 +1875,8 @@ package body Sem_Type is ...@@ -1880,8 +1875,8 @@ package body Sem_Type is
if Ekind (Etype (Opnd)) = E_Anonymous_Access_Type if Ekind (Etype (Opnd)) = E_Anonymous_Access_Type
and then and then
List_Containing (Parent (Designated_Type (Etype (Opnd)))) List_Containing (Parent (Designated_Type (Etype (Opnd))))
= List_Containing (Unit_Declaration_Node (User_Subp)) = List_Containing (Unit_Declaration_Node (User_Subp))
then then
if It2.Nam = Predef_Subp then if It2.Nam = Predef_Subp then
return It1; return It1;
......
gcc/ada/sem_util.adb
...@@ -2817,9 +2817,7 @@ package body Sem_Util is ...@@ -2817,9 +2817,7 @@ package body Sem_Util is
-- Avoid cascaded messages with duplicate components in -- Avoid cascaded messages with duplicate components in
-- derived types. -- derived types.
if Ekind (E) = E_Component if Ekind_In (E, E_Component, E_Discriminant) then
or else Ekind (E) = E_Discriminant
then
return; return;
end if; end if;
end if; end if;
...@@ -2854,9 +2852,7 @@ package body Sem_Util is ...@@ -2854,9 +2852,7 @@ package body Sem_Util is
-- midst of inheriting components in a derived record definition. -- midst of inheriting components in a derived record definition.
-- Preserve their Ekind and Etype. -- Preserve their Ekind and Etype.
if Ekind (Def_Id) = E_Discriminant if Ekind_In (Def_Id, E_Discriminant, E_Component) then
or else Ekind (Def_Id) = E_Component
then
null; null;
-- If a type is already set, leave it alone (happens whey a type -- If a type is already set, leave it alone (happens whey a type
...@@ -2876,8 +2872,7 @@ package body Sem_Util is ...@@ -2876,8 +2872,7 @@ package body Sem_Util is
-- Inherited discriminants and components in derived record types are -- Inherited discriminants and components in derived record types are
-- immediately visible. Itypes are not. -- immediately visible. Itypes are not.
if Ekind (Def_Id) = E_Discriminant if Ekind_In (Def_Id, E_Discriminant, E_Component)
or else Ekind (Def_Id) = E_Component
or else (No (Corresponding_Remote_Type (Def_Id)) or else (No (Corresponding_Remote_Type (Def_Id))
and then not Is_Itype (Def_Id)) and then not Is_Itype (Def_Id))
then then
...@@ -4848,10 +4843,8 @@ package body Sem_Util is ...@@ -4848,10 +4843,8 @@ package body Sem_Util is
-- We are interested only in components and discriminants -- We are interested only in components and discriminants
if Ekind (Ent) = E_Component if Ekind_In (Ent, E_Component, E_Discriminant) then
or else
Ekind (Ent) = E_Discriminant
then
-- Get default expression if any. If there is no declaration -- Get default expression if any. If there is no declaration
-- node, it means we have an internal entity. The parent and -- node, it means we have an internal entity. The parent and
-- tag fields are examples of such entities. For these cases, -- tag fields are examples of such entities. For these cases,
...@@ -6376,10 +6369,7 @@ package body Sem_Util is ...@@ -6376,10 +6369,7 @@ package body Sem_Util is
Ent : constant Entity_Id := Entity (Expr); Ent : constant Entity_Id := Entity (Expr);
Sub : constant Entity_Id := Enclosing_Subprogram (Ent); Sub : constant Entity_Id := Enclosing_Subprogram (Ent);
begin begin
if Ekind (Ent) /= E_Variable if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then
and then
Ekind (Ent) /= E_In_Out_Parameter
then
return False; return False;
else else
return Present (Sub) and then Sub = Current_Subprogram; return Present (Sub) and then Sub = Current_Subprogram;
...@@ -8658,9 +8648,7 @@ package body Sem_Util is ...@@ -8658,9 +8648,7 @@ package body Sem_Util is
-- If a record subtype is simply copied, the entity list will be -- If a record subtype is simply copied, the entity list will be
-- shared. Thus cloned_Subtype must be set to indicate the sharing. -- shared. Thus cloned_Subtype must be set to indicate the sharing.
if Ekind (Old_Itype) = E_Record_Subtype if Ekind_In (Old_Itype, E_Record_Subtype, E_Class_Wide_Subtype) then
or else Ekind (Old_Itype) = E_Class_Wide_Subtype
then
Set_Cloned_Subtype (New_Itype, Old_Itype); Set_Cloned_Subtype (New_Itype, Old_Itype);
end if; end if;
...@@ -10151,12 +10139,7 @@ package body Sem_Util is ...@@ -10151,12 +10139,7 @@ package body Sem_Util is
while R_Scope /= Standard_Standard loop while R_Scope /= Standard_Standard loop
exit when R_Scope = E_Scope; exit when R_Scope = E_Scope;
if Ekind (R_Scope) /= E_Package if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then
and then
Ekind (R_Scope) /= E_Block
and then
Ekind (R_Scope) /= E_Loop
then
return False; return False;
else else
R_Scope := Scope (R_Scope); R_Scope := Scope (R_Scope);
......
gcc/ada/sem_warn.adb
...@@ -1027,9 +1027,8 @@ package body Sem_Warn is ...@@ -1027,9 +1027,8 @@ package body Sem_Warn is
-- we exclude protected types, too complicated to worry about. -- we exclude protected types, too complicated to worry about.
if Ekind (E1) = E_Variable if Ekind (E1) = E_Variable
or else or else
((Ekind (E1) = E_Out_Parameter (Ekind_In (E1, E_Out_Parameter, E_In_Out_Parameter)
or else Ekind (E1) = E_In_Out_Parameter)
and then not Is_Protected_Type (Current_Scope)) and then not Is_Protected_Type (Current_Scope))
then then
-- Case of an unassigned variable -- Case of an unassigned variable
...@@ -1345,7 +1344,7 @@ package body Sem_Warn is ...@@ -1345,7 +1344,7 @@ package body Sem_Warn is
while Present (Comp) loop while Present (Comp) loop
if Ekind (Comp) = E_Component if Ekind (Comp) = E_Component
and then Nkind (Parent (Comp)) = and then Nkind (Parent (Comp)) =
N_Component_Declaration N_Component_Declaration
and then No (Expression (Parent (Comp))) and then No (Expression (Parent (Comp)))
then then
Error_Msg_Node_2 := Comp; Error_Msg_Node_2 := Comp;
...@@ -2883,9 +2882,7 @@ package body Sem_Warn is ...@@ -2883,9 +2882,7 @@ package body Sem_Warn is
-- Reference to obsolescent component -- Reference to obsolescent component
elsif Ekind (E) = E_Component elsif Ekind_In (E, E_Component, E_Discriminant) then
or else Ekind (E) = E_Discriminant
then
Error_Msg_NE Error_Msg_NE
("?reference to obsolescent component& declared#", N, E); ("?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