Skip to content

R
riscv-gcc-1
Commit 45fc7ddb by Hristian Kirtchev Committed by Arnaud Charlet
Options

exp_ch2.adb: Minor reformatting. 

2008-04-08  Hristian Kirtchev  <kirtchev@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Robert Dewar  <dewar@adacore.com>

	* exp_ch2.adb: Minor reformatting.
	(Expand_Entry_Index_Parameter): Set the type of the identifier.
	(Expand_Entry_Reference): Add call to Expand_Protected_Component.
	(Expand_Protected_Component): New routine.
	(Expand_Protected_Private): Removed.
	Add Sure parameter to Note_Possible_Modification calls

	* sem_ch12.ads, sem_ch12.adb (Analyze_Subprogram_Instantiation): The
	generated subprogram declaration must inherit the overriding indicator
	from the instantiation node.
	(Validate_Access_Type_Instance): If the designated type of the actual is
	a limited view, use the available view in all cases, not only if the
	type is an incomplete type.
	(Instantiate_Object):  Actual is illegal if the formal is null-excluding
	and the actual subtype does not exclude null.
	(Process_Default): Handle properly abstract formal subprograms.
	(Check_Formal_Package_Instance): Handle properly defaulted formal
	subprograms in a partially parameterized formal package.
	Add Sure parameter to Note_Possible_Modification calls
	(Validate_Derived_Type_Instance): if the formal is non-limited, the
	actual cannot be limited.
	(Collect_Previous_Instances): Generate instance bodies for subprograms
	as well.

	* sem_ch13.adb (Analyze_Attribute_Definition_Clause, case Small): Don't
	try to set RM_Size.
	Add Sure parameter to Note_Possible_Modification calls
	(Analyze_At_Clause): Preserve Comes_From_Source on Rewrite call
	(Analyze_Attribute_Definition_Clause, case Attribute_Address): Check for
	constant overlaid by variable and issue warning.
	Use new Is_Standard_Character_Type predicate
	(Analyze_Record_Representation_Clause): Check that the specified
	Last_Bit is not less than First_Bit - 1.
	(Analyze_Attribute_Definition_Clause, case Address): Check for
	self-referential address clause

	* sem_ch5.ads, sem_ch5.adb (Diagnose_Non_Variable_Lhs): Rewrite the
	detection mechanism when the lhs is a prival.
	(Analyze_Assignment): Call Check_Unprotected_Access to detect
	assignment of a pointer to protected data, to an object declared
	outside of the protected object.
	(Analyze_Loop_Statement): Check for unreachable code after loop
	Add Sure parameter to Note_Possible_Modication calls
	Protect analysis from previous syntax error such as a scope mismatch
	or a missing begin.
	(Analyze_Assignment_Statement): The assignment is illegal if the
	left-hand is an interface.

	* sem_res.adb (Resolve_Arithmetic_Op): For mod/rem check violation of
	restriction No_Implicit_Conditionals
	Add Sure parameter to Note_Possible_Modication calls
	Use new Is_Standard_Character_Type predicate
	(Make_Call_Into_Operator): Preserve Comes_From_Source when rewriting
	call as operator. Fixes problems (e.g. validity checking) which
	come from the result looking as though it does not come from source).
	(Resolve_Call): Check case of name in named parameter if style checks
	are enabled.
	(Resolve_Call): Exclude calls to Current_Task as entry formal defaults
	from the checking that such calls should not occur from an entry body.
	(Resolve_Call): If the return type of an Inline_Always function
	requires the secondary stack, create a transient scope for the call
	if the body of the function is not available for inlining.
	(Resolve_Actuals): Apply Ada2005 checks to view conversions of arrays
	that are actuals for in-out formals.
	(Try_Object_Operation): If prefix is a tagged protected object,retrieve
	primitive operations from base type.
	(Analyze_Selected_Component): If the context is a call to a protected
	operation the parent may be an indexed component prior to expansion.
	(Resolve_Actuals): If an actual is of a protected subtype, use its
	base type to determine whether a conversion to the corresponding record
	is needed.
	(Resolve_Short_Circuit): Handle pragma Check

	* sem_eval.adb: Minor code reorganization (usea Is_Constant_Object)
	Use new Is_Standard_Character_Type predicate
	(Eval_Relational_Op): Catch more cases of string comparison

From-SVN: r134027
parent b4592168
Showing with 355 additions and 197 deletions
gcc/ada/exp_ch2.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2008, 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- --
......@@ -80,12 +80,12 @@ package body Exp_Ch2 is
-- Dispatches to specific expansion procedures.
procedure Expand_Entry_Index_Parameter (N : Node_Id);
-- A reference to the identifier in the entry index specification of
-- protected entry body is modified to a reference to a constant definition
-- equal to the index of the entry family member being called. This
-- constant is calculated as part of the elaboration of the expanded code
-- for the body, and is calculated from the object-wide entry index
-- returned by Next_Entry_Call.
-- A reference to the identifier in the entry index specification of an
-- entry body is modified to a reference to a constant definition equal to
-- the index of the entry family member being called. This constant is
-- calculated as part of the elaboration of the expanded code for the body,
-- and is calculated from the object-wide entry index returned by Next_
-- Entry_Call.
procedure Expand_Entry_Parameter (N : Node_Id);
-- A reference to an entry parameter is modified to be a reference to the
......@@ -98,12 +98,10 @@ package body Exp_Ch2 is
-- represent the operation within the protected object. In other cases
-- Expand_Formal is a no-op.
procedure Expand_Protected_Private (N : Node_Id);
-- A reference to a private component of a protected type is expanded to a
-- component selected from the record used to implement the protected
-- object. Such a record is passed to all operations on a protected object
-- in a parameter named _object. This object is a constant in the body of a
-- function, and a variable within a procedure or entry body.
procedure Expand_Protected_Component (N : Node_Id);
-- A reference to a private component of a protected type is expanded into
-- a reference to the corresponding prival in the current protected entry
-- or subprogram.
procedure Expand_Renaming (N : Node_Id);
-- For renamings, just replace the identifier by the corresponding
......@@ -332,16 +330,12 @@ package body Exp_Ch2 is
elsif Is_Entry_Formal (E) then
Expand_Entry_Parameter (N);
elsif Ekind (E) = E_Component
and then Is_Protected_Private (E)
then
-- Protect against junk use of tasking in no run time mode
elsif Is_Protected_Component (E) then
if No_Run_Time_Mode then
return;
end if;
Expand_Protected_Private (N);
Expand_Protected_Component (N);
elsif Ekind (E) = E_Entry_Index_Parameter then
Expand_Entry_Index_Parameter (N);
......@@ -385,11 +379,7 @@ package body Exp_Ch2 is
-- Interpret possible Current_Value for constant case
elsif (Ekind (E) = E_Constant
or else
Ekind (E) = E_In_Parameter
or else
Ekind (E) = E_Loop_Parameter)
elsif Is_Constant_Object (E)
and then Present (Current_Value (E))
then
Expand_Current_Value (N);
......@@ -401,8 +391,10 @@ package body Exp_Ch2 is
----------------------------------
procedure Expand_Entry_Index_Parameter (N : Node_Id) is
Index_Con : constant Entity_Id := Entry_Index_Constant (Entity (N));
begin
Set_Entity (N, Entry_Index_Constant (Entity (N)));
Set_Entity (N, Index_Con);
Set_Etype (N, Etype (Index_Con));
end Expand_Entry_Index_Parameter;
----------------------------
......@@ -477,10 +469,14 @@ package body Exp_Ch2 is
-- we also generate an extra parameter to hold the Constrained
-- attribute of the actual. No renaming is generated for this flag.
-- Calling Node_Posssible_Modifications in the expander is dubious,
-- because this generates a cross-reference entry, and should be
-- done during semantic processing so it is called in -gnatc mode???
if Ekind (Entity (N)) /= E_In_Parameter
and then In_Assignment_Context (N)
then
Note_Possible_Modification (N);
Note_Possible_Modification (N, Sure => True);
end if;
Rewrite (N, New_Occurrence_Of (Renamed_Object (Entity (N)), Loc));
......@@ -564,93 +560,54 @@ package body Exp_Ch2 is
end if;
end Expand_N_Real_Literal;
------------------------------
-- Expand_Protected_Private --
------------------------------
--------------------------------
-- Expand_Protected_Component --
--------------------------------
procedure Expand_Protected_Private (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
E : constant Entity_Id := Entity (N);
Op : constant Node_Id := Protected_Operation (E);
Scop : Entity_Id;
Lo : Node_Id;
Hi : Node_Id;
D_Range : Node_Id;
begin
if Nkind (Op) /= N_Subprogram_Body
or else Nkind (Specification (Op)) /= N_Function_Specification
then
Set_Ekind (Prival (E), E_Variable);
else
Set_Ekind (Prival (E), E_Constant);
end if;
procedure Expand_Protected_Component (N : Node_Id) is
-- If the private component appears in an assignment (either lhs or
-- rhs) and is a one-dimensional array constrained by a discriminant,
-- rewrite as P (Lo .. Hi) with an explicit range, so that discriminal
-- is directly visible. This solves delicate visibility problems.
function Inside_Eliminated_Body return Boolean;
-- Determine whether the current entity is inside a subprogram or an
-- entry which has been marked as eliminated.
if Comes_From_Source (N)
and then Is_Array_Type (Etype (E))
and then Number_Dimensions (Etype (E)) = 1
and then not Within_Init_Proc
then
Lo := Type_Low_Bound (Etype (First_Index (Etype (E))));
Hi := Type_High_Bound (Etype (First_Index (Etype (E))));
if Nkind (Parent (N)) = N_Assignment_Statement
and then ((Is_Entity_Name (Lo)
and then Ekind (Entity (Lo)) = E_In_Parameter)
or else (Is_Entity_Name (Hi)
and then
Ekind (Entity (Hi)) = E_In_Parameter))
then
D_Range := New_Node (N_Range, Loc);
----------------------------
-- Inside_Eliminated_Body --
----------------------------
if Is_Entity_Name (Lo)
and then Ekind (Entity (Lo)) = E_In_Parameter
then
Set_Low_Bound (D_Range,
Make_Identifier (Loc, Chars (Entity (Lo))));
else
Set_Low_Bound (D_Range, Duplicate_Subexpr (Lo));
end if;
function Inside_Eliminated_Body return Boolean is
S : Entity_Id := Current_Scope;
if Is_Entity_Name (Hi)
and then Ekind (Entity (Hi)) = E_In_Parameter
begin
while Present (S) loop
if (Ekind (S) = E_Entry
or else Ekind (S) = E_Entry_Family
or else Ekind (S) = E_Function
or else Ekind (S) = E_Procedure)
and then Is_Eliminated (S)
then
Set_High_Bound (D_Range,
Make_Identifier (Loc, Chars (Entity (Hi))));
else
Set_High_Bound (D_Range, Duplicate_Subexpr (Hi));
return True;
end if;
Rewrite (N,
Make_Slice (Loc,
Prefix => New_Occurrence_Of (E, Loc),
Discrete_Range => D_Range));
Analyze_And_Resolve (N, Etype (E));
return;
end if;
end if;
-- The type of the reference is the type of the prival, which may differ
-- from that of the original component if it is an itype.
Set_Entity (N, Prival (E));
Set_Etype (N, Etype (Prival (E)));
Scop := Current_Scope;
S := Scope (S);
end loop;
-- Find entity for protected operation, which must be on scope stack
return False;
end Inside_Eliminated_Body;
while not Is_Protected_Type (Scope (Scop)) loop
Scop := Scope (Scop);
end loop;
-- Start of processing for Expand_Protected_Component
Append_Elmt (N, Privals_Chain (Scop));
end Expand_Protected_Private;
begin
-- Eliminated bodies are not expanded and thus do not need privals
if not Inside_Eliminated_Body then
declare
Priv : constant Entity_Id := Prival (Entity (N));
begin
Set_Entity (N, Priv);
Set_Etype (N, Etype (Priv));
end;
end if;
end Expand_Protected_Component;
---------------------
-- Expand_Renaming --
......
gcc/ada/sem_ch12.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2008, 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- --
......@@ -100,9 +100,11 @@ package Sem_Ch12 is
-- between the current procedure and Load_Parent_Of_Generic.
procedure Instantiate_Subprogram_Body
(Body_Info : Pending_Body_Info);
(Body_Info : Pending_Body_Info;
Body_Optional : Boolean := False);
-- Called after semantic analysis, to complete the instantiation of
-- function and procedure instances.
-- function and procedure instances. The flag Body_Optional has the
-- same purpose as described for Instantiate_Package_Body.
procedure Save_Global_References (N : Node_Id);
-- Traverse the original generic unit, and capture all references to
......
gcc/ada/sem_ch13.adb
......@@ -29,7 +29,6 @@ with Einfo; use Einfo;
with Errout; use Errout;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Layout; use Layout;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
with Namet; use Namet;
......@@ -485,7 +484,11 @@ package body Sem_Ch13 is
-- definition clause that is the preferred approach in Ada 95.
procedure Analyze_At_Clause (N : Node_Id) is
CS : constant Boolean := Comes_From_Source (N);
begin
-- This is an obsolescent feature
Check_Restriction (No_Obsolescent_Features, N);
if Warn_On_Obsolescent_Feature then
......@@ -495,11 +498,21 @@ package body Sem_Ch13 is
("\use address attribute definition clause instead?", N);
end if;
-- Rewrite as address clause
Rewrite (N,
Make_Attribute_Definition_Clause (Sloc (N),
Name => Identifier (N),
Chars => Name_Address,
Expression => Expression (N)));
-- We preserve Comes_From_Source, since logically the clause still
-- comes from the source program even though it is changed in form.
Set_Comes_From_Source (N, CS);
-- Analyze rewritten clause
Analyze_Attribute_Definition_Clause (N);
end Analyze_At_Clause;
......@@ -529,6 +542,10 @@ package body Sem_Ch13 is
-- Common processing for 'Read, 'Write, 'Input and 'Output attribute
-- definition clauses.
-----------------------------------
-- Analyze_Stream_TSS_Definition --
-----------------------------------
procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type) is
Subp : Entity_Id := Empty;
I : Interp_Index;
......@@ -588,7 +605,6 @@ package body Sem_Ch13 is
return Base_Type (Typ) = Base_Type (Ent)
and then No (Next_Formal (F));
end Has_Good_Profile;
-- Start of processing for Analyze_Stream_TSS_Definition
......@@ -739,6 +755,22 @@ package body Sem_Ch13 is
-- Address attribute definition clause
when Attribute_Address => Address : begin
-- A little error check, catch for X'Address use X'Address;
if Nkind (Nam) = N_Identifier
and then Nkind (Expr) = N_Attribute_Reference
and then Attribute_Name (Expr) = Name_Address
and then Nkind (Prefix (Expr)) = N_Identifier
and then Chars (Nam) = Chars (Prefix (Expr))
then
Error_Msg_NE
("address for & is self-referencing", Prefix (Expr), Ent);
return;
end if;
-- Not that special case, carry on with analysis of expression
Analyze_And_Resolve (Expr, RTE (RE_Address));
if Present (Address_Clause (U_Ent)) then
......@@ -875,7 +907,7 @@ package body Sem_Ch13 is
-- We mark a possible modification of a variable with an
-- address clause, since it is likely aliasing is occurring.
Note_Possible_Modification (Nam);
Note_Possible_Modification (Nam, Sure => False);
-- Here we are checking for explicit overlap of one variable
-- by another, and if we find this then mark the overlapped
......@@ -920,22 +952,25 @@ package body Sem_Ch13 is
-- If the address clause is of the form:
-- for X'Address use Y'Address
-- for Y'Address use X'Address
-- or
-- Const : constant Address := Y'Address;
-- Const : constant Address := X'Address;
-- ...
-- for X'Address use Const;
-- for Y'Address use Const;
-- then we make an entry in the table for checking the size and
-- alignment of the overlaying variable. We defer this check
-- till after code generation to take full advantage of the
-- annotation done by the back end. This entry is only made if
-- we have not already posted a warning about size/alignment
-- (some warnings of this type are posted in Checks).
-- (some warnings of this type are posted in Checks), and if
-- the address clause comes from source.
if Address_Clause_Overlay_Warnings then
if Address_Clause_Overlay_Warnings
and then Comes_From_Source (N)
then
declare
Ent_X : Entity_Id := Empty;
Ent_Y : Entity_Id := Empty;
......@@ -945,7 +980,18 @@ package body Sem_Ch13 is
if Present (Ent_Y) and then Is_Entity_Name (Name (N)) then
Ent_X := Entity (Name (N));
Address_Clause_Checks.Append ((N, Ent_X, Ent_Y));
Address_Clause_Checks.Append ((N, Ent_X, Ent_Y));
-- If variable overlays a constant view, and we are
-- warning on overlays, then mark the variable as
-- overlaying a constant (we will give warnings later
-- if this variable is assigned).
if Is_Constant_Object (Ent_Y)
and then Ekind (Ent_X) = E_Variable
then
Set_Overlays_Constant (Ent_X);
end if;
end if;
end;
end if;
......@@ -1391,10 +1437,6 @@ package body Sem_Ch13 is
Set_Has_Small_Clause (U_Ent);
Set_Has_Small_Clause (Implicit_Base);
Set_Has_Non_Standard_Rep (Implicit_Base);
-- Recompute RM_Size, but shouldn't this be done in Freeze???
Set_Discrete_RM_Size (U_Ent);
end if;
end Small;
......@@ -1857,10 +1899,7 @@ package body Sem_Ch13 is
-- Don't allow rep clause for standard [wide_[wide_]]character
elsif Root_Type (Enumtype) = Standard_Character
or else Root_Type (Enumtype) = Standard_Wide_Character
or else Root_Type (Enumtype) = Standard_Wide_Wide_Character
then
elsif Is_Standard_Character_Type (Enumtype) then
Error_Msg_N ("enumeration rep clause not allowed for this type", N);
return;
......@@ -2310,6 +2349,14 @@ package body Sem_Ch13 is
Error_Msg_N
("first bit cannot be negative", First_Bit (CC));
-- The Last_Bit specified in a component clause must not be
-- less than the First_Bit minus one (RM-13.5.1(10)).
elsif Lbit < Fbit - 1 then
Error_Msg_N
("last bit cannot be less than first bit minus one",
Last_Bit (CC));
-- Values look OK, so find the corresponding record component
-- Even though the syntax allows an attribute reference for
-- implementation-defined components, GNAT does not allow the
......
gcc/ada/sem_ch5.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2008, 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- --
......@@ -118,31 +118,40 @@ package body Sem_Ch5 is
-- Some special bad cases of entity names
elsif Is_Entity_Name (N) then
if Ekind (Entity (N)) = E_In_Parameter then
Error_Msg_N
("assignment to IN mode parameter not allowed", N);
-- Private declarations in a protected object are turned into
-- constants when compiling a protected function.
declare
Ent : constant Entity_Id := Entity (N);
elsif Present (Scope (Entity (N)))
and then Is_Protected_Type (Scope (Entity (N)))
and then
(Ekind (Current_Scope) = E_Function
or else
Ekind (Enclosing_Dynamic_Scope (Current_Scope)) = E_Function)
then
Error_Msg_N
("protected function cannot modify protected object", N);
begin
if Ekind (Ent) = E_In_Parameter then
Error_Msg_N
("assignment to IN mode parameter not allowed", N);
-- Renamings of protected private components are turned into
-- constants when compiling a protected function. In the case
-- of single protected types, the private component appears
-- directly.
elsif (Is_Prival (Ent)
and then
(Ekind (Current_Scope) = E_Function
or else Ekind (Enclosing_Dynamic_Scope (
Current_Scope)) = E_Function))
or else
(Ekind (Ent) = E_Component
and then Is_Protected_Type (Scope (Ent)))
then
Error_Msg_N
("protected function cannot modify protected object", N);
elsif Ekind (Entity (N)) = E_Loop_Parameter then
Error_Msg_N
("assignment to loop parameter not allowed", N);
elsif Ekind (Ent) = E_Loop_Parameter then
Error_Msg_N
("assignment to loop parameter not allowed", N);
else
Error_Msg_N
("left hand side of assignment must be a variable", N);
end if;
else
Error_Msg_N
("left hand side of assignment must be a variable", N);
end if;
end;
-- For indexed components or selected components, test prefix
......@@ -430,6 +439,15 @@ package body Sem_Ch5 is
("left hand of assignment must not be limited type", Lhs);
Explain_Limited_Type (T1, Lhs);
return;
-- Enforce RM 3.9.3 (8): left-hand side cannot be abstract
elsif Is_Interface (T1)
and then not Is_Class_Wide_Type (T1)
then
Error_Msg_N
("target of assignment operation may not be abstract", Lhs);
return;
end if;
-- Resolution may have updated the subtype, in case the left-hand
......@@ -469,6 +487,7 @@ package body Sem_Ch5 is
-- This is the point at which we check for an unset reference
Check_Unset_Reference (Rhs);
Check_Unprotected_Access (Lhs, Rhs);
-- Remaining steps are skipped if Rhs was syntactically in error
......@@ -588,7 +607,7 @@ package body Sem_Ch5 is
-- We still mark this as a possible modification, that's necessary
-- to reset Is_True_Constant, and desirable for xref purposes.
Note_Possible_Modification (Lhs);
Note_Possible_Modification (Lhs, Sure => True);
return;
-- If we know the right hand side is non-null, then we convert to the
......@@ -635,7 +654,7 @@ package body Sem_Ch5 is
-- Note: modifications of the Lhs may only be recorded after
-- checks have been applied.
Note_Possible_Modification (Lhs);
Note_Possible_Modification (Lhs, Sure => True);
-- ??? a real accessibility check is needed when ???
......@@ -1901,20 +1920,36 @@ package body Sem_Ch5 is
Analyze (Id);
Ent := Entity (Id);
Generate_Reference (Ent, Loop_Statement, ' ');
Generate_Definition (Ent);
-- If we found a label, mark its type. If not, ignore it, since it
-- means we have a conflicting declaration, which would already have
-- been diagnosed at declaration time. Set Label_Construct of the
-- implicit label declaration, which is not created by the parser
-- for generic units.
-- Guard against serious error (typically, a scope mismatch when
-- semantic analysis is requested) by creating loop entity to
-- continue analysis.
if Ekind (Ent) = E_Label then
Set_Ekind (Ent, E_Loop);
if No (Ent) then
if Total_Errors_Detected /= 0 then
Ent :=
New_Internal_Entity
(E_Loop, Current_Scope, Sloc (Loop_Statement), 'L');
else
raise Program_Error;
end if;
else
Generate_Reference (Ent, Loop_Statement, ' ');
Generate_Definition (Ent);
if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then
Set_Label_Construct (Parent (Ent), Loop_Statement);
-- If we found a label, mark its type. If not, ignore it, since it
-- means we have a conflicting declaration, which would already
-- have been diagnosed at declaration time. Set Label_Construct
-- of the implicit label declaration, which is not created by the
-- parser for generic units.
if Ekind (Ent) = E_Label then
Set_Ekind (Ent, E_Loop);
if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then
Set_Label_Construct (Parent (Ent), Loop_Statement);
end if;
end if;
end if;
......@@ -1928,10 +1963,10 @@ package body Sem_Ch5 is
Set_Parent (Ent, Loop_Statement);
end if;
-- Kill current values on entry to loop, since statements in body
-- of loop may have been executed before the loop is entered.
-- Similarly we kill values after the loop, since we do not know
-- that the body of the loop was executed.
-- Kill current values on entry to loop, since statements in body of
-- loop may have been executed before the loop is entered. Similarly we
-- kill values after the loop, since we do not know that the body of the
-- loop was executed.
Kill_Current_Values;
Push_Scope (Ent);
......@@ -1941,6 +1976,13 @@ package body Sem_Ch5 is
End_Scope;
Kill_Current_Values;
Check_Infinite_Loop_Warning (N);
-- Code after loop is unreachable if the loop has no WHILE or FOR
-- and contains no EXIT statements within the body of the loop.
if No (Iter) and then not Has_Exit (Ent) then
Check_Unreachable_Code (N);
end if;
end Analyze_Loop_Statement;
----------------------------
......
gcc/ada/sem_ch5.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2008, 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- --
......@@ -47,9 +47,9 @@ package Sem_Ch5 is
-- be assumed to be reachable.
procedure Check_Unreachable_Code (N : Node_Id);
-- This procedure is called with N being the node for a statement that
-- is an unconditional transfer of control. It checks to see if the
-- statement is followed by some other statement, and if so generates
-- an appropriate warning for unreachable code.
-- This procedure is called with N being the node for a statement that is
-- an unconditional transfer of control or an apparent infinite loop. It
-- checks to see if the statement is followed by some other statement, and
-- if so generates an appropriate warning for unreachable code.
end Sem_Ch5;
gcc/ada/sem_eval.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2008, 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- --
......@@ -578,9 +578,7 @@ package body Sem_Eval is
if Nkind (Lf) = N_Identifier and then Nkind (Rf) = N_Identifier
and then Entity (Lf) = Entity (Rf)
and then not Is_Floating_Point_Type (Etype (L))
and then (Ekind (Entity (Lf)) = E_Constant or else
Ekind (Entity (Lf)) = E_In_Parameter or else
Ekind (Entity (Lf)) = E_Loop_Parameter)
and then Is_Constant_Object (Entity (Lf))
then
return True;
......@@ -1432,9 +1430,7 @@ package body Sem_Eval is
Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
if (C_Typ = Standard_Character
or else C_Typ = Standard_Wide_Character
or else C_Typ = Standard_Wide_Wide_Character)
if Is_Standard_Character_Type (C_Typ)
and then Fold
then
null;
......@@ -2269,14 +2265,13 @@ package body Sem_Eval is
Fold : Boolean;
begin
-- One special case to deal with first. If we can tell that
-- the result will be false because the lengths of one or
-- more index subtypes are compile time known and different,
-- then we can replace the entire result by False. We only
-- do this for one dimensional arrays, because the case of
-- multi-dimensional arrays is rare and too much trouble!
-- If one of the operands is an illegal aggregate, its type
-- might still be an arbitrary composite type, so nothing to do.
-- One special case to deal with first. If we can tell that the result
-- will be false because the lengths of one or more index subtypes are
-- compile time known and different, then we can replace the entire
-- result by False. We only do this for one dimensional arrays, because
-- the case of multi-dimensional arrays is rare and too much trouble! If
-- one of the operands is an illegal aggregate, its type might still be
-- an arbitrary composite type, so nothing to do.
if Is_Array_Type (Typ)
and then Typ /= Any_Composite
......@@ -2289,7 +2284,9 @@ package body Sem_Eval is
return;
end if;
declare
-- OK, we have the case where we may be able to do this fold
Length_Mismatch : declare
procedure Get_Static_Length (Op : Node_Id; Len : out Uint);
-- If Op is an expression for a constrained array with a known
-- at compile time length, then Len is set to this (non-negative
......@@ -2303,33 +2300,145 @@ package body Sem_Eval is
T : Entity_Id;
begin
-- First easy case string literal
if Nkind (Op) = N_String_Literal then
Len := UI_From_Int (String_Length (Strval (Op)));
return;
end if;
-- Second easy case, not constrained subtype, so no length
elsif not Is_Constrained (Etype (Op)) then
if not Is_Constrained (Etype (Op)) then
Len := Uint_Minus_1;
return;
end if;
else
T := Etype (First_Index (Etype (Op)));
-- General case
if Is_Discrete_Type (T)
and then
Compile_Time_Known_Value (Type_Low_Bound (T))
and then
Compile_Time_Known_Value (Type_High_Bound (T))
T := Etype (First_Index (Etype (Op)));
-- The simple case, both bounds are known at compile time
if Is_Discrete_Type (T)
and then
Compile_Time_Known_Value (Type_Low_Bound (T))
and then
Compile_Time_Known_Value (Type_High_Bound (T))
then
Len := UI_Max (Uint_0,
Expr_Value (Type_High_Bound (T)) -
Expr_Value (Type_Low_Bound (T)) + 1);
return;
end if;
-- A more complex case, where the bounds are of the form
-- X [+/- K1] .. X [+/- K2]), where X is an expression that is
-- either A'First or A'Last (with A an entity name), or X is an
-- entity name, and the two X's are the same and K1 and K2 are
-- known at compile time, in this case, the length can also be
-- computed at compile time, even though the bounds are not
-- known. A common case of this is e.g. (X'First..X'First+5).
Extract_Length : declare
procedure Decompose_Expr
(Expr : Node_Id;
Ent : out Entity_Id;
Kind : out Character;
Cons : out Uint);
-- Given an expression, see if is of the form above,
-- X [+/- K]. If so Ent is set to the entity in X,
-- Kind is 'F','L','E' for 'First/'Last/simple entity,
-- and Cons is the value of K. If the expression is
-- not of the required form, Ent is set to Empty.
--------------------
-- Decompose_Expr --
--------------------
procedure Decompose_Expr
(Expr : Node_Id;
Ent : out Entity_Id;
Kind : out Character;
Cons : out Uint)
is
Exp : Node_Id;
begin
if Nkind (Expr) = N_Op_Add
and then Compile_Time_Known_Value (Right_Opnd (Expr))
then
Exp := Left_Opnd (Expr);
Cons := Expr_Value (Right_Opnd (Expr));
elsif Nkind (Expr) = N_Op_Subtract
and then Compile_Time_Known_Value (Right_Opnd (Expr))
then
Exp := Left_Opnd (Expr);
Cons := -Expr_Value (Right_Opnd (Expr));
else
Exp := Expr;
Cons := Uint_0;
end if;
-- At this stage Exp is set to the potential X
if Nkind (Exp) = N_Attribute_Reference then
if Attribute_Name (Exp) = Name_First then
Kind := 'F';
elsif Attribute_Name (Exp) = Name_Last then
Kind := 'L';
else
Ent := Empty;
return;
end if;
Exp := Prefix (Exp);
else
Kind := 'E';
end if;
if Is_Entity_Name (Exp)
and then Present (Entity (Exp))
then
Ent := Entity (Exp);
else
Ent := Empty;
end if;
end Decompose_Expr;
-- Local Variables
Ent1, Ent2 : Entity_Id;
Kind1, Kind2 : Character;
Cons1, Cons2 : Uint;
-- Start of processing for Extract_Length
begin
Decompose_Expr (Type_Low_Bound (T), Ent1, Kind1, Cons1);
Decompose_Expr (Type_High_Bound (T), Ent2, Kind2, Cons2);
if Present (Ent1)
and then Kind1 = Kind2
and then Ent1 = Ent2
then
Len := UI_Max (Uint_0,
Expr_Value (Type_High_Bound (T)) -
Expr_Value (Type_Low_Bound (T)) + 1);
Len := Cons2 - Cons1 + 1;
else
Len := Uint_Minus_1;
end if;
end if;
end Extract_Length;
end Get_Static_Length;
-- Local Variables
Len_L : Uint;
Len_R : Uint;
-- Start of processing for Length_Mismatch
begin
Get_Static_Length (Left, Len_L);
Get_Static_Length (Right, Len_R);
......@@ -2342,12 +2451,13 @@ package body Sem_Eval is
Warn_On_Known_Condition (N);
return;
end if;
end;
end Length_Mismatch;
end if;
-- Another special case: comparisons of access types, where one or both
-- operands are known to be null, so the result can be determined.
elsif Is_Access_Type (Typ) then
if Is_Access_Type (Typ) then
if Known_Null (Left) then
if Known_Null (Right) then
Fold_Uint (N, Test (Nkind (N) = N_Op_Eq), False);
......
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