-- Ada 2005 (AI-287): If the ancestor part is an aggregate of
-- limited type, a recursive call expands the ancestor. Note that
-- in the limited case, the ancestor part must be either a
- -- function call (possibly qualified) or aggregate (definitely
- -- qualified).
+ -- function call (possibly qualified, or wrapped in an unchecked
+ -- conversion) or aggregate (definitely qualified).
elsif Is_Limited_Type (Etype (A))
and then Nkind (Unqualify (A)) /= N_Function_Call -- aggregate?
+ and then
+ (Nkind (Unqualify (A)) /= N_Unchecked_Type_Conversion
+ or else
+ Nkind (Expression (Unqualify (A))) /= N_Function_Call)
then
Ancestor_Is_Expression := True;
(Typ : Entity_Id;
Operation : TSS_Name_Type) return Boolean
is
- Has_Inheritable_Stream_Attribute : Boolean := False;
+ Has_Predefined_Or_Specified_Stream_Attribute : Boolean := False;
begin
+ -- Special case of a limited type extension: a default implementation
+ -- of the stream attributes Read or Write exists if that attribute
+ -- has been specified or is available for an ancestor type; a default
+ -- implementation of the attribute Output (resp. Input) exists if the
+ -- attribute has been specified or Write (resp. Read) is available for
+ -- an ancestor type. The last condition only applies under Ada 2005.
+
if Is_Limited_Type (Typ)
and then Is_Tagged_Type (Typ)
- and then Is_Derived_Type (Typ)
then
- -- Special case of a limited type extension: a default implementation
- -- of the stream attributes Read and Write exists if the attribute
- -- has been specified for an ancestor type.
+ if Operation = TSS_Stream_Read then
+ Has_Predefined_Or_Specified_Stream_Attribute :=
+ Has_Specified_Stream_Read (Typ);
+
+ elsif Operation = TSS_Stream_Write then
+ Has_Predefined_Or_Specified_Stream_Attribute :=
+ Has_Specified_Stream_Write (Typ);
+
+ elsif Operation = TSS_Stream_Input then
+ Has_Predefined_Or_Specified_Stream_Attribute :=
+ Has_Specified_Stream_Input (Typ)
+ or else
+ (Ada_Version >= Ada_05
+ and then Stream_Operation_OK (Typ, TSS_Stream_Read));
+
+ elsif Operation = TSS_Stream_Output then
+ Has_Predefined_Or_Specified_Stream_Attribute :=
+ Has_Specified_Stream_Output (Typ)
+ or else
+ (Ada_Version >= Ada_05
+ and then Stream_Operation_OK (Typ, TSS_Stream_Write));
+ end if;
+
+ -- Case of inherited TSS_Stream_Read or TSS_Stream_Write
- Has_Inheritable_Stream_Attribute :=
- Present (Find_Inherited_TSS (Base_Type (Etype (Typ)), Operation));
+ if not Has_Predefined_Or_Specified_Stream_Attribute
+ and then Is_Derived_Type (Typ)
+ and then (Operation = TSS_Stream_Read
+ or else Operation = TSS_Stream_Write)
+ then
+ Has_Predefined_Or_Specified_Stream_Attribute :=
+ Present
+ (Find_Inherited_TSS (Base_Type (Etype (Typ)), Operation));
+ end if;
end if;
- return
- not (Is_Limited_Type (Typ)
- and then not Has_Inheritable_Stream_Attribute)
- and then not Has_Unknown_Discriminants (Typ)
- and then not (Is_Interface (Typ)
- and then (Is_Task_Interface (Typ)
- or else Is_Protected_Interface (Typ)
- or else Is_Synchronized_Interface (Typ)))
- and then not Restriction_Active (No_Streams)
- and then not Restriction_Active (No_Dispatch)
- and then not No_Run_Time_Mode
- and then RTE_Available (RE_Tag)
- and then RTE_Available (RE_Root_Stream_Type);
+ return (not Is_Limited_Type (Typ)
+ or else Has_Predefined_Or_Specified_Stream_Attribute)
+ and then not Has_Unknown_Discriminants (Typ)
+ and then not (Is_Interface (Typ)
+ and then (Is_Task_Interface (Typ)
+ or else Is_Protected_Interface (Typ)
+ or else Is_Synchronized_Interface (Typ)))
+ and then not Restriction_Active (No_Streams)
+ and then not Restriction_Active (No_Dispatch)
+ and then not No_Run_Time_Mode
+ and then RTE_Available (RE_Tag)
+ and then RTE_Available (RE_Root_Stream_Type);
end Stream_Operation_OK;
+
end Exp_Ch3;
Call : Node_Id;
Conctyp : Entity_Id;
Ent : Entity_Id;
- Object_Parm : Node_Id;
Subprg : Entity_Id;
RT_Subprg_Name : Node_Id;
end loop;
-- The attribute Priority applied to protected objects has been
- -- previously expanded into calls to the Get_Ceiling run-time
+ -- previously expanded into a call to the Get_Ceiling run-time
-- subprogram.
if Nkind (Ent) = N_Function_Call
Subprg := Scope (Subprg);
end loop;
- Object_Parm :=
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix => New_Reference_To
- (First_Entity
- (Protected_Body_Subprogram (Subprg)),
- Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_uObject)),
- Attribute_Name => Name_Unchecked_Access);
-
-- Select the appropriate run-time call
if Number_Entries (Conctyp) = 0 then
Call :=
Make_Procedure_Call_Statement (Loc,
Name => RT_Subprg_Name,
- Parameter_Associations =>
- New_List (Object_Parm,
- Relocate_Node (Expression (N))));
+ Parameter_Associations => New_List (
+ New_Copy_Tree (First (Parameter_Associations (Ent))),
+ Relocate_Node (Expression (N))));
Rewrite (N, Call);
Analyze (N);
-- We do not need to reanalyze that assignment, and we do not need
-- to worry about references to the temporary, but we do need to
-- make sure that the temporary is not marked as a true constant
- -- since we now have a generate assignment to it!
+ -- since we now have a generated assignment to it!
Set_Is_True_Constant (Tnn, False);
end;
end if;
- -- When we have the appropriate type of aggregate in the
- -- expression (it has been determined during analysis of the
- -- aggregate by setting the delay flag), let's perform in place
- -- assignment and thus avoid creating a temporay.
+ -- When we have the appropriate type of aggregate in the expression (it
+ -- has been determined during analysis of the aggregate by setting the
+ -- delay flag), let's perform in place assignment and thus avoid
+ -- creating a temporary.
if Is_Delayed_Aggregate (Rhs) then
Convert_Aggr_In_Assignment (N);
Make_Build_In_Place_Call_In_Assignment (N, Rhs);
elsif Is_Tagged_Type (Typ) and then Is_Value_Type (Etype (Lhs)) then
+
-- Nothing to do for valuetypes
-- ??? Set_Scope_Is_Transient (False);
+
return;
elsif Is_Tagged_Type (Typ)
elsif Is_Entity_Name (Lhs)
and then Is_Known_Valid (Entity (Lhs))
then
- -- Note that the Ensure_Valid call is ignored if the
- -- Validity_Checking mode is set to none so we do not
- -- need to worry about that case here.
+ -- Note: If Validity_Checking mode is set to none, we ignore
+ -- the Ensure_Valid call so don't worry about that case here.
Ensure_Valid (Rhs);
or else Is_Composite_Type (Etype (Parent_Function))
or else No (Exp)
then
- Statements := New_List;
+ if No (Handled_Stm_Seq) then
+ Statements := New_List;
+
+ -- If the extended return has a handled statement sequence, then wrap
+ -- it in a block and use the block as the first statement.
- if Present (Handled_Stm_Seq) then
- Append_To (Statements, Handled_Stm_Seq);
+ else
+ Statements :=
+ New_List (Make_Block_Statement (Loc,
+ Declarations => New_List,
+ Handled_Statement_Sequence => Handled_Stm_Seq));
end if;
-- If control gets past the above Statements, we have successfully
-- function to have a flag or a Uint attribute to identify it. ???
loop
+ pragma Assert (Present (Extra_Formal));
exit when
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;
return Extra_Formal;
-- The protected subprogram is declared outside of the protected
-- body. Given that the body has frozen all entities so far, we
-- analyze the subprogram and perform freezing actions explicitly.
+ -- including the generation of an explicit freeze node, to ensure
+ -- that gigi has the proper order of elaboration.
-- If the body is a subunit, the insertion point is before the
-- stub in the parent.
Insert_Before (Prot_Bod, Prot_Decl);
Prot_Id := Defining_Unit_Name (Specification (Prot_Decl));
+ Set_Has_Delayed_Freeze (Prot_Id);
Push_Scope (Scope (Scop));
Analyze (Prot_Decl);
- Create_Extra_Formals (Prot_Id);
+ Insert_Actions (N, Freeze_Entity (Prot_Id, Loc));
Set_Protected_Body_Subprogram (Subp, Prot_Id);
Pop_Scope;
end if;
Function_Id : Entity_Id;
begin
- if Nkind (Exp_Node) = N_Qualified_Expression then
+ -- Step past qualification or unchecked conversion (the latter can occur
+ -- in cases of calls to 'Input).
+
+ if Nkind (Exp_Node) = N_Qualified_Expression
+ or else Nkind (Exp_Node) = N_Unchecked_Type_Conversion
+ then
Exp_Node := Expression (N);
end if;
Return_Obj_Access : Entity_Id;
begin
- if Nkind (Func_Call) = N_Qualified_Expression then
+ -- Step past qualification or unchecked conversion (the latter can occur
+ -- in cases of calls to 'Input).
+
+ if Nkind (Func_Call) = N_Qualified_Expression
+ or else Nkind (Func_Call) = N_Unchecked_Type_Conversion
+ then
Func_Call := Expression (Func_Call);
end if;
Return_Obj_Decl : Entity_Id;
begin
- if Nkind (Func_Call) = N_Qualified_Expression then
+ -- Step past qualification or unchecked conversion (the latter can occur
+ -- in cases of calls to 'Input).
+
+ if Nkind (Func_Call) = N_Qualified_Expression
+ or else Nkind (Func_Call) = N_Unchecked_Type_Conversion
+ then
Func_Call := Expression (Func_Call);
end if;
New_Expr : Node_Id;
begin
- if Nkind (Func_Call) = N_Qualified_Expression then
+ -- Step past qualification or unchecked conversion (the latter can occur
+ -- in cases of calls to 'Input).
+
+ if Nkind (Func_Call) = N_Qualified_Expression
+ or else Nkind (Func_Call) = N_Unchecked_Type_Conversion
+ then
Func_Call := Expression (Func_Call);
end if;
Pass_Caller_Acc : Boolean := False;
begin
- if Nkind (Func_Call) = N_Qualified_Expression then
+ -- Step past qualification or unchecked conversion (the latter can occur
+ -- in cases of calls to 'Input).
+
+ if Nkind (Func_Call) = N_Qualified_Expression
+ or else Nkind (Func_Call) = N_Unchecked_Type_Conversion
+ then
Func_Call := Expression (Func_Call);
end if;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
+with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
Odef := New_Occurrence_Of (Typ, Loc);
end if;
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
- Object_Definition => Odef));
+ -- For Ada 2005 we create an extended return statement encapsulating
+ -- the result object and 'Read call, which is needed in general for
+ -- proper handling of build-in-place results (such as when the result
+ -- type is inherently limited).
+
+ -- Perhaps we should just generate an extended return in all cases???
+
+ if Ada_Version >= Ada_05 then
+ Stms := New_List (
+ Make_Extended_Return_Statement (Loc,
+ Return_Object_Declarations =>
+ New_List (Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_V),
+ Object_Definition => Odef)),
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ New_List (Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Typ, Loc),
+ Attribute_Name => Name_Read,
+ Expressions => New_List (
+ Make_Identifier (Loc, Name_S),
+ Make_Identifier (Loc, Name_V)))))));
- Stms := New_List (
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Typ, Loc),
- Attribute_Name => Name_Read,
- Expressions => New_List (
- Make_Identifier (Loc, Name_S),
- Make_Identifier (Loc, Name_V))),
+ else
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
+ Object_Definition => Odef));
- Make_Simple_Return_Statement (Loc,
- Expression => Make_Identifier (Loc, Name_V)));
+ Stms := New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Typ, Loc),
+ Attribute_Name => Name_Read,
+ Expressions => New_List (
+ Make_Identifier (Loc, Name_S),
+ Make_Identifier (Loc, Name_V))),
+
+ Make_Simple_Return_Statement (Loc,
+ Expression => Make_Identifier (Loc, Name_V)));
+ end if;
Fnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Input);
-- itype, so that gigi can elaborate it on the proper objstack.
if Is_Itype (Typ)
- and then Scope (Typ) = Current_Scope
+ and then Scope (Typ) = Current_Scope
then
IR := Make_Itype_Reference (Sloc (N));
Set_Itype (IR, Typ);
N_Private_Extension_Declaration |
N_Private_Type_Declaration |
N_Procedure_Instantiation |
+ N_Protected_Body |
N_Protected_Body_Stub |
N_Protected_Type_Declaration |
N_Single_Task_Declaration |
N_Pop_Storage_Error_Label |
N_Pragma_Argument_Association |
N_Procedure_Specification |
- N_Protected_Body |
N_Protected_Definition |
N_Push_Constraint_Error_Label |
N_Push_Program_Error_Label |
-------------------------------------------------------------------------------
+-----------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- Set True if we find at least one component with a component
-- clause (used to warn about useless Bit_Order pragmas).
+ function Check_Allocator (N : Node_Id) return Boolean;
+ -- Returns True if N is an expression or a qualified expression with
+ -- an allocator.
+
procedure Check_Itype (Typ : Entity_Id);
-- If the component subtype is an access to a constrained subtype of
-- an already frozen type, make the subtype frozen as well. It might
-- freeze node at some eventual point of call. Protected operations
-- are handled elsewhere.
+ ---------------------
+ -- Check_Allocator --
+ ---------------------
+
+ function Check_Allocator (N : Node_Id) return Boolean is
+ begin
+ if Nkind (N) = N_Allocator then
+ return True;
+ elsif Nkind (N) = N_Qualified_Expression then
+ return Check_Allocator (Expression (N));
+ else
+ return False;
+ end if;
+ end Check_Allocator;
+
-----------------
-- Check_Itype --
-----------------
elsif Is_Access_Type (Etype (Comp))
and then Present (Parent (Comp))
and then Present (Expression (Parent (Comp)))
- and then Nkind (Expression (Parent (Comp))) = N_Allocator
+ and then Check_Allocator (Expression (Parent (Comp)))
then
declare
- Alloc : constant Node_Id := Expression (Parent (Comp));
+ Alloc : Node_Id;
begin
- -- If component is pointer to a classwide type, freeze
- -- the specific type in the expression being allocated.
- -- The expression may be a subtype indication, in which
- -- case freeze the subtype mark.
+ -- Handle qualified expressions
+
+ Alloc := Expression (Parent (Comp));
+ while Nkind (Alloc) /= N_Allocator loop
+ pragma Assert (Nkind (Alloc) = N_Qualified_Expression);
+ Alloc := Expression (Alloc);
+ end loop;
+
+ -- If component is pointer to a classwide type, freeze the
+ -- specific type in the expression being allocated. The
+ -- expression may be a subtype indication, in which case
+ -- freeze the subtype mark.
if Is_Class_Wide_Type (Designated_Type (Etype (Comp))) then
if Is_Entity_Name (Expression (Alloc)) then
-- The two-pass elaboration mechanism in gigi guarantees that E will
-- be frozen before the inner call is elaborated. We exclude constants
-- from this test, because deferred constants may be frozen early, and
- -- must be diagnosed (see e.g. 1522-005). If the enclosing subprogram
- -- comes from source, or is a generic instance, then the freeze point
- -- is the one mandated by the language. and we freze the entity.
- -- A subprogram that is a child unit body that acts as a spec does not
- -- have a spec that comes from source, but can only come from source.
+ -- must be diagnosed (e.g. in the case of a deferred constant being used
+ -- in a default expression). If the enclosing subprogram comes from
+ -- source, or is a generic instance, then the freeze point is the one
+ -- mandated by the language, and we freeze the entity. A subprogram that
+ -- is a child unit body that acts as a spec does not have a spec that
+ -- comes from source, but can only come from source.
elsif In_Open_Scopes (Scope (Test_E))
and then Scope (Test_E) /= Current_Scope
Freeze_And_Append (Alias (E), Loc, Result);
end if;
- if not Is_Internal (E) then
+ -- We don't freeze internal subprograms, because we don't normally
+ -- want addition of extra formals or mechanism setting to happen
+ -- for those. However we do pass through predefined dispatching
+ -- cases, since extra formals may be needed in some cases, such as
+ -- for the stream 'Input function (build-in-place formals).
+
+ if not Is_Internal (E)
+ or else Is_Predefined_Dispatching_Operation (E)
+ then
Freeze_Subprogram (E);
end if;
("not type conformant with declaration#!", Enode);
when Mode_Conformant =>
- Error_Msg_N
- ("not mode conformant with declaration#!", Enode);
+ if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then
+ Error_Msg_N
+ ("not mode conformant with operation inherited#!",
+ Enode);
+ else
+ Error_Msg_N
+ ("not mode conformant with declaration#!", Enode);
+ end if;
when Subtype_Conformant =>
- Error_Msg_N
- ("not subtype conformant with declaration#!", Enode);
+ if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then
+ Error_Msg_N
+ ("not subtype conformant with operation inherited#!",
+ Enode);
+ else
+ Error_Msg_N
+ ("not subtype conformant with declaration#!", Enode);
+ end if;
when Fully_Conformant =>
- Error_Msg_N
- ("not fully conformant with declaration#!", Enode);
+ if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then
+ Error_Msg_N
+ ("not fully conformant with operation inherited#!",
+ Enode);
+ else
+ Error_Msg_N
+ ("not fully conformant with declaration#!", Enode);
+ end if;
end case;
Error_Msg_NE (Msg, Enode, N);
return;
end if;
+ -- If the subprogram is a predefined dispatching subprogram then don't
+ -- generate any extra constrained or accessibility level formals. In
+ -- general we suppress these for internal subprograms (by not calling
+ -- Freeze_Subprogram and Create_Extra_Formals at all), but internally
+ -- generated stream attributes do get passed through because extra
+ -- build-in-place formals are needed in some cases (limited 'Input).
+
+ if Is_Predefined_Dispatching_Operation (E) then
+ goto Test_For_BIP_Extras;
+ end if;
+
Formal := First_Formal (E);
while Present (Formal) loop
Next_Formal (Formal);
end loop;
+ <<Test_For_BIP_Extras>>
+
-- Ada 2005 (AI-318-02): In the case of build-in-place functions, add
-- appropriate extra formals. See type Exp_Ch6.BIP_Formal_Kind.