frontend.adb, [...]: Minor reformatting and code clean up.
2014-07-29 Robert Dewar <dewar@adacore.com> * frontend.adb, inline.adb, sem_util.adb, sem_res.adb, prepcomp.ads: Minor reformatting and code clean up. * exp_ch6.adb (Expand_Actuals): Generate predicate test unconditionally for case of OUT or IN OUT actual (before this was generated only for certain subcases, which is wrong, the test is always needed). From-SVN: r213208
This commit is contained in:
parent
1c4ff014fe
commit
fc27e20e72
|
@ -1,3 +1,12 @@
|
||||||
|
2014-07-29 Robert Dewar <dewar@adacore.com>
|
||||||
|
|
||||||
|
* frontend.adb, inline.adb, sem_util.adb, sem_res.adb,
|
||||||
|
prepcomp.ads: Minor reformatting and code clean up.
|
||||||
|
* exp_ch6.adb (Expand_Actuals): Generate predicate test
|
||||||
|
unconditionally for case of OUT or IN OUT actual (before this
|
||||||
|
was generated only for certain subcases, which is wrong, the
|
||||||
|
test is always needed).
|
||||||
|
|
||||||
2014-07-29 Ed Schonberg <schonberg@adacore.com>
|
2014-07-29 Ed Schonberg <schonberg@adacore.com>
|
||||||
|
|
||||||
* sem_ch3.adb: Move Has_Defaulted_Discriminants to sem_util.
|
* sem_ch3.adb: Move Has_Defaulted_Discriminants to sem_util.
|
||||||
|
|
|
@ -1743,10 +1743,6 @@ package body Exp_Ch6 is
|
||||||
-- be handled separately because the name does not denote an
|
-- be handled separately because the name does not denote an
|
||||||
-- overloadable entity.
|
-- overloadable entity.
|
||||||
|
|
||||||
-- If the formal is class-wide the corresponding postcondition
|
|
||||||
-- procedure does not include a predicate call, so it has to be
|
|
||||||
-- generated explicitly.
|
|
||||||
|
|
||||||
if not Is_Init_Proc (Subp)
|
if not Is_Init_Proc (Subp)
|
||||||
and then (Has_Aspect (E_Actual, Aspect_Predicate)
|
and then (Has_Aspect (E_Actual, Aspect_Predicate)
|
||||||
or else
|
or else
|
||||||
|
@ -1754,22 +1750,9 @@ package body Exp_Ch6 is
|
||||||
or else
|
or else
|
||||||
Has_Aspect (E_Actual, Aspect_Static_Predicate))
|
Has_Aspect (E_Actual, Aspect_Static_Predicate))
|
||||||
and then Present (Predicate_Function (E_Actual))
|
and then Present (Predicate_Function (E_Actual))
|
||||||
then
|
|
||||||
if Is_Entity_Name (Actual)
|
|
||||||
or else
|
|
||||||
(Is_Derived_Type (E_Actual)
|
|
||||||
and then Is_Overloadable (Subp)
|
|
||||||
and then Is_Inherited_Operation_For_Type (Subp, E_Actual))
|
|
||||||
then
|
then
|
||||||
Append_To (Post_Call,
|
Append_To (Post_Call,
|
||||||
Make_Predicate_Check (E_Actual, Actual));
|
Make_Predicate_Check (E_Actual, Actual));
|
||||||
|
|
||||||
elsif Is_Class_Wide_Type (E_Formal)
|
|
||||||
and then not Is_Class_Wide_Type (E_Actual)
|
|
||||||
then
|
|
||||||
Append_To (Post_Call,
|
|
||||||
Make_Predicate_Check (E_Actual, Actual));
|
|
||||||
end if;
|
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- Processing for IN parameters
|
-- Processing for IN parameters
|
||||||
|
|
|
@ -71,6 +71,39 @@ procedure Frontend is
|
||||||
Config_Pragmas : List_Id;
|
Config_Pragmas : List_Id;
|
||||||
-- Gather configuration pragmas
|
-- Gather configuration pragmas
|
||||||
|
|
||||||
|
function Need_To_Be_In_The_Dependencies (Pragma_List : List_Id)
|
||||||
|
return Boolean;
|
||||||
|
-- Check if a configuration pragmas file that contains the Pragma_List
|
||||||
|
-- should be a dependency for the source being compiled. Returns
|
||||||
|
-- False if Pragma_List is Error_List or contains only pragmas
|
||||||
|
-- Source_File_Name_Project, returns True otherwise.
|
||||||
|
|
||||||
|
------------------------------------
|
||||||
|
-- Need_To_Be_In_The_Dependencies --
|
||||||
|
------------------------------------
|
||||||
|
|
||||||
|
function Need_To_Be_In_The_Dependencies (Pragma_List : List_Id)
|
||||||
|
return Boolean
|
||||||
|
is
|
||||||
|
Prag : Node_Id;
|
||||||
|
Pname : Name_Id;
|
||||||
|
begin
|
||||||
|
if Pragma_List /= Error_List then
|
||||||
|
Prag := First (Pragma_List);
|
||||||
|
while Present (Prag) loop
|
||||||
|
Pname := Pragma_Name (Prag);
|
||||||
|
|
||||||
|
if Pname /= Name_Source_File_Name_Project then
|
||||||
|
return True;
|
||||||
|
end if;
|
||||||
|
|
||||||
|
Next (Prag);
|
||||||
|
end loop;
|
||||||
|
end if;
|
||||||
|
|
||||||
|
return False;
|
||||||
|
end Need_To_Be_In_The_Dependencies;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
-- Carry out package initializations. These are initializations which might
|
-- Carry out package initializations. These are initializations which might
|
||||||
-- logically be performed at elaboration time, were it not for the fact
|
-- logically be performed at elaboration time, were it not for the fact
|
||||||
|
@ -144,8 +177,6 @@ begin
|
||||||
|
|
||||||
Prag : Node_Id;
|
Prag : Node_Id;
|
||||||
|
|
||||||
Temp_File : Boolean;
|
|
||||||
|
|
||||||
begin
|
begin
|
||||||
-- We always analyze config files with style checks off, since
|
-- We always analyze config files with style checks off, since
|
||||||
-- we don't want a miscellaneous gnat.adc that is around to
|
-- we don't want a miscellaneous gnat.adc that is around to
|
||||||
|
@ -166,10 +197,23 @@ begin
|
||||||
Name_Len := 8;
|
Name_Len := 8;
|
||||||
Source_gnat_adc := Load_Config_File (Name_Enter);
|
Source_gnat_adc := Load_Config_File (Name_Enter);
|
||||||
|
|
||||||
|
-- Case of gnat.adc file present
|
||||||
|
|
||||||
if Source_gnat_adc /= No_Source_File then
|
if Source_gnat_adc /= No_Source_File then
|
||||||
|
|
||||||
|
-- Parse the gnat.adc file for configuration pragmas
|
||||||
|
|
||||||
Initialize_Scanner (No_Unit, Source_gnat_adc);
|
Initialize_Scanner (No_Unit, Source_gnat_adc);
|
||||||
Config_Pragmas := Par (Configuration_Pragmas => True);
|
Config_Pragmas := Par (Configuration_Pragmas => True);
|
||||||
|
|
||||||
|
-- We unconditionally add a compilation dependency for gnat.adc
|
||||||
|
-- so that if it changes, we force a recompilation. This is a
|
||||||
|
-- fairly recent (2014-03-28) change.
|
||||||
|
|
||||||
Prepcomp.Add_Dependency (Source_gnat_adc);
|
Prepcomp.Add_Dependency (Source_gnat_adc);
|
||||||
|
|
||||||
|
-- Case of no gnat.adc file present
|
||||||
|
|
||||||
else
|
else
|
||||||
Config_Pragmas := Empty_List;
|
Config_Pragmas := Empty_List;
|
||||||
end if;
|
end if;
|
||||||
|
@ -196,15 +240,17 @@ begin
|
||||||
-- Now deal with specified config pragmas files if there are any
|
-- Now deal with specified config pragmas files if there are any
|
||||||
|
|
||||||
if Opt.Config_File_Names /= null then
|
if Opt.Config_File_Names /= null then
|
||||||
|
|
||||||
|
-- Loop through config pragmas files
|
||||||
|
|
||||||
for Index in Opt.Config_File_Names'Range loop
|
for Index in Opt.Config_File_Names'Range loop
|
||||||
|
|
||||||
|
-- See if extension is .TMP/.tmp indicating a temporary config
|
||||||
|
-- file (which we ignore from the dependency point of view).
|
||||||
|
|
||||||
Name_Len := Config_File_Names (Index)'Length;
|
Name_Len := Config_File_Names (Index)'Length;
|
||||||
Name_Buffer (1 .. Name_Len) := Config_File_Names (Index).all;
|
Name_Buffer (1 .. Name_Len) := Config_File_Names (Index).all;
|
||||||
Temp_File :=
|
-- Load the file, error if we did not find it
|
||||||
Name_Len > 4
|
|
||||||
and then
|
|
||||||
(Name_Buffer (Name_Len - 3 .. Name_Len) = ".TMP"
|
|
||||||
or else
|
|
||||||
Name_Buffer (Name_Len - 3 .. Name_Len) = ".tmp");
|
|
||||||
|
|
||||||
Source_Config_File := Load_Config_File (Name_Enter);
|
Source_Config_File := Load_Config_File (Name_Enter);
|
||||||
|
|
||||||
|
@ -213,13 +259,29 @@ begin
|
||||||
("cannot find configuration pragmas file "
|
("cannot find configuration pragmas file "
|
||||||
& Config_File_Names (Index).all);
|
& Config_File_Names (Index).all);
|
||||||
|
|
||||||
elsif not Temp_File then
|
-- If we did find the file, and it contains pragmas other than
|
||||||
|
-- Source_File_Name_Project, then we unconditionally add a
|
||||||
|
-- compilation dependency for it so that if it changes, we force
|
||||||
|
-- a recompilation. This is a fairly recent (2014-03-28) change.
|
||||||
|
|
||||||
|
else
|
||||||
|
|
||||||
|
-- Parse the config pragmas file, and accumulate results
|
||||||
|
|
||||||
|
Initialize_Scanner (No_Unit, Source_Config_File);
|
||||||
|
|
||||||
|
declare
|
||||||
|
Pragma_List : constant List_Id :=
|
||||||
|
Par (Configuration_Pragmas => True);
|
||||||
|
begin
|
||||||
|
if Need_To_Be_In_The_Dependencies (Pragma_List) then
|
||||||
Prepcomp.Add_Dependency (Source_Config_File);
|
Prepcomp.Add_Dependency (Source_Config_File);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
Initialize_Scanner (No_Unit, Source_Config_File);
|
Append_List_To (Config_Pragmas, Pragma_List);
|
||||||
Append_List_To
|
end;
|
||||||
(Config_Pragmas, Par (Configuration_Pragmas => True));
|
end if;
|
||||||
|
|
||||||
end loop;
|
end loop;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
|
|
@ -1499,12 +1499,12 @@ package body Inline is
|
||||||
--------------------------
|
--------------------------
|
||||||
|
|
||||||
function In_Some_Private_Part (N : Node_Id) return Boolean is
|
function In_Some_Private_Part (N : Node_Id) return Boolean is
|
||||||
P : Node_Id := N;
|
P : Node_Id;
|
||||||
PP : Node_Id;
|
PP : Node_Id;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
while Present (P)
|
P := N;
|
||||||
and then Present (Parent (P))
|
while Present (P) and then Present (Parent (P)) loop
|
||||||
loop
|
|
||||||
PP := Parent (P);
|
PP := Parent (P);
|
||||||
|
|
||||||
if Nkind (PP) = N_Package_Specification
|
if Nkind (PP) = N_Package_Specification
|
||||||
|
@ -1515,6 +1515,7 @@ package body Inline is
|
||||||
|
|
||||||
P := PP;
|
P := PP;
|
||||||
end loop;
|
end loop;
|
||||||
|
|
||||||
return False;
|
return False;
|
||||||
end In_Some_Private_Part;
|
end In_Some_Private_Part;
|
||||||
|
|
||||||
|
@ -1541,6 +1542,8 @@ package body Inline is
|
||||||
return Nkind (Original_Node (Decl)) = N_Expression_Function;
|
return Nkind (Original_Node (Decl)) = N_Expression_Function;
|
||||||
end Is_Expression_Function;
|
end Is_Expression_Function;
|
||||||
|
|
||||||
|
-- Local declarations
|
||||||
|
|
||||||
Id : Entity_Id; -- Procedure or function entity for the subprogram
|
Id : Entity_Id; -- Procedure or function entity for the subprogram
|
||||||
|
|
||||||
-- Start of Can_Be_Inlined_In_GNATprove_Mode
|
-- Start of Can_Be_Inlined_In_GNATprove_Mode
|
||||||
|
@ -2162,9 +2165,10 @@ package body Inline is
|
||||||
or else Has_Pragma_Inline_Always (Spec_Id)
|
or else Has_Pragma_Inline_Always (Spec_Id)
|
||||||
or else (Has_Pragma_Inline (Spec_Id)
|
or else (Has_Pragma_Inline (Spec_Id)
|
||||||
and then ((Optimization_Level > 0
|
and then ((Optimization_Level > 0
|
||||||
and then Ekind (Spec_Id)
|
and then Ekind (Spec_Id) =
|
||||||
= E_Function)
|
E_Function)
|
||||||
or else Front_End_Inlining));
|
or else Front_End_Inlining));
|
||||||
|
|
||||||
Body_To_Analyze : Node_Id;
|
Body_To_Analyze : Node_Id;
|
||||||
|
|
||||||
-- Start of processing for Check_Body_To_Inline
|
-- Start of processing for Check_Body_To_Inline
|
||||||
|
|
|
@ -31,10 +31,9 @@ with Types; use Types;
|
||||||
package Prepcomp is
|
package Prepcomp is
|
||||||
|
|
||||||
procedure Add_Dependency (S : Source_File_Index);
|
procedure Add_Dependency (S : Source_File_Index);
|
||||||
-- Add a dependency on a non-source file.
|
-- Add a dependency on a non-source file. This is used internally for the
|
||||||
-- This is used internally for the preprocessing data file and the
|
-- preprocessing data file and the preprocessing definition file, and also
|
||||||
-- preprocessing definition file, and also externally for non-temporary
|
-- externally for non-temporary configuration pragmas files.
|
||||||
-- configuration pragmas files.
|
|
||||||
|
|
||||||
procedure Add_Dependencies;
|
procedure Add_Dependencies;
|
||||||
-- Add dependencies on the preprocessing data file and the preprocessing
|
-- Add dependencies on the preprocessing data file and the preprocessing
|
||||||
|
|
|
@ -2978,7 +2978,7 @@ package body Sem_Res is
|
||||||
|
|
||||||
procedure Check_Aliased_Parameter;
|
procedure Check_Aliased_Parameter;
|
||||||
-- Check rules on aliased parameters and related accessibility rules
|
-- Check rules on aliased parameters and related accessibility rules
|
||||||
-- in (3.10.2 (10.2-10.4)).
|
-- in (RM 3.10.2 (10.2-10.4)).
|
||||||
|
|
||||||
procedure Check_Argument_Order;
|
procedure Check_Argument_Order;
|
||||||
-- Performs a check for the case where the actuals are all simple
|
-- Performs a check for the case where the actuals are all simple
|
||||||
|
@ -3063,19 +3063,19 @@ package body Sem_Res is
|
||||||
|
|
||||||
elsif Ekind (Etype (Nam)) = E_Anonymous_Access_Type then
|
elsif Ekind (Etype (Nam)) = E_Anonymous_Access_Type then
|
||||||
if Nkind (Parent (N)) = N_Type_Conversion
|
if Nkind (Parent (N)) = N_Type_Conversion
|
||||||
and then Type_Access_Level (Etype (Parent (N)))
|
and then Type_Access_Level (Etype (Parent (N))) <
|
||||||
< Object_Access_Level (A)
|
Object_Access_Level (A)
|
||||||
then
|
then
|
||||||
Error_Msg_N ("aliased actual has wrong accessibility", A);
|
Error_Msg_N ("aliased actual has wrong accessibility", A);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
elsif Nkind (Parent (N)) = N_Qualified_Expression
|
elsif Nkind (Parent (N)) = N_Qualified_Expression
|
||||||
and then Nkind (Parent (Parent (N))) = N_Allocator
|
and then Nkind (Parent (Parent (N))) = N_Allocator
|
||||||
and then Type_Access_Level (Etype (Parent (Parent (N))))
|
and then Type_Access_Level (Etype (Parent (Parent (N)))) <
|
||||||
< Object_Access_Level (A)
|
Object_Access_Level (A)
|
||||||
then
|
then
|
||||||
Error_Msg_N
|
Error_Msg_N
|
||||||
("Aliased actual in allocator has wrong accessibility", A);
|
("aliased actual in allocator has wrong accessibility", A);
|
||||||
end if;
|
end if;
|
||||||
end if;
|
end if;
|
||||||
end Check_Aliased_Parameter;
|
end Check_Aliased_Parameter;
|
||||||
|
|
|
@ -7345,8 +7345,8 @@ package body Sem_Util is
|
||||||
begin
|
begin
|
||||||
return Has_Discriminants (Typ)
|
return Has_Discriminants (Typ)
|
||||||
and then Present (First_Discriminant (Typ))
|
and then Present (First_Discriminant (Typ))
|
||||||
and then Present
|
and then Present (Discriminant_Default_Value
|
||||||
(Discriminant_Default_Value (First_Discriminant (Typ)));
|
(First_Discriminant (Typ)));
|
||||||
end Has_Defaulted_Discriminants;
|
end Has_Defaulted_Discriminants;
|
||||||
|
|
||||||
-------------------
|
-------------------
|
||||||
|
|
Loading…
Reference in New Issue