-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
After : in out Node_Id)
is
Body_Node : constant Node_Id := Build_Renamed_Body (Decl, New_S);
-
begin
Insert_After (After, Body_Node);
Mark_Rewrite_Insertion (Body_Node);
-- Loop through components
- Comp := First_Entity (T);
+ Comp := First_Component_Or_Discriminant (T);
while Present (Comp) loop
- if Ekind (Comp) = E_Component
- or else
- Ekind (Comp) = E_Discriminant
- then
- Ctyp := Etype (Comp);
+ Ctyp := Etype (Comp);
- -- We do not know the packed size if there is a
- -- component clause present (we possibly could,
- -- but this would only help in the case of a record
- -- with partial rep clauses. That's because in the
- -- case of full rep clauses, the size gets figured
- -- out anyway by a different circuit).
+ -- We do not know the packed size if there is a component
+ -- clause present (we possibly could, but this would only
+ -- help in the case of a record with partial rep clauses.
+ -- That's because in the case of full rep clauses, the
+ -- size gets figured out anyway by a different circuit).
- if Present (Component_Clause (Comp)) then
- Packed_Size_Known := False;
- end if;
+ if Present (Component_Clause (Comp)) then
+ Packed_Size_Known := False;
+ end if;
- -- We need to identify a component that is an array
- -- where the index type is an enumeration type with
- -- non-standard representation, and some bound of the
- -- type depends on a discriminant.
-
- -- This is because gigi computes the size by doing a
- -- substituation of the appropriate discriminant value
- -- in the size expression for the base type, and gigi
- -- is not clever enough to evaluate the resulting
- -- expression (which involves a call to rep_to_pos)
- -- at compile time.
-
- -- It would be nice if gigi would either recognize that
- -- this expression can be computed at compile time, or
- -- alternatively figured out the size from the subtype
- -- directly, where all the information is at hand ???
-
- if Is_Array_Type (Etype (Comp))
- and then Present (Packed_Array_Type (Etype (Comp)))
- then
- declare
- Ocomp : constant Entity_Id :=
- Original_Record_Component (Comp);
- OCtyp : constant Entity_Id := Etype (Ocomp);
- Ind : Node_Id;
- Indtyp : Entity_Id;
- Lo, Hi : Node_Id;
+ -- We need to identify a component that is an array where
+ -- the index type is an enumeration type with non-standard
+ -- representation, and some bound of the type depends on a
+ -- discriminant.
- begin
- Ind := First_Index (OCtyp);
- while Present (Ind) loop
- Indtyp := Etype (Ind);
+ -- This is because gigi computes the size by doing a
+ -- substituation of the appropriate discriminant value in
+ -- the size expression for the base type, and gigi is not
+ -- clever enough to evaluate the resulting expression (which
+ -- involves a call to rep_to_pos) at compile time.
- if Is_Enumeration_Type (Indtyp)
- and then Has_Non_Standard_Rep (Indtyp)
- then
- Lo := Type_Low_Bound (Indtyp);
- Hi := Type_High_Bound (Indtyp);
-
- if Is_Entity_Name (Lo)
- and then
- Ekind (Entity (Lo)) = E_Discriminant
- then
- return False;
-
- elsif Is_Entity_Name (Hi)
- and then
- Ekind (Entity (Hi)) = E_Discriminant
- then
- return False;
- end if;
- end if;
+ -- It would be nice if gigi would either recognize that
+ -- this expression can be computed at compile time, or
+ -- alternatively figured out the size from the subtype
+ -- directly, where all the information is at hand ???
- Next_Index (Ind);
- end loop;
- end;
- end if;
+ if Is_Array_Type (Etype (Comp))
+ and then Present (Packed_Array_Type (Etype (Comp)))
+ then
+ declare
+ Ocomp : constant Entity_Id :=
+ Original_Record_Component (Comp);
+ OCtyp : constant Entity_Id := Etype (Ocomp);
+ Ind : Node_Id;
+ Indtyp : Entity_Id;
+ Lo, Hi : Node_Id;
- -- Clearly size of record is not known if the size of
- -- one of the components is not known.
+ begin
+ Ind := First_Index (OCtyp);
+ while Present (Ind) loop
+ Indtyp := Etype (Ind);
- if not Size_Known (Ctyp) then
- return False;
- end if;
+ if Is_Enumeration_Type (Indtyp)
+ and then Has_Non_Standard_Rep (Indtyp)
+ then
+ Lo := Type_Low_Bound (Indtyp);
+ Hi := Type_High_Bound (Indtyp);
- -- Accumulate packed size if possible
+ if Is_Entity_Name (Lo)
+ and then Ekind (Entity (Lo)) = E_Discriminant
+ then
+ return False;
- if Packed_Size_Known then
+ elsif Is_Entity_Name (Hi)
+ and then Ekind (Entity (Hi)) = E_Discriminant
+ then
+ return False;
+ end if;
+ end if;
- -- We can only deal with elementary types, since for
- -- non-elementary components, alignment enters into
- -- the picture, and we don't know enough to handle
- -- proper alignment in this context. Packed arrays
- -- count as elementary if the representation is a
- -- modular type.
+ Next_Index (Ind);
+ end loop;
+ end;
+ end if;
- if Is_Elementary_Type (Ctyp)
- or else (Is_Array_Type (Ctyp)
- and then
- Present (Packed_Array_Type (Ctyp))
- and then
- Is_Modular_Integer_Type
- (Packed_Array_Type (Ctyp)))
- then
- -- If RM_Size is known and static, then we can
- -- keep accumulating the packed size.
+ -- Clearly size of record is not known if the size of
+ -- one of the components is not known.
- if Known_Static_RM_Size (Ctyp) then
+ if not Size_Known (Ctyp) then
+ return False;
+ end if;
- -- A little glitch, to be removed sometime ???
- -- gigi does not understand zero sizes yet.
+ -- Accumulate packed size if possible
- if RM_Size (Ctyp) = Uint_0 then
- Packed_Size_Known := False;
+ if Packed_Size_Known then
- -- Normal case where we can keep accumulating
- -- the packed array size.
+ -- We can only deal with elementary types, since for
+ -- non-elementary components, alignment enters into the
+ -- picture, and we don't know enough to handle proper
+ -- alignment in this context. Packed arrays count as
+ -- elementary if the representation is a modular type.
- else
- Packed_Size := Packed_Size + RM_Size (Ctyp);
- end if;
+ if Is_Elementary_Type (Ctyp)
+ or else (Is_Array_Type (Ctyp)
+ and then Present (Packed_Array_Type (Ctyp))
+ and then Is_Modular_Integer_Type
+ (Packed_Array_Type (Ctyp)))
+ then
+ -- If RM_Size is known and static, then we can
+ -- keep accumulating the packed size.
- -- If we have a field whose RM_Size is not known
- -- then we can't figure out the packed size here.
+ if Known_Static_RM_Size (Ctyp) then
- else
+ -- A little glitch, to be removed sometime ???
+ -- gigi does not understand zero sizes yet.
+
+ if RM_Size (Ctyp) = Uint_0 then
Packed_Size_Known := False;
+
+ -- Normal case where we can keep accumulating the
+ -- packed array size.
+
+ else
+ Packed_Size := Packed_Size + RM_Size (Ctyp);
end if;
- -- If we have a non-elementary type we can't figure
- -- out the packed array size (alignment issues).
+ -- If we have a field whose RM_Size is not known then
+ -- we can't figure out the packed size here.
else
Packed_Size_Known := False;
end if;
+
+ -- If we have a non-elementary type we can't figure out
+ -- the packed array size (alignment issues).
+
+ else
+ Packed_Size_Known := False;
end if;
end if;
- Next_Entity (Comp);
+ Next_Component_Or_Discriminant (Comp);
end loop;
if Packed_Size_Known then
Comp := First_Entity (Rec);
Prev := Empty;
-
while Present (Comp) loop
-- First handle the (real) component case
end if;
-- If component clause is present, then deal with the
- -- non-default bit order case. We cannot do this before
- -- the freeze point, because there is no required order
- -- for the component clause and the bit_order clause.
+ -- non-default bit order case for Ada 95 mode. The required
+ -- processing for Ada 2005 mode is handled separately after
+ -- processing all components.
-- We only do this processing for the base type, and in
-- fact that's important, since otherwise if there are
if Present (CC)
and then Reverse_Bit_Order (Rec)
and then Ekind (E) = E_Record_Type
+ and then Ada_Version <= Ada_95
then
declare
CFB : constant Uint := Component_Bit_Offset (Comp);
else
-- Give warning if suspicious component clause
- if Intval (FB) >= System_Storage_Unit then
+ if Intval (FB) >= System_Storage_Unit
+ and then Warn_On_Reverse_Bit_Order
+ then
Error_Msg_N
("?Bit_Order clause does not affect " &
"byte ordering", Pos);
S : Entity_Id := Scope (Rec);
begin
- -- We have a pretty bad kludge here. Suppose Rec is a
- -- subtype being defined in a subprogram that's created
- -- as part of the freezing of Rec'Base. In that case,
- -- we know that Comp'Base must have already been frozen by
- -- the time we get to elaborate this because Gigi doesn't
- -- elaborate any bodies until it has elaborated all of the
- -- declarative part. But Is_Frozen will not be set at this
- -- point because we are processing code in lexical order.
-
- -- We detect this case by going up the Scope chain of
- -- Rec and seeing if we have a subprogram scope before
- -- reaching the top of the scope chain or that of Comp'Base.
- -- If we do, then mark that Comp'Base will actually be
- -- frozen. If so, we merely undelay it.
+ -- We have a pretty bad kludge here. Suppose Rec is subtype
+ -- being defined in a subprogram that's created as part of
+ -- the freezing of Rec'Base. In that case, we know that
+ -- Comp'Base must have already been frozen by the time we
+ -- get to elaborate this because Gigi doesn't elaborate any
+ -- bodies until it has elaborated all of the declarative
+ -- part. But Is_Frozen will not be set at this point because
+ -- we are processing code in lexical order.
+
+ -- We detect this case by going up the Scope chain of Rec
+ -- and seeing if we have a subprogram scope before reaching
+ -- the top of the scope chain or that of Comp'Base. If we
+ -- do, then mark that Comp'Base will actually be frozen. If
+ -- so, we merely undelay it.
while Present (S) loop
if Is_Subprogram (S) then
Next_Entity (Comp);
end loop;
- -- Check for useless pragma Bit_Order
+ -- Deal with pragma Bit_Order
+
+ if Reverse_Bit_Order (Rec) and then Base_Type (Rec) = Rec then
+ if not Placed_Component then
+ ADC :=
+ Get_Attribute_Definition_Clause (Rec, Attribute_Bit_Order);
+ Error_Msg_N
+ ("?Bit_Order specification has no effect", ADC);
+ Error_Msg_N
+ ("\?since no component clauses were specified", ADC);
+
+ -- Here is where we do Ada 2005 processing for bit order (the
+ -- Ada 95 case was already taken care of above).
- if not Placed_Component and then Reverse_Bit_Order (Rec) then
- ADC := Get_Attribute_Definition_Clause (Rec, Attribute_Bit_Order);
- Error_Msg_N ("?Bit_Order specification has no effect", ADC);
- Error_Msg_N ("\?since no component clauses were specified", ADC);
+ elsif Ada_Version >= Ada_05 then
+ Adjust_Record_For_Reverse_Bit_Order (Rec);
+ end if;
end if;
- -- Check for useless pragma Pack when all components placed
+ -- Check for useless pragma Pack when all components placed. We only
+ -- do this check for record types, not subtypes, since a subtype may
+ -- have all its components placed, and it still makes perfectly good
+ -- sense to pack other subtypes or the parent type.
- if Is_Packed (Rec)
+ if Ekind (Rec) = E_Record_Type
+ and then Is_Packed (Rec)
and then not Unplaced_Component
- and then Warn_On_Redundant_Constructs
then
- Error_Msg_N
- ("?pragma Pack has no effect, no unplaced components",
- Get_Rep_Pragma (Rec, Name_Pack));
+ -- Reset packed status. Probably not necessary, but we do it
+ -- so that there is no chance of the back end doing something
+ -- strange with this redundant indication of packing.
+
Set_Is_Packed (Rec, False);
+
+ -- Give warning if redundant constructs warnings on
+
+ if Warn_On_Redundant_Constructs then
+ Error_Msg_N
+ ("?pragma Pack has no effect, no unplaced components",
+ Get_Rep_Pragma (Rec, Name_Pack));
+ end if;
end if;
- -- If this is the record corresponding to a remote type,
- -- freeze the remote type here since that is what we are
- -- semantically freezing. This prevents having the freeze
- -- node for that type in an inner scope.
+ -- If this is the record corresponding to a remote type, freeze the
+ -- remote type here since that is what we are semantically freezing.
+ -- This prevents the freeze node for that type in an inner scope.
-- Also, Check for controlled components and unchecked unions.
- -- Finally, enforce the restriction that access attributes with
- -- a current instance prefix can only apply to limited types.
+ -- Finally, enforce the restriction that access attributes with a
+ -- current instance prefix can only apply to limited types.
if Ekind (Rec) = E_Record_Type then
if Present (Corresponding_Remote_Type (Rec)) then
if Has_Per_Object_Constraint (Comp)
and then not Is_Limited_Type (Rec)
then
- -- Scan component declaration for likely misuses of
- -- current instance, either in a constraint or in a
- -- default expression.
+ -- Scan component declaration for likely misuses of current
+ -- instance, either in a constraint or a default expression.
Check_Current_Instance (Parent (Comp));
end if;
Set_Component_Alignment_If_Not_Set (Rec);
- -- For first subtypes, check if there are any fixed-point
- -- fields with component clauses, where we must check the size.
- -- This is not done till the freeze point, since for fixed-point
- -- types, we do not know the size until the type is frozen.
- -- Similar processing applies to bit packed arrays.
+ -- For first subtypes, check if there are any fixed-point fields with
+ -- component clauses, where we must check the size. This is not done
+ -- till the freeze point, since for fixed-point types, we do not know
+ -- the size until the type is frozen. Similar processing applies to
+ -- bit packed arrays.
if Is_First_Subtype (Rec) then
Comp := First_Component (Rec);
-- must be diagnosed (see e.g. 1522-005). If the enclosing subprogram
-- comes from source, or is a generic instance, then the freeze point
-- is the one mandated by the language. and we freze the entity.
+ -- A subprogram that is a child unit body that acts as a spec does not
+ -- have a spec that comes from source, but can only come from source.
elsif In_Open_Scopes (Scope (Test_E))
and then Scope (Test_E) /= Current_Scope
if Is_Overloadable (S) then
if Comes_From_Source (S)
or else Is_Generic_Instance (S)
+ or else Is_Child_Unit (S)
then
exit;
else
if Nkind (Expr) = N_Aggregate then
Expand_Atomic_Aggregate (Expr, Etype (E));
- -- If the expression is a reference to a record or array
- -- object entity, then reset Is_True_Constant to False so
- -- that the compiler will not optimize away the intermediate
- -- object, which we need in this case for the same reason
- -- (to ensure that the actual assignment is atomic, rather
- -- than component-wise).
+ -- If the expression is a reference to a record or array object
+ -- entity, then reset Is_True_Constant to False so that the
+ -- compiler will not optimize away the intermediate object,
+ -- which we need in this case for the same reason (to ensure
+ -- that the actual assignment is atomic, rather than
+ -- component-wise).
elsif Is_Entity_Name (Expr)
and then (Is_Record_Type (Etype (Expr))
if Formal = First_Formal (E) then
Error_Msg_NE
- ("?in inherited operation&!", Warn_Node, E);
+ ("?in inherited operation&", Warn_Node, E);
end if;
else
Warn_Node := Formal;
Error_Msg_N
("(Ada 2005): invalid use of unconstrained tagged"
& " incomplete type", E);
+
+ elsif Ekind (F_Type) = E_Subprogram_Type then
+ Freeze_And_Append (F_Type, Loc, Result);
end if;
end if;
Freeze_And_Append (Alias (E), Loc, Result);
end if;
- -- If the return type requires a transient scope, and we are on
- -- a target allowing functions to return with a depressed stack
- -- pointer, then we mark the function as requiring this treatment.
-
- if Ekind (E) = E_Function
- and then Functions_Return_By_DSP_On_Target
- and then Requires_Transient_Scope (Etype (E))
- then
- Set_Function_Returns_With_DSP (E);
- end if;
-
if not Is_Internal (E) then
Freeze_Subprogram (E);
end if;
-- pragma is to suppress implicit initialization.
if Is_Imported (E)
- and then not Present (Address_Clause (E))
+ and then No (Address_Clause (E))
then
Set_Is_Public (E);
end if;
-- Case of a type or subtype being frozen
else
+ -- Check preelaborable initialization for full type completing a
+ -- private type for which pragma Preelaborable_Initialization given.
+
+ if Must_Have_Preelab_Init (E)
+ and then not Has_Preelaborable_Initialization (E)
+ then
+ Error_Msg_N
+ ("full view of & does not have preelaborable initialization", E);
+ end if;
+
-- The type may be defined in a generic unit. This can occur when
-- freezing a generic function that returns the type (which is
-- defined in a parent unit). It is clearly meaningless to freeze
Freeze_And_Append (Packed_Array_Type (E), Loc, Result);
-- Size information of packed array type is copied to the
- -- array type, since this is really the representation.
+ -- array type, since this is really the representation. But
+ -- do not override explicit existing size values.
- Set_Size_Info (E, Packed_Array_Type (E));
- Set_RM_Size (E, RM_Size (Packed_Array_Type (E)));
+ if not Has_Size_Clause (E) then
+ Set_Esize (E, Esize (Packed_Array_Type (E)));
+ Set_RM_Size (E, RM_Size (Packed_Array_Type (E)));
+ end if;
+
+ if not Has_Alignment_Clause (E) then
+ Set_Alignment (E, Alignment (Packed_Array_Type (E)));
+ end if;
end if;
-- For non-packed arrays set the alignment of the array
Next_Entity (Comp);
end loop;
- -- Private types are required to point to the same freeze node
- -- as their corresponding full views. The freeze node itself
- -- has to point to the partial view of the entity (because
- -- from the partial view, we can retrieve the full view, but
- -- not the reverse). However, in order to freeze correctly,
- -- we need to freeze the full view. If we are freezing at the
- -- end of a scope (or within the scope of the private type),
- -- the partial and full views will have been swapped, the
- -- full view appears first in the entity chain and the swapping
- -- mechanism ensures that the pointers are properly set (on
- -- scope exit).
-
- -- If we encounter the partial view before the full view
- -- (e.g. when freezing from another scope), we freeze the
- -- full view, and then set the pointers appropriately since
- -- we cannot rely on swapping to fix things up (subtypes in an
- -- outer scope might not get swapped).
+ -- Private types are required to point to the same freeze node as
+ -- their corresponding full views. The freeze node itself has to
+ -- point to the partial view of the entity (because from the partial
+ -- view, we can retrieve the full view, but not the reverse).
+ -- However, in order to freeze correctly, we need to freeze the full
+ -- view. If we are freezing at the end of a scope (or within the
+ -- scope of the private type), the partial and full views will have
+ -- been swapped, the full view appears first in the entity chain and
+ -- the swapping mechanism ensures that the pointers are properly set
+ -- (on scope exit).
+
+ -- If we encounter the partial view before the full view (e.g. when
+ -- freezing from another scope), we freeze the full view, and then
+ -- set the pointers appropriately since we cannot rely on swapping to
+ -- fix things up (subtypes in an outer scope might not get swapped).
elsif Is_Incomplete_Or_Private_Type (E)
and then not Is_Generic_Type (E)
if Present (Full_View (E)) then
- -- If full view has already been frozen, then no
- -- further processing is required
+ -- If full view has already been frozen, then no further
+ -- processing is required
if Is_Frozen (Full_View (E)) then
Set_Freeze_Node (E, Empty);
Check_Debug_Info_Needed (E);
- -- Otherwise freeze full view and patch the pointers
- -- so that the freeze node will elaborate both views
- -- in the back-end.
+ -- Otherwise freeze full view and patch the pointers so that
+ -- the freeze node will elaborate both views in the back-end.
else
declare
Check_Debug_Info_Needed (E);
end if;
- -- AI-117 requires that the convention of a partial view
- -- be the same as the convention of the full view. Note
- -- that this is a recognized breach of privacy, but it's
- -- essential for logical consistency of representation,
- -- and the lack of a rule in RM95 was an oversight.
+ -- AI-117 requires that the convention of a partial view be the
+ -- same as the convention of the full view. Note that this is a
+ -- recognized breach of privacy, but it's essential for logical
+ -- consistency of representation, and the lack of a rule in
+ -- RM95 was an oversight.
Set_Convention (E, Convention (Full_View (E)));
-- Size information is copied from the full view to the
-- incomplete or private view for consistency
- -- We skip this is the full view is not a type. This is
- -- very strange of course, and can only happen as a result
- -- of certain illegalities, such as a premature attempt to
- -- derive from an incomplete type.
+ -- We skip this is the full view is not a type. This is very
+ -- strange of course, and can only happen as a result of
+ -- certain illegalities, such as a premature attempt to derive
+ -- from an incomplete type.
if Is_Type (Full_View (E)) then
Set_Size_Info (E, Full_View (E));
Next_Formal (Formal);
end loop;
- -- If the return type requires a transient scope, and we are on
- -- a target allowing functions to return with a depressed stack
- -- pointer, then we mark the function as requiring this treatment.
-
- if Functions_Return_By_DSP_On_Target
- and then Requires_Transient_Scope (Etype (E))
- then
- Set_Function_Returns_With_DSP (E);
- end if;
-
Freeze_Subprogram (E);
- -- AI-326: Check wrong use of tag incomplete type
+ -- Ada 2005 (AI-326): Check wrong use of tag incomplete type
--
-- type T is tagged;
-- type Acc is access function (X : T) return T; -- ERROR
("(Ada 2005): invalid use of tagged incomplete type", E);
end if;
- -- For access to a protected subprogram, freeze the equivalent
- -- type (however this is not set if we are not generating code)
- -- or if this is an anonymous type used just for resolution).
+ -- For access to a protected subprogram, freeze the equivalent type
+ -- (however this is not set if we are not generating code or if this
+ -- is an anonymous type used just for resolution).
- elsif Ekind (E) = E_Access_Protected_Subprogram_Type then
+ elsif Is_Access_Protected_Subprogram_Type (E) then
-- AI-326: Check wrong use of tagged incomplete types
end if;
end;
- if Operating_Mode = Generate_Code
- and then Present (Equivalent_Type (E))
- then
+ if Present (Equivalent_Type (E)) then
Freeze_And_Append (Equivalent_Type (E), Loc, Result);
end if;
end if;
if Is_Fixed_Point_Type (E) then
Freeze_Fixed_Point_Type (E);
- -- Some error checks required for ordinary fixed-point type.
- -- Defer these till the freeze-point since we need the small
- -- and range values. We only do these checks for base types
+ -- Some error checks required for ordinary fixed-point type. Defer
+ -- these till the freeze-point since we need the small and range
+ -- values. We only do these checks for base types
if Is_Ordinary_Fixed_Point_Type (E)
and then E = Base_Type (E)
-- inherit the convention of the full view of the type. Inherited
-- and overriding operations are defined to inherit the convention
-- of their parent or overridden subprogram (also specified in
- -- AI-117), and that will have occurred earlier (in
- -- Derive_Subprogram and New_Overloaded_Entity). Here we set the
- -- convention of primitives that are still convention Ada, which
- -- will ensure that any new primitives inherit the type's
- -- convention. Class-wide types can have a foreign convention
- -- inherited from their specific type, but are excluded from this
- -- since they don't have any associated primitives.
+ -- AI-117), which will have occurred earlier (in Derive_Subprogram
+ -- and New_Overloaded_Entity). Here we set the convention of
+ -- primitives that are still convention Ada, which will ensure
+ -- that any new primitives inherit the type's convention.
+ -- Class-wide types can have a foreign convention inherited from
+ -- their specific type, but are excluded from this since they
+ -- don't have any associated primitives.
if Is_Tagged_Type (E)
and then not Is_Class_Wide_Type (E)
Prim_List : Elist_Id;
Prim : Elmt_Id;
Ent : Entity_Id;
+ Aux_E : Entity_Id;
begin
+ -- Handle subtypes
+
+ if Ekind (E) = E_Protected_Subtype
+ or else Ekind (E) = E_Task_Subtype
+ then
+ Aux_E := Etype (E);
+ else
+ Aux_E := E;
+ end if;
+
-- Ada 2005 (AI-345): In case of concurrent type generate
-- reference to the wrapper that allow us to dispatch calls
-- through their implemented abstract interface types.
-- The check for Present here is to protect against previously
-- reported critical errors.
- if Is_Concurrent_Type (E)
- and then Present (Corresponding_Record_Type (E))
+ if Is_Concurrent_Type (Aux_E)
+ and then Present (Corresponding_Record_Type (Aux_E))
then
- pragma Assert (not Is_Empty_Elmt_List
- (Abstract_Interfaces
- (Corresponding_Record_Type (E))));
-
Prim_List := Primitive_Operations
- (Corresponding_Record_Type (E));
+ (Corresponding_Record_Type (Aux_E));
else
- Prim_List := Primitive_Operations (E);
+ Prim_List := Primitive_Operations (Aux_E);
end if;
-- Loop to generate references for primitive operations
- Prim := First_Elmt (Prim_List);
- while Present (Prim) loop
- Ent := Node (Prim);
-
- -- If the operation is derived, get the original for cross-
- -- reference purposes (it is the original for which we want
- -- the xref, and for which the comes from source test needs
- -- to be performed).
-
- while Present (Alias (Ent)) loop
- Ent := Alias (Ent);
- end loop;
+ if Present (Prim_List) then
+ Prim := First_Elmt (Prim_List);
+ while Present (Prim) loop
- Generate_Reference (E, Ent, 'p', Set_Ref => False);
- Next_Elmt (Prim);
- end loop;
+ -- If the operation is derived, get the original for
+ -- cross-reference purposes (it is the original for
+ -- which we want the xref, and for which the comes
+ -- from source test needs to be performed).
- -- If we get an exception, then something peculiar has happened
- -- probably as a result of a previous error. Since this is only
- -- for non-critical cross-references, ignore the error.
+ Ent := Node (Prim);
+ while Present (Alias (Ent)) loop
+ Ent := Alias (Ent);
+ end loop;
- exception
- when others => null;
+ Generate_Reference (E, Ent, 'p', Set_Ref => False);
+ Next_Elmt (Prim);
+ end loop;
+ end if;
end;
end if;
- -- Now that all types from which E may depend are frozen, see
- -- if the size is known at compile time, if it must be unsigned,
- -- or if strict alignent is required
+ -- Now that all types from which E may depend are frozen, see if the
+ -- size is known at compile time, if it must be unsigned, or if
+ -- strict alignent is required
Check_Compile_Time_Size (E);
Check_Unsigned_Type (E);
-- For an allocator freeze designated type if not frozen already
- -- For an aggregate whose component type is an access type, freeze
- -- the designated type now, so that its freeze does not appear within
- -- the loop that might be created in the expansion of the aggregate.
- -- If the designated type is a private type without full view, the
- -- expression cannot contain an allocator, so the type is not frozen.
+ -- For an aggregate whose component type is an access type, freeze the
+ -- designated type now, so that its freeze does not appear within the
+ -- loop that might be created in the expansion of the aggregate. If the
+ -- designated type is a private type without full view, the expression
+ -- cannot contain an allocator, so the type is not frozen.
Desig_Typ := Empty;
loop
Parent_P := Parent (P);
- -- If we don't have a parent, then we are not in a well-formed
- -- tree. This is an unusual case, but there are some legitimate
- -- situations in which this occurs, notably when the expressions
- -- in the range of a type declaration are resolved. We simply
- -- ignore the freeze request in this case. Is this right ???
+ -- If we don't have a parent, then we are not in a well-formed tree.
+ -- This is an unusual case, but there are some legitimate situations
+ -- in which this occurs, notably when the expressions in the range of
+ -- a type declaration are resolved. We simply ignore the freeze
+ -- request in this case. Is this right ???
if No (Parent_P) then
return;
then
return;
- -- If enumeration literal appears as the name of a
- -- function which is the choice, then also do not freeze.
- -- This happens in the overloaded literal case, where the
+ -- If enumeration literal appears as the name of function
+ -- which is the choice, then also do not freeze. This
+ -- happens in the overloaded literal case, where the
-- enumeration literal is temporarily changed to a function
-- call for overloading analysis purposes.
exit;
end if;
- -- If parent is a body or a spec or a block, then the current
- -- node is a statement or declaration and we can insert the
- -- freeze node before it.
+ -- If parent is a body or a spec or a block, then the current node
+ -- is a statement or declaration and we can insert the freeze node
+ -- before it.
when N_Package_Specification |
N_Package_Body |
-- appears in the source can never be frozen in a loop (this
-- occurs only because of a loop expanded by the expander), so we
-- keep on going. Otherwise we terminate the search. Same is true
- -- of any entity which comes from source. (if they have a
- -- predefined type, that type does not appear to come from source,
- -- but the entity should not be frozen here).
+ -- of any entity which comes from source. (if they have predefined
+ -- type, that type does not appear to come from source, but the
+ -- entity should not be frozen here).
when N_Loop_Statement =>
exit when not Comes_From_Source (Etype (N))
-- the outer record type so they can eventually be placed in the
-- enclosing declaration list.
- -- The other case requiring this special handling is if we are in
- -- a default expression, since in that case we are about to freeze
- -- a static type, and the freeze scope needs to be the outer scope,
- -- not the scope of the subprogram with the default parameter.
+ -- The other case requiring this special handling is if we are in a
+ -- default expression, since in that case we are about to freeze a
+ -- static type, and the freeze scope needs to be the outer scope, not
+ -- the scope of the subprogram with the default parameter.
-- For default expressions in generic units, the Move_Freeze_Nodes
- -- mechanism (see sem_ch12.adb) takes care of placing them at the
- -- proper place, after the generic unit.
+ -- mechanism (see sem_ch12.adb) takes care of placing them at the proper
+ -- place, after the generic unit.
if (In_Def_Exp and not Inside_A_Generic)
or else Freeze_Outside
-- Now we have the right place to do the freezing. First, a special
-- adjustment, if we are in default expression analysis mode, these
- -- freeze actions must not be thrown away (normally all inserted
- -- actions are thrown away in this mode. However, the freeze actions
- -- are from static expressions and one of the important reasons we
- -- are doing this special analysis is to get these freeze actions.
- -- Therefore we turn off the In_Default_Expression mode to propagate
- -- these freeze actions. This also means they get properly analyzed
- -- and expanded.
+ -- freeze actions must not be thrown away (normally all inserted actions
+ -- are thrown away in this mode. However, the freeze actions are from
+ -- static expressions and one of the important reasons we are doing this
+ -- special analysis is to get these freeze actions. Therefore we turn
+ -- off the In_Default_Expression mode to propagate these freeze actions.
+ -- This also means they get properly analyzed and expanded.
In_Default_Expression := False;
end if;
end if;
- -- Immediate return if the range is already analyzed. This means
- -- that the range is already set, and does not need to be computed
- -- by this routine.
+ -- Immediate return if the range is already analyzed. This means that
+ -- the range is already set, and does not need to be computed by this
+ -- routine.
if Analyzed (Rng) then
return;
if Is_Ordinary_Fixed_Point_Type (Typ) then
-- For the ordinary fixed-point case, we are allowed to fudge the
- -- end-points up or down by small. Generally we prefer to fudge
- -- up, i.e. widen the bounds for non-model numbers so that the
- -- end points are included. However there are cases in which this
- -- cannot be done, and indeed cases in which we may need to narrow
- -- the bounds. The following circuit makes the decision.
+ -- end-points up or down by small. Generally we prefer to fudge up,
+ -- i.e. widen the bounds for non-model numbers so that the end points
+ -- are included. However there are cases in which this cannot be
+ -- done, and indeed cases in which we may need to narrow the bounds.
+ -- The following circuit makes the decision.
- -- Note: our terminology here is that Incl_EP means that the
- -- bounds are widened by Small if necessary to include the end
- -- points, and Excl_EP means that the bounds are narrowed by
- -- Small to exclude the end-points if this reduces the size.
+ -- Note: our terminology here is that Incl_EP means that the bounds
+ -- are widened by Small if necessary to include the end points, and
+ -- Excl_EP means that the bounds are narrowed by Small to exclude the
+ -- end-points if this reduces the size.
-- Note that in the Incl case, all we care about is including the
-- end-points. In the Excl case, we want to narrow the bounds as
Hival_Excl_EP := Hival_Incl_EP;
end if;
- -- One further adjustment is needed. In the case of subtypes,
- -- we cannot go outside the range of the base type, or we get
+ -- One further adjustment is needed. In the case of subtypes, we
+ -- cannot go outside the range of the base type, or we get
-- peculiarities, and the base type range is already set. This
- -- only applies to the Incl values, since clearly the Excl
- -- values are already as restricted as they are allowed to be.
+ -- only applies to the Incl values, since clearly the Excl values
+ -- are already as restricted as they are allowed to be.
if Typ /= Btyp then
Loval_Incl_EP := UR_Max (Loval_Incl_EP, Realval (BLo));
-- static. This happens if the type depends on non-global objects.
procedure Ensure_Expression_Is_SA (N : Node_Id);
- -- Called to ensure that an expression used as part of a type
- -- definition is statically allocatable, which means that the type
- -- of the expression is statically allocatable, and the expression
- -- is either static, or a reference to a library level constant.
+ -- Called to ensure that an expression used as part of a type definition
+ -- is statically allocatable, which means that the expression type is
+ -- statically allocatable, and the expression is either static, or a
+ -- reference to a library level constant.
procedure Ensure_Type_Is_SA (Typ : Entity_Id);
-- Called to mark a type as static, checking that it is possible
return;
end if;
- -- We are also OK if the type is already marked as statically
- -- allocated, which means we processed it before.
+ -- We are also OK if the type already marked as statically allocated,
+ -- which means we processed it before.
if Is_Statically_Allocated (Typ) then
return;
elsif Is_Record_Type (Typ) then
C := First_Entity (Typ);
-
while Present (C) loop
if Ekind (C) = E_Discriminant
or else Ekind (C) = E_Component
-- Reset True_Constant flag, since something strange is going on with
-- the scoping here, and our simple value tracing may not be sufficient
-- for this indication to be reliable. We kill the Constant_Value
- -- indication for the same reason.
+ -- and Last_Assignment indications for the same reason.
Set_Is_True_Constant (E, False);
Set_Current_Value (E, Empty);
+ if Ekind (E) = E_Variable then
+ Set_Last_Assignment (E, Empty);
+ end if;
+
exception
when Cannot_Be_Static =>
-- Reset the Pure indication on an imported subprogram unless an
-- explicit Pure_Function pragma was present. We do this because
- -- otherwise it is an insidious error to call a non-pure function
- -- from pure unit and have calls mysteriously optimized away. What
- -- happens here is that the Import can bypass the normal check to
- -- ensure that pure units call only pure subprograms.
+ -- otherwise it is an insidious error to call a non-pure function from
+ -- pure unit and have calls mysteriously optimized away. What happens
+ -- here is that the Import can bypass the normal check to ensure that
+ -- pure units call only pure subprograms.
if Is_Imported (E)
and then Is_Pure (E)
elsif Is_Record_Type (T)
and not Is_Private_Type (T)
then
- -- Verify that the record type has no components with
- -- private types without completion.
+ -- Verify that the record type has no components with private types
+ -- without completion.
declare
Comp : Entity_Id;
begin
Set_Default_Expressions_Processed (E);
- -- A subprogram instance and its associated anonymous subprogram
- -- share their signature. The default expression functions are defined
- -- in the wrapper packages for the anonymous subprogram, and should
- -- not be generated again for the instance.
+ -- A subprogram instance and its associated anonymous subprogram share
+ -- their signature. The default expression functions are defined in the
+ -- wrapper packages for the anonymous subprogram, and should not be
+ -- generated again for the instance.
if Is_Generic_Instance (E)
and then Present (Alias (E))
then
-- If there is no default function, we must still do a full
- -- analyze call on the default value, to ensure that all
- -- error checks are performed, e.g. those associated with
- -- static evaluation. Note that this branch will always be
- -- taken if the analyzer is turned off (but we still need the
- -- error checks).
+ -- analyze call on the default value, to ensure that all error
+ -- checks are performed, e.g. those associated with static
+ -- evaluation. Note: this branch will always be taken if the
+ -- analyzer is turned off (but we still need the error checks).
-- Note: the setting of parent here is to meet the requirement
-- that we can only analyze the expression while attached to
-- Full_View or Corresponding_Record_Type to have one either.
-- ??? Fundamentally, this whole handling is a kludge. What we really
- -- want is to be sure that for an Itype that's part of record R and is
- -- a subtype of type T, that it's frozen after the later of the freeze
+ -- want is to be sure that for an Itype that's part of record R and is a
+ -- subtype of type T, that it's frozen after the later of the freeze
-- points of R and T. We have no way of doing that directly, so what we
-- do is force most such Itypes to be frozen as part of freezing R via
-- this procedure and only delay the ones that need to be delayed
- -- (mostly the designated types of access types that are defined as
- -- part of the record).
+ -- (mostly the designated types of access types that are defined as part
+ -- of the record).
if Is_Private_Type (T)
and then Present (Full_View (T))
return;
end if;
- -- A function call (most likely to To_Address) is probably not
- -- an overlay, so skip warning. Ditto if the function call was
- -- inlined and transformed into an entity.
+ -- A function call (most likely to To_Address) is probably not an
+ -- overlay, so skip warning. Ditto if the function call was inlined
+ -- and transformed into an entity.
elsif Nkind (Original_Node (Expr)) = N_Function_Call then
return;
and then Present (Packed_Array_Type (Etype (Comp)))
then
Error_Msg_NE
- ("packed array component& will be initialized to zero?",
- Nam, Comp);
+ ("\packed array component& " &
+ "will be initialized to zero?",
+ Nam, Comp);
exit;
else
Next_Component (Comp);
end if;
Error_Msg_N
- ("use pragma Import for & to " &
- "suppress initialization ('R'M B.1(24))?",
- Nam);
+ ("\use pragma Import for & to " &
+ "suppress initialization ('R'M B.1(24))?",
+ Nam);
end if;
end Warn_Overlay;
OSDN Git Service
