diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 20 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_aggr.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 98 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_eval.adb | 13 |
7 files changed, 97 insertions, 52 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 47f60b5..2066c1f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,23 @@ +2015-10-26 Javier Miranda <miranda@adacore.com> + + * exp_aggr.adb (Aggr_Assignment_OK_For_Backend): Return False when + generating C code. + * sem_ch3.adb: Fix typos. + +2015-10-26 Bob Duff <duff@adacore.com> + + * sem_ch13.adb (Build_Predicate_Functions): Change the + structure of the predicate functions to reflect the requirements + of AI12-0071. + (Add_Condition): New procedure to do the "and-then-ing" in Add_Call + and Add_Predicates. + * einfo.ads (Static_Real_Or_String_Predicate): Change the + documentation to reflect the new structure. + * sem_eval.adb (Real_Or_String_Static_Predicate_Matches): + Change the walking of the predicate expression to reflect the + new structure. + * exp_util.adb: Minor comment fix. + 2015-10-26 Bob Duff <duff@adacore.com> * s-rident.ads (No_Dynamic_Sized_Objects): New restriction name. diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index a827514..ae4ad47 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -4149,7 +4149,7 @@ package Einfo is -- 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)) +-- xxxPredicate (typ2 (ent)) AND THEN expression -- -- where typ2 is the type from which the predicate is inherited, ent is -- the entity for the current predicate function, and xxxPredicate is the diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 5266bca..53f1c91 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -4105,6 +4105,8 @@ package body Exp_Aggr is -- Backend processing by Gigi/gcc is possible only if all the following -- conditions are met: + -- 0. We are not generating C code + -- 1. N consists of a single OTHERS choice, possibly recursively -- 2. The array type is not packed @@ -4135,6 +4137,10 @@ package body Exp_Aggr is Nunits : Nat; begin + if Generate_C_Code then + return False; + end if; + -- Recurse as far as possible to find the innermost component type Ctyp := Etype (N); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 73fb9b8..aec7320 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -3860,10 +3860,10 @@ package body Exp_Util is -- caller. Note that in the subexpression case, N is always the child we -- came from. - -- N_Raise_xxx_Error is an annoying special case, it is a statement if - -- it has type Standard_Void_Type, and a subexpression otherwise. - -- otherwise. Procedure calls, and similarly procedure attribute - -- references, are also statements. + -- N_Raise_xxx_Error is an annoying special case, it is a statement + -- if it has type Standard_Void_Type, and a subexpression otherwise. + -- Procedure calls, and similarly procedure attribute references, are + -- also statements. if Nkind (Assoc_Node) in N_Subexpr and then (Nkind (Assoc_Node) not in N_Raise_xxx_Error diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index cf2ba43..d187023 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -8340,10 +8340,10 @@ package body Sem_Ch13 is -- function typPredicate (Ixxx : typ) return Boolean is -- begin -- return - -- exp1 and then exp2 and then ... - -- and then typ1Predicate (typ1 (Ixxx)) + -- typ1Predicate (typ1 (Ixxx)) -- and then typ2Predicate (typ2 (Ixxx)) -- and then ...; + -- exp1 and then exp2 and then ... -- end typPredicate; -- Here exp1, and exp2 are expressions from Predicate pragmas. Note that @@ -8352,6 +8352,12 @@ package body Sem_Ch13 is -- inherited. Note that we do NOT generate Check pragmas, that's because we -- use this function even if checks are off, e.g. for membership tests. + -- Note that the inherited predicates are evaluated first, as required by + -- AI12-0071-1. + + -- Note that Sem_Eval.Real_Or_String_Static_Predicate_Matches depends on + -- the form of this return expression. + -- If the expression has at least one Raise_Expression, then we also build -- the typPredicateM version of the function, in which any occurrence of a -- Raise_Expression is converted to "return False". @@ -8384,9 +8390,9 @@ package body Sem_Ch13 is Raise_Expression_Present : Boolean := False; -- Set True if Expr has at least one Raise_Expression - procedure Add_Call (T : Entity_Id); - -- Includes a call to the predicate function for type T in Expr if T - -- has predicates and Predicate_Function (T) is non-empty. + procedure Add_Condition (Cond : Node_Id); + -- Append Cond to Expr using "and then" (or just copy Cond to Expr if + -- Expr is empty). procedure Add_Predicates; -- Appends expressions for any Predicate pragmas in the rep item chain @@ -8394,6 +8400,10 @@ package body Sem_Ch13 is -- Inheritance of predicates for the parent type is done by calling the -- Predicate_Function of the parent type, using Add_Call above. + procedure Add_Call (T : Entity_Id); + -- Includes a call to the predicate function for type T in Expr if T + -- has predicates and Predicate_Function (T) is non-empty. + function Process_RE (N : Node_Id) return Traverse_Result; -- Used in Process REs, tests if node N is a raise expression, and if -- so, marks it to be converted to return False. @@ -8425,17 +8435,9 @@ package body Sem_Ch13 is Make_Predicate_Call (T, Convert_To (T, Make_Identifier (Loc, Object_Name))); - -- Add call to evolving expression, using AND THEN if needed + -- "and"-in the call to evolving expression - if No (Expr) then - Expr := Exp; - - else - Expr := - Make_And_Then (Sloc (Expr), - Left_Opnd => Relocate_Node (Expr), - Right_Opnd => Exp); - end if; + Add_Condition (Exp); -- Output info message on inheritance if required. Note we do not -- give this information for generic actual types, since it is @@ -8456,6 +8458,28 @@ package body Sem_Ch13 is end if; end Add_Call; + ------------------- + -- Add_Condition -- + ------------------- + + procedure Add_Condition (Cond : Node_Id) is + begin + -- This is the first predicate expression + + if No (Expr) then + Expr := Cond; + + -- Otherwise concatenate to the existing predicate expressions by + -- using "and then". + + else + Expr := + Make_And_Then (Loc, + Left_Opnd => Relocate_Node (Expr), + Right_Opnd => Cond); + end if; + end Add_Condition; + -------------------- -- Add_Predicates -- -------------------- @@ -8535,24 +8559,12 @@ package body Sem_Ch13 is -- Check_Aspect_At_xxx routines. if Present (Asp) then - Set_Entity (Identifier (Asp), New_Copy_Tree (Arg2)); end if; - -- Concatenate to the existing predicate expressions by using - -- "and then". - - if Present (Expr) then - Expr := - Make_And_Then (Loc, - Left_Opnd => Relocate_Node (Expr), - Right_Opnd => Relocate_Node (Arg2)); - - -- Otherwise this is the first predicate expression + -- "and"-in the Arg2 condition to evolving expression - else - Expr := Relocate_Node (Arg2); - end if; + Add_Condition (Relocate_Node (Arg2)); end if; end Add_Predicate; @@ -8627,11 +8639,8 @@ package body Sem_Ch13 is Expr := Empty; - -- Add Predicates for the current type - - Add_Predicates; - - -- Add predicates for ancestor if present + -- Add predicates for ancestor if present. These must come before the + -- ones for the current type, as required by AI12-0071-1. declare Atyp : constant Entity_Id := Nearest_Ancestor (Typ); @@ -8641,6 +8650,10 @@ package body Sem_Ch13 is end if; end; + -- Add Predicates for the current type + + Add_Predicates; + -- Case where predicates are present if Present (Expr) then @@ -8955,13 +8968,18 @@ package body Sem_Ch13 is -- First a little fiddling to get a nice location for the -- message. If the expression is of the form (A and then B), - -- then use the left operand for the Sloc. This avoids getting - -- confused by a call to a higher-level predicate with a less - -- convenient source location. + -- where A is an inherited predicate, then use the right + -- operand for the Sloc. This avoids getting confused by a call + -- to an inherited predicate with a less convenient source + -- location. EN := Expr; - while Nkind (EN) = N_And_Then loop - EN := Left_Opnd (EN); + while Nkind (EN) = N_And_Then + and then Nkind (Left_Opnd (EN)) = N_Function_Call + and then Is_Predicate_Function + (Entity (Name (Left_Opnd (EN)))) + loop + EN := Right_Opnd (EN); end loop; -- Now post appropriate message @@ -11688,7 +11706,7 @@ package body Sem_Ch13 is -- references to inherited predicates, so that the expression we are -- processing looks like: - -- expression and then xxPredicate (typ (Inns)) + -- xxPredicate (typ (Inns)) and then expression -- Where the call is to a Predicate function for an inherited predicate. -- We simply ignore such a call, which could be to either a dynamic or diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index be43736..9b5f5da 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -3278,7 +3278,7 @@ package body Sem_Ch3 is -- task type is declared. Its function is to count the static number of -- tasks declared within the type (it is only called if Has_Tasks is set -- for T). As a side effect, if an array of tasks with non-static bounds - -- or a variant record type is encountered, Check_Restrictions is called + -- or a variant record type is encountered, Check_Restriction is called -- indicating the count is unknown. function Delayed_Aspect_Present return Boolean; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index c4fe768..5110f16 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -5408,13 +5408,14 @@ package body Sem_Eval is -- First deal with special case of inherited predicate, where the -- predicate expression looks like: - -- Expr and then xxPredicate (typ (Ent)) + -- xxPredicate (typ (Ent)) and then Expr -- where Expr is the predicate expression for this level, and the - -- right operand is the call to evaluate the inherited predicate. + -- left operand is the call to evaluate the inherited predicate. if Nkind (Expr) = N_And_Then - and then Nkind (Right_Opnd (Expr)) = N_Function_Call + and then Nkind (Left_Opnd (Expr)) = N_Function_Call + and then Is_Predicate_Function (Entity (Name (Left_Opnd (Expr)))) then -- OK we have the inherited case, so make a call to evaluate the -- inherited predicate. If that fails, so do we! @@ -5422,14 +5423,14 @@ package body Sem_Eval is if not Real_Or_String_Static_Predicate_Matches (Val => Val, - Typ => Etype (First_Formal (Entity (Name (Right_Opnd (Expr)))))) + Typ => Etype (First_Formal (Entity (Name (Left_Opnd (Expr)))))) then return False; end if; - -- Use the left operand for the continued processing + -- Use the right operand for the continued processing - Copy := Copy_Separate_Tree (Left_Opnd (Expr)); + Copy := Copy_Separate_Tree (Right_Opnd (Expr)); -- Case where call to predicate function appears on its own (this means -- that the predicate at this level is just inherited from the parent). |