+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
-- 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;
-- 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
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))));
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 --
--------------------
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
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;
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;
** Terminal/serial I/O constants
**/
+#if defined(HAVE_TERMIOS) || defined(__MINGW32__)
/*
----------------------
----------------------
*/
+#endif
#ifdef HAVE_TERMIOS
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 --
--------------------
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);
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 --
--------------------
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 --
-------------------------------
-- 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;
-- 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;
-- 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
-- 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;
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);
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 --
----------------
-- 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;
-- 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
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???
-- 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
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
-- 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
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));
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));
-- 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;
-- 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
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
-- 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)
projects / platform / upstream / gcc.git / commitdiff