diff options
author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2007-06-06 10:42:51 +0000 |
---|---|---|
committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2007-06-06 10:42:51 +0000 |
commit | 6340e5ccdbe8addbcc54aacd5d8c0507a6be8b03 (patch) | |
tree | 95320bf40d77c808dfc41813047ea6378aa5413e /gcc/ada/sem_disp.adb | |
parent | f49f70c601bb9894863330a4b61c1490223c81bc (diff) | |
download | gcc-6340e5ccdbe8addbcc54aacd5d8c0507a6be8b03.tar.gz |
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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@125448 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada/sem_disp.adb')
-rw-r--r-- | gcc/ada/sem_disp.adb | 75 |
1 files changed, 40 insertions, 35 deletions
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 5d81004dace..3b2a18ad3b1 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -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; |