-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-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- --
Index : Positive) return Character
is
begin
- if Index in 1 .. Source.Current_Length then
+ if Index <= Source.Current_Length then
return Source.Data (Index);
else
raise Strings.Index_Error;
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-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- --
Index : Positive) return Wide_Character
is
begin
- if Index in 1 .. Source.Current_Length then
+ if Index <= Source.Current_Length then
return Source.Data (Index);
else
raise Strings.Index_Error;
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-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- --
Index : Positive) return Wide_Wide_Character
is
begin
- if Index in 1 .. Source.Current_Length then
+ if Index <= Source.Current_Length then
return Source.Data (Index);
else
raise Strings.Index_Error;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Exp_VFpt; use Exp_VFpt;
+with Namet; use Namet;
with Nmake; use Nmake;
with Opt; use Opt;
with Sem; use Sem;
-with Sem_Attr; use Sem_Attr;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
+with Snames; use Snames;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
procedure Expand_Entry_Parameter (N : Node_Id);
-- A reference to an entry parameter is modified to be a reference to the
-- corresponding component of the entry parameter record that is passed by
- -- the runtime to the accept body procedure
+ -- the runtime to the accept body procedure.
procedure Expand_Formal (N : Node_Id);
-- A reference to a formal parameter of a protected subprogram is expanded
-- into the corresponding formal of the unprotected procedure used to
-- represent the operation within the protected object. In other cases
- -- Expand_Formal is a noop.
+ -- Expand_Formal is a no-op.
procedure Expand_Protected_Private (N : Node_Id);
-- A reference to a private component of a protected type is expanded to a
and then Nkind (Parent (N)) /= N_Pragma_Argument_Association
- -- Same for attribute references that require a simple name prefix
+ -- Do not replace the prefixes of attribute references, since this
+ -- causes trouble with cases like 4'Size. Also for Name_Asm_Input and
+ -- Name_Asm_Output, don't do replacement anywhere, since we can have
+ -- lvalue references in the arguments.
and then not (Nkind (Parent (N)) = N_Attribute_Reference
- and then Requires_Simple_Name_Prefix (
- Attribute_Name (Parent (N))))
+ and then
+ (Attribute_Name (Parent (N)) = Name_Asm_Input
+ or else
+ Attribute_Name (Parent (N)) = Name_Asm_Output
+ or else
+ Prefix (Parent (N)) = N))
then
-- Case of Current_Value is a compile time known value
function In_Assignment_Context (N : Node_Id) return Boolean is
begin
+ -- Case of use in a call
+
+ -- ??? passing a formal as actual for a mode IN formal is
+ -- considered as an assignment?
+
if Nkind (Parent (N)) = N_Procedure_Call_Statement
or else Nkind (Parent (N)) = N_Entry_Call_Statement
or else
then
return True;
+ -- Case of a parameter association: climb up to enclosing call
+
elsif Nkind (Parent (N)) = N_Parameter_Association then
return In_Assignment_Context (Parent (N));
+ -- Case of a selected component, indexed component or slice prefix:
+ -- climb up the tree, unless the prefix is of an access type (in
+ -- which case there is an implicit dereference, and the formal itself
+ -- is not being assigned to).
+
elsif (Nkind (Parent (N)) = N_Selected_Component
or else Nkind (Parent (N)) = N_Indexed_Component
or else Nkind (Parent (N)) = N_Slice)
+ and then N = Prefix (Parent (N))
+ and then not Is_Access_Type (Etype (N))
and then In_Assignment_Context (Parent (N))
then
return True;
+
else
return False;
end if;
-- through an address clause is rewritten as dereference as well.
function Param_Entity (N : Node_Id) return Entity_Id is
+ Renamed_Obj : Node_Id;
+
begin
-- Simple reference case
if Is_Formal (Entity (N)) then
return Entity (N);
- elsif Nkind (Parent (Entity (N))) = N_Object_Renaming_Declaration
- and then Nkind (Parent (Parent (Entity (N)))) = N_Accept_Statement
- then
- return Entity (N);
+ -- Handle renamings of formal parameters and formals of tasks that
+ -- are rewritten as renamings.
+
+ elsif Nkind (Parent (Entity (N))) = N_Object_Renaming_Declaration then
+ Renamed_Obj := Get_Referenced_Object (Renamed_Object (Entity (N)));
+
+ if Is_Entity_Name (Renamed_Obj)
+ and then Is_Formal (Entity (Renamed_Obj))
+ then
+ return Entity (Renamed_Obj);
+
+ elsif
+ Nkind (Parent (Parent (Entity (N)))) = N_Accept_Statement
+ then
+ return Entity (N);
+ end if;
end if;
else
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-1997 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- --
-- Given an expression N, determines if the expression is a reference
-- to a formal (of a subprogram or entry), and if so returns the Id
-- of the corresponding formal entity, otherwise returns Empty. The
- -- reason that this is in Exp_Ch2 is that it has to deal with the
- -- case where the reference is to an entry formal, and has been
- -- expanded already. Since Exp_Ch2 is in charge of the expansion, it
- -- is best suited to knowing how to detect this case.
+ -- reason that this is in Exp_Ch2 is that it has to deal with the case
+ -- where the reference is to an entry formal, and has been expanded
+ -- already. Since Exp_Ch2 is in charge of the expansion, it is best
+ -- suited to knowing how to detect this case. Also handles the case
+ -- of references to renamings of formals.
end Exp_Ch2;
Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT);
end if;
- Convert_Aggr_In_Allocator (Tmp_Node, Exp);
+ Convert_Aggr_In_Allocator (N, Tmp_Node, Exp);
else
Node := Relocate_Node (N);
Set_Analyzed (Node);
Get_Allocator_Final_List (N, Base_Type (T), PtrT);
end if;
- Convert_Aggr_In_Allocator (Tmp_Node, Exp);
+ Convert_Aggr_In_Allocator (N, Tmp_Node, Exp);
else
Node := Relocate_Node (N);
Set_Analyzed (Node);
Set_No_Initialization (Expression (Tmp_Node));
Insert_Action (N, Tmp_Node);
- Convert_Aggr_In_Allocator (Tmp_Node, Exp);
+ Convert_Aggr_In_Allocator (N, Tmp_Node, Exp);
Rewrite (N, New_Reference_To (Temp, Loc));
Analyze_And_Resolve (N, PtrT);
Make_Implicit_If_Statement (Nod,
Condition => Make_Op_Not (Loc, Right_Opnd => Test),
Then_Statements => New_List (
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (Standard_False, Loc))));
end if;
end Component_Equality;
Make_Implicit_If_Statement (Nod,
Condition => Test_Empty_Arrays,
Then_Statements => New_List (
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression =>
New_Occurrence_Of (Standard_True, Loc)))),
Make_Implicit_If_Statement (Nod,
Condition => Test_Lengths_Correspond,
Then_Statements => New_List (
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression =>
New_Occurrence_Of (Standard_False, Loc)))),
Handle_One_Dimension (1, First_Index (Ltyp)),
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (Standard_True, Loc)))));
Set_Has_Completion (Func_Name, True);
Condition => S_Length_Test (1),
Then_Statements => New_List (Init_L (1)),
Elsif_Parts => Elsif_List,
- Else_Statements => New_List (Make_Return_Statement (Loc,
+ Else_Statements => New_List (Make_Simple_Return_Statement (Loc,
Expression => S (Nb_Opnds))));
-- Construct the declaration for H
Then_Statements => Copy_Into_R_S (I, I = Nb_Opnds)));
end loop;
- Append_To (Declare_Stmts, Make_Return_Statement (Loc, Expression => R));
+ Append_To
+ (Declare_Stmts, Make_Simple_Return_Statement (Loc, Expression => R));
-- Construct the declare block
P := Parent (N);
while Present (P) loop
if Nkind (P) = N_Extended_Return_Statement
- or else Nkind (P) = N_Return_Statement
+ or else Nkind (P) = N_Simple_Return_Statement
then
return True;
-- Postpone the generation of a finalization call for the
-- current allocator if it acts as a coextension.
- if Is_Coextension (N) then
+ if Is_Dynamic_Coextension (N) then
if No (Coextensions (N)) then
Set_Coextensions (N, New_Elmt_List);
end if;
Lo : constant Node_Id := Low_Bound (Rop);
Hi : constant Node_Id := High_Bound (Rop);
+ Ltyp : constant Entity_Id := Etype (Lop);
+
Lo_Orig : constant Node_Id := Original_Node (Lo);
Hi_Orig : constant Node_Id := Original_Node (Hi);
Lcheck : constant Compare_Result := Compile_Time_Compare (Lop, Lo);
Ucheck : constant Compare_Result := Compile_Time_Compare (Lop, Hi);
+ Warn1 : constant Boolean :=
+ Constant_Condition_Warnings
+ and then Comes_From_Source (N);
+ -- This must be true for any of the optimization warnings, we
+ -- clearly want to give them only for source with the flag on.
+
+ Warn2 : constant Boolean :=
+ Warn1
+ and then Nkind (Original_Node (Rop)) = N_Range
+ and then Is_Integer_Type (Etype (Lo));
+ -- For the case where only one bound warning is elided, we also
+ -- insist on an explicit range and an integer type. The reason is
+ -- that the use of enumeration ranges including an end point is
+ -- common, as is the use of a subtype name, one of whose bounds
+ -- is the same as the type of the expression.
+
begin
-- If test is explicit x'first .. x'last, replace by valid check
- if Is_Scalar_Type (Etype (Lop))
+ if Is_Scalar_Type (Ltyp)
and then Nkind (Lo_Orig) = N_Attribute_Reference
and then Attribute_Name (Lo_Orig) = Name_First
and then Nkind (Prefix (Lo_Orig)) in N_Has_Entity
- and then Entity (Prefix (Lo_Orig)) = Etype (Lop)
+ and then Entity (Prefix (Lo_Orig)) = Ltyp
and then Nkind (Hi_Orig) = N_Attribute_Reference
and then Attribute_Name (Hi_Orig) = Name_Last
and then Nkind (Prefix (Hi_Orig)) in N_Has_Entity
- and then Entity (Prefix (Hi_Orig)) = Etype (Lop)
+ and then Entity (Prefix (Hi_Orig)) = Ltyp
and then Comes_From_Source (N)
and then VM_Target = No_VM
then
return;
end if;
+ -- If bounds of type are known at compile time, and the end points
+ -- are known at compile time and identical, this is another case
+ -- for substituting a valid test. We only do this for discrete
+ -- types, since it won't arise in practice for float types.
+
+ if Comes_From_Source (N)
+ and then Is_Discrete_Type (Ltyp)
+ and then Compile_Time_Known_Value (Type_High_Bound (Ltyp))
+ and then Compile_Time_Known_Value (Type_Low_Bound (Ltyp))
+ and then Compile_Time_Known_Value (Lo)
+ and then Compile_Time_Known_Value (Hi)
+ and then Expr_Value (Type_High_Bound (Ltyp)) = Expr_Value (Hi)
+ and then Expr_Value (Type_Low_Bound (Ltyp)) = Expr_Value (Lo)
+ then
+ Substitute_Valid_Check;
+ return;
+ end if;
+
-- If we have an explicit range, do a bit of optimization based
-- on range analysis (we may be able to kill one or both checks).
-- legality checks, because we are constant-folding beyond RM 4.9.
if Lcheck = LT or else Ucheck = GT then
+ if Warn1 then
+ Error_Msg_N ("?range test optimized away", N);
+ Error_Msg_N ("\?value is known to be out of range", N);
+ end if;
+
Rewrite (N,
New_Reference_To (Standard_False, Loc));
Analyze_And_Resolve (N, Rtyp);
Set_Is_Static_Expression (N, Static);
+
return;
-- If both checks are known to succeed, replace result
-- by True, since we know we are in range.
elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
+ if Warn1 then
+ Error_Msg_N ("?range test optimized away", N);
+ Error_Msg_N ("\?value is known to be in range", N);
+ end if;
+
Rewrite (N,
New_Reference_To (Standard_True, Loc));
Analyze_And_Resolve (N, Rtyp);
Set_Is_Static_Expression (N, Static);
+
return;
- -- If lower bound check succeeds and upper bound check is
- -- not known to succeed or fail, then replace the range check
- -- with a comparison against the upper bound.
+ -- If lower bound check succeeds and upper bound check is not
+ -- known to succeed or fail, then replace the range check with
+ -- a comparison against the upper bound.
elsif Lcheck in Compare_GE then
+ if Warn2 then
+ Error_Msg_N ("?lower bound test optimized away", Lo);
+ Error_Msg_N ("\?value is known to be in range", Lo);
+ end if;
+
Rewrite (N,
Make_Op_Le (Loc,
Left_Opnd => Lop,
Right_Opnd => High_Bound (Rop)));
Analyze_And_Resolve (N, Rtyp);
+
return;
- -- If upper bound check succeeds and lower bound check is
- -- not known to succeed or fail, then replace the range check
- -- with a comparison against the lower bound.
+ -- If upper bound check succeeds and lower bound check is not
+ -- known to succeed or fail, then replace the range check with
+ -- a comparison against the lower bound.
elsif Ucheck in Compare_LE then
+ if Warn2 then
+ Error_Msg_N ("?upper bound test optimized away", Hi);
+ Error_Msg_N ("\?value is known to be in range", Hi);
+ end if;
+
Rewrite (N,
Make_Op_Ge (Loc,
Left_Opnd => Lop,
Right_Opnd => Low_Bound (Rop)));
Analyze_And_Resolve (N, Rtyp);
+
return;
end if;
end;
Right_Opnd =>
Make_In (Loc,
Left_Opnd => Left_Opnd (N),
- Right_Opnd => Right_Opnd (N))));
+ Right_Opnd => Right_Opnd (N))));
- -- We want this tp appear as coming from source if original does (see
+ -- We want this to appear as coming from source if original does (see
-- tranformations in Expand_N_In).
Set_Comes_From_Source (N, Cfs);
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Loop_Statement,
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression =>
Make_Identifier (Loc, Chars (B)))))));
if Is_Access_Type (Target_Type) then
- -- Apply an accessibility check if the operand is an
- -- access parameter. Note that other checks may still
- -- need to be applied below (such as tagged type checks).
+ -- Apply an accessibility check when the conversion operand is an
+ -- access parameter (or a renaming thereof), unless conversion was
+ -- expanded from an unchecked or unrestricted access attribute. Note
+ -- that other checks may still need to be applied below (such as
+ -- tagged type checks).
if Is_Entity_Name (Operand)
- and then Ekind (Entity (Operand)) in Formal_Kind
+ and then
+ (Is_Formal (Entity (Operand))
+ or else
+ (Present (Renamed_Object (Entity (Operand)))
+ and then Is_Entity_Name (Renamed_Object (Entity (Operand)))
+ and then Is_Formal
+ (Entity (Renamed_Object (Entity (Operand))))))
and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type
+ and then (Nkind (Original_Node (N)) /= N_Attribute_Reference
+ or else Attribute_Name (Original_Node (N)) = Name_Access)
then
Apply_Accessibility_Check (Operand, Target_Type);
-- Case of an access discriminant, or (Ada 2005), of an anonymous
-- access component or anonymous access function result: find the
- -- final list associated with the scope of the type.
+ -- final list associated with the scope of the type. (In the
+ -- anonymous access component kind, a list controller will have
+ -- been allocated when freezing the record type, and PtrT has an
+ -- Associated_Final_Chain attribute designating it.)
- else
+ elsif No (Associated_Final_Chain (PtrT)) then
Owner := Scope (PtrT);
end if;
end if;
Then_Statements => New_List (Inner_If),
Else_Statements => New_List (
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression =>
Make_Op_Gt (Loc,
Left_Opnd =>
Then_Statements =>
New_List (
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression => New_Reference_To (Standard_False, Loc))),
Elsif_Parts => New_List (
Then_Statements =>
New_List (
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression => New_Reference_To (Standard_True, Loc))))),
Else_Statements => New_List (
Loop_Statement,
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression => Final_Expr)));
-- (X : a; Y: a)
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Loop_Statement,
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression => New_Reference_To (C, Loc)))));
return Func_Body;
Rewrite (Actual, New_Reference_To (Temp, Loc));
Analyze (Actual);
- Append_To (Post_Call,
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Var, Loc),
- Expression => Expr));
+ -- If the actual is a conversion of a packed reference, it may
+ -- already have been expanded by Remove_Side_Effects, and the
+ -- resulting variable is a temporary which does not designate
+ -- the proper out-parameter, which may not be addressable. In
+ -- that case, generate an assignment to the original expression
+ -- (before expansion of the packed reference) so that the proper
+ -- expansion of assignment to a packed component can take place.
- Set_Assignment_OK (Name (Last (Post_Call)));
+ declare
+ Obj : Node_Id;
+ Lhs : Node_Id;
+
+ begin
+ if Is_Renaming_Of_Object (Var)
+ and then Nkind (Renamed_Object (Var)) = N_Selected_Component
+ and then Is_Entity_Name (Prefix (Renamed_Object (Var)))
+ and then Nkind (Original_Node (Prefix (Renamed_Object (Var))))
+ = N_Indexed_Component
+ and then
+ Has_Non_Standard_Rep (Etype (Prefix (Renamed_Object (Var))))
+ then
+ Obj := Renamed_Object (Var);
+ Lhs :=
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Copy_Tree (Original_Node (Prefix (Obj))),
+ Selector_Name => New_Copy (Selector_Name (Obj)));
+ Reset_Analyzed_Flags (Lhs);
+
+ else
+ Lhs := New_Occurrence_Of (Var, Loc);
+ end if;
+
+ Set_Assignment_OK (Lhs);
+
+ Append_To (Post_Call,
+ Make_Assignment_Statement (Loc,
+ Name => Lhs,
+ Expression => Expr));
+ end;
end if;
+
end Add_Call_By_Copy_Code;
----------------------------------
if Is_Entity_Name (Prev_Orig) then
- -- When passing an access parameter as the actual to another
- -- access parameter we need to pass along the actual's own
- -- associated access level parameter. This is done if we are
- -- in the scope of the formal access parameter (if this is an
- -- inlined body the extra formal is irrelevant).
-
- if Ekind (Entity (Prev_Orig)) in Formal_Kind
+ -- When passing an access parameter, or a renaming of an access
+ -- parameter, as the actual to another access parameter we need
+ -- to pass along the actual's own access level parameter. This
+ -- is done if we are within the scope of the formal access
+ -- parameter (if this is an inlined body the extra formal is
+ -- irrelevant).
+
+ if (Is_Formal (Entity (Prev_Orig))
+ or else
+ (Present (Renamed_Object (Entity (Prev_Orig)))
+ and then
+ Is_Entity_Name (Renamed_Object (Entity (Prev_Orig)))
+ and then
+ Is_Formal
+ (Entity (Renamed_Object (Entity (Prev_Orig))))))
and then Ekind (Etype (Prev_Orig)) = E_Anonymous_Access_Type
and then In_Open_Scopes (Scope (Entity (Prev_Orig)))
then
if Is_Access_Type (Etype (Formal))
and then Can_Never_Be_Null (Etype (Formal))
and then Nkind (Prev) /= N_Raise_Constraint_Error
- and then (Nkind (Prev) = N_Null
+ and then (Known_Null (Prev)
or else not Can_Never_Be_Null (Etype (Prev)))
then
Install_Null_Excluding_Check (Prev);
then
Error_Msg_NE
("tag-indeterminate expression "
- & " must have designated type& ('R'M 5.2 (6))",
+ & " must have designated type& (RM 5.2 (6))",
N, Root_Type (Etype (Name (Ass))));
else
Propagate_Tag (Name (Ass), N);
elsif Etype (N) /= Root_Type (Etype (Name (Ass))) then
Error_Msg_NE
("tag-indeterminate expression must have type&"
- & "('R'M 5.2 (6))", N, Root_Type (Etype (Name (Ass))));
+ & "(RM 5.2 (6))", N, Root_Type (Etype (Name (Ass))));
else
Propagate_Tag (Name (Ass), N);
-- In the case where the intrinsic is to be processed by the back end,
-- the call to Expand_Intrinsic_Call will do nothing, which is fine,
-- since the idea in this case is to pass the call unchanged.
+ -- If the intrinsic is an inherited unchecked conversion, and the
+ -- derived type is the target type of the conversion, we must retain
+ -- it as the return type of the expression. Otherwise the expansion
+ -- below, which uses the parent operation, will yield the wrong type.
if Is_Intrinsic_Subprogram (Subp) then
Expand_Intrinsic_Call (N, Subp);
+
+ if Nkind (N) = N_Unchecked_Type_Conversion
+ and then Parent_Subp /= Orig_Subp
+ and then Etype (Parent_Subp) /= Etype (Orig_Subp)
+ then
+ Set_Etype (N, Etype (Orig_Subp));
+ end if;
+
return;
end if;
and then
(No (Stat2)
or else
- (Nkind (Stat2) = N_Return_Statement
+ (Nkind (Stat2) = N_Simple_Return_Statement
and then No (Next (Stat2))));
end;
end if;
Rewrite (N, New_Occurrence_Of (A, Loc));
Check_Private_View (N);
- else -- numeric literal
+ -- Numeric literal
+
+ else
Rewrite (N, New_Copy (A));
end if;
end if;
return Skip;
- elsif Nkind (N) = N_Return_Statement then
-
+ elsif Nkind (N) = N_Simple_Return_Statement then
if No (Expression (N)) then
Make_Exit_Label;
- Rewrite (N, Make_Goto_Statement (Loc,
- Name => New_Copy (Lab_Id)));
+ Rewrite (N,
+ Make_Goto_Statement (Loc,
+ Name => New_Copy (Lab_Id)));
else
if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
if Is_Inherently_Limited_Type (Typ) then
return True;
- elsif Nkind (Parent (N)) /= N_Return_Statement then
+ elsif Nkind (Parent (N)) /= N_Simple_Return_Statement then
return False;
elsif Requires_Transient_Scope (Typ) then
Loc := Sloc (Last_Stm);
end if;
- Append_To (S, Make_Return_Statement (Loc));
+ Append_To (S, Make_Simple_Return_Statement (Loc));
end if;
end Add_Return;
then
Add_Discriminal_Declarations
(Declarations (N), Scop, Name_uObject, Loc);
- Add_Private_Declarations (Declarations (N), Scop, Name_uObject, Loc);
+ Add_Private_Declarations
+ (Declarations (N), Scop, Name_uObject, Loc);
-- Associate privals and discriminals with the next protected
-- operation body to be expanded. These are used to expand references
function Is_Build_In_Place_Function_Return (N : Node_Id) return Boolean is
begin
- if Nkind (N) = N_Return_Statement
+ if Nkind (N) = N_Simple_Return_Statement
or else Nkind (N) = N_Extended_Return_Statement
then
return Is_Build_In_Place_Function
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);
+ Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
if Present (Thunk_Code) then
Insert_Actions (N, New_List (
-- Local variables
Subp : constant Entity_Id := Entity (N);
- Typ : constant Entity_Id := Etype (Subp);
- Utyp : constant Entity_Id := Underlying_Type (Typ);
begin
- if not Static_Dispatch_Tables then
+ -- 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 (Subp)
+ and then not Is_Abstract_Subprogram (Subp)
+ and then Present (DTC_Entity (Subp))
+ and then Present (Scope (DTC_Entity (Subp)))
+ and then VM_Target = No_VM
+ and then not Restriction_Active (No_Dispatching_Calls)
+ and then RTE_Available (RE_Tag)
+ then
declare
- E : constant Entity_Id := Subp;
- Typ : Entity_Id;
+ Typ : constant Entity_Id := Scope (DTC_Entity (Subp));
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).
+ -- Handle private overriden primitives
- if Is_Imported (E)
- and then Convention (E) = Convention_CPP
- then
- return;
+ if not Is_CPP_Class (Typ) then
+ Check_Overriding_Operation (Subp);
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 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);
+ -- We assume that imported CPP primitives correspond with objects
+ -- whose constructor is in the CPP side; therefore we don't need
+ -- to generate code to register them in the dispatch table.
- -- Register the primitive in its dispatch table if we are not
- -- compiling under No_Dispatching_Calls restriction
+ if Is_CPP_Class (Typ) then
+ null;
- if not Restriction_Active (No_Dispatching_Calls)
- and then RTE_Available (RE_Tag)
- then
- Typ := Scope (DTC_Entity (E));
+ -- Handle CPP primitives found in derivations of CPP_Class types.
+ -- These primitives must have been inherited from some parent, and
+ -- there is no need to register them in the dispatch table because
+ -- Build_Inherit_Prims takes care of the initialization of these
+ -- slots.
- if not Is_Interface (Typ)
- or else Present (Abstract_Interface_Alias (E))
- then
- if Is_Predefined_Dispatching_Operation (E) then
- Register_Predefined_DT_Entry (E);
- end if;
+ elsif Is_Imported (Subp)
+ and then (Convention (Subp) = Convention_CPP
+ or else Convention (Subp) = Convention_C)
+ then
+ null;
+
+ -- Generate code to register the primitive in non statically
+ -- allocated dispatch tables
+
+ elsif not Static_Dispatch_Tables
+ or else not
+ Is_Library_Level_Tagged_Type (Scope (DTC_Entity (Subp)))
+ then
+ -- When a primitive is frozen, enter its name in its dispatch
+ -- table slot.
- Register_Primitive (Loc,
- Prim => E,
- Ins_Nod => N);
+ if not Is_Interface (Typ)
+ or else Present (Abstract_Interface_Alias (Subp))
+ then
+ if Is_Predefined_Dispatching_Operation (Subp) then
+ Register_Predefined_DT_Entry (Subp);
end if;
+
+ Register_Primitive (Loc,
+ Prim => Subp,
+ Ins_Nod => N);
end if;
end if;
end;
-
- -- GCC 4.1 backend
-
- else
- -- Handle private overriden primitives
-
- 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).
- if Is_Inherently_Limited_Type (Typ) then
- Set_Returns_By_Ref (Subp);
-
- elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then
- Set_Returns_By_Ref (Subp);
- end if;
+ declare
+ Typ : constant Entity_Id := Etype (Subp);
+ Utyp : constant Entity_Id := Underlying_Type (Typ);
+ begin
+ if Is_Inherently_Limited_Type (Typ) then
+ Set_Returns_By_Ref (Subp);
+ elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then
+ Set_Returns_By_Ref (Subp);
+ end if;
+ end;
end Freeze_Subprogram;
-------------------------------------------
-- Present if result type contains tasks. Master associated with
-- calling context.
BIP_Activation_Chain,
- -- Present if result type contains tasks. Caller's activation chain.
+ -- Present if result type contains tasks. Caller's activation chain
BIP_Object_Access);
-- Present for all build-in-place functions. Address at which to place
-- the return object, or null if BIP_Alloc_Form indicates
-- expression applied to such a call; otherwise returns False.
function Is_Build_In_Place_Function_Return (N : Node_Id) return Boolean;
- -- Ada 2005 (AI-318-02): Returns True if N is an N_Return_Statement or
- -- N_Extended_Return_Statement and it applies to a build-in-place function
- -- or generic function.
+ -- Ada 2005 (AI-318-02): Returns True if N is an N_Simple_Return_Statement
+ -- or N_Extended_Return_Statement and it applies to a build-in-place
+ -- function or generic function.
procedure Make_Build_In_Place_Call_In_Allocator
(Allocator : Node_Id;
-- Start of processing for Write_Info_Char_Code
begin
- if Code in 16#00# .. 16#7F# then
+ -- 00 .. 7F
+
+ if Code <= 16#7F# then
Write_Info_Char (Character'Val (Code));
- elsif Code in 16#80# .. 16#FF# then
+ -- 80 .. FF
+
+ elsif Code <= 16#FF# then
Write_Info_Char ('U');
Write_Info_Hex_Byte (Natural (Code));
+ -- 0100 .. FFFF
+
else
Write_Info_Char ('W');
Write_Info_Hex_Byte (Natural (Code / 256));
-- Prefix Of an indexed or selected component that is present in a
-- subtree rooted by an assignment statement. There is no
-- restriction of nesting of components, thus cases such as
- -- A.B(C).D are handled properly.
+ -- A.B (C).D are handled properly.
+ -- However a prefix of a dereference (either implicit or
+ -- explicit) is never considered as on a LHS.
---------------
-- Is_On_LHS --
---------------
- -- Couldn't we use Is_Lvalue or whatever it is called ???
+ -- ??? There are several routines here and there that perform a similar
+ -- (but subtly different) computation, which should be factored:
+
+ -- Sem_Util.May_Be_Lvalue
+ -- Sem_Util.Known_To_Be_Assigned
+ -- Exp_Ch2.Expand_Entry_Parameter.In_Assignment_Context
function Is_On_LHS (Node : Node_Id) return Boolean is
N : Node_Id := Node;
while Nkind (Parent (N)) /= N_Assignment_Statement loop
- -- Check whether the parent is a component and the
- -- current node is its prefix.
+ -- Check whether the parent is a component and the current node
+ -- is its prefix, but return False if the current node has an
+ -- access type, as in that case the selected or indexed component
+ -- is an implicit dereference, and the LHS is the designated
+ -- object, not the access object.
+
+ -- ??? case of a slice assignment?
+
+ -- ??? Note that in some cases this is called too early
+ -- (see comments in Sem_Ch8.Find_Direct_Name), at a point where
+ -- the tree is not fully typed yet. In that case we may lack
+ -- an Etype for N, and we must disable the check for an implicit
+ -- dereference. If the dereference is on an LHS, this causes a
+ -- false positive.
if (Nkind (Parent (N)) = N_Selected_Component
or else
Nkind (Parent (N)) = N_Indexed_Component)
and then Prefix (Parent (N)) = N
+ and then not (Present (Etype (N))
+ and then
+ Is_Access_Type (Etype (N)))
then
N := Parent (N);
else
-- a left hand side. We also set the Referenced_As_LHS flag of a
-- prefix of selected or indexed component.
- if Ekind (E) = E_Variable
+ if (Ekind (E) = E_Variable or else Is_Formal (E))
and then Is_On_LHS (N)
then
Set_Referenced_As_LHS (E);
end if;
end if;
- -- Collect inherited primitive operations that may be
- -- declared in another unit and have no visible reference
- -- in the current one.
+ -- Collect inherited primitive operations that may be declared in
+ -- another unit and have no visible reference in the current one.
if Is_Type (Ent)
and then Is_Tagged_Type (Ent)
if List = No_List then
return Empty;
else
- pragma Assert (List in First_List_Id .. Lists.Last);
+ pragma Assert (List <= Lists.Last);
return Lists.Table (List).First;
end if;
end First;
function Last (List : List_Id) return Node_Id is
begin
- pragma Assert (List in First_List_Id .. Lists.Last);
+ pragma Assert (List <= Lists.Last);
return Lists.Table (List).Last;
end Last;
function Parent (List : List_Id) return Node_Id is
begin
- pragma Assert (List in First_List_Id .. Lists.Last);
+ pragma Assert (List <= Lists.Last);
return Lists.Table (List).Parent;
end Parent;
procedure Set_Parent (List : List_Id; Node : Node_Id) is
begin
- pragma Assert (List in First_List_Id .. Lists.Last);
+ pragma Assert (List <= Lists.Last);
Lists.Table (List).Parent := Node;
end Set_Parent;
Notes := False;
- if N not in
- Atree_Private_Part.Nodes.First .. Atree_Private_Part.Nodes.Last then
+ if N > Atree_Private_Part.Nodes.Last then
Print_Str (" (no such node)");
Print_Eol;
return;
projects / platform / upstream / linaro-gcc.git / commitdiff