mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-22 22:51:32 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2010-10-22  Robert Dewar  <dewar@adacore.com>

	* par-ch5.adb: Minor reformatting.
	* gcc-interface/Make-lang.in: Update dependencies.

2010-10-22  Robert Dewar  <dewar@adacore.com>

	* a-except.adb, a-except-2005.adb: Add new Rcheck entry.
	* exp_ch13.adb (Add_Call): Make sure subtype is marked with
	Has_Predicates set to True if it inherits predicates.
	* sem_attr.adb: Handle 'First/'Last/'Range for predicated types
	* types.ads (PE_Bad_Attribute_For_Predicate): New reason code
	* types.h: Add new Rcheck entry.
	* einfo.ads, einfo.adb (Static_Predicate): New field.
	Minor code reorganization (file float routines in proper section)
	Fix bad field name in comments.

2010-10-22  Robert Dewar  <dewar@adacore.com>

	* sem_eval.adb (Subtypes_Statically_Compatible): Check null exclusion
	case.

2010-10-22  Vincent Celier  <celier@adacore.com>

	* prj-conf.adb (Get_Config_Switches): Detect if there is at least one
	declaration of IDE'Compiler_Command for one of the language in the main
	project.
	(Do_Autoconf): If there were at least one Compiler_Command declared and
	no target, invoke gprconfig with --target=all instead of the normalized
	host name.

2010-10-22  Robert Dewar  <dewar@adacore.com>

	* par-ch4.adb: Update syntax in comments for Ada 2012.
	* sinfo.ads: Update syntax in comments for Ada 2012
	* par-ch3.adb (Check_Restricted_Expression): Remove "in Ada 2012 mode"
	from msg.

From-SVN: r165822
This commit is contained in:
Arnaud Charlet 2010-10-22 12:41:17 +02:00
parent 0937fb69fe
commit 26df19ce4f
16 changed files with 956 additions and 759 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
gcc/ada/ChangeLog
View File

@ -1,3 +1,41 @@
2010-10-22 Robert Dewar <dewar@adacore.com>
* par-ch5.adb: Minor reformatting.
* gcc-interface/Make-lang.in: Update dependencies.
2010-10-22 Robert Dewar <dewar@adacore.com>
* a-except.adb, a-except-2005.adb: Add new Rcheck entry.
* exp_ch13.adb (Add_Call): Make sure subtype is marked with
Has_Predicates set to True if it inherits predicates.
* sem_attr.adb: Handle 'First/'Last/'Range for predicated types
* types.ads (PE_Bad_Attribute_For_Predicate): New reason code
* types.h: Add new Rcheck entry.
* einfo.ads, einfo.adb (Static_Predicate): New field.
Minor code reorganization (file float routines in proper section)
Fix bad field name in comments.
2010-10-22 Robert Dewar <dewar@adacore.com>
* sem_eval.adb (Subtypes_Statically_Compatible): Check null exclusion
case.
2010-10-22 Vincent Celier <celier@adacore.com>
* prj-conf.adb (Get_Config_Switches): Detect if there is at least one
declaration of IDE'Compiler_Command for one of the language in the main
project.
(Do_Autoconf): If there were at least one Compiler_Command declared and
no target, invoke gprconfig with --target=all instead of the normalized
host name.
2010-10-22 Robert Dewar <dewar@adacore.com>
* par-ch4.adb: Update syntax in comments for Ada 2012.
* sinfo.ads: Update syntax in comments for Ada 2012
* par-ch3.adb (Check_Restricted_Expression): Remove "in Ada 2012 mode"
from msg.
2010-10-22 Gary Dismukes <dismukes@adacore.com>
* sem_ch3.adb (Check_Or_Process_Discriminants): In Ada 2012, allow

44
gcc/ada/a-except-2005.adb
View File

@ -464,6 +464,7 @@ package body Ada.Exceptions is
procedure Rcheck_31 (File : System.Address; Line : Integer);
procedure Rcheck_32 (File : System.Address; Line : Integer);
procedure Rcheck_33 (File : System.Address; Line : Integer);
procedure Rcheck_34 (File : System.Address; Line : Integer);
procedure Rcheck_00_Ext
(File : System.Address; Line, Column : Integer);
@ -508,6 +509,7 @@ package body Ada.Exceptions is
pragma Export (C, Rcheck_31, "__gnat_rcheck_31");
pragma Export (C, Rcheck_32, "__gnat_rcheck_32");
pragma Export (C, Rcheck_33, "__gnat_rcheck_33");
pragma Export (C, Rcheck_34, "__gnat_rcheck_34");
pragma Export (C, Rcheck_00_Ext, "__gnat_rcheck_00_ext");
pragma Export (C, Rcheck_05_Ext, "__gnat_rcheck_05_ext");
@ -551,6 +553,7 @@ package body Ada.Exceptions is
pragma No_Return (Rcheck_30);
pragma No_Return (Rcheck_32);
pragma No_Return (Rcheck_33);
pragma No_Return (Rcheck_34);
pragma No_Return (Rcheck_00_Ext);
pragma No_Return (Rcheck_05_Ext);
@ -585,24 +588,26 @@ package body Ada.Exceptions is
Rmsg_16 : constant String := "attempt to take address of" &
" intrinsic subprogram" & NUL;
Rmsg_17 : constant String := "all guards closed" & NUL;
Rmsg_18 : constant String := "Current_Task referenced in entry" &
Rmsg_18 : constant String := "attribute not allowed for " &
" generic subtype with predicate" & NUL;
Rmsg_19 : constant String := "Current_Task referenced in entry" &
" body" & NUL;
Rmsg_19 : constant String := "duplicated entry address" & NUL;
Rmsg_20 : constant String := "explicit raise" & NUL;
Rmsg_21 : constant String := "finalize/adjust raised exception" & NUL;
Rmsg_22 : constant String := "implicit return with No_Return" & NUL;
Rmsg_23 : constant String := "misaligned address value" & NUL;
Rmsg_24 : constant String := "missing return" & NUL;
Rmsg_25 : constant String := "overlaid controlled object" & NUL;
Rmsg_26 : constant String := "potentially blocking operation" & NUL;
Rmsg_27 : constant String := "stubbed subprogram called" & NUL;
Rmsg_28 : constant String := "unchecked union restriction" & NUL;
Rmsg_29 : constant String := "actual/returned class-wide" &
Rmsg_20 : constant String := "duplicated entry address" & NUL;
Rmsg_21 : constant String := "explicit raise" & NUL;
Rmsg_22 : constant String := "finalize/adjust raised exception" & NUL;
Rmsg_23 : constant String := "implicit return with No_Return" & NUL;
Rmsg_24 : constant String := "misaligned address value" & NUL;
Rmsg_25 : constant String := "missing return" & NUL;
Rmsg_26 : constant String := "overlaid controlled object" & NUL;
Rmsg_27 : constant String := "potentially blocking operation" & NUL;
Rmsg_28 : constant String := "stubbed subprogram called" & NUL;
Rmsg_29 : constant String := "unchecked union restriction" & NUL;
Rmsg_30 : constant String := "actual/returned class-wide" &
" value not transportable" & NUL;
Rmsg_30 : constant String := "empty storage pool" & NUL;
Rmsg_31 : constant String := "explicit raise" & NUL;
Rmsg_32 : constant String := "infinite recursion" & NUL;
Rmsg_33 : constant String := "object too large" & NUL;
Rmsg_31 : constant String := "empty storage pool" & NUL;
Rmsg_32 : constant String := "explicit raise" & NUL;
Rmsg_33 : constant String := "infinite recursion" & NUL;
Rmsg_34 : constant String := "object too large" & NUL;
-----------------------
-- Polling Interface --
@ -1206,7 +1211,7 @@ package body Ada.Exceptions is
procedure Rcheck_30 (File : System.Address; Line : Integer) is
begin
Raise_Storage_Error_Msg (File, Line, Rmsg_30'Address);
Raise_Program_Error_Msg (File, Line, Rmsg_30'Address);
end Rcheck_30;
procedure Rcheck_31 (File : System.Address; Line : Integer) is
@ -1224,6 +1229,11 @@ package body Ada.Exceptions is
Raise_Storage_Error_Msg (File, Line, Rmsg_33'Address);
end Rcheck_33;
procedure Rcheck_34 (File : System.Address; Line : Integer) is
begin
Raise_Storage_Error_Msg (File, Line, Rmsg_34'Address);
end Rcheck_34;
procedure Rcheck_00_Ext (File : System.Address; Line, Column : Integer) is
begin
Raise_Constraint_Error_Msg (File, Line, Column, Rmsg_00'Address);

44
gcc/ada/a-except.adb
View File

@ -415,6 +415,7 @@ package body Ada.Exceptions is
procedure Rcheck_31 (File : System.Address; Line : Integer);
procedure Rcheck_32 (File : System.Address; Line : Integer);
procedure Rcheck_33 (File : System.Address; Line : Integer);
procedure Rcheck_34 (File : System.Address; Line : Integer);
pragma Export (C, Rcheck_00, "__gnat_rcheck_00");
pragma Export (C, Rcheck_01, "__gnat_rcheck_01");
@ -450,6 +451,7 @@ package body Ada.Exceptions is
pragma Export (C, Rcheck_31, "__gnat_rcheck_31");
pragma Export (C, Rcheck_32, "__gnat_rcheck_32");
pragma Export (C, Rcheck_33, "__gnat_rcheck_33");
pragma Export (C, Rcheck_34, "__gnat_rcheck_34");
-- None of these procedures ever returns (they raise an exception!). By
-- using pragma No_Return, we ensure that any junk code after the call,
@ -488,6 +490,7 @@ package body Ada.Exceptions is
pragma No_Return (Rcheck_30);
pragma No_Return (Rcheck_32);
pragma No_Return (Rcheck_33);
pragma No_Return (Rcheck_34);
---------------------------------------------
-- Reason Strings for Run-Time Check Calls --
@ -517,24 +520,26 @@ package body Ada.Exceptions is
Rmsg_16 : constant String := "attempt to take address of" &
" intrinsic subprogram" & NUL;
Rmsg_17 : constant String := "all guards closed" & NUL;
Rmsg_18 : constant String := "Current_Task referenced in entry" &
Rmsg_18 : constant String := "attribute not allowed for " &
" generic subtype with predicate" & NUL;
Rmsg_19 : constant String := "Current_Task referenced in entry" &
" body" & NUL;
Rmsg_19 : constant String := "duplicated entry address" & NUL;
Rmsg_20 : constant String := "explicit raise" & NUL;
Rmsg_21 : constant String := "finalize/adjust raised exception" & NUL;
Rmsg_22 : constant String := "implicit return with No_Return" & NUL;
Rmsg_23 : constant String := "misaligned address value" & NUL;
Rmsg_24 : constant String := "missing return" & NUL;
Rmsg_25 : constant String := "overlaid controlled object" & NUL;
Rmsg_26 : constant String := "potentially blocking operation" & NUL;
Rmsg_27 : constant String := "stubbed subprogram called" & NUL;
Rmsg_28 : constant String := "unchecked union restriction" & NUL;
Rmsg_29 : constant String := "actual/returned class-wide" &
Rmsg_20 : constant String := "duplicated entry address" & NUL;
Rmsg_21 : constant String := "explicit raise" & NUL;
Rmsg_22 : constant String := "finalize/adjust raised exception" & NUL;
Rmsg_23 : constant String := "implicit return with No_Return" & NUL;
Rmsg_24 : constant String := "misaligned address value" & NUL;
Rmsg_25 : constant String := "missing return" & NUL;
Rmsg_26 : constant String := "overlaid controlled object" & NUL;
Rmsg_27 : constant String := "potentially blocking operation" & NUL;
Rmsg_28 : constant String := "stubbed subprogram called" & NUL;
Rmsg_29 : constant String := "unchecked union restriction" & NUL;
Rmsg_30 : constant String := "actual/returned class-wide" &
" value not transportable" & NUL;
Rmsg_30 : constant String := "empty storage pool" & NUL;
Rmsg_31 : constant String := "explicit raise" & NUL;
Rmsg_32 : constant String := "infinite recursion" & NUL;
Rmsg_33 : constant String := "object too large" & NUL;
Rmsg_31 : constant String := "empty storage pool" & NUL;
Rmsg_32 : constant String := "explicit raise" & NUL;
Rmsg_33 : constant String := "infinite recursion" & NUL;
Rmsg_34 : constant String := "object too large" & NUL;
-----------------------
-- Polling Interface --
@ -1137,7 +1142,7 @@ package body Ada.Exceptions is
procedure Rcheck_30 (File : System.Address; Line : Integer) is
begin
Raise_Storage_Error_Msg (File, Line, Rmsg_30'Address);
Raise_Program_Error_Msg (File, Line, Rmsg_30'Address);
end Rcheck_30;
procedure Rcheck_31 (File : System.Address; Line : Integer) is
@ -1155,6 +1160,11 @@ package body Ada.Exceptions is
Raise_Storage_Error_Msg (File, Line, Rmsg_33'Address);
end Rcheck_33;
procedure Rcheck_34 (File : System.Address; Line : Integer) is
begin
Raise_Storage_Error_Msg (File, Line, Rmsg_34'Address);
end Rcheck_34;
-------------
-- Reraise --
-------------

330
gcc/ada/einfo.adb
View File

@ -215,6 +215,7 @@ package body Einfo is
-- Debug_Renaming_Link Node25
-- DT_Offset_To_Top_Func Node25
-- PPC_Wrapper Node25
-- Static_Predicate Node25
-- Task_Body_Procedure Node25
-- Dispatch_Table_Wrappers Elist26
@ -2196,84 +2197,12 @@ package body Einfo is
return Flag205 (Id);
end Low_Bound_Tested;
function Machine_Emax_Value (Id : E) return Uint is
Digs : constant Pos := UI_To_Int (Digits_Value (Base_Type (Id)));
begin
case Float_Rep (Id) is
when IEEE_Binary =>
case Digs is
when 1 .. 6 => return Uint_128;
when 7 .. 15 => return 2**10;
when 16 .. 18 => return 2**14;
when others => return No_Uint;
end case;
when VAX_Native =>
case Digs is
when 1 .. 9 => return 2**7 - 1;
when 10 .. 15 => return 2**10 - 1;
when others => return No_Uint;
end case;
when AAMP =>
return Uint_2 ** Uint_7 - Uint_1;
end case;
end Machine_Emax_Value;
function Machine_Emin_Value (Id : E) return Uint is
begin
case Float_Rep (Id) is
when IEEE_Binary => return Uint_3 - Machine_Emax_Value (Id);
when VAX_Native => return -Machine_Emax_Value (Id);
when AAMP => return -Machine_Emax_Value (Id);
end case;
end Machine_Emin_Value;
function Machine_Mantissa_Value (Id : E) return Uint is
Digs : constant Pos := UI_To_Int (Digits_Value (Base_Type (Id)));
begin
case Float_Rep (Id) is
when IEEE_Binary =>
case Digs is
when 1 .. 6 => return Uint_24;
when 7 .. 15 => return UI_From_Int (53);
when 16 .. 18 => return Uint_64;
when others => return No_Uint;
end case;
when VAX_Native =>
case Digs is
when 1 .. 6 => return Uint_24;
when 7 .. 9 => return UI_From_Int (56);
when 10 .. 15 => return UI_From_Int (53);
when others => return No_Uint;
end case;
when AAMP =>
case Digs is
when 1 .. 6 => return Uint_24;
when 7 .. 9 => return UI_From_Int (40);
when others => return No_Uint;
end case;
end case;
end Machine_Mantissa_Value;
function Machine_Radix_10 (Id : E) return B is
begin
pragma Assert (Is_Decimal_Fixed_Point_Type (Id));
return Flag84 (Id);
end Machine_Radix_10;
function Machine_Radix_Value (Id : E) return U is
begin
case Float_Rep (Id) is
when IEEE_Binary | VAX_Native | AAMP =>
return Uint_2;
end case;
end Machine_Radix_Value;
function Master_Id (Id : E) return E is
begin
pragma Assert (Is_Access_Type (Id));
@ -2291,28 +2220,6 @@ package body Einfo is
return UI_To_Int (Uint8 (Id));
end Mechanism;
function Model_Emin_Value (Id : E) return Uint is
begin
return Machine_Emin_Value (Id);
end Model_Emin_Value;
function Model_Epsilon_Value (Id : E) return Ureal is
Radix : constant Ureal := UR_From_Uint (Machine_Radix_Value (Id));
begin
return Radix ** (1 - Model_Mantissa_Value (Id));
end Model_Epsilon_Value;
function Model_Mantissa_Value (Id : E) return Uint is
begin
return Machine_Mantissa_Value (Id);
end Model_Mantissa_Value;
function Model_Small_Value (Id : E) return Ureal is
Radix : constant Ureal := UR_From_Uint (Machine_Radix_Value (Id));
begin
return Radix ** (Model_Emin_Value (Id) - 1);
end Model_Small_Value;
function Modulus (Id : E) return Uint is
begin
pragma Assert (Is_Modular_Integer_Type (Id));
@ -2645,38 +2552,6 @@ package body Einfo is
return Uint13 (Id);
end RM_Size;
function Safe_Emax_Value (Id : E) return Uint is
begin
return Machine_Emax_Value (Id);
end Safe_Emax_Value;
function Safe_First_Value (Id : E) return Ureal is
begin
return -Safe_Last_Value (Id);
end Safe_First_Value;
function Safe_Last_Value (Id : E) return Ureal is
Radix : constant Uint := Machine_Radix_Value (Id);
Mantissa : constant Uint := Machine_Mantissa_Value (Id);
Emax : constant Uint := Safe_Emax_Value (Id);
Significand : constant Uint := Radix ** Mantissa - 1;
Exponent : constant Uint := Emax - Mantissa;
begin
if Radix = 2 then
return
UR_From_Components
(Num => Significand * 2 ** (Exponent mod 4),
Den => -Exponent / 4,
Rbase => 16);
else
return
UR_From_Components
(Num => Significand,
Den => -Exponent,
Rbase => 16);
end if;
end Safe_Last_Value;
function Scalar_Range (Id : E) return N is
begin
return Node20 (Id);
@ -2746,6 +2621,12 @@ package body Einfo is
return Node24 (Id);
end Spec_PPC_List;
function Static_Predicate (Id : E) return N is
begin
pragma Assert (Is_Discrete_Type (Id));
return Node25 (Id);
end Static_Predicate;
function Storage_Size_Variable (Id : E) return E is
begin
pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id));
@ -2856,11 +2737,6 @@ package body Einfo is
return Flag95 (Id);
end Uses_Sec_Stack;
function Vax_Float (Id : E) return B is
begin
return Is_Floating_Point_Type (Id) and then Float_Rep (Id) = VAX_Native;
end Vax_Float;
function Warnings_Off (Id : E) return B is
begin
return Flag96 (Id);
@ -5251,6 +5127,16 @@ package body Einfo is
Set_Node24 (Id, V);
end Set_Spec_PPC_List;
procedure Set_Static_Predicate (Id : E; V : N) is
begin
pragma Assert
(Ekind_In (Id, E_Enumeration_Subtype,
E_Modular_Integer_Subtype,
E_Signed_Integer_Subtype)
and then Has_Predicates (Id));
Set_Node25 (Id, V);
end Set_Static_Predicate;
procedure Set_Storage_Size_Variable (Id : E; V : E) is
begin
pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id));
@ -6596,6 +6482,128 @@ package body Einfo is
end if;
end Last_Formal;
function Model_Emin_Value (Id : E) return Uint is
begin
return Machine_Emin_Value (Id);
end Model_Emin_Value;
-------------------------
-- Model_Epsilon_Value --
-------------------------
function Model_Epsilon_Value (Id : E) return Ureal is
Radix : constant Ureal := UR_From_Uint (Machine_Radix_Value (Id));
begin
return Radix ** (1 - Model_Mantissa_Value (Id));
end Model_Epsilon_Value;
--------------------------
-- Model_Mantissa_Value --
--------------------------
function Model_Mantissa_Value (Id : E) return Uint is
begin
return Machine_Mantissa_Value (Id);
end Model_Mantissa_Value;
-----------------------
-- Model_Small_Value --
-----------------------
function Model_Small_Value (Id : E) return Ureal is
Radix : constant Ureal := UR_From_Uint (Machine_Radix_Value (Id));
begin
return Radix ** (Model_Emin_Value (Id) - 1);
end Model_Small_Value;
------------------------
-- Machine_Emax_Value --
------------------------
function Machine_Emax_Value (Id : E) return Uint is
Digs : constant Pos := UI_To_Int (Digits_Value (Base_Type (Id)));
begin
case Float_Rep (Id) is
when IEEE_Binary =>
case Digs is
when 1 .. 6 => return Uint_128;
when 7 .. 15 => return 2**10;
when 16 .. 18 => return 2**14;
when others => return No_Uint;
end case;
when VAX_Native =>
case Digs is
when 1 .. 9 => return 2**7 - 1;
when 10 .. 15 => return 2**10 - 1;
when others => return No_Uint;
end case;
when AAMP =>
return Uint_2 ** Uint_7 - Uint_1;
end case;
end Machine_Emax_Value;
------------------------
-- Machine_Emin_Value --
------------------------
function Machine_Emin_Value (Id : E) return Uint is
begin
case Float_Rep (Id) is
when IEEE_Binary => return Uint_3 - Machine_Emax_Value (Id);
when VAX_Native => return -Machine_Emax_Value (Id);
when AAMP => return -Machine_Emax_Value (Id);
end case;
end Machine_Emin_Value;
----------------------------
-- Machine_Mantissa_Value --
----------------------------
function Machine_Mantissa_Value (Id : E) return Uint is
Digs : constant Pos := UI_To_Int (Digits_Value (Base_Type (Id)));
begin
case Float_Rep (Id) is
when IEEE_Binary =>
case Digs is
when 1 .. 6 => return Uint_24;
when 7 .. 15 => return UI_From_Int (53);
when 16 .. 18 => return Uint_64;
when others => return No_Uint;
end case;
when VAX_Native =>
case Digs is
when 1 .. 6 => return Uint_24;
when 7 .. 9 => return UI_From_Int (56);
when 10 .. 15 => return UI_From_Int (53);
when others => return No_Uint;
end case;
when AAMP =>
case Digs is
when 1 .. 6 => return Uint_24;
when 7 .. 9 => return UI_From_Int (40);
when others => return No_Uint;
end case;
end case;
end Machine_Mantissa_Value;
-------------------------
-- Machine_Radix_Value --
-------------------------
function Machine_Radix_Value (Id : E) return U is
begin
case Float_Rep (Id) is
when IEEE_Binary | VAX_Native | AAMP =>
return Uint_2;
end case;
end Machine_Radix_Value;
--------------------
-- Next_Component --
--------------------
@ -6902,6 +6910,52 @@ package body Einfo is
end if;
end Root_Type;
---------------------
-- Safe_Emax_Value --
---------------------
function Safe_Emax_Value (Id : E) return Uint is
begin
return Machine_Emax_Value (Id);
end Safe_Emax_Value;
----------------------
-- Safe_First_Value --
----------------------
function Safe_First_Value (Id : E) return Ureal is
begin
return -Safe_Last_Value (Id);
end Safe_First_Value;
---------------------
-- Safe_Last_Value --
---------------------
function Safe_Last_Value (Id : E) return Ureal is
Radix : constant Uint := Machine_Radix_Value (Id);
Mantissa : constant Uint := Machine_Mantissa_Value (Id);
Emax : constant Uint := Safe_Emax_Value (Id);
Significand : constant Uint := Radix ** Mantissa - 1;
Exponent : constant Uint := Emax - Mantissa;
begin
if Radix = 2 then
return
UR_From_Components
(Num => Significand * 2 ** (Exponent mod 4),
Den => -Exponent / 4,
Rbase => 16);
else
return
UR_From_Components
(Num => Significand,
Den => -Exponent,
Rbase => 16);
end if;
end Safe_Last_Value;
-----------------
-- Scope_Depth --
-----------------
@ -7198,6 +7252,15 @@ package body Einfo is
end if;
end Underlying_Type;
---------------
-- Vax_Float --
---------------
function Vax_Float (Id : E) return B is
begin
return Is_Floating_Point_Type (Id) and then Float_Rep (Id) = VAX_Native;
end Vax_Float;
------------------------
-- Write_Entity_Flags --
------------------------
@ -8428,6 +8491,11 @@ package body Einfo is
E_Entry_Family =>
Write_Str ("PPC_Wrapper");
when E_Enumeration_Subtype |
E_Modular_Integer_Subtype |
E_Signed_Integer_Subtype =>
Write_Str ("Static_Predicate");
when others =>
Write_Str ("Field25??");
end case;

17
gcc/ada/einfo.ads
View File

@ -1264,7 +1264,7 @@ package Einfo is
-- Note in particular that size clauses are present only for this
-- purpose, and should only be accessed if Has_Size_Clause is set.
-- Float_Rep (Uint8)
-- Float_Rep (Uint10)
-- Present in floating-point entities. Contains a value of type
-- Float_Rep_Kind. Together with the Digits_Value uniquely defines
-- the floating-point representation to be used.
@ -3609,6 +3609,12 @@ package Einfo is
-- textual appearance. Note that this includes precondition/postcondition
-- pragmas generated to correspond to Pre/Post aspects.
-- Static_Predicate (Node25)
-- Present in discrete types/subtypes with predicates (Has_Predicates
-- set True). Set for a subtype that has a predicate that is considered
-- static. Points to the fully analyzed predicate expression, which is
-- always a membership test (possibly a set membership).
-- Storage_Size_Variable (Node15) [implementation base type only]
-- Present in access types and task type entities. This flag is set
-- if a valid and effective pragma Storage_Size applies to the base
@ -5067,6 +5073,7 @@ package Einfo is
-- First_Literal (Node17)
-- Scalar_Range (Node20)
-- Enum_Pos_To_Rep (Node23) (type only)
-- Static_Predicate (Node25)
-- Has_Biased_Representation (Flag139)
-- Has_Contiguous_Rep (Flag181)
-- Has_Enumeration_Rep_Clause (Flag66)
@ -5094,7 +5101,7 @@ package Einfo is
-- E_Floating_Point_Type
-- E_Floating_Point_Subtype
-- Digits_Value (Uint17)
-- Float_Rep (Uint8) (Float_Rep_Kind)
-- Float_Rep (Uint10) (Float_Rep_Kind)
-- Machine_Emax_Value (synth)
-- Machine_Emin_Value (synth)
-- Machine_Mantissa_Value (synth)
@ -5268,6 +5275,7 @@ package Einfo is
-- Modulus (Uint17) (base type only)
-- Original_Array_Type (Node21)
-- Scalar_Range (Node20)
-- Static_Predicate (Node25)
-- Non_Binary_Modulus (Flag58) (base type only)
-- Has_Biased_Representation (Flag139)
-- Type_Low_Bound (synth)
@ -5537,6 +5545,7 @@ package Einfo is
-- E_Signed_Integer_Type
-- E_Signed_Integer_Subtype
-- Scalar_Range (Node20)
-- Static_Predicate (Node25)
-- Has_Biased_Representation (Flag139)
-- Type_Low_Bound (synth)
-- Type_High_Bound (synth)
@ -6232,6 +6241,7 @@ package Einfo is
function Small_Value (Id : E) return R;
function Spec_Entity (Id : E) return E;
function Spec_PPC_List (Id : E) return N;
function Static_Predicate (Id : E) return N;
function Storage_Size_Variable (Id : E) return E;
function Static_Elaboration_Desired (Id : E) return B;
function Static_Initialization (Id : E) return N;
@ -6819,6 +6829,7 @@ package Einfo is
procedure Set_Small_Value (Id : E; V : R);
procedure Set_Spec_Entity (Id : E; V : E);
procedure Set_Spec_PPC_List (Id : E; V : N);
procedure Set_Static_Predicate (Id : E; V : N);
procedure Set_Storage_Size_Variable (Id : E; V : E);
procedure Set_Static_Elaboration_Desired (Id : E; V : B);
procedure Set_Static_Initialization (Id : E; V : N);
@ -7551,6 +7562,7 @@ package Einfo is
pragma Inline (Small_Value);
pragma Inline (Spec_Entity);
pragma Inline (Spec_PPC_List);
pragma Inline (Static_Predicate);
pragma Inline (Storage_Size_Variable);
pragma Inline (Static_Elaboration_Desired);
pragma Inline (Static_Initialization);
@ -7944,6 +7956,7 @@ package Einfo is
pragma Inline (Set_Small_Value);
pragma Inline (Set_Spec_Entity);
pragma Inline (Set_Spec_PPC_List);
pragma Inline (Set_Static_Predicate);
pragma Inline (Set_Storage_Size_Variable);
pragma Inline (Set_Static_Elaboration_Desired);
pragma Inline (Set_Static_Initialization);

1
gcc/ada/exp_ch13.adb
View File

@ -127,6 +127,7 @@ package body Exp_Ch13 is
begin
if Present (T) and then Present (Predicate_Function (T)) then
Set_Has_Predicates (Typ);
-- Build the call to the predicate function of T

959
gcc/ada/gcc-interface/Make-lang.in
View File

File diff suppressed because it is too large Load Diff

3
gcc/ada/par-ch3.adb
View File

@ -124,8 +124,7 @@ package body Ch3 is
elsif Nkind_In (N, N_In, N_Not_In)
and then Paren_Count (N) = 0
then
Error_Msg_N
("|this expression must be parenthesized in Ada 2012 mode!", N);
Error_Msg_N ("|this expression must be parenthesized!", N);
end if;
end Check_Restricted_Expression;

25
gcc/ada/par-ch4.adb
View File

@ -1577,10 +1577,15 @@ package body Ch4 is
-- 4.4 Expression --
---------------------
-- This procedure parses EXPRESSION or CHOICE_EXPRESSION
-- EXPRESSION ::=
-- RELATION {and RELATION} | RELATION {and then RELATION}
-- | RELATION {or RELATION} | RELATION {or else RELATION}
-- | RELATION {xor RELATION}
-- RELATION {LOGICAL_OPERATOR RELATION}
-- CHOICE_EXPRESSION ::=
-- CHOICE_RELATION {LOGICAL_OPERATOR CHOICE_RELATION}
-- LOGICAL_OPERATOR ::= and | and then | or | or else | xor
-- On return, Expr_Form indicates the categorization of the expression
-- EF_Range_Attr is not a possible value (if a range attribute is found,
@ -1766,9 +1771,19 @@ package body Ch4 is
-- 4.4 Relation --
-------------------
-- RELATION ::=
-- This procedure scans both relations and choice relations
-- CHOICE_RELATION ::=
-- SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION]
-- | SIMPLE_EXPRESSION [not] in MEMBERSHIP_CHOICE_LIST
-- RELATION ::=
-- SIMPLE_EXPRESSION [not] in MEMBERSHIP_CHOICE_LIST
-- MEMBERSHIP_CHOICE_LIST ::=
-- MEMBERSHIP_CHOICE {'|' MEMBERSHIP CHOICE}
-- MEMBERSHIP_CHOICE ::=
-- CHOICE_EXPRESSION | RANGE | SUBTYPE_MARK
-- On return, Expr_Form indicates the categorization of the expression

5
gcc/ada/par-ch5.adb
View File

@ -1702,8 +1702,8 @@ package body Ch5 is
ID_Node := P_Defining_Identifier (C_In);
-- If the next token is OF, it indicates an Ada 2012 iterator. If the
-- next token is a colon, this is also an Ada 2012 iterator, including a
-- subtype indication for the loop parameter. Otherwise we parse the
-- next token is a colon, this is also an Ada 2012 iterator, including
-- a subtype indication for the loop parameter. Otherwise we parse the
-- construct as a loop parameter specification. Note that the form
-- "for A in B" is ambiguous, and must be resolved semantically: if B
-- is a discrete subtype this is a loop specification, but if it is an
@ -1711,7 +1711,6 @@ package body Ch5 is
-- during analysis of the loop parameter specification.
if Token = Tok_Of or else Token = Tok_Colon then
if Ada_Version < Ada_2012 then
Error_Msg_SC ("iterator is an Ada2012 feature");
end if;

94
gcc/ada/prj-conf.adb
View File

@ -39,6 +39,7 @@ with Prj; use Prj;
with Snames; use Snames;
with Ada.Directories; use Ada.Directories;
with Ada.Exceptions; use Ada.Exceptions;
with GNAT.Case_Util; use GNAT.Case_Util;
with GNAT.HTable; use GNAT.HTable;
@ -66,6 +67,10 @@ package body Prj.Conf is
-- Stores the runtime names for the various languages. This is in general
-- set from a --RTS command line option.
-----------------------
-- Local_Subprograms --
-----------------------
procedure Add_Attributes
(Project_Tree : Project_Tree_Ref;
Conf_Decl : Declarations;
@ -76,10 +81,6 @@ package body Prj.Conf is
-- For string list values, prepend the value in the user declarations with
-- the value in the config declarations.
function Locate_Config_File (Name : String) return String_Access;
-- Search for Name in the config files directory. Return full path if
-- found, or null otherwise
function Check_Target
(Config_File : Prj.Project_Id;
Autoconf_Specified : Boolean;
@ -89,7 +90,16 @@ package body Prj.Conf is
-- Target should be set to the empty string when the user did not specify
-- a target. If the target in the configuration file is invalid, this
-- function will raise Invalid_Config with an appropriate message.
-- Autoconf_Specified should be set to True if the user has used --autoconf
-- Autoconf_Specified should be set to True if the user has used
-- autoconf.
function Locate_Config_File (Name : String) return String_Access;
-- Search for Name in the config files directory. Return full path if
-- found, or null otherwise.
procedure Raise_Invalid_Config (Msg : String);
pragma No_Return (Raise_Invalid_Config);
-- Raises exception Invalid_Config with given message
--------------------
-- Add_Attributes --
@ -542,13 +552,12 @@ package body Prj.Conf is
else
if Tgt_Name /= No_Name then
raise Invalid_Config
with "invalid target name """
& Get_Name_String (Tgt_Name) & """ in configuration";
Raise_Invalid_Config
("invalid target name """
& Get_Name_String (Tgt_Name) & """ in configuration");
else
raise Invalid_Config
with "no target specified in configuration file";
Raise_Invalid_Config
("no target specified in configuration file");
end if;
end if;
end if;
@ -576,13 +585,17 @@ package body Prj.Conf is
Flags : Processing_Flags;
On_Load_Config : Config_File_Hook := null)
is
At_Least_One_Compiler_Command : Boolean := False;
-- Set to True if at least one attribute Ide'Compiler_Command is
-- specified for one language of the system.
function Default_File_Name return String;
-- Return the name of the default config file that should be tested
procedure Do_Autoconf;
-- Generate a new config file through gprconfig.
-- In case of error, this raises the Invalid_Config exception with an
-- appropriate message
-- Generate a new config file through gprconfig. In case of error, this
-- raises the Invalid_Config exception with an appropriate message
function Get_Config_Switches return Argument_List_Access;
-- Return the --config switches to use for gprconfig
@ -617,6 +630,7 @@ package body Prj.Conf is
declare
T : constant String := Tmp.all;
begin
Free (Tmp);
@ -804,6 +818,8 @@ package body Prj.Conf is
new String'(Config_Command & ",," & Runtime_Name);
else
At_Least_One_Compiler_Command := True;
declare
Compiler_Command : constant String :=
Get_Name_String (Variable.Value);
@ -850,8 +866,8 @@ package body Prj.Conf is
Gprconfig_Path := Locate_Exec_On_Path (Gprconfig_Name);
if Gprconfig_Path = null then
raise Invalid_Config
with "could not locate gprconfig for auto-configuration";
Raise_Invalid_Config
("could not locate gprconfig for auto-configuration");
end if;
-- First, find the object directory of the user's project
@ -910,16 +926,16 @@ package body Prj.Conf is
exception
when others =>
raise Invalid_Config
with "could not create object directory " & Obj_Dir;
Raise_Invalid_Config
("could not create object directory " & Obj_Dir);
end;
end if;
if not Is_Directory (Obj_Dir) then
case Flags.Require_Obj_Dirs is
when Error =>
raise Invalid_Config
with "object directory " & Obj_Dir & " does not exist";
Raise_Invalid_Config
("object directory " & Obj_Dir & " does not exist");
when Warning =>
Prj.Err.Error_Msg
(Flags,
@ -975,7 +991,14 @@ package body Prj.Conf is
Arg_Last := 3;
else
if Target_Name = "" then
Args (4) := new String'("--target=" & Normalized_Hostname);
if At_Least_One_Compiler_Command then
Args (4) := new String'("--target=all");
else
Args (4) :=
new String'("--target=" & Normalized_Hostname);
end if;
else
Args (4) := new String'("--target=" & Target_Name);
end if;
@ -1024,8 +1047,8 @@ package body Prj.Conf is
Config_File_Path := Locate_Config_File (Args (3).all);
if Config_File_Path = null then
raise Invalid_Config
with "could not create " & Args (3).all;
Raise_Invalid_Config
("could not create " & Args (3).all);
end if;
for F in Args'Range loop
@ -1051,9 +1074,9 @@ package body Prj.Conf is
if (not Allow_Automatic_Generation) and then
Config_File_Name /= ""
then
raise Invalid_Config
with "could not locate main configuration project "
& Config_File_Name;
Raise_Invalid_Config
("could not locate main configuration project "
& Config_File_Name);
end if;
end if;
@ -1067,8 +1090,8 @@ package body Prj.Conf is
-- There is no gprconfig on VMS
raise Invalid_Config
with "could not locate any configuration project file";
Raise_Invalid_Config
("could not locate any configuration project file");
else
-- This might raise an Invalid_Config exception
@ -1119,9 +1142,9 @@ package body Prj.Conf is
if Config_Project_Node = Empty_Node
or else Config = No_Project
then
raise Invalid_Config
with "processing of configuration project """
& Config_File_Path.all & """ failed";
Raise_Invalid_Config
("processing of configuration project """
& Config_File_Path.all & """ failed");
end if;
-- Check that the target of the configuration file is the one the user
@ -1335,6 +1358,15 @@ package body Prj.Conf is
end if;
end Process_Project_And_Apply_Config;
--------------------------
-- Raise_Invalid_Config --
--------------------------
procedure Raise_Invalid_Config (Msg : String) is
begin
Raise_Exception (Invalid_Config'Identity, Msg);
end Raise_Invalid_Config;
----------------------
-- Runtime_Name_For --
----------------------

36
gcc/ada/sem_attr.adb
View File

@ -211,6 +211,12 @@ package body Sem_Attr is
-- Used for Access, Unchecked_Access, Unrestricted_Access attributes.
-- Internally, Id distinguishes which of the three cases is involved.
procedure Bad_Attribute_For_Predicate;
-- Output error message for use of a predicate (First, Last, Range) not
-- allowed with a type that has predicates. If the type is a generic
-- actual, then the message is a warning, and we generate code to raise
-- program error with an appropriate reason.
procedure Check_Array_Or_Scalar_Type;
-- Common procedure used by First, Last, Range attribute to check
-- that the prefix is a constrained array or scalar type, or a name
@ -826,6 +832,32 @@ package body Sem_Attr is
end if;
end Analyze_Access_Attribute;
---------------------------------
-- Bad_Attribute_For_Predicate --
---------------------------------
procedure Bad_Attribute_For_Predicate is
begin
if Has_Predicates (P_Type) then
Error_Msg_Name_1 := Aname;
if Is_Generic_Actual_Type (P_Type) then
Error_Msg_F
("type& has predicates, attribute % not allowed?", P);
Error_Msg_F
("\?Program_Error will be raised at run time", P);
Rewrite (N,
Make_Raise_Program_Error (Loc,
Reason => PE_Bad_Attribute_For_Predicate));
else
Error_Msg_F
("type& has predicates, attribute % not allowed", P);
Error_Attr;
end if;
end if;
end Bad_Attribute_For_Predicate;
--------------------------------
-- Check_Array_Or_Scalar_Type --
--------------------------------
@ -3078,6 +3110,7 @@ package body Sem_Attr is
when Attribute_First =>
Check_Array_Or_Scalar_Type;
Bad_Attribute_For_Predicate;
---------------
-- First_Bit --
@ -3292,6 +3325,7 @@ package body Sem_Attr is
when Attribute_Last =>
Check_Array_Or_Scalar_Type;
Bad_Attribute_For_Predicate;
--------------
-- Last_Bit --
@ -3645,6 +3679,7 @@ package body Sem_Attr is
---------
when Attribute_Old =>
-- The attribute reference is a primary. If expressions follow, the
-- attribute reference is an indexable object, so rewrite the node
-- accordingly.
@ -3895,6 +3930,7 @@ package body Sem_Attr is
when Attribute_Range =>
Check_Array_Or_Scalar_Type;
Bad_Attribute_For_Predicate;
if Ada_Version = Ada_83
and then Is_Scalar_Type (P_Type)

19
gcc/ada/sem_eval.adb
View File

@ -4581,9 +4581,9 @@ package body Sem_Eval is
then
return True;
-- Base types must match, but we don't check that (should
-- we???) but we do at least check that both types are
-- real, or both types are not real.
-- Base types must match, but we don't check that (should we???) but
-- we do at least check that both types are real, or both types are
-- not real.
elsif Is_Real_Type (T1) /= Is_Real_Type (T2) then
return False;
@ -4620,14 +4620,11 @@ package body Sem_Eval is
-- Access types
elsif Is_Access_Type (T1) then
return not Is_Constrained (T2)
or else Subtypes_Statically_Match
(Designated_Type (T1), Designated_Type (T2));
-- Also check that null exclusion matches (AI05-0086-1)
-- commented out because this causes many mail test failures ???
-- and then Can_Never_Be_Null (T1) = Can_Never_Be_Null (T2);
return (not Is_Constrained (T2)
or else (Subtypes_Statically_Match
(Designated_Type (T1), Designated_Type (T2))))
and then not (Can_Never_Be_Null (T2)
and then not Can_Never_Be_Null (T1));
-- All other cases

30
gcc/ada/sinfo.ads
View File

@ -3508,14 +3508,24 @@ package Sinfo is
--------------------------------------------------
-- EXPRESSION ::=
-- RELATION {and RELATION} | RELATION {and then RELATION}
-- | RELATION {or RELATION} | RELATION {or else RELATION}
-- | RELATION {xor RELATION}
-- RELATION {LOGICAL_OPERATOR RELATION}
-- CHOICE_EXPRESSION ::=
-- CHOICE_RELATION {LOGICAL_OPERATOR CHOICE_RELATION}
-- CHOICE_RELATION ::=
-- SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION]
-- RELATION ::=
-- SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION]
-- | SIMPLE_EXPRESSION [not] in RANGE
-- | SIMPLE_EXPRESSION [not] in SUBTYPE_MARK
-- SIMPLE_EXPRESSION [not] in MEMBERSHIP_CHOICE_LIST
-- MEMBERSHIP_CHOICE_LIST ::=
-- MEMBERSHIP_CHOICE {'|' MEMBERSHIP CHOICE}
-- MEMBERSHIP_CHOICE ::=
-- CHOICE_EXPRESSION | RANGE | SUBTYPE_MARK
-- LOGICAL_OPERATOR ::= and | and then | or | or else | xor
-- SIMPLE_EXPRESSION ::=
-- [UNARY_ADDING_OPERATOR] TERM {BINARY_ADDING_OPERATOR TERM}
@ -3530,6 +3540,14 @@ package Sinfo is
-- constituent components of an expression (e.g. identifier is
-- an example of an expression).
-- Note: the above syntax is that Ada 2012 syntax which restricts
-- choice relations to simple expressions to avoid ambiguities in
-- some contexts with set membership notation. It has been decided
-- that in retrospect, the Ada 95 change allowing general expressions
-- in this context was a mistake, so we have reverted to the above
-- syntax in Ada 95 and Ada 2005 modes (the restriction to simple
-- expressions was there in Ada 83 from the start).
------------------
-- 4.4 Primary --
------------------

33
gcc/ada/types.ads
View File

@ -789,23 +789,24 @@ package Types is
PE_Accessibility_Check_Failed, -- 15
PE_Address_Of_Intrinsic, -- 16
PE_All_Guards_Closed, -- 17
PE_Current_Task_In_Entry_Body, -- 18
PE_Duplicated_Entry_Address, -- 19
PE_Explicit_Raise, -- 20
PE_Finalize_Raised_Exception, -- 21
PE_Implicit_Return, -- 22
PE_Misaligned_Address_Value, -- 23
PE_Missing_Return, -- 24
PE_Overlaid_Controlled_Object, -- 25
PE_Potentially_Blocking_Operation, -- 26
PE_Stubbed_Subprogram_Called, -- 27
PE_Unchecked_Union_Restriction, -- 28
PE_Non_Transportable_Actual, -- 29
PE_Bad_Attribute_For_Predicate, -- 18
PE_Current_Task_In_Entry_Body, -- 19
PE_Duplicated_Entry_Address, -- 20
PE_Explicit_Raise, -- 21
PE_Finalize_Raised_Exception, -- 22
PE_Implicit_Return, -- 23
PE_Misaligned_Address_Value, -- 24
PE_Missing_Return, -- 25
PE_Overlaid_Controlled_Object, -- 26
PE_Potentially_Blocking_Operation, -- 27
PE_Stubbed_Subprogram_Called, -- 28
PE_Unchecked_Union_Restriction, -- 29
PE_Non_Transportable_Actual, -- 30
SE_Empty_Storage_Pool, -- 30
SE_Explicit_Raise, -- 31
SE_Infinite_Recursion, -- 32
SE_Object_Too_Large); -- 33
SE_Empty_Storage_Pool, -- 31
SE_Explicit_Raise, -- 32
SE_Infinite_Recursion, -- 33
SE_Object_Too_Large); -- 34
subtype RT_CE_Exceptions is RT_Exception_Code range
CE_Access_Check_Failed ..

37
gcc/ada/types.h
View File

@ -6,7 +6,7 @@
* *
* C Header File *
* *
* Copyright (C) 1992-2008, Free Software Foundation, Inc. *
* Copyright (C) 1992-2010, Free Software Foundation, Inc. *
* *
* 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- *
@ -361,22 +361,23 @@ typedef Int Mechanism_Type;
#define PE_Accessibility_Check_Failed 15
#define PE_Address_Of_Intrinsic 16
#define PE_All_Guards_Closed 17
#define PE_Current_Task_In_Entry_Body 18
#define PE_Duplicated_Entry_Address 19
#define PE_Explicit_Raise 20
#define PE_Finalize_Raised_Exception 21
#define PE_Implicit_Return 22
#define PE_Misaligned_Address_Value 23
#define PE_Missing_Return 24
#define PE_Overlaid_Controlled_Object 25
#define PE_Potentially_Blocking_Operation 26
#define PE_Stubbed_Subprogram_Called 27
#define PE_Unchecked_Union_Restriction 28
#define PE_Non_Transportable_Actual 29
#define PE_Bad_Attribute_For_Predicate 18
#define PE_Current_Task_In_Entry_Body 19
#define PE_Duplicated_Entry_Address 20
#define PE_Explicit_Raise 21
#define PE_Finalize_Raised_Exception 22
#define PE_Implicit_Return 23
#define PE_Misaligned_Address_Value 24
#define PE_Missing_Return 25
#define PE_Overlaid_Controlled_Object 26
#define PE_Potentially_Blocking_Operation 27
#define PE_Stubbed_Subprogram_Called 28
#define PE_Unchecked_Union_Restriction 29
#define PE_Non_Transportable_Actual 30
#define SE_Empty_Storage_Pool 30
#define SE_Explicit_Raise 31
#define SE_Infinite_Recursion 32
#define SE_Object_Too_Large 33
#define SE_Empty_Storage_Pool 31
#define SE_Explicit_Raise 32
#define SE_Infinite_Recursion 33
#define SE_Object_Too_Large 34
#define LAST_REASON_CODE 33
#define LAST_REASON_CODE 34