+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
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;
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
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;
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)));
----------------------------------
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
-- 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);
--------------------------------
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);
----------------
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);
--------------------------------
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');
type Bounded_String (Max_Length : Natural := 4 * Max_Line_Length) is limited
-- The default here is intended to be an infinite value that ensures that
-- we never overflow the buffer (names this long are too absurd to worry).
- record
- Length : Natural := 0;
- Chars : String (1 .. Max_Length);
- end record;
+ record
+ Length : Natural := 0;
+ Chars : String (1 .. Max_Length);
+ end record;
-- To create a Name_Id, you can declare a Bounded_String as a local
-- variable, and Append things onto it, and finally call Name_Find.
-- to avoid the global.
Global_Name_Buffer : Bounded_String;
- Name_Buffer : String renames Global_Name_Buffer.Chars;
- Name_Len : Natural renames Global_Name_Buffer.Length;
+ Name_Buffer : String renames Global_Name_Buffer.Chars;
+ Name_Len : Natural renames Global_Name_Buffer.Length;
-- Note that there is some circuitry (e.g. Osint.Write_Program_Name) that
-- does a save/restore on Name_Len and Name_Buffer (1 .. Name_Len). This
-- 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
-- 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
-- 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);
-- 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.
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 --
--------------------------
-- 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;
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
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;
-- 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;
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 :=
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
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;
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)))) =
-- 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
-- (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
-- 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
-- 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
-- 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;
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
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
end if;
end if;
- -- Real type case
+ -- 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
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
end if;
end if;
- -- String type cases
+ -- 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;
-- 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;
-- 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,
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));
then
return False;
+ elsif Has_Dynamic_Predicate_Aspect (Typ) then
+ return False;
+
-- String types
elsif Is_String_Type (Typ) then
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));
return True;
end Is_Static_Choice_List;
----------------------
+ ---------------------
-- Is_Static_Range --
---------------------
then
return False;
+ elsif Has_Dynamic_Predicate_Aspect (Typ) then
+ return False;
+
-- String types
elsif Is_String_Type (Typ) then
-- 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
-- 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
-- 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
-- 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);
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
-- 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;
-- 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;
-- 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)
-- 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
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 "
projects / gcc.git / commitdiff