diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 60 | ||||
| -rw-r--r-- | gcc/ada/a-cbdlli.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/a-cbprqu.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/einfo.adb | 14 | ||||
| -rw-r--r-- | gcc/ada/exp_attr.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/exp_ch5.adb | 73 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/inline.adb | 35 | ||||
| -rw-r--r-- | gcc/ada/lib-load.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/style.adb | 2 |
11 files changed, 186 insertions, 42 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5a87f68..fc0f2ca 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,63 @@ +2017-09-08 Ed Schonberg <schonberg@adacore.com> + + * style.adb: Fix typo. + +2017-09-08 Javier Miranda <miranda@adacore.com> + + * 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 <schonberg@adacore.com> + + * 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 <squirek@adacore.com> + + * lib-load.adb: Modify printing of error message to exclude file + line number. + +2017-09-08 Arnaud Charlet <charlet@adacore.com> + + * 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 <schonberg@adacore.com> + + * 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 <duff@adacore.com> + + * a-cbprqu.ads, a-cbdlli.adb: Suppress warnings. + +2017-09-08 Bob Duff <duff@adacore.com> + + * a-strfix.adb (Trim): Compute Low and High only if needed. + +2017-09-08 Justin Squirek <squirek@adacore.com> + + * lib-load.adb (Load_Main_Source): Add error output in the case a + source file is missing. + 2017-09-08 Bob Duff <duff@adacore.com> PR ada/80888 diff --git a/gcc/ada/a-cbdlli.adb b/gcc/ada/a-cbdlli.adb index b19fc3c..8f7b537 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 932e607..d3e7e0f 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 c0d48b7..265ec9c 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 62ccc4b..99a24e7 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 14249f0..8762367 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 ff1a752..9c6ea2b 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 bc0428e..ca9986d 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 e18fa24..f509721 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 188a0d3..7afe9a7 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 e475b82..a0d61aa 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 |