-- --
-- 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 Exp_Util; use Exp_Util;
with Fname; use Fname;
with Freeze; use Freeze;
-with Hostparm; use Hostparm;
with Inline; use Inline;
with Lib; use Lib;
+with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
+with Targparm; use Targparm;
with Tbuild; use Tbuild;
-with Ttypes; use Ttypes;
with Uintp; use Uintp;
with Validsw; use Validsw;
procedure Add_Final_List_Actual_To_Build_In_Place_Call
(Function_Call : Node_Id;
- Function_Id : Entity_Id);
+ Function_Id : Entity_Id;
+ Acc_Type : Entity_Id);
-- Ada 2005 (AI-318-02): For a build-in-place call, if the result type has
- -- controlled parts, add an actual parameter that is a pointer to caller's
- -- finalization list.
+ -- controlled parts, add an actual parameter that is a pointer to
+ -- appropriate finalization list. The finalization list is that of the
+ -- current scope, except for "new Acc'(F(...))" in which case it's the
+ -- finalization list of the access type returned by the allocator. Acc_Type
+ -- is that type in the allocator case; Empty otherwise.
procedure Add_Task_Actuals_To_Build_In_Place_Call
(Function_Call : Node_Id;
if not Present (Return_Object) then
Obj_Address := Make_Null (Loc);
+ Set_Parent (Obj_Address, Function_Call);
-- If Return_Object is already an expression of an access type, then use
-- it directly, since it must be an access value denoting the return
elsif Is_Access then
Obj_Address := Return_Object;
+ Set_Parent (Obj_Address, Function_Call);
-- Apply Unrestricted_Access to caller's return object
Make_Attribute_Reference (Loc,
Prefix => Return_Object,
Attribute_Name => Name_Unrestricted_Access);
+
+ Set_Parent (Return_Object, Obj_Address);
+ Set_Parent (Obj_Address, Function_Call);
end if;
Analyze_And_Resolve (Obj_Address, Etype (Obj_Acc_Formal));
Alloc_Form_Formal : Node_Id;
begin
+ -- The allocation form generally doesn't need to be passed in the case
+ -- of a constrained result subtype, since normally the caller performs
+ -- the allocation in that case. However this formal is still needed in
+ -- the case where the function has a tagged result, because generally
+ -- such functions can be called in a dispatching context and such calls
+ -- must be handled like calls to class-wide functions.
+
+ if Is_Constrained (Underlying_Type (Etype (Function_Id)))
+ and then not Is_Tagged_Type (Underlying_Type (Etype (Function_Id)))
+ then
+ return;
+ end if;
+
-- Locate the implicit allocation form parameter in the called function.
-- Maybe it would be better for each implicit formal of a build-in-place
-- function to have a flag or a Uint attribute to identify it. ???
procedure Add_Final_List_Actual_To_Build_In_Place_Call
(Function_Call : Node_Id;
- Function_Id : Entity_Id)
+ Function_Id : Entity_Id;
+ Acc_Type : Entity_Id)
is
Loc : constant Source_Ptr := Sloc (Function_Call);
Final_List : Node_Id;
Final_List_Formal : Node_Id;
begin
- -- No such extra parameter is needed if there are no controlled parts
-
- if not (Is_Controlled (Etype (Function_Id))
- or else Has_Controlled_Component (Etype (Function_Id))) then
+ -- No such extra parameter is needed if there are no controlled parts.
+ -- The test for Controlled_Type accounts for class-wide results (which
+ -- potentially have controlled parts, even if the root type doesn't),
+ -- and the test for a tagged result type is needed because calls to
+ -- such a function can in general occur in dispatching contexts, which
+ -- must be treated the same as a call to class-wide functions. Both of
+ -- these situations require that a finalization list be passed.
+
+ if not Controlled_Type (Underlying_Type (Etype (Function_Id)))
+ and then not Is_Tagged_Type (Underlying_Type (Etype (Function_Id)))
+ then
return;
end if;
Final_List_Formal := Build_In_Place_Formal (Function_Id, BIP_Final_List);
- -- Create the actual which is a pointer to the current finalization list
+ -- Create the actual which is a pointer to the appropriate finalization
+ -- list. Acc_Type is present if and only if this call is the
+ -- initialization of an allocator. Use the Current_Scope or the Acc_Type
+ -- as appropriate.
+
+ if Present (Acc_Type)
+ and then (Ekind (Acc_Type) = E_Anonymous_Access_Type
+ or else
+ Present (Associated_Final_Chain (Base_Type (Acc_Type))))
+ then
+ Final_List := Find_Final_List (Acc_Type);
+ else
+ Final_List := Find_Final_List (Current_Scope);
+ end if;
- Final_List := Find_Final_List (Current_Scope);
Final_List_Actual :=
Make_Attribute_Reference (Loc,
Prefix => Final_List,
Chars (Extra_Formal) =
New_External_Name (Chars (Func), BIP_Formal_Suffix (Kind));
Next_Formal_With_Extras (Extra_Formal);
+ pragma Assert (Present (Extra_Formal));
end loop;
- pragma Assert (Present (Extra_Formal));
return Extra_Formal;
end Build_In_Place_Formal;
-- Push our current scope for analyzing the declarations and code that
-- we will insert for the checking.
- New_Scope (Spec);
+ Push_Scope (Spec);
-- This loop builds temporary variables for each of the referenced
-- globals, so that at the end of the loop the list Shad_List contains
return False;
-- For users of Starlet, we assume that the specification of by-
- -- reference mechanism is mandatory. This may lead to unligned
+ -- reference mechanism is mandatory. This may lead to unaligned
-- objects but at least for DEC legacy code it is known to work.
-- The warning will alert users of this code that a problem may
-- be lurking.
elsif Is_Possibly_Unaligned_Slice (Actual) then
Add_Call_By_Copy_Code;
- -- Deal with access types where the actual subtpe and the
+ -- Deal with access types where the actual subtype and the
-- formal subtype are not the same, requiring a check.
-- It is necessary to exclude tagged types because of "downward
Gen_Par := Generic_Parent_Type (Parent (Par));
end if;
+ -- If the actual has no generic parent type, the formal is not
+ -- a formal derived type, so nothing to inherit.
+
+ if No (Gen_Par) then
+ return Empty;
+ end if;
+
-- If the generic parent type is still the generic type, this is a
-- private formal, not a derived formal, and there are no operations
-- inherited from the formal.
-- if we can tell that the first parameter cannot possibly be null.
-- This helps optimization and also generation of warnings.
- if not Restriction_Active (No_Exception_Handlers)
- and then Is_RTE (Subp, RE_Raise_Exception)
+ -- We do not do this if Raise_Exception_Always does not exist, which
+ -- can happen in configurable run time profiles which provide only a
+ -- Raise_Exception, which is in fact an unconditional raise anyway.
+
+ if Is_RTE (Subp, RE_Raise_Exception)
+ and then RTE_Available (RE_Raise_Exception_Always)
then
declare
FA : constant Node_Id := Original_Node (First_Actual (N));
and then Attribute_Name (FA) = Name_Identity
then
Subp := RTE (RE_Raise_Exception_Always);
- Set_Entity (Name (N), Subp);
+ Set_Name (N, New_Occurrence_Of (Subp, Loc));
end if;
end;
end if;
Prev := Actual;
Prev_Orig := Original_Node (Prev);
+ -- The original actual may have been a call written in prefix
+ -- form, and rewritten before analysis.
+
if not Analyzed (Prev_Orig)
- and then Nkind (Actual) = N_Function_Call
+ and then
+ (Nkind (Actual) = N_Function_Call
+ or else
+ Nkind (Actual) = N_Identifier)
then
Prev_Orig := Prev;
end if;
-- Create possible extra actual for accessibility level
if Present (Extra_Accessibility (Formal)) then
+
+ -- Ada 2005 (AI-252): If the actual was rewritten as an Access
+ -- attribute, then the original actual may be an aliased object
+ -- occurring as the prefix in a call using "Object.Operation"
+ -- notation. In that case we must pass the level of the object,
+ -- so Prev_Orig is reset to Prev and the attribute will be
+ -- processed by the code for Access attributes further below.
+
+ if Prev_Orig /= Prev
+ and then Nkind (Prev) = N_Attribute_Reference
+ and then
+ Get_Attribute_Id (Attribute_Name (Prev)) = Attribute_Access
+ and then Is_Aliased_View (Prev_Orig)
+ then
+ Prev_Orig := Prev;
+ end if;
+
if Is_Entity_Name (Prev_Orig) then
-- When passing an access parameter as the actual to another
end if;
end;
- -- The actual is a normal access value, so just pass the
- -- level of the actual's access type.
+ -- The actual is a normal access value, so just pass the level
+ -- of the actual's access type.
else
Add_Extra_Actual
null;
-- Suppress null checks when passing to access parameters of Java
- -- subprograms. (Should this be done for other foreign conventions
- -- as well ???)
+ -- and CIL subprograms. (Should this be done for other foreign
+ -- conventions as well ???)
- elsif Convention (Subp) = Convention_Java then
+ elsif Convention (Subp) = Convention_Java
+ or else Convention (Subp) = Convention_CIL
+ then
null;
else
(Ekind (Formal) = E_In_Out_Parameter
and then Validity_Check_In_Out_Params)
then
- -- If the actual is an indexed component of a packed
- -- type, it has not been expanded yet. It will be
- -- copied in the validity code that follows, and has
- -- to be expanded appropriately, so reanalyze it.
+ -- If the actual is an indexed component of a packed type (or
+ -- is an indexed or selected component whose prefix recursively
+ -- meets this condition), it has not been expanded yet. It will
+ -- be copied in the validity code that follows, and has to be
+ -- expanded appropriately, so reanalyze it.
- if Nkind (Actual) = N_Indexed_Component then
- Set_Analyzed (Actual, False);
- end if;
+ -- What we do is just to unset analyzed bits on prefixes till
+ -- we reach something that does not have a prefix.
+
+ declare
+ Nod : Node_Id;
+
+ begin
+ Nod := Actual;
+ while Nkind (Nod) = N_Indexed_Component
+ or else
+ Nkind (Nod) = N_Selected_Component
+ loop
+ Set_Analyzed (Nod, False);
+ Nod := Prefix (Nod);
+ end loop;
+ end;
Ensure_Valid (Actual);
end if;
-- In a remote call, if the formal is of a class-wide type, check
-- that the actual meets the requirements described in E.4(18).
- if Remote
- and then Is_Class_Wide_Type (Etype (Formal))
- then
+ if Remote and then Is_Class_Wide_Type (Etype (Formal)) then
Insert_Action (Actual,
- Make_Implicit_If_Statement (N,
- Condition =>
- Make_Op_Not (Loc,
- Build_Get_Remotely_Callable (Loc,
- Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr_Move_Checks (Actual),
- Selector_Name =>
- Make_Identifier (Loc, Name_uTag)))),
- Then_Statements => New_List (
- Make_Raise_Program_Error (Loc,
- Reason => PE_Illegal_RACW_E_4_18))));
+ Make_Transportable_Check (Loc,
+ Duplicate_Subexpr_Move_Checks (Actual)));
end if;
-- This label is required when skipping extra actual generation for
-- extra actuals since this will be done on the re-analysis of the
-- dispatching call. Note that we do not try to shorten the actual
-- list for a dispatching call, it would not make sense to do so.
- -- 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 (Nkind (N) = N_Function_Call
or else Nkind (N) = N_Procedure_Call_Statement)
and then Present (Controlling_Argument (N))
- and then not Java_VM
+ and then VM_Target = No_VM
then
Expand_Dispatching_Call (N);
end if;
-- Functions returning controlled objects need special attention
+ -- If the return type is limited the context is an initialization
+ -- and different processing applies.
if Controlled_Type (Etype (Subp))
and then not Is_Inherently_Limited_Type (Etype (Subp))
+ and then not Is_Limited_Interface (Etype (Subp))
then
Expand_Ctrl_Function_Call (N);
end if;
Temp : Node_Id;
Passoc : Node_Id;
- Discard : Node_Id;
- pragma Warnings (Off, Discard);
-
begin
-- First step, remove all the named parameters from the
-- list (they are still chained using First_Named_Actual
end loop;
while Present (Next (Temp)) loop
- Discard := Remove_Next (Temp);
+ Remove (Next (Temp));
end loop;
end if;
-- parameter to Raise_Exception is a use of Identity, since in these
-- cases we know that the parameter is never null.
+ -- Note: We must check that the node has not been inlined. This is
+ -- required because under zfp the Raise_Exception subprogram has the
+ -- pragma inline_always (and hence the call has been expanded above
+ -- into a block containing the code of the subprogram).
+
if Ada_Version >= Ada_05
and then not GNAT_Mode
and then Is_RTE (Subp, RE_Raise_Exception)
+ and then Nkind (N) = N_Procedure_Call_Statement
and then (Nkind (First_Actual (N)) /= N_Attribute_Reference
or else Attribute_Name (First_Actual (N)) /= Name_Identity)
then
elsif Nkind (Orig_Bod) /= N_Subprogram_Body then
return False;
- -- Check if this is an ada 2005 null procedure
+ -- Check if this is an Ada 2005 null procedure
elsif Nkind (Decl) = N_Subprogram_Declaration
and then Null_Present (Specification (Decl))
-- If the actual is a simple name or a literal, no need to
-- create a temporary, object can be used directly.
+ -- If the actual is a literal and the formal has its address taken,
+ -- we cannot pass the literal itself as an argument, so its value
+ -- must be captured in a temporary.
+
if (Is_Entity_Name (A)
and then
(not Is_Scalar_Type (Etype (A))
or else (Nkind (A) = N_Identifier
and then Formal_Is_Used_Once (F))
- or else Nkind (A) = N_Real_Literal
- or else Nkind (A) = N_Integer_Literal
- or else Nkind (A) = N_Character_Literal
+ or else
+ ((Nkind (A) = N_Real_Literal or else
+ Nkind (A) = N_Integer_Literal or else
+ Nkind (A) = N_Character_Literal)
+ and then not Address_Taken (F))
then
if Etype (F) /= Etype (A) then
Set_Renamed_Object
-- If the actual has a by-reference type, it cannot be copied, so
-- its value is captured in a renaming declaration. Otherwise
- -- declare a local constant initalized with the actual.
+ -- declare a local constant initialized with the actual.
if Ekind (F) = E_In_Parameter
and then not Is_Limited_Type (Etype (A))
-- If the return type is returned through the secondary stack; that is
-- by reference, we don't want to create a temp to force stack checking.
-- ???"sec stack" is not right -- Ada 95 return-by-reference object are
- -- returned whereever they are.
+ -- returned wherever they are.
-- Shouldn't this function be moved to exp_util???
function Rhs_Of_Assign_Or_Decl (N : Node_Id) return Boolean;
-- because otherwise gigi may generate a large temporary on the fly and
-- this can cause trouble with stack checking.
- -- This is unecessary if the call is the expression in an object
+ -- This is unnecessary if the call is the expression in an object
-- declaration, or if it appears outside of any library unit. This can
-- only happen if it appears as an actual in a library-level instance,
-- in which case a temporary will be generated for it once the instance
-- Add poll call if ATC polling is enabled, unless the body will be
-- inlined by the back-end.
+ -- Add dummy push/pop label nodes at start and end to clear any local
+ -- exception indications if local-exception-to-goto optimization active.
+
-- Add return statement if last statement in body is not a return statement
-- (this makes things easier on Gigi which does not want to have to handle
-- a missing return).
-- the latter test is not critical, it does not matter if we add a
-- few extra returns, since they get eliminated anyway later on.
- procedure Expand_Thread_Body;
- -- Perform required expansion of a thread body
-
----------------
-- Add_Return --
----------------
procedure Add_Return (S : List_Id) is
- begin
- if not Is_Transfer (Last (S)) then
-
- -- The source location for the return is the end label
- -- of the procedure in all cases. This is a bit odd when
- -- there are exception handlers, but not much else we can do.
-
- Append_To (S, Make_Return_Statement (Sloc (End_Label (H))));
- end if;
- end Add_Return;
-
- ------------------------
- -- Expand_Thread_Body --
- ------------------------
-
- -- The required expansion of a thread body is as follows
-
- -- procedure <thread body procedure name> is
-
- -- _Secondary_Stack : aliased
- -- Storage_Elements.Storage_Array
- -- (1 .. Storage_Offset (Sec_Stack_Size));
- -- for _Secondary_Stack'Alignment use Standard'Maximum_Alignment;
-
- -- _Process_ATSD : aliased System.Threads.ATSD;
-
- -- begin
- -- System.Threads.Thread_Body_Enter;
- -- (_Secondary_Stack'Address,
- -- _Secondary_Stack'Length,
- -- _Process_ATSD'Address);
-
- -- declare
- -- <user declarations>
- -- begin
- -- <user statements>
- -- <user exception handlers>
- -- end;
-
- -- System.Threads.Thread_Body_Leave;
-
- -- exception
- -- when E : others =>
- -- System.Threads.Thread_Body_Exceptional_Exit (E);
- -- end;
-
- -- Note the exception handler is omitted if pragma Restriction
- -- No_Exception_Handlers is currently active.
-
- procedure Expand_Thread_Body is
- User_Decls : constant List_Id := Declarations (N);
- Sec_Stack_Len : Node_Id;
-
- TB_Pragma : constant Node_Id :=
- Get_Rep_Pragma (Spec_Id, Name_Thread_Body);
-
- Ent_SS : Entity_Id;
- Ent_ATSD : Entity_Id;
- Ent_EO : Entity_Id;
-
- Decl_SS : Node_Id;
- Decl_ATSD : Node_Id;
-
- Excep_Handlers : List_Id;
+ Last_Stm : Node_Id;
+ Loc : Source_Ptr;
begin
- New_Scope (Spec_Id);
-
- -- Get proper setting for secondary stack size
-
- if List_Length (Pragma_Argument_Associations (TB_Pragma)) = 2 then
- Sec_Stack_Len :=
- Expression (Last (Pragma_Argument_Associations (TB_Pragma)));
- else
- Sec_Stack_Len :=
- New_Occurrence_Of (RTE (RE_Default_Secondary_Stack_Size), Loc);
- end if;
+ -- Get last statement, ignoring any Pop_xxx_Label nodes, which are
+ -- not relevant in this context since they are not executable.
- Sec_Stack_Len := Convert_To (RTE (RE_Storage_Offset), Sec_Stack_Len);
-
- -- Build and set declarations for the wrapped thread body
-
- Ent_SS :=
- Make_Defining_Identifier (Loc,
- Chars => Name_uSecondary_Stack);
- Ent_ATSD :=
- Make_Defining_Identifier (Loc,
- Chars => Name_uProcess_ATSD);
+ Last_Stm := Last (S);
+ while Nkind (Last_Stm) in N_Pop_xxx_Label loop
+ Prev (Last_Stm);
+ end loop;
- Decl_SS :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Ent_SS,
- Aliased_Present => True,
- Object_Definition =>
- Make_Subtype_Indication (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (RTE (RE_Storage_Array), Loc),
- Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints => New_List (
- Make_Range (Loc,
- Low_Bound => Make_Integer_Literal (Loc, 1),
- High_Bound => Sec_Stack_Len)))));
-
- Decl_ATSD :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Ent_ATSD,
- Aliased_Present => True,
- Object_Definition => New_Occurrence_Of (RTE (RE_ATSD), Loc));
+ -- Now insert return unless last statement is a transfer
- Set_Declarations (N, New_List (Decl_SS, Decl_ATSD));
- Analyze (Decl_SS);
- Analyze (Decl_ATSD);
- Set_Alignment (Ent_SS, UI_From_Int (Maximum_Alignment));
+ if not Is_Transfer (Last_Stm) then
- -- Create new exception handler
+ -- The source location for the return is the end label of the
+ -- procedure if present. Otherwise use the sloc of the last
+ -- statement in the list. If the list comes from a generated
+ -- exception handler and we are not debugging generated code,
+ -- all the statements within the handler are made invisible
+ -- to the debugger.
- if Restriction_Active (No_Exception_Handlers) then
- Excep_Handlers := No_List;
+ if Nkind (Parent (S)) = N_Exception_Handler
+ and then not Comes_From_Source (Parent (S))
+ then
+ Loc := Sloc (Last_Stm);
- else
- Check_Restriction (No_Exception_Handlers, N);
+ elsif Present (End_Label (H)) then
+ Loc := Sloc (End_Label (H));
- Ent_EO :=
- Make_Defining_Identifier (Loc,
- Chars => Name_uE);
+ else
+ Loc := Sloc (Last_Stm);
+ end if;
- Excep_Handlers := New_List (
- Make_Implicit_Exception_Handler (Loc,
- Choice_Parameter => Ent_EO,
- Exception_Choices => New_List (
- Make_Others_Choice (Loc)),
- Statements => New_List (
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (RTE (RE_Thread_Body_Exceptional_Exit), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (Ent_EO, Loc))))));
+ Append_To (S, Make_Return_Statement (Loc));
end if;
-
- -- Now build new handled statement sequence and analyze it
-
- Set_Handled_Statement_Sequence (N,
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
-
- Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (RTE (RE_Thread_Body_Enter), Loc),
- Parameter_Associations => New_List (
-
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ent_SS, Loc),
- Attribute_Name => Name_Address),
-
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ent_SS, Loc),
- Attribute_Name => Name_Length),
-
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ent_ATSD, Loc),
- Attribute_Name => Name_Address))),
-
- Make_Block_Statement (Loc,
- Declarations => User_Decls,
- Handled_Statement_Sequence => H),
-
- Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (RTE (RE_Thread_Body_Leave), Loc))),
-
- Exception_Handlers => Excep_Handlers));
-
- Analyze (Handled_Statement_Sequence (N));
- End_Scope;
- end Expand_Thread_Body;
+ end Add_Return;
-- Start of processing for Expand_N_Subprogram_Body
if Is_Non_Empty_List (Declarations (N)) then
L := Declarations (N);
else
- L := Statements (Handled_Statement_Sequence (N));
+ L := Statements (H);
+ end if;
+
+ -- If local-exception-to-goto optimization active, insert dummy push
+ -- statements at start, and dummy pop statements at end.
+
+ if (Debug_Flag_Dot_G
+ or else Restriction_Active (No_Exception_Propagation))
+ and then Is_Non_Empty_List (L)
+ then
+ declare
+ FS : constant Node_Id := First (L);
+ FL : constant Source_Ptr := Sloc (FS);
+ LS : Node_Id;
+ LL : Source_Ptr;
+
+ begin
+ -- LS points to either last statement, if statements are present
+ -- or to the last declaration if there are no statements present.
+ -- It is the node after which the pop's are generated.
+
+ if Is_Non_Empty_List (Statements (H)) then
+ LS := Last (Statements (H));
+ else
+ LS := Last (L);
+ end if;
+
+ LL := Sloc (LS);
+
+ Insert_List_Before_And_Analyze (FS, New_List (
+ Make_Push_Constraint_Error_Label (FL),
+ Make_Push_Program_Error_Label (FL),
+ Make_Push_Storage_Error_Label (FL)));
+
+ Insert_List_After_And_Analyze (LS, New_List (
+ Make_Pop_Constraint_Error_Label (LL),
+ Make_Pop_Program_Error_Label (LL),
+ Make_Pop_Storage_Error_Label (LL)));
+ end;
end if;
-- Find entity for subprogram
Spec_Id := Body_Id;
end if;
- -- Need poll on entry to subprogram if polling enabled. We only
- -- do this for non-empty subprograms, since it does not seem
- -- necessary to poll for a dummy null subprogram. Do not add polling
- -- point if calls to this subprogram will be inlined by the back-end,
- -- to avoid repeated polling points in nested inlinings.
+ -- Need poll on entry to subprogram if polling enabled. We only do this
+ -- for non-empty subprograms, since it does not seem necessary to poll
+ -- for a dummy null subprogram. Do not add polling point if calls to
+ -- this subprogram will be inlined by the back-end, to avoid repeated
+ -- polling points in nested inlinings.
if Is_Non_Empty_List (L) then
if Is_Inlined (Spec_Id)
Make_Handled_Sequence_Of_Statements (Hloc,
Statements => New_List (Blok, Rais)));
- New_Scope (Spec_Id);
+ Push_Scope (Spec_Id);
Analyze (Blok);
Analyze (Rais);
Pop_Scope;
end;
end if;
- -- Deal with thread body
-
- if Is_Thread_Body (Spec_Id) then
- Expand_Thread_Body;
- end if;
-
-- Set to encode entity names in package body before gigi is called
Qualify_Entity_Names (N);
Insert_Before (Prot_Bod, Prot_Decl);
Prot_Id := Defining_Unit_Name (Specification (Prot_Decl));
- New_Scope (Scope (Scop));
+ Push_Scope (Scope (Scop));
Analyze (Prot_Decl);
Create_Extra_Formals (Prot_Id);
Set_Protected_Body_Subprogram (Subp, Prot_Id);
New_Occurrence_Of (Param, Loc)));
-- Analyze new actual. Other actuals in calls are already analyzed
- -- and the list of actuals is not renalyzed after rewriting.
+ -- and the list of actuals is not reanalyzed after rewriting.
Set_Parent (Rec, N);
Analyze (Rec);
then
return False;
+ -- If the return type is a limited interface it has to be treated
+ -- as a return in place, even if the actual object is some non-
+ -- limited descendant.
+
+ elsif Is_Limited_Interface (Etype (E)) then
+ return True;
+
else
return Is_Inherently_Limited_Type (Etype (E))
and then Ada_Version >= Ada_05
procedure Freeze_Subprogram (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- E : constant Entity_Id := Entity (N);
procedure Register_Predefined_DT_Entry (Prim : Entity_Id);
-- (Ada 2005): Register a predefined primitive in all the secondary
Iface_DT_Ptr : Elmt_Id;
Tagged_Typ : Entity_Id;
Thunk_Id : Entity_Id;
+ Thunk_Code : Node_Id;
begin
Tagged_Typ := Find_Dispatching_Type (Prim);
Iface_DT_Ptr :=
Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ)));
- while Present (Iface_DT_Ptr) loop
- Thunk_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('T'));
-
- Insert_Actions (N, New_List (
- Expand_Interface_Thunk
- (N => Prim,
- Thunk_Alias => Prim,
- Thunk_Id => Thunk_Id),
-
- Build_Set_Predefined_Prim_Op_Address (Loc,
- Tag_Node =>
- New_Reference_To (Node (Iface_DT_Ptr), Loc),
- Position_Node =>
- Make_Integer_Literal (Loc, DT_Position (Prim)),
- Address_Node =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Thunk_Id, Loc),
- Attribute_Name => Name_Address))));
+ while Present (Iface_DT_Ptr)
+ and then Ekind (Node (Iface_DT_Ptr)) = E_Constant
+ loop
+ Expand_Interface_Thunk
+ (N => Prim,
+ Thunk_Alias => Prim,
+ Thunk_Id => Thunk_Id,
+ Thunk_Code => Thunk_Code);
+
+ if Present (Thunk_Code) then
+ Insert_Actions (N, New_List (
+ Thunk_Code,
+
+ Build_Set_Predefined_Prim_Op_Address (Loc,
+ Tag_Node => New_Reference_To (Node (Iface_DT_Ptr), Loc),
+ Position => DT_Position (Prim),
+ Address_Node =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Thunk_Id, Loc),
+ Attribute_Name => Name_Address))));
+ end if;
Next_Elmt (Iface_DT_Ptr);
end loop;
end Register_Predefined_DT_Entry;
- -- Start of processing for Freeze_Subprogram
+ -- Local variables
- begin
- -- We assume that imported CPP primitives correspond with objects
- -- whose constructor is in the CPP side (and therefore we don't need
- -- to generate code to register them in the dispatch table).
-
- if Is_Imported (E)
- and then Convention (E) = Convention_CPP
- then
- return;
- end if;
-
- -- When a primitive is frozen, enter its name in the corresponding
- -- dispatch table. If the DTC_Entity field is not set this is an
- -- overridden primitive that can be ignored. We suppress the
- -- initialization of the dispatch table entry when Java_VM because
- -- the dispatching mechanism is handled internally by the JVM.
-
- if Is_Dispatching_Operation (E)
- and then not Is_Abstract_Subprogram (E)
- and then Present (DTC_Entity (E))
- and then not Java_VM
- and then not Is_CPP_Class (Scope (DTC_Entity (E)))
- then
- Check_Overriding_Operation (E);
+ Subp : constant Entity_Id := Entity (N);
+ Typ : constant Entity_Id := Etype (Subp);
+ Utyp : constant Entity_Id := Underlying_Type (Typ);
- -- Ada 95 case: Register the subprogram in the primary dispatch table
+ begin
+ if not Static_Dispatch_Tables then
+ declare
+ E : constant Entity_Id := Subp;
+ Typ : Entity_Id;
- -- Do not register the subprogram in the dispatch table if we are
- -- compiling under No_Dispatching_Calls restriction.
+ begin
+ -- We assume that imported CPP primitives correspond with objects
+ -- whose constructor is in the CPP side (and therefore we don't
+ -- need to generate code to register them in the dispatch table).
- if not Restriction_Active (No_Dispatching_Calls) then
+ if Is_Imported (E)
+ and then Convention (E) = Convention_CPP
+ then
+ return;
+ end if;
- if Ada_Version < Ada_05 then
- Insert_After (N,
- Fill_DT_Entry (Sloc (N), Prim => E));
+ -- When a primitive is frozen, enter its name in the corresponding
+ -- dispatch table. If the DTC_Entity field is not set this is
+ -- an overridden primitive that can be ignored. We suppress the
+ -- initialization of the dispatch table entry when VM_Target
+ -- because the dispatching mechanism is handled internally by
+ -- the VM.
+
+ if Is_Dispatching_Operation (E)
+ and then not Is_Abstract_Subprogram (E)
+ and then Present (DTC_Entity (E))
+ and then VM_Target = No_VM
+ and then not Is_CPP_Class (Scope (DTC_Entity (E)))
+ then
+ Check_Overriding_Operation (E);
- -- Ada 2005 case: Register the subprogram in all the dispatch
- -- tables associated with the type
+ -- Register the primitive in its dispatch table if we are not
+ -- compiling under No_Dispatching_Calls restriction
- else
- declare
- Typ : constant Entity_Id := Scope (DTC_Entity (E));
+ if not Restriction_Active (No_Dispatching_Calls)
+ and then RTE_Available (RE_Tag)
+ then
+ Typ := Scope (DTC_Entity (E));
- begin
if not Is_Interface (Typ)
- and then Is_Predefined_Dispatching_Operation (E)
- then
- Register_Predefined_DT_Entry (E);
- Insert_After (N, Fill_DT_Entry (Sloc (N), Prim => E));
-
- -- There is no dispatch table associated with abstract
- -- interface types. Each type implementing interfaces will
- -- fill the associated secondary DT entries.
-
- elsif not Is_Interface (Typ)
- or else Present (Alias (E))
+ or else Present (Abstract_Interface_Alias (E))
then
- -- Ada 2005 (AI-251): Check if this entry corresponds
- -- with a subprogram that covers an abstract interface
- -- type.
-
- if Present (Abstract_Interface_Alias (E)) then
- Register_Interface_DT_Entry (N, E);
+ if Is_Predefined_Dispatching_Operation (E) then
+ Register_Predefined_DT_Entry (E);
+ end if;
- -- Common case: Primitive subprogram
+ Register_Primitive (Loc,
+ Prim => E,
+ Ins_Nod => N);
+ end if;
+ end if;
+ end if;
+ end;
- else
- -- Generate thunks for all the predefined operations
+ -- GCC 4.1 backend
- if Is_Predefined_Dispatching_Operation (E) then
- Register_Predefined_DT_Entry (E);
- end if;
+ else
+ -- Handle private overriden primitives
- Insert_After (N,
- Fill_DT_Entry (Sloc (N), Prim => E));
- end if;
- end if;
- end;
- end if;
+ if Is_Dispatching_Operation (Subp)
+ and then not Is_Abstract_Subprogram (Subp)
+ and then Present (DTC_Entity (Subp))
+ and then VM_Target = No_VM
+ and then not Is_CPP_Class (Scope (DTC_Entity (Subp)))
+ then
+ Check_Overriding_Operation (Subp);
end if;
end if;
- -- Mark functions that return by reference. Note that it cannot be
- -- part of the normal semantic analysis of the spec since the
- -- underlying returned type may not be known yet (for private types).
+ -- Mark functions that return by reference. Note that it cannot be part
+ -- of the normal semantic analysis of the spec since the underlying
+ -- returned type may not be known yet (for private types).
- declare
- Typ : constant Entity_Id := Etype (E);
- Utyp : constant Entity_Id := Underlying_Type (Typ);
+ if Is_Inherently_Limited_Type (Typ) then
+ Set_Returns_By_Ref (Subp);
- begin
- if Is_Inherently_Limited_Type (Typ) then
- Set_Returns_By_Ref (E);
-
- elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then
- Set_Returns_By_Ref (E);
- end if;
- end;
+ elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then
+ Set_Returns_By_Ref (Subp);
+ end if;
end Freeze_Subprogram;
-------------------------------------------
-- allocated on the caller side, and access to it is passed to the
-- function.
- if Is_Constrained (Result_Subt) then
+ -- Here and in related routines, we must examine the full view of the
+ -- type, because the view at the point of call may differ from that
+ -- that in the function body, and the expansion mechanism depends on
+ -- the characteristics of the full view.
+
+ if Is_Constrained (Underlying_Type (Result_Subt)) then
-- Replace the initialized allocator of form "new T'(Func (...))"
-- with an uninitialized allocator of form "new T", where T is the
Object_Definition => New_Reference_To (Acc_Type, Loc),
Expression => Relocate_Node (Allocator)));
+ -- When the function has a controlling result, an allocation-form
+ -- parameter must be passed indicating that the caller is allocating
+ -- the result object. This is needed because such a function can be
+ -- called as a dispatching operation and must be treated similarly
+ -- to functions with unconstrained result subtypes.
+
+ Add_Alloc_Form_Actual_To_Build_In_Place_Call
+ (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
+
+ Add_Final_List_Actual_To_Build_In_Place_Call
+ (Func_Call, Function_Id, Acc_Type);
+
+ Add_Task_Actuals_To_Build_In_Place_Call
+ (Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type));
+
-- Add an implicit actual to the function call that provides access
-- to the allocated object. An unchecked conversion to the (specific)
-- result subtype of the function is inserted to handle cases where
-- the access type of the allocator has a class-wide designated type.
- Add_Final_List_Actual_To_Build_In_Place_Call (Func_Call, Function_Id);
- Add_Task_Actuals_To_Build_In_Place_Call
- (Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type));
Add_Access_Actual_To_Build_In_Place_Call
(Func_Call,
Function_Id,
-- operations. ???
else
+
-- Pass an allocation parameter indicating that the function should
-- allocate its result on the heap.
Add_Alloc_Form_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Alloc_Form => Global_Heap);
- -- The caller does not provide the return object in this case, so we
- -- have to pass null for the object access actual.
+ Add_Final_List_Actual_To_Build_In_Place_Call
+ (Func_Call, Function_Id, Acc_Type);
- Add_Final_List_Actual_To_Build_In_Place_Call (Func_Call, Function_Id);
Add_Task_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type));
+
+ -- The caller does not provide the return object in this case, so we
+ -- have to pass null for the object access actual.
+
Add_Access_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Return_Object => Empty);
end if;
-- When the result subtype is constrained, an object of the subtype is
-- declared and an access value designating it is passed as an actual.
- if Is_Constrained (Result_Subt) then
+ if Is_Constrained (Underlying_Type (Result_Subt)) then
-- Create a temporary object to hold the function result
Insert_Action (Func_Call, Return_Obj_Decl);
- -- Add an implicit actual to the function call that provides access
- -- to the caller's return object.
+ -- When the function has a controlling result, an allocation-form
+ -- parameter must be passed indicating that the caller is allocating
+ -- the result object. This is needed because such a function can be
+ -- called as a dispatching operation and must be treated similarly
+ -- to functions with unconstrained result subtypes.
+
+ Add_Alloc_Form_Actual_To_Build_In_Place_Call
+ (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
+
+ Add_Final_List_Actual_To_Build_In_Place_Call
+ (Func_Call, Function_Id, Acc_Type => Empty);
- Add_Final_List_Actual_To_Build_In_Place_Call (Func_Call, Function_Id);
Add_Task_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
+
+ -- Add an implicit actual to the function call that provides access
+ -- to the caller's return object.
+
Add_Access_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, New_Reference_To (Return_Obj_Id, Loc));
-- scope is established to ensure eventual cleanup of the result.
else
+
-- Pass an allocation parameter indicating that the function should
-- allocate its result on the secondary stack.
Add_Alloc_Form_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Alloc_Form => Secondary_Stack);
- -- Pass a null value to the function since no return object is
- -- available on the caller side.
+ Add_Final_List_Actual_To_Build_In_Place_Call
+ (Func_Call, Function_Id, Acc_Type => Empty);
- Add_Final_List_Actual_To_Build_In_Place_Call (Func_Call, Function_Id);
Add_Task_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
+
+ -- Pass a null value to the function since no return object is
+ -- available on the caller side.
+
Add_Access_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Empty);
-- When the result subtype is unconstrained, an additional actual must
-- be passed to indicate that the caller is providing the return object.
+ -- This parameter must also be passed when the called function has a
+ -- controlling result, because dispatching calls to the function needs
+ -- to be treated effectively the same as calls to class-wide functions.
- if not Is_Constrained (Result_Subt) then
- Add_Alloc_Form_Actual_To_Build_In_Place_Call
- (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
- end if;
+ Add_Alloc_Form_Actual_To_Build_In_Place_Call
+ (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
- -- Add an implicit actual to the function call that provides access to
- -- the caller's return object.
+ Add_Final_List_Actual_To_Build_In_Place_Call
+ (Func_Call, Function_Id, Acc_Type => Empty);
- Add_Final_List_Actual_To_Build_In_Place_Call (Func_Call, Function_Id);
Add_Task_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
+
+ -- Add an implicit actual to the function call that provides access to
+ -- the caller's return object.
+
Add_Access_Actual_To_Build_In_Place_Call
(Func_Call,
Function_Id,
Loc : Source_Ptr;
Obj_Def_Id : constant Entity_Id :=
Defining_Identifier (Object_Decl);
+
Func_Call : Node_Id := Function_Call;
Function_Id : Entity_Id;
Result_Subt : Entity_Id;
-- to the (specific) result type of the function is inserted to handle
-- the case where the object is declared with a class-wide type.
- if Is_Constrained (Result_Subt) then
+ if Is_Constrained (Underlying_Type (Result_Subt)) then
Caller_Object :=
Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark => New_Reference_To (Result_Subt, Loc),
Expression => New_Reference_To (Obj_Def_Id, Loc));
+ -- When the function has a controlling result, an allocation-form
+ -- parameter must be passed indicating that the caller is allocating
+ -- the result object. This is needed because such a function can be
+ -- called as a dispatching operation and must be treated similarly
+ -- to functions with unconstrained result subtypes.
+
+ Add_Alloc_Form_Actual_To_Build_In_Place_Call
+ (Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
+
-- If the function's result subtype is unconstrained and the object is
-- a return object of an enclosing build-in-place function, then the
-- implicit build-in-place parameters of the enclosing function must be
-- Otherwise, when the enclosing function has an unconstrained result
-- type, the BIP_Alloc_Form formal of the enclosing function must be
- -- passed long to the callee.
+ -- passed along to the callee.
else
Add_Alloc_Form_Actual_To_Build_In_Place_Call
Establish_Transient_Scope (Object_Decl, Sec_Stack => True);
end if;
- Add_Final_List_Actual_To_Build_In_Place_Call (Func_Call, Function_Id);
+ Add_Final_List_Actual_To_Build_In_Place_Call
+ (Func_Call, Function_Id, Acc_Type => Empty);
+
if Nkind (Parent (Object_Decl)) = N_Extended_Return_Statement
and then Has_Task (Result_Subt)
then
Enclosing_Func := Enclosing_Subprogram (Obj_Def_Id);
+
+ -- Here we're passing along the master that was passed in to this
+ -- function.
+
Add_Task_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id,
Master_Actual =>
New_Reference_To
(Build_In_Place_Formal (Enclosing_Func, BIP_Master), Loc));
- -- Here we're passing along the master that was passed in to this
- -- function.
+
else
Add_Task_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
end if;
+
Add_Access_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Caller_Object, Is_Access => Pass_Caller_Acc);
-- the object declaration is rewritten to be a renaming of a dereference
-- of the access object.
- if Is_Constrained (Result_Subt) then
+ if Is_Constrained (Underlying_Type (Result_Subt)) then
Insert_After_And_Analyze (Object_Decl, Ptr_Typ_Decl);
else
Insert_Before_And_Analyze (Object_Decl, Ptr_Typ_Decl);
Object_Definition => New_Reference_To (Ref_Type, Loc),
Expression => New_Expr));
- if Is_Constrained (Result_Subt) then
+ if Is_Constrained (Underlying_Type (Result_Subt)) then
Set_Expression (Object_Decl, Empty);
Set_No_Initialization (Object_Decl);
end if;
end Make_Build_In_Place_Call_In_Object_Declaration;
- ---------------------------------
- -- Register_Interface_DT_Entry --
- ---------------------------------
-
- procedure Register_Interface_DT_Entry
- (Related_Nod : Node_Id;
- Prim : Entity_Id)
- is
- Loc : constant Source_Ptr := Sloc (Prim);
- Iface_Typ : Entity_Id;
- Tagged_Typ : Entity_Id;
- Thunk_Id : Entity_Id;
-
- begin
- -- Nothing to do if the run-time does not support abstract interfaces
-
- if not (RTE_Available (RE_Interface_Tag)) then
- return;
- end if;
-
- Tagged_Typ := Find_Dispatching_Type (Alias (Prim));
- Iface_Typ := Find_Dispatching_Type (Abstract_Interface_Alias (Prim));
-
- -- Generate the code of the thunk only if the abstract interface type is
- -- not an immediate ancestor of Tagged_Type; otherwise the dispatch
- -- table associated with the interface is the primary dispatch table.
-
- pragma Assert (Is_Interface (Iface_Typ));
-
- if not Is_Parent (Iface_Typ, Tagged_Typ) then
- Thunk_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('T'));
-
- Insert_Actions (Related_Nod, New_List (
- Expand_Interface_Thunk
- (N => Prim,
- Thunk_Alias => Alias (Prim),
- Thunk_Id => Thunk_Id),
-
- Fill_Secondary_DT_Entry (Sloc (Prim),
- Prim => Prim,
- Iface_DT_Ptr => Find_Interface_ADT (Tagged_Typ, Iface_Typ),
- Thunk_Id => Thunk_Id)));
- end if;
- end Register_Interface_DT_Entry;
-
end Exp_Ch6;
OSDN Git Service
