Commit c8ef728f by Ed Schonberg Committed by Arnaud Charlet

re PR ada/25885 (Tree checking failure on ASIS)

2006-02-13  Ed Schonberg  <schonberg@adacore.com>
	    Javier Miranda  <miranda@adacore.com>
	    Robert Dewar  <dewar@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>

	* exp_ch6.adb (Expand_Inlined_Call): Handle calls to functions that
	return unconstrained arrays.
	Update comments.
	(Expand_Call):  An indirect call through an access parameter of a
	protected operation is not a protected call.
	Add circuit to raise CE in Ada 2005 mode following call
	to Raise_Exception.
	(Register_DT_Entry): Do nothing if
	the run-time does not give support to abstract interfaces.
	(Freeze_Subprogram): In case of dispatching operations, do not generate
	code to register the operation in the dispatch table if the source
	is compiled with No_Dispatching_Calls.
	(Register_Predefined_DT_Entry): Generate code that calls the new
	run-time subprogram Set_Predefined_Prim_Op_Address instead of
	Set_Prim_Op_Address.

	* sem_ch5.adb (Analyze_Assignment_Statement): Do not apply length checks
	on array assignments if the right-hand side is a function call that has
	been inlined. Check is performed on the assignment in the block.
	(Process_Bounds): If bounds and range are overloaded, apply preference
	rule for root operations to disambiguate, and diagnose true ambiguity.
	(Analyze_Assignment): Propagate the tag for a class-wide assignment with
	a tag-indeterminate right-hand side even when Expander_Active is True.
	Needed to ensure that dispatching calls to T'Input are allowed and
	get the tag of the target class-wide object.

	* sem_ch6.adb (New_Overloaded_Entity): Handle entities that override
	an inherited primitive operation that already overrides several
	abstract interface primitives. For transitivity, the new entity must
	also override all the abstract interface primitives covered by the
	inherited overriden primitive.
	Emit warning if new entity differs from homograph in same scope only in
	that one has an access parameter and the other one has a parameter of
	a general access type with the same designated type, at the same
	position in the signature.
	(Make_Inequality_Operator): Use source locations of parameters and
	subtype marks from corresponding equality operator when creating the
	tree structure for the implicit declaration of "/=". This does not
	change anything in behaviour except that the decoration of the
	components of the subtree created for "/=" allows ASIS to get the
	string images of the corresponding identifiers.
	(Analyze_Return_Statement): Remove '!' in warning message.
	(Check_Statement_Sequence): Likewise.
	(Analyze_Subprogram_Body): For an access parameter whose designated type
	is an incomplete type imported through a limited_with clause, use the
	type of the corresponding formal in the body.
	(Check_Returns): Implicit return in No_Return procedure now raises
	Program_Error with a compile time warning, instead of beging illegal.
	(Has_Single_Return):  Function returning unconstrained type cannot be
	inlined if expression in unique return statement is not an identifier.
	(Build_Body_To_Inline): It is possible to inline a function call that
	returns an unconstrained type if all return statements in the function
	return the same local variable. Subsidiary procedure Has_Single_Return
	verifies that the body conforms to this restriction.

	* sem_res.adb (Resolve_Equality_Op): If the operands do not have the
	same type, and  one of them is of an anonymous access type, convert
	the other operand to it, so that this is a valid binary operation for
	gigi.
	(Resolve_Type_Conversion): Handle subtypes of protected types and
	task types when accessing to the corresponding record type.
	(Resolve_Allocator): Add '\' in 2-line warning message.
	Remove '!' in warning message.
	(Resolve_Call): Add '\' in 2-line warning message.
	(Valid_Conversion): Likewise.
	(Resolve_Overloaded_Selected_Component): If disambiguation succeeds, the
	resulting type may be an access type with an implicit dereference.
	Obtain the proper component from the designated type.
	(Make_Call_Into_Operator): Handle properly a call to predefined equality
	given by an expanded name with prefix Standard, when the operands are
	of an anonymous access type.
	(Check_Fully_Declared_Prefix): New procedure, subsidiary of Resolve_
	Explicit_Dereference and Resolve_Selected_Component, to verify that the
	prefix of the expression is not of an incomplete type. Allows full
	diagnoses of all semantic errors.
	(Resolve_Actuals): If the actual is an allocator whose directly
	designated type is a class-wide interface we build an anonymous
	access type to use it as the type of the allocator. Later, when
	the subprogram call is expanded, if the interface has a secondary
	dispatch table the expander will add a type conversion to force
	the displacement of the pointer.
	(Resolve_Call): If a function that returns an unconstrained type is
	marked Inlined_Always and inlined, the call will be inlined and does
	not require the creation of a transient scope.
	(Check_Direct_Boolean_Op): Removed
	(Resolve_Comparison_Op): Remove call to above
	(Resolve_Equality_Op): Remove call to above
	(Resolve_Logical_Op): Inline above, since this is only call.
	(Valid_Conversion): Handle properly conversions between arrays of
	convertible anonymous access types.

	PR ada/25885

	(Set_Literal_String_Subtype): If the lower bound is not static, wrap
	the literal in an unchecked conversion, because GCC 4.x needs a static
	value for a string bound.

From-SVN: r111062
parent 6ec9c97a
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2006, 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- --
......@@ -698,6 +698,11 @@ package body Exp_Ch6 is
-- Processing for OUT or IN OUT parameter
else
-- Kill current value indications for the temporary variable we
-- created, since we just passed it as an OUT parameter.
Kill_Current_Values (Temp);
-- If type conversion, use reverse conversion on exit
if Nkind (Actual) = N_Type_Conversion then
......@@ -1265,7 +1270,7 @@ package body Exp_Ch6 is
Set_First_Named_Actual (N, Actual_Expr);
if No (Prev) then
if not Present (Parameter_Associations (N)) then
if No (Parameter_Associations (N)) then
Set_Parameter_Associations (N, New_List);
Append (Insert_Param, Parameter_Associations (N));
end if;
......@@ -1830,11 +1835,10 @@ package body Exp_Ch6 is
Check_Valid_Lvalue_Subscripts (Actual);
end if;
-- Mark any scalar OUT parameter that is a simple variable
-- as no longer known to be valid (unless the type is always
-- valid). This reflects the fact that if an OUT parameter
-- is never set in a procedure, then it can become invalid
-- on return from the procedure.
-- Mark any scalar OUT parameter that is a simple variable as no
-- longer known to be valid (unless the type is always valid). This
-- reflects the fact that if an OUT parameter is never set in a
-- procedure, then it can become invalid on the procedure return.
if Ekind (Formal) = E_Out_Parameter
and then Is_Entity_Name (Actual)
......@@ -1844,14 +1848,15 @@ package body Exp_Ch6 is
Set_Is_Known_Valid (Entity (Actual), False);
end if;
-- For an OUT or IN OUT parameter of an access type, if the
-- actual is an entity, then it is no longer known to be non-null.
-- For an OUT or IN OUT parameter, if the actual is an entity, then
-- clear current values, since they can be clobbered. We are probably
-- doing this in more places than we need to, but better safe than
-- sorry when it comes to retaining bad current values!
if Ekind (Formal) /= E_In_Parameter
and then Is_Entity_Name (Actual)
and then Is_Access_Type (Etype (Actual))
then
Set_Is_Known_Non_Null (Entity (Actual), False);
Kill_Current_Values (Entity (Actual));
end if;
-- If the formal is class wide and the actual is an aggregate, force
......@@ -1894,11 +1899,11 @@ package body Exp_Ch6 is
Next_Formal (Formal);
end loop;
-- If we are expanding a rhs of an assignement we need to check if
-- tag propagation is needed. This code belongs theorically in Analyze
-- Assignment but has to be done earlier (bottom-up) because the
-- assignment might be transformed into a declaration for an uncons-
-- trained value, if the expression is classwide.
-- If we are expanding a rhs of an assignment we need to check if tag
-- propagation is needed. You might expect this processing to be in
-- Analyze_Assignment but has to be done earlier (bottom-up) because the
-- assignment might be transformed to a declaration for an unconstrained
-- value if the expression is classwide.
if Nkind (N) = N_Function_Call
and then Is_Tag_Indeterminate (N)
......@@ -2016,6 +2021,8 @@ package body Exp_Ch6 is
end loop;
end if;
-- The below setting of Entity is suspect, see F109-018 discussion???
Set_Entity (Name (N), Parent_Subp);
if Is_Abstract (Parent_Subp)
......@@ -2337,10 +2344,16 @@ package body Exp_Ch6 is
-- call, or a protected function call. Protected procedure calls are
-- rewritten as entry calls and handled accordingly.
-- In Ada 2005, this may be an indirect call to an access parameter
-- that is an access_to_subprogram. In that case the anonymous type
-- has a scope that is a protected operation, but the call is a
-- regular one.
Scop := Scope (Subp);
if Nkind (N) /= N_Entry_Call_Statement
and then Is_Protected_Type (Scop)
and then Ekind (Subp) /= E_Subprogram_Type
then
-- If the call is an internal one, it is rewritten as a call to
-- to the corresponding unprotected subprogram.
......@@ -2498,6 +2511,28 @@ package body Exp_Ch6 is
end if;
end;
end if;
-- Special processing for Ada 2005 AI-329, which requires a call to
-- Raise_Exception to raise Constraint_Error if the Exception_Id is
-- null. Note that we never need to do this in GNAT mode, or if the
-- parameter to Raise_Exception is a use of Identity, since in these
-- cases we know that the parameter is never null.
if Ada_Version >= Ada_05
and then not GNAT_Mode
and then Is_RTE (Subp, RE_Raise_Exception)
and then (Nkind (First_Actual (N)) /= N_Attribute_Reference
or else Attribute_Name (First_Actual (N)) /= Name_Identity)
then
declare
RCE : constant Node_Id :=
Make_Raise_Constraint_Error (Loc,
Reason => CE_Null_Exception_Id);
begin
Insert_After (N, RCE);
Analyze (RCE);
end;
end if;
end Expand_Call;
--------------------------
......@@ -2519,6 +2554,7 @@ package body Exp_Ch6 is
Blk : Node_Id;
Bod : Node_Id;
Decl : Node_Id;
Decls : constant List_Id := New_List;
Exit_Lab : Entity_Id := Empty;
F : Entity_Id;
A : Node_Id;
......@@ -2528,9 +2564,23 @@ package body Exp_Ch6 is
Num_Ret : Int := 0;
Ret_Type : Entity_Id;
Targ : Node_Id;
Targ1 : Node_Id;
Temp : Entity_Id;
Temp_Typ : Entity_Id;
Is_Unc : constant Boolean :=
Is_Array_Type (Etype (Subp))
and then not Is_Constrained (Etype (Subp));
-- If the type returned by the function is unconstrained and the
-- call can be inlined, special processing is required.
procedure Find_Result;
-- For a function that returns an unconstrained type, retrieve the
-- name of the single variable that is the expression of a return
-- statement in the body of the function. Build_Body_To_Inline has
-- verified that this variable is unique, even in the presence of
-- multiple return statements.
procedure Make_Exit_Label;
-- Build declaration for exit label to be used in Return statements
......@@ -2557,6 +2607,50 @@ package body Exp_Ch6 is
function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean;
-- Determine whether a formal parameter is used only once in Orig_Bod
-----------------
-- Find_Result --
-----------------
procedure Find_Result is
Decl : Node_Id;
Id : Node_Id;
function Get_Return (N : Node_Id) return Traverse_Result;
-- Recursive function to locate return statements in body.
function Get_Return (N : Node_Id) return Traverse_Result is
begin
if Nkind (N) = N_Return_Statement then
Id := Expression (N);
return Abandon;
else
return OK;
end if;
end Get_Return;
procedure Find_It is new Traverse_Proc (Get_Return);
-- Start of processing for Find_Result
begin
Find_It (Handled_Statement_Sequence (Orig_Bod));
-- At this point the body is unanalyzed. Traverse the list of
-- declarations to locate the defining_identifier for it.
Decl := First (Declarations (Blk));
while Present (Decl) loop
if Chars (Defining_Identifier (Decl)) = Chars (Id) then
Targ1 := Defining_Identifier (Decl);
exit;
else
Next (Decl);
end if;
end loop;
end Find_Result;
---------------------
-- Make_Exit_Label --
---------------------
......@@ -2746,7 +2840,11 @@ package body Exp_Ch6 is
Insert_After (Parent (Entity (N)), Blk);
elsif Nkind (Parent (N)) = N_Assignment_Statement
and then Is_Entity_Name (Name (Parent (N)))
and then
(Is_Entity_Name (Name (Parent (N)))
or else
(Nkind (Name (Parent (N))) = N_Explicit_Dereference
and then Is_Entity_Name (Prefix (Name (Parent (N))))))
then
-- Replace assignment with the block
......@@ -2770,6 +2868,9 @@ package body Exp_Ch6 is
elsif Nkind (Parent (N)) = N_Object_Declaration then
Set_Expression (Parent (N), Empty);
Insert_After (Parent (N), Blk);
elsif Is_Unc then
Insert_Before (Parent (N), Blk);
end if;
end Rewrite_Function_Call;
......@@ -2907,6 +3008,13 @@ package body Exp_Ch6 is
Set_Declarations (Blk, New_List);
end if;
-- For the unconstrained case, capture the name of the local
-- variable that holds the result.
if Is_Unc then
Find_Result;
end if;
-- If this is a derived function, establish the proper return type
if Present (Orig_Subp)
......@@ -3022,7 +3130,7 @@ package body Exp_Ch6 is
Name => New_A);
end if;
Prepend (Decl, Declarations (Blk));
Append (Decl, Decls);
Set_Renamed_Object (F, Temp);
end if;
......@@ -3034,7 +3142,7 @@ package body Exp_Ch6 is
-- declaration, create a temporary as a target. The declaration for
-- the temporary may be subsequently optimized away if the body is a
-- single expression, or if the left-hand side of the assignment is
-- simple enough.
-- simple enough, i.e. an entity or an explicit dereference of one.
if Ekind (Subp) = E_Function then
if Nkind (Parent (N)) = N_Assignment_Statement
......@@ -3042,6 +3150,12 @@ package body Exp_Ch6 is
then
Targ := Name (Parent (N));
elsif Nkind (Parent (N)) = N_Assignment_Statement
and then Nkind (Name (Parent (N))) = N_Explicit_Dereference
and then Is_Entity_Name (Prefix (Name (Parent (N))))
then
Targ := Name (Parent (N));
else
-- Replace call with temporary and create its declaration
......@@ -3049,19 +3163,39 @@ package body Exp_Ch6 is
Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
Set_Is_Internal (Temp);
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition =>
New_Occurrence_Of (Ret_Type, Loc));
-- For the unconstrained case. the generated temporary has the
-- same constrained declaration as the result variable.
-- It may eventually be possible to remove that temporary and
-- use the result variable directly.
if Is_Unc then
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition =>
New_Copy_Tree (Object_Definition (Parent (Targ1))));
Replace_Formals (Decl);
else
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition =>
New_Occurrence_Of (Ret_Type, Loc));
Set_Etype (Temp, Ret_Type);
end if;
Set_No_Initialization (Decl);
Insert_Action (N, Decl);
Append (Decl, Decls);
Rewrite (N, New_Occurrence_Of (Temp, Loc));
Targ := Temp;
end if;
end if;
Insert_Actions (N, Decls);
-- Traverse the tree and replace formals with actuals or their thunks.
-- Attach block to tree before analysis and rewriting.
......@@ -3122,6 +3256,18 @@ package body Exp_Ch6 is
Rewrite_Procedure_Call (N, Blk);
else
Rewrite_Function_Call (N, Blk);
-- For the unconstrained case, the replacement of the call has been
-- made prior to the complete analysis of the generated declarations.
-- Propagate the proper type now.
if Is_Unc then
if Nkind (N) = N_Identifier then
Set_Etype (N, Etype (Entity (N)));
else
Set_Etype (N, Etype (Targ1));
end if;
end if;
end if;
Restore_Env;
......@@ -3280,8 +3426,8 @@ package body Exp_Ch6 is
Proc := Entity (Name (Parent (N)));
F := First_Formal (Proc);
A := First_Actual (Parent (N));
F := First_Formal (Proc);
A := First_Actual (Parent (N));
while A /= N loop
Next_Formal (F);
Next_Actual (A);
......@@ -4133,8 +4279,7 @@ package body Exp_Ch6 is
-- (Ada 2005): Register an interface primitive in a secondary dispatch
-- table. If Prim overrides an ancestor primitive of its associated
-- tagged-type then Ancestor_Iface_Prim indicates the entity of that
-- immediate ancestor associated with the interface; otherwise Prim and
-- Ancestor_Iface_Prim have the same info.
-- immediate ancestor associated with the interface.
procedure Register_Predefined_DT_Entry (Prim : Entity_Id);
-- (Ada 2005): Register a predefined primitive in all the secondary
......@@ -4192,7 +4337,7 @@ package body Exp_Ch6 is
Skip_Controlling_Formals => True)
and then DT_Position (Prim_Op) = DT_Position (E)
and then Etype (DTC_Entity (Prim_Op)) = RTE (RE_Tag)
and then not Present (Abstract_Interface_Alias (Prim_Op))
and then No (Abstract_Interface_Alias (Prim_Op))
then
if Overriden_Op = Empty then
Overriden_Op := Prim_Op;
......@@ -4268,7 +4413,14 @@ package body Exp_Ch6 is
Thunk_Id : Entity_Id;
begin
if not Present (Ancestor_Iface_Prim) then
-- Nothing to do if the run-time does not give support to abstract
-- interfaces.
if not (RTE_Available (RE_Interface_Tag)) then
return;
end if;
if No (Ancestor_Iface_Prim) then
Prim_Typ := Scope (DTC_Entity (Alias (Prim)));
Iface_Typ := Scope (DTC_Entity (Abstract_Interface_Alias (Prim)));
......@@ -4373,8 +4525,9 @@ package body Exp_Ch6 is
begin
Prim_Typ := Scope (DTC_Entity (Prim));
if not Present (Access_Disp_Table (Prim_Typ))
or else not Present (Abstract_Interfaces (Prim_Typ))
if No (Access_Disp_Table (Prim_Typ))
or else No (Abstract_Interfaces (Prim_Typ))
or else not RTE_Available (RE_Interface_Tag)
then
return;
end if;
......@@ -4404,7 +4557,7 @@ package body Exp_Ch6 is
Insert_After (N, New_Thunk);
Insert_After (New_Thunk,
Make_DT_Access_Action (Node (Iface_Typ),
Action => Set_Prim_Op_Address,
Action => Set_Predefined_Prim_Op_Address,
Args => New_List (
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (Node (Iface_DT_Ptr), Loc)),
......@@ -4438,9 +4591,20 @@ package body Exp_Ch6 is
then
Check_Overriding_Operation (E);
-- Ada 95 case: Register the subprogram in the primary dispatch table
if Ada_Version < Ada_05 then
Insert_After (N,
Fill_DT_Entry (Sloc (N), Prim => E));
-- Do not register the subprogram in the dispatch table if we
-- are compiling with the No_Dispatching_Calls restriction.
if not Restriction_Active (No_Dispatching_Calls) then
Insert_After (N,
Fill_DT_Entry (Sloc (N), Prim => E));
end if;
-- Ada 2005 case: Register the subprogram in the secondary dispatch
-- tables associated with abstract interfaces.
else
declare
......@@ -4448,8 +4612,8 @@ package body Exp_Ch6 is
begin
-- There is no dispatch table associated with abstract
-- interface types; each type implementing interfaces
-- will fill the associated secondary DT entries.
-- interface types. Each type implementing interfaces will
-- fill the associated secondary DT entries.
if not Is_Interface (Typ)
or else Present (Alias (E))
......@@ -4465,12 +4629,15 @@ package body Exp_Ch6 is
else
-- Generate thunks for all the predefined operations
if Is_Predefined_Dispatching_Operation (E) then
Register_Predefined_DT_Entry (E);
if not Restriction_Active (No_Dispatching_Calls) then
if Is_Predefined_Dispatching_Operation (E) then
Register_Predefined_DT_Entry (E);
end if;
Insert_After (N,
Fill_DT_Entry (Sloc (N), Prim => E));
end if;
Insert_After (N,
Fill_DT_Entry (Sloc (N), Prim => E));
Check_Overriding_Inherited_Interfaces (E);
end if;
end if;
......
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2006, 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- --
......@@ -81,12 +81,17 @@ package body Sem_Ch5 is
T1 : Entity_Id;
T2 : Entity_Id;
Decl : Node_Id;
Ent : Entity_Id;
procedure Diagnose_Non_Variable_Lhs (N : Node_Id);
-- N is the node for the left hand side of an assignment, and it
-- is not a variable. This routine issues an appropriate diagnostic.
procedure Kill_Lhs;
-- This is called to kill current value settings of a simple variable
-- on the left hand side. We call it if we find any error in analyzing
-- the assignment, and at the end of processing before setting any new
-- current values in place.
procedure Set_Assignment_Type
(Opnd : Node_Id;
Opnd_Type : in out Entity_Id);
......@@ -159,6 +164,23 @@ package body Sem_Ch5 is
end if;
end Diagnose_Non_Variable_Lhs;
--------------
-- Kill_LHS --
--------------
procedure Kill_Lhs is
begin
if Is_Entity_Name (Lhs) then
declare
Ent : constant Entity_Id := Entity (Lhs);
begin
if Present (Ent) then
Kill_Current_Values (Ent);
end if;
end;
end if;
end Kill_Lhs;
-------------------------
-- Set_Assignment_Type --
-------------------------
......@@ -225,6 +247,9 @@ package body Sem_Ch5 is
begin
Analyze (Rhs);
Analyze (Lhs);
-- Start type analysis for assignment
T1 := Etype (Lhs);
-- In the most general case, both Lhs and Rhs can be overloaded, and we
......@@ -305,6 +330,7 @@ package body Sem_Ch5 is
if T1 = Any_Type then
Error_Msg_N
("no valid types for left-hand side for assignment", Lhs);
Kill_Lhs;
return;
end if;
end if;
......@@ -350,6 +376,7 @@ package body Sem_Ch5 is
and then Ekind (T1) = E_Incomplete_Type
then
Error_Msg_N ("invalid use of incomplete type", Lhs);
Kill_Lhs;
return;
end if;
......@@ -361,6 +388,7 @@ package body Sem_Ch5 is
-- Remaining steps are skipped if Rhs was syntactically in error
if Rhs = Error then
Kill_Lhs;
return;
end if;
......@@ -368,6 +396,7 @@ package body Sem_Ch5 is
if not Covers (T1, T2) then
Wrong_Type (Rhs, Etype (Lhs));
Kill_Lhs;
return;
end if;
......@@ -395,6 +424,7 @@ package body Sem_Ch5 is
end if;
if T1 = Any_Type or else T2 = Any_Type then
Kill_Lhs;
return;
end if;
......@@ -411,13 +441,10 @@ package body Sem_Ch5 is
Error_Msg_N ("dynamically tagged expression required!", Rhs);
end if;
-- Tag propagation is done only in semantics mode only. If expansion
-- is on, the rhs tag indeterminate function call has been expanded
-- and tag propagation would have happened too late, so the
-- propagation take place in expand_call instead.
-- Propagate the tag from a class-wide target to the rhs when the rhs
-- is a tag-indeterminate call.
if not Expander_Active
and then Is_Class_Wide_Type (T1)
if Is_Class_Wide_Type (T1)
and then Is_Tag_Indeterminate (Rhs)
then
Propagate_Tag (Lhs, Rhs);
......@@ -457,10 +484,18 @@ package body Sem_Ch5 is
if Is_Scalar_Type (T1) then
Apply_Scalar_Range_Check (Rhs, Etype (Lhs));
-- For array types, verify that lengths match. If the right hand side
-- if a function call that has been inlined, the assignment has been
-- rewritten as a block, and the constraint check will be applied to the
-- assignment within the block.
elsif Is_Array_Type (T1)
and then
(Nkind (Rhs) /= N_Type_Conversion
or else Is_Constrained (Etype (Rhs)))
or else Is_Constrained (Etype (Rhs)))
and then
(Nkind (Rhs) /= N_Function_Call
or else Nkind (N) /= N_Block_Statement)
then
-- Assignment verifies that the length of the Lsh and Rhs are equal,
-- but of course the indices do not have to match. If the right-hand
......@@ -520,33 +555,59 @@ package body Sem_Ch5 is
Error_Msg_CRT ("composite assignment", N);
end if;
-- One more step. Let's see if we have a simple assignment of a
-- known at compile time value to a simple variable. If so, we
-- can record the value as the current value providing that:
-- Final step. If left side is an entity, then we may be able to
-- reset the current tracked values to new safe values. We only have
-- something to do if the left side is an entity name, and expansion
-- has not modified the node into something other than an assignment,
-- and of course we only capture values if it is safe to do so.
-- We still have a simple assignment statement (no expansion
-- activity has modified it in some peculiar manner)
if Is_Entity_Name (Lhs)
and then Nkind (N) = N_Assignment_Statement
then
declare
Ent : constant Entity_Id := Entity (Lhs);
-- The type is a discrete type
begin
if Safe_To_Capture_Value (N, Ent) then
-- The assignment is to a named entity
-- If we are assigning an access type and the left side is an
-- entity, then make sure that the Is_Known_[Non_]Null flags
-- properly reflect the state of the entity after assignment.
-- The value is known at compile time
if Is_Access_Type (T1) then
if Known_Non_Null (Rhs) then
Set_Is_Known_Non_Null (Ent, True);
if Nkind (N) /= N_Assignment_Statement
or else not Is_Discrete_Type (T1)
or else not Is_Entity_Name (Lhs)
or else not Compile_Time_Known_Value (Rhs)
then
return;
end if;
elsif Known_Null (Rhs)
and then not Can_Never_Be_Null (Ent)
then
Set_Is_Known_Null (Ent, True);
else
Set_Is_Known_Null (Ent, False);
Ent := Entity (Lhs);
if not Can_Never_Be_Null (Ent) then
Set_Is_Known_Non_Null (Ent, False);
end if;
end if;
-- Capture value if safe to do so
-- For discrete types, we may be able to set the current value
-- if the value is known at compile time.
if Safe_To_Capture_Value (N, Ent) then
Set_Current_Value (Ent, Rhs);
elsif Is_Discrete_Type (T1)
and then Compile_Time_Known_Value (Rhs)
then
Set_Current_Value (Ent, Rhs);
else
Set_Current_Value (Ent, Empty);
end if;
-- If not safe to capture values, kill them
else
Kill_Lhs;
end if;
end;
end if;
end Analyze_Assignment;
......@@ -1193,6 +1254,7 @@ package body Sem_Ch5 is
New_Lo_Bound : Node_Id := Empty;
New_Hi_Bound : Node_Id := Empty;
Typ : Entity_Id;
Save_Analysis : Boolean;
function One_Bound
(Original_Bound : Node_Id;
......@@ -1268,9 +1330,64 @@ package body Sem_Ch5 is
begin
-- Determine expected type of range by analyzing separate copy
-- Do the analysis and resolution of the copy of the bounds with
-- expansion disabled, to prevent the generation of finalization
-- actions on each bound. This prevents memory leaks when the
-- bounds contain calls to functions returning controlled arrays.
Set_Parent (R_Copy, Parent (R));
Pre_Analyze_And_Resolve (R_Copy);
Save_Analysis := Full_Analysis;
Full_Analysis := False;
Expander_Mode_Save_And_Set (False);
Analyze (R_Copy);
if Is_Overloaded (R_Copy) then
-- Apply preference rules for range of predefined integer types,
-- or diagnose true ambiguity.
declare
I : Interp_Index;
It : Interp;
Found : Entity_Id := Empty;
begin
Get_First_Interp (R_Copy, I, It);
while Present (It.Typ) loop
if Is_Discrete_Type (It.Typ) then
if No (Found) then
Found := It.Typ;
else
if Scope (Found) = Standard_Standard then
null;
elsif Scope (It.Typ) = Standard_Standard then
Found := It.Typ;
else
-- Both of them are user-defined
Error_Msg_N
("ambiguous bounds in range of iteration",
R_Copy);
Error_Msg_N ("\possible interpretations:", R_Copy);
Error_Msg_NE ("\} ", R_Copy, Found);
Error_Msg_NE ("\} ", R_Copy, It.Typ);
exit;
end if;
end if;
end if;
Get_Next_Interp (I, It);
end loop;
end;
end if;
Resolve (R_Copy);
Expander_Mode_Restore;
Full_Analysis := Save_Analysis;
Typ := Etype (R_Copy);
-- If the type of the discrete range is Universal_Integer, then
......
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2006, 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- --
......@@ -77,6 +77,16 @@ with Validsw; use Validsw;
package body Sem_Ch6 is
-- The following flag is used to indicate that two formals in two
-- subprograms being checked for conformance differ only in that one is
-- an access parameter while the other is of a general access type with
-- the same designated type. In this case, if the rest of the signatures
-- match, a call to either subprogram may be ambiguous, which is worth
-- a warning. The flag is set in Compatible_Types, and the warning emitted
-- in New_Overloaded_Entity.
May_Hide_Profile : Boolean := False;
-----------------------
-- Local Subprograms --
-----------------------
......@@ -141,14 +151,17 @@ package body Sem_Ch6 is
procedure Check_Returns
(HSS : Node_Id;
Mode : Character;
Err : out Boolean);
-- Called to check for missing return statements in a function body, or
-- for returns present in a procedure body which has No_Return set. L is
-- the handled statement sequence for the subprogram body. This procedure
-- checks all flow paths to make sure they either have return (Mode = 'F')
-- or do not have a return (Mode = 'P'). The flag Err is set if there are
-- any control paths not explicitly terminated by a return in the function
-- case, and is True otherwise.
Err : out Boolean;
Proc : Entity_Id := Empty);
-- Called to check for missing return statements in a function body, or for
-- returns present in a procedure body which has No_Return set. L is the
-- handled statement sequence for the subprogram body. This procedure
-- checks all flow paths to make sure they either have return (Mode = 'F',
-- used for functions) or do not have a return (Mode = 'P', used for
-- No_Return procedures). The flag Err is set if there are any control
-- paths not explicitly terminated by a return in the function case, and is
-- True otherwise. Proc is the entity for the procedure case and is used
-- in posting the warning message.
function Conforming_Types
(T1 : Entity_Id;
......@@ -790,7 +803,7 @@ package body Sem_Ch6 is
Error_Msg_N
("cannot return a local value by reference?", N);
Error_Msg_NE
("& will be raised at run time?!",
("\& will be raised at run time?",
N, Standard_Program_Error);
end if;
......@@ -1328,7 +1341,38 @@ package body Sem_Ch6 is
(Etype (First_Entity (Spec_Id))));
end if;
-- Comment needed here, since this is not Ada 2005 stuff! ???
-- Ada 2005: A formal that is an access parameter may have a
-- designated type imported through a limited_with clause, while
-- the body has a regular with clause. Update the types of the
-- formals accordingly, so that the non-limited view of each type
-- is available in the body. We have already verified that the
-- declarations are type-conformant.
if Ada_Version >= Ada_05 then
declare
F_Spec : Entity_Id;
F_Body : Entity_Id;
begin
F_Spec := First_Formal (Spec_Id);
F_Body := First_Formal (Body_Id);
while Present (F_Spec) loop
if Ekind (Etype (F_Spec)) = E_Anonymous_Access_Type
and then
From_With_Type (Designated_Type (Etype (F_Spec)))
then
Set_Etype (F_Spec, Etype (F_Body));
end if;
Next_Formal (F_Spec);
Next_Formal (F_Body);
end loop;
end;
end if;
-- Now make the formals visible, and place subprogram
-- on scope stack.
Install_Formals (Spec_Id);
Last_Formal := Last_Entity (Spec_Id);
......@@ -1508,7 +1552,7 @@ package body Sem_Ch6 is
and then Present (Spec_Id)
and then No_Return (Spec_Id)
then
Check_Returns (HSS, 'P', Missing_Ret);
Check_Returns (HSS, 'P', Missing_Ret, Spec_Id);
end if;
-- Now we are going to check for variables that are never modified in
......@@ -1873,6 +1917,13 @@ package body Sem_Ch6 is
-- conflict with subsequent inlinings, so that it is unsafe to try to
-- inline in such a case.
function Has_Single_Return return Boolean;
-- In general we cannot inline functions that return unconstrained
-- type. However, we can handle such functions if all return statements
-- return a local variable that is the only declaration in the body
-- of the function. In that case the call can be replaced by that
-- local variable as is done for other inlined calls.
procedure Remove_Pragmas;
-- A pragma Unreferenced that mentions a formal parameter has no
-- meaning when the body is inlined and the formals are rewritten.
......@@ -2064,6 +2115,57 @@ package body Sem_Ch6 is
return False;
end Has_Pending_Instantiation;
------------------------
-- Has_Single_Return --
------------------------
function Has_Single_Return return Boolean is
Return_Statement : Node_Id := Empty;
function Check_Return (N : Node_Id) return Traverse_Result;
------------------
-- Check_Return --
------------------
function Check_Return (N : Node_Id) return Traverse_Result is
begin
if Nkind (N) = N_Return_Statement then
if Present (Expression (N))
and then Is_Entity_Name (Expression (N))
then
if No (Return_Statement) then
Return_Statement := N;
return OK;
elsif Chars (Expression (N)) =
Chars (Expression (Return_Statement))
then
return OK;
else
return Abandon;
end if;
else
-- Expression has wrong form
return Abandon;
end if;
else
return OK;
end if;
end Check_Return;
function Check_All_Returns is new Traverse_Func (Check_Return);
-- Start of processing for Has_Single_Return
begin
return Check_All_Returns (N) = OK;
end Has_Single_Return;
--------------------
-- Remove_Pragmas --
--------------------
......@@ -2138,6 +2240,7 @@ package body Sem_Ch6 is
and then not Is_Scalar_Type (Etype (Subp))
and then not Is_Access_Type (Etype (Subp))
and then not Is_Constrained (Etype (Subp))
and then not Has_Single_Return
then
Cannot_Inline
("cannot inline & (unconstrained return type)?", N, Subp);
......@@ -2963,7 +3066,8 @@ package body Sem_Ch6 is
procedure Check_Returns
(HSS : Node_Id;
Mode : Character;
Err : out Boolean)
Err : out Boolean;
Proc : Entity_Id := Empty)
is
Handler : Node_Id;
......@@ -3040,6 +3144,9 @@ package body Sem_Ch6 is
-- missing return curious, and raising Program_Error does not
-- seem such a bad behavior if this does occur.
-- Note that in the Ada 2005 case for Raise_Exception, the actual
-- behavior will be to raise Constraint_Error (see AI-329).
if Is_RTE (Entity (Name (Last_Stm)), RE_Raise_Exception)
or else
Is_RTE (Entity (Name (Last_Stm)), RE_Reraise_Occurrence)
......@@ -3208,10 +3315,9 @@ package body Sem_Ch6 is
-- If we fall through, issue appropriate message
if Mode = 'F' then
if not Raise_Exception_Call then
Error_Msg_N
("?RETURN statement missing following this statement!",
("?RETURN statement missing following this statement",
Last_Stm);
Error_Msg_N
("\?Program_Error may be raised at run time",
......@@ -3225,10 +3331,24 @@ package body Sem_Ch6 is
Err := True;
-- Otherwise we have the case of a procedure marked No_Return
else
Error_Msg_N
("implied return after this statement not allowed (No_Return)",
("?implied return after this statement will raise Program_Error",
Last_Stm);
Error_Msg_NE
("?procedure & is marked as No_Return",
Last_Stm, Proc);
declare
RE : constant Node_Id :=
Make_Raise_Program_Error (Sloc (Last_Stm),
Reason => PE_Implicit_Return);
begin
Insert_After (Last_Stm, RE);
Analyze (RE);
end;
end if;
end Check_Statement_Sequence;
......@@ -3598,6 +3718,17 @@ package body Sem_Ch6 is
-- Otherwise definitely no match
else
if ((Ekind (Type_1) = E_Anonymous_Access_Type
and then Is_Access_Type (Type_2))
or else (Ekind (Type_2) = E_Anonymous_Access_Type
and then Is_Access_Type (Type_1)))
and then
Conforming_Types
(Designated_Type (Type_1), Designated_Type (Type_2), Ctype)
then
May_Hide_Profile := True;
end if;
return False;
end if;
end Conforming_Types;
......@@ -3739,7 +3870,7 @@ package body Sem_Ch6 is
or else
Explicit_Suppress (Scope (E), Accessibility_Check))
and then
(not Present (P_Formal)
(No (P_Formal)
or else Present (Extra_Accessibility (P_Formal)))
then
-- Temporary kludge: for now we avoid creating the extra formal
......@@ -4403,7 +4534,6 @@ package body Sem_Ch6 is
procedure Install_Entity (E : Entity_Id) is
Prev : constant Entity_Id := Current_Entity (E);
begin
Set_Is_Immediately_Visible (E);
Set_Current_Entity (E);
......@@ -4416,10 +4546,8 @@ package body Sem_Ch6 is
procedure Install_Formals (Id : Entity_Id) is
F : Entity_Id;
begin
F := First_Formal (Id);
while Present (F) loop
Install_Entity (F);
Next_Formal (F);
......@@ -4555,7 +4683,7 @@ package body Sem_Ch6 is
Next_Formal (Formal);
end loop;
if not Present (G_Typ) and then Ekind (Prev_E) = E_Function then
if No (G_Typ) and then Ekind (Prev_E) = E_Function then
G_Typ := Get_Generic_Parent_Type (Base_Type (Etype (Prev_E)));
end if;
......@@ -4611,8 +4739,8 @@ package body Sem_Ch6 is
-- formal ancestor type, so the new subprogram is
-- overriding.
if not Present (P_Formal)
and then not Present (N_Formal)
if No (P_Formal)
and then No (N_Formal)
and then (Ekind (New_E) /= E_Function
or else
Types_Correspond
......@@ -4651,67 +4779,77 @@ package body Sem_Ch6 is
Formals : List_Id;
Op_Name : Entity_Id;
A : Entity_Id;
B : Entity_Id;
FF : constant Entity_Id := First_Formal (S);
NF : constant Entity_Id := Next_Formal (FF);
begin
-- Check that equality was properly defined
-- Check that equality was properly defined, ignore call if not
if No (Next_Formal (First_Formal (S))) then
if No (NF) then
return;
end if;
A := Make_Defining_Identifier (Loc, Chars (First_Formal (S)));
B := Make_Defining_Identifier (Loc,
Chars (Next_Formal (First_Formal (S))));
Op_Name := Make_Defining_Operator_Symbol (Loc, Name_Op_Ne);
Formals := New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => A,
Parameter_Type =>
New_Reference_To (Etype (First_Formal (S)), Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => B,
Parameter_Type =>
New_Reference_To (Etype (Next_Formal (First_Formal (S))), Loc)));
Decl :=
Make_Subprogram_Declaration (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => Op_Name,
Parameter_Specifications => Formals,
Result_Definition => New_Reference_To (Standard_Boolean, Loc)));
-- Insert inequality right after equality if it is explicit or after
-- the derived type when implicit. These entities are created only for
-- visibility purposes, and eventually replaced in the course of
-- expansion, so they do not need to be attached to the tree and seen
-- by the back-end. Keeping them internal also avoids spurious freezing
-- problems. The declaration is inserted in the tree for analysis, and
-- removed afterwards. If the equality operator comes from an explicit
-- declaration, attach the inequality immediately after. Else the
-- equality is inherited from a derived type declaration, so insert
-- inequality after that declaration.
if No (Alias (S)) then
Insert_After (Unit_Declaration_Node (S), Decl);
elsif Is_List_Member (Parent (S)) then
Insert_After (Parent (S), Decl);
else
Insert_After (Parent (Etype (First_Formal (S))), Decl);
end if;
declare
A : constant Entity_Id :=
Make_Defining_Identifier (Sloc (FF),
Chars => Chars (FF));
B : constant Entity_Id :=
Make_Defining_Identifier (Sloc (NF),
Chars => Chars (NF));
begin
Op_Name := Make_Defining_Operator_Symbol (Loc, Name_Op_Ne);
Formals := New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => A,
Parameter_Type =>
New_Reference_To (Etype (First_Formal (S)),
Sloc (Etype (First_Formal (S))))),
Make_Parameter_Specification (Loc,
Defining_Identifier => B,
Parameter_Type =>
New_Reference_To (Etype (Next_Formal (First_Formal (S))),
Sloc (Etype (Next_Formal (First_Formal (S)))))));
Decl :=
Make_Subprogram_Declaration (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => Op_Name,
Parameter_Specifications => Formals,
Result_Definition =>
New_Reference_To (Standard_Boolean, Loc)));
-- Insert inequality right after equality if it is explicit or after
-- the derived type when implicit. These entities are created only
-- for visibility purposes, and eventually replaced in the course of
-- expansion, so they do not need to be attached to the tree and seen
-- by the back-end. Keeping them internal also avoids spurious
-- freezing problems. The declaration is inserted in the tree for
-- analysis, and removed afterwards. If the equality operator comes
-- from an explicit declaration, attach the inequality immediately
-- after. Else the equality is inherited from a derived type
-- declaration, so insert inequality after that declaration.
if No (Alias (S)) then
Insert_After (Unit_Declaration_Node (S), Decl);
elsif Is_List_Member (Parent (S)) then
Insert_After (Parent (S), Decl);
else
Insert_After (Parent (Etype (First_Formal (S))), Decl);
end if;
Mark_Rewrite_Insertion (Decl);
Set_Is_Intrinsic_Subprogram (Op_Name);
Analyze (Decl);
Remove (Decl);
Set_Has_Completion (Op_Name);
Set_Corresponding_Equality (Op_Name, S);
Set_Is_Abstract (Op_Name, Is_Abstract (S));
Mark_Rewrite_Insertion (Decl);
Set_Is_Intrinsic_Subprogram (Op_Name);
Analyze (Decl);
Remove (Decl);
Set_Has_Completion (Op_Name);
Set_Corresponding_Equality (Op_Name, S);
Set_Is_Abstract (Op_Name, Is_Abstract (S));
end;
end Make_Inequality_Operator;
----------------------
......@@ -5074,6 +5212,14 @@ package body Sem_Ch6 is
elsif not Is_Alias_Interface
and then Type_Conformant (E, S)
-- Ada 2005 (AI-251): Do not consider here entities that cover
-- abstract interface primitives. They will be handled after
-- the overriden entity is found (see comments bellow inside
-- this subprogram).
and then not (Is_Subprogram (E)
and then Present (Abstract_Interface_Alias (E)))
then
-- If the old and new entities have the same profile and one
-- is not the body of the other, then this is an error, unless
......@@ -5159,7 +5305,7 @@ package body Sem_Ch6 is
if Is_Non_Overriding_Operation (E, S) then
Enter_Overloaded_Entity (S);
if not Present (Derived_Type)
if No (Derived_Type)
or else Is_Tagged_Type (Derived_Type)
then
Check_Dispatching_Operation (S, Empty);
......@@ -5289,7 +5435,7 @@ package body Sem_Ch6 is
-- E is inherited.
if Comes_From_Source (S) then
if Present (Alias (E)) then
if Present (Alias (E)) then
Set_Overridden_Operation (S, Alias (E));
else
Set_Overridden_Operation (S, E);
......@@ -5344,6 +5490,27 @@ package body Sem_Ch6 is
Check_Dispatching_Operation (S, E);
-- AI-251: Handle the case in which the entity
-- overrides a primitive operation that covered
-- several abstract interface primitives.
declare
E1 : Entity_Id;
begin
E1 := Current_Entity_In_Scope (S);
while Present (E1) loop
if Is_Subprogram (E1)
and then Present
(Abstract_Interface_Alias (E1))
and then Alias (E1) = E
then
Set_Alias (E1, S);
end if;
E1 := Homonym (E1);
end loop;
end;
else
Check_Dispatching_Operation (S, Empty);
end if;
......@@ -5389,7 +5556,48 @@ package body Sem_Ch6 is
end if;
else
null;
-- If one subprogram has an access parameter and the other
-- a parameter of an access type, calls to either might be
-- ambiguous. Verify that parameters match except for the
-- access parameter.
if May_Hide_Profile then
declare
F1 : Entity_Id;
F2 : Entity_Id;
begin
F1 := First_Formal (S);
F2 := First_Formal (E);
while Present (F1) and then Present (F2) loop
if Is_Access_Type (Etype (F1)) then
if not Is_Access_Type (Etype (F2))
or else not Conforming_Types
(Designated_Type (Etype (F1)),
Designated_Type (Etype (F2)),
Type_Conformant)
then
May_Hide_Profile := False;
end if;
elsif
not Conforming_Types
(Etype (F1), Etype (F2), Type_Conformant)
then
May_Hide_Profile := False;
end if;
Next_Formal (F1);
Next_Formal (F2);
end loop;
if May_Hide_Profile
and then No (F1)
and then No (F2)
then
Error_Msg_NE ("calls to& may be ambiguous?", S, S);
end if;
end;
end if;
end if;
Prev_Vis := E;
......@@ -5407,7 +5615,7 @@ package body Sem_Ch6 is
-- operation was dispatching), so we don't call
-- Check_Dispatching_Operation in that case.
if not Present (Derived_Type)
if No (Derived_Type)
or else Is_Tagged_Type (Derived_Type)
then
Check_Dispatching_Operation (S, Empty);
......@@ -5922,6 +6130,8 @@ package body Sem_Ch6 is
is
Result : Boolean;
begin
May_Hide_Profile := False;
Check_Conformance
(New_Id, Old_Id, Type_Conformant, False, Result,
Skip_Controlling_Formals => Skip_Controlling_Formals);
......
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2006, 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- --
......@@ -90,11 +90,6 @@ package body Sem_Res is
-- Give list of candidate interpretations when a character literal cannot
-- be resolved.
procedure Check_Direct_Boolean_Op (N : Node_Id);
-- N is a binary operator node which may possibly operate on Boolean
-- operands. If the operator does have Boolean operands, then a call is
-- made to check the restriction No_Direct_Boolean_Operators.
procedure Check_Discriminant_Use (N : Node_Id);
-- Enforce the restrictions on the use of discriminants when constraining
-- a component of a discriminated type (record or concurrent type).
......@@ -105,6 +100,11 @@ package body Sem_Res is
-- universal must be checked for visibility during resolution
-- because their type is not determinable based on their operands.
procedure Check_Fully_Declared_Prefix
(Typ : Entity_Id;
Pref : Node_Id);
-- Check that the type of the prefix of a dereference is not incomplete
function Check_Infinite_Recursion (N : Node_Id) return Boolean;
-- Given a call node, N, which is known to occur immediately within the
-- subprogram being called, determines whether it is a detectable case of
......@@ -346,19 +346,6 @@ package body Sem_Res is
end if;
end Analyze_And_Resolve;
-----------------------------
-- Check_Direct_Boolean_Op --
-----------------------------
procedure Check_Direct_Boolean_Op (N : Node_Id) is
begin
if Nkind (N) in N_Op
and then Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean
then
Check_Restriction (No_Direct_Boolean_Operators, N);
end if;
end Check_Direct_Boolean_Op;
----------------------------
-- Check_Discriminant_Use --
----------------------------
......@@ -472,7 +459,7 @@ package body Sem_Res is
-- Check that it is the high bound
if N /= High_Bound (PN)
or else not Present (Discriminant_Default_Value (Disc))
or else No (Discriminant_Default_Value (Disc))
then
goto No_Danger;
end if;
......@@ -600,6 +587,54 @@ package body Sem_Res is
end if;
end Check_For_Visible_Operator;
----------------------------------
-- Check_Fully_Declared_Prefix --
----------------------------------
procedure Check_Fully_Declared_Prefix
(Typ : Entity_Id;
Pref : Node_Id)
is
begin
-- Check that the designated type of the prefix of a dereference is
-- not an incomplete type. This cannot be done unconditionally, because
-- dereferences of private types are legal in default expressions. This
-- case is taken care of in Check_Fully_Declared, called below. There
-- are also 2005 cases where it is legal for the prefix to be unfrozen.
-- This consideration also applies to similar checks for allocators,
-- qualified expressions, and type conversions.
-- An additional exception concerns other per-object expressions that
-- are not directly related to component declarations, in particular
-- representation pragmas for tasks. These will be per-object
-- expressions if they depend on discriminants or some global entity.
-- If the task has access discriminants, the designated type may be
-- incomplete at the point the expression is resolved. This resolution
-- takes place within the body of the initialization procedure, where
-- the discriminant is replaced by its discriminal.
if Is_Entity_Name (Pref)
and then Ekind (Entity (Pref)) = E_In_Parameter
then
null;
-- Ada 2005 (AI-326): Tagged incomplete types allowed. The wrong usages
-- are handled by Analyze_Access_Attribute, Analyze_Assignment,
-- Analyze_Object_Renaming, and Freeze_Entity.
elsif Ada_Version >= Ada_05
and then Is_Entity_Name (Pref)
and then Ekind (Directly_Designated_Type (Etype (Pref))) =
E_Incomplete_Type
and then Is_Tagged_Type (Directly_Designated_Type (Etype (Pref)))
then
null;
else
Check_Fully_Declared (Typ, Parent (Pref));
end if;
end Check_Fully_Declared_Prefix;
------------------------------
-- Check_Infinite_Recursion --
------------------------------
......@@ -1156,6 +1191,15 @@ package body Sem_Res is
Error := True;
end if;
-- Ada 2005, AI-420: Predefined equality on Universal_Access
-- is available.
elsif Ada_Version >= Ada_05
and then (Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne)
and then Ekind (Etype (Act1)) = E_Anonymous_Access_Type
then
null;
else
Opnd_Type := Base_Type (Etype (Right_Opnd (Op_Node)));
......@@ -1899,7 +1943,7 @@ package body Sem_Res is
-- Move to next interpretation
exit Interp_Loop when not Present (It.Typ);
exit Interp_Loop when No (It.Typ);
Get_Next_Interp (I, It);
end loop Interp_Loop;
......@@ -2512,7 +2556,7 @@ package body Sem_Res is
Set_First_Named_Actual (N, Actval);
if No (Prev) then
if not Present (Parameter_Associations (N)) then
if No (Parameter_Associations (N)) then
Set_Parameter_Associations (N, New_List (Assoc));
else
Append (Assoc, Parameter_Associations (N));
......@@ -2594,7 +2638,7 @@ package body Sem_Res is
-- the tag check to occur and no temporary will be needed (no
-- representation change can occur) and the parameter is passed by
-- reference, so we go ahead and resolve the type conversion.
-- Another excpetion is the case of reference to component or
-- Another exception is the case of reference to component or
-- subcomponent of a bit-packed array, in which case we want to
-- defer expansion to the point the in and out assignments are
-- performed.
......@@ -2666,6 +2710,33 @@ package body Sem_Res is
end if;
end if;
-- (Ada 2005: AI-251): If the actual is an allocator whose
-- directly designated type is a class-wide interface, we build
-- an anonymous access type to use it as the type of the
-- allocator. Later, when the subprogram call is expanded, if
-- the interface has a secondary dispatch table the expander
-- will add a type conversion to force the correct displacement
-- of the pointer.
if Nkind (A) = N_Allocator then
declare
DDT : constant Entity_Id :=
Directly_Designated_Type (Base_Type (Etype (F)));
New_Itype : Entity_Id;
begin
if Is_Class_Wide_Type (DDT)
and then Is_Interface (DDT)
then
New_Itype := Create_Itype (E_Anonymous_Access_Type, A);
Set_Etype (New_Itype, Etype (A));
Init_Size_Align (New_Itype);
Set_Directly_Designated_Type (New_Itype,
Directly_Designated_Type (Etype (A)));
Set_Etype (A, New_Itype);
end if;
end;
end if;
Resolve (A, Etype (F));
end if;
......@@ -3090,7 +3161,8 @@ package body Sem_Res is
if In_Instance_Body then
Error_Msg_N ("?type in allocator has deeper level than" &
" designated class-wide type", E);
Error_Msg_N ("?Program_Error will be raised at run time", E);
Error_Msg_N ("\?Program_Error will be raised at run time",
E);
Rewrite (N,
Make_Raise_Program_Error (Sloc (N),
Reason => PE_Accessibility_Check_Failed));
......@@ -3109,8 +3181,8 @@ package body Sem_Res is
declare
Loc : constant Source_Ptr := Sloc (N);
begin
Error_Msg_N ("?allocation from empty storage pool!", N);
Error_Msg_N ("?Storage_Error will be raised at run time!", N);
Error_Msg_N ("?allocation from empty storage pool", N);
Error_Msg_N ("\?Storage_Error will be raised at run time", N);
Insert_Action (N,
Make_Raise_Storage_Error (Loc,
Reason => SE_Empty_Storage_Pool));
......@@ -3708,8 +3780,7 @@ package body Sem_Res is
and then not Is_Controlling_Limited_Procedure (Nam)
then
Error_Msg_N
("entry call, entry renaming or dispatching primitive " &
"of limited or synchronized interface required", N);
("entry call or dispatching primitive of interface required", N);
end if;
end if;
......@@ -3869,7 +3940,7 @@ package body Sem_Res is
then
Set_Has_Recursive_Call (Nam);
Error_Msg_N ("possible infinite recursion?", N);
Error_Msg_N ("Storage_Error may be raised at run time?", N);
Error_Msg_N ("\Storage_Error may be raised at run time?", N);
end if;
exit;
......@@ -3909,7 +3980,18 @@ package body Sem_Res is
-- for it, precisely because we will not do it within the init proc
-- itself.
if Expander_Active
-- If the subprogram is marked Inlined_Always, then even if it returns
-- an unconstrained type the call does not require use of the secondary
-- stack.
if Is_Inlined (Nam)
and then Present (First_Rep_Item (Nam))
and then Nkind (First_Rep_Item (Nam)) = N_Pragma
and then Chars (First_Rep_Item (Nam)) = Name_Inline_Always
then
null;
elsif Expander_Active
and then Is_Type (Etype (Nam))
and then Requires_Transient_Scope (Etype (Nam))
and then Ekind (Nam) /= E_Enumeration_Literal
......@@ -4120,7 +4202,6 @@ package body Sem_Res is
Check_Unset_Reference (R);
Generate_Operator_Reference (N, T);
Eval_Relational_Op (N);
Check_Direct_Boolean_Op (N);
end if;
end if;
end Resolve_Comparison_Op;
......@@ -4875,7 +4956,31 @@ package body Sem_Res is
Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N));
end if;
Check_Direct_Boolean_Op (N);
-- Ada 2005: If one operand is an anonymous access type, convert
-- the other operand to it, to ensure that the underlying types
-- match in the back-end.
-- We apply the same conversion in the case one of the operands is
-- a private subtype of the type of the other.
if Ekind (T) = E_Anonymous_Access_Type
or else Is_Private_Type (T)
then
if Etype (L) /= T then
Rewrite (L,
Make_Unchecked_Type_Conversion (Sloc (L),
Subtype_Mark => New_Occurrence_Of (T, Sloc (L)),
Expression => Relocate_Node (L)));
Analyze_And_Resolve (L, T);
end if;
if (Etype (R)) /= T then
Rewrite (R,
Make_Unchecked_Type_Conversion (Sloc (R),
Subtype_Mark => New_Occurrence_Of (Etype (L), Sloc (R)),
Expression => Relocate_Node (R)));
Analyze_And_Resolve (R, T);
end if;
end if;
end if;
end Resolve_Equality_Op;
......@@ -4891,42 +4996,7 @@ package body Sem_Res is
It : Interp;
begin
-- Now that we know the type, check that this is not dereference of an
-- uncompleted type. Note that this is not entirely correct, because
-- dereferences of private types are legal in default expressions. This
-- exception is taken care of in Check_Fully_Declared.
-- This consideration also applies to similar checks for allocators,
-- qualified expressions, and type conversions.
-- An additional exception concerns other per-object expressions that
-- are not directly related to component declarations, in particular
-- representation pragmas for tasks. These will be per-object
-- expressions if they depend on discriminants or some global entity.
-- If the task has access discriminants, the designated type may be
-- incomplete at the point the expression is resolved. This resolution
-- takes place within the body of the initialization procedure, where
-- the discriminant is replaced by its discriminal.
if Is_Entity_Name (Prefix (N))
and then Ekind (Entity (Prefix (N))) = E_In_Parameter
then
null;
-- Ada 2005 (AI-326): Tagged incomplete types allowed. The wrong usages
-- are handled by Analyze_Access_Attribute, Analyze_Assignment, Analyze_
-- Object_Renaming, and Freeze_Entity.
elsif Ada_Version >= Ada_05
and then Is_Entity_Name (Prefix (N))
and then Ekind (Directly_Designated_Type (Etype (Prefix (N))))
= E_Incomplete_Type
and then Is_Tagged_Type (Directly_Designated_Type (Etype (Prefix (N))))
then
null;
else
Check_Fully_Declared (Typ, N);
end if;
Check_Fully_Declared_Prefix (Typ, P);
if Is_Overloaded (P) then
......@@ -5239,6 +5309,7 @@ package body Sem_Res is
procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id) is
B_Typ : Entity_Id;
N_Opr : constant Node_Kind := Nkind (N);
begin
-- Predefined operations on scalar types yield the base type. On the
......@@ -5283,7 +5354,15 @@ package body Sem_Res is
Set_Etype (N, B_Typ);
Generate_Operator_Reference (N, B_Typ);
Eval_Logical_Op (N);
Check_Direct_Boolean_Op (N);
-- Check for violation of restriction No_Direct_Boolean_Operators
-- if the operator was not eliminated by the Eval_Logical_Op call.
if Nkind (N) = N_Opr
and then Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean
then
Check_Restriction (No_Direct_Boolean_Operators, N);
end if;
end Resolve_Logical_Op;
---------------------------
......@@ -5319,7 +5398,7 @@ package body Sem_Res is
-- type I is interface;
-- type T is tagged ...
-- function Test (O : in I'Class) is
-- function Test (O : I'Class) is
-- begin
-- return O in T'Class.
-- end Test;
......@@ -5994,12 +6073,21 @@ package body Sem_Res is
else
It1 := It;
if Scope (Comp1) /= It1.Typ then
-- There may be an implicit dereference. Retrieve
-- designated record type.
if Is_Access_Type (It1.Typ) then
T := Designated_Type (It1.Typ);
else
T := It1.Typ;
end if;
if Scope (Comp1) /= T then
-- Resolution chooses the new interpretation.
-- Find the component with the right name.
Comp1 := First_Entity (It1.Typ);
Comp1 := First_Entity (T);
while Present (Comp1)
and then Chars (Comp1) /= Chars (S)
loop
......@@ -6030,12 +6118,13 @@ package body Sem_Res is
Resolve (P, T);
end if;
-- If prefix is an access type, the node will be transformed into
-- an explicit dereference during expansion. The type of the node
-- is the designated type of that of the prefix.
-- If prefix is an access type, the node will be transformed into an
-- explicit dereference during expansion. The type of the node is the
-- designated type of that of the prefix.
if Is_Access_Type (Etype (P)) then
T := Designated_Type (Etype (P));
Check_Fully_Declared_Prefix (T, P);
else
T := Etype (P);
end if;
......@@ -6183,11 +6272,11 @@ package body Sem_Res is
Apply_Access_Check (N);
Array_Type := Designated_Type (Array_Type);
-- If the prefix is an access to an unconstrained array, we must
-- use the actual subtype of the object to perform the index checks.
-- The object denoted by the prefix is implicit in the node, so we
-- build an explicit representation for it in order to compute the
-- actual subtype.
-- If the prefix is an access to an unconstrained array, we must use
-- the actual subtype of the object to perform the index checks. The
-- object denoted by the prefix is implicit in the node, so we build
-- an explicit representation for it in order to compute the actual
-- subtype.
if not Is_Constrained (Array_Type) then
Remove_Side_Effects (Prefix (N));
......@@ -6214,8 +6303,8 @@ package body Sem_Res is
Set_Etype (N, Array_Type);
-- If the range is specified by a subtype mark, no resolution
-- is necessary. Else resolve the bounds, and apply needed checks.
-- If the range is specified by a subtype mark, no resolution is
-- necessary. Else resolve the bounds, and apply needed checks.
if not Is_Entity_Name (Drange) then
Index := First_Index (Array_Type);
......@@ -6246,13 +6335,13 @@ package body Sem_Res is
begin
-- For a string appearing in a concatenation, defer creation of the
-- string_literal_subtype until the end of the resolution of the
-- concatenation, because the literal may be constant-folded away.
-- This is a useful optimization for long concatenation expressions.
-- concatenation, because the literal may be constant-folded away. This
-- is a useful optimization for long concatenation expressions.
-- If the string is an aggregate built for a single character (which
-- If the string is an aggregate built for a single character (which
-- happens in a non-static context) or a is null string to which special
-- checks may apply, we build the subtype. Wide strings must also get
-- a string subtype if they come from a one character aggregate. Strings
-- checks may apply, we build the subtype. Wide strings must also get a
-- string subtype if they come from a one character aggregate. Strings
-- generated by attributes might be static, but it is often hard to
-- determine whether the enclosing context is static, so we generate
-- subtypes for them as well, thus losing some rarer optimizations ???
......@@ -6311,15 +6400,15 @@ package body Sem_Res is
if Strlen = 0 then
return;
-- Always accept string literal with component type Any_Character,
-- which occurs in error situations and in comparisons of literals,
-- both of which should accept all literals.
-- Always accept string literal with component type Any_Character, which
-- occurs in error situations and in comparisons of literals, both of
-- which should accept all literals.
elsif R_Typ = Any_Character then
return;
-- If the type is bit-packed, then we always tranform the string
-- literal into a full fledged aggregate.
-- If the type is bit-packed, then we always tranform the string literal
-- into a full fledged aggregate.
elsif Is_Bit_Packed_Array (Typ) then
null;
......@@ -6335,14 +6424,14 @@ package body Sem_Res is
if R_Typ = Standard_Wide_Wide_Character then
null;
-- For the case of Standard.String, or any other type whose
-- component type is Standard.Character, we must make sure that
-- there are no wide characters in the string, i.e. that it is
-- entirely composed of characters in range of type Character.
-- For the case of Standard.String, or any other type whose component
-- type is Standard.Character, we must make sure that there are no
-- wide characters in the string, i.e. that it is entirely composed
-- of characters in range of type Character.
-- If the string literal is the result of a static concatenation,
-- the test has already been performed on the components, and need
-- not be repeated.
-- If the string literal is the result of a static concatenation, the
-- test has already been performed on the components, and need not be
-- repeated.
elsif R_Typ = Standard_Character
and then Nkind (Original_Node (N)) /= N_Op_Concat
......@@ -6398,11 +6487,11 @@ package body Sem_Res is
null;
end if;
-- See if the component type of the array corresponding to the
-- string has compile time known bounds. If yes we can directly
-- check whether the evaluation of the string will raise constraint
-- error. Otherwise we need to transform the string literal into
-- the corresponding character aggregate and let the aggregate
-- See if the component type of the array corresponding to the string
-- has compile time known bounds. If yes we can directly check
-- whether the evaluation of the string will raise constraint error.
-- Otherwise we need to transform the string literal into the
-- corresponding character aggregate and let the aggregate
-- code do the checking.
if R_Typ = Standard_Character
......@@ -6457,9 +6546,9 @@ package body Sem_Res is
C : Char_Code;
begin
-- Build the character literals, we give them source locations
-- that correspond to the string positions, which is a bit tricky
-- given the possible presence of wide character escape sequences.
-- Build the character literals, we give them source locations that
-- correspond to the string positions, which is a bit tricky given
-- the possible presence of wide character escape sequences.
for J in 1 .. Strlen loop
C := Get_String_Char (Str, J);
......@@ -6666,6 +6755,14 @@ package body Sem_Res is
Opnd_Type := Etype (Opnd_Type);
end if;
-- Handle subtypes
if Ekind (Opnd_Type) = E_Protected_Subtype
or else Ekind (Opnd_Type) = E_Task_Subtype
then
Opnd_Type := Etype (Opnd_Type);
end if;
if not Interface_Present_In_Ancestor
(Typ => Opnd_Type,
Iface => Target_Type)
......@@ -6686,20 +6783,7 @@ package body Sem_Res is
end if;
else
-- If a conversion to an interface type appears as an actual
-- in a source call, it will be expanded when the enclosing
-- call itself is examined in Expand_Interface_Formals.
-- Otherwise, generate the proper conversion code now, using
-- the tag of the interface.
if (Nkind (Parent (N)) = N_Procedure_Call_Statement
or else Nkind (Parent (N)) = N_Function_Call)
and then Comes_From_Source (N)
then
null;
else
Expand_Interface_Conversion (N);
end if;
Expand_Interface_Conversion (N);
end if;
end;
end if;
......@@ -6989,29 +7073,85 @@ package body Sem_Res is
--------------------------------
procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
Low_Bound : constant Node_Id :=
Type_Low_Bound (Etype (First_Index (Typ)));
Subtype_Id : Entity_Id;
begin
if Nkind (N) /= N_String_Literal then
return;
else
Subtype_Id := Create_Itype (E_String_Literal_Subtype, N);
end if;
Subtype_Id := Create_Itype (E_String_Literal_Subtype, N);
Set_String_Literal_Length (Subtype_Id, UI_From_Int
(String_Length (Strval (N))));
Set_Etype (Subtype_Id, Base_Type (Typ));
Set_Is_Constrained (Subtype_Id);
Set_Etype (Subtype_Id, Base_Type (Typ));
Set_Is_Constrained (Subtype_Id);
Set_Etype (N, Subtype_Id);
if Is_OK_Static_Expression (Low_Bound) then
-- The low bound is set from the low bound of the corresponding
-- index type. Note that we do not store the high bound in the
-- string literal subtype, but it can be deduced if necssary
-- string literal subtype, but it can be deduced if necessary
-- from the length and the low bound.
Set_String_Literal_Low_Bound
(Subtype_Id, Type_Low_Bound (Etype (First_Index (Typ))));
Set_String_Literal_Low_Bound (Subtype_Id, Low_Bound);
Set_Etype (N, Subtype_Id);
else
Set_String_Literal_Low_Bound
(Subtype_Id, Make_Integer_Literal (Loc, 1));
Set_Etype (String_Literal_Low_Bound (Subtype_Id), Standard_Positive);
-- Build bona fide subtypes for the string, and wrap it in an
-- unchecked conversion, because the backend expects the
-- String_Literal_Subtype to have a static lower bound.
declare
Index_List : constant List_Id := New_List;
Index_Type : constant Entity_Id := Etype (First_Index (Typ));
High_Bound : constant Node_Id :=
Make_Op_Add (Loc,
Left_Opnd => New_Copy_Tree (Low_Bound),
Right_Opnd =>
Make_Integer_Literal (Loc,
String_Length (Strval (N)) - 1));
Array_Subtype : Entity_Id;
Index_Subtype : Entity_Id;
Drange : Node_Id;
Index : Node_Id;
begin
Index_Subtype :=
Create_Itype (Subtype_Kind (Ekind (Index_Type)), N);
Drange := Make_Range (Loc, Low_Bound, High_Bound);
Set_Scalar_Range (Index_Subtype, Drange);
Set_Parent (Drange, N);
Analyze_And_Resolve (Drange, Index_Type);
Set_Etype (Index_Subtype, Index_Type);
Set_Size_Info (Index_Subtype, Index_Type);
Set_RM_Size (Index_Subtype, RM_Size (Index_Type));
Array_Subtype := Create_Itype (E_Array_Subtype, N);
Index := New_Occurrence_Of (Index_Subtype, Loc);
Set_Etype (Index, Index_Subtype);
Append (Index, Index_List);
Set_First_Index (Array_Subtype, Index);
Set_Etype (Array_Subtype, Base_Type (Typ));
Set_Is_Constrained (Array_Subtype, True);
Init_Size_Align (Array_Subtype);
Rewrite (N,
Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark => New_Occurrence_Of (Array_Subtype, Loc),
Expression => Relocate_Node (N)));
Set_Etype (N, Array_Subtype);
end;
end if;
end Set_String_Literal_Subtype;
-----------------------------
......@@ -7349,19 +7489,35 @@ package body Sem_Res is
Next_Index (Opnd_Index);
end loop;
if Base_Type (Target_Comp_Type) /=
Base_Type (Opnd_Comp_Type)
then
Error_Msg_N
("incompatible component types for array conversion",
Operand);
return False;
declare
BT : constant Entity_Id := Base_Type (Target_Comp_Type);
BO : constant Entity_Id := Base_Type (Opnd_Comp_Type);
elsif
Is_Constrained (Target_Comp_Type)
/= Is_Constrained (Opnd_Comp_Type)
or else not Subtypes_Statically_Match
(Target_Comp_Type, Opnd_Comp_Type)
begin
if BT = BO then
null;
elsif
(Ekind (BT) = E_Anonymous_Access_Type
or else Ekind (BT) = E_Anonymous_Access_Subprogram_Type)
and then Ekind (BO) = Ekind (BT)
and then Subtypes_Statically_Match
(Target_Comp_Type, Opnd_Comp_Type)
then
null;
else
Error_Msg_N
("incompatible component types for array conversion",
Operand);
return False;
end if;
end;
if Is_Constrained (Target_Comp_Type) /=
Is_Constrained (Opnd_Comp_Type)
or else not Subtypes_Statically_Match
(Target_Comp_Type, Opnd_Comp_Type)
then
Error_Msg_N
("component subtypes must statically match", Operand);
......@@ -7396,8 +7552,7 @@ package body Sem_Res is
("?cannot convert local pointer to non-local access type",
Operand);
Error_Msg_N
("?Program_Error will be raised at run time", Operand);
("\?Program_Error will be raised at run time", Operand);
else
Error_Msg_N
("cannot convert local pointer to non-local access type",
......@@ -7417,8 +7572,8 @@ package body Sem_Res is
-- handles checking the prefix of the operand for this case.)
if Nkind (Operand) = N_Selected_Component
and then Object_Access_Level (Operand)
> Type_Access_Level (Target_Type)
and then Object_Access_Level (Operand) >
Type_Access_Level (Target_Type)
then
-- In an instance, this is a run-time check, but one we
-- know will fail, so generate an appropriate warning.
......@@ -7429,8 +7584,7 @@ package body Sem_Res is
("?cannot convert access discriminant to non-local" &
" access type", Operand);
Error_Msg_N
("?Program_Error will be raised at run time", Operand);
("\?Program_Error will be raised at run time", Operand);
else
Error_Msg_N
("cannot convert access discriminant to non-local" &
......@@ -7499,7 +7653,7 @@ package body Sem_Res is
("?cannot convert local pointer to non-local access type",
Operand);
Error_Msg_N
("?Program_Error will be raised at run time", Operand);
("\?Program_Error will be raised at run time", Operand);
else
Error_Msg_N
......@@ -7533,7 +7687,8 @@ package body Sem_Res is
("?cannot convert access discriminant to non-local" &
" access type", Operand);
Error_Msg_N
("?Program_Error will be raised at run time", Operand);
("\?Program_Error will be raised at run time",
Operand);
else
Error_Msg_N
......
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