-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
-- For simple renamings, subsequent calls can be expanded directly as
-- calls to the renamed entity. The body must be generated in any case
- -- for calls that may appear elsewhere.
+ -- for calls that may appear elsewhere. This is not done in the case
+ -- where the subprogram is an instantiation because the actual proper
+ -- body has not been built yet.
if Ekind_In (Old_S, E_Function, E_Procedure)
and then Nkind (Decl) = N_Subprogram_Declaration
+ and then not Is_Generic_Instance (Old_S)
then
Set_Body_To_Inline (Decl, Old_S);
end if;
if S > 32 then
return;
- -- Don't bother if alignment clause with a value other than 1 is
- -- present, because size may be padded up to meet back end alignment
- -- requirements, and only the back end knows the rules!
-
- elsif Known_Alignment (T) and then Alignment (T) /= 1 then
- return;
-
-- Check for bad size clause given
elsif Has_Size_Clause (T) then
Error_Msg_NE
("size for& too small, minimum allowed is ^",
Size_Clause (T), T);
-
- elsif Unknown_Esize (T) then
- Set_Esize (T, S);
end if;
- -- Set sizes if not set already
+ -- Set size if not set already
- else
- if Unknown_Esize (T) then
- Set_Esize (T, S);
- end if;
-
- if Unknown_RM_Size (T) then
- Set_RM_Size (T, S);
- end if;
+ elsif Unknown_RM_Size (T) then
+ Set_RM_Size (T, S);
end if;
end Set_Small_Size;
if not Is_Constrained (T)
and then
No (Discriminant_Default_Value (First_Discriminant (T)))
- and then Unknown_Esize (T)
+ and then Unknown_RM_Size (T)
then
return False;
end if;
End_Package_Scope (E);
+ if Is_Generic_Instance (E)
+ and then Has_Delayed_Freeze (E)
+ then
+ Set_Has_Delayed_Freeze (E, False);
+ Expand_N_Package_Declaration (Unit_Declaration_Node (E));
+ end if;
+
elsif Ekind (E) in Task_Kind
and then
(Nkind (Parent (E)) = N_Task_Type_Declaration
Subp : Entity_Id;
begin
- Prim := First_Elmt (Prim_List);
+ Prim := First_Elmt (Prim_List);
while Present (Prim) loop
Subp := Node (Prim);
end loop;
end;
+ -- We add finalization masters to access types whose designated types
+ -- require finalization. This is normally done when freezing the
+ -- type, but this misses recursive type definitions where the later
+ -- members of the recursion introduce controlled components (such as
+ -- can happen when incomplete types are involved), as well cases
+ -- where a component type is private and the controlled full type
+ -- occurs after the access type is frozen. Cases that don't need a
+ -- finalization master are generic formal types (the actual type will
+ -- have it) and types with Java and CIL conventions, since those are
+ -- used for API bindings. (Are there any other cases that should be
+ -- excluded here???)
+
elsif Is_Access_Type (E)
and then Comes_From_Source (E)
- and then Ekind (Directly_Designated_Type (E)) = E_Incomplete_Type
+ and then not Is_Generic_Type (E)
and then Needs_Finalization (Designated_Type (E))
- and then No (Associated_Final_Chain (E))
then
- Build_Final_List (Parent (E), E);
+ Build_Finalization_Master (E);
end if;
Next_Entity (E);
-- Start of processing for Freeze_Record_Type
begin
- -- If this is a subtype of a controlled type, declared without a
- -- constraint, the _controller may not appear in the component list
- -- if the parent was not frozen at the point of subtype declaration.
- -- Inherit the _controller component now.
-
- if Rec /= Base_Type (Rec)
- and then Has_Controlled_Component (Rec)
- then
- if Nkind (Parent (Rec)) = N_Subtype_Declaration
- and then Is_Entity_Name (Subtype_Indication (Parent (Rec)))
- then
- Set_First_Entity (Rec, First_Entity (Base_Type (Rec)));
-
- -- If this is an internal type without a declaration, as for
- -- record component, the base type may not yet be frozen, and its
- -- controller has not been created. Add an explicit freeze node
- -- for the itype, so it will be frozen after the base type. This
- -- freeze node is used to communicate with the expander, in order
- -- to create the controller for the enclosing record, and it is
- -- deleted afterwards (see exp_ch3). It must not be created when
- -- expansion is off, because it might appear in the wrong context
- -- for the back end.
-
- elsif Is_Itype (Rec)
- and then Has_Delayed_Freeze (Base_Type (Rec))
- and then
- Nkind (Associated_Node_For_Itype (Rec)) =
- N_Component_Declaration
- and then Expander_Active
- then
- Ensure_Freeze_Node (Rec);
- end if;
- end if;
-
-- Freeze components and embedded subtypes
Comp := First_Entity (Rec);
-- if it is variable length. We omit this test in a generic
-- context, it will be applied at instantiation time.
+ -- We also omit this test in CodePeer mode, since we do not
+ -- have sufficient info on size and representation clauses.
+
if Present (CC) then
Placed_Component := True;
if Inside_A_Generic then
null;
+ elsif CodePeer_Mode then
+ null;
+
elsif not
Size_Known_At_Compile_Time
(Underlying_Type (Etype (Comp)))
Next_Entity (Comp);
end loop;
- -- Deal with pragma Bit_Order setting non-standard bit order
+ -- Deal with Bit_Order aspect specifying a non-default bit order
if Reverse_Bit_Order (Rec) and then Base_Type (Rec) = Rec then
if not Placed_Component then
-- less than the sum of the object sizes (no point in packing if
-- this is not the case).
- and then Esize (Rec) < Scalar_Component_Total_Esize
+ and then RM_Size (Rec) < Scalar_Component_Total_Esize
-- And the total RM size cannot be greater than the specified size
-- since otherwise packing will not get us where we have to be!
- and then Esize (Rec) >= Scalar_Component_Total_RM_Size
+ and then RM_Size (Rec) >= Scalar_Component_Total_RM_Size
- -- Never do implicit packing in CodePeer mode since we don't do
- -- any packing in this mode, since this generates over-complex
- -- code that confuses CodePeer, and in general, CodePeer does not
- -- care about the internal representation of objects.
+ -- Never do implicit packing in CodePeer or Alfa modes since
+ -- we don't do any packing in these modes, since this generates
+ -- over-complex code that confuses static analysis, and in
+ -- general, neither CodePeer not GNATprove care about the
+ -- internal representation of objects.
- and then not CodePeer_Mode
+ and then not (CodePeer_Mode or Alfa_Mode)
then
-- If implicit packing enabled, do it
elsif Inside_A_Generic and then External_Ref_In_Generic (Test_E) then
return No_List;
+ -- AI05-0213: A formal incomplete type does not freeze the actual. In
+ -- the instance, the same applies to the subtype renaming the actual.
+
+ elsif Is_Private_Type (E)
+ and then Is_Generic_Actual_Type (E)
+ and then No (Full_View (Base_Type (E)))
+ and then Ada_Version >= Ada_2012
+ then
+ return No_List;
+
-- Do not freeze a global entity within an inner scope created during
-- expansion. A call to subprogram E within some internal procedure
-- (a stream attribute for example) might require freezing E, but the
if Nkind (Ritem) = N_Aspect_Specification
and then Entity (Ritem) = E
and then Is_Delayed_Aspect (Ritem)
+ and then Scope (E) = Current_Scope
then
Aitem := Aspect_Rep_Item (Ritem);
Formal := First_Formal (E);
while Present (Formal) loop
F_Type := Etype (Formal);
+
+ -- AI05-0151 : incomplete types can appear in a profile.
+ -- By the time the entity is frozen, the full view must
+ -- be available, unless it is a limited view.
+
+ if Is_Incomplete_Type (F_Type)
+ and then Present (Full_View (F_Type))
+ then
+ F_Type := Full_View (F_Type);
+ Set_Etype (Formal, F_Type);
+ end if;
+
Freeze_And_Append (F_Type, N, Result);
if Is_Private_Type (F_Type)
-- Freeze return type
R_Type := Etype (E);
+
+ -- AI05-0151: the return type may have been incomplete
+ -- at the point of declaration.
+
+ if Ekind (R_Type) = E_Incomplete_Type
+ and then Present (Full_View (R_Type))
+ then
+ R_Type := Full_View (R_Type);
+ Set_Etype (E, R_Type);
+ end if;
+
Freeze_And_Append (R_Type, N, Result);
-- Check suspicious return type for C function
and then not Is_Constrained (R_Type)
-- Exclude imported routines, the warning does not
- -- belong on the import, but on the routine definition.
+ -- belong on the import, but rather on the routine
+ -- definition.
and then not Is_Imported (E)
-- Note: we inhibit this check for objects that do not come
-- from source because there is at least one case (the
- -- expansion of x'class'input where x is abstract) where we
+ -- expansion of x'Class'Input where x is abstract) where we
-- legitimately generate an abstract object.
if Is_Abstract_Type (Etype (E))
((Has_Non_Null_Base_Init_Proc (Etype (E))
and then not No_Initialization (Declaration_Node (E))
and then not Is_Value_Type (Etype (E))
- and then not Suppress_Init_Proc (Etype (E)))
+ and then not Initialization_Suppressed (Etype (E)))
or else
(Needs_Simple_Initialization (Etype (E))
and then not Is_Internal (E)))
-- action that causes stuff to be inherited).
if Present (Size_Clause (E))
- and then Known_Static_Esize (E)
+ and then Known_Static_RM_Size (E)
and then not Is_Packed (E)
and then not Has_Pragma_Pack (E)
and then Number_Dimensions (E) = 1
and then not Has_Component_Size_Clause (E)
- and then Known_Static_Esize (Ctyp)
+ and then Known_Static_RM_Size (Ctyp)
and then not Is_Limited_Composite (E)
and then not Is_Packed (Root_Type (E))
and then not Has_Component_Size_Clause (Root_Type (E))
- and then not CodePeer_Mode
+ and then not (CodePeer_Mode or Alfa_Mode)
then
Get_Index_Bounds (First_Index (E), Lo, Hi);
-- Start of processing for Alias_Atomic_Check
begin
+
+ -- If object size of component type isn't known, we
+ -- cannot be sure so we defer to the back end.
+
+ if not Known_Static_Esize (Ctyp) then
+ null;
+
-- Case where component size has no effect. First
- -- check for object size of component type known
- -- and a multiple of the storage unit size.
+ -- check for object size of component type multiple
+ -- of the storage unit size.
- if Known_Static_Esize (Ctyp)
- and then Esize (Ctyp) mod System_Storage_Unit = 0
+ elsif Esize (Ctyp) mod System_Storage_Unit = 0
-- OK in both packing case and component size case
-- if RM size is known and static and the same as
-- package Pkg is
-- type T is tagged private;
-- type DT is new T with private;
- -- procedure Prim (X : in out T; Y : in out DT'class);
+ -- procedure Prim (X : in out T; Y : in out DT'Class);
-- private
-- type T is tagged null record;
-- Obj : T;
and then Mechanism (E) not in Descriptor_Codes
- -- Check appropriate warning is enabled (should we check for
- -- Warnings (Off) on specific entities here, probably so???)
+ -- Check appropriate warning is enabled (should we check for
+ -- Warnings (Off) on specific entities here, probably so???)
and then Warn_On_Export_Import
- -- Exclude the VM case, since return of unconstrained arrays
- -- is properly handled in both the JVM and .NET cases.
+ -- Exclude the VM case, since return of unconstrained arrays
+ -- is properly handled in both the JVM and .NET cases.
and then VM_Target = No_VM
then
Declarations => New_List (
Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('T')),
- Object_Definition =>
- New_Occurrence_Of (Etype (Formal), Loc),
- Expression => New_Copy_Tree (Dcopy))),
+ Defining_Identifier => Make_Temporary (Loc, 'T'),
+ Object_Definition =>
+ New_Occurrence_Of (Etype (Formal), Loc),
+ Expression => New_Copy_Tree (Dcopy))),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List));
+ Statements => Empty_List));
Set_Scope (Dnam, Scope (E));
Set_Assignment_OK (First (Declarations (Dbody)));
-- tested for because predefined String types are initialized by inline
-- code rather than by an init_proc). Note that we do not give the
-- warning for Initialize_Scalars, since we suppressed initialization
- -- in this case.
+ -- in this case. Also, do not warn if Suppress_Initialization is set.
if Present (Expr)
and then not Is_Imported (Ent)
+ and then not Initialization_Suppressed (Typ)
and then (Has_Non_Null_Base_Init_Proc (Typ)
- or else Is_Access_Type (Typ)
- or else (Normalize_Scalars
- and then (Is_Scalar_Type (Typ)
- or else Is_String_Type (Typ))))
+ or else Is_Access_Type (Typ)
+ or else (Normalize_Scalars
+ and then (Is_Scalar_Type (Typ)
+ or else Is_String_Type (Typ))))
then
if Nkind (Expr) = N_Attribute_Reference
and then Is_Entity_Name (Prefix (Expr))
OSDN Git Service
