-- --
-- 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- --
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;
with Stand; use Stand;
with Sinfo; use Sinfo;
with Style;
+with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
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;
-- 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);
procedure Analyze_Delay_Relative (N : Node_Id) is
E : constant Node_Id := Expression (N);
-
begin
Check_Restriction (No_Relative_Delay, N);
Tasking_Used := True;
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);
if Present (Formals) then
Set_Scope (Id, Current_Scope);
- New_Scope (Id);
+ Push_Scope (Id);
Process_Formals (Formals, Parent (N));
End_Scope;
end if;
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;
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));
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);
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)
Freeze_Before (N, Etype (Iface));
-- Ada 2005 (AI-345): Protected types can only implement
- -- limited, synchronized or protected interfaces.
-
- if Is_Limited_Interface (Iface_Typ)
- or else Is_Protected_Interface (Iface_Typ)
- or else Is_Synchronized_Interface (Iface_Typ)
- then
- null;
+ -- limited, synchronized, or protected interfaces (note that
+ -- the predicate Is_Limited_Interface includes synchronized
+ -- and protected interfaces).
- 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;
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
-- 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;
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
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);
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);
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,
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;
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);
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);
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;
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)
Freeze_Before (N, Etype (Iface));
-- Ada 2005 (AI-345): Task types can only implement limited,
- -- synchronized or task interfaces.
-
- if Is_Limited_Interface (Iface_Typ)
- or else Is_Synchronized_Interface (Iface_Typ)
- or else Is_Task_Interface (Iface_Typ)
- then
- null;
+ -- synchronized, or task interfaces (note that the predicate
+ -- Is_Limited_Interface includes synchronized and task
+ -- interfaces).
- 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;
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;
-- 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;
-- --
-- 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- --
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;
with Snames; use Snames;
with Stand; use Stand;
with Sinfo; use Sinfo;
+with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
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);
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;
----------------------------
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;
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.
Func := Empty;
-- Only other possibility is a qualified expression whose
- -- consituent expression is itself a call.
+ -- constituent expression is itself a call.
else
Func :=
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
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;
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.
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);
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: ");
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.
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;
projects / gcc.git / commitdiff