Commit d766cee3 by Robert Dewar Committed by Arnaud Charlet

a-stzsup.adb, [...]: Fix warnings for range tests optimized out.

2007-08-14  Robert Dewar  <dewar@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Thomas Quinot  <quinot@adacore.com>

	* a-stzsup.adb, nlists.adb, lib-util.adb, treepr.adb, 
	a-stwisu.adb, a-strsup.adb: Fix warnings for range
	tests optimized out.

	* exp_ch4.adb (Expand_N_In): Add warnings for range tests optimized out.
	(Get_Allocator_Final_List): For the case of an anonymous access type
	that has a specified Associated_Final_Chain, do not go up to the
	enclosing scope.
	(Expand_N_Type_Conversion): Test for the case of renamings of access
	parameters when deciding whether to apply a run-time accessibility
	check.
	(Convert_Aggr_In_Allocator): Use Insert_Actions to place expanded
	aggregate code before allocator, and ahead of declaration for
	temporary, to prevent access before elaboration when the allocator is
	an actual for an access parameter.
	(Expand_N_Type_Conversion): On an access type conversion involving an
	access parameter, do not apply an accessibility check when the
	operand's original node was an attribute other than 'Access. We now
	create access conversions for the expansion of 'Unchecked_Access and
	'Unrestricted_Access in certain cases and clearly accessibility should
	not be checked for those.

	* exp_ch6.ads, exp_ch6.adb (Add_Call_By_Copy_Code): For an actual that
	includes a type conversion of a packed component that has been expanded,
	recover the original expression for the object, and use this expression
	in the post-call assignment statement, so that the assignment is made
	to the object and not to a back-end temporary.
	(Freeze_Subprogram): In case of primitives of tagged types not defined
	at the library level force generation of code to register the primitive
	in the dispatch table. In addition some code reorganization has been
	done to leave the implementation clear.
	(Expand_Call): When expanding an inherited implicit conversion,
	preserve the type of the inherited function after the intrinsic
	operation has been expanded.

	* exp_ch2.ads, exp_ch2.adb
	(Expand_Entry_Parameter.In_Assignment_Context): An implicit dereference
	of an entry formal appearing in an assignment statement does not assign
	to the formal.
	(Expand_Current_Value): Instead of calling a routine to determine
	whether the prefix of an attribute reference should be optimized or
	not, prevent the optimization of such prefixes all together.

	* lib-xref.adb (Generate_Reference.Is_On_LHS): An indexed or selected
	component whose prefix is known to be of an access type is an implicit
	dereference and does not assign to the prefix.

From-SVN: r127411
parent 939c12d2
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -783,7 +783,7 @@ package body Ada.Strings.Superbounded is ...@@ -783,7 +783,7 @@ package body Ada.Strings.Superbounded is
Index : Positive) return Character Index : Positive) return Character
is is
begin begin
if Index in 1 .. Source.Current_Length then if Index <= Source.Current_Length then
return Source.Data (Index); return Source.Data (Index);
else else
raise Strings.Index_Error; raise Strings.Index_Error;
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -784,7 +784,7 @@ package body Ada.Strings.Wide_Superbounded is ...@@ -784,7 +784,7 @@ package body Ada.Strings.Wide_Superbounded is
Index : Positive) return Wide_Character Index : Positive) return Wide_Character
is is
begin begin
if Index in 1 .. Source.Current_Length then if Index <= Source.Current_Length then
return Source.Data (Index); return Source.Data (Index);
else else
raise Strings.Index_Error; raise Strings.Index_Error;
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -787,7 +787,7 @@ package body Ada.Strings.Wide_Wide_Superbounded is ...@@ -787,7 +787,7 @@ package body Ada.Strings.Wide_Wide_Superbounded is
Index : Positive) return Wide_Wide_Character Index : Positive) return Wide_Wide_Character
is is
begin begin
if Index in 1 .. Source.Current_Length then if Index <= Source.Current_Length then
return Source.Data (Index); return Source.Data (Index);
else else
raise Strings.Index_Error; raise Strings.Index_Error;
......
...@@ -32,15 +32,16 @@ with Exp_Smem; use Exp_Smem; ...@@ -32,15 +32,16 @@ with Exp_Smem; use Exp_Smem;
with Exp_Tss; use Exp_Tss; with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util; with Exp_Util; use Exp_Util;
with Exp_VFpt; use Exp_VFpt; with Exp_VFpt; use Exp_VFpt;
with Namet; use Namet;
with Nmake; use Nmake; with Nmake; use Nmake;
with Opt; use Opt; with Opt; use Opt;
with Sem; use Sem; with Sem; use Sem;
with Sem_Attr; use Sem_Attr;
with Sem_Eval; use Sem_Eval; with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res; with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util; with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn; with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo; with Sinfo; use Sinfo;
with Snames; use Snames;
with Tbuild; use Tbuild; with Tbuild; use Tbuild;
with Uintp; use Uintp; with Uintp; use Uintp;
...@@ -90,13 +91,13 @@ package body Exp_Ch2 is ...@@ -90,13 +91,13 @@ package body Exp_Ch2 is
procedure Expand_Entry_Parameter (N : Node_Id); procedure Expand_Entry_Parameter (N : Node_Id);
-- A reference to an entry parameter is modified to be a reference to the -- 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 -- 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); procedure Expand_Formal (N : Node_Id);
-- A reference to a formal parameter of a protected subprogram is expanded -- A reference to a formal parameter of a protected subprogram is expanded
-- into the corresponding formal of the unprotected procedure used to -- into the corresponding formal of the unprotected procedure used to
-- represent the operation within the protected object. In other cases -- 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); procedure Expand_Protected_Private (N : Node_Id);
-- A reference to a private component of a protected type is expanded to a -- A reference to a private component of a protected type is expanded to a
...@@ -156,11 +157,18 @@ package body Exp_Ch2 is ...@@ -156,11 +157,18 @@ package body Exp_Ch2 is
and then Nkind (Parent (N)) /= N_Pragma_Argument_Association 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 not (Nkind (Parent (N)) = N_Attribute_Reference
and then Requires_Simple_Name_Prefix ( and then
Attribute_Name (Parent (N)))) (Attribute_Name (Parent (N)) = Name_Asm_Input
or else
Attribute_Name (Parent (N)) = Name_Asm_Output
or else
Prefix (Parent (N)) = N))
then then
-- Case of Current_Value is a compile time known value -- Case of Current_Value is a compile time known value
...@@ -421,6 +429,11 @@ package body Exp_Ch2 is ...@@ -421,6 +429,11 @@ package body Exp_Ch2 is
function In_Assignment_Context (N : Node_Id) return Boolean is function In_Assignment_Context (N : Node_Id) return Boolean is
begin 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 if Nkind (Parent (N)) = N_Procedure_Call_Statement
or else Nkind (Parent (N)) = N_Entry_Call_Statement or else Nkind (Parent (N)) = N_Entry_Call_Statement
or else or else
...@@ -429,15 +442,25 @@ package body Exp_Ch2 is ...@@ -429,15 +442,25 @@ package body Exp_Ch2 is
then then
return True; return True;
-- Case of a parameter association: climb up to enclosing call
elsif Nkind (Parent (N)) = N_Parameter_Association then elsif Nkind (Parent (N)) = N_Parameter_Association then
return In_Assignment_Context (Parent (N)); 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 elsif (Nkind (Parent (N)) = N_Selected_Component
or else Nkind (Parent (N)) = N_Indexed_Component or else Nkind (Parent (N)) = N_Indexed_Component
or else Nkind (Parent (N)) = N_Slice) 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)) and then In_Assignment_Context (Parent (N))
then then
return True; return True;
else else
return False; return False;
end if; end if;
...@@ -670,6 +693,8 @@ package body Exp_Ch2 is ...@@ -670,6 +693,8 @@ package body Exp_Ch2 is
-- through an address clause is rewritten as dereference as well. -- through an address clause is rewritten as dereference as well.
function Param_Entity (N : Node_Id) return Entity_Id is function Param_Entity (N : Node_Id) return Entity_Id is
Renamed_Obj : Node_Id;
begin begin
-- Simple reference case -- Simple reference case
...@@ -677,10 +702,22 @@ package body Exp_Ch2 is ...@@ -677,10 +702,22 @@ package body Exp_Ch2 is
if Is_Formal (Entity (N)) then if Is_Formal (Entity (N)) then
return Entity (N); return Entity (N);
elsif Nkind (Parent (Entity (N))) = N_Object_Renaming_Declaration -- Handle renamings of formal parameters and formals of tasks that
and then Nkind (Parent (Parent (Entity (N)))) = N_Accept_Statement -- are rewritten as renamings.
then
return Entity (N); 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; end if;
else else
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -37,9 +37,10 @@ package Exp_Ch2 is ...@@ -37,9 +37,10 @@ package Exp_Ch2 is
-- Given an expression N, determines if the expression is a reference -- 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 -- to a formal (of a subprogram or entry), and if so returns the Id
-- of the corresponding formal entity, otherwise returns Empty. The -- of the corresponding formal entity, otherwise returns Empty. The
-- reason that this is in Exp_Ch2 is that it has to deal with the -- reason that this is in Exp_Ch2 is that it has to deal with the case
-- case where the reference is to an entry formal, and has been -- where the reference is to an entry formal, and has been expanded
-- expanded already. Since Exp_Ch2 is in charge of the expansion, it -- already. Since Exp_Ch2 is in charge of the expansion, it is best
-- is best suited to knowing how to detect this case. -- suited to knowing how to detect this case. Also handles the case
-- of references to renamings of formals.
end Exp_Ch2; end Exp_Ch2;
...@@ -670,7 +670,7 @@ package body Exp_Ch4 is ...@@ -670,7 +670,7 @@ package body Exp_Ch4 is
Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT); Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT);
end if; end if;
Convert_Aggr_In_Allocator (Tmp_Node, Exp); Convert_Aggr_In_Allocator (N, Tmp_Node, Exp);
else else
Node := Relocate_Node (N); Node := Relocate_Node (N);
Set_Analyzed (Node); Set_Analyzed (Node);
...@@ -741,7 +741,7 @@ package body Exp_Ch4 is ...@@ -741,7 +741,7 @@ package body Exp_Ch4 is
Get_Allocator_Final_List (N, Base_Type (T), PtrT); Get_Allocator_Final_List (N, Base_Type (T), PtrT);
end if; end if;
Convert_Aggr_In_Allocator (Tmp_Node, Exp); Convert_Aggr_In_Allocator (N, Tmp_Node, Exp);
else else
Node := Relocate_Node (N); Node := Relocate_Node (N);
Set_Analyzed (Node); Set_Analyzed (Node);
...@@ -935,7 +935,7 @@ package body Exp_Ch4 is ...@@ -935,7 +935,7 @@ package body Exp_Ch4 is
Set_No_Initialization (Expression (Tmp_Node)); Set_No_Initialization (Expression (Tmp_Node));
Insert_Action (N, 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)); Rewrite (N, New_Reference_To (Temp, Loc));
Analyze_And_Resolve (N, PtrT); Analyze_And_Resolve (N, PtrT);
...@@ -1467,7 +1467,7 @@ package body Exp_Ch4 is ...@@ -1467,7 +1467,7 @@ package body Exp_Ch4 is
Make_Implicit_If_Statement (Nod, Make_Implicit_If_Statement (Nod,
Condition => Make_Op_Not (Loc, Right_Opnd => Test), Condition => Make_Op_Not (Loc, Right_Opnd => Test),
Then_Statements => New_List ( Then_Statements => New_List (
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (Standard_False, Loc)))); Expression => New_Occurrence_Of (Standard_False, Loc))));
end if; end if;
end Component_Equality; end Component_Equality;
...@@ -1749,20 +1749,20 @@ package body Exp_Ch4 is ...@@ -1749,20 +1749,20 @@ package body Exp_Ch4 is
Make_Implicit_If_Statement (Nod, Make_Implicit_If_Statement (Nod,
Condition => Test_Empty_Arrays, Condition => Test_Empty_Arrays,
Then_Statements => New_List ( Then_Statements => New_List (
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => Expression =>
New_Occurrence_Of (Standard_True, Loc)))), New_Occurrence_Of (Standard_True, Loc)))),
Make_Implicit_If_Statement (Nod, Make_Implicit_If_Statement (Nod,
Condition => Test_Lengths_Correspond, Condition => Test_Lengths_Correspond,
Then_Statements => New_List ( Then_Statements => New_List (
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => Expression =>
New_Occurrence_Of (Standard_False, Loc)))), New_Occurrence_Of (Standard_False, Loc)))),
Handle_One_Dimension (1, First_Index (Ltyp)), Handle_One_Dimension (1, First_Index (Ltyp)),
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (Standard_True, Loc))))); Expression => New_Occurrence_Of (Standard_True, Loc)))));
Set_Has_Completion (Func_Name, True); Set_Has_Completion (Func_Name, True);
...@@ -2590,7 +2590,7 @@ package body Exp_Ch4 is ...@@ -2590,7 +2590,7 @@ package body Exp_Ch4 is
Condition => S_Length_Test (1), Condition => S_Length_Test (1),
Then_Statements => New_List (Init_L (1)), Then_Statements => New_List (Init_L (1)),
Elsif_Parts => Elsif_List, 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)))); Expression => S (Nb_Opnds))));
-- Construct the declaration for H -- Construct the declaration for H
...@@ -2641,7 +2641,8 @@ package body Exp_Ch4 is ...@@ -2641,7 +2641,8 @@ package body Exp_Ch4 is
Then_Statements => Copy_Into_R_S (I, I = Nb_Opnds))); Then_Statements => Copy_Into_R_S (I, I = Nb_Opnds)));
end loop; 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 -- Construct the declare block
...@@ -2817,7 +2818,7 @@ package body Exp_Ch4 is ...@@ -2817,7 +2818,7 @@ package body Exp_Ch4 is
P := Parent (N); P := Parent (N);
while Present (P) loop while Present (P) loop
if Nkind (P) = N_Extended_Return_Statement if Nkind (P) = N_Extended_Return_Statement
or else Nkind (P) = N_Return_Statement or else Nkind (P) = N_Simple_Return_Statement
then then
return True; return True;
...@@ -3441,7 +3442,7 @@ package body Exp_Ch4 is ...@@ -3441,7 +3442,7 @@ package body Exp_Ch4 is
-- Postpone the generation of a finalization call for the -- Postpone the generation of a finalization call for the
-- current allocator if it acts as a coextension. -- current allocator if it acts as a coextension.
if Is_Coextension (N) then if Is_Dynamic_Coextension (N) then
if No (Coextensions (N)) then if No (Coextensions (N)) then
Set_Coextensions (N, New_Elmt_List); Set_Coextensions (N, New_Elmt_List);
end if; end if;
...@@ -3762,24 +3763,42 @@ package body Exp_Ch4 is ...@@ -3762,24 +3763,42 @@ package body Exp_Ch4 is
Lo : constant Node_Id := Low_Bound (Rop); Lo : constant Node_Id := Low_Bound (Rop);
Hi : constant Node_Id := High_Bound (Rop); Hi : constant Node_Id := High_Bound (Rop);
Ltyp : constant Entity_Id := Etype (Lop);
Lo_Orig : constant Node_Id := Original_Node (Lo); Lo_Orig : constant Node_Id := Original_Node (Lo);
Hi_Orig : constant Node_Id := Original_Node (Hi); Hi_Orig : constant Node_Id := Original_Node (Hi);
Lcheck : constant Compare_Result := Compile_Time_Compare (Lop, Lo); Lcheck : constant Compare_Result := Compile_Time_Compare (Lop, Lo);
Ucheck : constant Compare_Result := Compile_Time_Compare (Lop, Hi); 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 begin
-- If test is explicit x'first .. x'last, replace by valid check -- 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 Nkind (Lo_Orig) = N_Attribute_Reference
and then Attribute_Name (Lo_Orig) = Name_First and then Attribute_Name (Lo_Orig) = Name_First
and then Nkind (Prefix (Lo_Orig)) in N_Has_Entity 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 Nkind (Hi_Orig) = N_Attribute_Reference
and then Attribute_Name (Hi_Orig) = Name_Last and then Attribute_Name (Hi_Orig) = Name_Last
and then Nkind (Prefix (Hi_Orig)) in N_Has_Entity 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 Comes_From_Source (N)
and then VM_Target = No_VM and then VM_Target = No_VM
then then
...@@ -3787,6 +3806,24 @@ package body Exp_Ch4 is ...@@ -3787,6 +3806,24 @@ package body Exp_Ch4 is
return; return;
end if; 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 -- 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). -- on range analysis (we may be able to kill one or both checks).
...@@ -3795,44 +3832,68 @@ package body Exp_Ch4 is ...@@ -3795,44 +3832,68 @@ package body Exp_Ch4 is
-- legality checks, because we are constant-folding beyond RM 4.9. -- legality checks, because we are constant-folding beyond RM 4.9.
if Lcheck = LT or else Ucheck = GT then 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, Rewrite (N,
New_Reference_To (Standard_False, Loc)); New_Reference_To (Standard_False, Loc));
Analyze_And_Resolve (N, Rtyp); Analyze_And_Resolve (N, Rtyp);
Set_Is_Static_Expression (N, Static); Set_Is_Static_Expression (N, Static);
return; return;
-- If both checks are known to succeed, replace result -- If both checks are known to succeed, replace result
-- by True, since we know we are in range. -- by True, since we know we are in range.
elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then 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, Rewrite (N,
New_Reference_To (Standard_True, Loc)); New_Reference_To (Standard_True, Loc));
Analyze_And_Resolve (N, Rtyp); Analyze_And_Resolve (N, Rtyp);
Set_Is_Static_Expression (N, Static); Set_Is_Static_Expression (N, Static);
return; return;
-- If lower bound check succeeds and upper bound check is -- If lower bound check succeeds and upper bound check is not
-- not known to succeed or fail, then replace the range check -- known to succeed or fail, then replace the range check with
-- with a comparison against the upper bound. -- a comparison against the upper bound.
elsif Lcheck in Compare_GE then 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, Rewrite (N,
Make_Op_Le (Loc, Make_Op_Le (Loc,
Left_Opnd => Lop, Left_Opnd => Lop,
Right_Opnd => High_Bound (Rop))); Right_Opnd => High_Bound (Rop)));
Analyze_And_Resolve (N, Rtyp); Analyze_And_Resolve (N, Rtyp);
return; return;
-- If upper bound check succeeds and lower bound check is -- If upper bound check succeeds and lower bound check is not
-- not known to succeed or fail, then replace the range check -- known to succeed or fail, then replace the range check with
-- with a comparison against the lower bound. -- a comparison against the lower bound.
elsif Ucheck in Compare_LE then 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, Rewrite (N,
Make_Op_Ge (Loc, Make_Op_Ge (Loc,
Left_Opnd => Lop, Left_Opnd => Lop,
Right_Opnd => Low_Bound (Rop))); Right_Opnd => Low_Bound (Rop)));
Analyze_And_Resolve (N, Rtyp); Analyze_And_Resolve (N, Rtyp);
return; return;
end if; end if;
end; end;
...@@ -4203,9 +4264,9 @@ package body Exp_Ch4 is ...@@ -4203,9 +4264,9 @@ package body Exp_Ch4 is
Right_Opnd => Right_Opnd =>
Make_In (Loc, Make_In (Loc,
Left_Opnd => Left_Opnd (N), 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). -- tranformations in Expand_N_In).
Set_Comes_From_Source (N, Cfs); Set_Comes_From_Source (N, Cfs);
...@@ -6295,7 +6356,7 @@ package body Exp_Ch4 is ...@@ -6295,7 +6356,7 @@ package body Exp_Ch4 is
Make_Handled_Sequence_Of_Statements (Loc, Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List ( Statements => New_List (
Loop_Statement, Loop_Statement,
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => Expression =>
Make_Identifier (Loc, Chars (B))))))); Make_Identifier (Loc, Chars (B)))))));
...@@ -7413,13 +7474,23 @@ package body Exp_Ch4 is ...@@ -7413,13 +7474,23 @@ package body Exp_Ch4 is
if Is_Access_Type (Target_Type) then if Is_Access_Type (Target_Type) then
-- Apply an accessibility check if the operand is an -- Apply an accessibility check when the conversion operand is an
-- access parameter. Note that other checks may still -- access parameter (or a renaming thereof), unless conversion was
-- need to be applied below (such as tagged type checks). -- 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) 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 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 then
Apply_Accessibility_Check (Operand, Target_Type); Apply_Accessibility_Check (Operand, Target_Type);
...@@ -8172,9 +8243,12 @@ package body Exp_Ch4 is ...@@ -8172,9 +8243,12 @@ package body Exp_Ch4 is
-- Case of an access discriminant, or (Ada 2005), of an anonymous -- Case of an access discriminant, or (Ada 2005), of an anonymous
-- access component or anonymous access function result: find the -- 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); Owner := Scope (PtrT);
end if; end if;
end if; end if;
...@@ -8480,7 +8554,7 @@ package body Exp_Ch4 is ...@@ -8480,7 +8554,7 @@ package body Exp_Ch4 is
Then_Statements => New_List (Inner_If), Then_Statements => New_List (Inner_If),
Else_Statements => New_List ( Else_Statements => New_List (
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => Expression =>
Make_Op_Gt (Loc, Make_Op_Gt (Loc,
Left_Opnd => Left_Opnd =>
...@@ -8551,7 +8625,7 @@ package body Exp_Ch4 is ...@@ -8551,7 +8625,7 @@ package body Exp_Ch4 is
Then_Statements => Then_Statements =>
New_List ( New_List (
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => New_Reference_To (Standard_False, Loc))), Expression => New_Reference_To (Standard_False, Loc))),
Elsif_Parts => New_List ( Elsif_Parts => New_List (
...@@ -8567,12 +8641,12 @@ package body Exp_Ch4 is ...@@ -8567,12 +8641,12 @@ package body Exp_Ch4 is
Then_Statements => Then_Statements =>
New_List ( New_List (
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => New_Reference_To (Standard_True, Loc))))), Expression => New_Reference_To (Standard_True, Loc))))),
Else_Statements => New_List ( Else_Statements => New_List (
Loop_Statement, Loop_Statement,
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => Final_Expr))); Expression => Final_Expr)));
-- (X : a; Y: a) -- (X : a; Y: a)
...@@ -8741,7 +8815,7 @@ package body Exp_Ch4 is ...@@ -8741,7 +8815,7 @@ package body Exp_Ch4 is
Make_Handled_Sequence_Of_Statements (Loc, Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List ( Statements => New_List (
Loop_Statement, Loop_Statement,
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => New_Reference_To (C, Loc))))); Expression => New_Reference_To (C, Loc)))));
return Func_Body; return Func_Body;
......
...@@ -1123,13 +1123,48 @@ package body Exp_Ch6 is ...@@ -1123,13 +1123,48 @@ package body Exp_Ch6 is
Rewrite (Actual, New_Reference_To (Temp, Loc)); Rewrite (Actual, New_Reference_To (Temp, Loc));
Analyze (Actual); Analyze (Actual);
Append_To (Post_Call, -- If the actual is a conversion of a packed reference, it may
Make_Assignment_Statement (Loc, -- already have been expanded by Remove_Side_Effects, and the
Name => New_Occurrence_Of (Var, Loc), -- resulting variable is a temporary which does not designate
Expression => Expr)); -- 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 if;
end Add_Call_By_Copy_Code; end Add_Call_By_Copy_Code;
---------------------------------- ----------------------------------
...@@ -2104,13 +2139,21 @@ package body Exp_Ch6 is ...@@ -2104,13 +2139,21 @@ package body Exp_Ch6 is
if Is_Entity_Name (Prev_Orig) then if Is_Entity_Name (Prev_Orig) then
-- When passing an access parameter as the actual to another -- When passing an access parameter, or a renaming of an access
-- access parameter we need to pass along the actual's own -- parameter, as the actual to another access parameter we need
-- associated access level parameter. This is done if we are -- to pass along the actual's own access level parameter. This
-- in the scope of the formal access parameter (if this is an -- is done if we are within the scope of the formal access
-- inlined body the extra formal is irrelevant). -- parameter (if this is an inlined body the extra formal is
-- irrelevant).
if Ekind (Entity (Prev_Orig)) in Formal_Kind
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 Ekind (Etype (Prev_Orig)) = E_Anonymous_Access_Type
and then In_Open_Scopes (Scope (Entity (Prev_Orig))) and then In_Open_Scopes (Scope (Entity (Prev_Orig)))
then then
...@@ -2218,7 +2261,7 @@ package body Exp_Ch6 is ...@@ -2218,7 +2261,7 @@ package body Exp_Ch6 is
if Is_Access_Type (Etype (Formal)) if Is_Access_Type (Etype (Formal))
and then Can_Never_Be_Null (Etype (Formal)) and then Can_Never_Be_Null (Etype (Formal))
and then Nkind (Prev) /= N_Raise_Constraint_Error 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))) or else not Can_Never_Be_Null (Etype (Prev)))
then then
Install_Null_Excluding_Check (Prev); Install_Null_Excluding_Check (Prev);
...@@ -2410,7 +2453,7 @@ package body Exp_Ch6 is ...@@ -2410,7 +2453,7 @@ package body Exp_Ch6 is
then then
Error_Msg_NE Error_Msg_NE
("tag-indeterminate expression " ("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)))); N, Root_Type (Etype (Name (Ass))));
else else
Propagate_Tag (Name (Ass), N); Propagate_Tag (Name (Ass), N);
...@@ -2419,7 +2462,7 @@ package body Exp_Ch6 is ...@@ -2419,7 +2462,7 @@ package body Exp_Ch6 is
elsif Etype (N) /= Root_Type (Etype (Name (Ass))) then elsif Etype (N) /= Root_Type (Etype (Name (Ass))) then
Error_Msg_NE Error_Msg_NE
("tag-indeterminate expression must have type&" ("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 else
Propagate_Tag (Name (Ass), N); Propagate_Tag (Name (Ass), N);
...@@ -2708,9 +2751,21 @@ package body Exp_Ch6 is ...@@ -2708,9 +2751,21 @@ package body Exp_Ch6 is
-- In the case where the intrinsic is to be processed by the back end, -- 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, -- the call to Expand_Intrinsic_Call will do nothing, which is fine,
-- since the idea in this case is to pass the call unchanged. -- 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 if Is_Intrinsic_Subprogram (Subp) then
Expand_Intrinsic_Call (N, Subp); 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; return;
end if; end if;
...@@ -3147,7 +3202,7 @@ package body Exp_Ch6 is ...@@ -3147,7 +3202,7 @@ package body Exp_Ch6 is
and then and then
(No (Stat2) (No (Stat2)
or else or else
(Nkind (Stat2) = N_Return_Statement (Nkind (Stat2) = N_Simple_Return_Statement
and then No (Next (Stat2)))); and then No (Next (Stat2))));
end; end;
end if; end if;
...@@ -3211,19 +3266,21 @@ package body Exp_Ch6 is ...@@ -3211,19 +3266,21 @@ package body Exp_Ch6 is
Rewrite (N, New_Occurrence_Of (A, Loc)); Rewrite (N, New_Occurrence_Of (A, Loc));
Check_Private_View (N); Check_Private_View (N);
else -- numeric literal -- Numeric literal
else
Rewrite (N, New_Copy (A)); Rewrite (N, New_Copy (A));
end if; end if;
end if; end if;
return Skip; return Skip;
elsif Nkind (N) = N_Return_Statement then elsif Nkind (N) = N_Simple_Return_Statement then
if No (Expression (N)) then if No (Expression (N)) then
Make_Exit_Label; Make_Exit_Label;
Rewrite (N, Make_Goto_Statement (Loc, Rewrite (N,
Name => New_Copy (Lab_Id))); Make_Goto_Statement (Loc,
Name => New_Copy (Lab_Id)));
else else
if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
...@@ -3863,7 +3920,7 @@ package body Exp_Ch6 is ...@@ -3863,7 +3920,7 @@ package body Exp_Ch6 is
if Is_Inherently_Limited_Type (Typ) then if Is_Inherently_Limited_Type (Typ) then
return True; return True;
elsif Nkind (Parent (N)) /= N_Return_Statement then elsif Nkind (Parent (N)) /= N_Simple_Return_Statement then
return False; return False;
elsif Requires_Transient_Scope (Typ) then elsif Requires_Transient_Scope (Typ) then
...@@ -4113,7 +4170,7 @@ package body Exp_Ch6 is ...@@ -4113,7 +4170,7 @@ package body Exp_Ch6 is
Loc := Sloc (Last_Stm); Loc := Sloc (Last_Stm);
end if; end if;
Append_To (S, Make_Return_Statement (Loc)); Append_To (S, Make_Simple_Return_Statement (Loc));
end if; end if;
end Add_Return; end Add_Return;
...@@ -4275,7 +4332,8 @@ package body Exp_Ch6 is ...@@ -4275,7 +4332,8 @@ package body Exp_Ch6 is
then then
Add_Discriminal_Declarations Add_Discriminal_Declarations
(Declarations (N), Scop, Name_uObject, Loc); (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 -- Associate privals and discriminals with the next protected
-- operation body to be expanded. These are used to expand references -- operation body to be expanded. These are used to expand references
...@@ -4787,7 +4845,7 @@ package body Exp_Ch6 is ...@@ -4787,7 +4845,7 @@ package body Exp_Ch6 is
function Is_Build_In_Place_Function_Return (N : Node_Id) return Boolean is function Is_Build_In_Place_Function_Return (N : Node_Id) return Boolean is
begin begin
if Nkind (N) = N_Return_Statement if Nkind (N) = N_Simple_Return_Statement
or else Nkind (N) = N_Extended_Return_Statement or else Nkind (N) = N_Extended_Return_Statement
then then
return Is_Build_In_Place_Function return Is_Build_In_Place_Function
...@@ -4841,11 +4899,7 @@ package body Exp_Ch6 is ...@@ -4841,11 +4899,7 @@ package body Exp_Ch6 is
while Present (Iface_DT_Ptr) while Present (Iface_DT_Ptr)
and then Ekind (Node (Iface_DT_Ptr)) = E_Constant and then Ekind (Node (Iface_DT_Ptr)) = E_Constant
loop loop
Expand_Interface_Thunk Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
(N => Prim,
Thunk_Alias => Prim,
Thunk_Id => Thunk_Id,
Thunk_Code => Thunk_Code);
if Present (Thunk_Code) then if Present (Thunk_Code) then
Insert_Actions (N, New_List ( Insert_Actions (N, New_List (
...@@ -4867,89 +4921,88 @@ package body Exp_Ch6 is ...@@ -4867,89 +4921,88 @@ package body Exp_Ch6 is
-- Local variables -- Local variables
Subp : constant Entity_Id := Entity (N); Subp : constant Entity_Id := Entity (N);
Typ : constant Entity_Id := Etype (Subp);
Utyp : constant Entity_Id := Underlying_Type (Typ);
begin 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 declare
E : constant Entity_Id := Subp; Typ : constant Entity_Id := Scope (DTC_Entity (Subp));
Typ : Entity_Id;
begin begin
-- We assume that imported CPP primitives correspond with objects -- Handle private overriden primitives
-- 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) if not Is_CPP_Class (Typ) then
and then Convention (E) = Convention_CPP Check_Overriding_Operation (Subp);
then
return;
end if; end if;
-- When a primitive is frozen, enter its name in the corresponding -- We assume that imported CPP primitives correspond with objects
-- dispatch table. If the DTC_Entity field is not set this is -- whose constructor is in the CPP side; therefore we don't need
-- an overridden primitive that can be ignored. We suppress the -- to generate code to register them in the dispatch table.
-- 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);
-- Register the primitive in its dispatch table if we are not if Is_CPP_Class (Typ) then
-- compiling under No_Dispatching_Calls restriction null;
if not Restriction_Active (No_Dispatching_Calls) -- Handle CPP primitives found in derivations of CPP_Class types.
and then RTE_Available (RE_Tag) -- These primitives must have been inherited from some parent, and
then -- there is no need to register them in the dispatch table because
Typ := Scope (DTC_Entity (E)); -- Build_Inherit_Prims takes care of the initialization of these
-- slots.
if not Is_Interface (Typ) elsif Is_Imported (Subp)
or else Present (Abstract_Interface_Alias (E)) and then (Convention (Subp) = Convention_CPP
then or else Convention (Subp) = Convention_C)
if Is_Predefined_Dispatching_Operation (E) then then
Register_Predefined_DT_Entry (E); null;
end if;
-- 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, if not Is_Interface (Typ)
Prim => E, or else Present (Abstract_Interface_Alias (Subp))
Ins_Nod => N); then
if Is_Predefined_Dispatching_Operation (Subp) then
Register_Predefined_DT_Entry (Subp);
end if; end if;
Register_Primitive (Loc,
Prim => Subp,
Ins_Nod => N);
end if; end if;
end if; end if;
end; 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; end if;
-- Mark functions that return by reference. Note that it cannot be part -- Mark functions that return by reference. Note that it cannot be part
-- of the normal semantic analysis of the spec since the underlying -- of the normal semantic analysis of the spec since the underlying
-- returned type may not be known yet (for private types). -- returned type may not be known yet (for private types).
if Is_Inherently_Limited_Type (Typ) then declare
Set_Returns_By_Ref (Subp); Typ : constant Entity_Id := Etype (Subp);
Utyp : constant Entity_Id := Underlying_Type (Typ);
elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then begin
Set_Returns_By_Ref (Subp); if Is_Inherently_Limited_Type (Typ) then
end if; 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; end Freeze_Subprogram;
------------------------------------------- -------------------------------------------
......
...@@ -72,7 +72,7 @@ package Exp_Ch6 is ...@@ -72,7 +72,7 @@ package Exp_Ch6 is
-- Present if result type contains tasks. Master associated with -- Present if result type contains tasks. Master associated with
-- calling context. -- calling context.
BIP_Activation_Chain, 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); BIP_Object_Access);
-- Present for all build-in-place functions. Address at which to place -- Present for all build-in-place functions. Address at which to place
-- the return object, or null if BIP_Alloc_Form indicates -- the return object, or null if BIP_Alloc_Form indicates
...@@ -114,9 +114,9 @@ package Exp_Ch6 is ...@@ -114,9 +114,9 @@ package Exp_Ch6 is
-- expression applied to such a call; otherwise returns False. -- expression applied to such a call; otherwise returns False.
function Is_Build_In_Place_Function_Return (N : Node_Id) return Boolean; 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 -- Ada 2005 (AI-318-02): Returns True if N is an N_Simple_Return_Statement
-- N_Extended_Return_Statement and it applies to a build-in-place function -- or N_Extended_Return_Statement and it applies to a build-in-place
-- or generic function. -- function or generic function.
procedure Make_Build_In_Place_Call_In_Allocator procedure Make_Build_In_Place_Call_In_Allocator
(Allocator : Node_Id; (Allocator : Node_Id;
......
...@@ -74,13 +74,19 @@ package body Lib.Util is ...@@ -74,13 +74,19 @@ package body Lib.Util is
-- Start of processing for Write_Info_Char_Code -- Start of processing for Write_Info_Char_Code
begin begin
if Code in 16#00# .. 16#7F# then -- 00 .. 7F
if Code <= 16#7F# then
Write_Info_Char (Character'Val (Code)); 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_Char ('U');
Write_Info_Hex_Byte (Natural (Code)); Write_Info_Hex_Byte (Natural (Code));
-- 0100 .. FFFF
else else
Write_Info_Char ('W'); Write_Info_Char ('W');
Write_Info_Hex_Byte (Natural (Code / 256)); Write_Info_Hex_Byte (Natural (Code / 256));
......
...@@ -223,13 +223,20 @@ package body Lib.Xref is ...@@ -223,13 +223,20 @@ package body Lib.Xref is
-- Prefix Of an indexed or selected component that is present in a -- Prefix Of an indexed or selected component that is present in a
-- subtree rooted by an assignment statement. There is no -- subtree rooted by an assignment statement. There is no
-- restriction of nesting of components, thus cases such as -- 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 -- -- 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 function Is_On_LHS (Node : Node_Id) return Boolean is
N : Node_Id := Node; N : Node_Id := Node;
...@@ -247,13 +254,28 @@ package body Lib.Xref is ...@@ -247,13 +254,28 @@ package body Lib.Xref is
while Nkind (Parent (N)) /= N_Assignment_Statement loop while Nkind (Parent (N)) /= N_Assignment_Statement loop
-- Check whether the parent is a component and the -- Check whether the parent is a component and the current node
-- current node is its prefix. -- 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 if (Nkind (Parent (N)) = N_Selected_Component
or else or else
Nkind (Parent (N)) = N_Indexed_Component) Nkind (Parent (N)) = N_Indexed_Component)
and then Prefix (Parent (N)) = N and then Prefix (Parent (N)) = N
and then not (Present (Etype (N))
and then
Is_Access_Type (Etype (N)))
then then
N := Parent (N); N := Parent (N);
else else
...@@ -370,7 +392,7 @@ package body Lib.Xref is ...@@ -370,7 +392,7 @@ package body Lib.Xref is
-- a left hand side. We also set the Referenced_As_LHS flag of a -- a left hand side. We also set the Referenced_As_LHS flag of a
-- prefix of selected or indexed component. -- 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) and then Is_On_LHS (N)
then then
Set_Referenced_As_LHS (E); Set_Referenced_As_LHS (E);
...@@ -1004,9 +1026,8 @@ package body Lib.Xref is ...@@ -1004,9 +1026,8 @@ package body Lib.Xref is
end if; end if;
end if; end if;
-- Collect inherited primitive operations that may be -- Collect inherited primitive operations that may be declared in
-- declared in another unit and have no visible reference -- another unit and have no visible reference in the current one.
-- in the current one.
if Is_Type (Ent) if Is_Type (Ent)
and then Is_Tagged_Type (Ent) and then Is_Tagged_Type (Ent)
......
...@@ -304,7 +304,7 @@ package body Nlists is ...@@ -304,7 +304,7 @@ package body Nlists is
if List = No_List then if List = No_List then
return Empty; return Empty;
else else
pragma Assert (List in First_List_Id .. Lists.Last); pragma Assert (List <= Lists.Last);
return Lists.Table (List).First; return Lists.Table (List).First;
end if; end if;
end First; end First;
...@@ -630,7 +630,7 @@ package body Nlists is ...@@ -630,7 +630,7 @@ package body Nlists is
function Last (List : List_Id) return Node_Id is function Last (List : List_Id) return Node_Id is
begin begin
pragma Assert (List in First_List_Id .. Lists.Last); pragma Assert (List <= Lists.Last);
return Lists.Table (List).Last; return Lists.Table (List).Last;
end Last; end Last;
...@@ -1028,7 +1028,7 @@ package body Nlists is ...@@ -1028,7 +1028,7 @@ package body Nlists is
function Parent (List : List_Id) return Node_Id is function Parent (List : List_Id) return Node_Id is
begin begin
pragma Assert (List in First_List_Id .. Lists.Last); pragma Assert (List <= Lists.Last);
return Lists.Table (List).Parent; return Lists.Table (List).Parent;
end Parent; end Parent;
...@@ -1355,7 +1355,7 @@ package body Nlists is ...@@ -1355,7 +1355,7 @@ package body Nlists is
procedure Set_Parent (List : List_Id; Node : Node_Id) is procedure Set_Parent (List : List_Id; Node : Node_Id) is
begin begin
pragma Assert (List in First_List_Id .. Lists.Last); pragma Assert (List <= Lists.Last);
Lists.Table (List).Parent := Node; Lists.Table (List).Parent := Node;
end Set_Parent; end Set_Parent;
......
...@@ -796,8 +796,7 @@ package body Treepr is ...@@ -796,8 +796,7 @@ package body Treepr is
Notes := False; Notes := False;
if N not in if N > Atree_Private_Part.Nodes.Last then
Atree_Private_Part.Nodes.First .. Atree_Private_Part.Nodes.Last then
Print_Str (" (no such node)"); Print_Str (" (no such node)");
Print_Eol; Print_Eol;
return; return;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment