Skip to content

R
riscv-gcc-1
Commit 6cbfce7e by Arnaud Charlet
Options

[multiple changes] 

2017-04-27  Claire Dross  <dross@adacore.com>

	* a-cfdlli.adb, a-cfdlli.ads (Formal_Model): Adapt to
	modifications in functional containers.
	* a-cofuba.ads, a-cofuma.ads, a-cofuse.ads, a-cofuve.ads Reformat
	to improve readablity. Subprograms are separated between basic
	operations, constructors and properties. Universally quantified
	formulas in contracts are factorized in independant functions
	with a name and a comment.  Names of parameters are improved.

2017-04-27  Gary Dismukes  <dismukes@adacore.com>

	* exp_spark.adb, sem_elab.adb: Minor reformatting and typo fix.

2017-04-27  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_res.adb (Resolve_Type_Conversion): Do not
	install a predicate check here since this is already done during
	the expansion phase. Verify whether the operand satisfies the
	static predicate (if any) of the target type.
	* sem_ch3.adb (Analyze_Object_Declaration): Do
	not install a predicate check if the object is initialized by
	means of a type conversion because the conversion is subjected
	to the same check.

2017-04-27  Tristan Gingold  <gingold@adacore.com>

	* raise.c (__gnat_builtin_longjmp): Remove.
	(__gnat_bracktrace):
	Add a dummy definition for the compiler (__gnat_eh_personality,
	__gnat_rcheck_04, __gnat_rcheck_10) (__gnat_rcheck_19,
	__gnat_rcheck_20, __gnat_rcheck_21) (__gnat_rcheck_30,
	__gnat_rcheck_31, __gnat_rcheck_32): Likewise.
	* a-exexpr.adb: Renamed from a-exexpr-gcc.adb
	* a-except.ads, a-except.adb: Renamed from a-except-2005.ads
	and a-except-2005.adb.
	* raise-gcc.c: Allow build in compiler, compiled as a C++
	file.
	(__gnat_Unwind_ForcedUnwind): Adjust prototype.
	(db): Constify msg_format.
	(get_call_site_action_for): Don't use void arithmetic.
	* system.ads (Frontend_Exceptions): Set to False.
	(ZCX_By_Default): Set to True.
	(GCC_ZC_Support): Set to True.
	* gcc-interface/Makefile.in: No more variants for a-exexpr.adb and
	a-except.ad[sb].
	* gcc-interface/Make-lang.in: Add support for backend zcx exceptions
	in gnat1 and gnatbind.
	* gnat1, gnatbind: link with raise-gcc.o, a-exctra.o, s-addima.o,
	s-excmac.o, s-imgint.o, s-traceb.o, s-trasym.o, s-wchstw.o
	* s-excmac.ads, s-excmac.adb: Copy of variants.
	* a-except.o: Adjust preequisites.
	Add handling of s-excmac-arm.adb and s-excmac-gcc.adb.

From-SVN: r247301
parent de3b531c
Showing with 719 additions and 418 deletions
gcc/ada/ChangeLog
2017-04-27 Claire Dross <dross@adacore.com>
* a-cfdlli.adb, a-cfdlli.ads (Formal_Model): Adapt to
modifications in functional containers.
* a-cofuba.ads, a-cofuma.ads, a-cofuse.ads, a-cofuve.ads Reformat
to improve readablity. Subprograms are separated between basic
operations, constructors and properties. Universally quantified
formulas in contracts are factorized in independant functions
with a name and a comment. Names of parameters are improved.
2017-04-27 Gary Dismukes <dismukes@adacore.com>
* exp_spark.adb, sem_elab.adb: Minor reformatting and typo fix.
2017-04-27 Hristian Kirtchev <kirtchev@adacore.com>
* sem_res.adb (Resolve_Type_Conversion): Do not
install a predicate check here since this is already done during
the expansion phase. Verify whether the operand satisfies the
static predicate (if any) of the target type.
* sem_ch3.adb (Analyze_Object_Declaration): Do
not install a predicate check if the object is initialized by
means of a type conversion because the conversion is subjected
to the same check.
2017-04-27 Tristan Gingold <gingold@adacore.com>
* raise.c (__gnat_builtin_longjmp): Remove.
(__gnat_bracktrace):
Add a dummy definition for the compiler (__gnat_eh_personality,
__gnat_rcheck_04, __gnat_rcheck_10) (__gnat_rcheck_19,
__gnat_rcheck_20, __gnat_rcheck_21) (__gnat_rcheck_30,
__gnat_rcheck_31, __gnat_rcheck_32): Likewise.
* a-exexpr.adb: Renamed from a-exexpr-gcc.adb
* a-except.ads, a-except.adb: Renamed from a-except-2005.ads
and a-except-2005.adb.
* raise-gcc.c: Allow build in compiler, compiled as a C++
file.
(__gnat_Unwind_ForcedUnwind): Adjust prototype.
(db): Constify msg_format.
(get_call_site_action_for): Don't use void arithmetic.
* system.ads (Frontend_Exceptions): Set to False.
(ZCX_By_Default): Set to True.
(GCC_ZC_Support): Set to True.
* gcc-interface/Makefile.in: No more variants for a-exexpr.adb and
a-except.ad[sb].
* gcc-interface/Make-lang.in: Add support for backend zcx exceptions
in gnat1 and gnatbind.
* gnat1, gnatbind: link with raise-gcc.o, a-exctra.o, s-addima.o,
s-excmac.o, s-imgint.o, s-traceb.o, s-trasym.o, s-wchstw.o
* s-excmac.ads, s-excmac.adb: Copy of variants.
* a-except.o: Adjust preequisites.
Add handling of s-excmac-arm.adb and s-excmac-gcc.adb.
2017-04-27 Claire Dross <dross@adacore.com>
* a-cfdlli.adb, a-cfdlli.ads (Formal_Model): Adapt to
modifications in functional containers.
* a-cofuba.ads, a-cofuma.ads, a-cofuse.ads, a-cofuve.ads Reformat
to improve readablity. Subprograms are separated between basic
operations, constructors and properties. Universally quantified
formulas in contracts are factorized in independant functions
with a name and a comment. Names of parameters are improved.
2017-04-27 Gary Dismukes <dismukes@adacore.com>
* exp_spark.adb, sem_elab.adb: Minor reformatting and typo fix.
2017-04-27 Hristian Kirtchev <kirtchev@adacore.com>
* sem_res.adb (Resolve_Type_Conversion): Do not
install a predicate check here since this is already done during
the expansion phase. Verify whether the operand satisfies the
static predicate (if any) of the target type.
* sem_ch3.adb (Analyze_Object_Declaration): Do
not install a predicate check if the object is initialized by
means of a type conversion because the conversion is subjected
to the same check.
2017-04-27 Tristan Gingold <gingold@adacore.com>
* a-except.ads, a-except.adb, a-exexpr.adb: Removed (will be
replaced by their variants).
2017-04-27 Hristian Kirtchev <kirtchev@adacore.com> 2017-04-27 Hristian Kirtchev <kirtchev@adacore.com>
* exp_prag.adb, a-cofuse.adb, a-cofuse.ads, einfo.adb, sem_prag.adb, * exp_prag.adb, a-cofuse.adb, a-cofuse.ads, einfo.adb, sem_prag.adb,
......
gcc/ada/a-cofuma.adb
...@@ -38,21 +38,21 @@ package body Ada.Containers.Functional_Maps with SPARK_Mode => Off is ...@@ -38,21 +38,21 @@ package body Ada.Containers.Functional_Maps with SPARK_Mode => Off is
-- "=" -- -- "=" --
--------- ---------
function "=" (M1 : Map; M2 : Map) return Boolean is function "=" (Left : Map; Right : Map) return Boolean is
(M1.Keys <= M2.Keys and M2 <= M1); (Left.Keys <= Right.Keys and Right <= Left);
---------- ----------
-- "<=" -- -- "<=" --
---------- ----------
function "<=" (M1 : Map; M2 : Map) return Boolean is function "<=" (Left : Map; Right : Map) return Boolean is
I2 : Count_Type; I2 : Count_Type;
begin begin
for I1 in 1 .. Length (M1.Keys) loop for I1 in 1 .. Length (Left.Keys) loop
I2 := Find (M2.Keys, Get (M1.Keys, I1)); I2 := Find (Right.Keys, Get (Left.Keys, I1));
if I2 = 0 if I2 = 0
or else Get (M2.Elements, I2) /= Get (M1.Elements, I1) or else Get (Right.Elements, I2) /= Get (Left.Elements, I1)
then then
return False; return False;
end if; end if;
...@@ -64,103 +64,185 @@ package body Ada.Containers.Functional_Maps with SPARK_Mode => Off is ...@@ -64,103 +64,185 @@ package body Ada.Containers.Functional_Maps with SPARK_Mode => Off is
-- Add -- -- Add --
--------- ---------
function Add (M : Map; K : Key_Type; E : Element_Type) return Map is function Add
(Container : Map;
New_Key : Key_Type;
New_Item : Element_Type) return Map
is
begin begin
return return
(Keys => Add (M.Keys, Length (M.Keys) + 1, K), (Keys =>
Elements => Add (M.Elements, Length (M.Elements) + 1, E)); Add (Container.Keys, Length (Container.Keys) + 1, New_Key),
Elements =>
Add
(Container.Elements, Length (Container.Elements) + 1, New_Item));
end Add; end Add;
---------------------------
-- Elements_Equal_Except --
---------------------------
function Elements_Equal_Except
(Left : Map;
Right : Map;
New_Key : Key_Type) return Boolean
is
begin
for I in 1 .. Length (Left.Keys) loop
declare
K : constant Key_Type := Get (Left.Keys, I);
begin
if not Equivalent_Keys (K, New_Key)
and then Get (Right.Elements, Find (Right.Keys, K))
/= Get (Left.Elements, I)
then
return False;
end if;
end;
end loop;
return True;
end Elements_Equal_Except;
function Elements_Equal_Except
(Left : Map;
Right : Map;
X, Y : Key_Type) return Boolean
is
begin
for I in 1 .. Length (Left.Keys) loop
declare
K : constant Key_Type := Get (Left.Keys, I);
begin
if not Equivalent_Keys (K, X)
and then not Equivalent_Keys (K, Y)
and then Get (Right.Elements, Find (Right.Keys, K))
/= Get (Left.Elements, I)
then
return False;
end if;
end;
end loop;
return True;
end Elements_Equal_Except;
--------- ---------
-- Get -- -- Get --
--------- ---------
function Get (M : Map; K : Key_Type) return Element_Type is function Get (Container : Map; Key : Key_Type) return Element_Type is
begin begin
return Get (M.Elements, Find (M.Keys, K)); return Get (Container.Elements, Find (Container.Keys, Key));
end Get; end Get;
------------ -------------
-- Is_Add -- -- Has_Key --
------------ -------------
function Is_Add function Has_Key (Container : Map; Key : Key_Type) return Boolean is
(M : Map;
K : Key_Type;
E : Element_Type;
Result : Map) return Boolean
is
begin begin
if Mem (M, K) or not Mem (Result, K) or Get (Result, K) /= E then return Find (Container.Keys, Key) > 0;
return False; end Has_Key;
end if;
for K of M loop
if not Mem (Result, K) or else Get (Result, K) /= Get (M, K) then
return False;
end if;
end loop;
for KK of Result loop
if KK /= K and not Mem (M, KK) then
return False;
end if;
end loop;
return True;
end Is_Add;
-------------- --------------
-- Is_Empty -- -- Is_Empty --
-------------- --------------
function Is_Empty (M : Map) return Boolean is function Is_Empty (Container : Map) return Boolean is
begin begin
return Length (M.Keys) = 0; return Length (Container.Keys) = 0;
end Is_Empty; end Is_Empty;
------------ -------------------
-- Is_Set -- -- Keys_Included --
------------ -------------------
function Keys_Included (Left : Map; Right : Map) return Boolean is
begin
for I in 1 .. Length (Left.Keys) loop
declare
K : constant Key_Type := Get (Left.Keys, I);
begin
if Find (Right.Keys, K) = 0 then
return False;
end if;
end;
end loop;
return True;
end Keys_Included;
--------------------------
-- Keys_Included_Except --
--------------------------
function Keys_Included_Except
(Left : Map;
Right : Map;
New_Key : Key_Type) return Boolean
is
begin
for I in 1 .. Length (Left.Keys) loop
declare
K : constant Key_Type := Get (Left.Keys, I);
begin
if not Equivalent_Keys (K, New_Key)
and then Find (Right.Keys, K) = 0
then
return False;
end if;
end;
end loop;
return True;
end Keys_Included_Except;
function Is_Set function Keys_Included_Except
(M : Map; (Left : Map;
K : Key_Type; Right : Map;
E : Element_Type; X, Y : Key_Type) return Boolean
Result : Map) return Boolean
is is
(Mem (M, K) begin
and then Mem (Result, K) for I in 1 .. Length (Left.Keys) loop
and then Get (Result, K) = E declare
and then (for all KK of M => K : constant Key_Type := Get (Left.Keys, I);
Mem (Result, KK) begin
and then if not Equivalent_Keys (K, X)
(if K /= KK then Get (Result, KK) = Get (M, KK))) and then not Equivalent_Keys (K, Y)
and then (for all K of Result => Mem (M, K))); and then Find (Right.Keys, K) = 0
then
return False;
end if;
end;
end loop;
return True;
end Keys_Included_Except;
------------ ------------
-- Length -- -- Length --
------------ ------------
function Length (M : Map) return Count_Type is function Length (Container : Map) return Count_Type is
begin begin
return Length (M.Elements); return Length (Container.Elements);
end Length; end Length;
--------- ---------------
-- Mem -- -- Same_Keys --
--------- ---------------
function Mem (M : Map; K : Key_Type) return Boolean is function Same_Keys (Left : Map; Right : Map) return Boolean is
begin (Keys_Included (Left, Right)
return Find (M.Keys, K) > 0; and Keys_Included (Left => Right, Right => Left));
end Mem;
--------- ---------
-- Set -- -- Set --
--------- ---------
function Set (M : Map; K : Key_Type; E : Element_Type) return Map is function Set
(Keys => M.Keys, Elements => Set (M.Elements, Find (M.Keys, K), E)); (Container : Map;
Key : Key_Type;
New_Item : Element_Type) return Map
is
(Keys => Container.Keys,
Elements =>
Set (Container.Elements, Find (Container.Keys, Key), New_Item));
end Ada.Containers.Functional_Maps; end Ada.Containers.Functional_Maps;
gcc/ada/a-cofuse.adb
...@@ -38,101 +38,107 @@ package body Ada.Containers.Functional_Sets with SPARK_Mode => Off is ...@@ -38,101 +38,107 @@ package body Ada.Containers.Functional_Sets with SPARK_Mode => Off is
-- "=" -- -- "=" --
--------- ---------
function "=" (S1 : Set; S2 : Set) return Boolean is function "=" (Left : Set; Right : Set) return Boolean is
(S1.Content <= S2.Content and S2.Content <= S1.Content); (Left.Content <= Right.Content and Right.Content <= Left.Content);
---------- ----------
-- "<=" -- -- "<=" --
---------- ----------
function "<=" (S1 : Set; S2 : Set) return Boolean is function "<=" (Left : Set; Right : Set) return Boolean is
(S1.Content <= S2.Content); (Left.Content <= Right.Content);
--------- ---------
-- Add -- -- Add --
--------- ---------
function Add (S : Set; E : Element_Type) return Set is function Add (Container : Set; Item : Element_Type) return Set is
(Content => Add (S.Content, Length (S.Content) + 1, E)); (Content =>
Add (Container.Content, Length (Container.Content) + 1, Item));
------------------ --------------
-- Intersection -- -- Contains --
------------------ --------------
function Intersection (S1 : Set; S2 : Set) return Set is function Contains (Container : Set; Item : Element_Type) return Boolean is
(Content => Intersection (S1.Content, S2.Content)); (Find (Container.Content, Item) > 0);
------------ ---------------------
-- Is_Add -- -- Included_Except --
------------ ---------------------
function Is_Add (S : Set; E : Element_Type; Result : Set) return Boolean function Included_Except
(Left : Set;
Right : Set;
Item : Element_Type) return Boolean
is is
(Mem (Result, E) (for all E of Left =>
and (for all F of Result => Mem (S, F) or F = E) Equivalent_Elements (E, Item) or Contains (Right, E));
and (for all E of S => Mem (Result, E)));
-------------- -----------------------
-- Is_Empty -- -- Included_In_Union --
-------------- -----------------------
function Is_Empty (S : Set) return Boolean is (Length (S.Content) = 0); function Included_In_Union
(Container : Set;
Left : Set;
Right : Set) return Boolean
is
(for all Item of Container =>
Contains (Left, Item) or Contains (Right, Item));
--------------------- ---------------------------
-- Is_Intersection -- -- Includes_Intersection --
--------------------- ---------------------------
function Is_Intersection function Includes_Intersection
(S1 : Set; (Container : Set;
S2 : Set; Left : Set;
Result : Set) return Boolean Right : Set) return Boolean
is is
((for all E of Result => (for all Item of Left =>
Mem (S1, E) (if Contains (Right, Item) then Contains (Container, Item)));
and Mem (S2, E))
and (for all E of S1 => (if Mem (S2, E) then Mem (Result, E)))); ------------------
-- Intersection --
------------------
function Intersection (Left : Set; Right : Set) return Set is
(Content => Intersection (Left.Content, Right.Content));
-------------- --------------
-- Is_Union -- -- Is_Empty --
-------------- --------------
function Is_Union (S1 : Set; S2 : Set; Result : Set) return Boolean is function Is_Empty (Container : Set) return Boolean is
((for all E of Result => Mem (S1, E) or Mem (S2, E)) (Length (Container.Content) = 0);
and (for all E of S1 => Mem (Result, E))
and (for all E of S2 => Mem (Result, E)));
------------ ------------
-- Length -- -- Length --
------------ ------------
function Length (S : Set) return Count_Type is (Length (S.Content)); function Length (Container : Set) return Count_Type is
(Length (Container.Content));
---------
-- Mem --
---------
function Mem (S : Set; E : Element_Type) return Boolean is
(Find (S.Content, E) > 0);
------------------ ------------------
-- Num_Overlaps -- -- Num_Overlaps --
------------------ ------------------
function Num_Overlaps (S1 : Set; S2 : Set) return Count_Type is function Num_Overlaps (Left : Set; Right : Set) return Count_Type is
(Num_Overlaps (S1.Content, S2.Content)); (Num_Overlaps (Left.Content, Right.Content));
------------ ------------
-- Remove -- -- Remove --
------------ ------------
function Remove (S : Set; E : Element_Type) return Set is function Remove (Container : Set; Item : Element_Type) return Set is
(Content => Remove (S.Content, Find (S.Content, E))); (Content => Remove (Container.Content, Find (Container.Content, Item)));
----------- -----------
-- Union -- -- Union --
----------- -----------
function Union (S1 : Set; S2 : Set) return Set is function Union (Left : Set; Right : Set) return Set is
(Content => Union (S1.Content, S2.Content)); (Content => Union (Left.Content, Right.Content));
end Ada.Containers.Functional_Sets; end Ada.Containers.Functional_Sets;
gcc/ada/a-cofuve.adb
...@@ -34,129 +34,215 @@ package body Ada.Containers.Functional_Vectors with SPARK_Mode => Off is ...@@ -34,129 +34,215 @@ package body Ada.Containers.Functional_Vectors with SPARK_Mode => Off is
use Containers; use Containers;
--------- ---------
-- "=" --
---------
function "=" (S1 : Sequence; S2 : Sequence) return Boolean is
(S1.Content = S2.Content);
---------
-- "<" -- -- "<" --
--------- ---------
function "<" (S1 : Sequence; S2 : Sequence) return Boolean is function "<" (Left : Sequence; Right : Sequence) return Boolean is
(Length (S1.Content) < Length (S2.Content) (Length (Left.Content) < Length (Right.Content)
and then (for all I in Index_Type'First .. Last (S1) => and then (for all I in Index_Type'First .. Last (Left) =>
Get (S1.Content, I) = Get (S2.Content, I))); Get (Left.Content, I) = Get (Right.Content, I)));
---------- ----------
-- "<=" -- -- "<=" --
---------- ----------
function "<=" (S1 : Sequence; S2 : Sequence) return Boolean is function "<=" (Left : Sequence; Right : Sequence) return Boolean is
(Length (S1.Content) <= Length (S2.Content) (Length (Left.Content) <= Length (Right.Content)
and then (for all I in Index_Type'First .. Last (S1) => and then (for all I in Index_Type'First .. Last (Left) =>
Get (S1.Content, I) = Get (S2.Content, I))); Get (Left.Content, I) = Get (Right.Content, I)));
--------- ---------
-- Add -- -- "=" --
--------- ---------
function Add (S : Sequence; E : Element_Type) return Sequence is function "=" (Left : Sequence; Right : Sequence) return Boolean is
(Content => Add (S.Content, (Left.Content = Right.Content);
Index_Type'Val
(Index_Type'Pos (Index_Type'First) +
Length (S.Content)),
E));
--------- ---------
-- Get -- -- Add --
--------- ---------
function Get (S : Sequence; N : Extended_Index) return Element_Type is function Add (Container : Sequence; New_Item : Element_Type) return Sequence
(Get (S.Content, N));
------------
-- Insert --
------------
function Insert
(S : Sequence;
N : Index_Type;
E : Element_Type) return Sequence
is is
(Content => Add (S.Content, N, E)); (Content => Add (Container.Content,
Index_Type'Val
------------ (Index_Type'Pos (Index_Type'First) +
-- Is_Add -- Length (Container.Content)),
------------ New_Item));
function Is_Add function Add
(S : Sequence; (Container : Sequence;
E : Element_Type; Position : Index_Type;
Result : Sequence) return Boolean New_Item : Element_Type) return Sequence
is
(Content => Add (Container.Content, Position, New_Item));
--------------------
-- Constant_Range --
--------------------
function Constant_Range
(Container : Sequence;
Fst : Index_Type;
Lst : Extended_Index;
Item : Element_Type) return Boolean is
begin
for I in Fst .. Lst loop
if Get (Container.Content, I) /= Item then
return False;
end if;
end loop;
return True;
end Constant_Range;
--------------
-- Contains --
--------------
function Contains
(Container : Sequence;
Fst : Index_Type;
Lst : Extended_Index;
Item : Element_Type) return Boolean
is is
(Length (Result) = Length (S) + 1 begin
and then Get (Result, Index_Type'Val for I in Fst .. Lst loop
((Index_Type'Pos (Index_Type'First) - 1) + if Get (Container.Content, I) = Item then
Length (Result))) = E return True;
and then end if;
(for all M in Index_Type'First .. end loop;
(Index_Type'Val return False;
((Index_Type'Pos (Index_Type'First) - 1) + Length (S))) => end Contains;
Get (Result, M) = Get (S, M)));
------------------
-- Range_Except --
------------------
function Equal_Except
(Left : Sequence;
Right : Sequence;
Position : Index_Type) return Boolean
is
begin
if Length (Left.Content) /= Length (Right.Content) then
return False;
end if;
for I in Index_Type'First .. Last (Left) loop
if I /= Position
and then Get (Left.Content, I) /= Get (Right.Content, I)
then
return False;
end if;
end loop;
return True;
end Equal_Except;
function Equal_Except
(Left : Sequence;
Right : Sequence;
X, Y : Index_Type) return Boolean
is
begin
if Length (Left.Content) /= Length (Right.Content) then
return False;
end if;
for I in Index_Type'First .. Last (Left) loop
if I /= X and then I /= Y
and then Get (Left.Content, I) /= Get (Right.Content, I)
then
return False;
end if;
end loop;
return True;
end Equal_Except;
------------ ---------
-- Is_Set -- -- Get --
------------ ---------
function Is_Set function Get (Container : Sequence;
(S : Sequence; Position : Extended_Index) return Element_Type
N : Index_Type;
E : Element_Type;
Result : Sequence) return Boolean
is is
(N in Index_Type'First .. (Get (Container.Content, Position));
(Index_Type'Val
((Index_Type'Pos (Index_Type'First) - 1) + Length (S)))
and then Length (Result) = Length (S)
and then Get (Result, N) = E
and then
(for all M in Index_Type'First ..
(Index_Type'Val
((Index_Type'Pos (Index_Type'First) - 1) + Length (S))) =>
(if M /= N then Get (Result, M) = Get (S, M))));
---------- ----------
-- Last -- -- Last --
---------- ----------
function Last (S : Sequence) return Extended_Index is function Last (Container : Sequence) return Extended_Index is
(Index_Type'Val ((Index_Type'Pos (Index_Type'First) - 1) + Length (S))); (Index_Type'Val ((Index_Type'Pos (Index_Type'First) - 1)
+ Length (Container)));
------------ ------------
-- Length -- -- Length --
------------ ------------
function Length (S : Sequence) return Count_Type is function Length (Container : Sequence) return Count_Type is
(Length (S.Content)); (Length (Container.Content));
-----------------
-- Range_Equal --
-----------------
function Range_Equal
(Left : Sequence;
Right : Sequence;
Fst : Index_Type;
Lst : Extended_Index) return Boolean
is
begin
for I in Fst .. Lst loop
if Get (Left, I) /= Get (Right, I) then
return False;
end if;
end loop;
return True;
end Range_Equal;
-------------------
-- Range_Shifted --
-------------------
function Range_Shifted
(Left : Sequence;
Right : Sequence;
Fst : Index_Type;
Lst : Extended_Index;
Offset : Count_Type'Base) return Boolean
is
begin
for I in Fst .. Lst loop
if Get (Left, I)
/= Get (Right, Index_Type'Val (Index_Type'Pos (I) + Offset))
then
return False;
end if;
end loop;
return True;
end Range_Shifted;
------------ ------------
-- Remove -- -- Remove --
------------ ------------
function Remove (S : Sequence; N : Index_Type) return Sequence is function Remove (Container : Sequence;
(Content => Remove (S.Content, N)); Position : Index_Type) return Sequence
is
(Content => Remove (Container.Content, Position));
--------- ---------
-- Set -- -- Set --
--------- ---------
function Set function Set
(S : Sequence; (Container : Sequence;
N : Index_Type; Position : Index_Type;
E : Element_Type) return Sequence New_Item : Element_Type) return Sequence
is is
(Content => Set (S.Content, N, E)); (Content => Set (Container.Content, Position, New_Item));
end Ada.Containers.Functional_Vectors; end Ada.Containers.Functional_Vectors;
gcc/ada/a-except.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- -- -- --
-- This specification is derived from the Ada Reference Manual for use with -- -- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow -- -- GNAT. The copyright notice above, and the license provisions that follow --
...@@ -33,24 +33,15 @@ ...@@ -33,24 +33,15 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- This version of Ada.Exceptions is used only for building the compiler -- This version of Ada.Exceptions fully supports Ada 95 and later language
-- and certain basic tools. The "real" version of Ada.Exceptions is in -- versions. It is used in all situations except for the build of the
-- a-except-2005.ads/adb, and is used for all other builds where full Ada -- compiler and other basic tools. For these latter builds, we use an
-- functionality is required. In particular, it is used for building run -- Ada 95-only version.
-- times on all targets.
-- This version is limited to Ada 95 features. It omits Ada 2005 features
-- such as the additional definitions of Exception_Name returning
-- Wide_[Wide_]String. It differs from the version specified in the Ada 95 RM
-- only in that it is declared Preelaborate (see declaration below for why
-- this is done).
-- The reason for this splitting off of a separate version is to support -- The reason for this splitting off of a separate version is to support
-- older bootstrap compilers that do not support Ada 2005 features, and -- older bootstrap compilers that do not support Ada 2005 features, and
-- Ada.Exceptions is part of the compiler sources. -- Ada.Exceptions is part of the compiler sources.
pragma Compiler_Unit_Warning;
pragma Polling (Off); pragma Polling (Off);
-- We must turn polling off for this unit, because otherwise we get -- We must turn polling off for this unit, because otherwise we get
-- elaboration circularities with ourself. -- elaboration circularities with ourself.
...@@ -62,25 +53,39 @@ with System.Traceback_Entries; ...@@ -62,25 +53,39 @@ with System.Traceback_Entries;
package Ada.Exceptions is package Ada.Exceptions is
pragma Preelaborate; pragma Preelaborate;
-- We make this preelaborable. If we did not do this, then run time units -- In accordance with Ada 2005 AI-362.
-- used by the compiler (e.g. s-soflin.ads) would run into trouble.
-- Conformance with Ada 95 is not an issue, since this version is used
-- only by the compiler.
type Exception_Id is private; type Exception_Id is private;
pragma Preelaborable_Initialization (Exception_Id);
Null_Id : constant Exception_Id; Null_Id : constant Exception_Id;
type Exception_Occurrence is limited private; type Exception_Occurrence is limited private;
pragma Preelaborable_Initialization (Exception_Occurrence);
type Exception_Occurrence_Access is access all Exception_Occurrence; type Exception_Occurrence_Access is access all Exception_Occurrence;
Null_Occurrence : constant Exception_Occurrence; Null_Occurrence : constant Exception_Occurrence;
function Exception_Name (Id : Exception_Id) return String;
function Exception_Name (X : Exception_Occurrence) return String; function Exception_Name (X : Exception_Occurrence) return String;
-- Same as Exception_Name (Exception_Identity (X))
function Exception_Name (Id : Exception_Id) return String; function Wide_Exception_Name
(Id : Exception_Id) return Wide_String;
pragma Ada_05 (Wide_Exception_Name);
function Wide_Exception_Name
(X : Exception_Occurrence) return Wide_String;
pragma Ada_05 (Wide_Exception_Name);
function Wide_Wide_Exception_Name
(Id : Exception_Id) return Wide_Wide_String;
pragma Ada_05 (Wide_Wide_Exception_Name);
function Wide_Wide_Exception_Name
(X : Exception_Occurrence) return Wide_Wide_String;
pragma Ada_05 (Wide_Wide_Exception_Name);
procedure Raise_Exception (E : Exception_Id; Message : String := ""); procedure Raise_Exception (E : Exception_Id; Message : String := "");
pragma No_Return (Raise_Exception); pragma No_Return (Raise_Exception);
...@@ -105,7 +110,9 @@ package Ada.Exceptions is ...@@ -105,7 +110,9 @@ package Ada.Exceptions is
-- 0xyyyyyyyy 0xyyyyyyyy ... -- 0xyyyyyyyy 0xyyyyyyyy ...
-- --
-- The lines are separated by a ASCII.LF character -- The lines are separated by a ASCII.LF character
-- The nnnn is the partition Id given as decimal digits. --
-- The nnnn is the partition Id given as decimal digits
--
-- The 0x... line represents traceback program counter locations, -- The 0x... line represents traceback program counter locations,
-- in order with the first one being the exception location. -- in order with the first one being the exception location.
...@@ -121,6 +128,22 @@ package Ada.Exceptions is ...@@ -121,6 +128,22 @@ package Ada.Exceptions is
(Source : Exception_Occurrence) (Source : Exception_Occurrence)
return Exception_Occurrence_Access; return Exception_Occurrence_Access;
-- Ada 2005 (AI-438): The language revision introduces the following
-- subprograms and attribute definitions. We do not provide them
-- explicitly. instead, the corresponding stream attributes are made
-- available through a pragma Stream_Convert in the private part.
-- procedure Read_Exception_Occurrence
-- (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
-- Item : out Exception_Occurrence);
-- procedure Write_Exception_Occurrence
-- (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
-- Item : Exception_Occurrence);
-- for Exception_Occurrence'Read use Read_Exception_Occurrence;
-- for Exception_Occurrence'Write use Write_Exception_Occurrence;
private private
package SSL renames System.Standard_Library; package SSL renames System.Standard_Library;
package SP renames System.Parameters; package SP renames System.Parameters;
...@@ -216,8 +239,8 @@ private ...@@ -216,8 +239,8 @@ private
pragma No_Return (Reraise_Occurrence_No_Defer); pragma No_Return (Reraise_Occurrence_No_Defer);
-- Exactly like Reraise_Occurrence, except that abort is not deferred -- Exactly like Reraise_Occurrence, except that abort is not deferred
-- before the call and the parameter X is known not to be the null -- before the call and the parameter X is known not to be the null
-- occurrence. This is used in generated code when it is known that -- occurrence. This is used in generated code when it is known that abort
-- abort is already deferred. -- is already deferred.
function Triggered_By_Abort return Boolean; function Triggered_By_Abort return Boolean;
-- Determine whether the current exception (if it exists) is an instance of -- Determine whether the current exception (if it exists) is an instance of
...@@ -264,6 +287,10 @@ private ...@@ -264,6 +287,10 @@ private
Id : Exception_Id; Id : Exception_Id;
-- Exception_Identity for this exception occurrence -- Exception_Identity for this exception occurrence
Machine_Occurrence : System.Address;
-- The underlying machine occurrence. For GCC, this corresponds to the
-- _Unwind_Exception structure address.
Msg_Length : Natural := 0; Msg_Length : Natural := 0;
-- Length of message (zero = no message) -- Length of message (zero = no message)
...@@ -295,18 +322,28 @@ private ...@@ -295,18 +322,28 @@ private
-- this, and it would not work right, because of the Msg and Tracebacks -- this, and it would not work right, because of the Msg and Tracebacks
-- fields which have unused entries not copied by Save_Occurrence. -- fields which have unused entries not copied by Save_Occurrence.
function Get_Exception_Machine_Occurrence
(X : Exception_Occurrence) return System.Address;
pragma Export (Ada, Get_Exception_Machine_Occurrence,
"__gnat_get_exception_machine_occurrence");
-- Get the machine occurrence corresponding to an exception occurrence.
-- It is Null_Address if there is no machine occurrence (in runtimes that
-- doesn't use GCC mechanism) or if it has been lost (Save_Occurrence
-- doesn't save the machine occurrence).
function EO_To_String (X : Exception_Occurrence) return String; function EO_To_String (X : Exception_Occurrence) return String;
function String_To_EO (S : String) return Exception_Occurrence; function String_To_EO (S : String) return Exception_Occurrence;
pragma Stream_Convert (Exception_Occurrence, String_To_EO, EO_To_String); pragma Stream_Convert (Exception_Occurrence, String_To_EO, EO_To_String);
-- Functions for implementing Exception_Occurrence stream attributes -- Functions for implementing Exception_Occurrence stream attributes
Null_Occurrence : constant Exception_Occurrence := ( Null_Occurrence : constant Exception_Occurrence := (
Id => null, Id => null,
Msg_Length => 0, Machine_Occurrence => System.Null_Address,
Msg => (others => ' '), Msg_Length => 0,
Exception_Raised => False, Msg => (others => ' '),
Pid => 0, Exception_Raised => False,
Num_Tracebacks => 0, Pid => 0,
Tracebacks => (others => TBE.Null_TB_Entry)); Num_Tracebacks => 0,
Tracebacks => (others => TBE.Null_TB_Entry));
end Ada.Exceptions; end Ada.Exceptions;
gcc/ada/exp_spark.adb
...@@ -54,7 +54,7 @@ package body Exp_SPARK is ...@@ -54,7 +54,7 @@ package body Exp_SPARK is
-- System.Storage_Elements.To_Address -- System.Storage_Elements.To_Address
procedure Expand_SPARK_N_Object_Declaration (N : Node_Id); procedure Expand_SPARK_N_Object_Declaration (N : Node_Id);
-- Perform object declaration-specific expansion -- Perform object-declaration-specific expansion
procedure Expand_SPARK_N_Object_Renaming_Declaration (N : Node_Id); procedure Expand_SPARK_N_Object_Renaming_Declaration (N : Node_Id);
-- Perform name evaluation for a renamed object -- Perform name evaluation for a renamed object
...@@ -86,7 +86,7 @@ package body Exp_SPARK is ...@@ -86,7 +86,7 @@ package body Exp_SPARK is
Qualify_Entity_Names (N); Qualify_Entity_Names (N);
-- Replace occurrences of System'To_Address by calls to -- Replace occurrences of System'To_Address by calls to
-- System.Storage_Elements.To_Address -- System.Storage_Elements.To_Address.
when N_Attribute_Reference => when N_Attribute_Reference =>
Expand_SPARK_N_Attribute_Reference (N); Expand_SPARK_N_Attribute_Reference (N);
......
gcc/ada/gcc-interface/Make-lang.in
...@@ -99,6 +99,8 @@ ADA_TOOLS=gnatbind gnatchop gnat gnatkr gnatlink gnatls gnatmake \ ...@@ -99,6 +99,8 @@ ADA_TOOLS=gnatbind gnatchop gnat gnatkr gnatlink gnatls gnatmake \
ada-warn = $(ADA_CFLAGS) $(filter-out -pedantic, $(STRICT_WARN)) ada-warn = $(ADA_CFLAGS) $(filter-out -pedantic, $(STRICT_WARN))
# Unresolved warnings in specific files. # Unresolved warnings in specific files.
ada/adaint.o-warn = -Wno-error ada/adaint.o-warn = -Wno-error
# For unwind-pe.h
CFLAGS-ada/raise-gcc.o += -I$(srcdir)/../libgcc -Iinclude
ada/%.o: ada/gcc-interface/%.c ada/%.o: ada/gcc-interface/%.c
$(COMPILE) $< $(COMPILE) $<
...@@ -223,6 +225,7 @@ GCC_LLINK=$(LLINKER) $(GCC_LINKERFLAGS) $(LDFLAGS) ...@@ -223,6 +225,7 @@ GCC_LLINK=$(LLINKER) $(GCC_LINKERFLAGS) $(LDFLAGS)
# Object files for gnat1 from C sources. # Object files for gnat1 from C sources.
GNAT1_C_OBJS = ada/adadecode.o ada/adaint.o ada/argv.o ada/cio.o \ GNAT1_C_OBJS = ada/adadecode.o ada/adaint.o ada/argv.o ada/cio.o \
ada/cstreams.o ada/env.o ada/init.o ada/initialize.o ada/raise.o \ ada/cstreams.o ada/env.o ada/init.o ada/initialize.o ada/raise.o \
ada/raise-gcc.o \
ada/seh_init.o ada/targext.o ada/cuintp.o ada/decl.o ada/rtfinal.o \ ada/seh_init.o ada/targext.o ada/cuintp.o ada/decl.o ada/rtfinal.o \
ada/rtinit.o ada/misc.o ada/utils.o ada/utils2.o ada/trans.o ada/targtyps.o ada/rtinit.o ada/misc.o ada/utils.o ada/utils2.o ada/trans.o ada/targtyps.o
...@@ -232,6 +235,7 @@ GNAT_ADA_OBJS = \ ...@@ -232,6 +235,7 @@ GNAT_ADA_OBJS = \
ada/a-chlat1.o \ ada/a-chlat1.o \
ada/a-elchha.o \ ada/a-elchha.o \
ada/a-except.o \ ada/a-except.o \
ada/a-exctra.o \
ada/a-ioexce.o \ ada/a-ioexce.o \
ada/ada.o \ ada/ada.o \
ada/spark_xrefs.o \ ada/spark_xrefs.o \
...@@ -334,6 +338,7 @@ GNAT_ADA_OBJS = \ ...@@ -334,6 +338,7 @@ GNAT_ADA_OBJS = \
ada/rident.o \ ada/rident.o \
ada/rtsfind.o \ ada/rtsfind.o \
ada/s-addope.o \ ada/s-addope.o \
ada/s-addima.o \
ada/s-assert.o \ ada/s-assert.o \
ada/s-bitops.o \ ada/s-bitops.o \
ada/s-carun8.o \ ada/s-carun8.o \
...@@ -351,9 +356,11 @@ GNAT_ADA_OBJS = \ ...@@ -351,9 +356,11 @@ GNAT_ADA_OBJS = \
ada/s-excdeb.o \ ada/s-excdeb.o \
ada/s-except.o \ ada/s-except.o \
ada/s-exctab.o \ ada/s-exctab.o \
ada/s-excmac.o \
ada/s-htable.o \ ada/s-htable.o \
ada/s-imenne.o \ ada/s-imenne.o \
ada/s-imgenu.o \ ada/s-imgenu.o \
ada/s-imgint.o \
ada/s-mastop.o \ ada/s-mastop.o \
ada/s-memory.o \ ada/s-memory.o \
ada/s-os_lib.o \ ada/s-os_lib.o \
...@@ -372,7 +379,9 @@ GNAT_ADA_OBJS = \ ...@@ -372,7 +379,9 @@ GNAT_ADA_OBJS = \
ada/s-strhas.o \ ada/s-strhas.o \
ada/s-string.o \ ada/s-string.o \
ada/s-strops.o \ ada/s-strops.o \
ada/s-traceb.o \
ada/s-traent.o \ ada/s-traent.o \
ada/s-trasym.o \
ada/s-unstyp.o \ ada/s-unstyp.o \
ada/s-utf_32.o \ ada/s-utf_32.o \
ada/s-valint.o \ ada/s-valint.o \
...@@ -381,6 +390,7 @@ GNAT_ADA_OBJS = \ ...@@ -381,6 +390,7 @@ GNAT_ADA_OBJS = \
ada/s-wchcnv.o \ ada/s-wchcnv.o \
ada/s-wchcon.o \ ada/s-wchcon.o \
ada/s-wchjis.o \ ada/s-wchjis.o \
ada/s-wchstw.o \
ada/scans.o \ ada/scans.o \
ada/scil_ll.o \ ada/scil_ll.o \
ada/scn.o \ ada/scn.o \
...@@ -514,6 +524,7 @@ GNATBIND_OBJS = \ ...@@ -514,6 +524,7 @@ GNATBIND_OBJS = \
ada/osint.o \ ada/osint.o \
ada/output.o \ ada/output.o \
ada/raise.o \ ada/raise.o \
ada/raise-gcc.o \
ada/restrict.o \ ada/restrict.o \
ada/rident.o \ ada/rident.o \
ada/rtfinal.o \ ada/rtfinal.o \
...@@ -534,10 +545,12 @@ GNATBIND_OBJS = \ ...@@ -534,10 +545,12 @@ GNATBIND_OBJS = \
ada/s-crtl.o \ ada/s-crtl.o \
ada/s-excdeb.o \ ada/s-excdeb.o \
ada/s-except.o \ ada/s-except.o \
ada/s-excmac.o \
ada/s-exctab.o \ ada/s-exctab.o \
ada/s-htable.o \ ada/s-htable.o \
ada/s-imenne.o \ ada/s-imenne.o \
ada/s-imgenu.o \ ada/s-imgenu.o \
ada/s-imgint.o \
ada/s-mastop.o \ ada/s-mastop.o \
ada/s-memory.o \ ada/s-memory.o \
ada/s-os_lib.o \ ada/s-os_lib.o \
...@@ -555,11 +568,13 @@ GNATBIND_OBJS = \ ...@@ -555,11 +568,13 @@ GNATBIND_OBJS = \
ada/s-string.o \ ada/s-string.o \
ada/s-strops.o \ ada/s-strops.o \
ada/s-traent.o \ ada/s-traent.o \
ada/s-traceb.o \
ada/s-unstyp.o \ ada/s-unstyp.o \
ada/s-utf_32.o \ ada/s-utf_32.o \
ada/s-wchcnv.o \ ada/s-wchcnv.o \
ada/s-wchcon.o \ ada/s-wchcon.o \
ada/s-wchjis.o \ ada/s-wchjis.o \
ada/s-wchstw.o \
ada/scans.o \ ada/scans.o \
ada/scil_ll.o \ ada/scil_ll.o \
ada/scng.o \ ada/scng.o \
...@@ -594,6 +609,21 @@ ADA_BACKEND = $(BACKEND) attribs.o ...@@ -594,6 +609,21 @@ ADA_BACKEND = $(BACKEND) attribs.o
# List of target dependent sources, overridden below as necessary # List of target dependent sources, overridden below as necessary
TARGET_ADA_SRCS = TARGET_ADA_SRCS =
# Select the right s-excmac according to exception layout (Itanium or arm)
host_cpu=$(word 1, $(subst -, ,$(host)))
EH_MECHANISM=-gcc
ifeq ($(strip $(filter-out arm%,$(host_cpu))),)
EH_MECHANISM=-arm
endif
ada/s-excmac.o: ada/s-excmac.ads ada/s-excmac.adb
ada/s-excmac.ads: $(srcdir)/ada/s-excmac$(EH_MECHANISM).ads
$(CP) $< $@
ada/s-excmac.adb: $(srcdir)/ada/s-excmac$(EH_MECHANISM).adb
$(CP) $< $@
# Needs to be built with CC=gcc # Needs to be built with CC=gcc
# Since the RTL should be built with the latest compiler, remove the # Since the RTL should be built with the latest compiler, remove the
# stamp target in the parent directory whenever gnat1 is rebuilt # stamp target in the parent directory whenever gnat1 is rebuilt
...@@ -976,12 +1006,12 @@ ada/sdefault.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ...@@ -976,12 +1006,12 @@ ada/sdefault.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
# Special flags - see gcc-interface/Makefile.in for the template. # Special flags - see gcc-interface/Makefile.in for the template.
ada/a-except.o : ada/a-except.adb ada/a-except.ads ada/a-except.o : ada/a-except.adb ada/a-except.ads ada/s-excmac.ads ada/s-excmac.adb
$(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O1 -fno-inline \ $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O1 -fno-inline \
$(ADA_INCLUDES) $< $(OUTPUT_OPTION) $(ADA_INCLUDES) $< $(OUTPUT_OPTION)
@$(ADA_DEPS) @$(ADA_DEPS)
ada/s-excdeb.o : ada/s-excdeb.adb ada/s-excdeb.ads ada/s-excdeb.o : ada/s-excdeb.adb ada/s-excdeb.ads
$(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 \ $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 \
$(ADA_INCLUDES) $< $(OUTPUT_OPTION) $(ADA_INCLUDES) $< $(OUTPUT_OPTION)
@$(ADA_DEPS) @$(ADA_DEPS)
......
gcc/ada/gcc-interface/Makefile.in
...@@ -2427,32 +2427,20 @@ endif ...@@ -2427,32 +2427,20 @@ endif
ifeq ($(EH_MECHANISM),-gcc) ifeq ($(EH_MECHANISM),-gcc)
LIBGNAT_TARGET_PAIRS += \ LIBGNAT_TARGET_PAIRS += \
a-exexpr.adb<a-exexpr-gcc.adb \ s-excmac.ads<s-excmac-gcc.ads \
s-excmac.ads<s-excmac-gcc.ads s-excmac.adb<s-excmac-gcc.adb
EXTRA_LIBGNAT_OBJS+=raise-gcc.o EXTRA_LIBGNAT_OBJS+=raise-gcc.o
EXTRA_GNATRTL_NONTASKING_OBJS+=g-cppexc.o s-excmac.o EXTRA_GNATRTL_NONTASKING_OBJS+=g-cppexc.o s-excmac.o
endif endif
ifeq ($(EH_MECHANISM),-arm) ifeq ($(EH_MECHANISM),-arm)
LIBGNAT_TARGET_PAIRS += \ LIBGNAT_TARGET_PAIRS += \
a-exexpr.adb<a-exexpr-gcc.adb \ s-excmac.ads<s-excmac-arm.ads \
s-excmac.ads<s-excmac-arm.ads s-excmac.adb<s-excmac-arm.adb
EXTRA_LIBGNAT_OBJS+=raise-gcc.o EXTRA_LIBGNAT_OBJS+=raise-gcc.o
EXTRA_GNATRTL_NONTASKING_OBJS+=g-cppexc.o s-excmac.o EXTRA_GNATRTL_NONTASKING_OBJS+=g-cppexc.o s-excmac.o
endif endif
# Use the Ada 2005 version of Ada.Exceptions by default, unless specified
# explicitly already. The base files (a-except.ad?) are used only for building
# the compiler and other basic tools.
# These base versions lack Ada 2005 additions which would cause bootstrap
# problems if included in the compiler and other basic tools.
ifeq ($(filter a-except%,$(LIBGNAT_TARGET_PAIRS)),)
LIBGNAT_TARGET_PAIRS += \
a-except.ads<a-except-2005.ads \
a-except.adb<a-except-2005.adb
endif
# Configuration of host tools # Configuration of host tools
# Under linux, host tools need to be linked with -ldl # Under linux, host tools need to be linked with -ldl
......
gcc/ada/raise-gcc.c
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
* * * *
* C Implementation File * * C Implementation File *
* * * *
* Copyright (C) 1992-2016, Free Software Foundation, Inc. * * Copyright (C) 1992-2017, Free Software Foundation, Inc. *
* * * *
* GNAT is free software; you can redistribute it and/or modify it under * * GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- * * terms of the GNU General Public License as published by the Free Soft- *
...@@ -32,10 +32,6 @@ ...@@ -32,10 +32,6 @@
/* Code related to the integration of the GCC mechanism for exception /* Code related to the integration of the GCC mechanism for exception
handling. */ handling. */
#ifndef IN_RTS
#error "RTS unit only"
#endif
#ifndef CERT #ifndef CERT
#include "tconfig.h" #include "tconfig.h"
#include "tsystem.h" #include "tsystem.h"
...@@ -45,9 +41,14 @@ ...@@ -45,9 +41,14 @@
#endif #endif
#include <stdarg.h> #include <stdarg.h>
#ifdef __cplusplus
# include <cstdlib>
#else
typedef char bool; typedef char bool;
# define true 1 # define true 1
# define false 0 # define false 0
#endif
#include "raise.h" #include "raise.h"
...@@ -72,6 +73,10 @@ typedef char bool; ...@@ -72,6 +73,10 @@ typedef char bool;
#include "unwind.h" #include "unwind.h"
#ifdef __cplusplus
extern "C" {
#endif
typedef struct _Unwind_Context _Unwind_Context; typedef struct _Unwind_Context _Unwind_Context;
typedef struct _Unwind_Exception _Unwind_Exception; typedef struct _Unwind_Exception _Unwind_Exception;
...@@ -79,7 +84,7 @@ _Unwind_Reason_Code ...@@ -79,7 +84,7 @@ _Unwind_Reason_Code
__gnat_Unwind_RaiseException (_Unwind_Exception *); __gnat_Unwind_RaiseException (_Unwind_Exception *);
_Unwind_Reason_Code _Unwind_Reason_Code
__gnat_Unwind_ForcedUnwind (_Unwind_Exception *, void *, void *); __gnat_Unwind_ForcedUnwind (_Unwind_Exception *, _Unwind_Stop_Fn, void *);
extern struct Exception_Occurrence *__gnat_setup_current_excep extern struct Exception_Occurrence *__gnat_setup_current_excep
(_Unwind_Exception *); (_Unwind_Exception *);
...@@ -209,7 +214,7 @@ db_indent (int requests) ...@@ -209,7 +214,7 @@ db_indent (int requests)
} }
static void ATTRIBUTE_PRINTF_2 static void ATTRIBUTE_PRINTF_2
db (int db_code, char * msg_format, ...) db (int db_code, const char * msg_format, ...)
{ {
if (db_accepted_codes () & db_code) if (db_accepted_codes () & db_code)
{ {
...@@ -816,8 +821,8 @@ get_call_site_action_for (_Unwind_Ptr ip, ...@@ -816,8 +821,8 @@ get_call_site_action_for (_Unwind_Ptr ip,
db (DB_CSITE, db (DB_CSITE,
"c_site @ %p (+%p), len = %p, lpad @ %p (+%p)\n", "c_site @ %p (+%p), len = %p, lpad @ %p (+%p)\n",
(void *)region->base + cs_start, (void *)cs_start, (void *)cs_len, (char *)region->base + cs_start, (void *)cs_start, (void *)cs_len,
(void *)region->lp_base + cs_lp, (void *)cs_lp); (char *)region->lp_base + cs_lp, (void *)cs_lp);
/* The table is sorted, so if we've passed the IP, stop. */ /* The table is sorted, so if we've passed the IP, stop. */
if (ip < region->base + cs_start) if (ip < region->base + cs_start)
...@@ -1399,7 +1404,7 @@ __gnat_Unwind_RaiseException (_Unwind_Exception *e) ...@@ -1399,7 +1404,7 @@ __gnat_Unwind_RaiseException (_Unwind_Exception *e)
_Unwind_Reason_Code _Unwind_Reason_Code
__gnat_Unwind_ForcedUnwind (_Unwind_Exception *e ATTRIBUTE_UNUSED, __gnat_Unwind_ForcedUnwind (_Unwind_Exception *e ATTRIBUTE_UNUSED,
void *handler ATTRIBUTE_UNUSED, _Unwind_Stop_Fn handler ATTRIBUTE_UNUSED,
void *argument ATTRIBUTE_UNUSED) void *argument ATTRIBUTE_UNUSED)
{ {
#ifdef __USING_SJLJ_EXCEPTIONS__ #ifdef __USING_SJLJ_EXCEPTIONS__
...@@ -1609,3 +1614,7 @@ __gnat_personality_seh0 (PEXCEPTION_RECORD ms_exc, void *this_frame, ...@@ -1609,3 +1614,7 @@ __gnat_personality_seh0 (PEXCEPTION_RECORD ms_exc, void *this_frame,
const int __gnat_unwind_exception_size = sizeof (_Unwind_Exception); const int __gnat_unwind_exception_size = sizeof (_Unwind_Exception);
#endif #endif
#ifdef __cplusplus
}
#endif
gcc/ada/raise.c
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
* * * *
* C Implementation File * * C Implementation File *
* * * *
* Copyright (C) 1992-2012, Free Software Foundation, Inc. * * Copyright (C) 1992-2017, Free Software Foundation, Inc. *
* * * *
* GNAT is free software; you can redistribute it and/or modify it under * * GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- * * terms of the GNU General Public License as published by the Free Soft- *
...@@ -47,20 +47,6 @@ ...@@ -47,20 +47,6 @@
extern "C" { extern "C" {
#endif #endif
/* Wrapper to builtin_longjmp. This is for the compiler eh only, as the sjlj
runtime library interfaces directly to the intrinsic. We can't yet do
this for the compiler itself, because this capability relies on changes
made in April 2008 and we need to preserve the possibility to bootstrap
with an older base version. */
#if defined (IN_GCC) && !defined (IN_RTS)
void
_gnat_builtin_longjmp (void *ptr, int flag ATTRIBUTE_UNUSED)
{
__builtin_longjmp (ptr, 1);
}
#endif
/* When an exception is raised for which no handler exists, the procedure /* When an exception is raised for which no handler exists, the procedure
Ada.Exceptions.Unhandled_Exception is called, which performs the call to Ada.Exceptions.Unhandled_Exception is called, which performs the call to
adafinal to complete finalization, and then prints out the error messages adafinal to complete finalization, and then prints out the error messages
...@@ -84,6 +70,71 @@ __gnat_unhandled_terminate (void) ...@@ -84,6 +70,71 @@ __gnat_unhandled_terminate (void)
__gnat_os_exit (1); __gnat_os_exit (1);
} }
#ifndef IN_RTS
int
__gnat_backtrace (void **array ATTRIBUTE_UNUSED,
int size ATTRIBUTE_UNUSED,
void *exclude_min ATTRIBUTE_UNUSED,
void *exclude_max ATTRIBUTE_UNUSED,
int skip_frames ATTRIBUTE_UNUSED)
{
return 0;
}
void
__gnat_eh_personality (void)
{
abort ();
}
void
__gnat_rcheck_04 (void)
{
abort ();
}
void
__gnat_rcheck_10 (void)
{
abort ();
}
void
__gnat_rcheck_19 (void)
{
abort ();
}
void
__gnat_rcheck_20 (void)
{
abort ();
}
void
__gnat_rcheck_21 (void)
{
abort ();
}
void
__gnat_rcheck_30 (void)
{
abort ();
}
void
__gnat_rcheck_31 (void)
{
abort ();
}
void
__gnat_rcheck_32 (void)
{
abort ();
}
#endif
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif
gcc/ada/sem_ch3.adb
...@@ -4195,6 +4195,14 @@ package body Sem_Ch3 is ...@@ -4195,6 +4195,14 @@ package body Sem_Ch3 is
if No (E) and then Is_Null_Record_Type (T) then if No (E) and then Is_Null_Record_Type (T) then
null; null;
-- Do not generate a predicate check if the initialization expression
-- is a type conversion because the conversion has been subjected to
-- the same check. This is a small optimization which avoid redundant
-- checks.
elsif Present (E) and then Nkind (E) = N_Type_Conversion then
null;
else else
Insert_After (N, Insert_After (N,
Make_Predicate_Check (T, New_Occurrence_Of (Id, Loc))); Make_Predicate_Check (T, New_Occurrence_Of (Id, Loc)));
......
gcc/ada/sem_elab.adb
...@@ -688,7 +688,7 @@ package body Sem_Elab is ...@@ -688,7 +688,7 @@ package body Sem_Elab is
-- see whether an elaboration check is required. -- see whether an elaboration check is required.
Is_DIC : Boolean; Is_DIC : Boolean;
-- Flag set when the subprogram being invoked the procedure generated -- Flag set when the subprogram being invoked is the procedure generated
-- for pragma Default_Initial_Condition. -- for pragma Default_Initial_Condition.
SPARK_Elab_Errors : Boolean; SPARK_Elab_Errors : Boolean;
......
gcc/ada/sem_res.adb
...@@ -11065,22 +11065,11 @@ package body Sem_Res is ...@@ -11065,22 +11065,11 @@ package body Sem_Res is
end; end;
end if; end if;
-- Ada 2012: if target type has predicates, the result requires a -- Ada 2012: once the type conversion is resolved, check whether the
-- predicate check. If the context is a call to another predicate -- operand statisfies the static predicate of the target type.
-- check we must prevent infinite recursion.
if Has_Predicates (Target_Typ) then if Has_Predicates (Target_Typ) then
if Nkind (Parent (N)) = N_Function_Call Check_Expression_Against_Static_Predicate (N, Target_Typ);
and then Present (Name (Parent (N)))
and then (Is_Predicate_Function (Entity (Name (Parent (N))))
or else
Is_Predicate_Function_M (Entity (Name (Parent (N)))))
then
null;
else
Apply_Predicate_Check (N, Target_Typ);
end if;
end if; end if;
-- If at this stage we have a real to integer conversion, make sure that -- If at this stage we have a real to integer conversion, make sure that
......
gcc/ada/system.ads
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- S p e c -- -- S p e c --
-- (Compiler Version) -- -- (Compiler Version) --
-- -- -- --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- -- -- --
-- This specification is derived from the Ada Reference Manual for use with -- -- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow -- -- GNAT. The copyright notice above, and the license provisions that follow --
...@@ -163,8 +163,8 @@ private ...@@ -163,8 +163,8 @@ private
Always_Compatible_Rep : constant Boolean := True; Always_Compatible_Rep : constant Boolean := True;
Suppress_Standard_Library : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False;
Frontend_Exceptions : constant Boolean := True; Frontend_Exceptions : constant Boolean := False;
ZCX_By_Default : constant Boolean := False; ZCX_By_Default : constant Boolean := True;
-- Obsolete entries, to be removed eventually (bootstrap issues) -- Obsolete entries, to be removed eventually (bootstrap issues)
...@@ -173,6 +173,6 @@ private ...@@ -173,6 +173,6 @@ private
Long_Shifts_Inlined : constant Boolean := True; Long_Shifts_Inlined : constant Boolean := True;
Functions_Return_By_DSP : constant Boolean := False; Functions_Return_By_DSP : constant Boolean := False;
Support_64_Bit_Divides : constant Boolean := True; Support_64_Bit_Divides : constant Boolean := True;
GCC_ZCX_Support : constant Boolean := False; GCC_ZCX_Support : constant Boolean := True;
end System; end System;
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