From: Arnaud Charlet Date: Wed, 3 Aug 2011 08:02:56 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=c0b118502029cede7f7fe9fa16bae5ff936ac461;p=gcc.git [multiple changes] 2011-08-03 Gary Dismukes * sem_aggr.adb (Analyze_Array_Aggregate): When checking the discrete choices of a named array aggregate, bail out when any choices are marked as Errors_Posted. 2011-08-03 Ed Schonberg * exp_ch13.adb (Expand_N_Freeze_Entity): cleanup determination of scope in which entity is frozen, to handle properly loop variables in iterators. 2011-08-03 Ed Schonberg * sem_res.adb (Set_String_Literal_Subtype): if the lower bound of the subtype is not static, compute the upper bound using attributes, to handle properly index types that are not integer types. 2011-08-03 Bob Duff * gnat_rm.texi, gnat_ugn.texi: Fix some dangling URLs. Update copyright notice. 2011-08-03 Ed Schonberg * sem_ch3.adb (Build_Discriminant_Constraints): Only use Original_Discriminant if within an instance. * sem_ch4.adb (Analyze_Selected_Component): Ditto. 2011-08-03 Thomas Quinot * einfo.ads: Minor reformatting. 2011-08-03 Ed Schonberg * exp_disp.adb (Check_Premature_Freezing): diagnose the presence of a composite type with an unfrozen subcomponent, in the profile of a primitive operation. From-SVN: r177236 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 47ec9bf44f7..2ce9de1811d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,42 @@ +2011-08-03 Gary Dismukes + + * sem_aggr.adb (Analyze_Array_Aggregate): When checking the discrete + choices of a named array aggregate, bail out when any choices are + marked as Errors_Posted. + +2011-08-03 Ed Schonberg + + * exp_ch13.adb (Expand_N_Freeze_Entity): cleanup determination of scope + in which entity is frozen, to handle properly loop variables in + iterators. + +2011-08-03 Ed Schonberg + + * sem_res.adb (Set_String_Literal_Subtype): if the lower bound of the + subtype is not static, compute the upper bound using attributes, to + handle properly index types that are not integer types. + +2011-08-03 Bob Duff + + * gnat_rm.texi, gnat_ugn.texi: Fix some dangling URLs. + Update copyright notice. + +2011-08-03 Ed Schonberg + + * sem_ch3.adb (Build_Discriminant_Constraints): Only use + Original_Discriminant if within an instance. + * sem_ch4.adb (Analyze_Selected_Component): Ditto. + +2011-08-03 Thomas Quinot + + * einfo.ads: Minor reformatting. + +2011-08-03 Ed Schonberg + + * exp_disp.adb (Check_Premature_Freezing): diagnose the presence of a + composite type with an unfrozen subcomponent, in the profile of a + primitive operation. + 2011-08-03 Robert Dewar * sem_util.ads, exp_aggr.adb, exp_ch3.adb: Minor reformatting. diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index d666b5f85fb..993094e19c7 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2426,11 +2426,11 @@ package Einfo is -- Thus this flag has no meaning to the back end. -- Is_Limited_Composite (Flag106) --- Present in all entities. Set for composite types that have a --- limited component. Used to enforce the rule that operations on --- the composite type that depend on the full view of the component --- do not become visible until the immediate scope of the composite --- type itself (RM 7.3.1 (5)). +-- Present in all entities. Set for composite types that have a limited +-- component. Used to enforce the rule that operations on the composite +-- type that depend on the full view of the component do not become +-- visible until the immediate scope of the composite type itself +-- (RM 7.3.1 (5)). -- Is_Limited_Interface (Flag197) -- Present in record types and subtypes. True for interface types, if diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index 39b32cec46d..dbf664c5bad 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- 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 General Public License as published by the Free Soft- -- @@ -43,7 +43,6 @@ with Sem_Eval; use Sem_Eval; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; -with Stand; use Stand; with Tbuild; use Tbuild; with Uintp; use Uintp; with Validsw; use Validsw; @@ -213,7 +212,6 @@ package body Exp_Ch13 is procedure Expand_N_Freeze_Entity (N : Node_Id) is E : constant Entity_Id := Entity (N); E_Scope : Entity_Id; - S : Entity_Id; In_Other_Scope : Boolean; In_Outer_Scope : Boolean; Decl : Node_Id; @@ -306,13 +304,18 @@ package body Exp_Ch13 is E_Scope := Corresponding_Spec (Unit_Declaration_Node (E_Scope)); end if; - S := Current_Scope; - while S /= Standard_Standard and then S /= E_Scope loop - S := Scope (S); - end loop; + -- If the scope of the entity is in open scopes, it is the current one + -- or an enclosing one, including a loop, a block, or a subprogram. - In_Other_Scope := not (S = E_Scope); - In_Outer_Scope := (not In_Other_Scope) and then (S /= Current_Scope); + if In_Open_Scopes (E_Scope) then + In_Other_Scope := False; + In_Outer_Scope := E_Scope /= Current_Scope; + + -- Otherwise it is a local package or a different compilation unit. + else + In_Other_Scope := True; + In_Outer_Scope := False; + end if; -- If the entity being frozen is defined in a scope that is not -- currently on the scope stack, we must establish the proper diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 85abeafdb13..69159632d50 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -3764,7 +3764,10 @@ package body Exp_Disp is DT_Aggr : constant Elist_Id := New_Elmt_List; -- Entities marked with attribute Is_Dispatch_Table_Entity - procedure Check_Premature_Freezing (Subp : Entity_Id; Typ : Entity_Id); + procedure Check_Premature_Freezing + (Subp : Entity_Id; + Tagged_Type : Entity_Id; + Typ : Entity_Id); -- Verify that all non-tagged types in the profile of a subprogram -- are frozen at the point the subprogram is frozen. This enforces -- the rule on RM 13.14 (14) as modified by AI05-019. At the point a @@ -3775,6 +3778,8 @@ package body Exp_Disp is -- Typical violation of the rule involves an object declaration that -- freezes a tagged type, when one of its primitive operations has a -- type in its profile whose full view has not been analyzed yet. + -- More complex cases involve composite types that have one private + -- unfrozen subcomponent. procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0); -- Export the dispatch table DT of tagged type Typ. Required to generate @@ -3814,10 +3819,15 @@ package body Exp_Disp is -- Check_Premature_Freezing -- ------------------------------ - procedure Check_Premature_Freezing (Subp : Entity_Id; Typ : Entity_Id) is + procedure Check_Premature_Freezing + (Subp : Entity_Id; + Tagged_Type : Entity_Id; + Typ : Entity_Id) + is + Comp : Entity_Id; begin if Present (N) - and then Is_Private_Type (Typ) + and then Is_Private_Type (Typ) and then No (Full_View (Typ)) and then not Is_Generic_Type (Typ) and then not Is_Tagged_Type (Typ) @@ -3828,8 +3838,26 @@ package body Exp_Disp is ("declaration must appear after completion of type &", N, Typ); Error_Msg_NE ("\which is an untagged type in the profile of" - & " primitive operation & declared#", - N, Subp); + & " primitive operation & declared#", N, Subp); + + else + Comp := Private_Component (Typ); + + if not Is_Tagged_Type (Typ) + and then Present (Comp) + and then not Is_Frozen (Comp) + then + Error_Msg_Sloc := Sloc (Subp); + Error_Msg_Node_2 := Subp; + Error_Msg_Name_1 := Chars (Tagged_Type); + Error_Msg_NE + ("declaration must appear after completion of type &", + N, Comp); + Error_Msg_NE + ("\which is a component of untagged type& in the profile of" + & " primitive & of type % that is frozen by the declaration ", + N, Typ); + end if; end if; end Check_Premature_Freezing; @@ -4587,11 +4615,11 @@ package body Exp_Disp is begin F := First_Formal (Prim); while Present (F) loop - Check_Premature_Freezing (Prim, Etype (F)); + Check_Premature_Freezing (Prim, Typ, Etype (F)); Next_Formal (F); end loop; - Check_Premature_Freezing (Prim, Etype (Prim)); + Check_Premature_Freezing (Prim, Typ, Etype (Prim)); end; if Present (Frnodes) then diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index cc3435b0581..670c23cf031 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -4285,9 +4285,8 @@ Integrity Systems}, and has been approved by ISO/IEC/SC22/WG9 for inclusion in the next revision of the standard. The formal definition given by the Ada Rapporteur Group (ARG) can be found in two Ada Issues (AI-249 and AI-305) available at -@url{http://www.ada-auth.org/cgi-bin/cvsweb.cgi/AIs/AI-00249.TXT} and -@url{http://www.ada-auth.org/cgi-bin/cvsweb.cgi/AIs/AI-00305.TXT} -respectively. +@url{http://www.ada-auth.org/cgi-bin/cvsweb.cgi/ais/ai-00249.txt} and +@url{http://www.ada-auth.org/cgi-bin/cvsweb.cgi/ais/ai-00305.txt}. The above set is a superset of the restrictions provided by pragma @code{Profile (Restricted)}, it includes six additional restrictions diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 0174bd71bd4..ba83f787f5d 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -7,7 +7,7 @@ @c o @c G N A T _ U G N o @c o -@c Copyright (C) 1992-2010, AdaCore o +@c Copyright (C) 1992-2011, AdaCore o @c o @c oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 59374c20382..63a02e1d247 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -1823,6 +1823,9 @@ package body Sem_Aggr is -- Used to keep track of the number of discrete choices in the -- current association. + Errors_Posted_On_Choices : Boolean := False; + -- Keeps track of whether any choices have semantic errors + begin -- STEP 2 (A): Check discrete choices validity @@ -1867,6 +1870,14 @@ package body Sem_Aggr is Check_Unset_Reference (Choice); Check_Non_Static_Context (Choice); + -- If semantic errors were posted on the choice, then + -- record that for possible early return from later + -- processing (see handling of enumeration choices). + + if Error_Posted (Choice) then + Errors_Posted_On_Choices := True; + end if; + -- Do not range check a choice. This check is redundant -- since this test is already done when we check that the -- bounds of the array aggregate are within range. @@ -2144,13 +2155,12 @@ package body Sem_Aggr is and then Compile_Time_Known_Value (Choices_Low) and then Compile_Time_Known_Value (Choices_High) then - -- If the bounds have semantic errors, do not attempt - -- further resolution to prevent cascaded errors. + -- If any of the expressions or range bounds in choices + -- have semantic errors, then do not attempt further + -- resolution, to prevent cascaded errors. - if Error_Posted (Choices_Low) - or else Error_Posted (Choices_High) - then - return False; + if Errors_Posted_On_Choices then + return Failure; end if; declare diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 6a1e3e940ea..6441cfa7396 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -8298,7 +8298,9 @@ package body Sem_Ch3 is -- the point of instantiation, we want to find the discriminant -- that corresponds to D in Rec, i.e. X. - if Present (Original_Discriminant (Id)) then + if Present (Original_Discriminant (Id)) + and then In_Instance + then Discr := Find_Corresponding_Discriminant (Id, T); Found := True; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index ba631fbffc3..82a6161533d 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -3754,6 +3754,7 @@ package body Sem_Ch4 is -- be done transitively, so note the new original discriminant. if Nkind (Sel) = N_Identifier + and then In_Instance and then Present (Original_Discriminant (Sel)) then Comp := Find_Corresponding_Discriminant (Sel, Prefix_Type); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 840537d8377..7d518037242 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -9873,29 +9873,49 @@ package body Sem_Res is Set_String_Literal_Low_Bound (Subtype_Id, Low_Bound); else - Set_String_Literal_Low_Bound - (Subtype_Id, Make_Integer_Literal (Loc, 1)); - Set_Etype (String_Literal_Low_Bound (Subtype_Id), Standard_Positive); - - -- Build bona fide subtype for the string, and wrap it in an - -- unchecked conversion, because the backend expects the - -- String_Literal_Subtype to have a static lower bound. + -- If the lower bound is not static we create a range for the string + -- literal, using the index type and the known length of the literal. + -- The index type is not necessarily Positive, so the upper bound is + -- computed as T'Val (T'Pos (Low_Bound) + L - 1) declare Index_List : constant List_Id := New_List; Index_Type : constant Entity_Id := Etype (First_Index (Typ)); High_Bound : constant Node_Id := - Make_Op_Add (Loc, - Left_Opnd => New_Copy_Tree (Low_Bound), - Right_Opnd => - Make_Integer_Literal (Loc, - String_Length (Strval (N)) - 1)); + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Val, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Expressions => + New_List ( + Make_Op_Add (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Pos, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Expressions => New_List (New_Copy_Tree (Low_Bound))), + Right_Opnd => + Make_Integer_Literal (Loc, + String_Length (Strval (N)) - 1)))); + Array_Subtype : Entity_Id; Index_Subtype : Entity_Id; Drange : Node_Id; Index : Node_Id; begin + Set_String_Literal_Low_Bound + (Subtype_Id, + Make_Attribute_Reference (Loc, + Attribute_Name => Name_First, + Prefix => + New_Occurrence_Of (Base_Type (Index_Type), Loc))); + Set_Etype (String_Literal_Low_Bound (Subtype_Id), Index_Type); + Analyze_And_Resolve (String_Literal_Low_Bound (Subtype_Id)); + + -- Build bona fide subtype for the string, and wrap it in an + -- unchecked conversion, because the backend expects the + -- String_Literal_Subtype to have a static lower bound. + Index_Subtype := Create_Itype (Subtype_Kind (Ekind (Index_Type)), N); Drange := Make_Range (Loc, New_Copy_Tree (Low_Bound), High_Bound);