[multiple changes]
2014-10-10 Robert Dewar <dewar@adacore.com> * freeze.adb, sem_attr.adb: Minor reformatting. 2014-10-10 Johannes Kanig <kanig@adacore.com> * a-cfdlli.ads, a-cfhama.ads, a-cfhase.ads, a-cforma.ads, a-cforse.ads, a-cofove.ads: add "Default_Initial_Condition" to container type. 2014-10-10 Vincent Celier <celier@adacore.com> * prj-conf.adb (Do_Autoconf): In Codepeer mode, do not try to get any configuration switches from the project file. 2014-10-10 Ed Schonberg <schonberg@adacore.com> * sem_ch12.adb (Build_Wrapper): Renamed as Build_Operator_Wrapper. (Build_Function_Wrapper): New function, to construct a wrapper function for actuals that are functions with an arbitrary number of parameters. Used in GNATProve mode to simplify proof propagation in instantiations. From-SVN: r216092
This commit is contained in:
Arnaud Charlet
parent
4d1429b2dd
commit
9ceeaf9d16
11 changed files with 224 additions and 118 deletions
|
|
@ -1,3 +1,26 @@
|
|||
2014-10-10 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* freeze.adb, sem_attr.adb: Minor reformatting.
|
||||
|
||||
2014-10-10 Johannes Kanig <kanig@adacore.com>
|
||||
|
||||
* a-cfdlli.ads, a-cfhama.ads, a-cfhase.ads, a-cforma.ads,
|
||||
a-cforse.ads, a-cofove.ads: add "Default_Initial_Condition"
|
||||
to container type.
|
||||
|
||||
2014-10-10 Vincent Celier <celier@adacore.com>
|
||||
|
||||
* prj-conf.adb (Do_Autoconf): In Codepeer mode, do not try to get
|
||||
any configuration switches from the project file.
|
||||
|
||||
2014-10-10 Ed Schonberg <schonberg@adacore.com>
|
||||
|
||||
* sem_ch12.adb (Build_Wrapper): Renamed as Build_Operator_Wrapper.
|
||||
(Build_Function_Wrapper): New function, to construct a wrapper
|
||||
function for actuals that are functions with an arbitrary
|
||||
number of parameters. Used in GNATProve mode to simplify proof
|
||||
propagation in instantiations.
|
||||
|
||||
2014-10-10 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* freeze.adb, gnat1drv.adb, sem_ch13.adb: Minor reformatting and
|
||||
|
|
|
|||
|
|
@ -69,7 +69,8 @@ package Ada.Containers.Formal_Doubly_Linked_Lists is
|
|||
Iterable => (First => First,
|
||||
Next => Next,
|
||||
Has_Element => Has_Element,
|
||||
Element => Element);
|
||||
Element => Element),
|
||||
Default_Initial_Condition;
|
||||
pragma Preelaborable_Initialization (List);
|
||||
|
||||
type Cursor is private;
|
||||
|
|
|
|||
|
|
@ -74,7 +74,8 @@ package Ada.Containers.Formal_Hashed_Maps is
|
|||
Iterable => (First => First,
|
||||
Next => Next,
|
||||
Has_Element => Has_Element,
|
||||
Element => Element);
|
||||
Element => Element),
|
||||
Default_Initial_Condition;
|
||||
pragma Preelaborable_Initialization (Map);
|
||||
|
||||
type Cursor is private;
|
||||
|
|
|
|||
|
|
@ -76,7 +76,8 @@ package Ada.Containers.Formal_Hashed_Sets is
|
|||
Iterable => (First => First,
|
||||
Next => Next,
|
||||
Has_Element => Has_Element,
|
||||
Element => Element);
|
||||
Element => Element),
|
||||
Default_Initial_Condition;
|
||||
pragma Preelaborable_Initialization (Set);
|
||||
|
||||
type Cursor is private;
|
||||
|
|
|
|||
|
|
@ -78,7 +78,8 @@ package Ada.Containers.Formal_Ordered_Maps is
|
|||
Iterable => (First => First,
|
||||
Next => Next,
|
||||
Has_Element => Has_Element,
|
||||
Element => Element);
|
||||
Element => Element),
|
||||
Default_Initial_Condition;
|
||||
pragma Preelaborable_Initialization (Map);
|
||||
|
||||
type Cursor is private;
|
||||
|
|
|
|||
|
|
@ -77,7 +77,8 @@ package Ada.Containers.Formal_Ordered_Sets is
|
|||
Iterable => (First => First,
|
||||
Next => Next,
|
||||
Has_Element => Has_Element,
|
||||
Element => Element);
|
||||
Element => Element),
|
||||
Default_Initial_Condition;
|
||||
pragma Preelaborable_Initialization (Set);
|
||||
|
||||
type Cursor is private;
|
||||
|
|
|
|||
|
|
@ -81,7 +81,8 @@ package Ada.Containers.Formal_Vectors is
|
|||
Iterable => (First => First,
|
||||
Next => Next,
|
||||
Has_Element => Has_Element,
|
||||
Element => Element);
|
||||
Element => Element),
|
||||
Default_Initial_Condition;
|
||||
|
||||
type Cursor is private;
|
||||
pragma Preelaborable_Initialization (Cursor);
|
||||
|
|
|
|||
|
|
@ -1858,11 +1858,10 @@ package body Freeze is
|
|||
-- 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.
|
||||
-- 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
|
||||
|
|
@ -2557,8 +2556,8 @@ package body Freeze is
|
|||
Attribute_Name => Name_Range_Length);
|
||||
Analyze_And_Resolve (Ilen);
|
||||
|
||||
-- No attempt is made to check number of elements
|
||||
-- if not compile time known.
|
||||
-- No attempt is made to check number of elements if not
|
||||
-- compile time known.
|
||||
|
||||
if Nkind (Ilen) /= N_Integer_Literal then
|
||||
Elmts := Uint_0;
|
||||
|
|
@ -2601,9 +2600,9 @@ package body Freeze is
|
|||
end if;
|
||||
end if;
|
||||
|
||||
-- If any of the index types was an enumeration type with a
|
||||
-- non-standard rep clause, then we indicate that the array type
|
||||
-- is always packed (even if it is not bit packed).
|
||||
-- If any of the index types was an enumeration type with a non-
|
||||
-- standard rep clause, then we indicate that the array type is
|
||||
-- always packed (even if it is not bit packed).
|
||||
|
||||
if Non_Standard_Enum then
|
||||
Set_Has_Non_Standard_Rep (Base_Type (Arr));
|
||||
|
|
@ -2704,9 +2703,9 @@ package body Freeze is
|
|||
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.
|
||||
-- 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))
|
||||
|
|
@ -2724,12 +2723,11 @@ package body Freeze is
|
|||
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 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);
|
||||
|
|
@ -2741,13 +2739,12 @@ package body Freeze is
|
|||
then
|
||||
Error_Msg_Node_1 := F_Type;
|
||||
Error_Msg
|
||||
("type& must be fully defined before this point",
|
||||
Loc);
|
||||
("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.
|
||||
-- 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)
|
||||
|
|
@ -2780,20 +2777,22 @@ package body Freeze is
|
|||
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 "
|
||||
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))))
|
||||
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 "
|
||||
Error_Msg_N
|
||||
("?x?& involves a tagged type which does not "
|
||||
& "correspond to any C type!", Formal);
|
||||
|
||||
-- Check wrong convention subprogram pointer
|
||||
|
|
@ -2801,7 +2800,8 @@ package body Freeze is
|
|||
elsif Ekind (F_Type) = E_Access_Subprogram_Type
|
||||
and then not Has_Foreign_Convention (F_Type)
|
||||
then
|
||||
Error_Msg_N ("?x?subprogram pointer & should "
|
||||
Error_Msg_N
|
||||
("?x?subprogram pointer & should "
|
||||
& "have foreign convention!", Formal);
|
||||
Error_Msg_Sloc := Sloc (F_Type);
|
||||
Error_Msg_NE
|
||||
|
|
@ -2814,8 +2814,8 @@ package body Freeze is
|
|||
Error_Msg_Qual_Level := 0;
|
||||
end if;
|
||||
|
||||
-- Check for unconstrained array in exported foreign
|
||||
-- convention case.
|
||||
-- Check for unconstrained array in exported foreign convention
|
||||
-- case.
|
||||
|
||||
if Has_Foreign_Convention (E)
|
||||
and then not Is_Imported (E)
|
||||
|
|
@ -2830,17 +2830,16 @@ package body Freeze is
|
|||
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 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);
|
||||
Error_Msg_NE ("??in inherited operation&", Warn_Node, E);
|
||||
end if;
|
||||
else
|
||||
Warn_Node := Formal;
|
||||
|
|
@ -2987,8 +2986,7 @@ package body Freeze is
|
|||
end if;
|
||||
|
||||
-- Give warning for suspicious return of a result of an
|
||||
-- unconstrained array type in a foreign convention
|
||||
-- function.
|
||||
-- unconstrained array type in a foreign convention function.
|
||||
|
||||
if Has_Foreign_Convention (E)
|
||||
|
||||
|
|
@ -2997,19 +2995,18 @@ package body Freeze is
|
|||
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.
|
||||
-- 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.
|
||||
-- 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.
|
||||
-- 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)
|
||||
|
|
|
|||
|
|
@ -172,7 +172,7 @@ package body Prj.Conf is
|
|||
begin
|
||||
if Config_File = Empty_Node then
|
||||
|
||||
-- Create a dummy config file is none was found
|
||||
-- Create a dummy config file if none was found
|
||||
|
||||
Name_Len := Auto_Cgpr'Length;
|
||||
Name_Buffer (1 .. Name_Len) := Auto_Cgpr;
|
||||
|
|
@ -587,7 +587,7 @@ package body Prj.Conf is
|
|||
or else
|
||||
(Tgt_Name /= No_Name
|
||||
and then (Length_Of_Name (Tgt_Name) = 0
|
||||
or else Target = Get_Name_String (Tgt_Name)));
|
||||
or else Target = Get_Name_String (Tgt_Name)));
|
||||
|
||||
if not OK then
|
||||
if Autoconf_Specified then
|
||||
|
|
@ -931,7 +931,8 @@ package body Prj.Conf is
|
|||
|
||||
declare
|
||||
Obj_Dir : constant String := Name_Buffer (1 .. Name_Len);
|
||||
Config_Switches : Argument_List_Access;
|
||||
Config_Switches : Argument_List_Access :=
|
||||
new Argument_List'(1 .. 0 => null);
|
||||
Db_Switches : Argument_List_Access;
|
||||
Args : Argument_List (1 .. 5);
|
||||
Arg_Last : Positive;
|
||||
|
|
@ -979,10 +980,13 @@ package body Prj.Conf is
|
|||
end case;
|
||||
end if;
|
||||
|
||||
-- Get the config switches. This should be done only now, as some
|
||||
-- runtimes may have been found if the Builder switches.
|
||||
-- If not in Codepeer mode, get the config switches. This should
|
||||
-- be done only now, as some runtimes may have been found if the
|
||||
-- Builder switches.
|
||||
|
||||
Config_Switches := Get_Config_Switches;
|
||||
if not CodePeer_Mode then
|
||||
Config_Switches := Get_Config_Switches;
|
||||
end if;
|
||||
|
||||
-- Get eventual --db switches
|
||||
|
||||
|
|
@ -1082,12 +1086,11 @@ package body Prj.Conf is
|
|||
Write_Eol;
|
||||
|
||||
elsif not Quiet_Output then
|
||||
-- Display no message if we are creating auto.cgpr, unless in
|
||||
-- verbose mode
|
||||
|
||||
if Config_File_Name'Length > 0
|
||||
or else Verbose_Mode
|
||||
then
|
||||
-- Display no message if we are creating auto.cgpr, unless in
|
||||
-- verbose mode.
|
||||
|
||||
if Config_File_Name'Length > 0 or else Verbose_Mode then
|
||||
Write_Str ("creating ");
|
||||
Write_Str (Simple_Name (Args (3).all));
|
||||
Write_Eol;
|
||||
|
|
@ -1300,8 +1303,7 @@ package body Prj.Conf is
|
|||
Config_Command : constant String :=
|
||||
"--config=" & Get_Name_String (Name);
|
||||
|
||||
Runtime_Name : constant String :=
|
||||
Runtime_Name_For (Name);
|
||||
Runtime_Name : constant String := Runtime_Name_For (Name);
|
||||
|
||||
begin
|
||||
if Variable = Nil_Variable_Value
|
||||
|
|
@ -1321,14 +1323,14 @@ package body Prj.Conf is
|
|||
if Is_Absolute_Path (Compiler_Command) then
|
||||
Result (Count) :=
|
||||
new String'
|
||||
(Config_Command & ",," & Runtime_Name & "," &
|
||||
Containing_Directory (Compiler_Command) & "," &
|
||||
Simple_Name (Compiler_Command));
|
||||
(Config_Command & ",," & Runtime_Name & ","
|
||||
& Containing_Directory (Compiler_Command) & ","
|
||||
& Simple_Name (Compiler_Command));
|
||||
else
|
||||
Result (Count) :=
|
||||
new String'
|
||||
(Config_Command & ",," & Runtime_Name & ",," &
|
||||
Compiler_Command);
|
||||
(Config_Command & ",," & Runtime_Name & ",,"
|
||||
& Compiler_Command);
|
||||
end if;
|
||||
end;
|
||||
end if;
|
||||
|
|
@ -1350,20 +1352,14 @@ package body Prj.Conf is
|
|||
|
||||
begin
|
||||
Variable :=
|
||||
Value_Of
|
||||
(Name_Source_Dirs,
|
||||
Project.Decl.Attributes,
|
||||
Shared);
|
||||
Value_Of (Name_Source_Dirs, Project.Decl.Attributes, Shared);
|
||||
|
||||
if Variable = Nil_Variable_Value
|
||||
or else Variable.Default
|
||||
or else Variable.Values /= Nil_String
|
||||
then
|
||||
Variable :=
|
||||
Value_Of
|
||||
(Name_Source_Files,
|
||||
Project.Decl.Attributes,
|
||||
Shared);
|
||||
Value_Of (Name_Source_Files, Project.Decl.Attributes, Shared);
|
||||
return Variable = Nil_Variable_Value
|
||||
or else Variable.Default
|
||||
or else Variable.Values /= Nil_String;
|
||||
|
|
@ -1373,9 +1369,13 @@ package body Prj.Conf is
|
|||
end if;
|
||||
end Might_Have_Sources;
|
||||
|
||||
-- Local Variables
|
||||
|
||||
Success : Boolean;
|
||||
Config_Project_Node : Project_Node_Id := Empty_Node;
|
||||
|
||||
-- Start of processing for Get_Or_Create_Configuration_File
|
||||
|
||||
begin
|
||||
pragma Assert (Prj.Env.Is_Initialized (Env.Project_Path));
|
||||
|
||||
|
|
@ -1472,9 +1472,7 @@ package body Prj.Conf is
|
|||
On_New_Tree_Loaded => null);
|
||||
end if;
|
||||
|
||||
if Config_Project_Node = Empty_Node
|
||||
or else Config = No_Project
|
||||
then
|
||||
if Config_Project_Node = Empty_Node or else Config = No_Project then
|
||||
Raise_Invalid_Config
|
||||
("processing of configuration project """
|
||||
& Config_File_Path.all & """ failed");
|
||||
|
|
@ -1606,7 +1604,6 @@ package body Prj.Conf is
|
|||
Implicit_Project => Implicit_Project);
|
||||
|
||||
if User_Project_Node = Empty_Node then
|
||||
User_Project_Node := Empty_Node;
|
||||
return;
|
||||
end if;
|
||||
|
||||
|
|
|
|||
|
|
@ -11021,7 +11021,6 @@ package body Sem_Attr is
|
|||
|
||||
else
|
||||
Assoc := First (Component_Associations (Aggr));
|
||||
|
||||
while Present (Assoc) loop
|
||||
Comp := First (Choices (Assoc));
|
||||
Expr := Expression (Assoc);
|
||||
|
|
|
|||
|
|
@ -954,10 +954,19 @@ package body Sem_Ch12 is
|
|||
-- In Ada 2005, indicates partial parameterization of a formal
|
||||
-- package. As usual an other association must be last in the list.
|
||||
|
||||
function Build_Wrapper
|
||||
function Build_Function_Wrapper
|
||||
(Formal : Entity_Id;
|
||||
Actual : Entity_Id := Empty) return Node_Id;
|
||||
-- In GNATProve mode, create a wrapper function for actuals that are
|
||||
-- In GNATprove mode, create a wrapper function for actuals that are
|
||||
-- functions with any number of formal parameters, in order to propagate
|
||||
-- their contract to the renaming declarations generated for them.
|
||||
-- If the actual is absent, the formal has a default, and the name of
|
||||
-- the function is that of the formal.
|
||||
|
||||
function Build_Operator_Wrapper
|
||||
(Formal : Entity_Id;
|
||||
Actual : Entity_Id := Empty) return Node_Id;
|
||||
-- In GNATprove mode, create a wrapper function for actuals that are
|
||||
-- operators, in order to propagate their contract to the renaming
|
||||
-- declarations generated for them. If the actual is absent, this is
|
||||
-- a formal with a default, and the name of the operator is that of the
|
||||
|
|
@ -1010,11 +1019,84 @@ package body Sem_Ch12 is
|
|||
-- anonymous types, the presence a formal equality will introduce an
|
||||
-- implicit declaration for the corresponding inequality.
|
||||
|
||||
-------------------
|
||||
-- Build_Wrapper --
|
||||
-------------------
|
||||
----------------------------
|
||||
-- Build_Function_Wrapper --
|
||||
----------------------------
|
||||
|
||||
function Build_Wrapper
|
||||
function Build_Function_Wrapper
|
||||
(Formal : Entity_Id;
|
||||
Actual : Entity_Id := Empty) return Node_Id
|
||||
is
|
||||
Loc : constant Source_Ptr := Sloc (I_Node);
|
||||
Actuals : List_Id;
|
||||
Decl : Node_Id;
|
||||
Func_Name : Node_Id;
|
||||
Func : Entity_Id;
|
||||
N_Parms : Natural;
|
||||
Profile : List_Id;
|
||||
Spec : Node_Id;
|
||||
F : Entity_Id;
|
||||
New_F : Entity_Id;
|
||||
|
||||
begin
|
||||
-- If there is no actual, the formal has a default and is retrieved
|
||||
-- by name. Otherwise the wrapper encloses a call to the actual.
|
||||
|
||||
if No (Actual) then
|
||||
Func_Name := Make_Identifier (Loc, Chars (Formal));
|
||||
else
|
||||
Func_Name := New_Occurrence_Of (Entity (Actual), Loc);
|
||||
end if;
|
||||
|
||||
Func := Make_Defining_Identifier (Loc, Chars (Formal));
|
||||
Set_Ekind (Func, E_Function);
|
||||
Set_Is_Generic_Actual_Subprogram (Func);
|
||||
|
||||
Actuals := New_List;
|
||||
Profile := New_List;
|
||||
|
||||
F := First_Formal (Formal);
|
||||
N_Parms := 0;
|
||||
while Present (F) loop
|
||||
|
||||
-- Create new formal for profile of wrapper, and add a reference
|
||||
-- to it in the list of actuals for the enclosing call.
|
||||
|
||||
New_F := Make_Temporary
|
||||
(Loc, Character'Val (Character'Pos ('A') + N_Parms));
|
||||
Append_To (Profile,
|
||||
Make_Parameter_Specification (Loc,
|
||||
Defining_Identifier => New_F,
|
||||
Parameter_Type =>
|
||||
Make_Identifier (Loc, Chars => Chars (Etype (F)))));
|
||||
|
||||
Append_To (Actuals, New_Occurrence_Of (New_F, Loc));
|
||||
Next_Formal (F);
|
||||
N_Parms := N_Parms + 1;
|
||||
end loop;
|
||||
|
||||
Spec :=
|
||||
Make_Function_Specification (Loc,
|
||||
Defining_Unit_Name => Func,
|
||||
Parameter_Specifications => Profile,
|
||||
Result_Definition =>
|
||||
Make_Identifier (Loc, Chars (Etype (Formal))));
|
||||
Decl :=
|
||||
Make_Expression_Function (Loc,
|
||||
Specification => Spec,
|
||||
Expression =>
|
||||
Make_Function_Call (Loc,
|
||||
Name => Func_Name,
|
||||
Parameter_Associations => Actuals));
|
||||
|
||||
return Decl;
|
||||
end Build_Function_Wrapper;
|
||||
|
||||
----------------------------
|
||||
-- Build_Operator_Wrapper --
|
||||
----------------------------
|
||||
|
||||
function Build_Operator_Wrapper
|
||||
(Formal : Entity_Id;
|
||||
Actual : Entity_Id := Empty) return Node_Id
|
||||
is
|
||||
|
|
@ -1029,8 +1111,7 @@ package body Sem_Ch12 is
|
|||
Func : Entity_Id;
|
||||
Op_Name : Name_Id;
|
||||
Spec : Node_Id;
|
||||
|
||||
L, R : Node_Id;
|
||||
L, R : Node_Id;
|
||||
|
||||
begin
|
||||
if No (Actual) then
|
||||
|
|
@ -1089,52 +1170,52 @@ package body Sem_Ch12 is
|
|||
|
||||
elsif Is_Binary then
|
||||
if Op_Name = Name_Op_And then
|
||||
Expr := Make_Op_And (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
Expr := Make_Op_And (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
elsif Op_Name = Name_Op_Or then
|
||||
Expr := Make_Op_Or (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
Expr := Make_Op_Or (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
elsif Op_Name = Name_Op_Xor then
|
||||
Expr := Make_Op_Xor (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
Expr := Make_Op_Xor (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
elsif Op_Name = Name_Op_Eq then
|
||||
Expr := Make_Op_Eq (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
Expr := Make_Op_Eq (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
elsif Op_Name = Name_Op_Ne then
|
||||
Expr := Make_Op_Ne (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
Expr := Make_Op_Ne (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
elsif Op_Name = Name_Op_Le then
|
||||
Expr := Make_Op_Le (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
Expr := Make_Op_Le (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
elsif Op_Name = Name_Op_Gt then
|
||||
Expr := Make_Op_Gt (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
Expr := Make_Op_Gt (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
elsif Op_Name = Name_Op_Ge then
|
||||
Expr := Make_Op_Ge (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
Expr := Make_Op_Ge (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
elsif Op_Name = Name_Op_Lt then
|
||||
Expr := Make_Op_Lt (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
Expr := Make_Op_Lt (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
elsif Op_Name = Name_Op_Add then
|
||||
Expr := Make_Op_Add (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
Expr := Make_Op_Add (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
elsif Op_Name = Name_Op_Subtract then
|
||||
Expr := Make_Op_Subtract (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
elsif Op_Name = Name_Op_Concat then
|
||||
Expr := Make_Op_Concat (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
Expr := Make_Op_Concat (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
elsif Op_Name = Name_Op_Multiply then
|
||||
Expr := Make_Op_Multiply (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
elsif Op_Name = Name_Op_Divide then
|
||||
Expr := Make_Op_Divide (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
Expr := Make_Op_Divide (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
elsif Op_Name = Name_Op_Mod then
|
||||
Expr := Make_Op_Mod (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
Expr := Make_Op_Mod (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
elsif Op_Name = Name_Op_Rem then
|
||||
Expr := Make_Op_Rem (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
Expr := Make_Op_Rem (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
elsif Op_Name = Name_Op_Expon then
|
||||
Expr := Make_Op_Expon (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
Expr := Make_Op_Expon (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
end if;
|
||||
|
||||
-- Unary operators
|
||||
|
||||
else
|
||||
if Op_Name = Name_Op_Add then
|
||||
Expr := Make_Op_Plus (Loc, Right_Opnd => L);
|
||||
Expr := Make_Op_Plus (Loc, Right_Opnd => L);
|
||||
elsif Op_Name = Name_Op_Subtract then
|
||||
Expr := Make_Op_Minus (Loc, Right_Opnd => L);
|
||||
elsif Op_Name = Name_Op_Abs then
|
||||
Expr := Make_Op_Abs (Loc, Right_Opnd => L);
|
||||
Expr := Make_Op_Abs (Loc, Right_Opnd => L);
|
||||
elsif Op_Name = Name_Op_Not then
|
||||
Expr := Make_Op_Not (Loc, Right_Opnd => L);
|
||||
Expr := Make_Op_Not (Loc, Right_Opnd => L);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
|
|
@ -1151,7 +1232,7 @@ package body Sem_Ch12 is
|
|||
Expression => Expr);
|
||||
|
||||
return Decl;
|
||||
end Build_Wrapper;
|
||||
end Build_Operator_Wrapper;
|
||||
|
||||
----------------------------------------
|
||||
-- Check_Overloaded_Formal_Subprogram --
|
||||
|
|
@ -1694,13 +1775,13 @@ package body Sem_Ch12 is
|
|||
|
||||
Append_To
|
||||
(Assoc,
|
||||
Build_Wrapper
|
||||
Build_Operator_Wrapper
|
||||
(Defining_Entity (Analyzed_Formal), Match));
|
||||
|
||||
else
|
||||
Append_To (Assoc,
|
||||
Instantiate_Formal_Subprogram
|
||||
(Formal, Match, Analyzed_Formal));
|
||||
Build_Function_Wrapper
|
||||
(Defining_Entity (Analyzed_Formal), Match));
|
||||
end if;
|
||||
|
||||
-- Ditto if formal is an operator with a default.
|
||||
|
|
@ -1710,15 +1791,15 @@ package body Sem_Ch12 is
|
|||
N_Defining_Operator_Symbol
|
||||
then
|
||||
Append_To (Assoc,
|
||||
Build_Wrapper
|
||||
Build_Operator_Wrapper
|
||||
(Defining_Entity (Analyzed_Formal)));
|
||||
|
||||
-- Otherwise create renaming declaration.
|
||||
|
||||
else
|
||||
Append_To (Assoc,
|
||||
Instantiate_Formal_Subprogram
|
||||
(Formal, Match, Analyzed_Formal));
|
||||
Build_Function_Wrapper
|
||||
(Defining_Entity (Analyzed_Formal)));
|
||||
end if;
|
||||
|
||||
else
|
||||
|
|
@ -9552,10 +9633,13 @@ package body Sem_Ch12 is
|
|||
|
||||
Loc := Sloc (Defining_Unit_Name (New_Spec));
|
||||
|
||||
-- Create new entity for the actual (New_Copy_Tree does not)
|
||||
-- Create new entity for the actual (New_Copy_Tree does not), and
|
||||
-- indicate that it is an actual.
|
||||
|
||||
Set_Defining_Unit_Name
|
||||
(New_Spec, Make_Defining_Identifier (Loc, Chars (Formal_Sub)));
|
||||
Set_Ekind (Defining_Unit_Name (New_Spec), Ekind (Analyzed_S));
|
||||
Set_Is_Generic_Actual_Subprogram (Defining_Unit_Name (New_Spec));
|
||||
|
||||
-- Create new entities for the each of the formals in the specification
|
||||
-- of the renaming declaration built for the actual.
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue