diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6461c13dd45..4c906dd6663 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,23 @@ +2014-08-01 Robert Dewar + + * sem_ch8.adb: Minor reformatting. + +2014-08-01 Yannick Moy + + * sem_ch13.adb (Insert_Pragma): Add special case for precondition + pragmas from aspects, which need to be inserted in proper order. + +2014-08-01 Ed Schonberg + + * exp_aggr.adb (Expand_Record_Aggregate, Init_Hidden_Discriminants): + Handle properly a type extension that constrains a discriminated + derived type that renames other discriminants of an ancestor. + +2014-08-01 Thomas Quinot + + * s-pack06.adb, s-pack10.adb, s-pack03.ads, s-pack12.adb, s-pack14.ads, + s-pack25.adb: Fix minor inconsistencies and typos. + 2014-08-01 Hristian Kirtchev * sem_ch8.adb (Analyze_Subprogram_Renaming): Alphabetize diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 557e3c82dfe..033ad011db8 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -1845,7 +1845,9 @@ package body Exp_Aggr is procedure Init_Hidden_Discriminants (Typ : Entity_Id; List : List_Id); -- If Typ is derived, and constrains discriminants of the parent type, -- these discriminants are not components of the aggregate, and must be - -- initialized. The assignments are appended to List. + -- initialized. The assignments are appended to List. The same is done + -- if Typ derives fron an already constrained subtype of a discriminated + -- parent type. function Get_Explicit_Discriminant_Value (D : Entity_Id) return Node_Id; -- If the ancestor part is an unconstrained type and further ancestors @@ -2113,13 +2115,30 @@ package body Exp_Aggr is begin Btype := Base_Type (Typ); + + -- The constraints on the hidden discriminants, if present, are + -- kep in the Stored_Constraint list of the type itself, or in + -- that of the base type. + while Is_Derived_Type (Btype) - and then Present (Stored_Constraint (Btype)) + and then (Present (Stored_Constraint (Btype)) + or else Present (Stored_Constraint (Typ))) loop Parent_Type := Etype (Btype); + if not Has_Discriminants (Parent_Type) then + return; + end if; Disc := First_Discriminant (Parent_Type); - Discr_Val := First_Elmt (Stored_Constraint (Base_Type (Typ))); + + -- We know that one of the stored-constraint lists is present. + + if Present (Stored_Constraint (Btype)) then + Discr_Val := First_Elmt (Stored_Constraint (Btype)); + else + Discr_Val := First_Elmt (Stored_Constraint (Typ)); + end if; + while Present (Discr_Val) loop -- Only those discriminants of the parent that are not diff --git a/gcc/ada/s-pack03.ads b/gcc/ada/s-pack03.ads index f34428bacde..d8f35c70555 100644 --- a/gcc/ada/s-pack03.ads +++ b/gcc/ada/s-pack03.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -29,7 +29,7 @@ -- -- ------------------------------------------------------------------------------ --- Handing of packed arrays with Component_Size = 3 +-- Handling of packed arrays with Component_Size = 3 package System.Pack_03 is pragma Preelaborate; diff --git a/gcc/ada/s-pack06.adb b/gcc/ada/s-pack06.adb index e2e77b097e2..a8cf24e842b 100644 --- a/gcc/ada/s-pack06.adb +++ b/gcc/ada/s-pack06.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -128,7 +128,6 @@ package body System.Pack_06 is procedure Set_06 (Arr : System.Address; N : Natural; E : Bits_06) is C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); - begin case N07 (Uns (N) mod 8) is when 0 => C.E0 := E; @@ -148,7 +147,6 @@ package body System.Pack_06 is procedure SetU_06 (Arr : System.Address; N : Natural; E : Bits_06) is C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); - begin case N07 (Uns (N) mod 8) is when 0 => C.E0 := E; diff --git a/gcc/ada/s-pack10.adb b/gcc/ada/s-pack10.adb index 933969db394..0fbd13ef962 100644 --- a/gcc/ada/s-pack10.adb +++ b/gcc/ada/s-pack10.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -128,7 +128,6 @@ package body System.Pack_10 is procedure Set_10 (Arr : System.Address; N : Natural; E : Bits_10) is C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); - begin case N07 (Uns (N) mod 8) is when 0 => C.E0 := E; @@ -148,7 +147,6 @@ package body System.Pack_10 is procedure SetU_10 (Arr : System.Address; N : Natural; E : Bits_10) is C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); - begin case N07 (Uns (N) mod 8) is when 0 => C.E0 := E; diff --git a/gcc/ada/s-pack12.adb b/gcc/ada/s-pack12.adb index e12cd66ce32..d43cca14a24 100644 --- a/gcc/ada/s-pack12.adb +++ b/gcc/ada/s-pack12.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -128,7 +128,6 @@ package body System.Pack_12 is procedure Set_12 (Arr : System.Address; N : Natural; E : Bits_12) is C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); - begin case N07 (Uns (N) mod 8) is when 0 => C.E0 := E; @@ -148,7 +147,6 @@ package body System.Pack_12 is procedure SetU_12 (Arr : System.Address; N : Natural; E : Bits_12) is C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); - begin case N07 (Uns (N) mod 8) is when 0 => C.E0 := E; diff --git a/gcc/ada/s-pack14.ads b/gcc/ada/s-pack14.ads index 326d2e68c32..aecd6f089cd 100644 --- a/gcc/ada/s-pack14.ads +++ b/gcc/ada/s-pack14.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -29,7 +29,7 @@ -- -- ------------------------------------------------------------------------------ --- Handing of packed arrays with Component_Size = 14 +-- Handling of packed arrays with Component_Size = 14 package System.Pack_14 is pragma Preelaborate; diff --git a/gcc/ada/s-pack25.adb b/gcc/ada/s-pack25.adb index 015d4030510..3d927c27e64 100644 --- a/gcc/ada/s-pack25.adb +++ b/gcc/ada/s-pack25.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -77,7 +77,6 @@ package body System.Pack_25 is function Get_25 (Arr : System.Address; N : Natural) return Bits_25 is C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); - begin case N07 (Uns (N) mod 8) is when 0 => return C.E0; @@ -97,7 +96,6 @@ package body System.Pack_25 is procedure Set_25 (Arr : System.Address; N : Natural; E : Bits_25) is C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); - begin case N07 (Uns (N) mod 8) is when 0 => C.E0 := E; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 86a36ced87f..a741cfffd4d 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -1283,10 +1283,19 @@ package body Sem_Ch13 is -- the proper insertion point. As a result the order of pragmas -- is the same as the order of aspects. + -- As precondition pragmas generated from conjuncts in the + -- precondition aspect are presented in reverse order to + -- Insert_Pragma, insert them in the correct order here by not + -- skipping previously inserted precondition pragmas when the + -- current pragma is a precondition. + Decl := First (Declarations (N)); while Present (Decl) loop if Nkind (Decl) = N_Pragma and then From_Aspect_Specification (Decl) + and then not (Get_Pragma_Id (Decl) = Pragma_Precondition + and then + Get_Pragma_Id (Prag) = Pragma_Precondition) then Next (Decl); else diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 01055d2265a..0e5c2e4e50f 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -1830,28 +1830,28 @@ package body Sem_Ch8 is -- type with unknown discriminants and a generic primitive operation of -- the said type with a box require special processing when the actual -- is a class-wide type: - + -- -- generic -- type Formal_Typ (<>) is private; -- with procedure Prim_Op (Param : Formal_Typ) is <>; -- package Gen is ... - + -- -- package Inst is new Gen (Actual_Typ'Class); - + -- -- In this case the general renaming mechanism used in the prologue of -- an instance no longer applies: - + -- -- procedure Prim_Op (Param : Formal_Typ) renames Prim_Op; - + -- -- The above is replaced the following wrapper/renaming combination: - + -- -- procedure Prim_Op (Param : Formal_Typ) is -- wrapper -- begin -- Prim_Op (Param); -- primitive -- end Wrapper; - + -- -- procedure Dummy (Param : Formal_Typ) renames Prim_Op; - + -- -- This transformation applies only if there is no explicit visible -- class-wide operation at the point of the instantiation. Ren_Id is -- the entity of the renaming declaration. Wrap_Id is the entity of @@ -1937,7 +1937,6 @@ package body Sem_Ch8 is while Present (Formal) loop Append_To (Actuals, Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); - Next (Formal); end loop;