From 74e7891f8d73153b50beebbd497d69b18fc8cb24 Mon Sep 17 00:00:00 2001 From: Robert Dewar Date: Tue, 22 Jun 2010 07:26:02 +0000 Subject: [PATCH] g-expect-vms.adb, [...]: Minor reformatting. 2010-06-22 Robert Dewar * g-expect-vms.adb, sem_res.adb: Minor reformatting. * exp_aggr.adb: Minor comment changes and reformatting. * sem_eval.adb (Find_Universal_Operator_Type): Put in proper alpha order * sem_util.ads: Add some missing pragma Inline's (efficiency issue only) From-SVN: r161139 --- gcc/ada/ChangeLog | 7 + gcc/ada/exp_aggr.adb | 5 +- gcc/ada/g-expect-vms.adb | 4 +- gcc/ada/sem_eval.adb | 270 +++++++++++++++++++-------------------- gcc/ada/sem_res.adb | 8 +- gcc/ada/sem_util.ads | 1 + 6 files changed, 154 insertions(+), 141 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 76c3f151827b..bc310e38c51f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,10 @@ +2010-06-22 Robert Dewar + + * g-expect-vms.adb, sem_res.adb: Minor reformatting. + * exp_aggr.adb: Minor comment changes and reformatting. + * sem_eval.adb (Find_Universal_Operator_Type): Put in proper alpha order + * sem_util.ads: Add some missing pragma Inline's (efficiency issue only) + 2010-06-22 Thomas Quinot * sem_util.adb (Build_Actual_Subtype): Record original expression in diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index c15b92282e3e..9345da2f56bf 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -176,8 +176,9 @@ package body Exp_Aggr is -- Very large static aggregates present problems to the back-end, and are -- transformed into assignments and loops. This function verifies that the -- total number of components of an aggregate is acceptable for rewriting - -- into a purely positional static form. It is called prior to calling - -- Flatten. + -- into a purely positional static form. Aggr_Size_OK must be called before + -- calling Flatten. + -- -- This function also detects and warns about one-component aggregates that -- appear in a non-static context. Even if the component value is static, -- such an aggregate must be expanded into an assignment. diff --git a/gcc/ada/g-expect-vms.adb b/gcc/ada/g-expect-vms.adb index d92e1e7783ef..4d1a770822ae 100644 --- a/gcc/ada/g-expect-vms.adb +++ b/gcc/ada/g-expect-vms.adb @@ -524,6 +524,7 @@ package body GNAT.Expect is for J in Descriptors'Range loop Descriptors (J) := Regexps (J).Descriptor; + if Descriptors (J) /= null then Reinitialize_Buffer (Regexps (J).Descriptor.all); end if; @@ -775,7 +776,8 @@ package body GNAT.Expect is ------------------------ function First_Dead_Process - (Regexp : Multiprocess_Regexp_Array) return Natural is + (Regexp : Multiprocess_Regexp_Array) return Natural + is begin for R in Regexp'Range loop if Regexp (R).Descriptor /= null diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index fb17144b668c..11fba8e7a3a5 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -3763,6 +3763,141 @@ package body Sem_Eval is end if; end Expr_Value_S; + ---------------------------------- + -- Find_Universal_Operator_Type -- + ---------------------------------- + + function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id is + PN : constant Node_Id := Parent (N); + Call : constant Node_Id := Original_Node (N); + Is_Int : constant Boolean := Is_Integer_Type (Etype (N)); + + Is_Fix : constant Boolean := + Nkind (N) in N_Binary_Op + and then Nkind (Right_Opnd (N)) /= Nkind (Left_Opnd (N)); + -- A mixed-mode operation in this context indicates the presence of + -- fixed-point type in the designated package. + + Is_Relational : constant Boolean := Etype (N) = Standard_Boolean; + -- Case where N is a relational (or membership) operator (else it is an + -- arithmetic one). + + In_Membership : constant Boolean := + Nkind (PN) in N_Membership_Test + and then + Nkind (Right_Opnd (PN)) = N_Range + and then + Is_Universal_Numeric_Type (Etype (Left_Opnd (PN))) + and then + Is_Universal_Numeric_Type + (Etype (Low_Bound (Right_Opnd (PN)))) + and then + Is_Universal_Numeric_Type + (Etype (High_Bound (Right_Opnd (PN)))); + -- Case where N is part of a membership test with a universal range + + E : Entity_Id; + Pack : Entity_Id; + Typ1 : Entity_Id := Empty; + Priv_E : Entity_Id; + + function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean; + -- Check whether one operand is a mixed-mode operation that requires + -- the presence of a fixed-point type. Given that all operands are + -- universal and have been constant-folded, retrieve the original + -- function call. + + --------------------------- + -- Is_Mixed_Mode_Operand -- + --------------------------- + + function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean is + begin + return Nkind (Original_Node (Op)) = N_Function_Call + and then Present (Next_Actual (First_Actual (Original_Node (Op)))) + and then Etype (First_Actual (Original_Node (Op))) /= + Etype (Next_Actual (First_Actual (Original_Node (Op)))); + end Is_Mixed_Mode_Operand; + + begin + if Nkind (Call) /= N_Function_Call + or else Nkind (Name (Call)) /= N_Expanded_Name + then + return Empty; + + -- There are two cases where the context does not imply the type of the + -- operands: either the universal expression appears in a type + -- type conversion, or we are in the case of a predefined relational + -- operator, where the context type is always Boolean. + + elsif Nkind (Parent (N)) = N_Type_Conversion + or else + Is_Relational + or else + In_Membership + then + Pack := Entity (Prefix (Name (Call))); + + -- If the prefix is a package declared elsewhere, iterate over + -- its visible entities, otherwise iterate over all declarations + -- in the designated scope. + + if Ekind (Pack) = E_Package + and then not In_Open_Scopes (Pack) + then + Priv_E := First_Private_Entity (Pack); + else + Priv_E := Empty; + end if; + + Typ1 := Empty; + E := First_Entity (Pack); + while Present (E) and then E /= Priv_E loop + if Is_Numeric_Type (E) + and then Nkind (Parent (E)) /= N_Subtype_Declaration + and then Comes_From_Source (E) + and then Is_Integer_Type (E) = Is_Int + and then + (Nkind (N) in N_Unary_Op + or else Is_Relational + or else Is_Fixed_Point_Type (E) = Is_Fix) + then + if No (Typ1) then + Typ1 := E; + + -- Before emitting an error, check for the presence of a + -- mixed-mode operation that specifies a fixed point type. + + elsif Is_Relational + and then + (Is_Mixed_Mode_Operand (Left_Opnd (N)) + or else Is_Mixed_Mode_Operand (Right_Opnd (N))) + and then Is_Fixed_Point_Type (E) /= Is_Fixed_Point_Type (Typ1) + + then + if Is_Fixed_Point_Type (E) then + Typ1 := E; + end if; + + else + -- More than one type of the proper class declared in P + + Error_Msg_N ("ambiguous operation", N); + Error_Msg_Sloc := Sloc (Typ1); + Error_Msg_N ("\possible interpretation (inherited)#", N); + Error_Msg_Sloc := Sloc (E); + Error_Msg_N ("\possible interpretation (inherited)#", N); + return Empty; + end if; + end if; + + Next_Entity (E); + end loop; + end if; + + return Typ1; + end Find_Universal_Operator_Type; + -------------------------- -- Flag_Non_Static_Expr -- -------------------------- @@ -4761,141 +4896,6 @@ package body Sem_Eval is end if; end Test; - ---------------------------------- - -- Find_Universal_Operator_Type -- - ---------------------------------- - - function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id is - PN : constant Node_Id := Parent (N); - Call : constant Node_Id := Original_Node (N); - Is_Int : constant Boolean := Is_Integer_Type (Etype (N)); - - Is_Fix : constant Boolean := - Nkind (N) in N_Binary_Op - and then Nkind (Right_Opnd (N)) /= Nkind (Left_Opnd (N)); - -- A mixed-mode operation in this context indicates the presence of - -- fixed-point type in the designated package. - - Is_Relational : constant Boolean := Etype (N) = Standard_Boolean; - -- Case where N is a relational (or membership) operator (else it is an - -- arithmetic one). - - In_Membership : constant Boolean := - Nkind (PN) in N_Membership_Test - and then - Nkind (Right_Opnd (PN)) = N_Range - and then - Is_Universal_Numeric_Type (Etype (Left_Opnd (PN))) - and then - Is_Universal_Numeric_Type - (Etype (Low_Bound (Right_Opnd (PN)))) - and then - Is_Universal_Numeric_Type - (Etype (High_Bound (Right_Opnd (PN)))); - -- Case where N is part of a membership test with a universal range - - E : Entity_Id; - Pack : Entity_Id; - Typ1 : Entity_Id := Empty; - Priv_E : Entity_Id; - - function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean; - -- Check whether one operand is a mixed-mode operation that requires - -- the presence of a fixed-point type. Given that all operands are - -- universal and have been constant-folded, retrieve the original - -- function call. - - --------------------------- - -- Is_Mixed_Mode_Operand -- - --------------------------- - - function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean is - begin - return Nkind (Original_Node (Op)) = N_Function_Call - and then Present (Next_Actual (First_Actual (Original_Node (Op)))) - and then Etype (First_Actual (Original_Node (Op))) /= - Etype (Next_Actual (First_Actual (Original_Node (Op)))); - end Is_Mixed_Mode_Operand; - - begin - if Nkind (Call) /= N_Function_Call - or else Nkind (Name (Call)) /= N_Expanded_Name - then - return Empty; - - -- There are two cases where the context does not imply the type of the - -- operands: either the universal expression appears in a type - -- type conversion, or we are in the case of a predefined relational - -- operator, where the context type is always Boolean. - - elsif Nkind (Parent (N)) = N_Type_Conversion - or else - Is_Relational - or else - In_Membership - then - Pack := Entity (Prefix (Name (Call))); - - -- If the prefix is a package declared elsewhere, iterate over - -- its visible entities, otherwise iterate over all declarations - -- in the designated scope. - - if Ekind (Pack) = E_Package - and then not In_Open_Scopes (Pack) - then - Priv_E := First_Private_Entity (Pack); - else - Priv_E := Empty; - end if; - - Typ1 := Empty; - E := First_Entity (Pack); - while Present (E) and then E /= Priv_E loop - if Is_Numeric_Type (E) - and then Nkind (Parent (E)) /= N_Subtype_Declaration - and then Comes_From_Source (E) - and then Is_Integer_Type (E) = Is_Int - and then - (Nkind (N) in N_Unary_Op - or else Is_Relational - or else Is_Fixed_Point_Type (E) = Is_Fix) - then - if No (Typ1) then - Typ1 := E; - - -- Before emitting an error, check for the presence of a - -- mixed-mode operation that specifies a fixed point type. - - elsif Is_Relational - and then - (Is_Mixed_Mode_Operand (Left_Opnd (N)) - or else Is_Mixed_Mode_Operand (Right_Opnd (N))) - and then Is_Fixed_Point_Type (E) /= Is_Fixed_Point_Type (Typ1) - - then - if Is_Fixed_Point_Type (E) then - Typ1 := E; - end if; - - else - -- More than one type of the proper class declared in P - - Error_Msg_N ("ambiguous operation", N); - Error_Msg_Sloc := Sloc (Typ1); - Error_Msg_N ("\possible interpretation (inherited)#", N); - Error_Msg_Sloc := Sloc (E); - Error_Msg_N ("\possible interpretation (inherited)#", N); - return Empty; - end if; - end if; - - Next_Entity (E); - end loop; - end if; - - return Typ1; - end Find_Universal_Operator_Type; - --------------------------------- -- Test_Expression_Is_Foldable -- --------------------------------- diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index a6b9d3a05496..c3be8b533680 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -5083,13 +5083,15 @@ package body Sem_Res is Expressions => Parameter_Associations (N)); end if; + -- Preserve the parenthesis count of the node + + Set_Paren_Count (Index_Node, Paren_Count (N)); + -- Since we are correcting a node classification error made -- by the parser, we call Replace rather than Rewrite. - -- Preserve the parenthesis count of the node, for use by - -- tools. - Set_Paren_Count (Index_Node, Paren_Count (N)); Replace (N, Index_Node); + Set_Etype (Prefix (N), Ret_Type); Set_Etype (N, Typ); Resolve_Indexed_Component (N, Typ); diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 1df648d43b28..2720b4e12322 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -801,6 +801,7 @@ package Sem_Util is -- function simply tests if it is True (i.e. non-zero) function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean; + pragma Inline (Is_Universal_Numeric_Type); -- True if T is Universal_Integer or Universal_Real function Is_Value_Type (T : Entity_Id) return Boolean; -- 2.43.5