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:
Robert Dewar
Arnaud Charlet
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>
|
||||
|
||||
* 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
|
||||
-- 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)
|
||||
and then (Has_Aspect (E_Actual, Aspect_Predicate)
|
||||
or else
|
||||
|
|
@ -1755,21 +1751,8 @@ package body Exp_Ch6 is
|
|||
Has_Aspect (E_Actual, Aspect_Static_Predicate))
|
||||
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
|
||||
Append_To (Post_Call,
|
||||
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;
|
||||
Append_To (Post_Call,
|
||||
Make_Predicate_Check (E_Actual, Actual));
|
||||
end if;
|
||||
|
||||
-- Processing for IN parameters
|
||||
|
|
|
|||
|
|
@ -71,6 +71,39 @@ procedure Frontend is
|
|||
Config_Pragmas : List_Id;
|
||||
-- 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
|
||||
-- Carry out package initializations. These are initializations which might
|
||||
-- logically be performed at elaboration time, were it not for the fact
|
||||
|
|
@ -144,8 +177,6 @@ begin
|
|||
|
||||
Prag : Node_Id;
|
||||
|
||||
Temp_File : Boolean;
|
||||
|
||||
begin
|
||||
-- We always analyze config files with style checks off, since
|
||||
-- we don't want a miscellaneous gnat.adc that is around to
|
||||
|
|
@ -166,10 +197,23 @@ begin
|
|||
Name_Len := 8;
|
||||
Source_gnat_adc := Load_Config_File (Name_Enter);
|
||||
|
||||
-- Case of gnat.adc file present
|
||||
|
||||
if Source_gnat_adc /= No_Source_File then
|
||||
|
||||
-- Parse the gnat.adc file for configuration pragmas
|
||||
|
||||
Initialize_Scanner (No_Unit, Source_gnat_adc);
|
||||
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);
|
||||
|
||||
-- Case of no gnat.adc file present
|
||||
|
||||
else
|
||||
Config_Pragmas := Empty_List;
|
||||
end if;
|
||||
|
|
@ -196,15 +240,17 @@ begin
|
|||
-- Now deal with specified config pragmas files if there are any
|
||||
|
||||
if Opt.Config_File_Names /= null then
|
||||
|
||||
-- Loop through config pragmas files
|
||||
|
||||
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_Buffer (1 .. Name_Len) := Config_File_Names (Index).all;
|
||||
Temp_File :=
|
||||
Name_Len > 4
|
||||
and then
|
||||
(Name_Buffer (Name_Len - 3 .. Name_Len) = ".TMP"
|
||||
or else
|
||||
Name_Buffer (Name_Len - 3 .. Name_Len) = ".tmp");
|
||||
-- Load the file, error if we did not find it
|
||||
|
||||
Source_Config_File := Load_Config_File (Name_Enter);
|
||||
|
||||
|
|
@ -213,13 +259,29 @@ begin
|
|||
("cannot find configuration pragmas file "
|
||||
& Config_File_Names (Index).all);
|
||||
|
||||
elsif not Temp_File then
|
||||
Prepcomp.Add_Dependency (Source_Config_File);
|
||||
-- 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);
|
||||
end if;
|
||||
|
||||
Append_List_To (Config_Pragmas, Pragma_List);
|
||||
end;
|
||||
end if;
|
||||
|
||||
Initialize_Scanner (No_Unit, Source_Config_File);
|
||||
Append_List_To
|
||||
(Config_Pragmas, Par (Configuration_Pragmas => True));
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
|
|
|
|||
|
|
@ -1499,12 +1499,12 @@ package body Inline is
|
|||
--------------------------
|
||||
|
||||
function In_Some_Private_Part (N : Node_Id) return Boolean is
|
||||
P : Node_Id := N;
|
||||
P : Node_Id;
|
||||
PP : Node_Id;
|
||||
|
||||
begin
|
||||
while Present (P)
|
||||
and then Present (Parent (P))
|
||||
loop
|
||||
P := N;
|
||||
while Present (P) and then Present (Parent (P)) loop
|
||||
PP := Parent (P);
|
||||
|
||||
if Nkind (PP) = N_Package_Specification
|
||||
|
|
@ -1515,6 +1515,7 @@ package body Inline is
|
|||
|
||||
P := PP;
|
||||
end loop;
|
||||
|
||||
return False;
|
||||
end In_Some_Private_Part;
|
||||
|
||||
|
|
@ -1541,6 +1542,8 @@ package body Inline is
|
|||
return Nkind (Original_Node (Decl)) = N_Expression_Function;
|
||||
end Is_Expression_Function;
|
||||
|
||||
-- Local declarations
|
||||
|
||||
Id : Entity_Id; -- Procedure or function entity for the subprogram
|
||||
|
||||
-- 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 (Spec_Id)
|
||||
and then ((Optimization_Level > 0
|
||||
and then Ekind (Spec_Id)
|
||||
= E_Function)
|
||||
and then Ekind (Spec_Id) =
|
||||
E_Function)
|
||||
or else Front_End_Inlining));
|
||||
|
||||
Body_To_Analyze : Node_Id;
|
||||
|
||||
-- Start of processing for Check_Body_To_Inline
|
||||
|
|
|
|||
|
|
@ -31,10 +31,9 @@ with Types; use Types;
|
|||
package Prepcomp is
|
||||
|
||||
procedure Add_Dependency (S : Source_File_Index);
|
||||
-- Add a dependency on a non-source file.
|
||||
-- This is used internally for the preprocessing data file and the
|
||||
-- preprocessing definition file, and also externally for non-temporary
|
||||
-- configuration pragmas files.
|
||||
-- Add a dependency on a non-source file. This is used internally for the
|
||||
-- preprocessing data file and the preprocessing definition file, and also
|
||||
-- externally for non-temporary configuration pragmas files.
|
||||
|
||||
procedure Add_Dependencies;
|
||||
-- Add dependencies on the preprocessing data file and the preprocessing
|
||||
|
|
|
|||
|
|
@ -2978,7 +2978,7 @@ package body Sem_Res is
|
|||
|
||||
procedure Check_Aliased_Parameter;
|
||||
-- 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;
|
||||
-- Performs a check for the case where the actuals are all simple
|
||||
|
|
@ -3050,12 +3050,12 @@ package body Sem_Res is
|
|||
|
||||
else
|
||||
Error_Msg_NE ("untagged actual does not match "
|
||||
& "aliased formal&", A, F);
|
||||
& "aliased formal&", A, F);
|
||||
end if;
|
||||
|
||||
else
|
||||
Error_Msg_NE ("actual for aliased formal& must be "
|
||||
& "aliased object", A, F);
|
||||
& "aliased object", A, F);
|
||||
end if;
|
||||
|
||||
if Ekind (Nam) = E_Procedure then
|
||||
|
|
@ -3063,19 +3063,19 @@ package body Sem_Res is
|
|||
|
||||
elsif Ekind (Etype (Nam)) = E_Anonymous_Access_Type then
|
||||
if Nkind (Parent (N)) = N_Type_Conversion
|
||||
and then Type_Access_Level (Etype (Parent (N)))
|
||||
< Object_Access_Level (A)
|
||||
and then Type_Access_Level (Etype (Parent (N))) <
|
||||
Object_Access_Level (A)
|
||||
then
|
||||
Error_Msg_N ("aliased actual has wrong accessibility", A);
|
||||
end if;
|
||||
|
||||
elsif Nkind (Parent (N)) = N_Qualified_Expression
|
||||
and then Nkind (Parent (Parent (N))) = N_Allocator
|
||||
and then Type_Access_Level (Etype (Parent (Parent (N))))
|
||||
< Object_Access_Level (A)
|
||||
and then Type_Access_Level (Etype (Parent (Parent (N)))) <
|
||||
Object_Access_Level (A)
|
||||
then
|
||||
Error_Msg_N
|
||||
("Aliased actual in allocator has wrong accessibility", A);
|
||||
("aliased actual in allocator has wrong accessibility", A);
|
||||
end if;
|
||||
end if;
|
||||
end Check_Aliased_Parameter;
|
||||
|
|
|
|||
|
|
@ -7345,8 +7345,8 @@ package body Sem_Util is
|
|||
begin
|
||||
return Has_Discriminants (Typ)
|
||||
and then Present (First_Discriminant (Typ))
|
||||
and then Present
|
||||
(Discriminant_Default_Value (First_Discriminant (Typ)));
|
||||
and then Present (Discriminant_Default_Value
|
||||
(First_Discriminant (Typ)));
|
||||
end Has_Defaulted_Discriminants;
|
||||
|
||||
-------------------
|
||||
|
|
|
|||
Loading…
Reference in New Issue