diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e598c0cdd67..9aa5cb098ca 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,16 @@ +2014-07-29 Robert Dewar + + * einfo.ads, einfo.adb (Static_Real_Or_String_Predicate): New function + (Set_Static_Real_Or_String_Predicate): New procedure + * sem_ch13.adb (Build_Predicate_Functions): Accomodate static + string predicates (Is_Predicate_Static): Handle static string + predicates. + * sem_eval.adb (Real_Or_String_Static_Predicate_Matches): + New procedure (Check_Expression_Against_Static_Predicate): + Deal with static string predicates, now fully implemented + (Eval_Relational_Op): Allow string equality/inequality as static + if not comes from source. + 2014-07-29 Robert Dewar * sem_aggr.adb, exp_ch5.adb, sem_ch5.adb, exp_util.adb, einfo.adb, diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index ac624123bb1..5da314a9ea4 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -223,6 +223,7 @@ package body Einfo is -- PPC_Wrapper Node25 -- Related_Array_Object Node25 -- Static_Discrete_Predicate List25 + -- Static_Real_Or_String_Predicate Node25 -- Task_Body_Procedure Node25 -- Dispatch_Table_Wrappers Elist26 @@ -2977,6 +2978,12 @@ package body Einfo is return List25 (Id); end Static_Discrete_Predicate; + function Static_Real_Or_String_Predicate (Id : E) return N is + begin + pragma Assert (Is_Real_Type (Id) or else Is_String_Type (Id)); + return Node25 (Id); + end Static_Real_Or_String_Predicate; + function Status_Flag_Or_Transient_Decl (Id : E) return N is begin pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); @@ -5767,6 +5774,13 @@ package body Einfo is Set_List25 (Id, V); end Set_Static_Discrete_Predicate; + procedure Set_Static_Real_Or_String_Predicate (Id : E; V : N) is + begin + pragma Assert ((Is_Real_Type (Id) or else Is_String_Type (Id)) + and then Has_Predicates (Id)); + Set_Node25 (Id, V); + end Set_Static_Real_Or_String_Predicate; + procedure Set_Status_Flag_Or_Transient_Decl (Id : E; V : E) is begin pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); @@ -9399,13 +9413,12 @@ package body Einfo is E_Entry_Family => Write_Str ("PPC_Wrapper"); - when E_Enumeration_Type | - E_Enumeration_Subtype | - E_Modular_Integer_Type | - E_Modular_Integer_Subtype | - E_Signed_Integer_Subtype => + when Discrete_Kind => Write_Str ("Static_Discrete_Predicate"); + when Real_Kind => + Write_Str ("Static_Real_Or_String_Predicate"); + when others => Write_Str ("Field25??"); end case; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index d6f7d7dd6de..41f134cd03d 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -3899,7 +3899,7 @@ package Einfo is -- Static_Discrete_Predicate (List25) -- Defined in discrete types/subtypes with static predicates (with the --- two flags Has_Predicates set and Has_Static_Predicate set). Set if the +-- two flags Has_Predicates and Has_Static_Predicate set). Set if the -- type/subtype has a static predicate. Points to a list of expression -- and N_Range nodes that represent the predicate in canonical form. The -- canonical form has entries sorted in ascending order, with duplicates @@ -3908,6 +3908,26 @@ package Einfo is -- are fully analyzed and typed with the base type of the subtype. Note -- that all entries are static and have values within the subtype range. +-- Static_Real_Or_String_Predicate (Node25) +-- Defined in real types/subtypes with static predicates (with the two +-- flags Has_Predicates and Has_Static_Predicate set). Set if the type +-- or subtype has a static predicate. Points to the return expression +-- of the predicate function. This is the original expression given as +-- the predicate except that occurrences of the type are replaced by +-- occurrences of the formal parameter of the predicate function (note +-- that the spec of this function including this formal parameter name) +-- is available from the Subprograms_For_Type field (it can be accessed +-- as Predicate_Function (typ). Also, in the case where a predicate is +-- inherited, the expression is of the form: +-- +-- expression AND THEN xxxPredicate (typ2 (ent)) +-- +-- where typ2 is the type from which the predicate is inherited, ent is +-- the entity for the current predicate function, and xxxPredicate is the +-- inherited predicate (from typ2). Finally for a predicate that inherits +-- from another predicate but does not add a predicate of its own, the +-- expression may consist of the above xxxPredicate call on its own. + -- Status_Flag_Or_Transient_Decl (Node15) -- Defined in variables and constants. Applies to objects that require -- special treatment by the finalization machinery, such as extended @@ -5452,6 +5472,7 @@ package Einfo is -- Scalar_Range (Node20) -- Delta_Value (Ureal18) -- Small_Value (Ureal21) + -- Static_Real_Or_String_Predicate (Node25) -- Has_Machine_Radix_Clause (Flag83) -- Machine_Radix_10 (Flag84) -- Aft_Value (synth) @@ -5557,6 +5578,7 @@ package Einfo is -- Float_Rep (Uint10) (Float_Rep_Kind) -- Default_Aspect_Value (Node19) (base type only) -- Scalar_Range (Node20) + -- Static_Real_Or_String_Predicate (Node25) -- Machine_Emax_Value (synth) -- Machine_Emin_Value (synth) -- Machine_Mantissa_Value (synth) @@ -5777,6 +5799,7 @@ package Einfo is -- Delta_Value (Ureal18) -- Default_Aspect_Value (Node19) (base type only) -- Scalar_Range (Node20) + -- Static_Real_Or_String_Predicate (Node25) -- Small_Value (Ureal21) -- Has_Small_Clause (Flag67) -- Aft_Value (synth) @@ -6048,6 +6071,7 @@ package Einfo is -- E_String_Subtype -- First_Index (Node17) -- Component_Type (Node20) (base type only) + -- Static_Real_Or_String_Predicate (Node25) -- Is_Constrained (Flag12) -- Next_Index (synth) -- Number_Dimensions (synth) @@ -6791,6 +6815,7 @@ package Einfo is function Static_Elaboration_Desired (Id : E) return B; function Static_Initialization (Id : E) return N; function Static_Discrete_Predicate (Id : E) return S; + function Static_Real_Or_String_Predicate (Id : E) return N; function Status_Flag_Or_Transient_Decl (Id : E) return E; function Storage_Size_Variable (Id : E) return E; function Stored_Constraint (Id : E) return L; @@ -7425,6 +7450,7 @@ package Einfo is procedure Set_Static_Elaboration_Desired (Id : E; V : B); procedure Set_Static_Initialization (Id : E; V : N); procedure Set_Static_Discrete_Predicate (Id : E; V : S); + procedure Set_Static_Real_Or_String_Predicate (Id : E; V : N); procedure Set_Status_Flag_Or_Transient_Decl (Id : E; V : E); procedure Set_Storage_Size_Variable (Id : E; V : E); procedure Set_Stored_Constraint (Id : E; V : L); @@ -8209,6 +8235,7 @@ package Einfo is pragma Inline (Static_Elaboration_Desired); pragma Inline (Static_Initialization); pragma Inline (Static_Discrete_Predicate); + pragma Inline (Static_Real_Or_String_Predicate); pragma Inline (Status_Flag_Or_Transient_Decl); pragma Inline (Storage_Size_Variable); pragma Inline (Stored_Constraint); @@ -8642,6 +8669,7 @@ package Einfo is pragma Inline (Set_Static_Elaboration_Desired); pragma Inline (Set_Static_Initialization); pragma Inline (Set_Static_Discrete_Predicate); + pragma Inline (Set_Static_Real_Or_String_Predicate); pragma Inline (Set_Status_Flag_Or_Transient_Decl); pragma Inline (Set_Storage_Size_Variable); pragma Inline (Set_Stored_Constraint); diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index e0c67824a22..73dc3c5ec1e 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -8002,10 +8002,16 @@ package body Sem_Ch13 is -- yes even if we have an explicit Dynamic_Predicate present. declare - PS : constant Boolean := Is_Predicate_Static (Expr, Object_Name); + PS : Boolean; EN : Node_Id; begin + if not Is_Scalar_Type (Typ) and then not Is_String_Type (Typ) then + PS := False; + else + PS := Is_Predicate_Static (Expr, Object_Name); + end if; + -- Case where we have a predicate-static aspect if PS then @@ -8033,6 +8039,11 @@ package body Sem_Ch13 is if No (Static_Discrete_Predicate (Typ)) then Set_Has_Static_Predicate (Typ, False); end if; + + -- For real or string subtype, save predicate expression + + elsif Is_Real_Type (Typ) or else Is_String_Type (Typ) then + Set_Static_Real_Or_String_Predicate (Typ, Expr); end if; -- Case of dynamic predicate (expression is not predicate-static) @@ -8060,14 +8071,13 @@ package body Sem_Ch13 is -- Now post appropriate message if Has_Static_Predicate_Aspect (Typ) then - if Is_Scalar_Type (Typ) then + if Is_Scalar_Type (Typ) or else Is_String_Type (Typ) then Error_Msg_F ("expression is not predicate-static (RM 4.3.2(16-22))", EN); else - Error_Msg_FE - ("static predicate not allowed for non-scalar type&", - EN, Typ); + Error_Msg_F + ("static predicate requires scalar or string type", EN); end if; end if; end if; @@ -10362,6 +10372,9 @@ package body Sem_Ch13 is -- Is_Predicate_Static -- ------------------------- + -- Note: the basic legality of the expression has already been checked, so + -- we don't need to worry about cases or ranges on strings for example. + function Is_Predicate_Static (Expr : Node_Id; Nam : Name_Id) return Boolean @@ -10462,12 +10475,6 @@ package body Sem_Ch13 is -- Start of processing for Is_Predicate_Static begin - -- Only scalar types can be predicate-static - - if not Is_Scalar_Type (Etype (Expr)) then - return False; - end if; - -- Predicate_Static means one of the following holds. Numbers are the -- corresponding paragraph numbers in (RM 3.2.4(16-22)). @@ -10502,7 +10509,20 @@ package body Sem_Ch13 is -- operand is the current instance, and the other is a static -- expression. + -- Note: the RM is clearly wrong here in not excluding string types. + -- Without this exclusion, we would allow expressions like X > "ABC" + -- to be considered as predicate-static, which is clearly not intended, + -- since the idea is for predicate-static to be a subset of normal + -- static expressions (and "DEF" > "ABC" is not a static expression). + + -- However, we do allow internally generated (not from source) equality + -- and inequality operations to be valid on strings (this helps deal + -- with cases where we transform A in "ABC" to A = "ABC). + elsif Nkind (Expr) in N_Op_Compare + and then ((not Is_String_Type (Etype (Left_Opnd (Expr)))) + or else (Nkind_In (Expr, N_Op_Eq, N_Op_Ne) + and then not Comes_From_Source (Expr))) and then ((Is_Type_Ref (Left_Opnd (Expr)) and then Is_OK_Static_Expression (Right_Opnd (Expr))) or else diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 57152ae1bdf..44344ceaa5a 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -227,6 +227,16 @@ package body Sem_Eval is -- this is an illegality if N is static, and should generate a warning -- otherwise. + function Real_Or_String_Static_Predicate_Matches + (Val : Node_Id; + Typ : Entity_Id) return Boolean; + -- This is the function used to evaluate real or string static predicates. + -- Val is an unanalyzed N_Real_Literal or N_String_Literal node, which + -- represents the value to be tested against the predicate. Typ is the + -- type with the predicate, from which the predicate expression can be + -- extracted. The result returned is True if the given value satisfies + -- the predicate. + procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id); -- N and Exp are nodes representing an expression, Exp is known to raise -- CE. N is rewritten in term of Exp in the optimal way. @@ -339,23 +349,36 @@ package body Sem_Eval is -- an explicitly specified Dynamic_Predicate whose expression met the -- rules for being predicate-static). - -- If we are not generating code, nothing more to do (why???) + -- Case of real static predicate - if Operating_Mode < Generate_Code then - return; - end if; + if Is_Real_Type (Typ) then + if Real_Or_String_Static_Predicate_Matches + (Val => Make_Real_Literal (Sloc (Expr), Expr_Value_R (Expr)), + Typ => Typ) + then + return; + end if; - -- If we have the real case, then for now, not implemented + -- Case of string static predicate - if not Is_Discrete_Type (Typ) then - Error_Msg_N ("??real predicate not applied", Expr); - return; - end if; + elsif Is_String_Type (Typ) then + if Real_Or_String_Static_Predicate_Matches + (Val => Expr_Value_S (Expr), + Typ => Typ) + then + return; + end if; - -- If static predicate matches, nothing to do + -- Case of discrete static predicate - if Choices_Match (Expr, Static_Discrete_Predicate (Typ)) = Match then - return; + else + pragma Assert (Is_Discrete_Type (Typ)); + + -- If static predicate matches, nothing to do + + if Choices_Match (Expr, Static_Discrete_Predicate (Typ)) = Match then + return; + end if; end if; -- Here we know that the predicate will fail @@ -3052,6 +3075,10 @@ package body Sem_Eval is -- both operands are static (RM 4.9(7), 4.9(20)), except that for strings, -- the result is never static, even if the operands are. + -- However, for internally generated nodes, we allow string equality and + -- inequality to be static. This is because we rewrite A in "ABC" as an + -- equality test A = "ABC", and the former is definitely static. + procedure Eval_Relational_Op (N : Node_Id) is Left : constant Node_Id := Left_Opnd (N); Right : constant Node_Id := Right_Opnd (N); @@ -3289,9 +3316,16 @@ package body Sem_Eval is -- Only comparisons of scalars can give static results. In -- particular, comparisons of strings never yield a static - -- result, even if both operands are static strings. + -- result, even if both operands are static strings, except that + -- as noted above, we allow equality/inequality for strings. - if not Is_Scalar_Type (Typ) then + if Is_String_Type (Typ) + and then not Comes_From_Source (N) + and then Nkind_In (N, N_Op_Eq, N_Op_Ne) + then + null; + + elsif not Is_Scalar_Type (Typ) then Is_Static_Expression := False; Set_Is_Static_Expression (N, False); end if; @@ -3307,9 +3341,8 @@ package body Sem_Eval is Otype := Find_Universal_Operator_Type (N); end if; - -- For static real type expressions, we cannot use - -- Compile_Time_Compare since it worries about run-time - -- results which are not exact. + -- For static real type expressions, do not use Compile_Time_Compare + -- since it worries about run-time results which are not exact. if Is_Static_Expression and then Is_Real_Type (Typ) then declare @@ -5322,6 +5355,112 @@ package body Sem_Eval is end if; end Predicates_Match; + --------------------------------------------- + -- Real_Or_String_Static_Predicate_Matches -- + --------------------------------------------- + + function Real_Or_String_Static_Predicate_Matches + (Val : Node_Id; + Typ : Entity_Id) return Boolean + is + Expr : constant Node_Id := Static_Real_Or_String_Predicate (Typ); + -- The predicate expression from the type + + Pfun : constant Entity_Id := Predicate_Function (Typ); + -- The entity for the predicate function + + Ent_Name : constant Name_Id := Chars (First_Formal (Pfun)); + -- The name of the formal of the predicate function. Occurrences of the + -- type name in Expr have been rewritten as references to this formal, + -- and it has a unique name, so we can identify references by this name. + + Copy : Node_Id; + -- Copy of the predicate function tree + + function Process (N : Node_Id) return Traverse_Result; + -- Function used to process nodes during the traversal in which we will + -- find occurrences of the entity name, and replace such occurrences + -- by a real literal with the value to be tested. + + procedure Traverse is new Traverse_Proc (Process); + -- The actual traversal procedure + + ------------- + -- Process -- + ------------- + + function Process (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Identifier and then Chars (N) = Ent_Name then + declare + Nod : constant Node_Id := New_Copy (Val); + begin + Set_Sloc (Nod, Sloc (N)); + Rewrite (N, Nod); + return Skip; + end; + + else + return OK; + end if; + end Process; + + -- Start of processing for Real_Or_String_Static_Predicate_Matches + + begin + -- First deal with special case of inherited predicate, where the + -- predicate expression looks like: + + -- Expr and then xxPredicate (typ (Ent)) + + -- where Expr is the predicate expression for this level, and the + -- right operand is the call to evaluate the inherited predicate. + + if Nkind (Expr) = N_And_Then + and then Nkind (Right_Opnd (Expr)) = N_Function_Call + then + -- OK we have the inherited case, so make a call to evaluate the + -- inherited predicate. If that fails, so do we! + + if not + Real_Or_String_Static_Predicate_Matches + (Val => Val, + Typ => Etype (First_Formal (Entity (Name (Right_Opnd (Expr)))))) + then + return False; + end if; + + -- Use the left operand for the continued processing + + Copy := Copy_Separate_Tree (Left_Opnd (Expr)); + + -- Case where call to predicate function appears on its own + + elsif Nkind (Expr) = N_Function_Call then + + -- Here the result is just the result of calling the inner predicate + + return + Real_Or_String_Static_Predicate_Matches + (Val => Val, + Typ => Etype (First_Formal (Entity (Name (Expr))))); + + -- If no inherited predicate, copy whole expression + + else + Copy := Copy_Separate_Tree (Expr); + end if; + + -- Now we replace occurrences of the entity by the value + + Traverse (Copy); + + -- And analyze the resulting static expression to see if it is True + + Analyze_And_Resolve (Copy, Standard_Boolean); + return Is_True (Expr_Value (Copy)); + end Real_Or_String_Static_Predicate_Matches; + ------------------------- -- Rewrite_In_Raise_CE -- -------------------------