From: Yannick Moy Date: Tue, 2 Aug 2011 09:07:35 +0000 (+0000) Subject: sem_aggr.adb (Resolve_Aggregate): disable incorrectly placed check in formal mode X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=bd434b3fbacdb26b874313ff225345cbaf17940a;p=gcc.git sem_aggr.adb (Resolve_Aggregate): disable incorrectly placed check in formal mode 2011-08-02 Yannick Moy * sem_aggr.adb (Resolve_Aggregate): disable incorrectly placed check in formal mode * sem_util.adb (Matching_Static_Array_Bounds): proper detection of matching static array bounds, taking into account the special case of string literals * sem_ch3.adb: Typo in comment. From-SVN: r177100 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 19849b307e3..0f7b14fb5ed 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,12 @@ +2011-08-02 Yannick Moy + + * sem_aggr.adb (Resolve_Aggregate): disable incorrectly placed check in + formal mode + * sem_util.adb (Matching_Static_Array_Bounds): proper detection of + matching static array bounds, taking into account the special case of + string literals + * sem_ch3.adb: Typo in comment. + 2011-08-02 Yannick Moy * errout.adb, errout.ads (Check_Formal_Restriction): new procedure diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 1b934946256..82025542ef6 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -1112,12 +1112,16 @@ package body Sem_Aggr is Check_Formal_Restriction ("array aggregate should have only OTHERS", N); end if; - elsif not (Nkind (Parent (N)) = N_Aggregate - and then Is_Array_Type (Etype (Parent (N))) - and then Number_Dimensions (Etype (Parent (N))) > 1) - then - Check_Formal_Restriction - ("array aggregate should be qualified", N); + + -- The following check is disabled until a proper place is + -- found where the type of the parent node can be inspected. + +-- elsif not (Nkind (Parent (N)) = N_Aggregate +-- and then Is_Array_Type (Etype (Parent (N))) +-- and then Number_Dimensions (Etype (Parent (N))) > 1) +-- then +-- Check_Formal_Restriction +-- ("array aggregate should be qualified", N); else null; end if; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index e468e1d7c40..bb1552a6dbc 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -11515,7 +11515,7 @@ package body Sem_Ch3 is (Nkind (S) = N_Attribute_Reference and then Attribute_Name (S) = Name_Range) then - -- A Range attribute will transformed into N_Range by Resolve + -- A Range attribute will be transformed into N_Range by Resolve Analyze (S); Set_Etype (S, T); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index e69b0946edc..964b3f83210 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -9,7 +9,7 @@ -- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU Genconflieral Public License as published by the Free Soft- -- +-- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- @@ -8013,8 +8013,10 @@ package body Sem_Util is R_Index : Node_Id; L_Low : Node_Id; L_High : Node_Id; + L_Len : Uint; R_Low : Node_Id; R_High : Node_Id; + R_Len : Uint; begin if L_Ndims /= R_Ndims then @@ -8027,18 +8029,65 @@ package body Sem_Util is return False; end if; - L_Index := First_Index (L_Typ); - R_Index := First_Index (R_Typ); + -- First treat specially the first dimension, as the lower bound and + -- length of string literals are not stored like those of arrays. - -- There may not be an index available even if the type is constrained, - -- see for example 0100-C23 when this function is called from - -- Resolve_Qualified_Expression. Temporarily return False in that case. + if Ekind (L_Typ) = E_String_Literal_Subtype then + L_Low := String_Literal_Low_Bound (L_Typ); + L_Len := String_Literal_Length (L_Typ); + else + L_Index := First_Index (L_Typ); + Get_Index_Bounds (L_Index, L_Low, L_High); + + if Is_OK_Static_Expression (L_Low) + and then Is_OK_Static_Expression (L_High) + then + if Expr_Value (L_High) < Expr_Value (L_Low) then + L_Len := Uint_0; + else + L_Len := (Expr_Value (L_High) - Expr_Value (L_Low)) + 1; + end if; + else + return False; + end if; + end if; - if No (L_Index) or else No (R_Index) then + if Ekind (R_Typ) = E_String_Literal_Subtype then + R_Low := String_Literal_Low_Bound (R_Typ); + R_Len := String_Literal_Length (R_Typ); + else + R_Index := First_Index (R_Typ); + Get_Index_Bounds (R_Index, R_Low, R_High); + + if Is_OK_Static_Expression (R_Low) + and then Is_OK_Static_Expression (R_High) + then + if Expr_Value (R_High) < Expr_Value (R_Low) then + R_Len := Uint_0; + else + R_Len := (Expr_Value (R_High) - Expr_Value (R_Low)) + 1; + end if; + else + return False; + end if; + end if; + + if Is_OK_Static_Expression (L_Low) + and then Is_OK_Static_Expression (R_Low) + and then Expr_Value (L_Low) = Expr_Value (R_Low) + and then L_Len = R_Len + then + null; + else return False; end if; - for Indx in 1 .. L_Ndims loop + -- Then treat all other dimensions + + for Indx in 2 .. L_Ndims loop + Next (L_Index); + Next (R_Index); + Get_Index_Bounds (L_Index, L_Low, L_High); Get_Index_Bounds (R_Index, R_Low, R_High); @@ -8049,9 +8098,7 @@ package body Sem_Util is and then Expr_Value (L_Low) = Expr_Value (R_Low) and then Expr_Value (L_High) = Expr_Value (R_High) then - Next (L_Index); - Next (R_Index); - + null; else return False; end if;