===================================================================
@@ -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);
===================================================================
@@ -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 --
-------------
===================================================================
@@ -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;
===================================================================
@@ -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 (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);
===================================================================
@@ -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
===================================================================
@@ -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)
===================================================================
@@ -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 ..
===================================================================
@@ -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 SE_Empty_Storage_Pool 30
-#define SE_Explicit_Raise 31
-#define SE_Infinite_Recursion 32
-#define SE_Object_Too_Large 33
+#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 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
First/Last/Range are not allowed on predicated types. For non-generic actuals attempted use is illegal, for generic actuals, a warning is given, and program error raised (to preserve the contract model). An example, compiled with -gnata12 -gnatj60 -gnatld7 1. package predicate_attr is 2. type r is range 1 .. 100; 3. subtype s is r with 4. predicate => s in 3 | 10 .. 20; 5. q1 : r := s'first; | >>> type "s" has predicates, attribute "first" not allowed 6. q2 : r := s'last; | >>> type "s" has predicates, attribute "last" not allowed 7. q3 : boolean := 13 in s'range; | >>> type "s" has predicates, attribute "range" not allowed 8. 9. generic 10. type x is (<>); 11. package gr is 12. q4 : x := x'first; 13. end; 14. 15. package grp is new gr (s); | >>> warning: in instantiation at line 12, type "x" has predicates, attribute "first" not allowed, Program_Error will be raised at run time 16. end; Tested on x86_64-pc-linux-gnu, committed on trunk 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.