OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

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.

From-SVN: r190172
This commit is contained in:
Arnaud Charlet 2012-08-06 10:48:19 +02:00
parent 2eef7403a0
commit dc3af7e24f
13 changed files with 469 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
gcc/ada/ChangeLog
View File

@ -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

28
gcc/ada/exp_aggr.adb
View File

@ -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 --
--------------------

11
gcc/ada/freeze.adb
View File

@ -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

4
gcc/ada/prj-attr.adb
View File

@ -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;

2
gcc/ada/s-oscons-tmplt.c
View File

@ -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

110
gcc/ada/sem_aux.adb
View File

@ -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 := Get_Rep_Item (E, Nam, Check_Parents);
if Present (N) and then Nkind (N) = N_Pragma then
return N;
end if;
return Empty;
end Get_Rep_Pragma;
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 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;
-- If Check_Parents is False, return N if the pragma doesn't
-- appear in the Rep_Item chain of the parent.
else
declare
Par : constant Entity_Id := Nearest_Ancestor (E);
-- This node represents the parent type of type E (if any)
begin
if No (Par) or else not Present_In_Rep_Item (Par, N) then
return N;
end if;
end;
end if;
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 --
-------------------------------

66
gcc/ada/sem_aux.ads
View File

@ -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

222
gcc/ada/sem_ch13.adb
View File

@ -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 --
----------------

4
gcc/ada/sem_ch13.ads
View File

@ -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;

32
gcc/ada/sem_ch3.adb
View File

@ -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));

9
gcc/ada/sem_dim.adb
View File

@ -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;

11
gcc/ada/sem_eval.ads
View File

@ -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

2
gcc/ada/sinfo.ads
View File

@ -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)