sem_ch11.adb (Analyze_Exception_Handlers): Add barrier to avoid the use of entity Exception_Occurrence if...
2007-04-20 Javier Miranda <miranda@adacore.com> Hristian Kirtchev <kirtchev@adacore.com> Gary Dismukes <dismukes@adacore.com> * sem_ch11.adb (Analyze_Exception_Handlers): Add barrier to avoid the use of entity Exception_Occurrence if it is not available in the target run-time. * sem_ch9.adb (Analyze_Protected_Type, Analyze_Task_Type): When concurrent types are declared within an Ada 2005 generic, build their corresponding record types since they are needed for overriding-related semantic checks. (Analyze_Protected_Type): Rearrange and simplify code for testing that a protected type does not implement a task interface or a nonlimited interface. (Analyze_Task_Type): Rearrange and simplify code for testing that a task type does not implement a protected interface or a nonlimited interface. (Single_Task_Declaration, Single_Protected_Declaration): use original entity for variable declaration, to ensure that debugging information is correcty generated. (Analyze_Protected_Type, Analyze_Task_Type): Do not call expander routines if the expander is not active. (Analyze_Task_Body): Mark all handlers to stop optimization of local raise, since special things happen for task exception handlers. * sem_disp.adb (Check_Controlling_Formals): Add type retrieval for concurrent types declared within a generic. (Check_Dispatching_Operation): Do not emit warning about late interface operations in the context of an instance. (Check_Dispatching_Call): Remove restriction against calling a dispatching operation with a limited controlling result. (Check_Dispatching_Operation): Replace calls to Fill_DT_Entry and Register_Interface_DT_Entry by calls to Register_Primitive. (Check_Dispatching_Formals): Handle properly a function with a controlling access result. From-SVN: r125448
This commit is contained in:
Javier Miranda
Arnaud Charlet
parent
fcd1d957e5
commit
8909e1edc6
3 changed files with 136 additions and 76 deletions
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
|
|
@ -30,6 +30,7 @@ with Einfo; use Einfo;
|
|||
with Errout; use Errout;
|
||||
with Lib; use Lib;
|
||||
with Lib.Xref; use Lib.Xref;
|
||||
with Namet; use Namet;
|
||||
with Nlists; use Nlists;
|
||||
with Nmake; use Nmake;
|
||||
with Opt; use Opt;
|
||||
|
|
@ -203,7 +204,7 @@ package body Sem_Ch11 is
|
|||
(E_Block, Current_Scope, Sloc (Choice), 'E');
|
||||
end if;
|
||||
|
||||
New_Scope (H_Scope);
|
||||
Push_Scope (H_Scope);
|
||||
Set_Etype (H_Scope, Standard_Void_Type);
|
||||
|
||||
-- Set the Finalization Chain entity to Error means that it
|
||||
|
|
@ -217,7 +218,11 @@ package body Sem_Ch11 is
|
|||
|
||||
Enter_Name (Choice);
|
||||
Set_Ekind (Choice, E_Variable);
|
||||
Set_Etype (Choice, RTE (RE_Exception_Occurrence));
|
||||
|
||||
if RTE_Available (RE_Exception_Occurrence) then
|
||||
Set_Etype (Choice, RTE (RE_Exception_Occurrence));
|
||||
end if;
|
||||
|
||||
Generate_Definition (Choice);
|
||||
|
||||
-- Set source assigned flag, since in effect this field is
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
|
|
@ -33,6 +33,7 @@ with Elists; use Elists;
|
|||
with Freeze; use Freeze;
|
||||
with Itypes; use Itypes;
|
||||
with Lib.Xref; use Lib.Xref;
|
||||
with Namet; use Namet;
|
||||
with Nlists; use Nlists;
|
||||
with Nmake; use Nmake;
|
||||
with Opt; use Opt;
|
||||
|
|
@ -53,6 +54,7 @@ with Snames; use Snames;
|
|||
with Stand; use Stand;
|
||||
with Sinfo; use Sinfo;
|
||||
with Style;
|
||||
with Targparm; use Targparm;
|
||||
with Tbuild; use Tbuild;
|
||||
with Uintp; use Uintp;
|
||||
|
||||
|
|
@ -259,7 +261,7 @@ package body Sem_Ch9 is
|
|||
Set_Accept_Address (Accept_Id, New_Elmt_List);
|
||||
|
||||
if Present (Formals) then
|
||||
New_Scope (Accept_Id);
|
||||
Push_Scope (Accept_Id);
|
||||
Process_Formals (Formals, N);
|
||||
Create_Extra_Formals (Accept_Id);
|
||||
End_Scope;
|
||||
|
|
@ -418,7 +420,7 @@ package body Sem_Ch9 is
|
|||
-- Analyze statements if present
|
||||
|
||||
if Present (Stats) then
|
||||
New_Scope (Entry_Nam);
|
||||
Push_Scope (Entry_Nam);
|
||||
Install_Declarations (Entry_Nam);
|
||||
|
||||
Set_Actual_Subtypes (N, Current_Scope);
|
||||
|
|
@ -571,7 +573,6 @@ package body Sem_Ch9 is
|
|||
|
||||
procedure Analyze_Delay_Relative (N : Node_Id) is
|
||||
E : constant Node_Id := Expression (N);
|
||||
|
||||
begin
|
||||
Check_Restriction (No_Relative_Delay, N);
|
||||
Tasking_Used := True;
|
||||
|
|
@ -730,7 +731,7 @@ package body Sem_Ch9 is
|
|||
end if;
|
||||
|
||||
Exp_Ch9.Expand_Entry_Barrier (N, Entry_Name);
|
||||
New_Scope (Entry_Name);
|
||||
Push_Scope (Entry_Name);
|
||||
|
||||
Exp_Ch9.Expand_Entry_Body_Declarations (N);
|
||||
Install_Declarations (Entry_Name);
|
||||
|
|
@ -847,7 +848,7 @@ package body Sem_Ch9 is
|
|||
|
||||
if Present (Formals) then
|
||||
Set_Scope (Id, Current_Scope);
|
||||
New_Scope (Id);
|
||||
Push_Scope (Id);
|
||||
Process_Formals (Formals, Parent (N));
|
||||
End_Scope;
|
||||
end if;
|
||||
|
|
@ -912,7 +913,7 @@ package body Sem_Ch9 is
|
|||
|
||||
if Present (Formals) then
|
||||
Set_Scope (Id, Current_Scope);
|
||||
New_Scope (Id);
|
||||
Push_Scope (Id);
|
||||
Process_Formals (Formals, N);
|
||||
Create_Extra_Formals (Id);
|
||||
End_Scope;
|
||||
|
|
@ -961,7 +962,7 @@ package body Sem_Ch9 is
|
|||
|
||||
Set_Ekind (Loop_Id, E_Loop);
|
||||
Set_Scope (Loop_Id, Current_Scope);
|
||||
New_Scope (Loop_Id);
|
||||
Push_Scope (Loop_Id);
|
||||
Enter_Name (Iden);
|
||||
Set_Ekind (Iden, E_Entry_Index_Parameter);
|
||||
Set_Etype (Iden, Etype (Def));
|
||||
|
|
@ -1018,7 +1019,7 @@ package body Sem_Ch9 is
|
|||
Spec_Id := Etype (Spec_Id);
|
||||
end if;
|
||||
|
||||
New_Scope (Spec_Id);
|
||||
Push_Scope (Spec_Id);
|
||||
Set_Corresponding_Spec (N, Spec_Id);
|
||||
Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
|
||||
Set_Has_Completion (Spec_Id);
|
||||
|
|
@ -1127,7 +1128,7 @@ package body Sem_Ch9 is
|
|||
Set_Etype (T, T);
|
||||
Set_Has_Delayed_Freeze (T, True);
|
||||
Set_Stored_Constraint (T, No_Elist);
|
||||
New_Scope (T);
|
||||
Push_Scope (T);
|
||||
|
||||
-- Ada 2005 (AI-345)
|
||||
|
||||
|
|
@ -1149,19 +1150,15 @@ package body Sem_Ch9 is
|
|||
Freeze_Before (N, Etype (Iface));
|
||||
|
||||
-- Ada 2005 (AI-345): Protected types can only implement
|
||||
-- limited, synchronized or protected interfaces.
|
||||
-- limited, synchronized, or protected interfaces (note that
|
||||
-- the predicate Is_Limited_Interface includes synchronized
|
||||
-- and protected interfaces).
|
||||
|
||||
if Is_Limited_Interface (Iface_Typ)
|
||||
or else Is_Protected_Interface (Iface_Typ)
|
||||
or else Is_Synchronized_Interface (Iface_Typ)
|
||||
then
|
||||
null;
|
||||
|
||||
elsif Is_Task_Interface (Iface_Typ) then
|
||||
if Is_Task_Interface (Iface_Typ) then
|
||||
Error_Msg_N ("(Ada 2005) protected type cannot implement a "
|
||||
& "task interface", Iface);
|
||||
|
||||
else
|
||||
elsif not Is_Limited_Interface (Iface_Typ) then
|
||||
Error_Msg_N ("(Ada 2005) protected type cannot implement a "
|
||||
& "non-limited interface", Iface);
|
||||
end if;
|
||||
|
|
@ -1214,6 +1211,17 @@ package body Sem_Ch9 is
|
|||
|
||||
Set_Is_Constrained (T, not Has_Discriminants (T));
|
||||
|
||||
-- Perform minimal expansion of the protected type while inside of a
|
||||
-- generic. The corresponding record is needed for various semantic
|
||||
-- checks.
|
||||
|
||||
if Ada_Version >= Ada_05
|
||||
and then Inside_A_Generic
|
||||
then
|
||||
Insert_After_And_Analyze (N,
|
||||
Build_Corresponding_Record (N, T, Sloc (T)));
|
||||
end if;
|
||||
|
||||
Analyze (Protected_Definition (N));
|
||||
|
||||
-- Protected types with entries are controlled (because of the
|
||||
|
|
@ -1264,8 +1272,10 @@ package body Sem_Ch9 is
|
|||
-- may be subtypes of the partial view. Skip if errors are present,
|
||||
-- to prevent cascaded messages.
|
||||
|
||||
if Serious_Errors_Detected = 0 then
|
||||
Exp_Ch9.Expand_N_Protected_Type_Declaration (N);
|
||||
if Serious_Errors_Detected = 0
|
||||
and then Expander_Active
|
||||
then
|
||||
Expand_N_Protected_Type_Declaration (N);
|
||||
Process_Full_View (N, T, Def_Id);
|
||||
end if;
|
||||
end if;
|
||||
|
|
@ -1444,6 +1454,13 @@ package body Sem_Ch9 is
|
|||
Generate_Reference (Entry_Id, Entry_Name);
|
||||
|
||||
if Present (First_Formal (Entry_Id)) then
|
||||
if VM_Target = JVM_Target then
|
||||
Error_Msg_N
|
||||
("arguments unsupported in requeue statement",
|
||||
First_Formal (Entry_Id));
|
||||
return;
|
||||
end if;
|
||||
|
||||
Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N));
|
||||
|
||||
-- Processing for parameters accessed by the requeue
|
||||
|
|
@ -1613,7 +1630,7 @@ package body Sem_Ch9 is
|
|||
T : Entity_Id;
|
||||
T_Decl : Node_Id;
|
||||
O_Decl : Node_Id;
|
||||
O_Name : constant Entity_Id := New_Copy (Id);
|
||||
O_Name : constant Entity_Id := Id;
|
||||
|
||||
begin
|
||||
Generate_Definition (Id);
|
||||
|
|
@ -1669,7 +1686,7 @@ package body Sem_Ch9 is
|
|||
T : Entity_Id;
|
||||
T_Decl : Node_Id;
|
||||
O_Decl : Node_Id;
|
||||
O_Name : constant Entity_Id := New_Copy (Id);
|
||||
O_Name : constant Entity_Id := Id;
|
||||
|
||||
begin
|
||||
Generate_Definition (Id);
|
||||
|
|
@ -1688,6 +1705,14 @@ package body Sem_Ch9 is
|
|||
Task_Definition => Relocate_Node (Task_Definition (N)),
|
||||
Interface_List => Interface_List (N));
|
||||
|
||||
-- We use the original defining identifier of the single task in the
|
||||
-- generated object declaration, so that debugging information can
|
||||
-- be attached to it when compiling with -gnatD. The parent of the
|
||||
-- entity is the new object declaration. The single_task_declaration
|
||||
-- is not used further in semantics or code generation, but is scanned
|
||||
-- when generating debug information, and therefore needs the updated
|
||||
-- Sloc information for the entity (see Sprint).
|
||||
|
||||
O_Decl :=
|
||||
Make_Object_Declaration (Loc,
|
||||
Defining_Identifier => O_Name,
|
||||
|
|
@ -1721,6 +1746,7 @@ package body Sem_Ch9 is
|
|||
|
||||
procedure Analyze_Task_Body (N : Node_Id) is
|
||||
Body_Id : constant Entity_Id := Defining_Identifier (N);
|
||||
HSS : constant Node_Id := Handled_Statement_Sequence (N);
|
||||
Last_E : Entity_Id;
|
||||
|
||||
Spec_Id : Entity_Id;
|
||||
|
|
@ -1779,7 +1805,7 @@ package body Sem_Ch9 is
|
|||
Spec_Id := Etype (Spec_Id);
|
||||
end if;
|
||||
|
||||
New_Scope (Spec_Id);
|
||||
Push_Scope (Spec_Id);
|
||||
Set_Corresponding_Spec (N, Spec_Id);
|
||||
Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
|
||||
Set_Has_Completion (Spec_Id);
|
||||
|
|
@ -1800,7 +1826,24 @@ package body Sem_Ch9 is
|
|||
end if;
|
||||
end if;
|
||||
|
||||
Analyze (Handled_Statement_Sequence (N));
|
||||
-- Mark all handlers as not suitable for local raise optimization,
|
||||
-- since this optimization causes difficulties in a task context.
|
||||
|
||||
if Present (Exception_Handlers (HSS)) then
|
||||
declare
|
||||
Handlr : Node_Id;
|
||||
begin
|
||||
Handlr := First (Exception_Handlers (HSS));
|
||||
while Present (Handlr) loop
|
||||
Set_Local_Raise_Not_OK (Handlr);
|
||||
Next (Handlr);
|
||||
end loop;
|
||||
end;
|
||||
end if;
|
||||
|
||||
-- Now go ahead and complete analysis of the task body
|
||||
|
||||
Analyze (HSS);
|
||||
Check_Completion (Body_Id);
|
||||
Check_References (Body_Id);
|
||||
Check_References (Spec_Id);
|
||||
|
|
@ -1824,7 +1867,7 @@ package body Sem_Ch9 is
|
|||
end loop;
|
||||
end;
|
||||
|
||||
Process_End_Label (Handled_Statement_Sequence (N), 't', Ref_Id);
|
||||
Process_End_Label (HSS, 't', Ref_Id);
|
||||
End_Scope;
|
||||
end Analyze_Task_Body;
|
||||
|
||||
|
|
@ -1887,7 +1930,7 @@ package body Sem_Ch9 is
|
|||
Set_Etype (T, T);
|
||||
Set_Has_Delayed_Freeze (T, True);
|
||||
Set_Stored_Constraint (T, No_Elist);
|
||||
New_Scope (T);
|
||||
Push_Scope (T);
|
||||
|
||||
-- Ada 2005 (AI-345)
|
||||
|
||||
|
|
@ -1909,19 +1952,15 @@ package body Sem_Ch9 is
|
|||
Freeze_Before (N, Etype (Iface));
|
||||
|
||||
-- Ada 2005 (AI-345): Task types can only implement limited,
|
||||
-- synchronized or task interfaces.
|
||||
-- synchronized, or task interfaces (note that the predicate
|
||||
-- Is_Limited_Interface includes synchronized and task
|
||||
-- interfaces).
|
||||
|
||||
if Is_Limited_Interface (Iface_Typ)
|
||||
or else Is_Synchronized_Interface (Iface_Typ)
|
||||
or else Is_Task_Interface (Iface_Typ)
|
||||
then
|
||||
null;
|
||||
|
||||
elsif Is_Protected_Interface (Iface_Typ) then
|
||||
if Is_Protected_Interface (Iface_Typ) then
|
||||
Error_Msg_N ("(Ada 2005) task type cannot implement a " &
|
||||
"protected interface", Iface);
|
||||
|
||||
else
|
||||
elsif not Is_Limited_Interface (Iface_Typ) then
|
||||
Error_Msg_N ("(Ada 2005) task type cannot implement a " &
|
||||
"non-limited interface", Iface);
|
||||
end if;
|
||||
|
|
@ -1978,6 +2017,15 @@ package body Sem_Ch9 is
|
|||
|
||||
Set_Is_Constrained (T, not Has_Discriminants (T));
|
||||
|
||||
-- Perform minimal expansion of the task type while inside a generic
|
||||
-- context. The corresponding record is needed for various semantic
|
||||
-- checks.
|
||||
|
||||
if Inside_A_Generic then
|
||||
Insert_After_And_Analyze (N,
|
||||
Build_Corresponding_Record (N, T, Sloc (T)));
|
||||
end if;
|
||||
|
||||
if Present (Task_Definition (N)) then
|
||||
Analyze_Task_Definition (Task_Definition (N));
|
||||
end if;
|
||||
|
|
@ -2006,8 +2054,10 @@ package body Sem_Ch9 is
|
|||
-- may be subtypes of the partial view. Skip if errors are present,
|
||||
-- to prevent cascaded messages.
|
||||
|
||||
if Serious_Errors_Detected = 0 then
|
||||
Exp_Ch9.Expand_N_Task_Type_Declaration (N);
|
||||
if Serious_Errors_Detected = 0
|
||||
and then Expander_Active
|
||||
then
|
||||
Expand_N_Task_Type_Declaration (N);
|
||||
Process_Full_View (N, T, Def_Id);
|
||||
end if;
|
||||
end if;
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
|
|
@ -29,11 +29,10 @@ with Debug; use Debug;
|
|||
with Elists; use Elists;
|
||||
with Einfo; use Einfo;
|
||||
with Exp_Disp; use Exp_Disp;
|
||||
with Exp_Ch6; use Exp_Ch6;
|
||||
with Exp_Ch7; use Exp_Ch7;
|
||||
with Exp_Tss; use Exp_Tss;
|
||||
with Errout; use Errout;
|
||||
with Hostparm; use Hostparm;
|
||||
with Namet; use Namet;
|
||||
with Nlists; use Nlists;
|
||||
with Nmake; use Nmake;
|
||||
with Opt; use Opt;
|
||||
|
|
@ -48,6 +47,7 @@ with Sem_Util; use Sem_Util;
|
|||
with Snames; use Snames;
|
||||
with Stand; use Stand;
|
||||
with Sinfo; use Sinfo;
|
||||
with Targparm; use Targparm;
|
||||
with Tbuild; use Tbuild;
|
||||
with Uintp; use Uintp;
|
||||
|
||||
|
|
@ -102,6 +102,17 @@ package body Sem_Disp is
|
|||
Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
|
||||
|
||||
if Present (Ctrl_Type) then
|
||||
|
||||
-- When the controlling type is concurrent and declared within a
|
||||
-- generic or inside an instance, use its corresponding record
|
||||
-- type.
|
||||
|
||||
if Is_Concurrent_Type (Ctrl_Type)
|
||||
and then Present (Corresponding_Record_Type (Ctrl_Type))
|
||||
then
|
||||
Ctrl_Type := Corresponding_Record_Type (Ctrl_Type);
|
||||
end if;
|
||||
|
||||
if Ctrl_Type = Typ then
|
||||
Set_Is_Controlling_Formal (Formal);
|
||||
|
||||
|
|
@ -162,8 +173,17 @@ package body Sem_Disp is
|
|||
Set_Has_Controlling_Result (Subp);
|
||||
|
||||
-- Check that result subtype statically matches first subtype
|
||||
-- (Ada 2005) : Subp may have a controlling access result.
|
||||
|
||||
if not Subtypes_Statically_Match (Typ, Etype (Subp)) then
|
||||
if Subtypes_Statically_Match (Typ, Etype (Subp))
|
||||
or else (Ekind (Etype (Subp)) = E_Anonymous_Access_Type
|
||||
and then
|
||||
Subtypes_Statically_Match
|
||||
(Typ, Designated_Type (Etype (Subp))))
|
||||
then
|
||||
null;
|
||||
|
||||
else
|
||||
Error_Msg_N
|
||||
("result subtype does not match controlling type", Subp);
|
||||
end if;
|
||||
|
|
@ -257,12 +277,12 @@ package body Sem_Disp is
|
|||
----------------------------
|
||||
|
||||
procedure Check_Dispatching_Call (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Actual : Node_Id;
|
||||
Formal : Entity_Id;
|
||||
Control : Node_Id := Empty;
|
||||
Func : Entity_Id;
|
||||
Subp_Entity : Entity_Id;
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Indeterm_Ancestor_Call : Boolean := False;
|
||||
Indeterm_Ctrl_Type : Entity_Id;
|
||||
|
||||
|
|
@ -436,25 +456,6 @@ package body Sem_Disp is
|
|||
Set_Controlling_Argument (N, Control);
|
||||
Check_Restriction (No_Dispatching_Calls, N);
|
||||
|
||||
-- Ada 2005 (AI-318-02): Check current implementation restriction
|
||||
-- that a dispatching call cannot be made to a primitive function
|
||||
-- with a limited result type. This restriction can be removed
|
||||
-- once calls to limited functions with class-wide results are
|
||||
-- supported. ???
|
||||
|
||||
if Ada_Version = Ada_05
|
||||
and then Nkind (N) = N_Function_Call
|
||||
then
|
||||
Func := Entity (Name (N));
|
||||
|
||||
if Has_Controlling_Result (Func)
|
||||
and then Is_Limited_Type (Etype (Func))
|
||||
then
|
||||
Error_Msg_N ("(Ada 2005) limited function call in this" &
|
||||
" context is not yet implemented", N);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
else
|
||||
-- The call is not dispatching, so check that there aren't any
|
||||
-- tag-indeterminate abstract calls left.
|
||||
|
|
@ -479,7 +480,7 @@ package body Sem_Disp is
|
|||
Func := Empty;
|
||||
|
||||
-- Only other possibility is a qualified expression whose
|
||||
-- consituent expression is itself a call.
|
||||
-- constituent expression is itself a call.
|
||||
|
||||
else
|
||||
Func :=
|
||||
|
|
@ -596,6 +597,7 @@ package body Sem_Disp is
|
|||
and then Is_Interface (Typ)
|
||||
and then not Is_Derived_Type (Typ)
|
||||
and then not Is_Generic_Type (Typ)
|
||||
and then not In_Instance
|
||||
then
|
||||
Error_Msg_N ("?declaration of& is too late!", Subp);
|
||||
Error_Msg_NE
|
||||
|
|
@ -738,8 +740,9 @@ package body Sem_Disp is
|
|||
Set_DT_Position (Subp, DT_Position (Old_Subp));
|
||||
|
||||
if not Restriction_Active (No_Dispatching_Calls) then
|
||||
Insert_After (Subp_Body,
|
||||
Fill_DT_Entry (Sloc (Subp_Body), Subp));
|
||||
Register_Primitive (Sloc (Subp_Body),
|
||||
Prim => Subp,
|
||||
Ins_Nod => Subp_Body);
|
||||
end if;
|
||||
end if;
|
||||
end if;
|
||||
|
|
@ -752,7 +755,7 @@ package body Sem_Disp is
|
|||
Subp);
|
||||
end if;
|
||||
|
||||
-- If the type is not frozen yet and we are not in the overridding
|
||||
-- If the type is not frozen yet and we are not in the overriding
|
||||
-- case it looks suspiciously like an attempt to define a primitive
|
||||
-- operation.
|
||||
|
||||
|
|
@ -769,7 +772,7 @@ package body Sem_Disp is
|
|||
end if;
|
||||
|
||||
-- Now, we are sure that the scope is a package spec. If the subprogram
|
||||
-- is declared after the freezing point ot the type that's an error
|
||||
-- is declared after the freezing point of the type that's an error
|
||||
|
||||
elsif Is_Frozen (Tagged_Type) and then not Has_Dispatching_Parent then
|
||||
Error_Msg_N ("this primitive operation is declared too late", Subp);
|
||||
|
|
@ -819,13 +822,15 @@ package body Sem_Disp is
|
|||
and then Present (Abstract_Interface_Alias (Prim))
|
||||
and then Alias (Prim) = Subp
|
||||
then
|
||||
Register_Interface_DT_Entry (Subp_Body, Prim);
|
||||
Register_Primitive (Sloc (Prim),
|
||||
Prim => Prim,
|
||||
Ins_Nod => Subp_Body);
|
||||
end if;
|
||||
|
||||
Next_Elmt (Elmt);
|
||||
end loop;
|
||||
|
||||
-- Redisplay the contents of the updated dispatch table.
|
||||
-- Redisplay the contents of the updated dispatch table
|
||||
|
||||
if Debug_Flag_ZZ then
|
||||
Write_Str ("Late overriding: ");
|
||||
|
|
@ -1322,7 +1327,7 @@ package body Sem_Disp is
|
|||
and then Has_Abstract_Interfaces (Tagged_Type)
|
||||
then
|
||||
-- Ada 2005 (AI-251): Update the attribute alias of all the aliased
|
||||
-- entities of the overriden primitive to reference New_Op, and also
|
||||
-- entities of the overridden primitive to reference New_Op, and also
|
||||
-- propagate them the new value of the attribute
|
||||
-- Is_Abstract_Subprogram.
|
||||
|
||||
|
|
@ -1429,11 +1434,11 @@ package body Sem_Disp is
|
|||
Next_Actual (Arg);
|
||||
end loop;
|
||||
|
||||
-- Expansion of dispatching calls is suppressed when Java_VM, because
|
||||
-- the JVM back end directly handles the generation of dispatching
|
||||
-- Expansion of dispatching calls is suppressed when VM_Target, because
|
||||
-- the VM back-ends directly handle the generation of dispatching
|
||||
-- calls and would have to undo any expansion to an indirect call.
|
||||
|
||||
if not Java_VM then
|
||||
if VM_Target = No_VM then
|
||||
Expand_Dispatching_Call (Call_Node);
|
||||
end if;
|
||||
end Propagate_Tag;
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue