Skip to content

R
riscv-gcc-1
Commit 8909e1ed by Javier Miranda Committed by Arnaud Charlet
Options

sem_ch11.adb (Analyze_Exception_Handlers): Add barrier to avoid the use of… 

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
parent fcd1d957
Showing with 136 additions and 76 deletions
gcc/ada/sem_ch11.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- --
......@@ -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
......
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;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment