From 63a5b3dc89fa01e461c96bde32df592db5bf700f Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 8 Sep 2017 11:44:30 +0200 Subject: [PATCH] [multiple changes] 2017-09-08 Ed Schonberg * style.adb: Fix typo. 2017-09-08 Javier Miranda * einfo.adb (Underlying_Type): Add missing support for class-wide types that come from the limited view. * exp_attr.adb (Attribute_Address): Check class-wide type interfaces using the underlying type to handle limited-withed types. (Attribute_Tag): Check class-wide type interfaces using the underlying type to handle limited-withed types. 2017-09-08 Ed Schonberg * exp_ch5.adb (Expand_Predicated_Loop): Handle properly a loop over a subtype of a type with a static predicate, taking into account the predicate function of the parent type and the bounds given in the loop specification. * sem_ch3.adb (Inherit_Predicate_Flags): For qn Itype created for a loop specification that is a subtype indication whose type mark is a type with a static predicate, inherit predicate function, used to build case statement for rewritten loop. 2017-09-08 Justin Squirek * lib-load.adb: Modify printing of error message to exclude file line number. 2017-09-08 Arnaud Charlet * inline.adb (Can_Be_Inlined_In_GNATprove_Mode): don't inline subprograms declared in both visible and private parts of a package. (In_Package_Spec): previously In_Package_Visible_Spec; now detects subprograms declared both in visible and private parts of a package spec. 2017-09-08 Ed Schonberg * exp_util.adb (Build_Invariant_Procedure_Declaration): If the type is an anonymous array in an object declaration, whose component type has an invariant, use the object declaration as the insertion point for the invariant procedure, given that there is no explicit type declaration for an anonymous array type. 2017-09-08 Bob Duff * a-cbprqu.ads, a-cbdlli.adb: Suppress warnings. From-SVN: r251876 --- gcc/ada/ChangeLog | 60 ++++++++++++++++++++++++++++++++++++ gcc/ada/a-cbdlli.adb | 6 ++-- gcc/ada/a-cbprqu.ads | 6 +++- gcc/ada/einfo.adb | 14 +++++++-- gcc/ada/exp_attr.adb | 4 +-- gcc/ada/exp_ch5.adb | 73 ++++++++++++++++++++++++++++++++++++++------ gcc/ada/exp_util.adb | 5 +++ gcc/ada/inline.adb | 35 +++++++++------------ gcc/ada/lib-load.adb | 10 ++++-- gcc/ada/sem_ch3.adb | 13 ++++++++ gcc/ada/style.adb | 2 +- 11 files changed, 186 insertions(+), 42 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5a87f681dc9..fc0f2caca19 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,63 @@ +2017-09-08 Ed Schonberg + + * style.adb: Fix typo. + +2017-09-08 Javier Miranda + + * einfo.adb (Underlying_Type): Add missing support for class-wide + types that come from the limited view. + * exp_attr.adb (Attribute_Address): Check class-wide type + interfaces using the underlying type to handle limited-withed + types. + (Attribute_Tag): Check class-wide type interfaces using + the underlying type to handle limited-withed types. + +2017-09-08 Ed Schonberg + + * exp_ch5.adb (Expand_Predicated_Loop): Handle properly a loop + over a subtype of a type with a static predicate, taking into + account the predicate function of the parent type and the bounds + given in the loop specification. + * sem_ch3.adb (Inherit_Predicate_Flags): For qn Itype created for + a loop specification that is a subtype indication whose type mark + is a type with a static predicate, inherit predicate function, + used to build case statement for rewritten loop. + +2017-09-08 Justin Squirek + + * lib-load.adb: Modify printing of error message to exclude file + line number. + +2017-09-08 Arnaud Charlet + + * inline.adb (Can_Be_Inlined_In_GNATprove_Mode): + don't inline subprograms declared in both visible and private + parts of a package. + (In_Package_Spec): previously In_Package_Visible_Spec; now + detects subprograms declared both in visible and private parts + of a package spec. + +2017-09-08 Ed Schonberg + + * exp_util.adb (Build_Invariant_Procedure_Declaration): If + the type is an anonymous array in an object declaration, whose + component type has an invariant, use the object declaration + as the insertion point for the invariant procedure, given that + there is no explicit type declaration for an anonymous array type. + +2017-09-08 Bob Duff + + * a-cbprqu.ads, a-cbdlli.adb: Suppress warnings. + +2017-09-08 Bob Duff + + * a-strfix.adb (Trim): Compute Low and High only if needed. + +2017-09-08 Justin Squirek + + * lib-load.adb (Load_Main_Source): Add error output in the case a + source file is missing. + 2017-09-08 Bob Duff PR ada/80888 diff --git a/gcc/ada/a-cbdlli.adb b/gcc/ada/a-cbdlli.adb index b19fc3c293e..8f7b5374901 100644 --- a/gcc/ada/a-cbdlli.adb +++ b/gcc/ada/a-cbdlli.adb @@ -1015,9 +1015,10 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is Position : out Cursor; Count : Count_Type := 1) is + pragma Warnings (Off); New_Item : Element_Type; - pragma Unmodified (New_Item); - -- OK to reference, see below. Needed to suppress front end warning. + -- OK to reference, see below. Note that we need to suppress both the + -- front end warning and the back end warning. begin -- There is no explicit element provided, but in an instance the element @@ -1026,7 +1027,6 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is -- initialization, so insert the specified number of possibly -- initialized elements at the given position. - pragma Warnings (Off); -- Needed to suppress back end warning Insert (Container, Before, New_Item, Position, Count); pragma Warnings (On); end Insert; diff --git a/gcc/ada/a-cbprqu.ads b/gcc/ada/a-cbprqu.ads index 932e607a90a..d3e7e0f0bb9 100644 --- a/gcc/ada/a-cbprqu.ads +++ b/gcc/ada/a-cbprqu.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -88,9 +88,13 @@ package Ada.Containers.Bounded_Priority_Queues is -- We need a better data structure here, such as a proper heap. ??? + pragma Warnings (Off); + -- Otherwise, we get warnings for the uninitialized variable in Insert + -- in Ada.Containers.Bounded_Doubly_Linked_Lists. package List_Types is new Bounded_Doubly_Linked_Lists (Element_Type => Queue_Interfaces.Element_Type, "=" => Queue_Interfaces."="); + pragma Warnings (On); type List_Type (Capacity : Count_Type) is tagged limited record Container : List_Types.List (Capacity); diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index c0d48b7b36c..265ec9c43ea 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -9300,6 +9300,15 @@ package body Einfo is if Ekind (Id) = E_Record_Type_With_Private then return Full_View (Id); + -- If we have a class-wide type that comes from the limited view then + -- we return the Underlying_Type of its nonlimited view. + + elsif Ekind (Id) = E_Class_Wide_Type + and then From_Limited_With (Id) + and then Present (Non_Limited_View (Id)) + then + return Underlying_Type (Non_Limited_View (Id)); + elsif Ekind (Id) in Incomplete_Or_Private_Kind then -- If we have an incomplete or private type with a full view, @@ -9324,9 +9333,8 @@ package body Einfo is then return Underlying_Type (Underlying_Full_View (Id)); - -- If we have an incomplete entity that comes from the limited - -- view then we return the Underlying_Type of its non-limited - -- view. + -- If we have an incomplete entity that comes from the limited view + -- then we return the Underlying_Type of its nonlimited view. elsif From_Limited_With (Id) and then Present (Non_Limited_View (Id)) diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 62ccc4be725..99a24e7139d 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -2235,7 +2235,7 @@ package body Exp_Attr is -- issues are taken care of by the virtual machine. elsif Is_Class_Wide_Type (Ptyp) - and then Is_Interface (Ptyp) + and then Is_Interface (Underlying_Type (Ptyp)) and then Tagged_Type_Expansion and then not (Nkind (Pref) in N_Has_Entity and then Is_Subprogram (Entity (Pref))) @@ -6241,7 +6241,7 @@ package body Exp_Attr is elsif Comes_From_Source (N) and then Is_Class_Wide_Type (Etype (Prefix (N))) - and then Is_Interface (Etype (Prefix (N))) + and then Is_Interface (Underlying_Type (Etype (Prefix (N)))) then -- Generate: -- (To_Tag_Ptr (Prefix'Address)).all diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 14249f0d278..8762367dd18 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -4698,6 +4698,10 @@ package body Exp_Ch5 is -- end loop; -- end; + -- In addition, if the loop specification is given by a subtype + -- indication that constrains a predicated type, the bounds of + -- iteration are given by those of the subtype indication. + else Static_Predicate : declare S : Node_Id; @@ -4706,6 +4710,11 @@ package body Exp_Ch5 is Alts : List_Id; Cstm : Node_Id; + -- If the domain is an itype, note the bounds of its range. + + L_Hi : Node_Id; + L_Lo : Node_Id; + function Lo_Val (N : Node_Id) return Node_Id; -- Given static expression or static range, returns an identifier -- whose value is the low bound of the expression value or range. @@ -4760,6 +4769,11 @@ package body Exp_Ch5 is Set_Warnings_Off (Loop_Id); + if Is_Itype (Ltype) then + L_Hi := High_Bound (Scalar_Range (Ltype)); + L_Lo := Low_Bound (Scalar_Range (Ltype)); + end if; + -- Loop to create branches of case statement Alts := New_List; @@ -4768,11 +4782,20 @@ package body Exp_Ch5 is -- Initial value is largest value in predicate. - D := - Make_Object_Declaration (Loc, - Defining_Identifier => Loop_Id, - Object_Definition => New_Occurrence_Of (Ltype, Loc), - Expression => Hi_Val (Last (Stat))); + if Is_Itype (Ltype) then + D := + Make_Object_Declaration (Loc, + Defining_Identifier => Loop_Id, + Object_Definition => New_Occurrence_Of (Ltype, Loc), + Expression => L_Hi); + + else + D := + Make_Object_Declaration (Loc, + Defining_Identifier => Loop_Id, + Object_Definition => New_Occurrence_Of (Ltype, Loc), + Expression => Hi_Val (Last (Stat))); + end if; P := Last (Stat); while Present (P) loop @@ -4794,15 +4817,34 @@ package body Exp_Ch5 is Prev (P); end loop; + if Is_Itype (Ltype) + and then Is_OK_Static_Expression (L_Lo) + and then + Expr_Value (L_Lo) /= Expr_Value (Lo_Val (First (Stat))) + then + Append_To (Alts, + Make_Case_Statement_Alternative (Loc, + Statements => New_List (Make_Exit_Statement (Loc)), + Discrete_Choices => New_List (L_Lo))); + end if; + else -- Initial value is smallest value in predicate. - D := - Make_Object_Declaration (Loc, - Defining_Identifier => Loop_Id, - Object_Definition => New_Occurrence_Of (Ltype, Loc), - Expression => Lo_Val (First (Stat))); + if Is_Itype (Ltype) then + D := + Make_Object_Declaration (Loc, + Defining_Identifier => Loop_Id, + Object_Definition => New_Occurrence_Of (Ltype, Loc), + Expression => L_Lo); + else + D := + Make_Object_Declaration (Loc, + Defining_Identifier => Loop_Id, + Object_Definition => New_Occurrence_Of (Ltype, Loc), + Expression => Lo_Val (First (Stat))); + end if; P := First (Stat); while Present (P) loop @@ -4823,6 +4865,17 @@ package body Exp_Ch5 is Next (P); end loop; + + if Is_Itype (Ltype) + and then Is_OK_Static_Expression (L_Hi) + and then + Expr_Value (L_Hi) /= Expr_Value (Lo_Val (Last (Stat))) + then + Append_To (Alts, + Make_Case_Statement_Alternative (Loc, + Statements => New_List (Make_Exit_Statement (Loc)), + Discrete_Choices => New_List (L_Hi))); + end if; end if; -- Add others choice diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index ff1a7523457..9c6ea2b6acc 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -3408,6 +3408,11 @@ package body Exp_Util is -- Derived types with the full view as parent do not have a partial -- view. Insert the invariant procedure after the derived type. + -- Anonymous arrays in object declarations have no explicit declaration + -- so use the related object declaration as the insertion point. + + elsif Is_Itype (Work_Typ) and then Is_Array_Type (Work_Typ) then + Typ_Decl := Associated_Node_For_Itype (Work_Typ); else Typ_Decl := Declaration_Node (Full_Typ); diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index bc0428e3551..ca9986d20da 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -1187,9 +1187,9 @@ package body Inline is -- Returns True if subprogram Id defines a compilation unit -- Shouldn't this be in Sem_Aux??? - function In_Package_Visible_Spec (Id : Node_Id) return Boolean; - -- Returns True if subprogram Id is defined in the visible part of a - -- package specification. + function In_Package_Spec (Id : Node_Id) return Boolean; + -- Returns True if subprogram Id is defined in the package + -- specification, either its visible or private part. --------------------------------------------------- -- Has_Formal_With_Discriminant_Dependent_Fields -- @@ -1288,24 +1288,17 @@ package body Inline is return False; end Has_Some_Contract; - ----------------------------- - -- In_Package_Visible_Spec -- - ----------------------------- + --------------------- + -- In_Package_Spec -- + --------------------- - function In_Package_Visible_Spec (Id : Node_Id) return Boolean is - Decl : Node_Id := Parent (Parent (Id)); - P : Node_Id; + function In_Package_Spec (Id : Node_Id) return Boolean is + P : constant Node_Id := Parent (Subprogram_Spec (Id)); + -- Parent of the subprogram's declaration begin - if Nkind (Parent (Id)) = N_Defining_Program_Unit_Name then - Decl := Parent (Decl); - end if; - - P := Parent (Decl); - - return Nkind (P) = N_Package_Specification - and then List_Containing (Decl) = Visible_Declarations (P); - end In_Package_Visible_Spec; + return Nkind (Enclosing_Declaration (P)) = N_Package_Declaration; + end In_Package_Spec; ------------------------ -- Is_Unit_Subprogram -- @@ -1351,9 +1344,11 @@ package body Inline is if Is_Unit_Subprogram (Id) then return False; - -- Do not inline subprograms declared in the visible part of a package + -- Do not inline subprograms declared in package specs, because they are + -- not local, i.e. can be called either from anywhere (if declared in + -- visible part) or from the child units (if declared in private part). - elsif In_Package_Visible_Spec (Id) then + elsif In_Package_Spec (Id) then return False; -- Do not inline subprograms declared in other units. This is important diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb index e18fa246f88..f509721c398 100644 --- a/gcc/ada/lib-load.adb +++ b/gcc/ada/lib-load.adb @@ -329,8 +329,14 @@ package body Lib.Load is if Main_Source_File /= No_Source_File then Version := Source_Checksum (Main_Source_File); else - Error_Msg_File_1 := Fname; - Error_Msg ("file{ not found", Load_Msg_Sloc); + -- To avoid emitting a source location (since there is no file), + -- we write a custom error message instead of using the machinery + -- in errout.adb. + + Set_Standard_Error; + Write_Str ("file """ & Get_Name_String (Fname) & """ not found"); + Write_Eol; + Set_Standard_Output; end if; Units.Table (Main_Unit) := diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 188a0d39799..7afe9a7ead6 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -18449,6 +18449,19 @@ package body Sem_Ch3 is (Subt, Has_Static_Predicate_Aspect (Par)); Set_Has_Dynamic_Predicate_Aspect (Subt, Has_Dynamic_Predicate_Aspect (Par)); + + -- A named subtype does not inherit the predicate function of its + -- parent but an itype declared for a loop index needs the discrete + -- predicate information of its parent to execute the loop properly. + + if Is_Itype (Subt) and then Present (Predicate_Function (Par)) then + Set_Subprograms_For_Type (Subt, Subprograms_For_Type (Par)); + + if Has_Static_Predicate (Par) then + Set_Static_Discrete_Predicate + (Subt, Static_Discrete_Predicate (Par)); + end if; + end if; end Inherit_Predicate_Flags; ---------------------- diff --git a/gcc/ada/style.adb b/gcc/ada/style.adb index e475b82a360..a0d61aa37b4 100644 --- a/gcc/ada/style.adb +++ b/gcc/ada/style.adb @@ -291,7 +291,7 @@ package body Style is elsif Nkind (N) = N_Abstract_Subprogram_Declaration then Error_Msg_NE -- CODEFIX - ("(style) missing OVERRIDING indicator in deckaration of&", + ("(style) missing OVERRIDING indicator in declaration of&", Specification (N), E); else -- 2.30.2