Skip to content

R
riscv-gcc-1
Commit 4d1429b2 by Arnaud Charlet
Options

[multiple changes] 

2014-10-10  Robert Dewar  <dewar@adacore.com>

	* freeze.adb, gnat1drv.adb, sem_ch13.adb: Minor reformatting and
	code clean up.

2014-10-10  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_res.adb (Is_OK_Volatile_Context): Allow
	a volatile object reference to appear as the expression of a
	type conversion.

From-SVN: r216091
parent c9f95e4c
Showing with 853 additions and 821 deletions
gcc/ada/ChangeLog
2014-10-10 Robert Dewar <dewar@adacore.com>
* freeze.adb, gnat1drv.adb, sem_ch13.adb: Minor reformatting and
code clean up.
2014-10-10 Hristian Kirtchev <kirtchev@adacore.com>
* sem_res.adb (Is_OK_Volatile_Context): Allow
a volatile object reference to appear as the expression of a
type conversion.
2014-10-10 Ed Schonberg <schonberg@adacore.com>
* sem_ch13.adb (Analyze_Aspect_Specifications, Library_Unit_Aspects):
......
gcc/ada/freeze.adb
......@@ -1857,6 +1857,13 @@ package body Freeze is
-- Create Freeze_Generic_Entity nodes for types declared in a generic
-- package. Recurse on inner generic packages.
function Freeze_Profile (E : Entity_Id) return Boolean;
-- Freeze formals and return type of subprogram.
-- If some type in the profile is a limited view, freezing of the entity
-- will take place elsewhere, and the function returns False.
-- This routine will be modified if and when we can implement AI05-019
-- efficiently.
procedure Freeze_Record_Type (Rec : Entity_Id);
-- Freeze record type, including freezing component types, and freezing
-- primitive operations if this is a tagged type.
......@@ -2681,346 +2688,681 @@ package body Freeze is
return Flist;
end Freeze_Generic_Entities;
------------------------
-- Freeze_Record_Type --
------------------------
--------------------
-- Freeze_Profile --
--------------------
procedure Freeze_Record_Type (Rec : Entity_Id) is
ADC : Node_Id;
Comp : Entity_Id;
IR : Node_Id;
Prev : Entity_Id;
function Freeze_Profile (E : Entity_Id) return Boolean is
F_Type : Entity_Id;
R_Type : Entity_Id;
Warn_Node : Node_Id;
Junk : Boolean;
pragma Warnings (Off, Junk);
begin
-- Loop through formals
Rec_Pushed : Boolean := False;
-- Set True if the record type scope Rec has been pushed on the scope
-- stack. Needed for the analysis of delayed aspects specified to the
-- components of Rec.
Formal := First_Formal (E);
while Present (Formal) loop
F_Type := Etype (Formal);
SSO_ADC : Node_Id;
-- Scalar_Storage_Order attribute definition clause for the record
-- 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.
Unplaced_Component : Boolean := False;
-- Set True if we find at least one component with no component
-- clause (used to warn about useless Pack pragmas).
if Is_Incomplete_Type (F_Type)
and then Present (Full_View (F_Type))
and then not From_Limited_With (F_Type)
then
F_Type := Full_View (F_Type);
Set_Etype (Formal, F_Type);
end if;
Placed_Component : Boolean := False;
-- Set True if we find at least one component with a component
-- clause (used to warn about useless Bit_Order pragmas, and also
-- to detect cases where Implicit_Packing may have an effect).
Freeze_And_Append (F_Type, N, Result);
Aliased_Component : Boolean := False;
-- Set True if we find at least one component which is aliased. This
-- is used to prevent Implicit_Packing of the record, since packing
-- cannot modify the size of alignment of an aliased component.
if Is_Private_Type (F_Type)
and then Is_Private_Type (Base_Type (F_Type))
and then No (Full_View (Base_Type (F_Type)))
and then not Is_Generic_Type (F_Type)
and then not Is_Derived_Type (F_Type)
then
-- If the type of a formal is incomplete, subprogram
-- is being frozen prematurely. Within an instance
-- (but not within a wrapper package) this is an
-- artifact of our need to regard the end of an
-- instantiation as a freeze point. Otherwise it is
-- a definite error.
SSO_ADC_Component : Boolean := False;
-- Set True if we find at least one component whose type has a
-- Scalar_Storage_Order attribute definition clause.
if In_Instance then
Set_Is_Frozen (E, False);
Result := No_List;
return False;
All_Scalar_Components : Boolean := True;
-- Set False if we encounter a component of a non-scalar type
elsif not After_Last_Declaration
and then not Freezing_Library_Level_Tagged_Type
then
Error_Msg_Node_1 := F_Type;
Error_Msg
("type& must be fully defined before this point",
Loc);
end if;
end if;
Scalar_Component_Total_RM_Size : Uint := Uint_0;
Scalar_Component_Total_Esize : Uint := Uint_0;
-- Accumulates total RM_Size values and total Esize values of all
-- scalar components. Used for processing of Implicit_Packing.
-- Check suspicious parameter for C function. These tests
-- apply only to exported/imported subprograms.
function Check_Allocator (N : Node_Id) return Node_Id;
-- If N is an allocator, possibly wrapped in one or more level of
-- qualified expression(s), return the inner allocator node, else
-- return Empty.
if Warn_On_Export_Import
and then Comes_From_Source (E)
and then (Convention (E) = Convention_C
or else
Convention (E) = Convention_CPP)
and then (Is_Imported (E) or else Is_Exported (E))
and then Convention (E) /= Convention (Formal)
and then not Has_Warnings_Off (E)
and then not Has_Warnings_Off (F_Type)
and then not Has_Warnings_Off (Formal)
then
-- Qualify mention of formals with subprogram name
procedure Check_Itype (Typ : Entity_Id);
-- If the component subtype is an access to a constrained subtype of
-- an already frozen type, make the subtype frozen as well. It might
-- otherwise be frozen in the wrong scope, and a freeze node on
-- subtype has no effect. Similarly, if the component subtype is a
-- regular (not protected) access to subprogram, set the anonymous
-- subprogram type to frozen as well, to prevent an out-of-scope
-- freeze node at some eventual point of call. Protected operations
-- are handled elsewhere.
Error_Msg_Qual_Level := 1;
procedure Freeze_Choices_In_Variant_Part (VP : Node_Id);
-- Make sure that all types mentioned in Discrete_Choices of the
-- variants referenceed by the Variant_Part VP are frozen. This is
-- a recursive routine to deal with nested variants.
-- Check suspicious use of fat C pointer
---------------------
-- Check_Allocator --
---------------------
if Is_Access_Type (F_Type)
and then Esize (F_Type) > Ttypes.System_Address_Size
then
Error_Msg_N
("?x?type of & does not correspond to C pointer!", Formal);
function Check_Allocator (N : Node_Id) return Node_Id is
Inner : Node_Id;
begin
Inner := N;
loop
if Nkind (Inner) = N_Allocator then
return Inner;
elsif Nkind (Inner) = N_Qualified_Expression then
Inner := Expression (Inner);
else
return Empty;
end if;
end loop;
end Check_Allocator;
-- Check suspicious return of boolean
-----------------
-- Check_Itype --
-----------------
elsif Root_Type (F_Type) = Standard_Boolean
and then Convention (F_Type) = Convention_Ada
and then not Has_Warnings_Off (F_Type)
and then not Has_Size_Clause (F_Type)
and then VM_Target = No_VM
then
Error_Msg_N ("& is an 8-bit Ada Boolean?x?", Formal);
Error_Msg_N ("\use appropriate corresponding type in C "
& "(e.g. char)?x?", Formal);
procedure Check_Itype (Typ : Entity_Id) is
Desig : constant Entity_Id := Designated_Type (Typ);
-- Check suspicious tagged type
begin
if not Is_Frozen (Desig)
and then Is_Frozen (Base_Type (Desig))
elsif (Is_Tagged_Type (F_Type)
or else (Is_Access_Type (F_Type)
and then
Is_Tagged_Type
(Designated_Type (F_Type))))
and then Convention (E) = Convention_C
then
Set_Is_Frozen (Desig);
Error_Msg_N ("?x?& involves a tagged type which does not "
& "correspond to any C type!", Formal);
-- In addition, add an Itype_Reference to ensure that the
-- access subtype is elaborated early enough. This cannot be
-- done if the subtype may depend on discriminants.
-- Check wrong convention subprogram pointer
if Ekind (Comp) = E_Component
and then Is_Itype (Etype (Comp))
and then not Has_Discriminants (Rec)
elsif Ekind (F_Type) = E_Access_Subprogram_Type
and then not Has_Foreign_Convention (F_Type)
then
IR := Make_Itype_Reference (Sloc (Comp));
Set_Itype (IR, Desig);
Add_To_Result (IR);
Error_Msg_N ("?x?subprogram pointer & should "
& "have foreign convention!", Formal);
Error_Msg_Sloc := Sloc (F_Type);
Error_Msg_NE
("\?x?add Convention pragma to declaration of &#",
Formal, F_Type);
end if;
elsif Ekind (Typ) = E_Anonymous_Access_Subprogram_Type
and then Convention (Desig) /= Convention_Protected
then
Set_Is_Frozen (Desig);
end if;
end Check_Itype;
-- Turn off name qualification after message output
------------------------------------
-- Freeze_Choices_In_Variant_Part --
------------------------------------
Error_Msg_Qual_Level := 0;
end if;
procedure Freeze_Choices_In_Variant_Part (VP : Node_Id) is
pragma Assert (Nkind (VP) = N_Variant_Part);
-- Check for unconstrained array in exported foreign
-- convention case.
Variant : Node_Id;
Choice : Node_Id;
CL : Node_Id;
if Has_Foreign_Convention (E)
and then not Is_Imported (E)
and then Is_Array_Type (F_Type)
and then not Is_Constrained (F_Type)
and then Warn_On_Export_Import
begin
-- Loop through variants
-- Exclude VM case, since both .NET and JVM can handle
-- unconstrained arrays without a problem.
Variant := First_Non_Pragma (Variants (VP));
while Present (Variant) loop
and then VM_Target = No_VM
then
Error_Msg_Qual_Level := 1;
-- Loop through choices, checking that all types are frozen
-- If this is an inherited operation, place the
-- warning on the derived type declaration, rather
-- than on the original subprogram.
Choice := First_Non_Pragma (Discrete_Choices (Variant));
while Present (Choice) loop
if Nkind (Choice) in N_Has_Etype
and then Present (Etype (Choice))
if Nkind (Original_Node (Parent (E))) = N_Full_Type_Declaration
then
Freeze_And_Append (Etype (Choice), N, Result);
Warn_Node := Parent (E);
if Formal = First_Formal (E) then
Error_Msg_NE
("??in inherited operation&", Warn_Node, E);
end if;
else
Warn_Node := Formal;
end if;
Next_Non_Pragma (Choice);
end loop;
Error_Msg_NE ("?x?type of argument& is unconstrained array",
Warn_Node, Formal);
Error_Msg_NE ("?x?foreign caller must pass bounds explicitly",
Warn_Node, Formal);
Error_Msg_Qual_Level := 0;
end if;
-- Check for nested variant part to process
if not From_Limited_With (F_Type) then
if Is_Access_Type (F_Type) then
F_Type := Designated_Type (F_Type);
end if;
CL := Component_List (Variant);
-- If the formal is an anonymous_access_to_subprogram
-- freeze the subprogram type as well, to prevent
-- scope anomalies in gigi, because there is no other
-- clear point at which it could be frozen.
if not Null_Present (CL) then
if Present (Variant_Part (CL)) then
Freeze_Choices_In_Variant_Part (Variant_Part (CL));
if Is_Itype (Etype (Formal))
and then Ekind (F_Type) = E_Subprogram_Type
then
Freeze_And_Append (F_Type, N, Result);
end if;
end if;
Next_Non_Pragma (Variant);
Next_Formal (Formal);
end loop;
end Freeze_Choices_In_Variant_Part;
-- Start of processing for Freeze_Record_Type
-- Case of function: similar checks on return type
begin
-- Deal with delayed aspect specifications for components. The
-- analysis of the aspect is required to be delayed to the freeze
-- point, thus we analyze the pragma or attribute definition
-- clause in the tree at this point. We also analyze the aspect
-- specification node at the freeze point when the aspect doesn't
-- correspond to pragma/attribute definition clause.
if Ekind (E) = E_Function then
Comp := First_Entity (Rec);
while Present (Comp) loop
if Ekind (Comp) = E_Component
and then Has_Delayed_Aspects (Comp)
then
if not Rec_Pushed then
Push_Scope (Rec);
Rec_Pushed := True;
-- Check whether function is declared elsewhere.
-- The visibility to the discriminants must be restored in
-- order to properly analyze the aspects.
Late_Freezing :=
Get_Source_Unit (E) /= Get_Source_Unit (N)
and then Returns_Limited_View (E)
and then not In_Open_Scopes (Scope (E));
if Has_Discriminants (Rec) then
Install_Discriminants (Rec);
end if;
end if;
-- Freeze return type
Analyze_Aspects_At_Freeze_Point (Comp);
end if;
R_Type := Etype (E);
Next_Entity (Comp);
end loop;
-- AI05-0151: the return type may have been incomplete
-- at the point of declaration. Replace it with the full
-- view, unless the current type is a limited view. In
-- that case the full view is in a different unit, and
-- gigi finds the non-limited view after the other unit
-- is elaborated.
-- Pop the scope if Rec scope has been pushed on the scope stack
-- during the delayed aspect analysis process.
if Ekind (R_Type) = E_Incomplete_Type
and then Present (Full_View (R_Type))
and then not From_Limited_With (R_Type)
then
R_Type := Full_View (R_Type);
Set_Etype (E, R_Type);
if Rec_Pushed then
if Has_Discriminants (Rec) then
Uninstall_Discriminants (Rec);
end if;
-- If the return type is a limited view and the non-
-- limited view is still incomplete, the function has
-- to be frozen at a later time.
Pop_Scope;
elsif Ekind (R_Type) = E_Incomplete_Type
and then From_Limited_With (R_Type)
and then
Ekind (Non_Limited_View (R_Type)) = E_Incomplete_Type
then
Set_Is_Frozen (E, False);
Set_Returns_Limited_View (E);
return False;
end if;
-- Freeze components and embedded subtypes
Freeze_And_Append (R_Type, N, Result);
Comp := First_Entity (Rec);
Prev := Empty;
while Present (Comp) loop
if Is_Aliased (Comp) then
Aliased_Component := True;
end if;
-- Check suspicious return type for C function
-- Handle the component and discriminant case
if Warn_On_Export_Import
and then (Convention (E) = Convention_C
or else
Convention (E) = Convention_CPP)
and then (Is_Imported (E) or else Is_Exported (E))
then
-- Check suspicious return of fat C pointer
if Ekind_In (Comp, E_Component, E_Discriminant) then
declare
CC : constant Node_Id := Component_Clause (Comp);
if Is_Access_Type (R_Type)
and then Esize (R_Type) > Ttypes.System_Address_Size
and then not Has_Warnings_Off (E)
and then not Has_Warnings_Off (R_Type)
then
Error_Msg_N ("?x?return type of& does not "
& "correspond to C pointer!", E);
begin
-- Freezing a record type freezes the type of each of its
-- components. However, if the type of the component is
-- part of this record, we do not want or need a separate
-- Freeze_Node. Note that Is_Itype is wrong because that's
-- also set in private type cases. We also can't check for
-- the Scope being exactly Rec because of private types and
-- record extensions.
-- Check suspicious return of boolean
if Is_Itype (Etype (Comp))
and then Is_Record_Type (Underlying_Type
(Scope (Etype (Comp))))
elsif Root_Type (R_Type) = Standard_Boolean
and then Convention (R_Type) = Convention_Ada
and then VM_Target = No_VM
and then not Has_Warnings_Off (E)
and then not Has_Warnings_Off (R_Type)
and then not Has_Size_Clause (R_Type)
then
Undelay_Type (Etype (Comp));
end if;
Freeze_And_Append (Etype (Comp), N, Result);
declare
N : constant Node_Id :=
Result_Definition (Declaration_Node (E));
begin
Error_Msg_NE
("return type of & is an 8-bit Ada Boolean?x?", N, E);
Error_Msg_NE
("\use appropriate corresponding type in C "
& "(e.g. char)?x?", N, E);
end;
-- Warn for pragma Pack overriding foreign convention
-- Check suspicious return tagged type
if Has_Foreign_Convention (Etype (Comp))
and then Has_Pragma_Pack (Rec)
elsif (Is_Tagged_Type (R_Type)
or else (Is_Access_Type (R_Type)
and then
Is_Tagged_Type
(Designated_Type (R_Type))))
and then Convention (E) = Convention_C
and then not Has_Warnings_Off (E)
and then not Has_Warnings_Off (R_Type)
then
Error_Msg_N ("?x?return type of & does not "
& "correspond to C type!", E);
-- Don't warn for aliased components, since override
-- cannot happen in that case.
-- Check return of wrong convention subprogram pointer
and then not Is_Aliased (Comp)
elsif Ekind (R_Type) = E_Access_Subprogram_Type
and then not Has_Foreign_Convention (R_Type)
and then not Has_Warnings_Off (E)
and then not Has_Warnings_Off (R_Type)
then
declare
CN : constant Name_Id :=
Get_Convention_Name (Convention (Etype (Comp)));
PP : constant Node_Id :=
Get_Pragma (Rec, Pragma_Pack);
begin
if Present (PP) then
Error_Msg_Name_1 := CN;
Error_Msg_Sloc := Sloc (Comp);
Error_Msg_N
("pragma Pack affects convention % component#??",
PP);
Error_Msg_Name_1 := CN;
Error_Msg_N ("?x?& should return a foreign "
& "convention subprogram pointer", E);
Error_Msg_Sloc := Sloc (R_Type);
Error_Msg_NE
("\component & may not have % compatible "
& "representation??", PP, Comp);
("\?x?add Convention pragma to declaration of& #",
E, R_Type);
end if;
end;
end if;
-- Check for error of component clause given for variable
-- sized type. We have to delay this test till this point,
-- since the component type has to be frozen for us to know
-- if it is variable length.
-- Give warning for suspicious return of a result of an
-- unconstrained array type in a foreign convention
-- function.
if Present (CC) then
Placed_Component := True;
if Has_Foreign_Convention (E)
-- We omit this test in a generic context, it will be
-- applied at instantiation time.
-- We are looking for a return of unconstrained array
if Inside_A_Generic then
null;
and then Is_Array_Type (R_Type)
and then not Is_Constrained (R_Type)
-- Also omit this test in CodePeer mode, since we do not
-- have sufficient info on size and rep clauses.
-- Exclude imported routines, the warning does not
-- belong on the import, but rather on the routine
-- definition.
elsif CodePeer_Mode then
null;
and then not Is_Imported (E)
-- Do the check
-- Exclude VM case, since both .NET and JVM can handle
-- return of unconstrained arrays without a problem.
elsif not
Size_Known_At_Compile_Time
(Underlying_Type (Etype (Comp)))
and then VM_Target = No_VM
-- Check that general warning is enabled, and that it
-- is not suppressed for this particular case.
and then Warn_On_Export_Import
and then not Has_Warnings_Off (E)
and then not Has_Warnings_Off (R_Type)
then
Error_Msg_N
("component clause not allowed for variable " &
"length component", CC);
Error_Msg_N ("?x?foreign convention function& should not " &
"return unconstrained array!", E);
end if;
else
Unplaced_Component := True;
end if;
-- Case of component requires byte alignment
return True;
end Freeze_Profile;
if Must_Be_On_Byte_Boundary (Etype (Comp)) then
------------------------
-- Freeze_Record_Type --
------------------------
-- Set the enclosing record to also require byte align
procedure Freeze_Record_Type (Rec : Entity_Id) is
ADC : Node_Id;
Comp : Entity_Id;
IR : Node_Id;
Prev : Entity_Id;
Set_Must_Be_On_Byte_Boundary (Rec);
Junk : Boolean;
pragma Warnings (Off, Junk);
-- Check for component clause that is inconsistent with
-- the required byte boundary alignment.
Rec_Pushed : Boolean := False;
-- Set True if the record type scope Rec has been pushed on the scope
-- stack. Needed for the analysis of delayed aspects specified to the
-- components of Rec.
if Present (CC)
and then Normalized_First_Bit (Comp) mod
System_Storage_Unit /= 0
then
Error_Msg_N
("component & must be byte aligned",
Component_Name (Component_Clause (Comp)));
end if;
end if;
end;
end if;
SSO_ADC : Node_Id;
-- Scalar_Storage_Order attribute definition clause for the record
-- Gather data for possible Implicit_Packing later. Note that at
-- this stage we might be dealing with a real component, or with
-- an implicit subtype declaration.
Unplaced_Component : Boolean := False;
-- Set True if we find at least one component with no component
-- clause (used to warn about useless Pack pragmas).
if not Is_Scalar_Type (Etype (Comp)) then
All_Scalar_Components := False;
else
Scalar_Component_Total_RM_Size :=
Scalar_Component_Total_RM_Size + RM_Size (Etype (Comp));
Scalar_Component_Total_Esize :=
Scalar_Component_Total_Esize + Esize (Etype (Comp));
end if;
Placed_Component : Boolean := False;
-- Set True if we find at least one component with a component
-- clause (used to warn about useless Bit_Order pragmas, and also
-- to detect cases where Implicit_Packing may have an effect).
Aliased_Component : Boolean := False;
-- Set True if we find at least one component which is aliased. This
-- is used to prevent Implicit_Packing of the record, since packing
-- cannot modify the size of alignment of an aliased component.
SSO_ADC_Component : Boolean := False;
-- Set True if we find at least one component whose type has a
-- Scalar_Storage_Order attribute definition clause.
All_Scalar_Components : Boolean := True;
-- Set False if we encounter a component of a non-scalar type
Scalar_Component_Total_RM_Size : Uint := Uint_0;
Scalar_Component_Total_Esize : Uint := Uint_0;
-- Accumulates total RM_Size values and total Esize values of all
-- scalar components. Used for processing of Implicit_Packing.
function Check_Allocator (N : Node_Id) return Node_Id;
-- If N is an allocator, possibly wrapped in one or more level of
-- qualified expression(s), return the inner allocator node, else
-- return Empty.
procedure Check_Itype (Typ : Entity_Id);
-- If the component subtype is an access to a constrained subtype of
-- an already frozen type, make the subtype frozen as well. It might
-- otherwise be frozen in the wrong scope, and a freeze node on
-- subtype has no effect. Similarly, if the component subtype is a
-- regular (not protected) access to subprogram, set the anonymous
-- subprogram type to frozen as well, to prevent an out-of-scope
-- freeze node at some eventual point of call. Protected operations
-- are handled elsewhere.
procedure Freeze_Choices_In_Variant_Part (VP : Node_Id);
-- Make sure that all types mentioned in Discrete_Choices of the
-- variants referenceed by the Variant_Part VP are frozen. This is
-- a recursive routine to deal with nested variants.
---------------------
-- Check_Allocator --
---------------------
function Check_Allocator (N : Node_Id) return Node_Id is
Inner : Node_Id;
begin
Inner := N;
loop
if Nkind (Inner) = N_Allocator then
return Inner;
elsif Nkind (Inner) = N_Qualified_Expression then
Inner := Expression (Inner);
else
return Empty;
end if;
end loop;
end Check_Allocator;
-----------------
-- Check_Itype --
-----------------
procedure Check_Itype (Typ : Entity_Id) is
Desig : constant Entity_Id := Designated_Type (Typ);
begin
if not Is_Frozen (Desig)
and then Is_Frozen (Base_Type (Desig))
then
Set_Is_Frozen (Desig);
-- In addition, add an Itype_Reference to ensure that the
-- access subtype is elaborated early enough. This cannot be
-- done if the subtype may depend on discriminants.
if Ekind (Comp) = E_Component
and then Is_Itype (Etype (Comp))
and then not Has_Discriminants (Rec)
then
IR := Make_Itype_Reference (Sloc (Comp));
Set_Itype (IR, Desig);
Add_To_Result (IR);
end if;
elsif Ekind (Typ) = E_Anonymous_Access_Subprogram_Type
and then Convention (Desig) /= Convention_Protected
then
Set_Is_Frozen (Desig);
end if;
end Check_Itype;
------------------------------------
-- Freeze_Choices_In_Variant_Part --
------------------------------------
procedure Freeze_Choices_In_Variant_Part (VP : Node_Id) is
pragma Assert (Nkind (VP) = N_Variant_Part);
Variant : Node_Id;
Choice : Node_Id;
CL : Node_Id;
begin
-- Loop through variants
Variant := First_Non_Pragma (Variants (VP));
while Present (Variant) loop
-- Loop through choices, checking that all types are frozen
Choice := First_Non_Pragma (Discrete_Choices (Variant));
while Present (Choice) loop
if Nkind (Choice) in N_Has_Etype
and then Present (Etype (Choice))
then
Freeze_And_Append (Etype (Choice), N, Result);
end if;
Next_Non_Pragma (Choice);
end loop;
-- Check for nested variant part to process
CL := Component_List (Variant);
if not Null_Present (CL) then
if Present (Variant_Part (CL)) then
Freeze_Choices_In_Variant_Part (Variant_Part (CL));
end if;
end if;
Next_Non_Pragma (Variant);
end loop;
end Freeze_Choices_In_Variant_Part;
-- Start of processing for Freeze_Record_Type
begin
-- Deal with delayed aspect specifications for components. The
-- analysis of the aspect is required to be delayed to the freeze
-- point, thus we analyze the pragma or attribute definition
-- clause in the tree at this point. We also analyze the aspect
-- specification node at the freeze point when the aspect doesn't
-- correspond to pragma/attribute definition clause.
Comp := First_Entity (Rec);
while Present (Comp) loop
if Ekind (Comp) = E_Component
and then Has_Delayed_Aspects (Comp)
then
if not Rec_Pushed then
Push_Scope (Rec);
Rec_Pushed := True;
-- The visibility to the discriminants must be restored in
-- order to properly analyze the aspects.
if Has_Discriminants (Rec) then
Install_Discriminants (Rec);
end if;
end if;
Analyze_Aspects_At_Freeze_Point (Comp);
end if;
Next_Entity (Comp);
end loop;
-- Pop the scope if Rec scope has been pushed on the scope stack
-- during the delayed aspect analysis process.
if Rec_Pushed then
if Has_Discriminants (Rec) then
Uninstall_Discriminants (Rec);
end if;
Pop_Scope;
end if;
-- Freeze components and embedded subtypes
Comp := First_Entity (Rec);
Prev := Empty;
while Present (Comp) loop
if Is_Aliased (Comp) then
Aliased_Component := True;
end if;
-- Handle the component and discriminant case
if Ekind_In (Comp, E_Component, E_Discriminant) then
declare
CC : constant Node_Id := Component_Clause (Comp);
begin
-- Freezing a record type freezes the type of each of its
-- components. However, if the type of the component is
-- part of this record, we do not want or need a separate
-- Freeze_Node. Note that Is_Itype is wrong because that's
-- also set in private type cases. We also can't check for
-- the Scope being exactly Rec because of private types and
-- record extensions.
if Is_Itype (Etype (Comp))
and then Is_Record_Type (Underlying_Type
(Scope (Etype (Comp))))
then
Undelay_Type (Etype (Comp));
end if;
Freeze_And_Append (Etype (Comp), N, Result);
-- Warn for pragma Pack overriding foreign convention
if Has_Foreign_Convention (Etype (Comp))
and then Has_Pragma_Pack (Rec)
-- Don't warn for aliased components, since override
-- cannot happen in that case.
and then not Is_Aliased (Comp)
then
declare
CN : constant Name_Id :=
Get_Convention_Name (Convention (Etype (Comp)));
PP : constant Node_Id :=
Get_Pragma (Rec, Pragma_Pack);
begin
if Present (PP) then
Error_Msg_Name_1 := CN;
Error_Msg_Sloc := Sloc (Comp);
Error_Msg_N
("pragma Pack affects convention % component#??",
PP);
Error_Msg_Name_1 := CN;
Error_Msg_NE
("\component & may not have % compatible "
& "representation??", PP, Comp);
end if;
end;
end if;
-- Check for error of component clause given for variable
-- sized type. We have to delay this test till this point,
-- since the component type has to be frozen for us to know
-- if it is variable length.
if Present (CC) then
Placed_Component := True;
-- We omit this test in a generic context, it will be
-- applied at instantiation time.
if Inside_A_Generic then
null;
-- Also omit this test in CodePeer mode, since we do not
-- have sufficient info on size and rep clauses.
elsif CodePeer_Mode then
null;
-- Do the check
elsif not
Size_Known_At_Compile_Time
(Underlying_Type (Etype (Comp)))
then
Error_Msg_N
("component clause not allowed for variable " &
"length component", CC);
end if;
else
Unplaced_Component := True;
end if;
-- Case of component requires byte alignment
if Must_Be_On_Byte_Boundary (Etype (Comp)) then
-- Set the enclosing record to also require byte align
Set_Must_Be_On_Byte_Boundary (Rec);
-- Check for component clause that is inconsistent with
-- the required byte boundary alignment.
if Present (CC)
and then Normalized_First_Bit (Comp) mod
System_Storage_Unit /= 0
then
Error_Msg_N
("component & must be byte aligned",
Component_Name (Component_Clause (Comp)));
end if;
end if;
end;
end if;
-- Gather data for possible Implicit_Packing later. Note that at
-- this stage we might be dealing with a real component, or with
-- an implicit subtype declaration.
if not Is_Scalar_Type (Etype (Comp)) then
All_Scalar_Components := False;
else
Scalar_Component_Total_RM_Size :=
Scalar_Component_Total_RM_Size + RM_Size (Etype (Comp));
Scalar_Component_Total_Esize :=
Scalar_Component_Total_Esize + Esize (Etype (Comp));
end if;
-- If the component is an Itype with Delayed_Freeze and is either
-- a record or array subtype and its base type has not yet been
......@@ -3713,648 +4055,308 @@ package body Freeze is
begin
-- Nothing to do if not imported
if not Is_Imported (E) then
return;
-- Test enabling conditions for wrapping
elsif Is_Subprogram (E)
and then Present (Contract (E))
and then Present (Pre_Post_Conditions (Contract (E)))
and then not GNATprove_Mode
then
-- Here we do the wrap
-- Note on calls to Copy_Separate_Tree. The trees we are copying
-- here are fully analyzed, but we definitely want fully syntactic
-- unanalyzed trees in the body we construct, so that the analysis
-- generates the right visibility, and that is exactly what the
-- calls to Copy_Separate_Tree give us.
-- Acquire copy of Inline pragma
Iprag := Copy_Separate_Tree (Import_Pragma (E));
-- Fix up spec to be not imported any more
Set_Is_Imported (E, False);
Set_Interface_Name (E, Empty);
Set_Has_Completion (E, False);
Set_Import_Pragma (E, Empty);
-- Grab the subprogram declaration and specification
Spec := Declaration_Node (E);
-- Build parameter list that we need
Parms := New_List;
Forml := First_Formal (E);
while Present (Forml) loop
Append_To (Parms, Make_Identifier (Loc, Chars (Forml)));
Next_Formal (Forml);
end loop;
-- Build the call
if Ekind_In (E, E_Function, E_Generic_Function) then
Stmt :=
Make_Simple_Return_Statement (Loc,
Expression =>
Make_Function_Call (Loc,
Name => Make_Identifier (Loc, CE),
Parameter_Associations => Parms));
else
Stmt :=
Make_Procedure_Call_Statement (Loc,
Name => Make_Identifier (Loc, CE),
Parameter_Associations => Parms);
end if;
-- Now build the body
Bod :=
Make_Subprogram_Body (Loc,
Specification =>
Copy_Separate_Tree (Spec),
Declarations => New_List (
Make_Subprogram_Declaration (Loc,
Specification =>
Copy_Separate_Tree (Spec)),
Iprag),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Stmt),
End_Label => Make_Identifier (Loc, CE)));
-- Append the body to freeze result
Add_To_Result (Bod);
return;
-- Case of imported subprogram that does not get wrapped
else
-- Set Is_Public. All imported entities need an external symbol
-- created for them since they are always referenced from another
-- object file. Note this used to be set when we set Is_Imported
-- back in Sem_Prag, but now we delay it to this point, since we
-- don't want to set this flag if we wrap an imported subprogram.
Set_Is_Public (E);
end if;
end Wrap_Imported_Subprogram;
-- Start of processing for Freeze_Entity
begin
-- We are going to test for various reasons why this entity need not be
-- frozen here, but in the case of an Itype that's defined within a
-- record, that test actually applies to the record.
if Is_Itype (E) and then Is_Record_Type (Scope (E)) then
Test_E := Scope (E);
elsif Is_Itype (E) and then Present (Underlying_Type (Scope (E)))
and then Is_Record_Type (Underlying_Type (Scope (E)))
then
Test_E := Underlying_Type (Scope (E));
end if;
-- Do not freeze if already frozen since we only need one freeze node
if Is_Frozen (E) then
return No_List;
-- It is improper to freeze an external entity within a generic because
-- its freeze node will appear in a non-valid context. The entity will
-- be frozen in the proper scope after the current generic is analyzed.
-- However, aspects must be analyzed because they may be queried later
-- within the generic itself, and the corresponding pragma or attribute
-- definition has not been analyzed yet.
elsif Inside_A_Generic and then External_Ref_In_Generic (Test_E) then
if Has_Delayed_Aspects (E) then
Analyze_Aspects_At_Freeze_Point (E);
end if;
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;
-- Formal subprograms are never frozen
elsif Is_Formal_Subprogram (E) then
return No_List;
-- Generic types are never frozen as they lack delayed semantic checks
elsif Is_Generic_Type (E) 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
-- freeze node must appear in the same declarative part as E itself.
-- The two-pass elaboration mechanism in gigi guarantees that E will
-- be frozen before the inner call is elaborated. We exclude constants
-- from this test, because deferred constants may be frozen early, and
-- must be diagnosed (e.g. in the case of a deferred constant being used
-- in a default expression). 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 freeze 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
and then Ekind (Test_E) /= E_Constant
then
declare
S : Entity_Id;
begin
S := Current_Scope;
while Present (S) loop
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
return No_List;
end if;
end if;
S := Scope (S);
end loop;
end;
-- Similarly, an inlined instance body may make reference to global
-- entities, but these references cannot be the proper freezing point
-- for them, and in the absence of inlining freezing will take place in
-- their own scope. Normally instance bodies are analyzed after the
-- enclosing compilation, and everything has been frozen at the proper
-- place, but with front-end inlining an instance body is compiled
-- before the end of the enclosing scope, and as a result out-of-order
-- freezing must be prevented.
elsif Front_End_Inlining
and then In_Instance_Body
and then Present (Scope (Test_E))
then
declare
S : Entity_Id;
begin
S := Scope (Test_E);
while Present (S) loop
if Is_Generic_Instance (S) then
exit;
else
S := Scope (S);
end if;
end loop;
if No (S) then
return No_List;
end if;
end;
elsif Ekind (E) = E_Generic_Package then
return Freeze_Generic_Entities (E);
end if;
-- Add checks to detect proper initialization of scalars that may appear
-- as subprogram parameters.
if Is_Subprogram (E) and then Check_Validity_Of_Parameters then
Apply_Parameter_Validity_Checks (E);
end if;
-- Deal with delayed aspect specifications. The analysis of the aspect
-- is required to be delayed to the freeze point, thus we analyze the
-- pragma or attribute definition clause in the tree at this point. We
-- also analyze the aspect specification node at the freeze point when
-- the aspect doesn't correspond to pragma/attribute definition clause.
if Has_Delayed_Aspects (E) then
Analyze_Aspects_At_Freeze_Point (E);
end if;
-- Here to freeze the entity
Set_Is_Frozen (E);
-- Case of entity being frozen is other than a type
if not Is_Type (E) then
-- If entity is exported or imported and does not have an external
-- name, now is the time to provide the appropriate default name.
-- Skip this if the entity is stubbed, since we don't need a name
-- for any stubbed routine. For the case on intrinsics, if no
-- external name is specified, then calls will be handled in
-- Exp_Intr.Expand_Intrinsic_Call, and no name is needed. If an
-- external name is provided, then Expand_Intrinsic_Call leaves
-- calls in place for expansion by GIGI.
if (Is_Imported (E) or else Is_Exported (E))
and then No (Interface_Name (E))
and then Convention (E) /= Convention_Stubbed
and then Convention (E) /= Convention_Intrinsic
then
Set_Encoded_Interface_Name
(E, Get_Default_External_Name (E));
if not Is_Imported (E) then
return;
-- If entity is an atomic object appearing in a declaration and
-- the expression is an aggregate, assign it to a temporary to
-- ensure that the actual assignment is done atomically rather
-- than component-wise (the assignment to the temp may be done
-- component-wise, but that is harmless).
-- Test enabling conditions for wrapping
elsif Is_Atomic (E)
and then Nkind (Parent (E)) = N_Object_Declaration
and then Present (Expression (Parent (E)))
and then Nkind (Expression (Parent (E))) = N_Aggregate
and then Is_Atomic_Aggregate (Expression (Parent (E)), Etype (E))
elsif Is_Subprogram (E)
and then Present (Contract (E))
and then Present (Pre_Post_Conditions (Contract (E)))
and then not GNATprove_Mode
then
null;
end if;
-- Here we do the wrap
-- Subprogram case
-- Note on calls to Copy_Separate_Tree. The trees we are copying
-- here are fully analyzed, but we definitely want fully syntactic
-- unanalyzed trees in the body we construct, so that the analysis
-- generates the right visibility, and that is exactly what the
-- calls to Copy_Separate_Tree give us.
if Is_Subprogram (E) then
-- Acquire copy of Inline pragma
-- Check for needing to wrap imported subprogram
Iprag := Copy_Separate_Tree (Import_Pragma (E));
Wrap_Imported_Subprogram (E);
-- Fix up spec to be not imported any more
-- Freeze all parameter types and the return type (RM 13.14(14)).
-- However skip this for internal subprograms. This is also where
-- any extra formal parameters are created since we now know
-- whether the subprogram will use a foreign convention.
Set_Is_Imported (E, False);
Set_Interface_Name (E, Empty);
Set_Has_Completion (E, False);
Set_Import_Pragma (E, Empty);
-- In Ada 2012, freezing a subprogram does not always freeze
-- the corresponding profile (see AI05-019). An attribute
-- reference is not a freezing point of the profile.
-- Other constructs that should not freeze ???
-- Grab the subprogram declaration and specification
if Ada_Version > Ada_2005
and then Nkind (N) = N_Attribute_Reference
then
null;
Spec := Declaration_Node (E);
elsif not Is_Internal (E) then
declare
F_Type : Entity_Id;
R_Type : Entity_Id;
Warn_Node : Node_Id;
-- Build parameter list that we need
begin
-- Loop through formals
Parms := New_List;
Forml := First_Formal (E);
while Present (Forml) loop
Append_To (Parms, Make_Identifier (Loc, Chars (Forml)));
Next_Formal (Forml);
end loop;
Formal := First_Formal (E);
while Present (Formal) loop
F_Type := Etype (Formal);
-- Build the call
-- 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 Ekind_In (E, E_Function, E_Generic_Function) then
Stmt :=
Make_Simple_Return_Statement (Loc,
Expression =>
Make_Function_Call (Loc,
Name => Make_Identifier (Loc, CE),
Parameter_Associations => Parms));
if Is_Incomplete_Type (F_Type)
and then Present (Full_View (F_Type))
and then not From_Limited_With (F_Type)
then
F_Type := Full_View (F_Type);
Set_Etype (Formal, F_Type);
else
Stmt :=
Make_Procedure_Call_Statement (Loc,
Name => Make_Identifier (Loc, CE),
Parameter_Associations => Parms);
end if;
Freeze_And_Append (F_Type, N, Result);
-- Now build the body
if Is_Private_Type (F_Type)
and then Is_Private_Type (Base_Type (F_Type))
and then No (Full_View (Base_Type (F_Type)))
and then not Is_Generic_Type (F_Type)
and then not Is_Derived_Type (F_Type)
then
-- If the type of a formal is incomplete, subprogram
-- is being frozen prematurely. Within an instance
-- (but not within a wrapper package) this is an
-- artifact of our need to regard the end of an
-- instantiation as a freeze point. Otherwise it is
-- a definite error.
Bod :=
Make_Subprogram_Body (Loc,
Specification =>
Copy_Separate_Tree (Spec),
Declarations => New_List (
Make_Subprogram_Declaration (Loc,
Specification =>
Copy_Separate_Tree (Spec)),
Iprag),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Stmt),
End_Label => Make_Identifier (Loc, CE)));
if In_Instance then
Set_Is_Frozen (E, False);
return No_List;
-- Append the body to freeze result
elsif not After_Last_Declaration
and then not Freezing_Library_Level_Tagged_Type
then
Error_Msg_Node_1 := F_Type;
Error_Msg
("type& must be fully defined before this point",
Loc);
end if;
end if;
Add_To_Result (Bod);
return;
-- Check suspicious parameter for C function. These tests
-- apply only to exported/imported subprograms.
-- Case of imported subprogram that does not get wrapped
if Warn_On_Export_Import
and then Comes_From_Source (E)
and then (Convention (E) = Convention_C
or else
Convention (E) = Convention_CPP)
and then (Is_Imported (E) or else Is_Exported (E))
and then Convention (E) /= Convention (Formal)
and then not Has_Warnings_Off (E)
and then not Has_Warnings_Off (F_Type)
and then not Has_Warnings_Off (Formal)
then
-- Qualify mention of formals with subprogram name
else
-- Set Is_Public. All imported entities need an external symbol
-- created for them since they are always referenced from another
-- object file. Note this used to be set when we set Is_Imported
-- back in Sem_Prag, but now we delay it to this point, since we
-- don't want to set this flag if we wrap an imported subprogram.
Error_Msg_Qual_Level := 1;
Set_Is_Public (E);
end if;
end Wrap_Imported_Subprogram;
-- Check suspicious use of fat C pointer
-- Start of processing for Freeze_Entity
if Is_Access_Type (F_Type)
and then Esize (F_Type) > Ttypes.System_Address_Size
begin
-- We are going to test for various reasons why this entity need not be
-- frozen here, but in the case of an Itype that's defined within a
-- record, that test actually applies to the record.
if Is_Itype (E) and then Is_Record_Type (Scope (E)) then
Test_E := Scope (E);
elsif Is_Itype (E) and then Present (Underlying_Type (Scope (E)))
and then Is_Record_Type (Underlying_Type (Scope (E)))
then
Error_Msg_N
("?x?type of & does not correspond to C pointer!",
Formal);
Test_E := Underlying_Type (Scope (E));
end if;
-- Check suspicious return of boolean
-- Do not freeze if already frozen since we only need one freeze node
elsif Root_Type (F_Type) = Standard_Boolean
and then Convention (F_Type) = Convention_Ada
and then not Has_Warnings_Off (F_Type)
and then not Has_Size_Clause (F_Type)
and then VM_Target = No_VM
then
Error_Msg_N
("& is an 8-bit Ada Boolean?x?", Formal);
Error_Msg_N
("\use appropriate corresponding type in C "
& "(e.g. char)?x?", Formal);
if Is_Frozen (E) then
return No_List;
-- Check suspicious tagged type
-- It is improper to freeze an external entity within a generic because
-- its freeze node will appear in a non-valid context. The entity will
-- be frozen in the proper scope after the current generic is analyzed.
-- However, aspects must be analyzed because they may be queried later
-- within the generic itself, and the corresponding pragma or attribute
-- definition has not been analyzed yet.
elsif (Is_Tagged_Type (F_Type)
or else (Is_Access_Type (F_Type)
and then
Is_Tagged_Type
(Designated_Type (F_Type))))
and then Convention (E) = Convention_C
then
Error_Msg_N
("?x?& involves a tagged type which does not "
& "correspond to any C type!", Formal);
elsif Inside_A_Generic and then External_Ref_In_Generic (Test_E) then
if Has_Delayed_Aspects (E) then
Analyze_Aspects_At_Freeze_Point (E);
end if;
-- Check wrong convention subprogram pointer
return No_List;
elsif Ekind (F_Type) = E_Access_Subprogram_Type
and then not Has_Foreign_Convention (F_Type)
-- 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
Error_Msg_N
("?x?subprogram pointer & should "
& "have foreign convention!", Formal);
Error_Msg_Sloc := Sloc (F_Type);
Error_Msg_NE
("\?x?add Convention pragma to declaration of &#",
Formal, F_Type);
end if;
return No_List;
-- Turn off name qualification after message output
-- Formal subprograms are never frozen
Error_Msg_Qual_Level := 0;
end if;
elsif Is_Formal_Subprogram (E) then
return No_List;
-- Check for unconstrained array in exported foreign
-- convention case.
-- Generic types are never frozen as they lack delayed semantic checks
if Has_Foreign_Convention (E)
and then not Is_Imported (E)
and then Is_Array_Type (F_Type)
and then not Is_Constrained (F_Type)
and then Warn_On_Export_Import
elsif Is_Generic_Type (E) then
return No_List;
-- Exclude VM case, since both .NET and JVM can handle
-- unconstrained arrays without a problem.
-- 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
-- freeze node must appear in the same declarative part as E itself.
-- The two-pass elaboration mechanism in gigi guarantees that E will
-- be frozen before the inner call is elaborated. We exclude constants
-- from this test, because deferred constants may be frozen early, and
-- must be diagnosed (e.g. in the case of a deferred constant being used
-- in a default expression). 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 freeze 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.
and then VM_Target = No_VM
elsif In_Open_Scopes (Scope (Test_E))
and then Scope (Test_E) /= Current_Scope
and then Ekind (Test_E) /= E_Constant
then
Error_Msg_Qual_Level := 1;
-- If this is an inherited operation, place the
-- warning on the derived type declaration, rather
-- than on the original subprogram.
declare
S : Entity_Id;
if Nkind (Original_Node (Parent (E))) =
N_Full_Type_Declaration
begin
S := Current_Scope;
while Present (S) loop
if Is_Overloadable (S) then
if Comes_From_Source (S)
or else Is_Generic_Instance (S)
or else Is_Child_Unit (S)
then
Warn_Node := Parent (E);
if Formal = First_Formal (E) then
Error_Msg_NE
("??in inherited operation&", Warn_Node, E);
end if;
exit;
else
Warn_Node := Formal;
return No_List;
end if;
Error_Msg_NE
("?x?type of argument& is unconstrained array",
Warn_Node, Formal);
Error_Msg_NE
("?x?foreign caller must pass bounds explicitly",
Warn_Node, Formal);
Error_Msg_Qual_Level := 0;
end if;
if not From_Limited_With (F_Type) then
if Is_Access_Type (F_Type) then
F_Type := Designated_Type (F_Type);
end if;
S := Scope (S);
end loop;
end;
-- If the formal is an anonymous_access_to_subprogram
-- freeze the subprogram type as well, to prevent
-- scope anomalies in gigi, because there is no other
-- clear point at which it could be frozen.
-- Similarly, an inlined instance body may make reference to global
-- entities, but these references cannot be the proper freezing point
-- for them, and in the absence of inlining freezing will take place in
-- their own scope. Normally instance bodies are analyzed after the
-- enclosing compilation, and everything has been frozen at the proper
-- place, but with front-end inlining an instance body is compiled
-- before the end of the enclosing scope, and as a result out-of-order
-- freezing must be prevented.
if Is_Itype (Etype (Formal))
and then Ekind (F_Type) = E_Subprogram_Type
elsif Front_End_Inlining
and then In_Instance_Body
and then Present (Scope (Test_E))
then
Freeze_And_Append (F_Type, N, Result);
end if;
end if;
declare
S : Entity_Id;
Next_Formal (Formal);
begin
S := Scope (Test_E);
while Present (S) loop
if Is_Generic_Instance (S) then
exit;
else
S := Scope (S);
end if;
end loop;
-- Case of function: similar checks on return type
if Ekind (E) = E_Function then
-- Check whether function is declared elsewhere.
Late_Freezing :=
Get_Source_Unit (E) /= Get_Source_Unit (N)
and then Returns_Limited_View (E)
and then not In_Open_Scopes (Scope (E));
-- Freeze return type
R_Type := Etype (E);
-- AI05-0151: the return type may have been incomplete
-- at the point of declaration. Replace it with the full
-- view, unless the current type is a limited view. In
-- that case the full view is in a different unit, and
-- gigi finds the non-limited view after the other unit
-- is elaborated.
if No (S) then
return No_List;
end if;
end;
if Ekind (R_Type) = E_Incomplete_Type
and then Present (Full_View (R_Type))
and then not From_Limited_With (R_Type)
then
R_Type := Full_View (R_Type);
Set_Etype (E, R_Type);
elsif Ekind (E) = E_Generic_Package then
return Freeze_Generic_Entities (E);
end if;
-- If the return type is a limited view and the non-
-- limited view is still incomplete, the function has
-- to be frozen at a later time.
-- Add checks to detect proper initialization of scalars that may appear
-- as subprogram parameters.
elsif Ekind (R_Type) = E_Incomplete_Type
and then From_Limited_With (R_Type)
and then
Ekind (Non_Limited_View (R_Type)) = E_Incomplete_Type
then
Set_Is_Frozen (E, False);
Set_Returns_Limited_View (E);
return Result;
if Is_Subprogram (E) and then Check_Validity_Of_Parameters then
Apply_Parameter_Validity_Checks (E);
end if;
Freeze_And_Append (R_Type, N, Result);
-- Deal with delayed aspect specifications. The analysis of the aspect
-- is required to be delayed to the freeze point, thus we analyze the
-- pragma or attribute definition clause in the tree at this point. We
-- also analyze the aspect specification node at the freeze point when
-- the aspect doesn't correspond to pragma/attribute definition clause.
-- Check suspicious return type for C function
if Has_Delayed_Aspects (E) then
Analyze_Aspects_At_Freeze_Point (E);
end if;
if Warn_On_Export_Import
and then (Convention (E) = Convention_C
or else
Convention (E) = Convention_CPP)
and then (Is_Imported (E) or else Is_Exported (E))
then
-- Check suspicious return of fat C pointer
-- Here to freeze the entity
if Is_Access_Type (R_Type)
and then Esize (R_Type) > Ttypes.System_Address_Size
and then not Has_Warnings_Off (E)
and then not Has_Warnings_Off (R_Type)
then
Error_Msg_N
("?x?return type of& does not "
& "correspond to C pointer!", E);
Set_Is_Frozen (E);
-- Check suspicious return of boolean
-- Case of entity being frozen is other than a type
elsif Root_Type (R_Type) = Standard_Boolean
and then Convention (R_Type) = Convention_Ada
and then VM_Target = No_VM
and then not Has_Warnings_Off (E)
and then not Has_Warnings_Off (R_Type)
and then not Has_Size_Clause (R_Type)
then
declare
N : constant Node_Id :=
Result_Definition (Declaration_Node (E));
begin
Error_Msg_NE
("return type of & is an 8-bit Ada Boolean?x?",
N, E);
Error_Msg_NE
("\use appropriate corresponding type in C "
& "(e.g. char)?x?", N, E);
end;
if not Is_Type (E) then
-- Check suspicious return tagged type
-- If entity is exported or imported and does not have an external
-- name, now is the time to provide the appropriate default name.
-- Skip this if the entity is stubbed, since we don't need a name
-- for any stubbed routine. For the case on intrinsics, if no
-- external name is specified, then calls will be handled in
-- Exp_Intr.Expand_Intrinsic_Call, and no name is needed. If an
-- external name is provided, then Expand_Intrinsic_Call leaves
-- calls in place for expansion by GIGI.
elsif (Is_Tagged_Type (R_Type)
or else (Is_Access_Type (R_Type)
and then
Is_Tagged_Type
(Designated_Type (R_Type))))
and then Convention (E) = Convention_C
and then not Has_Warnings_Off (E)
and then not Has_Warnings_Off (R_Type)
if (Is_Imported (E) or else Is_Exported (E))
and then No (Interface_Name (E))
and then Convention (E) /= Convention_Stubbed
and then Convention (E) /= Convention_Intrinsic
then
Error_Msg_N
("?x?return type of & does not "
& "correspond to C type!", E);
Set_Encoded_Interface_Name
(E, Get_Default_External_Name (E));
-- Check return of wrong convention subprogram pointer
-- If entity is an atomic object appearing in a declaration and
-- the expression is an aggregate, assign it to a temporary to
-- ensure that the actual assignment is done atomically rather
-- than component-wise (the assignment to the temp may be done
-- component-wise, but that is harmless).
elsif Ekind (R_Type) = E_Access_Subprogram_Type
and then not Has_Foreign_Convention (R_Type)
and then not Has_Warnings_Off (E)
and then not Has_Warnings_Off (R_Type)
elsif Is_Atomic (E)
and then Nkind (Parent (E)) = N_Object_Declaration
and then Present (Expression (Parent (E)))
and then Nkind (Expression (Parent (E))) = N_Aggregate
and then Is_Atomic_Aggregate (Expression (Parent (E)), Etype (E))
then
Error_Msg_N
("?x?& should return a foreign "
& "convention subprogram pointer", E);
Error_Msg_Sloc := Sloc (R_Type);
Error_Msg_NE
("\?x?add Convention pragma to declaration of& #",
E, R_Type);
end if;
null;
end if;
-- Give warning for suspicious return of a result of an
-- unconstrained array type in a foreign convention
-- function.
if Has_Foreign_Convention (E)
-- We are looking for a return of unconstrained array
-- Subprogram case
and then Is_Array_Type (R_Type)
and then not Is_Constrained (R_Type)
if Is_Subprogram (E) then
-- Exclude imported routines, the warning does not
-- belong on the import, but rather on the routine
-- definition.
-- Check for needing to wrap imported subprogram
and then not Is_Imported (E)
Wrap_Imported_Subprogram (E);
-- Exclude VM case, since both .NET and JVM can handle
-- return of unconstrained arrays without a problem.
-- Freeze all parameter types and the return type (RM 13.14(14)).
-- However skip this for internal subprograms. This is also where
-- any extra formal parameters are created since we now know
-- whether the subprogram will use a foreign convention.
and then VM_Target = No_VM
-- In Ada 2012, freezing a subprogram does not always freeze
-- the corresponding profile (see AI05-019). An attribute
-- reference is not a freezing point of the profile.
-- Other constructs that should not freeze ???
-- Check that general warning is enabled, and that it
-- is not suppressed for this particular case.
-- This processing doesn't apply to internal entities (see below)
and then Warn_On_Export_Import
and then not Has_Warnings_Off (E)
and then not Has_Warnings_Off (R_Type)
then
Error_Msg_N
("?x?foreign convention function& should not " &
"return unconstrained array!", E);
end if;
if not Is_Internal (E) then
if not Freeze_Profile (E) then
return Result;
end if;
end;
end if;
-- Must freeze its parent first if it is a derived subprogram
......
gcc/ada/gnat1drv.adb
......@@ -585,7 +585,12 @@ procedure Gnat1drv is
-- Treat -gnatn as equivalent to -gnatN for non-GCC targets
if Inline_Active and then not Front_End_Inlining then
if Inline_Active and not Front_End_Inlining then
-- We really should have a tag for this, what if we added a new
-- back end some day, it would not be true for this test, but it
-- would be non-GCC, so this is a bit troublesome ???
Front_End_Inlining := VM_Target /= No_VM or else AAMP_On_Target;
end if;
......
gcc/ada/sem_ch13.adb
......@@ -3018,14 +3018,16 @@ package body Sem_Ch13 is
-- of a package declaration, the pragma needs to be inserted
-- in the list of declarations for the associated package.
-- There is no issue of visibility delay for these aspects.
-- Aspect is legal on a local instantiation of a library-
-- level generic unit.
if A_Id in Library_Unit_Aspects
and then
Nkind_In (N, N_Package_Declaration,
N_Generic_Package_Declaration)
and then Nkind (Parent (N)) /= N_Compilation_Unit
-- Aspect is legal on a local instantiation of a library-
-- level generic unit.
and then not Is_Generic_Instance (Defining_Entity (N))
then
Error_Msg_N
......
gcc/ada/sem_res.adb
......@@ -6696,6 +6696,18 @@ package body Sem_Res is
then
return True;
-- The volatile object appears as the expression of a type conversion
-- occurring in a non-interfering context.
elsif Nkind_In (Context, N_Type_Conversion,
N_Unchecked_Type_Conversion)
and then Expression (Context) = Obj_Ref
and then Is_OK_Volatile_Context
(Context => Parent (Context),
Obj_Ref => Context)
then
return True;
-- Allow references to volatile objects in various checks. This is
-- not a direct SPARK 2014 requirement.
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment