-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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 Sem_Ch8; use Sem_Ch8;
with Sem_Ch11; use Sem_Ch11;
with Sem_Elab; use Sem_Elab;
+with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
end loop;
-- If we are in a package body, the activation chain variable is
- -- declared in the body, but the Activation_Chain_Entity is attached to
- -- the spec.
+ -- declared in the body, but the Activation_Chain_Entity is attached
+ -- to the spec.
if Nkind (P) = N_Package_Body then
Decls := Declarations (P);
-- for Lnn in Family_Low .. Family_High loop
-- Inn := Inn + 1;
-- Set_Entry_Name
- -- (_init._object, Inn, new String ("<Entry name> " & Lnn'Img));
- -- _init._task_id
+ -- (_init._object <or> _init._task_id,
+ -- Inn,
+ -- new String ("<Entry name>(" & Lnn'Img & ")"));
-- end loop;
-- Note that the bounds of the range may reference discriminants. The
-- above construct is added directly to the statements of the block.
procedure Build_Entry_Name (Id : Entity_Id);
-- Generate:
-- Inn := Inn + 1;
- -- Set_Entry_Name (_init._task_id, Inn, new String ("<Entry name>");
- -- _init._object
+ -- Set_Entry_Name
+ -- (_init._object <or>_init._task_id,
+ -- Inn,
+ -- new String ("<Entry name>");
-- The above construct is added directly to the statements of the block.
function Build_Set_Entry_Name_Call (Arg3 : Node_Id) return Node_Id;
begin
Get_Name_String (Chars (Id));
- if Is_Enumeration_Type (Etype (Def)) then
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := ' ';
- end if;
+ -- Add a leading '('
+
+ Add_Char_To_Name_Buffer ('(');
-- Generate:
- -- new String'("<Entry name>" & Lnn'Img);
+ -- new String'("<Entry name>(" & Lnn'Img & ")");
+
+ -- This is an implicit heap allocation, and Comes_From_Source is
+ -- False, which ensures that it will get flagged as a violation of
+ -- No_Implicit_Heap_Allocations when that restriction applies.
Val :=
Make_Allocator (Loc,
Expression =>
Make_Op_Concat (Loc,
Left_Opnd =>
- Make_String_Literal (Loc,
- String_From_Name_Buffer),
+ Make_Op_Concat (Loc,
+ Left_Opnd =>
+ Make_String_Literal (Loc,
+ Strval => String_From_Name_Buffer),
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Reference_To (L_Id, Loc),
+ Attribute_Name => Name_Img)),
Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Reference_To (L_Id, Loc),
- Attribute_Name => Name_Img))));
+ Make_String_Literal (Loc,
+ Strval => ")"))));
Increment_Index (L_Stmts);
Append_To (L_Stmts, Build_Set_Entry_Name_Call (Val));
-- Generate:
-- for Lnn in Family_Low .. Family_High loop
-- Inn := Inn + 1;
- -- Set_Entry_Name (_init._task_id, Inn, <Val>);
+ -- Set_Entry_Name
+ -- (_init._object <or> _init._task_id, Inn, <Val>);
-- end loop;
Append_To (B_Stmts,
begin
Get_Name_String (Chars (Id));
+
+ -- This is an implicit heap allocation, and Comes_From_Source is
+ -- False, which ensures that it will get flagged as a violation of
+ -- No_Implicit_Heap_Allocations when that restriction applies.
+
Val :=
Make_Allocator (Loc,
Make_Qualified_Expression (Loc,
Body_Spec : Node_Id;
begin
- Body_Spec := Build_Wrapper_Spec (Loc, Subp_Id, Obj_Typ, Formals);
+ Body_Spec := Build_Wrapper_Spec (Subp_Id, Obj_Typ, Formals);
-- The subprogram is not overriding or is not a primitive declared
-- between two views.
declare
Actuals : List_Id := No_List;
Conv_Id : Node_Id;
- First_Formal : Node_Id;
+ First_Form : Node_Id;
Formal : Node_Id;
Nam : Node_Id;
-- Map formals to actuals. Use the list built for the wrapper
-- spec, skipping the object notation parameter.
- First_Formal := First (Parameter_Specifications (Body_Spec));
+ First_Form := First (Parameter_Specifications (Body_Spec));
- Formal := First_Formal;
+ Formal := First_Form;
Next (Formal);
if Present (Formal) then
end if;
-- Special processing for primitives declared between a private
- -- type and its completion.
+ -- type and its completion: the wrapper needs a properly typed
+ -- parameter if the wrapped operation has a controlling first
+ -- parameter. Note that this might not be the case for a function
+ -- with a controlling result.
if Is_Private_Primitive_Subprogram (Subp_Id) then
if No (Actuals) then
Actuals := New_List;
end if;
- Prepend_To (Actuals,
- Unchecked_Convert_To (
- Corresponding_Concurrent_Type (Obj_Typ),
- Make_Identifier (Loc, Name_uO)));
+ if Is_Controlling_Formal (First_Formal (Subp_Id)) then
+ Prepend_To (Actuals,
+ Unchecked_Convert_To (
+ Corresponding_Concurrent_Type (Obj_Typ),
+ Make_Identifier (Loc, Name_uO)));
- Nam := New_Reference_To (Subp_Id, Loc);
+ else
+ Prepend_To (Actuals,
+ Make_Identifier (Loc, Chars =>
+ Chars (Defining_Identifier (First_Form))));
+ end if;
+ Nam := New_Reference_To (Subp_Id, Loc);
else
-- An access-to-variable object parameter requires an explicit
-- dereference in the unchecked conversion. This case occurs
-- O.all.Subp_Id (Formal_1, ..., Formal_N)
- if Nkind (Parameter_Type (First_Formal)) =
+ if Nkind (Parameter_Type (First_Form)) =
N_Access_Definition
then
Conv_Id :=
New_Reference_To (Subp_Id, Loc));
end if;
- -- Create the subprogram body
+ -- Create the subprogram body. For a function, the call to the
+ -- actual subprogram has to be converted to the corresponding
+ -- record if it is a controlling result.
if Ekind (Subp_Id) = E_Function then
- return
- Make_Subprogram_Body (Loc,
- Specification => Body_Spec,
- Declarations => Empty_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Simple_Return_Statement (Loc,
- Make_Function_Call (Loc,
- Name => Nam,
- Parameter_Associations => Actuals)))));
+ declare
+ Res : Node_Id;
+
+ begin
+ Res :=
+ Make_Function_Call (Loc,
+ Name => Nam,
+ Parameter_Associations => Actuals);
+
+ if Has_Controlling_Result (Subp_Id) then
+ Res :=
+ Unchecked_Convert_To
+ (Corresponding_Record_Type (Etype (Subp_Id)), Res);
+ end if;
+
+ return
+ Make_Subprogram_Body (Loc,
+ Specification => Body_Spec,
+ Declarations => Empty_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Simple_Return_Statement (Loc, Res))));
+ end;
else
return
------------------------
function Build_Wrapper_Spec
- (Loc : Source_Ptr;
- Subp_Id : Entity_Id;
+ (Subp_Id : Entity_Id;
Obj_Typ : Entity_Id;
Formals : List_Id) return Node_Id
is
+ Loc : constant Source_Ptr := Sloc (Subp_Id);
First_Param : Node_Id;
Iface : Entity_Id;
Iface_Elmt : Elmt_Id;
-- Determine whether the parameters of the generated entry wrapper
-- and those of a primitive operation are type conformant. During
-- this check, the first parameter of the primitive operation is
- -- always skipped.
+ -- skipped if it is a controlling argument: protected functions
+ -- may have a controlling result.
--------------------------------
-- Type_Conformant_Parameters --
Wrapper_Typ : Entity_Id;
begin
- -- Skip the first parameter of the primitive operation
+ -- Skip the first (controlling) parameter of primitive operation
+
+ Iface_Op_Param := First (Iface_Op_Params);
+
+ if Present (First_Formal (Iface_Op))
+ and then Is_Controlling_Formal (First_Formal (Iface_Op))
+ then
+ Iface_Op_Param := Next (Iface_Op_Param);
+ end if;
- Iface_Op_Param := Next (First (Iface_Op_Params));
Wrapper_Param := First (Wrapper_Params);
while Present (Iface_Op_Param)
and then Present (Wrapper_Param)
-- Skip the object parameter when dealing with primitives declared
-- between two views.
- if Is_Private_Primitive_Subprogram (Subp_Id) then
+ if Is_Private_Primitive_Subprogram (Subp_Id)
+ and then not Has_Controlling_Result (Subp_Id)
+ then
Formal := Next (Formal);
end if;
New_Formals := Replicate_Formals (Loc, Formals);
+ -- A function with a controlling result and no first controlling
+ -- formal needs no additional parameter.
+
+ if Has_Controlling_Result (Subp_Id)
+ and then
+ (No (First_Formal (Subp_Id))
+ or else not Is_Controlling_Formal (First_Formal (Subp_Id)))
+ then
+ null;
+
-- Routine Subp_Id has been found to override an interface primitive.
-- If the interface operation has an access parameter, create a copy
-- of it, with the same null exclusion indicator if present.
- if Present (First_Param) then
+ elsif Present (First_Param) then
if Nkind (Parameter_Type (First_Param)) = N_Access_Definition then
Obj_Param_Typ :=
Make_Access_Definition (Loc,
Out_Present => Out_Present (First_Param),
Parameter_Type => Obj_Param_Typ);
+ Prepend_To (New_Formals, Obj_Param);
+
-- If we are dealing with a primitive declared between two views,
- -- create a default parameter.
+ -- implemented by a synchronized operation, we need to create
+ -- a default parameter. The mode of the parameter must match that
+ -- of the primitive operation.
- else pragma Assert (Is_Private_Primitive_Subprogram (Subp_Id));
+ else
+ pragma Assert (Is_Private_Primitive_Subprogram (Subp_Id));
Obj_Param :=
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uO),
- In_Present => True,
+ In_Present => In_Present (Parent (First_Entity (Subp_Id))),
Out_Present => Ekind (Subp_Id) /= E_Function,
Parameter_Type => New_Reference_To (Obj_Typ, Loc));
+ Prepend_To (New_Formals, Obj_Param);
end if;
- Prepend_To (New_Formals, Obj_Param);
-
- -- Build the final spec
+ -- Build the final spec. If it is a function with a controlling
+ -- result, it is a primitive operation of the corresponding
+ -- record type, so mark the spec accordingly.
if Ekind (Subp_Id) = E_Function then
- return
- Make_Function_Specification (Loc,
- Defining_Unit_Name => Wrapper_Id,
- Parameter_Specifications => New_Formals,
- Result_Definition =>
- New_Copy (Result_Definition (Parent (Subp_Id))));
+
+ declare
+ Res_Def : Node_Id;
+
+ begin
+ if Has_Controlling_Result (Subp_Id) then
+ Res_Def :=
+ New_Occurrence_Of
+ (Corresponding_Record_Type (Etype (Subp_Id)), Loc);
+ else
+ Res_Def := New_Copy (Result_Definition (Parent (Subp_Id)));
+ end if;
+
+ return
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Wrapper_Id,
+ Parameter_Specifications => New_Formals,
+ Result_Definition => Res_Def);
+ end;
else
return
Make_Procedure_Specification (Loc,
and then Ekind (Defining_Identifier (Decl)) = E_Entry
then
Wrap_Spec :=
- Build_Wrapper_Spec (Loc,
- Subp_Id => Defining_Identifier (Decl),
- Obj_Typ => Rec_Typ,
- Formals => Parameter_Specifications (Decl));
+ Build_Wrapper_Spec
+ (Subp_Id => Defining_Identifier (Decl),
+ Obj_Typ => Rec_Typ,
+ Formals => Parameter_Specifications (Decl));
elsif Nkind (Decl) = N_Subprogram_Declaration then
Wrap_Spec :=
- Build_Wrapper_Spec (Loc,
- Subp_Id => Defining_Unit_Name (Specification (Decl)),
- Obj_Typ => Rec_Typ,
- Formals =>
- Parameter_Specifications (Specification (Decl)));
+ Build_Wrapper_Spec
+ (Subp_Id => Defining_Unit_Name (Specification (Decl)),
+ Obj_Typ => Rec_Typ,
+ Formals =>
+ Parameter_Specifications (Specification (Decl)));
end if;
if Present (Wrap_Spec) then
-- in internal scopes, unless present already.. Required for nested
-- limited aggregates, where the expansion of task components may
-- generate inner blocks. If the block is the rewriting of a call
- -- this is valid master.
+ -- or the scope is an extended return statement this is valid master.
+ -- The master in an extended return is only used within the return,
+ -- and is subsequently overwritten in Move_Activation_Chain, but it
+ -- must exist now.
if Ada_Version >= Ada_05 then
while Is_Internal (S) loop
Nkind (Original_Node (Parent (S))) = N_Procedure_Call_Statement
then
exit;
+ elsif Ekind (S) = E_Return_Statement then
+ exit;
else
S := Scope (S);
end if;
Set_Debug_Info_Needed (New_Id);
+ -- If a pragma Eliminate applies to the source entity, the internal
+ -- subprograms will be eliminated as well.
+
+ Set_Is_Eliminated (New_Id, Is_Eliminated (Def_Id));
+
if Nkind (Specification (Decl)) = N_Procedure_Specification then
New_Spec :=
Make_Procedure_Specification (Loc,
Params := New_List;
end if;
+ -- If the type is an untagged derived type, convert to the root type,
+ -- which is the one on which the operations are defined.
+
+ if Nkind (Rec) = N_Unchecked_Type_Conversion
+ and then not Is_Tagged_Type (Etype (Rec))
+ and then Is_Derived_Type (Etype (Rec))
+ then
+ Set_Etype (Rec, Root_Type (Etype (Rec)));
+ Set_Subtype_Mark (Rec,
+ New_Occurrence_Of (Root_Type (Etype (Rec)), Sloc (N)));
+ end if;
+
Prepend (Rec, Params);
if Ekind (Sub) = E_Procedure then
Name_Len := Name_Len - 1;
end if;
- Name_Buffer (Name_Len + 1) := '_';
- Name_Buffer (Name_Len + 2) := '_';
-
- Name_Len := Name_Len + 2;
+ Add_Str_To_Name_Buffer ("__");
for J in 1 .. Select_Len loop
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := Select_Buffer (J);
+ Add_Char_To_Name_Buffer (Select_Buffer (J));
end loop;
-- Now add the Append_Char if specified. The encoding to follow
if Append_Char /= ' ' then
if Append_Char = 'P' or Append_Char = 'N' then
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := Append_Char;
+ Add_Char_To_Name_Buffer (Append_Char);
return Name_Find;
else
- Name_Buffer (Name_Len + 1) := '_';
- Name_Buffer (Name_Len + 2) := Append_Char;
- Name_Len := Name_Len + 2;
+ Add_Str_To_Name_Buffer ((1 => '_', 2 => Append_Char));
return New_External_Name (Name_Find, ' ', -1);
end if;
else
Spec_Id : Entity_Id;
begin
- Spec_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (T), 'B'));
+ if Comes_From_Source (T) then
+ -- This is an explicit task type
+ Spec_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (T), "TB"));
+ else
+ -- This is an anonymous task type
+ Spec_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (T), 'B'));
+ end if;
+
Set_Is_Internal (Spec_Id);
-- Associate the procedure with the task, if this is the declaration
return N;
else
return
- Unchecked_Convert_To (Corresponding_Record_Type (Typ),
- New_Copy_Tree (N));
+ Unchecked_Convert_To
+ (Corresponding_Record_Type (Typ), New_Copy_Tree (N));
end if;
end Convert_Concurrent;
when N_Subprogram_Body =>
- -- Exclude functions created to analyze defaults
+ -- Do not create bodies for eliminated operations
if not Is_Eliminated (Defining_Entity (Op_Body))
and then not Is_Eliminated (Corresponding_Spec (Op_Body))
New_Op_Body :=
Build_Unprotected_Subprogram_Body (Op_Body, Pid);
- -- Propagate the finalization chain to the new body.
- -- In the unlikely event that the subprogram contains a
- -- declaration or allocator for an object that requires
- -- finalization, the corresponding chain is created when
- -- analyzing the body, and attached to its entity. This
- -- entity is not further elaborated, and so the chain
- -- properly belongs to the newly created subprogram body.
+ -- Propagate the finalization chain to the new body. In the
+ -- unlikely event that the subprogram contains a declaration
+ -- or allocator for an object that requires finalization,
+ -- the corresponding chain is created when analyzing the
+ -- body, and attached to its entity. This entity is not
+ -- further elaborated, and so the chain properly belongs to
+ -- the newly created subprogram body.
Chain :=
Finalization_Chain_Entity (Defining_Entity (Op_Body));
-- appear that this is needed only if this is a visible
-- operation of the type, or if it is an interrupt handler,
-- and this was the strategy used previously in GNAT.
- -- However, the operation may be exported through a
- -- 'Access to an external caller. This is the common idiom
- -- in code that uses the Ada 2005 Timing_Events package
- -- As a result we need to produce the protected body for
- -- both visible and private operations.
+ -- However, the operation may be exported through a 'Access
+ -- to an external caller. This is the common idiom in code
+ -- that uses the Ada 2005 Timing_Events package. As a result
+ -- we need to produce the protected body for both visible
+ -- and private operations.
if Present (Corresponding_Spec (Op_Body)) then
Op_Decl :=
Loc : constant Source_Ptr := Sloc (N);
Prot_Typ : constant Entity_Id := Defining_Identifier (N);
- Pdef : constant Node_Id := Protected_Definition (N);
+ Pdef : constant Node_Id := Protected_Definition (N);
-- This contains two lists; one for visible and one for private decls
Rec_Decl : Node_Id;
E_Count : Int;
Object_Comp : Node_Id;
+ procedure Check_Inlining (Subp : Entity_Id);
+ -- If the original operation has a pragma Inline, propagate the flag
+ -- to the internal body, for possible inlining later on. The source
+ -- operation is invisible to the back-end and is never actually called.
+
+ function Static_Component_Size (Comp : Entity_Id) return Boolean;
+ -- When compiling under the Ravenscar profile, private components must
+ -- have a static size, or else a protected object will require heap
+ -- allocation, violating the corresponding restriction. It is preferable
+ -- to make this check here, because it provides a better error message
+ -- than the back-end, which refers to the object as a whole.
+
procedure Register_Handler;
-- For a protected operation that is an interrupt handler, add the
-- freeze action that will register it as such.
+ --------------------
+ -- Check_Inlining --
+ --------------------
+
+ procedure Check_Inlining (Subp : Entity_Id) is
+ begin
+ if Is_Inlined (Subp) then
+ Set_Is_Inlined (Protected_Body_Subprogram (Subp));
+ Set_Is_Inlined (Subp, False);
+ end if;
+ end Check_Inlining;
+
+ ---------------------------------
+ -- Check_Static_Component_Size --
+ ---------------------------------
+
+ function Static_Component_Size (Comp : Entity_Id) return Boolean is
+ Typ : constant Entity_Id := Etype (Comp);
+ C : Entity_Id;
+
+ begin
+ if Is_Scalar_Type (Typ) then
+ return True;
+
+ elsif Is_Array_Type (Typ) then
+ return Compile_Time_Known_Bounds (Typ);
+
+ elsif Is_Record_Type (Typ) then
+ C := First_Component (Typ);
+ while Present (C) loop
+ if not Static_Component_Size (C) then
+ return False;
+ end if;
+
+ Next_Component (C);
+ end loop;
+
+ return True;
+
+ -- Any other types will be checked by the back-end
+
+ else
+ return True;
+ end if;
+ end Static_Component_Size;
+
----------------------
-- Register_Handler --
----------------------
while Present (Priv) loop
if Nkind (Priv) = N_Component_Declaration then
+ if not Static_Component_Size (Defining_Identifier (Priv)) then
+
+ -- When compiling for a restricted profile, the private
+ -- components must have a static size. If not, this is an
+ -- error for a single protected declaration, and rates a
+ -- warning on a protected type declaration.
+
+ if not Comes_From_Source (Prot_Typ) then
+ Check_Restriction (No_Implicit_Heap_Allocations, Priv);
+
+ elsif Restriction_Active (No_Implicit_Heap_Allocations) then
+ Error_Msg_N ("component has non-static size?", Priv);
+ Error_Msg_NE
+ ("\creation of protected object of type& will violate"
+ & " restriction No_Implicit_Heap_Allocations?",
+ Priv, Prot_Typ);
+ end if;
+ end if;
-- The component definition consists of a subtype indication,
-- or (in Ada 2005) an access definition. Make a copy of the
declare
Old_Comp : constant Node_Id := Component_Definition (Priv);
- Pent : constant Entity_Id := Defining_Identifier (Priv);
+ Oent : constant Entity_Id := Defining_Identifier (Priv);
New_Comp : Node_Id;
+ Nent : constant Entity_Id :=
+ Make_Defining_Identifier (Sloc (Oent),
+ Chars => Chars (Oent));
begin
if Present (Subtype_Indication (Old_Comp)) then
New_Comp :=
- Make_Component_Definition (Sloc (Pent),
+ Make_Component_Definition (Sloc (Oent),
Aliased_Present => False,
Subtype_Indication =>
New_Copy_Tree (Subtype_Indication (Old_Comp),
Discr_Map));
else
New_Comp :=
- Make_Component_Definition (Sloc (Pent),
+ Make_Component_Definition (Sloc (Oent),
Aliased_Present => False,
Access_Definition =>
New_Copy_Tree (Access_Definition (Old_Comp),
New_Priv :=
Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Sloc (Pent), Chars (Pent)),
+ Defining_Identifier => Nent,
Component_Definition => New_Comp,
- Expression => Expression (Priv));
+ Expression => Expression (Priv));
+
+ Set_Has_Per_Object_Constraint (Nent,
+ Has_Per_Object_Constraint (Oent));
Append_To (Cdecls, New_Priv);
end;
Set_Protected_Body_Subprogram
(Defining_Unit_Name (Specification (Priv)),
Defining_Unit_Name (Specification (Sub)));
-
+ Check_Inlining (Defining_Unit_Name (Specification (Priv)));
Current_Node := Sub;
Sub :=
Comp := First (Visible_Declarations (Pdef));
while Present (Comp) loop
- if Nkind (Comp) = N_Subprogram_Declaration
- and then not Is_Eliminated (Defining_Entity (Comp))
- then
+ if Nkind (Comp) = N_Subprogram_Declaration then
Sub :=
Make_Subprogram_Declaration (Loc,
Specification =>
Set_Protected_Body_Subprogram
(Defining_Unit_Name (Specification (Comp)),
Defining_Unit_Name (Specification (Sub)));
+ Check_Inlining (Defining_Unit_Name (Specification (Comp)));
-- Make the protected version of the subprogram available for
-- expansion of external calls.
S : Entity_Id; -- Primitive operation slot
begin
+ -- Under the Ravenscar profile, timed entry calls are excluded. An error
+ -- was already reported on spec, so do not attempt to expand the call.
+
+ if Restriction_Active (No_Select_Statements) then
+ return;
+ end if;
+
-- The arguments in the call may require dynamic allocation, and the
-- call statement may have been transformed into a block. The block
-- may contain additional declarations for internal entities, and the