From 87feba051d2870479fab45d2a8671bc4e6d7817f Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 18 Apr 2016 12:46:40 +0200 Subject: [multiple changes] 2016-04-18 Hristian Kirtchev * namet.adb, namet.ads, exp_unst.adb: Minor reformatting. 2016-04-18 Hristian Kirtchev * 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 * sem_prag.adb (Analyze_Input_Item): Allow generic formals to appear as initialization items. 2016-04-18 Ed Schonberg * 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 * 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 --- gcc/ada/ChangeLog | 42 ++++++++++ gcc/ada/exp_ch6.adb | 45 +++++++++++ gcc/ada/exp_unst.adb | 5 +- gcc/ada/namet.adb | 22 ++++-- gcc/ada/namet.ads | 28 ++++--- gcc/ada/sem_ch12.adb | 51 ++++++------ gcc/ada/sem_ch12.ads | 16 ++-- gcc/ada/sem_ch13.adb | 19 ++++- gcc/ada/sem_ch6.adb | 5 +- gcc/ada/sem_eval.adb | 122 +++++++++++++++-------------- gcc/ada/sem_eval.ads | 215 ++++++++++++++++++++++++--------------------------- gcc/ada/sem_prag.adb | 10 ++- 12 files changed, 347 insertions(+), 233 deletions(-) (limited to 'gcc') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 96cac54..143a6a1 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,45 @@ +2016-04-18 Hristian Kirtchev + + * namet.adb, namet.ads, exp_unst.adb: Minor reformatting. + +2016-04-18 Hristian Kirtchev + + * 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 + + * sem_prag.adb (Analyze_Input_Item): Allow + generic formals to appear as initialization items. + +2016-04-18 Ed Schonberg + + * 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 + + * 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 * sem_prag.adb (Build_Pragma_Check_Equivalent): The mapping diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index bdde498..a72bbe1 100644 --- a/gcc/ada/exp_ch6.adb +++ b/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 diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index fbc6a7b..eed26e6 100644 --- a/gcc/ada/exp_unst.adb +++ b/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; diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb index 20359f6..4ba68df 100644 --- a/gcc/ada/namet.adb +++ b/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'); diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads index 873897f..1d00ee0c 100644 --- a/gcc/ada/namet.ads +++ b/gcc/ada/namet.ads @@ -152,10 +152,10 @@ package Namet is 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. @@ -167,8 +167,8 @@ package Namet is -- 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 @@ -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. diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index b6256e1..5508c9b 100644 --- a/gcc/ada/sem_ch12.adb +++ b/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 diff --git a/gcc/ada/sem_ch12.ads b/gcc/ada/sem_ch12.ads index faf8917..c95396a 100644 --- a/gcc/ada/sem_ch12.ads +++ b/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; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 688861e..cb7eb8f 100644 --- a/gcc/ada/sem_ch13.adb +++ b/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; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 0e03ff6..343fbe6 100644 --- a/gcc/ada/sem_ch6.adb +++ b/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)))) = diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 3f7e97b..67d464c 100644 --- a/gcc/ada/sem_eval.adb +++ b/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 @@ -635,9 +646,9 @@ package body Sem_Eval is 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 @@ -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 @@ -671,15 +681,14 @@ package body Sem_Eval is 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; @@ -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 diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads index 7f206e7..b59fb6c 100644 --- a/gcc/ada/sem_eval.ads +++ b/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 diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index c55054b..c753e61 100644 --- a/gcc/ada/sem_prag.adb +++ b/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 " -- cgit v1.1