diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 41 | ||||
| -rw-r--r-- | gcc/ada/exp_aggr.adb | 28 | ||||
| -rw-r--r-- | gcc/ada/freeze.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/prj-attr.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/s-oscons-tmplt.c | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_aux.adb | 108 | ||||
| -rw-r--r-- | gcc/ada/sem_aux.ads | 66 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 222 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 32 | ||||
| -rw-r--r-- | gcc/ada/sem_dim.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/sem_eval.ads | 11 | ||||
| -rw-r--r-- | gcc/ada/sinfo.ads | 2 |
13 files changed, 468 insertions, 72 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c48bf74671b..15c8ef2c9cf 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,44 @@ +2012-08-06 Arnaud Charlet <charlet@adacore.com> + + * prj-attr.adb (Register_New_Package): Add missing blank. + +2012-08-06 Ed Schonberg <schonberg@adacore.com> + + * exp_aggr.adb (Is_Two_Dim_Packed_Array): New predicate, + used when computing maximum size allowable to construct static + aggregate. + +2012-08-06 Vincent Pucci <pucci@adacore.com> + + * freeze.adb (Freeze_Entity): Inherit_Aspects_At_Freeze_Point + calls added for derived types and subtypes. + * sem_aux.adb, sem_aux.ads (Get_Rep_Item, Get_Rep_Pragma, + Has_Rep_Pragma): New routines. + * sem_ch13.ads (Inherit_Aspects_At_Freeze_Point): New routine. + * sem_ch13.adb (Analyze_Aspect_Specifications): Error message + for aspect Lock_Free fixed. + (Inherits_Aspects_At_Freeze_Point): New routine. + * sem_ch3.adb: Several flag settings removed since inheritance + of aspects must be performed at freeze point. + +2012-08-06 Thomas Quinot <quinot@adacore.com> + + * s-oscons-tmplt.c: Fix s-oscons.ads formatting on VxWorks. + +2012-08-06 Vincent Pucci <pucci@adacore.com> + + * sem_dim.adb (Analyze_Dimension_Binary_Op): Issue an error message + for unknown exponent at compile-time. + +2012-08-06 Gary Dismukes <dismukes@adacore.com> + + * sem_eval.ads (Compile_Time_Known_Value_Or_Aggr): Enhance + comment to make it clear that the aggregate's evaluation might + still involve run-time checks even though the aggregate is + considered known at compile time. + * sinfo.ads (Compile_Time_Known_Aggregate): Correct comment to + refer to Exp_Aggr instead of Sem_Aggr. + 2012-08-06 Robert Dewar <dewar@adacore.com> * xoscons.adb: Minor code reorganization (remove unused variable diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 294a7d82ab2..bcfca25c6b0 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -238,6 +238,14 @@ package body Exp_Aggr is -- This is the top-level routine to perform array aggregate expansion. -- N is the N_Aggregate node to be expanded. + function Is_Two_Dim_Packed_Array (Typ : Entity_Id) return Boolean; + + -- For two-dimensional packed aggregates with constant bounds and constant + -- components, it is preferable to pack the inner aggregates because the + -- whole matrix can then be presented to the back-end as a one-dimensional + -- list of literals. This is much more efficient than expanding into single + -- component assignments. + function Late_Expansion (N : Node_Id; Typ : Entity_Id; @@ -306,6 +314,11 @@ package body Exp_Aggr is -- increase the limit when Static_Elaboration_Desired, given that this -- means that objects are intended to be placed in data memory. + -- We also increase the limit if the aggregate is for a packed two- + -- dimensional array, because if components are static it is much more + -- efficient to construct a one-dimensional equivalent array with static + -- components. + Max_Aggr_Size : constant Nat := 5000 + (2 ** 24 - 5000) * Boolean'Pos @@ -313,6 +326,8 @@ package body Exp_Aggr is or else Restriction_Active (No_Implicit_Loops) or else + Is_Two_Dim_Packed_Array (Typ) + or else ((Ekind (Current_Scope) = E_Package and then Static_Elaboration_Desired (Current_Scope)))); @@ -5900,6 +5915,19 @@ package body Exp_Aggr is and then Typ = RTE (RE_Interface_Data_Element))); end Is_Static_Dispatch_Table_Aggregate; + ----------------------------- + -- Is_Two_Dim_Packed_Array -- + ----------------------------- + + function Is_Two_Dim_Packed_Array (Typ : Entity_Id) return Boolean is + C : constant Int := UI_To_Int (Component_Size (Typ)); + begin + return Number_Dimensions (Typ) = 2 + and then Is_Bit_Packed_Array (Typ) + and then + (C = 1 or else C = 2 or else C = 4); + end Is_Two_Dim_Packed_Array; + -------------------- -- Late_Expansion -- -------------------- diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 5f0547c4bdb..ad9f06a0675 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -3434,11 +3434,22 @@ package body Freeze is end if; end if; + -- A subtype inherits all the type-related representation aspects + -- from its parents (RM 13.1(8)). + + Inherit_Aspects_At_Freeze_Point (E); + -- For a derived type, freeze its parent type first (RM 13.14(15)) elsif Is_Derived_Type (E) then Freeze_And_Append (Etype (E), N, Result); Freeze_And_Append (First_Subtype (Etype (E)), N, Result); + + -- A derived type inherits each type-related representation aspect + -- of its parent type that was directly specified before the + -- declaration of the derived type (RM 13.1(15)). + + Inherit_Aspects_At_Freeze_Point (E); end if; -- For array type, freeze index types and component type first diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb index 0321533fc18..f2af8379100 100644 --- a/gcc/ada/prj-attr.adb +++ b/gcc/ada/prj-attr.adb @@ -851,7 +851,7 @@ package body Prj.Attr is for Index in Package_Attributes.First .. Package_Attributes.Last loop if Package_Attributes.Table (Index).Name = Pkg_Name then - Fail ("cannot register a package with a non unique name""" + Fail ("cannot register a package with a non unique name """ & Name & """"); Id := Empty_Package; @@ -889,7 +889,7 @@ package body Prj.Attr is for Index in Package_Attributes.First .. Package_Attributes.Last loop if Package_Attributes.Table (Index).Name = Pkg_Name then - Fail ("cannot register a package with a non unique name""" + Fail ("cannot register a package with a non unique name """ & Name & """"); raise Project_Error; diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c index bfd46ddf6a5..eef71b4b719 100644 --- a/gcc/ada/s-oscons-tmplt.c +++ b/gcc/ada/s-oscons-tmplt.c @@ -628,6 +628,7 @@ CND(EILSEQ, "Illegal byte sequence") ** Terminal/serial I/O constants **/ +#if defined(HAVE_TERMIOS) || defined(__MINGW32__) /* ---------------------- @@ -635,6 +636,7 @@ CND(EILSEQ, "Illegal byte sequence") ---------------------- */ +#endif #ifdef HAVE_TERMIOS diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index d729519003e..bb24fc2e21a 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -489,6 +489,40 @@ package body Sem_Aux is return Empty; end Get_Rep_Item; + function Get_Rep_Item + (E : Entity_Id; + Nam1 : Name_Id; + Nam2 : Name_Id; + Check_Parents : Boolean := True) return Node_Id + is + Nam1_Item : constant Node_Id := Get_Rep_Item (E, Nam1, Check_Parents); + Nam2_Item : constant Node_Id := Get_Rep_Item (E, Nam2, Check_Parents); + + N : Node_Id; + + begin + -- Check both Nam1_Item and Nam2_Item are present + + if No (Nam1_Item) then + return Nam2_Item; + elsif No (Nam2_Item) then + return Nam1_Item; + end if; + + -- Return the first node encountered in the list + + N := First_Rep_Item (E); + while Present (N) loop + if N = Nam1_Item or else N = Nam2_Item then + return N; + end if; + + Next_Rep_Item (N); + end loop; + + return Empty; + end Get_Rep_Item; + -------------------- -- Get_Rep_Pragma -- -------------------- @@ -501,31 +535,41 @@ package body Sem_Aux is N : Node_Id; begin - N := First_Rep_Item (E); - while Present (N) loop - if Nkind (N) = N_Pragma - and then - (Pragma_Name (N) = Nam - or else (Nam = Name_Interrupt_Priority - and then Pragma_Name (N) = Name_Priority)) - then - if Check_Parents then - return N; + N := Get_Rep_Item (E, Nam, Check_Parents); - -- If Check_Parents is False, return N if the pragma doesn't - -- appear in the Rep_Item chain of the parent. + if Present (N) and then Nkind (N) = N_Pragma then + return N; + end if; - else - declare - Par : constant Entity_Id := Nearest_Ancestor (E); - -- This node represents the parent type of type E (if any) + return Empty; + end Get_Rep_Pragma; - begin - if No (Par) or else not Present_In_Rep_Item (Par, N) then - return N; - end if; - end; - end if; + function Get_Rep_Pragma + (E : Entity_Id; + Nam1 : Name_Id; + Nam2 : Name_Id; + Check_Parents : Boolean := True) return Node_Id + is + Nam1_Item : constant Node_Id := Get_Rep_Pragma (E, Nam1, Check_Parents); + Nam2_Item : constant Node_Id := Get_Rep_Pragma (E, Nam2, Check_Parents); + + N : Node_Id; + + begin + -- Check both Nam1_Item and Nam2_Item are present + + if No (Nam1_Item) then + return Nam2_Item; + elsif No (Nam2_Item) then + return Nam1_Item; + end if; + + -- Return the first node encountered in the list + + N := First_Rep_Item (E); + while Present (N) loop + if N = Nam1_Item or else N = Nam2_Item then + return N; end if; Next_Rep_Item (N); @@ -547,6 +591,16 @@ package body Sem_Aux is return Present (Get_Rep_Item (E, Nam, Check_Parents)); end Has_Rep_Item; + function Has_Rep_Item + (E : Entity_Id; + Nam1 : Name_Id; + Nam2 : Name_Id; + Check_Parents : Boolean := True) return Boolean + is + begin + return Present (Get_Rep_Item (E, Nam1, Nam2, Check_Parents)); + end Has_Rep_Item; + -------------------- -- Has_Rep_Pragma -- -------------------- @@ -560,6 +614,16 @@ package body Sem_Aux is return Present (Get_Rep_Pragma (E, Nam, Check_Parents)); end Has_Rep_Pragma; + function Has_Rep_Pragma + (E : Entity_Id; + Nam1 : Name_Id; + Nam2 : Name_Id; + Check_Parents : Boolean := True) return Boolean + is + begin + return Present (Get_Rep_Pragma (E, Nam1, Nam2, Check_Parents)); + end Has_Rep_Pragma; + ------------------------------- -- Initialization_Suppressed -- ------------------------------- diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index bf09e99ba5a..fafd70f7f45 100644 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -168,18 +168,47 @@ package Sem_Aux is -- otherwise Empty is returned. A special case is that when Nam is -- Name_Priority, the call will also find Interrupt_Priority. + function Get_Rep_Item + (E : Entity_Id; + Nam1 : Name_Id; + Nam2 : Name_Id; + Check_Parents : Boolean := True) return Node_Id; + -- Searches the Rep_Item chain for a given entity E, for an instance of a + -- rep item (pragma, attribute definition clause, or aspect specification) + -- whose name matches one of the given names Nam1 or Nam2. If Check_Parents + -- is False then it only returns rep item that has been directly specified + -- for E (and not inherited from its parents, if any). If one is found, it + -- is returned, otherwise Empty is returned. A special case is that when + -- one of the given names is Name_Priority, the call will also find + -- Interrupt_Priority. + function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id; Check_Parents : Boolean := True) return Node_Id; - -- Searches the Rep_Item chain for a given entity E, for an instance - -- of a representation pragma whose name matches the given name Nam. If + -- Searches the Rep_Item chain for a given entity E, for an instance of a + -- representation pragma whose name matches the given name Nam. If -- Check_Parents is False then it only returns representation pragma that -- has been directly specified for E (and not inherited from its parents, - -- if any). If one is found, it is returned, otherwise Empty is returned. A - -- special case is that when Nam is Name_Priority, the call will also find + -- if any). If one is found and if it is the first rep item in the list + -- that matches Nam, it is returned, otherwise Empty is returned. A special + -- case is that when Nam is Name_Priority, the call will also find -- Interrupt_Priority. + function Get_Rep_Pragma + (E : Entity_Id; + Nam1 : Name_Id; + Nam2 : Name_Id; + Check_Parents : Boolean := True) return Node_Id; + -- Searches the Rep_Item chain for a given entity E, for an instance of a + -- representation pragma whose name matches one of the given names Nam1 or + -- Nam2. If Check_Parents is False then it only returns representation + -- pragma that has been directly specified for E (and not inherited from + -- its parents, if any). If one is found and if it is the first rep item in + -- the list that matches one of the given names, it is returned, otherwise + -- Empty is returned. A special case is that when one of the given names is + -- Name_Priority, the call will also find Interrupt_Priority. + function Has_Rep_Item (E : Entity_Id; Nam : Name_Id; @@ -191,6 +220,18 @@ package Sem_Aux is -- from its parents, if any). If found then True is returned, otherwise -- False indicates that no matching entry was found. + function Has_Rep_Item + (E : Entity_Id; + Nam1 : Name_Id; + Nam2 : Name_Id; + Check_Parents : Boolean := True) return Boolean; + -- Searches the Rep_Item chain for the given entity E, for an instance of a + -- rep item (pragma, attribute definition clause, or aspect specification) + -- with the given names Nam1 or Nam2. If Check_Parents is False then it + -- only checks for a rep item that has been directly specified for E (and + -- not inherited from its parents, if any). If found then True is returned, + -- otherwise False indicates that no matching entry was found. + function Has_Rep_Pragma (E : Entity_Id; Nam : Name_Id; @@ -199,8 +240,21 @@ package Sem_Aux is -- representation pragma with the given name Nam. If Check_Parents is False -- then it only checks for a representation pragma that has been directly -- specified for E (and not inherited from its parents, if any). If found - -- then True is returned, otherwise False indicates that no matching entry - -- was found. + -- and if it is the first rep item in the list that matches Nam then True + -- is returned, otherwise False indicates that no matching entry was found. + + function Has_Rep_Pragma + (E : Entity_Id; + Nam1 : Name_Id; + Nam2 : Name_Id; + Check_Parents : Boolean := True) return Boolean; + -- Searches the Rep_Item chain for the given entity E, for an instance of a + -- representation pragma with the given names Nam1 or Nam2. If + -- Check_Parents is False then it only checks for a rep item that has been + -- directly specified for E (and not inherited from its parents, if any). + -- If found and if it is the first rep item in the list that matches one of + -- the given names then True is returned, otherwise False indicates that no + -- matching entry was found. function In_Generic_Body (Id : Entity_Id) return Boolean; -- Determine whether entity Id appears inside a generic body diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 7baaca7cb16..fff9bded522 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -856,9 +856,7 @@ package body Sem_Ch13 is -- Start of processing for Analyze_Aspects_At_Freeze_Point begin - -- Must be visible in current scope. Note that this is needed for - -- entities that creates their own scope such as protected objects, - -- tasks, etc. + -- Must be visible in current scope. if not Scope_Within_Or_Same (Current_Scope, Scope (E)) then return; @@ -1650,6 +1648,7 @@ package body Sem_Ch13 is if A_Id = Aspect_Lock_Free then if Ekind (E) /= E_Protected_Type then + Error_Msg_Name_1 := Nam; Error_Msg_N ("aspect % only applies to a protected object", Aspect); @@ -7943,6 +7942,223 @@ package body Sem_Ch13 is end if; end Get_Alignment_Value; + ------------------------------------- + -- Inherit_Aspects_At_Freeze_Point -- + ------------------------------------- + + procedure Inherit_Aspects_At_Freeze_Point (Typ : Entity_Id) is + function Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item + (Rep_Item : Node_Id) return Boolean; + -- This routine checks if Rep_Item is either a pragma or an aspect + -- specification node whose correponding pragma (if any) is present in + -- the Rep Item chain of the entity it has been specified to. + + -------------------------------------------------- + -- Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item -- + -------------------------------------------------- + + function Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item + (Rep_Item : Node_Id) return Boolean + is + begin + return Nkind (Rep_Item) = N_Pragma + or else Present_In_Rep_Item + (Entity (Rep_Item), Aspect_Rep_Item (Rep_Item)); + end Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item; + + begin + -- A representation item is either subtype-specific (Size and Alignment + -- clauses) or type-related (all others). Subtype-specific aspects may + -- differ for different subtypes of the same type.(RM 13.1.8) + + -- A derived type inherits each type-related representation aspect of + -- its parent type that was directly specified before the declaration of + -- the derived type. (RM 13.1.15) + + -- A derived subtype inherits each subtype-specific representation + -- aspect of its parent subtype that was directly specified before the + -- declaration of the derived type .(RM 13.1.15) + + -- The general processing involves inheriting a representation aspect + -- from a parent type whenever the first rep item (aspect specification, + -- attribute definition clause, pragma) corresponding to the given + -- representation aspect in the rep item chain of Typ, if any, isn't + -- directly specified to Typ but to one of its parents. + + -- ??? Note that, for now, just a limited number of representation + -- aspects have been inherited here so far. Many of them are still + -- inherited in Sem_Ch3. This will be fixed soon. Here is a + -- non-exhaustive list of aspects that likely also need to be moved to + -- this routine: Alignment, Component_Alignment, Component_Size, + -- Machine_Radix, Object_Size, Pack, Predicates, + -- Preelaborable_Initialization, RM_Size and Small. + + if Nkind (Parent (Typ)) = N_Private_Extension_Declaration then + return; + end if; + + -- Ada_05/Ada_2005 + + if not Has_Rep_Item (Typ, Name_Ada_05, Name_Ada_2005, False) + and then Has_Rep_Item (Typ, Name_Ada_05, Name_Ada_2005) + and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item + (Get_Rep_Item (Typ, Name_Ada_05, Name_Ada_2005)) + then + Set_Is_Ada_2005_Only (Typ); + end if; + + -- Ada_12/Ada_2012 + + if not Has_Rep_Item (Typ, Name_Ada_12, Name_Ada_2012, False) + and then Has_Rep_Item (Typ, Name_Ada_12, Name_Ada_2012) + and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item + (Get_Rep_Item (Typ, Name_Ada_12, Name_Ada_2012)) + then + Set_Is_Ada_2012_Only (Typ); + end if; + + -- Atomic/Shared + + if not Has_Rep_Item (Typ, Name_Atomic, Name_Shared, False) + and then Has_Rep_Pragma (Typ, Name_Atomic, Name_Shared) + and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item + (Get_Rep_Item (Typ, Name_Atomic, Name_Shared)) + then + Set_Is_Atomic (Typ); + Set_Treat_As_Volatile (Typ); + Set_Is_Volatile (Typ); + end if; + + -- Default_Component_Value. + + if Is_Array_Type (Typ) + and then Has_Rep_Item (Typ, Name_Default_Component_Value, False) + and then Has_Rep_Item (Typ, Name_Default_Component_Value) + then + Set_Default_Aspect_Component_Value (Typ, + Default_Aspect_Component_Value + (Entity (Get_Rep_Item (Typ, Name_Default_Component_Value)))); + end if; + + -- Default_Value. + + if Is_Scalar_Type (Typ) + and then Has_Rep_Item (Typ, Name_Default_Value, False) + and then Has_Rep_Item (Typ, Name_Default_Value) + then + Set_Default_Aspect_Value (Typ, + Default_Aspect_Value + (Entity (Get_Rep_Item (Typ, Name_Default_Value)))); + end if; + + -- Discard_Names + + if not Has_Rep_Item (Typ, Name_Discard_Names, False) + and then Has_Rep_Item (Typ, Name_Discard_Names) + and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item + (Get_Rep_Item (Typ, Name_Discard_Names)) + then + Set_Discard_Names (Typ); + end if; + + -- Invariants + + if not Has_Rep_Item (Typ, Name_Invariant, False) + and then Has_Rep_Item (Typ, Name_Invariant) + and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item + (Get_Rep_Item (Typ, Name_Invariant)) + then + Set_Has_Invariants (Typ); + + if Class_Present (Get_Rep_Item (Typ, Name_Invariant)) then + Set_Has_Inheritable_Invariants (Typ); + end if; + end if; + + -- Volatile + + if not Has_Rep_Item (Typ, Name_Volatile, False) + and then Has_Rep_Item (Typ, Name_Volatile) + and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item + (Get_Rep_Item (Typ, Name_Volatile)) + then + Set_Treat_As_Volatile (Typ); + Set_Is_Volatile (Typ); + end if; + + -- Inheritance for derived types only + + if Is_Derived_Type (Typ) then + declare + Bas_Typ : constant Entity_Id := Base_Type (Typ); + Imp_Bas_Typ : constant Entity_Id := Implementation_Base_Type (Typ); + + begin + -- Atomic_Components + + if not Has_Rep_Item (Typ, Name_Atomic_Components, False) + and then Has_Rep_Item (Typ, Name_Atomic_Components) + and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item + (Get_Rep_Item (Typ, Name_Atomic_Components)) + then + Set_Has_Atomic_Components (Imp_Bas_Typ); + end if; + + -- Volatile_Components + + if not Has_Rep_Item (Typ, Name_Volatile_Components, False) + and then Has_Rep_Item (Typ, Name_Volatile_Components) + and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item + (Get_Rep_Item (Typ, Name_Volatile_Components)) + then + Set_Has_Volatile_Components (Imp_Bas_Typ); + end if; + + -- Finalize_Storage_Only. + + if not Has_Rep_Pragma (Typ, Name_Finalize_Storage_Only, False) + and then Has_Rep_Pragma (Typ, Name_Finalize_Storage_Only) + then + Set_Finalize_Storage_Only (Bas_Typ); + end if; + + -- Universal_Aliasing + + if not Has_Rep_Item (Typ, Name_Universal_Aliasing, False) + and then Has_Rep_Item (Typ, Name_Universal_Aliasing) + and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item + (Get_Rep_Item (Typ, Name_Universal_Aliasing)) + then + Set_Universal_Aliasing (Imp_Bas_Typ); + end if; + + -- Record type specific aspects + + if Is_Record_Type (Typ) then + -- Bit_Order + + if not Has_Rep_Item (Typ, Name_Bit_Order, False) + and then Has_Rep_Item (Typ, Name_Bit_Order) + then + Set_Reverse_Bit_Order (Bas_Typ, + Reverse_Bit_Order (Entity (Name + (Get_Rep_Item (Typ, Name_Bit_Order))))); + end if; + + -- Scalar_Storage_Order + + if not Has_Rep_Item (Typ, Name_Scalar_Storage_Order, False) + and then Has_Rep_Item (Typ, Name_Scalar_Storage_Order) + then + Set_Reverse_Storage_Order (Bas_Typ, + Reverse_Storage_Order (Entity (Name + (Get_Rep_Item (Typ, Name_Scalar_Storage_Order))))); + end if; + end if; + end; + end if; + end Inherit_Aspects_At_Freeze_Point; + ---------------- -- Initialize -- ---------------- diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads index ba335e19585..0ac7386e878 100644 --- a/gcc/ada/sem_ch13.ads +++ b/gcc/ada/sem_ch13.ads @@ -310,4 +310,8 @@ package Sem_Ch13 is -- Performs the processing described above at the freeze all point, and -- issues appropriate error messages if the visibility has indeed changed. -- Again, ASN is the N_Aspect_Specification node for the aspect. + + procedure Inherit_Aspects_At_Freeze_Point (Typ : Entity_Id); + -- Given an entity Typ that denotes a derived type or a subtype, this + -- routine performs the inheritance of aspects at the freeze point. end Sem_Ch13; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 9a690fdf0fa..b61821e6549 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -4048,12 +4048,9 @@ package body Sem_Ch3 is -- Inherit common attributes - Set_Is_Generic_Type (Id, Is_Generic_Type (Base_Type (T))); Set_Is_Volatile (Id, Is_Volatile (T)); Set_Treat_As_Volatile (Id, Treat_As_Volatile (T)); - Set_Is_Atomic (Id, Is_Atomic (T)); - Set_Is_Ada_2005_Only (Id, Is_Ada_2005_Only (T)); - Set_Is_Ada_2012_Only (Id, Is_Ada_2012_Only (T)); + Set_Is_Generic_Type (Id, Is_Generic_Type (Base_Type (T))); Set_Convention (Id, Convention (T)); -- If ancestor has predicates then so does the subtype, and in addition @@ -5855,13 +5852,6 @@ package body Sem_Ch3 is Analyze (N); - -- If pragma Discard_Names applies on the first subtype of the parent - -- type, then it must be applied on this subtype as well. - - if Einfo.Discard_Names (First_Subtype (Parent_Type)) then - Set_Discard_Names (Derived_Type); - end if; - -- Apply a range check. Since this range expression doesn't have an -- Etype, we have to specifically pass the Source_Typ parameter. Is -- this right??? @@ -7666,8 +7656,6 @@ package body Sem_Ch3 is -- Fields inherited from the Parent_Type - Set_Discard_Names - (Derived_Type, Einfo.Discard_Names (Parent_Type)); Set_Has_Specified_Layout (Derived_Type, Has_Specified_Layout (Parent_Type)); Set_Is_Limited_Composite @@ -7711,20 +7699,9 @@ package body Sem_Ch3 is Set_OK_To_Reorder_Components (Derived_Type, OK_To_Reorder_Components (Parent_Full)); - Set_Reverse_Bit_Order - (Derived_Type, Reverse_Bit_Order (Parent_Full)); - Set_Reverse_Storage_Order - (Derived_Type, Reverse_Storage_Order (Parent_Full)); end; end if; - -- Direct controlled types do not inherit Finalize_Storage_Only flag - - if not Is_Controlled (Parent_Type) then - Set_Finalize_Storage_Only - (Derived_Type, Finalize_Storage_Only (Parent_Type)); - end if; - -- Set fields for private derived types if Is_Private_Type (Derived_Type) then @@ -8043,11 +8020,6 @@ package body Sem_Ch3 is -- they are inherited from the parent type, and these invariants can -- be further inherited, so both flags are set. - if Has_Inheritable_Invariants (Parent_Type) then - Set_Has_Inheritable_Invariants (Derived_Type); - Set_Has_Invariants (Derived_Type); - end if; - -- We similarly inherit predicates if Has_Predicates (Parent_Type) then @@ -12218,7 +12190,6 @@ package body Sem_Ch3 is Set_Component_Type (T1, Component_Type (T2)); Set_Component_Size (T1, Component_Size (T2)); Set_Has_Controlled_Component (T1, Has_Controlled_Component (T2)); - Set_Finalize_Storage_Only (T1, Finalize_Storage_Only (T2)); Set_Has_Non_Standard_Rep (T1, Has_Non_Standard_Rep (T2)); Set_Has_Task (T1, Has_Task (T2)); Set_Is_Packed (T1, Is_Packed (T2)); @@ -12237,7 +12208,6 @@ package body Sem_Ch3 is Set_First_Index (T1, First_Index (T2)); Set_Is_Aliased (T1, Is_Aliased (T2)); - Set_Is_Atomic (T1, Is_Atomic (T2)); Set_Is_Volatile (T1, Is_Volatile (T2)); Set_Treat_As_Volatile (T1, Treat_As_Volatile (T2)); Set_Is_Constrained (T1, Is_Constrained (T2)); diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index 0f518375a1e..a2dd53c4087 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -1322,9 +1322,12 @@ package body Sem_Dim is -- value of the exponent must be known compile time. Otherwise, -- the exponentiation evaluation will return an error message. - if L_Has_Dimensions - and then Compile_Time_Known_Value (R) - then + if L_Has_Dimensions then + if not Compile_Time_Known_Value (R) then + Error_Msg_N ("exponent of dimensioned operand must be " & + "known at compile-time", N); + end if; + declare Exponent_Value : Rational := Zero; diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads index 6e70021db29..a2f69feac33 100644 --- a/gcc/ada/sem_eval.ads +++ b/gcc/ada/sem_eval.ads @@ -225,7 +225,7 @@ package Sem_Eval is -- are statically matching subtypes (RM 4.9.1(1-2)). function Compile_Time_Known_Value (Op : Node_Id) return Boolean; - -- Returns true if Op is an expression not raising constraint error whose + -- Returns true if Op is an expression not raising Constraint_Error whose -- value is known at compile time. This is true if Op is a static -- expression, but can also be true for expressions which are technically -- non-static but which are in fact known at compile time, such as the @@ -236,9 +236,12 @@ package Sem_Eval is function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean; -- Similar to Compile_Time_Known_Value, but also returns True if the value - -- is a compile time known aggregate, i.e. an aggregate all of whose - -- constituent expressions are either compile time known values or compile - -- time known aggregates. + -- is a compile-time-known aggregate, i.e. an aggregate all of whose + -- constituent expressions are either compile-time-known values (based on + -- calling Compile_Time_Known_Value) or compile-time-known aggregates. + -- Note that the aggregate could still involve run-time checks that might + -- fail (such as for subtype checks in component associations), but the + -- evaluation of the expressions themselves will not raise an exception. function Compile_Time_Known_Bounds (T : Entity_Id) return Boolean; -- If T is an array whose index bounds are all known at compile time, then diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 8492948f4fe..560d6c24b95 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -669,7 +669,7 @@ package Sinfo is -- Present in N_Aggregate nodes. Set for aggregates which can be fully -- evaluated at compile time without raising constraint error. Such -- aggregates can be passed as is to Gigi without any expansion. See - -- Sem_Aggr for the specific conditions under which an aggregate has this + -- Exp_Aggr for the specific conditions under which an aggregate has this -- flag set. -- Componentwise_Assignment (Flag14-Sem) |