Skip to content

R
riscv-gcc-1
Commit 87feba05 by Arnaud Charlet
Options

[multiple changes] 

2016-04-18  Hristian Kirtchev  <kirtchev@adacore.com>

	* namet.adb, namet.ads, exp_unst.adb: Minor reformatting.

2016-04-18  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_eval.adb (Choice_Matches): Check the expression
	against the predicate values when the choice denotes a
	subtype with a static predicate.
	(Eval_Membership_Op): Code cleanup. Remove the suspicious guard which
	tests for predicates.
	(Is_OK_Static_Subtype): A subtype with a dynamic predicate
	is not static.	(Is_Static_Subtype): A subtype with a dynamic
	predicate is not static.
	* sem_eval.ads (Is_OK_Static_Subtype): Update the comment on usage.
	(Is_Static_Subtype): Update the comment on usage.

2016-04-18  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_prag.adb (Analyze_Input_Item): Allow
	generic formals to appear as initialization items.

2016-04-18  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch13.adb (Analyze_Stream_TSS_Definition,
	Has_Good_Profile): Additional error message to indicate that
	the second parameter of the subprogram must be a first subtype.

2016-04-18  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch6.adb (Analyze_Subprogram_Body_Helper, Is_Inline_Pragma):
	Use the pragma lookahead that determines whether a subprogram
	is to be inlined, when some level of backend optimization is
	required.
	* sem_ch12.ads, sem_ch12.adb (Add_Pending_Instantiation): Factorize
	code used to create an instance body when needed for inlining.
	* exp_ch6.adb (Expand_Call): When a call is to be inlined, and the
	call appears within an instantiation that is not a compilation
	unit, add a pending instantiation for the enclosing instance,
	so the backend can inline in turn the calls contained in the
	inlined body.

From-SVN: r235124
parent 3e20cb68
Showing with 339 additions and 225 deletions
gcc/ada/ChangeLog
2016-04-18 Hristian Kirtchev <kirtchev@adacore.com>
* namet.adb, namet.ads, exp_unst.adb: Minor reformatting.
2016-04-18 Hristian Kirtchev <kirtchev@adacore.com>
* sem_eval.adb (Choice_Matches): Check the expression
against the predicate values when the choice denotes a
subtype with a static predicate.
(Eval_Membership_Op): Code cleanup. Remove the suspicious guard which
tests for predicates.
(Is_OK_Static_Subtype): A subtype with a dynamic predicate
is not static. (Is_Static_Subtype): A subtype with a dynamic
predicate is not static.
* sem_eval.ads (Is_OK_Static_Subtype): Update the comment on usage.
(Is_Static_Subtype): Update the comment on usage.
2016-04-18 Hristian Kirtchev <kirtchev@adacore.com>
* sem_prag.adb (Analyze_Input_Item): Allow
generic formals to appear as initialization items.
2016-04-18 Ed Schonberg <schonberg@adacore.com>
* sem_ch13.adb (Analyze_Stream_TSS_Definition,
Has_Good_Profile): Additional error message to indicate that
the second parameter of the subprogram must be a first subtype.
2016-04-18 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb (Analyze_Subprogram_Body_Helper, Is_Inline_Pragma):
Use the pragma lookahead that determines whether a subprogram
is to be inlined, when some level of backend optimization is
required.
* sem_ch12.ads, sem_ch12.adb (Add_Pending_Instantiation): Factorize
code used to create an instance body when needed for inlining.
* exp_ch6.adb (Expand_Call): When a call is to be inlined, and the
call appears within an instantiation that is not a compilation
unit, add a pending instantiation for the enclosing instance,
so the backend can inline in turn the calls contained in the
inlined body.
2016-04-18 Ed Schonberg <schonberg@adacore.com>
* sem_prag.adb (Build_Pragma_Check_Equivalent): The mapping
......
gcc/ada/exp_ch6.adb
......@@ -59,6 +59,7 @@ with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch12; use Sem_Ch12;
with Sem_Ch13; use Sem_Ch13;
with Sem_Dim; use Sem_Dim;
with Sem_Disp; use Sem_Disp;
......@@ -3898,6 +3899,50 @@ package body Exp_Ch6 is
then
Add_Inlined_Body (Subp, Call_Node);
-- If the inlined call appears within an instantiation and some
-- level of optimization is required, ensure that the enclosing
-- instance body is available so that the back-end can actually
-- perform the inlining.
if In_Instance
and then Comes_From_Source (Subp)
and then Optimization_Level > 0
then
declare
Inst : Entity_Id;
Decl : Node_Id;
begin
Inst := Scope (Subp);
-- Find enclosing instance.
while Present (Inst) and then Inst /= Standard_Standard loop
exit when Is_Generic_Instance (Inst);
Inst := Scope (Inst);
end loop;
if Present (Inst) and then Is_Generic_Instance (Inst) then
Set_Is_Inlined (Inst);
Decl := Unit_Declaration_Node (Inst);
-- Do not add a pending instantiation if the body exits
-- already, or if the instance is a compilation unit, or
-- the instance node is missing.
if Present (Corresponding_Body (Decl))
or else Nkind (Parent (Decl)) = N_Compilation_Unit
or else No (Next (Decl))
then
null;
else
Add_Pending_Instantiation (Next (Decl), Decl);
end if;
end if;
end;
end if;
-- Front end expansion of simple functions returning unconstrained
-- types (see Check_And_Split_Unconstrained_Function). Note that the
-- case of a simple renaming (Body_To_Inline in N_Entity above, see
......
gcc/ada/exp_unst.adb
......@@ -243,9 +243,10 @@ package body Exp_Unst is
loop
if No (C) then
return Chars (Ent);
elsif Chars (Defining_Identifier (C)) = Chars (Ent) then
return Name_Find
(Get_Name_String (Chars (Ent)) & Img_Pos (Index));
return
Name_Find (Get_Name_String (Chars (Ent)) & Img_Pos (Index));
else
Next (C);
end if;
......
gcc/ada/namet.adb
......@@ -140,6 +140,7 @@ package body Namet is
procedure Append (Buf : in out Bounded_String; Id : Name_Id) is
pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
S : constant Int := Name_Entries.Table (Id).Name_Chars_Index;
begin
for J in 1 .. Natural (Name_Entries.Table (Id).Name_Len) loop
Append (Buf, Name_Chars.Table (S + Int (J)));
......@@ -420,7 +421,9 @@ package body Namet is
----------------------------------
procedure Append_Decoded_With_Brackets
(Buf : in out Bounded_String; Id : Name_Id) is
(Buf : in out Bounded_String;
Id : Name_Id)
is
P : Natural;
begin
......@@ -560,8 +563,7 @@ package body Namet is
-- Append_Unqualified --
------------------------
procedure Append_Unqualified
(Buf : in out Bounded_String; Id : Name_Id) is
procedure Append_Unqualified (Buf : in out Bounded_String; Id : Name_Id) is
begin
Append (Buf, Id);
Strip_Qualification_And_Suffixes (Buf);
......@@ -572,7 +574,9 @@ package body Namet is
--------------------------------
procedure Append_Unqualified_Decoded
(Buf : in out Bounded_String; Id : Name_Id) is
(Buf : in out Bounded_String;
Id : Name_Id)
is
begin
Append_Decoded (Buf, Id);
Strip_Qualification_And_Suffixes (Buf);
......@@ -908,8 +912,12 @@ package body Namet is
----------------
procedure Insert_Str
(Buf : in out Bounded_String; S : String; Index : Positive) is
(Buf : in out Bounded_String;
S : String;
Index : Positive)
is
SL : constant Natural := S'Length;
begin
Buf.Chars (Index + SL .. Buf.Length + SL) :=
Buf.Chars (Index .. Buf.Length);
......@@ -1468,7 +1476,9 @@ package body Namet is
--------------------------------
procedure Set_Character_Literal_Name
(Buf : in out Bounded_String; C : Char_Code) is
(Buf : in out Bounded_String;
C : Char_Code)
is
begin
Buf.Length := 0;
Append (Buf, 'Q');
......
gcc/ada/namet.ads
......@@ -373,7 +373,8 @@ package Namet is
-- apostrophes.
procedure Append_Decoded_With_Brackets
(Buf : in out Bounded_String; Id : Name_Id);
(Buf : in out Bounded_String;
Id : Name_Id);
-- Same as Append_Decoded, except that the brackets notation (Uhh
-- replaced by ["hh"], Whhhh replaced by ["hhhh"], WWhhhhhhhh replaced by
-- ["hhhhhhhh"]) is used for all non-lower half characters, regardless of
......@@ -383,8 +384,7 @@ package Namet is
-- requirement for a canonical representation not affected by the
-- character set options (e.g. in the binder generation of symbols).
procedure Append_Unqualified
(Buf : in out Bounded_String; Id : Name_Id);
procedure Append_Unqualified (Buf : in out Bounded_String; Id : Name_Id);
-- Same as Append, except that qualification (as defined in unit
-- Exp_Dbug) is removed (including both preceding __ delimited names, and
-- also the suffixes used to indicate package body entities and to
......@@ -395,7 +395,8 @@ package Namet is
-- after gigi has been called.
procedure Append_Unqualified_Decoded
(Buf : in out Bounded_String; Id : Name_Id);
(Buf : in out Bounded_String;
Id : Name_Id);
-- Same as Append_Unqualified, but decoded as for Append_Decoded
procedure Append_Encoded (Buf : in out Bounded_String; C : Char_Code);
......@@ -408,12 +409,15 @@ package Namet is
-- are stored using the Uhh encoding).
procedure Set_Character_Literal_Name
(Buf : in out Bounded_String; C : Char_Code);
(Buf : in out Bounded_String;
C : Char_Code);
-- This procedure sets the proper encoded name for the character literal
-- for the given character code.
procedure Insert_Str
(Buf : in out Bounded_String; S : String; Index : Positive);
(Buf : in out Bounded_String;
S : String;
Index : Positive);
-- Inserts S in Buf, starting at Index. Any existing characters at or past
-- this location get moved beyond the inserted string.
......
gcc/ada/sem_ch12.adb
......@@ -1027,6 +1027,31 @@ package body Sem_Ch12 is
raise Instantiation_Error;
end Abandon_Instantiation;
--------------------------------
-- Add_Pending_Instantiation --
--------------------------------
procedure Add_Pending_Instantiation (Inst : Node_Id; Act_Decl : Node_Id) is
begin
-- Add to the instantiation node and the corresponding unit declaration
-- the current values of global flags to be used when analyzing the
-- instance body.
Pending_Instantiations.Append
((Inst_Node => Inst,
Act_Decl => Act_Decl,
Expander_Status => Expander_Active,
Current_Sem_Unit => Current_Sem_Unit,
Scope_Suppress => Scope_Suppress,
Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
Version => Ada_Version,
Version_Pragma => Ada_Version_Pragma,
Warnings => Save_Warnings,
SPARK_Mode => SPARK_Mode,
SPARK_Mode_Pragma => SPARK_Mode_Pragma));
end Add_Pending_Instantiation;
--------------------------
-- Analyze_Associations --
--------------------------
......@@ -4138,18 +4163,7 @@ package body Sem_Ch12 is
-- Make entry in table
Pending_Instantiations.Append
((Inst_Node => N,
Act_Decl => Act_Decl,
Expander_Status => Expander_Active,
Current_Sem_Unit => Current_Sem_Unit,
Scope_Suppress => Scope_Suppress,
Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
Version => Ada_Version,
Version_Pragma => Ada_Version_Pragma,
Warnings => Save_Warnings,
SPARK_Mode => SPARK_Mode,
SPARK_Mode_Pragma => SPARK_Mode_Pragma));
Add_Pending_Instantiation (N, Act_Decl);
end if;
end if;
......@@ -4745,18 +4759,7 @@ package body Sem_Ch12 is
and then not Is_Eliminated (Subp)
then
Pending_Instantiations.Append
((Inst_Node => N,
Act_Decl => Unit_Declaration_Node (Subp),
Expander_Status => Expander_Active,
Current_Sem_Unit => Current_Sem_Unit,
Scope_Suppress => Scope_Suppress,
Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
Version => Ada_Version,
Version_Pragma => Ada_Version_Pragma,
Warnings => Save_Warnings,
SPARK_Mode => SPARK_Mode,
SPARK_Mode_Pragma => SPARK_Mode_Pragma));
Add_Pending_Instantiation (N, Unit_Declaration_Node (Subp));
return True;
-- Here if not inlined, or we ignore the inlining
......
gcc/ada/sem_ch12.ads
......@@ -37,6 +37,10 @@ package Sem_Ch12 is
procedure Analyze_Formal_Subprogram_Declaration (N : Node_Id);
procedure Analyze_Formal_Package_Declaration (N : Node_Id);
procedure Add_Pending_Instantiation (Inst : Node_Id; Act_Decl : Node_Id);
-- Add an entry in the table of instance bodies that must be analyzed
-- when inlining requires its body or the body of a nested instance.
function Build_Function_Wrapper
(Formal_Subp : Entity_Id;
Actual_Subp : Entity_Id) return Node_Id;
......@@ -113,12 +117,12 @@ package Sem_Ch12 is
-- of G, we compile the body of I2, but not that of I1. However, when we
-- compile U as the main unit, we compile both bodies. This will lead to
-- link-time errors if the compilation of I1 generates public symbols,
-- because those in I2 will receive different names in both cases.
-- This forces us to analyze the body of I1 even when U is not the main
-- unit. We don't want this additional mechanism to generate an error
-- when the body of the generic for I1 is not present, and this is the
-- reason for the presence of the flag Body_Optional, which is exchanged
-- between the current procedure and Load_Parent_Of_Generic.
-- because those in I2 will receive different names in both cases. This
-- forces us to analyze the body of I1 even when U is not the main unit.
-- We don't want this additional mechanism to generate an error when the
-- body of the generic for I1 is not present, and this is the reason for
-- the presence of the flag Body_Optional, which is exchanged between the
-- current procedure and Load_Parent_Of_Generic.
procedure Instantiate_Subprogram_Body
(Body_Info : Pending_Body_Info;
......
gcc/ada/sem_ch13.adb
......@@ -3754,15 +3754,21 @@ package body Sem_Ch13 is
Is_Read : constant Boolean := (TSS_Nam = TSS_Stream_Read);
-- True for Read attribute, false for other attributes
function Has_Good_Profile (Subp : Entity_Id) return Boolean;
function Has_Good_Profile
(Subp : Entity_Id;
Report : Boolean := False) return Boolean;
-- Return true if the entity is a subprogram with an appropriate
-- profile for the attribute being defined.
-- profile for the attribute being defined. If result is false and
-- Report is True function emits appropriate error.
----------------------
-- Has_Good_Profile --
----------------------
function Has_Good_Profile (Subp : Entity_Id) return Boolean is
function Has_Good_Profile
(Subp : Entity_Id;
Report : Boolean := False) return Boolean
is
F : Entity_Id;
Is_Function : constant Boolean := (TSS_Nam = TSS_Stream_Input);
Expected_Ekind : constant array (Boolean) of Entity_Kind :=
......@@ -3837,6 +3843,11 @@ package body Sem_Ch13 is
and then not Is_First_Subtype (Typ)
and then not Is_Class_Wide_Type (Typ)
then
if Report and not Is_First_Subtype (Typ) then
Error_Msg_N
("formal of stream operation must be a first subtype", F);
end if;
return False;
else
......@@ -3885,7 +3896,7 @@ package body Sem_Ch13 is
if Is_Entity_Name (Expr) then
if not Is_Overloaded (Expr) then
if Has_Good_Profile (Entity (Expr)) then
if Has_Good_Profile (Entity (Expr), Report => True) then
Subp := Entity (Expr);
end if;
......
gcc/ada/sem_ch6.adb
......@@ -2554,8 +2554,9 @@ package body Sem_Ch6 is
Nkind (N) = N_Pragma
and then
(Pragma_Name (N) = Name_Inline_Always
or else (Front_End_Inlining
and then Pragma_Name (N) = Name_Inline))
or else (Pragma_Name (N) = Name_Inline
and then
(Front_End_Inlining or else Optimization_Level > 0)))
and then
Chars
(Expression (First (Pragma_Argument_Associations (N)))) =
......
gcc/ada/sem_eval.adb
......@@ -173,6 +173,14 @@ package body Sem_Eval is
-- discrete, real, or string type and must be a compile time known value
-- (it is an error to make the call if these conditions are not met).
function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id;
-- Check whether an arithmetic operation with universal operands which is a
-- rewritten function call with an explicit scope indication is ambiguous:
-- P."+" (1, 2) will be ambiguous if there is more than one visible numeric
-- type declared in P and the context does not impose a type on the result
-- (e.g. in the expression of a type conversion). If ambiguous, emit an
-- error and return Empty, else return the result type of the operator.
function From_Bits (B : Bits; T : Entity_Id) return Uint;
-- Converts a bit string of length B'Length to a Uint value to be used for
-- a target of type T, which is a modular type. This procedure includes the
......@@ -180,14 +188,11 @@ package body Sem_Eval is
-- (for a binary modulus, the bit string is the right length any way so all
-- is well).
function Is_Static_Choice (Choice : Node_Id) return Boolean;
-- Given a choice (from a case expression or membership test), returns
-- True if the choice is static. No test is made for raising of constraint
-- error, so this function is used only for legality tests.
function Is_Static_Choice_List (Choices : List_Id) return Boolean;
-- Given a choice list (from a case expression or membership test), return
-- True if all choices are static in the sense of Is_Static_Choice.
function Get_String_Val (N : Node_Id) return Node_Id;
-- Given a tree node for a folded string or character value, returns the
-- corresponding string literal or character literal (one of the two must
-- be available, or the operand would not have been marked as foldable in
-- the earlier analysis of the operation).
function Is_OK_Static_Choice (Choice : Node_Id) return Boolean;
-- Given a choice (from a case expression or membership test), returns
......@@ -197,6 +202,15 @@ package body Sem_Eval is
-- Given a choice list (from a case expression or membership test), return
-- True if all choices are static in the sense of Is_OK_Static_Choice.
function Is_Static_Choice (Choice : Node_Id) return Boolean;
-- Given a choice (from a case expression or membership test), returns
-- True if the choice is static. No test is made for raising of constraint
-- error, so this function is used only for legality tests.
function Is_Static_Choice_List (Choices : List_Id) return Boolean;
-- Given a choice list (from a case expression or membership test), return
-- True if all choices are static in the sense of Is_Static_Choice.
function Is_Static_Range (N : Node_Id) return Boolean;
-- Determine if range is static, as defined in RM 4.9(26). The only allowed
-- argument is an N_Range node (but note that the semantic analysis of
......@@ -206,12 +220,6 @@ package body Sem_Eval is
-- raise Constraint_Error or not. Used for checking whether expressions are
-- static in the 4.9 sense (without worrying about exceptions).
function Get_String_Val (N : Node_Id) return Node_Id;
-- Given a tree node for a folded string or character value, returns the
-- corresponding string literal or character literal (one of the two must
-- be available, or the operand would not have been marked as foldable in
-- the earlier analysis of the operation).
function OK_Bits (N : Node_Id; Bits : Uint) return Boolean;
-- Bits represents the number of bits in an integer value to be computed
-- (but the value has not been computed yet). If this value in Bits is
......@@ -255,14 +263,6 @@ package body Sem_Eval is
-- used for producing the result of the static evaluation of the
-- logical operators
function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id;
-- Check whether an arithmetic operation with universal operands which is a
-- rewritten function call with an explicit scope indication is ambiguous:
-- P."+" (1, 2) will be ambiguous if there is more than one visible numeric
-- type declared in P and the context does not impose a type on the result
-- (e.g. in the expression of a type conversion). If ambiguous, emit an
-- error and return Empty, else return the result type of the operator.
procedure Test_Expression_Is_Foldable
(N : Node_Id;
Op1 : Node_Id;
......@@ -596,9 +596,21 @@ package body Sem_Eval is
Set_Raises_Constraint_Error (Choice);
return Non_Static;
-- When the choice denotes a subtype with a static predictate, check the
-- expression against the predicate values.
elsif (Nkind (Choice) = N_Subtype_Indication
or else (Is_Entity_Name (Choice)
and then Is_Type (Entity (Choice))))
and then Has_Predicates (Etype (Choice))
and then Has_Static_Predicate (Etype (Choice))
then
return
Choices_Match (Expr, Static_Discrete_Predicate (Etype (Choice)));
-- Discrete type case
elsif Is_Discrete_Type (Etype (Expr)) then
elsif Is_Discrete_Type (Etyp) then
Val := Expr_Value (Expr);
if Nkind (Choice) = N_Range then
......@@ -612,8 +624,7 @@ package body Sem_Eval is
end if;
elsif Nkind (Choice) = N_Subtype_Indication
or else
(Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
then
if Val >= Expr_Value (Type_Low_Bound (Etype (Choice)))
and then
......@@ -637,7 +648,7 @@ package body Sem_Eval is
-- Real type case
elsif Is_Real_Type (Etype (Expr)) then
elsif Is_Real_Type (Etyp) then
ValR := Expr_Value_R (Expr);
if Nkind (Choice) = N_Range then
......@@ -651,8 +662,7 @@ package body Sem_Eval is
end if;
elsif Nkind (Choice) = N_Subtype_Indication
or else
(Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
then
if ValR >= Expr_Value_R (Type_Low_Bound (Etype (Choice)))
and then
......@@ -674,12 +684,11 @@ package body Sem_Eval is
-- String type cases
else
pragma Assert (Is_String_Type (Etype (Expr)));
pragma Assert (Is_String_Type (Etyp));
ValS := Expr_Value_S (Expr);
if Nkind (Choice) = N_Subtype_Indication
or else
(Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
then
if not Is_Constrained (Etype (Choice)) then
return Match;
......@@ -2714,45 +2723,34 @@ package body Sem_Eval is
-- static subtype (RM 4.9(12)).
procedure Eval_Membership_Op (N : Node_Id) is
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
Alts : constant List_Id := Alternatives (N);
Choice : constant Node_Id := Right_Opnd (N);
Expr : constant Node_Id := Left_Opnd (N);
Result : Match_Result;
begin
-- Ignore if error in either operand, except to make sure that Any_Type
-- is properly propagated to avoid junk cascaded errors.
if Etype (Left) = Any_Type
or else (Present (Right) and then Etype (Right) = Any_Type)
if Etype (Expr) = Any_Type
or else (Present (Choice) and then Etype (Choice) = Any_Type)
then
Set_Etype (N, Any_Type);
return;
end if;
-- Ignore if types involved have predicates
-- Is this right for static predicates ???
-- And what about the alternatives ???
if Present (Predicate_Function (Etype (Left)))
or else (Present (Right)
and then Present (Predicate_Function (Etype (Right))))
then
return;
end if;
-- If left operand non-static, then nothing to do
if not Is_Static_Expression (Left) then
if not Is_Static_Expression (Expr) then
return;
end if;
-- If choice is non-static, left operand is in non-static context
if (Present (Right) and then not Is_Static_Choice (Right))
if (Present (Choice) and then not Is_Static_Choice (Choice))
or else (Present (Alts) and then not Is_Static_Choice_List (Alts))
then
Check_Non_Static_Context (Left);
Check_Non_Static_Context (Expr);
return;
end if;
......@@ -2762,16 +2760,16 @@ package body Sem_Eval is
-- If left operand raises constraint error, propagate and we are done
if Raises_Constraint_Error (Left) then
if Raises_Constraint_Error (Expr) then
Set_Raises_Constraint_Error (N, True);
-- See if we match
else
if Present (Right) then
Result := Choice_Matches (Left, Right);
if Present (Choice) then
Result := Choice_Matches (Expr, Choice);
else
Result := Choices_Match (Left, Alts);
Result := Choices_Match (Expr, Alts);
end if;
-- If result is Non_Static, it means that we raise Constraint_Error,
......@@ -4697,8 +4695,7 @@ package body Sem_Eval is
return Is_OK_Static_Range (Choice);
elsif Nkind (Choice) = N_Subtype_Indication
or else
(Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
then
return Is_OK_Static_Subtype (Etype (Choice));
......@@ -4787,6 +4784,9 @@ package body Sem_Eval is
then
return False;
elsif Has_Dynamic_Predicate_Aspect (Typ) then
return False;
-- String types
elsif Is_String_Type (Typ) then
......@@ -4853,8 +4853,7 @@ package body Sem_Eval is
return Is_Static_Range (Choice);
elsif Nkind (Choice) = N_Subtype_Indication
or else
(Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
then
return Is_Static_Subtype (Etype (Choice));
......@@ -4883,7 +4882,7 @@ package body Sem_Eval is
return True;
end Is_Static_Choice_List;
---------------------
---------------------
-- Is_Static_Range --
---------------------
......@@ -4929,6 +4928,9 @@ package body Sem_Eval is
then
return False;
elsif Has_Dynamic_Predicate_Aspect (Typ) then
return False;
-- String types
elsif Is_String_Type (Typ) then
......
gcc/ada/sem_eval.ads
......@@ -198,88 +198,10 @@ package Sem_Eval is
-- True for a recursive call from within Compile_Time_Compare to avoid some
-- infinite recursion cases. It should never be set by a client.
procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id);
-- This procedure is called after it has been determined that Expr is not
-- static when it is required to be. Msg is the text of a message that
-- explains the error. This procedure checks if an error is already posted
-- on Expr, if so, it does nothing unless All_Errors_Mode is set in which
-- case this flag is ignored. Otherwise the given message is posted using
-- Error_Msg_F, and then Why_Not_Static is called on Expr to generate
-- additional messages. The string given as Msg should end with ! to make
-- it an unconditional message, to ensure that if it is posted, the entire
-- set of messages is all posted.
function Is_OK_Static_Expression (N : Node_Id) return Boolean;
-- An OK static expression is one that is static in the RM definition sense
-- and which does not raise constraint error. For most legality checking
-- purposes you should use Is_Static_Expression. For those legality checks
-- where the expression N should not raise constraint error use this
-- routine. This routine is *not* to be used in contexts where the test is
-- for compile time evaluation purposes. Use Compile_Time_Known_Value
-- instead (see section on "Compile-Time Known Values" above).
function Is_OK_Static_Range (N : Node_Id) return Boolean;
-- Determines if range is static, as defined in RM 4.9(26), and also checks
-- that neither bound of the range raises constraint error, thus ensuring
-- that both bounds of the range are compile-time evaluable (i.e. do not
-- raise constraint error). A result of true means that the bounds are
-- compile time evaluable. A result of false means they are not (either
-- because the range is not static, or because one or the other bound
-- raises CE).
function Is_Static_Subtype (Typ : Entity_Id) return Boolean;
-- Determines whether a subtype fits the definition of an Ada static
-- subtype as given in (RM 4.9(26)). Important note: This check does not
-- include the Ada 2012 case of a non-static predicate which results in an
-- otherwise static subtype being non-static. Such a subtype will return
-- True for this test, so if the distinction is important, the caller must
-- deal with this.
--
-- Implementation note: an attempt to include this Ada 2012 case failed,
-- since it appears that this routine is called in some cases before the
-- Static_Discrete_Predicate field is set ???
--
-- This differs from Is_OK_Static_Subtype (which is what must be used by
-- clients) in that it does not care whether the bounds raise a constraint
-- error exception or not. Used for checking whether expressions are static
-- in the 4.9 sense (without worrying about exceptions).
function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean;
-- Determines whether a subtype fits the definition of an Ada static
-- subtype as given in (RM 4.9(26)) with the additional check that neither
-- bound raises constraint error (meaning that Expr_Value[_R|S] can be used
-- on these bounds). Important note: This check does not include the Ada
-- 2012 case of a non-static predicate which results in an otherwise static
-- subtype being non-static. Such a subtype will return True for this test,
-- so if the distinction is important, the caller must deal with this.
--
-- Implementation note: an attempt to include this Ada 2012 case failed,
-- since it appears that this routine is called in some cases before the
-- Static_Discrete_Predicate field is set ???
--
-- This differs from Is_Static_Subtype in that it includes the constraint
-- error checks, which are missing from Is_Static_Subtype.
function Subtypes_Statically_Compatible
(T1 : Entity_Id;
T2 : Entity_Id;
Formal_Derived_Matching : Boolean := False) return Boolean;
-- Returns true if the subtypes are unconstrained or the constraint on
-- on T1 is statically compatible with T2 (as defined by 4.9.1(4)).
-- Otherwise returns false. Formal_Derived_Matching indicates whether
-- the type T1 is a generic actual being checked against ancestor T2
-- in a formal derived type association.
function Subtypes_Statically_Match
(T1 : Entity_Id;
T2 : Entity_Id;
Formal_Derived_Matching : Boolean := False) return Boolean;
-- Determine whether two types T1, T2, which have the same base type,
-- are statically matching subtypes (RM 4.9.1(1-2)). Also includes the
-- extra GNAT rule that object sizes must match (this can be false for
-- types that match in the RM sense because of use of 'Object_Size),
-- except when testing a generic actual T1 against an ancestor T2 in a
-- formal derived type association (indicated by Formal_Derived_Matching).
function Compile_Time_Known_Bounds (T : Entity_Id) return Boolean;
-- If T is an array whose index bounds are all known at compile time, then
-- True is returned. If T is not an array type, or one or more of its index
-- bounds is not known at compile time, then False is returned.
function Compile_Time_Known_Value (Op : Node_Id) return Boolean;
-- Returns true if Op is an expression not raising Constraint_Error whose
......@@ -306,6 +228,15 @@ package Sem_Eval is
-- efficient with compile time known values, e.g. range analysis for the
-- purpose of removing checks is more effective if we know precise bounds.
function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean;
-- Similar to Compile_Time_Known_Value, but also returns True if the value
-- is a compile-time-known aggregate, i.e. an aggregate all of whose
-- constituent expressions are either compile-time-known values (based on
-- calling Compile_Time_Known_Value) or compile-time-known aggregates.
-- Note that the aggregate could still involve run-time checks that might
-- fail (such as for subtype checks in component associations), but the
-- evaluation of the expressions themselves will not raise an exception.
function CRT_Safe_Compile_Time_Known_Value (Op : Node_Id) return Boolean;
-- In the case of configurable run-times, there may be an issue calling
-- Compile_Time_Known_Value with non-static expressions where the legality
......@@ -328,19 +259,16 @@ package Sem_Eval is
-- if we are in configurable run-time mode, even if the expression would
-- normally be considered compile-time known.
function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean;
-- Similar to Compile_Time_Known_Value, but also returns True if the value
-- is a compile-time-known aggregate, i.e. an aggregate all of whose
-- constituent expressions are either compile-time-known values (based on
-- calling Compile_Time_Known_Value) or compile-time-known aggregates.
-- Note that the aggregate could still involve run-time checks that might
-- fail (such as for subtype checks in component associations), but the
-- evaluation of the expressions themselves will not raise an exception.
function Compile_Time_Known_Bounds (T : Entity_Id) return Boolean;
-- If T is an array whose index bounds are all known at compile time, then
-- True is returned. If T is not an array type, or one or more of its index
-- bounds is not known at compile time, then False is returned.
function Expr_Rep_Value (N : Node_Id) return Uint;
-- This is identical to Expr_Value, except in the case of enumeration
-- literals of types for which an enumeration representation clause has
-- been given, in which case it returns the representation value rather
-- than the pos value. This is the value that is needed for generating code
-- sequences, while the Expr_Value value is appropriate for compile time
-- constraint errors or getting the logical value. Note that this function
-- does NOT concern itself with biased values, if the caller needs a
-- properly biased value, the subtraction of the bias must be handled
-- explicitly.
function Expr_Value (N : Node_Id) return Uint;
-- Returns the folded value of the expression N. This function is called in
......@@ -372,17 +300,6 @@ package Sem_Eval is
-- is static or its value is known at compile time. This version is used
-- for string types and returns the corresponding N_String_Literal node.
function Expr_Rep_Value (N : Node_Id) return Uint;
-- This is identical to Expr_Value, except in the case of enumeration
-- literals of types for which an enumeration representation clause has
-- been given, in which case it returns the representation value rather
-- than the pos value. This is the value that is needed for generating code
-- sequences, while the Expr_Value value is appropriate for compile time
-- constraint errors or getting the logical value. Note that this function
-- does NOT concern itself with biased values, if the caller needs a
-- properly biased value, the subtraction of the bias must be handled
-- explicitly.
procedure Eval_Actual (N : Node_Id);
procedure Eval_Allocator (N : Node_Id);
procedure Eval_Arithmetic_Op (N : Node_Id);
......@@ -411,6 +328,17 @@ package Sem_Eval is
procedure Eval_Unary_Op (N : Node_Id);
procedure Eval_Unchecked_Conversion (N : Node_Id);
procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id);
-- This procedure is called after it has been determined that Expr is not
-- static when it is required to be. Msg is the text of a message that
-- explains the error. This procedure checks if an error is already posted
-- on Expr, if so, it does nothing unless All_Errors_Mode is set in which
-- case this flag is ignored. Otherwise the given message is posted using
-- Error_Msg_F, and then Why_Not_Static is called on Expr to generate
-- additional messages. The string given as Msg should end with ! to make
-- it an unconditional message, to ensure that if it is posted, the entire
-- set of messages is all posted.
procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean);
-- Rewrite N with a new N_String_Literal node as the result of the compile
-- time evaluation of the node N. Val is the resulting string value from
......@@ -474,6 +402,38 @@ package Sem_Eval is
-- is some independent way of knowing that it is valid, i.e. either it is
-- an entity with Is_Known_Valid set, or Assume_No_Invalid_Values is True.
function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean;
-- Returns True if it can guarantee that Lo .. Hi is a null range. If it
-- cannot (because the value of Lo or Hi is not known at compile time) then
-- it returns False.
function Is_OK_Static_Expression (N : Node_Id) return Boolean;
-- An OK static expression is one that is static in the RM definition sense
-- and which does not raise constraint error. For most legality checking
-- purposes you should use Is_Static_Expression. For those legality checks
-- where the expression N should not raise constraint error use this
-- routine. This routine is *not* to be used in contexts where the test is
-- for compile time evaluation purposes. Use Compile_Time_Known_Value
-- instead (see section on "Compile-Time Known Values" above).
function Is_OK_Static_Range (N : Node_Id) return Boolean;
-- Determines if range is static, as defined in RM 4.9(26), and also checks
-- that neither bound of the range raises constraint error, thus ensuring
-- that both bounds of the range are compile-time evaluable (i.e. do not
-- raise constraint error). A result of true means that the bounds are
-- compile time evaluable. A result of false means they are not (either
-- because the range is not static, or because one or the other bound
-- raises CE).
function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean;
-- Determines whether a subtype fits the definition of an Ada static
-- subtype as given in (RM 4.9(26)) with the additional check that neither
-- bound raises constraint error (meaning that Expr_Value[_R|S] can be used
-- on these bounds).
--
-- This differs from Is_Static_Subtype in that it includes the constraint
-- error checks, which are missing from Is_Static_Subtype.
function Is_Out_Of_Range
(N : Node_Id;
Typ : Entity_Id;
......@@ -488,6 +448,19 @@ package Sem_Eval is
-- that it is out of range. The parameters Assume_Valid, Fixed_Int, and
-- Int_Real are as described for Is_In_Range above.
function Is_Static_Subtype (Typ : Entity_Id) return Boolean;
-- Determines whether a subtype fits the definition of an Ada static
-- subtype as given in (RM 4.9(26)).
--
-- This differs from Is_OK_Static_Subtype (which is what must be used by
-- clients) in that it does not care whether the bounds raise a constraint
-- error exception or not. Used for checking whether expressions are static
-- in the 4.9 sense (without worrying about exceptions).
function Is_Statically_Unevaluated (Expr : Node_Id) return Boolean;
-- This function returns True if the given expression Expr is statically
-- unevaluated, as defined in (RM 4.9 (32.1-32.6)).
function In_Subrange_Of
(T1 : Entity_Id;
T2 : Entity_Id;
......@@ -498,15 +471,6 @@ package Sem_Eval is
-- it cannot be determined at compile time. Flag Fixed_Int is used as in
-- routine Is_In_Range above.
function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean;
-- Returns True if it can guarantee that Lo .. Hi is a null range. If it
-- cannot (because the value of Lo or Hi is not known at compile time) then
-- it returns False.
function Is_Statically_Unevaluated (Expr : Node_Id) return Boolean;
-- This function returns True if the given expression Expr is statically
-- unevaluated, as defined in (RM 4.9 (32.1-32.6)).
function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean;
-- Returns True if it can guarantee that Lo .. Hi is not a null range. If
-- it cannot (because the value of Lo or Hi is not known at compile time)
......@@ -518,6 +482,27 @@ package Sem_Eval is
-- predicates match. Separated out from Subtypes_Statically_Match so
-- that it can be used in specializing error messages.
function Subtypes_Statically_Compatible
(T1 : Entity_Id;
T2 : Entity_Id;
Formal_Derived_Matching : Boolean := False) return Boolean;
-- Returns true if the subtypes are unconstrained or the constraint on
-- on T1 is statically compatible with T2 (as defined by 4.9.1(4)).
-- Otherwise returns false. Formal_Derived_Matching indicates whether
-- the type T1 is a generic actual being checked against ancestor T2
-- in a formal derived type association.
function Subtypes_Statically_Match
(T1 : Entity_Id;
T2 : Entity_Id;
Formal_Derived_Matching : Boolean := False) return Boolean;
-- Determine whether two types T1, T2, which have the same base type,
-- are statically matching subtypes (RM 4.9.1(1-2)). Also includes the
-- extra GNAT rule that object sizes must match (this can be false for
-- types that match in the RM sense because of use of 'Object_Size),
-- except when testing a generic actual T1 against an ancestor T2 in a
-- formal derived type association (indicated by Formal_Derived_Matching).
procedure Why_Not_Static (Expr : Node_Id);
-- This procedure may be called after generating an error message that
-- complains that something is non-static. If it finds good reasons, it
......
gcc/ada/sem_prag.adb
......@@ -2860,15 +2860,21 @@ package body Sem_Prag is
if Ekind_In (Input_Id, E_Abstract_State,
E_Constant,
E_Generic_In_Out_Parameter,
E_Generic_In_Parameter,
E_In_Parameter,
E_In_Out_Parameter,
E_Out_Parameter,
E_Variable)
then
-- The input cannot denote states or objects declared
-- within the related package (SPARK RM 7.1.5(4)).
-- within the related package (SPARK RM 7.1.5(4)). The
-- only exception to this are generic formal parameters.
if Within_Scope (Input_Id, Current_Scope) then
if not Ekind_In (Input_Id, E_Generic_In_Out_Parameter,
E_Generic_In_Parameter)
and then Within_Scope (Input_Id, Current_Scope)
then
Error_Msg_Name_1 := Chars (Pack_Id);
SPARK_Msg_NE
("input item & cannot denote a visible object or "
......
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