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> 2014-10-10 Ed Schonberg <schonberg@adacore.com>
* sem_ch13.adb (Analyze_Aspect_Specifications, Library_Unit_Aspects): * sem_ch13.adb (Analyze_Aspect_Specifications, Library_Unit_Aspects):
......
gcc/ada/freeze.adb
...@@ -1857,6 +1857,13 @@ package body Freeze is ...@@ -1857,6 +1857,13 @@ package body Freeze is
-- Create Freeze_Generic_Entity nodes for types declared in a generic -- Create Freeze_Generic_Entity nodes for types declared in a generic
-- package. Recurse on inner generic packages. -- 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); procedure Freeze_Record_Type (Rec : Entity_Id);
-- Freeze record type, including freezing component types, and freezing -- Freeze record type, including freezing component types, and freezing
-- primitive operations if this is a tagged type. -- primitive operations if this is a tagged type.
...@@ -2681,346 +2688,681 @@ package body Freeze is ...@@ -2681,346 +2688,681 @@ package body Freeze is
return Flist; return Flist;
end Freeze_Generic_Entities; end Freeze_Generic_Entities;
------------------------ --------------------
-- Freeze_Record_Type -- -- Freeze_Profile --
------------------------ --------------------
procedure Freeze_Record_Type (Rec : Entity_Id) is function Freeze_Profile (E : Entity_Id) return Boolean is
ADC : Node_Id; F_Type : Entity_Id;
Comp : Entity_Id; R_Type : Entity_Id;
IR : Node_Id; Warn_Node : Node_Id;
Prev : Entity_Id;
Junk : Boolean; begin
pragma Warnings (Off, Junk); -- Loop through formals
Rec_Pushed : Boolean := False; Formal := First_Formal (E);
-- Set True if the record type scope Rec has been pushed on the scope while Present (Formal) loop
-- stack. Needed for the analysis of delayed aspects specified to the F_Type := Etype (Formal);
-- components of Rec.
SSO_ADC : Node_Id; -- AI05-0151: incomplete types can appear in a profile.
-- Scalar_Storage_Order attribute definition clause for the record -- By the time the entity is frozen, the full view must
-- be available, unless it is a limited view.
Unplaced_Component : Boolean := False; if Is_Incomplete_Type (F_Type)
-- Set True if we find at least one component with no component and then Present (Full_View (F_Type))
-- clause (used to warn about useless Pack pragmas). 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; Freeze_And_Append (F_Type, N, Result);
-- 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; if Is_Private_Type (F_Type)
-- Set True if we find at least one component which is aliased. This and then Is_Private_Type (Base_Type (F_Type))
-- is used to prevent Implicit_Packing of the record, since packing and then No (Full_View (Base_Type (F_Type)))
-- cannot modify the size of alignment of an aliased component. 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; if In_Instance then
-- Set True if we find at least one component whose type has a Set_Is_Frozen (E, False);
-- Scalar_Storage_Order attribute definition clause. Result := No_List;
return False;
All_Scalar_Components : Boolean := True; elsif not After_Last_Declaration
-- Set False if we encounter a component of a non-scalar type 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; -- Check suspicious parameter for C function. These tests
Scalar_Component_Total_Esize : Uint := Uint_0; -- apply only to exported/imported subprograms.
-- 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 Warn_On_Export_Import
-- If N is an allocator, possibly wrapped in one or more level of and then Comes_From_Source (E)
-- qualified expression(s), return the inner allocator node, else and then (Convention (E) = Convention_C
-- return Empty. 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); Error_Msg_Qual_Level := 1;
-- 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); -- Check suspicious use of fat C pointer
-- 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.
--------------------- if Is_Access_Type (F_Type)
-- Check_Allocator -- 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 -- Check suspicious return of boolean
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;
----------------- elsif Root_Type (F_Type) = Standard_Boolean
-- Check_Itype -- 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 -- Check suspicious tagged type
Desig : constant Entity_Id := Designated_Type (Typ);
begin elsif (Is_Tagged_Type (F_Type)
if not Is_Frozen (Desig) or else (Is_Access_Type (F_Type)
and then Is_Frozen (Base_Type (Desig)) and then
Is_Tagged_Type
(Designated_Type (F_Type))))
and then Convention (E) = Convention_C
then 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 -- Check wrong convention subprogram pointer
-- access subtype is elaborated early enough. This cannot be
-- done if the subtype may depend on discriminants.
if Ekind (Comp) = E_Component elsif Ekind (F_Type) = E_Access_Subprogram_Type
and then Is_Itype (Etype (Comp)) and then not Has_Foreign_Convention (F_Type)
and then not Has_Discriminants (Rec)
then then
IR := Make_Itype_Reference (Sloc (Comp)); Error_Msg_N ("?x?subprogram pointer & should "
Set_Itype (IR, Desig); & "have foreign convention!", Formal);
Add_To_Result (IR); Error_Msg_Sloc := Sloc (F_Type);
Error_Msg_NE
("\?x?add Convention pragma to declaration of &#",
Formal, F_Type);
end if; end if;
elsif Ekind (Typ) = E_Anonymous_Access_Subprogram_Type -- Turn off name qualification after message output
and then Convention (Desig) /= Convention_Protected
then
Set_Is_Frozen (Desig);
end if;
end Check_Itype;
------------------------------------ Error_Msg_Qual_Level := 0;
-- Freeze_Choices_In_Variant_Part -- end if;
------------------------------------
procedure Freeze_Choices_In_Variant_Part (VP : Node_Id) is -- Check for unconstrained array in exported foreign
pragma Assert (Nkind (VP) = N_Variant_Part); -- convention case.
Variant : Node_Id; if Has_Foreign_Convention (E)
Choice : Node_Id; and then not Is_Imported (E)
CL : Node_Id; and then Is_Array_Type (F_Type)
and then not Is_Constrained (F_Type)
and then Warn_On_Export_Import
begin -- Exclude VM case, since both .NET and JVM can handle
-- Loop through variants -- unconstrained arrays without a problem.
Variant := First_Non_Pragma (Variants (VP)); and then VM_Target = No_VM
while Present (Variant) loop 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)); if Nkind (Original_Node (Parent (E))) = N_Full_Type_Declaration
while Present (Choice) loop
if Nkind (Choice) in N_Has_Etype
and then Present (Etype (Choice))
then 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; end if;
Next_Non_Pragma (Choice); Error_Msg_NE ("?x?type of argument& is unconstrained array",
end loop; 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 Is_Itype (Etype (Formal))
if Present (Variant_Part (CL)) then and then Ekind (F_Type) = E_Subprogram_Type
Freeze_Choices_In_Variant_Part (Variant_Part (CL)); then
Freeze_And_Append (F_Type, N, Result);
end if; end if;
end if; end if;
Next_Non_Pragma (Variant); Next_Formal (Formal);
end loop; end loop;
end Freeze_Choices_In_Variant_Part;
-- Start of processing for Freeze_Record_Type -- Case of function: similar checks on return type
begin if Ekind (E) = E_Function then
-- 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); -- Check whether function is declared elsewhere.
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 Late_Freezing :=
-- order to properly analyze the aspects. 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 -- Freeze return type
Install_Discriminants (Rec);
end if;
end if;
Analyze_Aspects_At_Freeze_Point (Comp); R_Type := Etype (E);
end if;
Next_Entity (Comp); -- AI05-0151: the return type may have been incomplete
end loop; -- 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 if Ekind (R_Type) = E_Incomplete_Type
-- during the delayed aspect analysis process. 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 the return type is a limited view and the non-
if Has_Discriminants (Rec) then -- limited view is still incomplete, the function has
Uninstall_Discriminants (Rec); -- to be frozen at a later time.
end if;
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; end if;
-- Freeze components and embedded subtypes Freeze_And_Append (R_Type, N, Result);
Comp := First_Entity (Rec); -- Check suspicious return type for C function
Prev := Empty;
while Present (Comp) loop
if Is_Aliased (Comp) then
Aliased_Component := True;
end if;
-- 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 if Is_Access_Type (R_Type)
declare and then Esize (R_Type) > Ttypes.System_Address_Size
CC : constant Node_Id := Component_Clause (Comp); 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 -- Check suspicious return of boolean
-- 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)) elsif Root_Type (R_Type) = Standard_Boolean
and then Is_Record_Type (Underlying_Type and then Convention (R_Type) = Convention_Ada
(Scope (Etype (Comp)))) 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 then
Undelay_Type (Etype (Comp)); declare
end if; N : constant Node_Id :=
Result_Definition (Declaration_Node (E));
Freeze_And_Append (Etype (Comp), N, Result); 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)) elsif (Is_Tagged_Type (R_Type)
and then Has_Pragma_Pack (Rec) 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 -- Check return of wrong convention subprogram pointer
-- cannot happen in that case.
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 then
declare Error_Msg_N ("?x?& should return a foreign "
CN : constant Name_Id := & "convention subprogram pointer", E);
Get_Convention_Name (Convention (Etype (Comp))); Error_Msg_Sloc := Sloc (R_Type);
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 Error_Msg_NE
("\component & may not have % compatible " ("\?x?add Convention pragma to declaration of& #",
& "representation??", PP, Comp); E, R_Type);
end if; end if;
end;
end if; end if;
-- Check for error of component clause given for variable -- Give warning for suspicious return of a result of an
-- sized type. We have to delay this test till this point, -- unconstrained array type in a foreign convention
-- since the component type has to be frozen for us to know -- function.
-- if it is variable length.
if Present (CC) then if Has_Foreign_Convention (E)
Placed_Component := True;
-- We omit this test in a generic context, it will be -- We are looking for a return of unconstrained array
-- applied at instantiation time.
if Inside_A_Generic then and then Is_Array_Type (R_Type)
null; and then not Is_Constrained (R_Type)
-- Also omit this test in CodePeer mode, since we do not -- Exclude imported routines, the warning does not
-- have sufficient info on size and rep clauses. -- belong on the import, but rather on the routine
-- definition.
elsif CodePeer_Mode then and then not Is_Imported (E)
null;
-- Do the check -- Exclude VM case, since both .NET and JVM can handle
-- return of unconstrained arrays without a problem.
elsif not and then VM_Target = No_VM
Size_Known_At_Compile_Time
(Underlying_Type (Etype (Comp))) -- 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 then
Error_Msg_N Error_Msg_N ("?x?foreign convention function& should not " &
("component clause not allowed for variable " & "return unconstrained array!", E);
"length component", CC);
end if; end if;
else
Unplaced_Component := True;
end if; 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 Rec_Pushed : Boolean := False;
-- the required byte boundary alignment. -- 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) SSO_ADC : Node_Id;
and then Normalized_First_Bit (Comp) mod -- Scalar_Storage_Order attribute definition clause for the record
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 Unplaced_Component : Boolean := False;
-- this stage we might be dealing with a real component, or with -- Set True if we find at least one component with no component
-- an implicit subtype declaration. -- clause (used to warn about useless Pack pragmas).
if not Is_Scalar_Type (Etype (Comp)) then Placed_Component : Boolean := False;
All_Scalar_Components := False; -- Set True if we find at least one component with a component
else -- clause (used to warn about useless Bit_Order pragmas, and also
Scalar_Component_Total_RM_Size := -- to detect cases where Implicit_Packing may have an effect).
Scalar_Component_Total_RM_Size + RM_Size (Etype (Comp));
Scalar_Component_Total_Esize := Aliased_Component : Boolean := False;
Scalar_Component_Total_Esize + Esize (Etype (Comp)); -- Set True if we find at least one component which is aliased. This
end if; -- 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 -- 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 -- a record or array subtype and its base type has not yet been
...@@ -3713,648 +4055,308 @@ package body Freeze is ...@@ -3713,648 +4055,308 @@ package body Freeze is
begin begin
-- Nothing to do if not imported -- Nothing to do if not imported
if not Is_Imported (E) then if not Is_Imported (E) then
return; 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 entity is an atomic object appearing in a declaration and -- Test enabling conditions for wrapping
-- 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 Is_Atomic (E) elsif Is_Subprogram (E)
and then Nkind (Parent (E)) = N_Object_Declaration and then Present (Contract (E))
and then Present (Expression (Parent (E))) and then Present (Pre_Post_Conditions (Contract (E)))
and then Nkind (Expression (Parent (E))) = N_Aggregate and then not GNATprove_Mode
and then Is_Atomic_Aggregate (Expression (Parent (E)), Etype (E))
then then
null; -- Here we do the wrap
end if;
-- 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)). Set_Is_Imported (E, False);
-- However skip this for internal subprograms. This is also where Set_Interface_Name (E, Empty);
-- any extra formal parameters are created since we now know Set_Has_Completion (E, False);
-- whether the subprogram will use a foreign convention. Set_Import_Pragma (E, Empty);
-- In Ada 2012, freezing a subprogram does not always freeze -- Grab the subprogram declaration and specification
-- the corresponding profile (see AI05-019). An attribute
-- reference is not a freezing point of the profile.
-- Other constructs that should not freeze ???
if Ada_Version > Ada_2005 Spec := Declaration_Node (E);
and then Nkind (N) = N_Attribute_Reference
then
null;
elsif not Is_Internal (E) then -- Build parameter list that we need
declare
F_Type : Entity_Id;
R_Type : Entity_Id;
Warn_Node : Node_Id;
begin Parms := New_List;
-- Loop through formals 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); -- Build the call
while Present (Formal) loop
F_Type := Etype (Formal);
-- AI05-0151: incomplete types can appear in a profile. if Ekind_In (E, E_Function, E_Generic_Function) then
-- By the time the entity is frozen, the full view must Stmt :=
-- be available, unless it is a limited view. Make_Simple_Return_Statement (Loc,
Expression =>
Make_Function_Call (Loc,
Name => Make_Identifier (Loc, CE),
Parameter_Associations => Parms));
if Is_Incomplete_Type (F_Type) else
and then Present (Full_View (F_Type)) Stmt :=
and then not From_Limited_With (F_Type) Make_Procedure_Call_Statement (Loc,
then Name => Make_Identifier (Loc, CE),
F_Type := Full_View (F_Type); Parameter_Associations => Parms);
Set_Etype (Formal, F_Type);
end if; end if;
Freeze_And_Append (F_Type, N, Result); -- Now build the body
if Is_Private_Type (F_Type) Bod :=
and then Is_Private_Type (Base_Type (F_Type)) Make_Subprogram_Body (Loc,
and then No (Full_View (Base_Type (F_Type))) Specification =>
and then not Is_Generic_Type (F_Type) Copy_Separate_Tree (Spec),
and then not Is_Derived_Type (F_Type) Declarations => New_List (
then Make_Subprogram_Declaration (Loc,
-- If the type of a formal is incomplete, subprogram Specification =>
-- is being frozen prematurely. Within an instance Copy_Separate_Tree (Spec)),
-- (but not within a wrapper package) this is an Iprag),
-- artifact of our need to regard the end of an Handled_Statement_Sequence =>
-- instantiation as a freeze point. Otherwise it is Make_Handled_Sequence_Of_Statements (Loc,
-- a definite error. Statements => New_List (Stmt),
End_Label => Make_Identifier (Loc, CE)));
if In_Instance then -- Append the body to freeze result
Set_Is_Frozen (E, False);
return No_List;
elsif not After_Last_Declaration Add_To_Result (Bod);
and then not Freezing_Library_Level_Tagged_Type return;
then
Error_Msg_Node_1 := F_Type;
Error_Msg
("type& must be fully defined before this point",
Loc);
end if;
end if;
-- Check suspicious parameter for C function. These tests -- Case of imported subprogram that does not get wrapped
-- apply only to exported/imported subprograms.
if Warn_On_Export_Import else
and then Comes_From_Source (E) -- Set Is_Public. All imported entities need an external symbol
and then (Convention (E) = Convention_C -- created for them since they are always referenced from another
or else -- object file. Note this used to be set when we set Is_Imported
Convention (E) = Convention_CPP) -- back in Sem_Prag, but now we delay it to this point, since we
and then (Is_Imported (E) or else Is_Exported (E)) -- don't want to set this flag if we wrap an imported subprogram.
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
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) begin
and then Esize (F_Type) > Ttypes.System_Address_Size -- 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 then
Error_Msg_N Test_E := Underlying_Type (Scope (E));
("?x?type of & does not correspond to C pointer!", end if;
Formal);
-- 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 if Is_Frozen (E) then
and then Convention (F_Type) = Convention_Ada return No_List;
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);
-- 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) elsif Inside_A_Generic and then External_Ref_In_Generic (Test_E) then
or else (Is_Access_Type (F_Type) if Has_Delayed_Aspects (E) then
and then Analyze_Aspects_At_Freeze_Point (E);
Is_Tagged_Type end if;
(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);
-- Check wrong convention subprogram pointer return No_List;
elsif Ekind (F_Type) = E_Access_Subprogram_Type -- AI05-0213: A formal incomplete type does not freeze the actual. In
and then not Has_Foreign_Convention (F_Type) -- 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 then
Error_Msg_N return No_List;
("?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;
-- Turn off name qualification after message output -- Formal subprograms are never frozen
Error_Msg_Qual_Level := 0; elsif Is_Formal_Subprogram (E) then
end if; return No_List;
-- Check for unconstrained array in exported foreign -- Generic types are never frozen as they lack delayed semantic checks
-- convention case.
if Has_Foreign_Convention (E) elsif Is_Generic_Type (E) then
and then not Is_Imported (E) return No_List;
and then Is_Array_Type (F_Type)
and then not Is_Constrained (F_Type)
and then Warn_On_Export_Import
-- Exclude VM case, since both .NET and JVM can handle -- Do not freeze a global entity within an inner scope created during
-- unconstrained arrays without a problem. -- 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 then
Error_Msg_Qual_Level := 1; declare
S : Entity_Id;
-- If this is an inherited operation, place the
-- warning on the derived type declaration, rather
-- than on the original subprogram.
if Nkind (Original_Node (Parent (E))) = begin
N_Full_Type_Declaration 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 then
Warn_Node := Parent (E); exit;
if Formal = First_Formal (E) then
Error_Msg_NE
("??in inherited operation&", Warn_Node, E);
end if;
else else
Warn_Node := Formal; return No_List;
end if; 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; end if;
if not From_Limited_With (F_Type) then S := Scope (S);
if Is_Access_Type (F_Type) then end loop;
F_Type := Designated_Type (F_Type); end;
end if;
-- If the formal is an anonymous_access_to_subprogram -- Similarly, an inlined instance body may make reference to global
-- freeze the subprogram type as well, to prevent -- entities, but these references cannot be the proper freezing point
-- scope anomalies in gigi, because there is no other -- for them, and in the absence of inlining freezing will take place in
-- clear point at which it could be frozen. -- 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)) elsif Front_End_Inlining
and then Ekind (F_Type) = E_Subprogram_Type and then In_Instance_Body
and then Present (Scope (Test_E))
then then
Freeze_And_Append (F_Type, N, Result); declare
end if; S : Entity_Id;
end if;
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; end loop;
-- Case of function: similar checks on return type if No (S) then
return No_List;
if Ekind (E) = E_Function then end if;
end;
-- 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 Ekind (R_Type) = E_Incomplete_Type elsif Ekind (E) = E_Generic_Package then
and then Present (Full_View (R_Type)) return Freeze_Generic_Entities (E);
and then not From_Limited_With (R_Type) end if;
then
R_Type := Full_View (R_Type);
Set_Etype (E, R_Type);
-- If the return type is a limited view and the non- -- Add checks to detect proper initialization of scalars that may appear
-- limited view is still incomplete, the function has -- as subprogram parameters.
-- to be frozen at a later time.
elsif Ekind (R_Type) = E_Incomplete_Type if Is_Subprogram (E) and then Check_Validity_Of_Parameters then
and then From_Limited_With (R_Type) Apply_Parameter_Validity_Checks (E);
and then
Ekind (Non_Limited_View (R_Type)) = E_Incomplete_Type
then
Set_Is_Frozen (E, False);
Set_Returns_Limited_View (E);
return Result;
end if; 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 -- Here to freeze the entity
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 Is_Access_Type (R_Type) Set_Is_Frozen (E);
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);
-- Check suspicious return of boolean -- Case of entity being frozen is other than a type
elsif Root_Type (R_Type) = Standard_Boolean if not Is_Type (E) then
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;
-- 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) if (Is_Imported (E) or else Is_Exported (E))
or else (Is_Access_Type (R_Type) and then No (Interface_Name (E))
and then and then Convention (E) /= Convention_Stubbed
Is_Tagged_Type and then Convention (E) /= Convention_Intrinsic
(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 then
Error_Msg_N Set_Encoded_Interface_Name
("?x?return type of & does not " (E, Get_Default_External_Name (E));
& "correspond to C type!", 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 elsif Is_Atomic (E)
and then not Has_Foreign_Convention (R_Type) and then Nkind (Parent (E)) = N_Object_Declaration
and then not Has_Warnings_Off (E) and then Present (Expression (Parent (E)))
and then not Has_Warnings_Off (R_Type) and then Nkind (Expression (Parent (E))) = N_Aggregate
and then Is_Atomic_Aggregate (Expression (Parent (E)), Etype (E))
then then
Error_Msg_N null;
("?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;
end if; end if;
-- Give warning for suspicious return of a result of an -- Subprogram case
-- unconstrained array type in a foreign convention
-- function.
if Has_Foreign_Convention (E)
-- We are looking for a return of unconstrained array
and then Is_Array_Type (R_Type) if Is_Subprogram (E) then
and then not Is_Constrained (R_Type)
-- Exclude imported routines, the warning does not -- Check for needing to wrap imported subprogram
-- belong on the import, but rather on the routine
-- definition.
and then not Is_Imported (E) Wrap_Imported_Subprogram (E);
-- Exclude VM case, since both .NET and JVM can handle -- Freeze all parameter types and the return type (RM 13.14(14)).
-- return of unconstrained arrays without a problem. -- 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 -- This processing doesn't apply to internal entities (see below)
-- is not suppressed for this particular case.
and then Warn_On_Export_Import if not Is_Internal (E) then
and then not Has_Warnings_Off (E) if not Freeze_Profile (E) then
and then not Has_Warnings_Off (R_Type) return Result;
then
Error_Msg_N
("?x?foreign convention function& should not " &
"return unconstrained array!", E);
end if;
end if; end if;
end;
end if; end if;
-- Must freeze its parent first if it is a derived subprogram -- Must freeze its parent first if it is a derived subprogram
......
gcc/ada/gnat1drv.adb
...@@ -585,7 +585,12 @@ procedure Gnat1drv is ...@@ -585,7 +585,12 @@ procedure Gnat1drv is
-- Treat -gnatn as equivalent to -gnatN for non-GCC targets -- 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; Front_End_Inlining := VM_Target /= No_VM or else AAMP_On_Target;
end if; end if;
......
gcc/ada/sem_ch13.adb
...@@ -3018,14 +3018,16 @@ package body Sem_Ch13 is ...@@ -3018,14 +3018,16 @@ package body Sem_Ch13 is
-- of a package declaration, the pragma needs to be inserted -- of a package declaration, the pragma needs to be inserted
-- in the list of declarations for the associated package. -- in the list of declarations for the associated package.
-- There is no issue of visibility delay for these aspects. -- 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 if A_Id in Library_Unit_Aspects
and then and then
Nkind_In (N, N_Package_Declaration, Nkind_In (N, N_Package_Declaration,
N_Generic_Package_Declaration) N_Generic_Package_Declaration)
and then Nkind (Parent (N)) /= N_Compilation_Unit 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)) and then not Is_Generic_Instance (Defining_Entity (N))
then then
Error_Msg_N Error_Msg_N
......
gcc/ada/sem_res.adb
...@@ -6696,6 +6696,18 @@ package body Sem_Res is ...@@ -6696,6 +6696,18 @@ package body Sem_Res is
then then
return True; 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 -- Allow references to volatile objects in various checks. This is
-- not a direct SPARK 2014 requirement. -- 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