Skip to content

R
riscv-gcc-1
Commit 8255bc9d by Arnaud Charlet
Options

[multiple changes] 

2010-06-14  Jerome Lambourg  <lambourg@adacore.com>

	* sem_prag.adb (Check_Duplicated_Export_Name): Remove check for
	CLI_Target as this prevents proper detection of exported names
	duplicates when the exported language is different to CIL.
	(Process_Interface_Name): Add check for CIL convention exports,
	replacing the old one from Check_Duplicated_Export_Name.

2010-06-14  Matthew Heaney  <heaney@adacore.com>

	* a-coinve.adb, a-convec.adb (operator "&"): Check both that new length
	and new last satisfy constraints.
	(Delete_Last): prevent overflow for subtraction of index values
	(To_Vector): prevent overflow for addition of index values

From-SVN: r160710
parent 438ff97c
Showing with 427 additions and 220 deletions
gcc/ada/ChangeLog
2010-06-14 Jerome Lambourg <lambourg@adacore.com>
* sem_prag.adb (Check_Duplicated_Export_Name): Remove check for
CLI_Target as this prevents proper detection of exported names
duplicates when the exported language is different to CIL.
(Process_Interface_Name): Add check for CIL convention exports,
replacing the old one from Check_Duplicated_Export_Name.
2010-06-14 Matthew Heaney <heaney@adacore.com>
* a-coinve.adb, a-convec.adb (operator "&"): Check both that new length
and new last satisfy constraints.
(Delete_Last): prevent overflow for subtraction of index values
(To_Vector): prevent overflow for addition of index values
2010-06-14 Ed Schonberg <schonberg@adacore.com> 2010-06-14 Ed Schonberg <schonberg@adacore.com>
* sem_ch4.adb (Complete_Object_Operation): After analyzing the * sem_ch4.adb (Complete_Object_Operation): After analyzing the
......
gcc/ada/a-coinve.adb
...@@ -117,22 +117,63 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -117,22 +117,63 @@ package body Ada.Containers.Indefinite_Vectors is
end if; end if;
declare declare
N : constant Int'Base := Int (LN) + Int (RN); N : constant Int'Base := Int (LN) + Int (RN);
Last_As_Int : Int'Base; J : Int'Base;
begin begin
if Int (No_Index) > Int'Last - N then -- There are two constraints we need to satisfy. The first constraint
-- is that a container cannot have more than Count_Type'Last
-- elements, so we must check the sum of the combined lengths. (It
-- would be rare for vectors to have such a large number of elements,
-- so we would normally expect this first check to succeed.) The
-- second constraint is that the new Last index value cannot exceed
-- Index_Type'Last.
if N > Count_Type'Pos (Count_Type'Last) then
raise Constraint_Error with "new length is out of range"; raise Constraint_Error with "new length is out of range";
end if; end if;
Last_As_Int := Int (No_Index) + N; -- We now check whether the new length would create a Last index
-- value greater than Index_Type'Last. This calculation requires
-- care, because overflow can occur when Index_Type'First is near the
-- end of the range of Int.
if Last_As_Int > Int (Index_Type'Last) then if Index_Type'First <= 0 then
raise Constraint_Error with "new length is out of range";
-- Compute the potential Last index value in the normal way, using
-- Int as the type in which to perform intermediate
-- calculations. Int is a 64-bit type, and Count_Type is a 32-bit
-- type, so no overflow can occur.
J := Int (Index_Type'First - 1) + N;
if J > Int (Index_Type'Last) then
raise Constraint_Error with "new length is out of range";
end if;
else
-- If Index_Type'First is within N of Int'Last, then overflow
-- would occur if we simply computed Last directly. So instead of
-- computing Last, and then determining whether its value is
-- greater than Index_Type'Last (as we do above), we work
-- backwards by computing the potential First index value, and
-- then checking whether that value is less than Index_Type'First.
J := Int (Index_Type'Last) - N + 1;
if J < Int (Index_Type'First) then
raise Constraint_Error with "new length is out of range";
end if;
-- We have determined that Length would not create a Last index
-- value outside of the range of Index_Type, so we can now safely
-- compute its value.
J := Int (Index_Type'First - 1) + N;
end if; end if;
declare declare
Last : constant Index_Type := Index_Type (Last_As_Int); Last : constant Index_Type := Index_Type (J);
LE : Elements_Array renames LE : Elements_Array renames
Left.Elements.EA (Index_Type'First .. Left.Last); Left.Elements.EA (Index_Type'First .. Left.Last);
...@@ -189,10 +230,8 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -189,10 +230,8 @@ package body Ada.Containers.Indefinite_Vectors is
end "&"; end "&";
function "&" (Left : Vector; Right : Element_Type) return Vector is function "&" (Left : Vector; Right : Element_Type) return Vector is
LN : constant Count_Type := Length (Left);
begin begin
if LN = 0 then if Left.Is_Empty then
declare declare
Elements : Elements_Access := new Elements_Type (Index_Type'First); Elements : Elements_Access := new Elements_Type (Index_Type'First);
...@@ -209,70 +248,65 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -209,70 +248,65 @@ package body Ada.Containers.Indefinite_Vectors is
end; end;
end if; end if;
declare -- We must satisfy two constraints: the new length cannot exceed
Last_As_Int : Int'Base; -- Count_Type'Last, and the new Last index cannot exceed
-- Index_Type'Last.
begin
if Int (Index_Type'First) > Int'Last - Int (LN) then
raise Constraint_Error with "new length is out of range";
end if;
Last_As_Int := Int (Index_Type'First) + Int (LN);
if Last_As_Int > Int (Index_Type'Last) then
raise Constraint_Error with "new length is out of range";
end if;
declare if Left.Length = Count_Type'Last then
Last : constant Index_Type := Index_Type (Last_As_Int); raise Constraint_Error with "new length is out of range";
end if;
LE : Elements_Array renames
Left.Elements.EA (Index_Type'First .. Left.Last);
Elements : Elements_Access := if Left.Last >= Index_Type'Last then
new Elements_Type (Last); raise Constraint_Error with "new length is out of range";
end if;
begin declare
for I in LE'Range loop Last : constant Index_Type := Left.Last + 1;
begin
if LE (I) /= null then
Elements.EA (I) := new Element_Type'(LE (I).all);
end if;
exception LE : Elements_Array renames
when others => Left.Elements.EA (Index_Type'First .. Left.Last);
for J in Index_Type'First .. I - 1 loop
Free (Elements.EA (J));
end loop;
Free (Elements); Elements : Elements_Access :=
raise; new Elements_Type (Last);
end;
end loop;
begin
for I in LE'Range loop
begin begin
Elements.EA (Last) := new Element_Type'(Right); if LE (I) /= null then
Elements.EA (I) := new Element_Type'(LE (I).all);
end if;
exception exception
when others => when others =>
for J in Index_Type'First .. Last - 1 loop for J in Index_Type'First .. I - 1 loop
Free (Elements.EA (J)); Free (Elements.EA (J));
end loop; end loop;
Free (Elements); Free (Elements);
raise; raise;
end; end;
end loop;
return (Controlled with Elements, Last, 0, 0); begin
Elements.EA (Last) := new Element_Type'(Right);
exception
when others =>
for J in Index_Type'First .. Last - 1 loop
Free (Elements.EA (J));
end loop;
Free (Elements);
raise;
end; end;
return (Controlled with Elements, Last, 0, 0);
end; end;
end "&"; end "&";
function "&" (Left : Element_Type; Right : Vector) return Vector is function "&" (Left : Element_Type; Right : Vector) return Vector is
RN : constant Count_Type := Length (Right);
begin begin
if RN = 0 then if Right.Is_Empty then
declare declare
Elements : Elements_Access := new Elements_Type (Index_Type'First); Elements : Elements_Access := new Elements_Type (Index_Type'First);
...@@ -289,61 +323,58 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -289,61 +323,58 @@ package body Ada.Containers.Indefinite_Vectors is
end; end;
end if; end if;
declare -- We must satisfy two constraints: the new length cannot exceed
Last_As_Int : Int'Base; -- Count_Type'Last, and the new Last index cannot exceed
-- Index_Type'Last.
begin if Right.Length = Count_Type'Last then
if Int (Index_Type'First) > Int'Last - Int (RN) then raise Constraint_Error with "new length is out of range";
raise Constraint_Error with "new length is out of range"; end if;
end if;
Last_As_Int := Int (Index_Type'First) + Int (RN);
if Last_As_Int > Int (Index_Type'Last) then if Right.Last >= Index_Type'Last then
raise Constraint_Error with "new length is out of range"; raise Constraint_Error with "new length is out of range";
end if; end if;
declare declare
Last : constant Index_Type := Index_Type (Last_As_Int); Last : constant Index_Type := Right.Last + 1;
RE : Elements_Array renames RE : Elements_Array renames
Right.Elements.EA (Index_Type'First .. Right.Last); Right.Elements.EA (Index_Type'First .. Right.Last);
Elements : Elements_Access := Elements : Elements_Access :=
new Elements_Type (Last); new Elements_Type (Last);
I : Index_Type'Base := Index_Type'First; I : Index_Type'Base := Index_Type'First;
begin
begin begin
Elements.EA (I) := new Element_Type'(Left);
exception
when others =>
Free (Elements);
raise;
end;
for RI in RE'Range loop
I := I + 1;
begin begin
Elements.EA (I) := new Element_Type'(Left); if RE (RI) /= null then
Elements.EA (I) := new Element_Type'(RE (RI).all);
end if;
exception exception
when others => when others =>
for J in Index_Type'First .. I - 1 loop
Free (Elements.EA (J));
end loop;
Free (Elements); Free (Elements);
raise; raise;
end; end;
end loop;
for RI in RE'Range loop return (Controlled with Elements, Last, 0, 0);
I := I + 1;
begin
if RE (RI) /= null then
Elements.EA (I) := new Element_Type'(RE (RI).all);
end if;
exception
when others =>
for J in Index_Type'First .. I - 1 loop
Free (Elements.EA (J));
end loop;
Free (Elements);
raise;
end;
end loop;
return (Controlled with Elements, Last, 0, 0);
end;
end; end;
end "&"; end "&";
...@@ -2498,73 +2529,145 @@ package body Ada.Containers.Indefinite_Vectors is ...@@ -2498,73 +2529,145 @@ package body Ada.Containers.Indefinite_Vectors is
--------------- ---------------
function To_Vector (Length : Count_Type) return Vector is function To_Vector (Length : Count_Type) return Vector is
Index : Int'Base;
Last : Index_Type;
Elements : Elements_Access;
begin begin
if Length = 0 then if Length = 0 then
return Empty_Vector; return Empty_Vector;
end if; end if;
declare -- We create a vector object with a capacity that matches the specified
First : constant Int := Int (Index_Type'First); -- Length. We do not allow the vector capacity (the length of the
Last_As_Int : constant Int'Base := First + Int (Length) - 1; -- internal array) to exceed the number of values in Index_Type'Range
Last : Index_Type; -- (otherwise, there would be no way to refer to those components via an
Elements : Elements_Access; -- index), so we must check whether the specified Length would create a
-- Last index value greater than Index_Type'Last. This calculation
-- requires care, because overflow can occur when Index_Type'First is
-- near the end of the range of Int.
begin if Index_Type'First <= 0 then
if Last_As_Int > Index_Type'Pos (Index_Type'Last) then -- Compute the potential Last index value in the normal way, using
-- Int as the type in which to perform intermediate calculations. Int
-- is a 64-bit type, and Count_Type is a 32-bit type, so no overflow
-- can occur.
Index := Int (Index_Type'First - 1) + Int (Length);
if Index > Int (Index_Type'Last) then
raise Constraint_Error with "Length is out of range"; raise Constraint_Error with "Length is out of range";
end if; end if;
Last := Index_Type (Last_As_Int); else
Elements := new Elements_Type (Last); -- If Index_Type'First is within Length of Int'Last, then overflow
-- would occur if we simply computed Last directly. So instead of
-- computing Last, and then determining whether its value is greater
-- than Index_Type'Last, we work backwards by computing the potential
-- First index value, and then checking whether that value is less
-- than Index_Type'First.
Index := Int (Index_Type'Last) - Int (Length) + 1;
if Index < Int (Index_Type'First) then
raise Constraint_Error with "Length is out of range";
end if;
return (Controlled with Elements, Last, 0, 0); -- We have determined that Length would not create a Last index value
end; -- outside of the range of Index_Type, so we can now safely compute
-- its value.
Index := Int (Index_Type'First - 1) + Int (Length);
end if;
Last := Index_Type (Index);
Elements := new Elements_Type (Last);
return Vector'(Controlled with Elements, Last, 0, 0);
end To_Vector; end To_Vector;
function To_Vector function To_Vector
(New_Item : Element_Type; (New_Item : Element_Type;
Length : Count_Type) return Vector Length : Count_Type) return Vector
is is
Index : Int'Base;
Last : Index_Type;
Elements : Elements_Access;
begin begin
if Length = 0 then if Length = 0 then
return Empty_Vector; return Empty_Vector;
end if; end if;
declare -- We create a vector object with a capacity that matches the specified
First : constant Int := Int (Index_Type'First); -- Length. We do not allow the vector capacity (the length of the
Last_As_Int : constant Int'Base := First + Int (Length) - 1; -- internal array) to exceed the number of values in Index_Type'Range
Last : Index_Type'Base; -- (otherwise, there would be no way to refer to those components via an
Elements : Elements_Access; -- index), so we must check whether the specified Length would create a
-- Last index value greater than Index_Type'Last. This calculation
-- requires care, because overflow can occur when Index_Type'First is
-- near the end of the range of Int.
begin if Index_Type'First <= 0 then
if Last_As_Int > Index_Type'Pos (Index_Type'Last) then -- Compute the potential Last index value in the normal way, using
-- Int as the type in which to perform intermediate calculations. Int
-- is a 64-bit type, and Count_Type is a 32-bit type, so no overflow
-- can occur.
Index := Int (Index_Type'First - 1) + Int (Length);
if Index > Int (Index_Type'Last) then
raise Constraint_Error with "Length is out of range"; raise Constraint_Error with "Length is out of range";
end if; end if;
Last := Index_Type (Last_As_Int); else
Elements := new Elements_Type (Last); -- If Index_Type'First is within Length of Int'Last, then overflow
-- would occur if we simply computed Last directly. So instead of
-- computing Last, and then determining whether its value is greater
-- than Index_Type'Last, we work backwards by computing the potential
-- First index value, and then checking whether that value is less
-- than Index_Type'First.
Index := Int (Index_Type'Last) - Int (Length) + 1;
if Index < Int (Index_Type'First) then
raise Constraint_Error with "Length is out of range";
end if;
Last := Index_Type'First; -- We have determined that Length would not create a Last index value
-- outside of the range of Index_Type, so we can now safely compute
-- its value.
Index := Int (Index_Type'First - 1) + Int (Length);
end if;
begin Last := Index_Type (Index);
loop Elements := new Elements_Type (Last);
Elements.EA (Last) := new Element_Type'(New_Item);
exit when Last = Elements.Last;
Last := Last + 1;
end loop;
exception -- We use Last as the index of the loop used to populate the internal
when others => -- array with items. In general, we prefer to initialize the loop index
for J in Index_Type'First .. Last - 1 loop -- immediately prior to entering the loop. However, Last is also used in
Free (Elements.EA (J)); -- the exception handler (it reclaims elements that have been allocated,
end loop; -- before propagating the exception), and the initialization of Last
-- after entering the block containing the handler confuses some static
-- analysis tools, with respect to whether Last has been properly
-- initialized when the handler executes. So here we initialize our loop
-- variable earlier than we prefer, before entering the block, so there
-- is no ambiguity.
Last := Index_Type'First;
Free (Elements); begin
raise; loop
end; Elements.EA (Last) := new Element_Type'(New_Item);
exit when Last = Elements.Last;
Last := Last + 1;
end loop;
return (Controlled with Elements, Last, 0, 0); exception
when others =>
for J in Index_Type'First .. Last - 1 loop
Free (Elements.EA (J));
end loop;
Free (Elements);
raise;
end; end;
return (Controlled with Elements, Last, 0, 0);
end To_Vector; end To_Vector;
-------------------- --------------------
......
gcc/ada/a-convec.adb
...@@ -81,22 +81,59 @@ package body Ada.Containers.Vectors is ...@@ -81,22 +81,59 @@ package body Ada.Containers.Vectors is
end if; end if;
declare declare
N : constant Int'Base := Int (LN) + Int (RN); N : constant Int'Base := Int (LN) + Int (RN);
Last_As_Int : Int'Base; J : Int'Base;
begin begin
if Int (No_Index) > Int'Last - N then -- There are two constraints we need to satisfy. The first constraint
-- is that a container cannot have more than Count_Type'Last
-- elements, so we must check the sum of the combined lengths. (It
-- would be rare for vectors to have such a large number of elements,
-- so we would normally expect this first check to succeed.) The
-- second constraint is that the new Last index value cannot exceed
-- Index_Type'Last.
if N > Count_Type'Pos (Count_Type'Last) then
raise Constraint_Error with "new length is out of range"; raise Constraint_Error with "new length is out of range";
end if; end if;
Last_As_Int := Int (No_Index) + N; -- We now check whether the new length would create a Last index
-- value greater than Index_Type'Last. This calculation requires
-- care, because overflow can occur when Index_Type'First is near the
-- end of the range of Int.
if Last_As_Int > Int (Index_Type'Last) then if Index_Type'First <= 0 then
raise Constraint_Error with "new length is out of range"; -- Compute the potential Last index value in the normal way, using
-- Int as the type in which to perform intermediate
-- calculations. Int is a 64-bit type, and Count_Type is a 32-bit
-- type, so no overflow can occur.
J := Int (Index_Type'First - 1) + N;
if J > Int (Index_Type'Last) then
raise Constraint_Error with "new length is out of range";
end if;
else
-- If Index_Type'First is within N of Int'Last, then overflow
-- would occur if we simply computed Last directly. So instead of
-- computing Last, and then determining whether its value is
-- greater than Index_Type'Last (as we do above), we work
-- backwards by computing the potential First index value, and
-- then checking whether that value is less than Index_Type'First.
J := Int (Index_Type'Last) - N + 1;
if J < Int (Index_Type'First) then
raise Constraint_Error with "new length is out of range";
end if;
-- We have determined that Length would not create a Last index
-- value outside of the range of Index_Type, so we can now safely
-- compute its value.
J := Int (Index_Type'First - 1) + N;
end if; end if;
declare declare
Last : constant Index_Type := Index_Type (Last_As_Int); Last : constant Index_Type := Index_Type (J);
LE : Elements_Array renames LE : Elements_Array renames
Left.Elements.EA (Index_Type'First .. Left.Last); Left.Elements.EA (Index_Type'First .. Left.Last);
...@@ -114,10 +151,8 @@ package body Ada.Containers.Vectors is ...@@ -114,10 +151,8 @@ package body Ada.Containers.Vectors is
end "&"; end "&";
function "&" (Left : Vector; Right : Element_Type) return Vector is function "&" (Left : Vector; Right : Element_Type) return Vector is
LN : constant Count_Type := Length (Left);
begin begin
if LN = 0 then if Left.Is_Empty then
declare declare
Elements : constant Elements_Access := Elements : constant Elements_Access :=
new Elements_Type' new Elements_Type'
...@@ -129,42 +164,37 @@ package body Ada.Containers.Vectors is ...@@ -129,42 +164,37 @@ package body Ada.Containers.Vectors is
end; end;
end if; end if;
declare -- We must satisfy two constraints: the new length cannot exceed
Last_As_Int : Int'Base; -- Count_Type'Last, and the new Last index cannot exceed
-- Index_Type'Last.
begin
if Int (Index_Type'First) > Int'Last - Int (LN) then
raise Constraint_Error with "new length is out of range";
end if;
Last_As_Int := Int (Index_Type'First) + Int (LN); if Left.Length = Count_Type'Last then
raise Constraint_Error with "new length is out of range";
end if;
if Last_As_Int > Int (Index_Type'Last) then if Left.Last >= Index_Type'Last then
raise Constraint_Error with "new length is out of range"; raise Constraint_Error with "new length is out of range";
end if; end if;
declare declare
Last : constant Index_Type := Index_Type (Last_As_Int); Last : constant Index_Type := Left.Last + 1;
LE : Elements_Array renames LE : Elements_Array renames
Left.Elements.EA (Index_Type'First .. Left.Last); Left.Elements.EA (Index_Type'First .. Left.Last);
Elements : constant Elements_Access := Elements : constant Elements_Access :=
new Elements_Type' new Elements_Type'
(Last => Last, (Last => Last,
EA => LE & Right); EA => LE & Right);
begin begin
return (Controlled with Elements, Last, 0, 0); return (Controlled with Elements, Last, 0, 0);
end;
end; end;
end "&"; end "&";
function "&" (Left : Element_Type; Right : Vector) return Vector is function "&" (Left : Element_Type; Right : Vector) return Vector is
RN : constant Count_Type := Length (Right);
begin begin
if RN = 0 then if Right.Is_Empty then
declare declare
Elements : constant Elements_Access := Elements : constant Elements_Access :=
new Elements_Type' new Elements_Type'
...@@ -176,34 +206,31 @@ package body Ada.Containers.Vectors is ...@@ -176,34 +206,31 @@ package body Ada.Containers.Vectors is
end; end;
end if; end if;
declare -- We must satisfy two constraints: the new length cannot exceed
Last_As_Int : Int'Base; -- Count_Type'Last, and the new Last index cannot exceed
-- Index_Type'Last.
begin if Right.Length = Count_Type'Last then
if Int (Index_Type'First) > Int'Last - Int (RN) then raise Constraint_Error with "new length is out of range";
raise Constraint_Error with "new length is out of range"; end if;
end if;
Last_As_Int := Int (Index_Type'First) + Int (RN);
if Last_As_Int > Int (Index_Type'Last) then if Right.Last >= Index_Type'Last then
raise Constraint_Error with "new length is out of range"; raise Constraint_Error with "new length is out of range";
end if; end if;
declare declare
Last : constant Index_Type := Index_Type (Last_As_Int); Last : constant Index_Type := Right.Last + 1;
RE : Elements_Array renames RE : Elements_Array renames
Right.Elements.EA (Index_Type'First .. Right.Last); Right.Elements.EA (Index_Type'First .. Right.Last);
Elements : constant Elements_Access := Elements : constant Elements_Access :=
new Elements_Type' new Elements_Type'
(Last => Last, (Last => Last,
EA => Left & RE); EA => Left & RE);
begin begin
return (Controlled with Elements, Last, 0, 0); return (Controlled with Elements, Last, 0, 0);
end;
end; end;
end "&"; end "&";
...@@ -488,12 +515,13 @@ package body Ada.Containers.Vectors is ...@@ -488,12 +515,13 @@ package body Ada.Containers.Vectors is
"attempt to tamper with elements (vector is busy)"; "attempt to tamper with elements (vector is busy)";
end if; end if;
Index := Int'Base (Container.Last) - Int'Base (Count); if Count >= Container.Length then
Container.Last := No_Index;
Container.Last := else
(if Index < Index_Type'Pos (Index_Type'First) Index := Int (Container.Last) - Int (Count);
then No_Index Container.Last := Index_Type (Index);
else Index_Type (Index)); end if;
end Delete_Last; end Delete_Last;
------------- -------------
...@@ -2135,54 +2163,116 @@ package body Ada.Containers.Vectors is ...@@ -2135,54 +2163,116 @@ package body Ada.Containers.Vectors is
--------------- ---------------
function To_Vector (Length : Count_Type) return Vector is function To_Vector (Length : Count_Type) return Vector is
Index : Int'Base;
Last : Index_Type;
Elements : Elements_Access;
begin begin
if Length = 0 then if Length = 0 then
return Empty_Vector; return Empty_Vector;
end if; end if;
declare -- We create a vector object with a capacity that matches the specified
First : constant Int := Int (Index_Type'First); -- Length, but we do not allow the vector capacity (the length of the
Last_As_Int : constant Int'Base := First + Int (Length) - 1; -- internal array) to exceed the number of values in Index_Type'Range
Last : Index_Type; -- (otherwise, there would be no way to refer to those components via an
Elements : Elements_Access; -- index). We must therefore check whether the specified Length would
-- create a Last index value greater than Index_Type'Last. This
-- calculation requires care, because overflow can occur when
-- Index_Type'First is near the end of the range of Int.
begin if Index_Type'First <= 0 then
if Last_As_Int > Index_Type'Pos (Index_Type'Last) then -- Compute the potential Last index value in the normal way, using
-- Int as the type in which to perform intermediate calculations. Int
-- is a 64-bit type, and Count_Type is a 32-bit type, so no overflow
-- can occur.
Index := Int (Index_Type'First - 1) + Int (Length);
if Index > Int (Index_Type'Last) then
raise Constraint_Error with "Length is out of range";
end if;
else
-- If Index_Type'First is within Length of Int'Last, then overflow
-- would occur if we simply computed Last directly. So instead of
-- computing Last, and then determining whether its value is greater
-- than Index_Type'Last, we work backwards by computing the potential
-- First index value, and then checking whether that value is less
-- than Index_Type'First.
Index := Int (Index_Type'Last) - Int (Length) + 1;
if Index < Int (Index_Type'First) then
raise Constraint_Error with "Length is out of range"; raise Constraint_Error with "Length is out of range";
end if; end if;
Last := Index_Type (Last_As_Int); -- We have determined that Length would not create a Last index value
Elements := new Elements_Type (Last); -- outside of the range of Index_Type, so we can now safely compute
-- its value.
Index := Int (Index_Type'First - 1) + Int (Length);
end if;
Last := Index_Type (Index);
Elements := new Elements_Type (Last);
return Vector'(Controlled with Elements, Last, 0, 0); return Vector'(Controlled with Elements, Last, 0, 0);
end;
end To_Vector; end To_Vector;
function To_Vector function To_Vector
(New_Item : Element_Type; (New_Item : Element_Type;
Length : Count_Type) return Vector Length : Count_Type) return Vector
is is
Index : Int'Base;
Last : Index_Type;
Elements : Elements_Access;
begin begin
if Length = 0 then if Length = 0 then
return Empty_Vector; return Empty_Vector;
end if; end if;
declare -- We create a vector object with a capacity that matches the specified
First : constant Int := Int (Index_Type'First); -- Length, but we do not allow the vector capacity (the length of the
Last_As_Int : constant Int'Base := First + Int (Length) - 1; -- internal array) to exceed the number of values in Index_Type'Range
Last : Index_Type; -- (otherwise, there would be no way to refer to those components via an
Elements : Elements_Access; -- index). We must therefore check whether the specified Length would
-- create a Last index value greater than Index_Type'Last. This
-- calculation requires care, because overflow can occur when
-- Index_Type'First is near the end of the range of Int.
begin if Index_Type'First <= 0 then
if Last_As_Int > Index_Type'Pos (Index_Type'Last) then -- Compute the potential Last index value in the normal way, using
-- Int as the type in which to perform intermediate calculations. Int
-- is a 64-bit type, and Count_Type is a 32-bit type, so no overflow
-- can occur.
Index := Int (Index_Type'First - 1) + Int (Length);
if Index > Int (Index_Type'Last) then
raise Constraint_Error with "Length is out of range"; raise Constraint_Error with "Length is out of range";
end if; end if;
Last := Index_Type (Last_As_Int); else
Elements := new Elements_Type'(Last, EA => (others => New_Item)); -- If Index_Type'First is within Length of Int'Last, then overflow
-- would occur if we simply computed Last directly. So instead of
-- computing Last, and then determining whether its value is greater
-- than Index_Type'Last, we work backwards by computing the potential
-- First index value, and then checking whether that value is less
-- than Index_Type'First.
Index := Int (Index_Type'Last) - Int (Length) + 1;
if Index < Int (Index_Type'First) then
raise Constraint_Error with "Length is out of range";
end if;
return Vector'(Controlled with Elements, Last, 0, 0); -- We have determined that Length would not create a Last index value
end; -- outside of the range of Index_Type, so we can now safely compute
-- its value.
Index := Int (Index_Type'First - 1) + Int (Length);
end if;
Last := Index_Type (Index);
Elements := new Elements_Type'(Last, EA => (others => New_Item));
return Vector'(Controlled with Elements, Last, 0, 0);
end To_Vector; end To_Vector;
-------------------- --------------------
......
gcc/ada/sem_prag.adb
...@@ -1154,14 +1154,6 @@ package body Sem_Prag is ...@@ -1154,14 +1154,6 @@ package body Sem_Prag is
String_Val : constant String_Id := Strval (Nam); String_Val : constant String_Id := Strval (Nam);
begin begin
-- We allow duplicated export names in CIL, as they are always
-- enclosed in a namespace that differentiates them, and overloaded
-- entities are supported by the VM.
if VM_Target = CLI_Target then
return;
end if;
-- We are only interested in the export case, and in the case of -- We are only interested in the export case, and in the case of
-- generics, it is the instance, not the template, that is the -- generics, it is the instance, not the template, that is the
-- problem (the template will generate a warning in any case). -- problem (the template will generate a warning in any case).
...@@ -4140,7 +4132,14 @@ package body Sem_Prag is ...@@ -4140,7 +4132,14 @@ package body Sem_Prag is
Set_Encoded_Interface_Name Set_Encoded_Interface_Name
(Get_Base_Subprogram (Subprogram_Def), Link_Nam); (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
Check_Duplicated_Export_Name (Link_Nam);
-- We allow duplicated export names in CIL, as they are always
-- enclosed in a namespace that differentiates them, and overloaded
-- entities are supported by the VM.
if Convention (Subprogram_Def) /= Convention_CIL then
Check_Duplicated_Export_Name (Link_Nam);
end if;
end Process_Interface_Name; end Process_Interface_Name;
----------------------------------------- -----------------------------------------
......
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