mirror of
https://gcc.gnu.org/git/gcc.git
synced 2025-01-15 16:24:09 +08:00
[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
This commit is contained in:
Arnaud Charlet
parent
c9f95e4c25
commit
4d1429b2dd
@ -1,3 +1,14 @@
|
||||
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):
|
||||
|
||||
@ -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,6 +2688,341 @@ package body Freeze is
|
||||
return Flist;
|
||||
end Freeze_Generic_Entities;
|
||||
|
||||
--------------------
|
||||
-- Freeze_Profile --
|
||||
--------------------
|
||||
|
||||
function Freeze_Profile (E : Entity_Id) return Boolean is
|
||||
F_Type : Entity_Id;
|
||||
R_Type : Entity_Id;
|
||||
Warn_Node : Node_Id;
|
||||
|
||||
begin
|
||||
-- Loop through formals
|
||||
|
||||
Formal := First_Formal (E);
|
||||
while Present (Formal) loop
|
||||
F_Type := Etype (Formal);
|
||||
|
||||
-- AI05-0151: incomplete types can appear in a profile.
|
||||
-- By the time the entity is frozen, the full view must
|
||||
-- be available, unless it is a limited view.
|
||||
|
||||
if Is_Incomplete_Type (F_Type)
|
||||
and then Present (Full_View (F_Type))
|
||||
and then not From_Limited_With (F_Type)
|
||||
then
|
||||
F_Type := Full_View (F_Type);
|
||||
Set_Etype (Formal, F_Type);
|
||||
end if;
|
||||
|
||||
Freeze_And_Append (F_Type, N, Result);
|
||||
|
||||
if Is_Private_Type (F_Type)
|
||||
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.
|
||||
|
||||
if In_Instance then
|
||||
Set_Is_Frozen (E, False);
|
||||
Result := No_List;
|
||||
return False;
|
||||
|
||||
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;
|
||||
|
||||
-- Check suspicious parameter for C function. These tests
|
||||
-- apply only to exported/imported subprograms.
|
||||
|
||||
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
|
||||
|
||||
Error_Msg_Qual_Level := 1;
|
||||
|
||||
-- Check suspicious use of fat C pointer
|
||||
|
||||
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);
|
||||
|
||||
-- Check suspicious return of boolean
|
||||
|
||||
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);
|
||||
|
||||
-- Check suspicious tagged type
|
||||
|
||||
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);
|
||||
|
||||
-- Check wrong convention subprogram pointer
|
||||
|
||||
elsif Ekind (F_Type) = E_Access_Subprogram_Type
|
||||
and then not Has_Foreign_Convention (F_Type)
|
||||
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;
|
||||
|
||||
-- Turn off name qualification after message output
|
||||
|
||||
Error_Msg_Qual_Level := 0;
|
||||
end if;
|
||||
|
||||
-- Check for unconstrained array in exported foreign
|
||||
-- convention case.
|
||||
|
||||
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
|
||||
|
||||
-- Exclude VM case, since both .NET and JVM can handle
|
||||
-- unconstrained arrays without a problem.
|
||||
|
||||
and then VM_Target = No_VM
|
||||
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.
|
||||
|
||||
if Nkind (Original_Node (Parent (E))) = N_Full_Type_Declaration
|
||||
then
|
||||
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;
|
||||
|
||||
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;
|
||||
|
||||
-- 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 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_Formal (Formal);
|
||||
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 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 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.
|
||||
|
||||
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_And_Append (R_Type, N, Result);
|
||||
|
||||
-- Check suspicious return type for C function
|
||||
|
||||
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 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);
|
||||
|
||||
-- Check suspicious return of boolean
|
||||
|
||||
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;
|
||||
|
||||
-- Check suspicious return tagged type
|
||||
|
||||
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);
|
||||
|
||||
-- Check return of wrong convention subprogram pointer
|
||||
|
||||
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
|
||||
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;
|
||||
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
|
||||
|
||||
and then Is_Array_Type (R_Type)
|
||||
and then not Is_Constrained (R_Type)
|
||||
|
||||
-- Exclude imported routines, the warning does not
|
||||
-- belong on the import, but rather on the routine
|
||||
-- definition.
|
||||
|
||||
and then not Is_Imported (E)
|
||||
|
||||
-- Exclude VM case, since both .NET and JVM can handle
|
||||
-- return of unconstrained arrays without a problem.
|
||||
|
||||
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 ("?x?foreign convention function& should not " &
|
||||
"return unconstrained array!", E);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
return True;
|
||||
end Freeze_Profile;
|
||||
|
||||
------------------------
|
||||
-- Freeze_Record_Type --
|
||||
------------------------
|
||||
@ -4009,352 +4351,12 @@ package body Freeze is
|
||||
-- reference is not a freezing point of the profile.
|
||||
-- Other constructs that should not freeze ???
|
||||
|
||||
if Ada_Version > Ada_2005
|
||||
and then Nkind (N) = N_Attribute_Reference
|
||||
then
|
||||
null;
|
||||
-- This processing doesn't apply to internal entities (see below)
|
||||
|
||||
elsif not Is_Internal (E) then
|
||||
declare
|
||||
F_Type : Entity_Id;
|
||||
R_Type : Entity_Id;
|
||||
Warn_Node : Node_Id;
|
||||
|
||||
begin
|
||||
-- Loop through formals
|
||||
|
||||
Formal := First_Formal (E);
|
||||
while Present (Formal) loop
|
||||
F_Type := Etype (Formal);
|
||||
|
||||
-- AI05-0151: incomplete types can appear in a profile.
|
||||
-- By the time the entity is frozen, the full view must
|
||||
-- be available, unless it is a limited view.
|
||||
|
||||
if Is_Incomplete_Type (F_Type)
|
||||
and then Present (Full_View (F_Type))
|
||||
and then not From_Limited_With (F_Type)
|
||||
then
|
||||
F_Type := Full_View (F_Type);
|
||||
Set_Etype (Formal, F_Type);
|
||||
end if;
|
||||
|
||||
Freeze_And_Append (F_Type, N, Result);
|
||||
|
||||
if Is_Private_Type (F_Type)
|
||||
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.
|
||||
|
||||
if In_Instance then
|
||||
Set_Is_Frozen (E, False);
|
||||
return No_List;
|
||||
|
||||
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;
|
||||
|
||||
-- Check suspicious parameter for C function. These tests
|
||||
-- apply only to exported/imported subprograms.
|
||||
|
||||
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
|
||||
|
||||
Error_Msg_Qual_Level := 1;
|
||||
|
||||
-- Check suspicious use of fat C pointer
|
||||
|
||||
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);
|
||||
|
||||
-- Check suspicious return of boolean
|
||||
|
||||
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);
|
||||
|
||||
-- Check suspicious tagged type
|
||||
|
||||
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);
|
||||
|
||||
-- Check wrong convention subprogram pointer
|
||||
|
||||
elsif Ekind (F_Type) = E_Access_Subprogram_Type
|
||||
and then not Has_Foreign_Convention (F_Type)
|
||||
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;
|
||||
|
||||
-- Turn off name qualification after message output
|
||||
|
||||
Error_Msg_Qual_Level := 0;
|
||||
end if;
|
||||
|
||||
-- Check for unconstrained array in exported foreign
|
||||
-- convention case.
|
||||
|
||||
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
|
||||
|
||||
-- Exclude VM case, since both .NET and JVM can handle
|
||||
-- unconstrained arrays without a problem.
|
||||
|
||||
and then VM_Target = No_VM
|
||||
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.
|
||||
|
||||
if Nkind (Original_Node (Parent (E))) =
|
||||
N_Full_Type_Declaration
|
||||
then
|
||||
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;
|
||||
|
||||
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;
|
||||
|
||||
-- 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 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_Formal (Formal);
|
||||
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 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 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.
|
||||
|
||||
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;
|
||||
end if;
|
||||
|
||||
Freeze_And_Append (R_Type, N, Result);
|
||||
|
||||
-- Check suspicious return type for C function
|
||||
|
||||
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 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);
|
||||
|
||||
-- Check suspicious return of boolean
|
||||
|
||||
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;
|
||||
|
||||
-- Check suspicious return tagged type
|
||||
|
||||
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);
|
||||
|
||||
-- Check return of wrong convention subprogram pointer
|
||||
|
||||
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
|
||||
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;
|
||||
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
|
||||
|
||||
and then Is_Array_Type (R_Type)
|
||||
and then not Is_Constrained (R_Type)
|
||||
|
||||
-- Exclude imported routines, the warning does not
|
||||
-- belong on the import, but rather on the routine
|
||||
-- definition.
|
||||
|
||||
and then not Is_Imported (E)
|
||||
|
||||
-- Exclude VM case, since both .NET and JVM can handle
|
||||
-- return of unconstrained arrays without a problem.
|
||||
|
||||
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
|
||||
("?x?foreign convention function& should not " &
|
||||
"return unconstrained array!", E);
|
||||
end if;
|
||||
end if;
|
||||
end;
|
||||
if not Is_Internal (E) then
|
||||
if not Freeze_Profile (E) then
|
||||
return Result;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- Must freeze its parent first if it is a derived subprogram
|
||||
|
||||
@ -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;
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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.
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user