OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2014-02-19  Robert Dewar  <dewar@adacore.com>

	* exp_attr.adb (Expand_Min_Max_Attribute): Use Insert_Declaration
	(Expand_Min_Max_Attribute): Use Matching_Standard_Type.
	* exp_ch4.adb (Expand_N_Expression_With_Actions): Remove special
	handling for the case of Modify_Tree_For_C, this approach did
	not work.
	* exp_util.adb (Matching_Standard_Type): New function
	(Side_Effect_Free): New top level functions (from
	Remove_Side_Effects).
	* exp_util.ads (Side_Effect_Free): New top level functions
	(moved from body).
	* sinfo.ads: Minor comment updates.

2014-02-19  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch6.adb (Expand_Simple_Function_Return): If return
	type is unconstrained and uses the secondary stack, mark the
	enclosing function accordingly, to ensure that the value is not
	prematurely removed.

2014-02-19  Hristian Kirtchev  <kirtchev@adacore.com>

	* par.adb Alphabetize the routines in Par.Sync.
	(Resync_Past_Malformed_Aspect): New routine.
	* par-ch13.adb (Get_Aspect_Specifications): Alphabetize local
	variables. Code and comment reformatting. Detect missing
	parentheses on aspects [Refined_]Global and [Refined_]Depends
	with a non-null definition.
	* par-sync.adb: Alphabetize all routines in this separate unit.
	(Resync_Past_Malformed_Aspect): New routine.

From-SVN: r207890
This commit is contained in:
Arnaud Charlet 2014-02-19 12:02:48 +01:00
parent a03670050f
commit adb252d824
10 changed files with 875 additions and 681 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
gcc/ada/ChangeLog
View File

@ -1,3 +1,35 @@
2014-02-19 Robert Dewar <dewar@adacore.com>
* exp_attr.adb (Expand_Min_Max_Attribute): Use Insert_Declaration
(Expand_Min_Max_Attribute): Use Matching_Standard_Type.
* exp_ch4.adb (Expand_N_Expression_With_Actions): Remove special
handling for the case of Modify_Tree_For_C, this approach did
not work.
* exp_util.adb (Matching_Standard_Type): New function
(Side_Effect_Free): New top level functions (from
Remove_Side_Effects).
* exp_util.ads (Side_Effect_Free): New top level functions
(moved from body).
* sinfo.ads: Minor comment updates.
2014-02-19 Ed Schonberg <schonberg@adacore.com>
* exp_ch6.adb (Expand_Simple_Function_Return): If return
type is unconstrained and uses the secondary stack, mark the
enclosing function accordingly, to ensure that the value is not
prematurely removed.
2014-02-19 Hristian Kirtchev <kirtchev@adacore.com>
* par.adb Alphabetize the routines in Par.Sync.
(Resync_Past_Malformed_Aspect): New routine.
* par-ch13.adb (Get_Aspect_Specifications): Alphabetize local
variables. Code and comment reformatting. Detect missing
parentheses on aspects [Refined_]Global and [Refined_]Depends
with a non-null definition.
* par-sync.adb: Alphabetize all routines in this separate unit.
(Resync_Past_Malformed_Aspect): New routine.
2014-02-19 Robert Dewar <dewar@adacore.com>
* sem_eval.ads, sem_eval.adb (Subtypes_Statically_Match): Return False

70
gcc/ada/exp_attr.adb
View File

@ -1062,8 +1062,6 @@ package body Exp_Attr is
Expr : constant Node_Id := First (Expressions (N));
Left : constant Node_Id := Relocate_Node (Expr);
Right : constant Node_Id := Relocate_Node (Next (Expr));
Ltyp : constant Entity_Id := Etype (Left);
Rtyp : constant Entity_Id := Etype (Right);
function Make_Compare (Left, Right : Node_Id) return Node_Id;
-- Returns Left >= Right for Max, Left <= Right for Min
@ -1090,12 +1088,12 @@ package body Exp_Attr is
-- Start of processing for Min_Max
begin
-- If both Left and Right are simple entity names, then we can
-- just use Duplicate_Expr to duplicate the references and return
-- If both Left and Right are side effect free, then we can just
-- use Duplicate_Expr to duplicate the references and return
-- (if Left >=|<= Right then Left else Right)
if Is_Entity_Name (Left) and then Is_Entity_Name (Right) then
if Side_Effect_Free (Left) and then Side_Effect_Free (Right) then
Rewrite (N,
Make_If_Expression (Loc,
Expressions => New_List (
@ -1103,35 +1101,57 @@ package body Exp_Attr is
Duplicate_Subexpr_No_Checks (Left),
Duplicate_Subexpr_No_Checks (Right))));
-- Otherwise we wrap things in an expression with actions. You
-- might think we could just use the approach above, but there
-- are problems, in particular with escaped discriminants. In
-- this case we generate:
-- Otherwise we generate declarations to capture the values. We
-- can't put these declarations inside the if expression, since
-- we could end up with an N_Expression_With_Actions which has
-- declarations in the actions, forbidden for Modify_Tree_For_C.
-- The translation is
-- T1 : styp; -- inserted high up in tree
-- T2 : styp; -- inserted high up in tree
-- do
-- T1 : constant typ := Left;
-- T2 : constant typ := Right;
-- T1 := styp!(Left);
-- T2 := styp!(Right);
-- in
-- (if T1 >=|<= T2 then T1 else T2)
-- (if T1 >=|<= T2 then typ!(T1) else typ!(T2))
-- end;
-- We insert the T1,T2 declarations with Insert_Declaration which
-- inserts these declarations high up in the tree unconditionally.
-- This is safe since no code is associated with the declarations.
-- Here styp is a standard type whose Esize matches the size of
-- our type. We do this because the actual type may be a result of
-- some local declaration which would not be visible at the point
-- where we insert the declarations of T1 and T2.
else
declare
T1 : constant Entity_Id := Make_Temporary (Loc, 'T', Left);
T2 : constant Entity_Id := Make_Temporary (Loc, 'T', Left);
T1 : constant Entity_Id := Make_Temporary (Loc, 'T', Left);
T2 : constant Entity_Id := Make_Temporary (Loc, 'T', Left);
Styp : constant Entity_Id := Matching_Standard_Type (Typ);
begin
Insert_Declaration (N,
Make_Object_Declaration (Loc,
Defining_Identifier => T1,
Object_Definition => New_Occurrence_Of (Styp, Loc)));
Insert_Declaration (N,
Make_Object_Declaration (Loc,
Defining_Identifier => T2,
Object_Definition => New_Occurrence_Of (Styp, Loc)));
Rewrite (N,
Make_Expression_With_Actions (Loc,
Actions => New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => T1,
Object_Definition => New_Occurrence_Of (Ltyp, Loc),
Expression => Left),
Make_Object_Declaration (Loc,
Defining_Identifier => T2,
Object_Definition => New_Occurrence_Of (Rtyp, Loc),
Expression => Right)),
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (T1, Loc),
Expression => Unchecked_Convert_To (Styp, Left)),
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (T2, Loc),
Expression => Unchecked_Convert_To (Styp, Right))),
Expression =>
Make_If_Expression (Loc,
@ -1139,8 +1159,10 @@ package body Exp_Attr is
Make_Compare
(New_Occurrence_Of (T1, Loc),
New_Occurrence_Of (T2, Loc)),
New_Occurrence_Of (T1, Loc),
New_Occurrence_Of (T2, Loc)))));
Unchecked_Convert_To (Typ,
New_Occurrence_Of (T1, Loc)),
Unchecked_Convert_To (Typ,
New_Occurrence_Of (T2, Loc))))));
end;
end if;

75
gcc/ada/exp_ch4.adb
View File

@ -5067,14 +5067,6 @@ package body Exp_Ch4 is
--------------------------------------
procedure Expand_N_Expression_With_Actions (N : Node_Id) is
procedure Insert_Declaration (Decl : Node_Id);
-- This is like Insert_Action, but inserts outside the expression in
-- which N appears. This is needed, because otherwise we can end up
-- inserting a declaration in the actions of a short circuit, and that
-- will not do, because that's likely where we (the expression with
-- actions) node came from the first place. We are only inserting a
-- declaration with no side effects, so it is harmless (and needed)
-- to insert at a higher point in the tree.
function Process_Action (Act : Node_Id) return Traverse_Result;
-- Inspect and process a single action of an expression_with_actions for
@ -5082,27 +5074,6 @@ package body Exp_Ch4 is
-- generates code to clean them up when the context of the expression is
-- evaluated or elaborated.
------------------------
-- Insert_Declaration --
------------------------
procedure Insert_Declaration (Decl : Node_Id) is
P : Node_Id;
begin
-- Climb out of the current expression
P := Decl;
loop
exit when Nkind (Parent (P)) not in N_Subexpr;
P := Parent (P);
end loop;
-- Now do the insertion
Insert_Action (P, Decl);
end Insert_Declaration;
--------------------
-- Process_Action --
--------------------
@ -5135,11 +5106,7 @@ package body Exp_Ch4 is
-- Local variables
Loc : Source_Ptr;
Act : Node_Id;
Def : Entity_Id;
Exp : Node_Id;
Nxt : Node_Id;
-- Start of processing for Expand_N_Expression_With_Actions
@ -5152,48 +5119,6 @@ package body Exp_Ch4 is
Next (Act);
end loop;
-- In Modify_Tree_For_C, we have trouble in C with object declarations
-- in the actions list (expressions are fine). So if we have an object
-- declaration, insert it higher in the tree, if necessary replacing it
-- with an assignment to capture initialization.
if Modify_Tree_For_C then
Act := First (Actions (N));
while Present (Act) loop
if Nkind (Act) = N_Object_Declaration then
Def := Defining_Identifier (Act);
Exp := Expression (Act);
Set_Constant_Present (Act, False);
Set_Expression (Act, Empty);
Insert_Declaration (Relocate_Node (Act));
Loc := Sloc (Act);
-- Expression present, rewrite as assignment, get next action
if Present (Exp) then
Rewrite (Act,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Def, Loc),
Expression => Exp));
Next (Act);
-- No expression, remove action and move to next
else
Nxt := Next (Act);
Remove (Act);
Act := Nxt;
end if;
-- Not an object declaration, move to next action
else
Next (Act);
end if;
end loop;
end if;
-- Deal with case where there are no actions. In this case we simply
-- rewrite the node with its expression since we don't need the actions
-- and the specification of this node does not allow a null action list.

7
gcc/ada/exp_ch6.adb
View File

@ -7834,6 +7834,13 @@ package body Exp_Ch6 is
Set_Sec_Stack_Needed_For_Return (S, True);
S := Enclosing_Dynamic_Scope (S);
end loop;
-- The enclosing function itself must be marked as well, to
-- prevent premature secondary stack cleanup.
if Ekind (S) = E_Function then
Set_Sec_Stack_Needed_For_Return (Scope_Id);
end if;
end;
-- Optimize the case where the result is a function call. In this

884
gcc/ada/exp_util.adb
View File

@ -3962,11 +3962,13 @@ package body Exp_Util is
-- Climb until we find a procedure or a package
P := Parent (N);
P := N;
loop
pragma Assert (Present (Parent (P)));
P := Parent (P);
if Is_List_Member (P) then
exit when Nkind_In (Parent (P), N_Package_Specification,
N_Package_Body,
N_Subprogram_Body);
-- Special handling for handled sequence of statements, we must
@ -3977,8 +3979,6 @@ package body Exp_Util is
exit;
end if;
end if;
P := Parent (P);
end loop;
-- Now do the insertion
@ -5970,7 +5970,7 @@ package body Exp_Util is
Siz : constant Uint := Esize (Typ);
begin
-- Float-point cases
-- Floating-point cases
if Is_Floating_Point_Type (Typ) then
if Siz <= Esize (Standard_Short_Float) then
@ -5987,7 +5987,7 @@ package body Exp_Util is
-- Integer cases (includes fixed-point types)
-- Unsigned cases (includes normal enumeration types)
-- Unsigned integer cases (includes normal enumeration types)
elsif Is_Unsigned_Type (Typ) then
if Siz <= Esize (Standard_Short_Short_Unsigned) then
@ -6004,7 +6004,7 @@ package body Exp_Util is
raise Program_Error;
end if;
-- Signed cases
-- Signed integer cases
else
if Siz <= Esize (Standard_Short_Short_Integer) then
@ -6635,435 +6635,6 @@ package body Exp_Util is
Ref_Type : Entity_Id;
Res : Node_Id;
function Side_Effect_Free (N : Node_Id) return Boolean;
-- Determines if the tree N represents an expression that is known not
-- to have side effects, and for which no processing is required.
function Side_Effect_Free (L : List_Id) return Boolean;
-- Determines if all elements of the list L are side effect free
function Safe_Prefixed_Reference (N : Node_Id) return Boolean;
-- The argument N is a construct where the Prefix is dereferenced if it
-- is an access type and the result is a variable. The call returns True
-- if the construct is side effect free (not considering side effects in
-- other than the prefix which are to be tested by the caller).
function Within_In_Parameter (N : Node_Id) return Boolean;
-- Determines if N is a subcomponent of a composite in-parameter. If so,
-- N is not side-effect free when the actual is global and modifiable
-- indirectly from within a subprogram, because it may be passed by
-- reference. The front-end must be conservative here and assume that
-- this may happen with any array or record type. On the other hand, we
-- cannot create temporaries for all expressions for which this
-- condition is true, for various reasons that might require clearing up
-- ??? For example, discriminant references that appear out of place, or
-- spurious type errors with class-wide expressions. As a result, we
-- limit the transformation to loop bounds, which is so far the only
-- case that requires it.
-----------------------------
-- Safe_Prefixed_Reference --
-----------------------------
function Safe_Prefixed_Reference (N : Node_Id) return Boolean is
begin
-- If prefix is not side effect free, definitely not safe
if not Side_Effect_Free (Prefix (N)) then
return False;
-- If the prefix is of an access type that is not access-to-constant,
-- then this construct is a variable reference, which means it is to
-- be considered to have side effects if Variable_Ref is set True.
elsif Is_Access_Type (Etype (Prefix (N)))
and then not Is_Access_Constant (Etype (Prefix (N)))
and then Variable_Ref
then
-- Exception is a prefix that is the result of a previous removal
-- of side-effects.
return Is_Entity_Name (Prefix (N))
and then not Comes_From_Source (Prefix (N))
and then Ekind (Entity (Prefix (N))) = E_Constant
and then Is_Internal_Name (Chars (Entity (Prefix (N))));
-- If the prefix is an explicit dereference then this construct is a
-- variable reference, which means it is to be considered to have
-- side effects if Variable_Ref is True.
-- We do NOT exclude dereferences of access-to-constant types because
-- we handle them as constant view of variables.
elsif Nkind (Prefix (N)) = N_Explicit_Dereference
and then Variable_Ref
then
return False;
-- Note: The following test is the simplest way of solving a complex
-- problem uncovered by the following test (Side effect on loop bound
-- that is a subcomponent of a global variable:
-- with Text_Io; use Text_Io;
-- procedure Tloop is
-- type X is
-- record
-- V : Natural := 4;
-- S : String (1..5) := (others => 'a');
-- end record;
-- X1 : X;
-- procedure Modi;
-- generic
-- with procedure Action;
-- procedure Loop_G (Arg : X; Msg : String)
-- procedure Loop_G (Arg : X; Msg : String) is
-- begin
-- Put_Line ("begin loop_g " & Msg & " will loop till: "
-- & Natural'Image (Arg.V));
-- for Index in 1 .. Arg.V loop
-- Text_Io.Put_Line
-- (Natural'Image (Index) & " " & Arg.S (Index));
-- if Index > 2 then
-- Modi;
-- end if;
-- end loop;
-- Put_Line ("end loop_g " & Msg);
-- end;
-- procedure Loop1 is new Loop_G (Modi);
-- procedure Modi is
-- begin
-- X1.V := 1;
-- Loop1 (X1, "from modi");
-- end;
--
-- begin
-- Loop1 (X1, "initial");
-- end;
-- The output of the above program should be:
-- begin loop_g initial will loop till: 4
-- 1 a
-- 2 a
-- 3 a
-- begin loop_g from modi will loop till: 1
-- 1 a
-- end loop_g from modi
-- 4 a
-- begin loop_g from modi will loop till: 1
-- 1 a
-- end loop_g from modi
-- end loop_g initial
-- If a loop bound is a subcomponent of a global variable, a
-- modification of that variable within the loop may incorrectly
-- affect the execution of the loop.
elsif Nkind (Parent (Parent (N))) = N_Loop_Parameter_Specification
and then Within_In_Parameter (Prefix (N))
and then Variable_Ref
then
return False;
-- All other cases are side effect free
else
return True;
end if;
end Safe_Prefixed_Reference;
----------------------
-- Side_Effect_Free --
----------------------
function Side_Effect_Free (N : Node_Id) return Boolean is
begin
-- Note on checks that could raise Constraint_Error. Strictly, if we
-- take advantage of 11.6, these checks do not count as side effects.
-- However, we would prefer to consider that they are side effects,
-- since the backend CSE does not work very well on expressions which
-- can raise Constraint_Error. On the other hand if we don't consider
-- them to be side effect free, then we get some awkward expansions
-- in -gnato mode, resulting in code insertions at a point where we
-- do not have a clear model for performing the insertions.
-- Special handling for entity names
if Is_Entity_Name (N) then
-- Variables are considered to be a side effect if Variable_Ref
-- is set or if we have a volatile reference and Name_Req is off.
-- If Name_Req is True then we can't help returning a name which
-- effectively allows multiple references in any case.
if Is_Variable (N, Use_Original_Node => False) then
return not Variable_Ref
and then (not Is_Volatile_Reference (N) or else Name_Req);
-- Any other entity (e.g. a subtype name) is definitely side
-- effect free.
else
return True;
end if;
-- A value known at compile time is always side effect free
elsif Compile_Time_Known_Value (N) then
return True;
-- A variable renaming is not side-effect free, because the renaming
-- will function like a macro in the front-end in some cases, and an
-- assignment can modify the component designated by N, so we need to
-- create a temporary for it.
-- The guard testing for Entity being present is needed at least in
-- the case of rewritten predicate expressions, and may well also be
-- appropriate elsewhere. Obviously we can't go testing the entity
-- field if it does not exist, so it's reasonable to say that this is
-- not the renaming case if it does not exist.
elsif Is_Entity_Name (Original_Node (N))
and then Present (Entity (Original_Node (N)))
and then Is_Renaming_Of_Object (Entity (Original_Node (N)))
and then Ekind (Entity (Original_Node (N))) /= E_Constant
then
declare
RO : constant Node_Id :=
Renamed_Object (Entity (Original_Node (N)));
begin
-- If the renamed object is an indexed component, or an
-- explicit dereference, then the designated object could
-- be modified by an assignment.
if Nkind_In (RO, N_Indexed_Component,
N_Explicit_Dereference)
then
return False;
-- A selected component must have a safe prefix
elsif Nkind (RO) = N_Selected_Component then
return Safe_Prefixed_Reference (RO);
-- In all other cases, designated object cannot be changed so
-- we are side effect free.
else
return True;
end if;
end;
-- Remove_Side_Effects generates an object renaming declaration to
-- capture the expression of a class-wide expression. In VM targets
-- the frontend performs no expansion for dispatching calls to
-- class- wide types since they are handled by the VM. Hence, we must
-- locate here if this node corresponds to a previous invocation of
-- Remove_Side_Effects to avoid a never ending loop in the frontend.
elsif VM_Target /= No_VM
and then not Comes_From_Source (N)
and then Nkind (Parent (N)) = N_Object_Renaming_Declaration
and then Is_Class_Wide_Type (Etype (N))
then
return True;
end if;
-- For other than entity names and compile time known values,
-- check the node kind for special processing.
case Nkind (N) is
-- An attribute reference is side effect free if its expressions
-- are side effect free and its prefix is side effect free or
-- is an entity reference.
-- Is this right? what about x'first where x is a variable???
when N_Attribute_Reference =>
return Side_Effect_Free (Expressions (N))
and then Attribute_Name (N) /= Name_Input
and then (Is_Entity_Name (Prefix (N))
or else Side_Effect_Free (Prefix (N)));
-- A binary operator is side effect free if and both operands are
-- side effect free. For this purpose binary operators include
-- membership tests and short circuit forms.
when N_Binary_Op | N_Membership_Test | N_Short_Circuit =>
return Side_Effect_Free (Left_Opnd (N))
and then
Side_Effect_Free (Right_Opnd (N));
-- An explicit dereference is side effect free only if it is
-- a side effect free prefixed reference.
when N_Explicit_Dereference =>
return Safe_Prefixed_Reference (N);
-- An expression with action is side effect free if its expression
-- is side effect free and it has no actions.
when N_Expression_With_Actions =>
return Is_Empty_List (Actions (N))
and then
Side_Effect_Free (Expression (N));
-- A call to _rep_to_pos is side effect free, since we generate
-- this pure function call ourselves. Moreover it is critically
-- important to make this exception, since otherwise we can have
-- discriminants in array components which don't look side effect
-- free in the case of an array whose index type is an enumeration
-- type with an enumeration rep clause.
-- All other function calls are not side effect free
when N_Function_Call =>
return Nkind (Name (N)) = N_Identifier
and then Is_TSS (Name (N), TSS_Rep_To_Pos)
and then
Side_Effect_Free (First (Parameter_Associations (N)));
-- An indexed component is side effect free if it is a side
-- effect free prefixed reference and all the indexing
-- expressions are side effect free.
when N_Indexed_Component =>
return Side_Effect_Free (Expressions (N))
and then Safe_Prefixed_Reference (N);
-- A type qualification is side effect free if the expression
-- is side effect free.
when N_Qualified_Expression =>
return Side_Effect_Free (Expression (N));
-- A selected component is side effect free only if it is a side
-- effect free prefixed reference. If it designates a component
-- with a rep. clause it must be treated has having a potential
-- side effect, because it may be modified through a renaming, and
-- a subsequent use of the renaming as a macro will yield the
-- wrong value. This complex interaction between renaming and
-- removing side effects is a reminder that the latter has become
-- a headache to maintain, and that it should be removed in favor
-- of the gcc mechanism to capture values ???
when N_Selected_Component =>
if Nkind (Parent (N)) = N_Explicit_Dereference
and then Has_Non_Standard_Rep (Designated_Type (Etype (N)))
then
return False;
else
return Safe_Prefixed_Reference (N);
end if;
-- A range is side effect free if the bounds are side effect free
when N_Range =>
return Side_Effect_Free (Low_Bound (N))
and then Side_Effect_Free (High_Bound (N));
-- A slice is side effect free if it is a side effect free
-- prefixed reference and the bounds are side effect free.
when N_Slice =>
return Side_Effect_Free (Discrete_Range (N))
and then Safe_Prefixed_Reference (N);
-- A type conversion is side effect free if the expression to be
-- converted is side effect free.
when N_Type_Conversion =>
return Side_Effect_Free (Expression (N));
-- A unary operator is side effect free if the operand
-- is side effect free.
when N_Unary_Op =>
return Side_Effect_Free (Right_Opnd (N));
-- An unchecked type conversion is side effect free only if it
-- is safe and its argument is side effect free.
when N_Unchecked_Type_Conversion =>
return Safe_Unchecked_Type_Conversion (N)
and then Side_Effect_Free (Expression (N));
-- An unchecked expression is side effect free if its expression
-- is side effect free.
when N_Unchecked_Expression =>
return Side_Effect_Free (Expression (N));
-- A literal is side effect free
when N_Character_Literal |
N_Integer_Literal |
N_Real_Literal |
N_String_Literal =>
return True;
-- We consider that anything else has side effects. This is a bit
-- crude, but we are pretty close for most common cases, and we
-- are certainly correct (i.e. we never return True when the
-- answer should be False).
when others =>
return False;
end case;
end Side_Effect_Free;
-- A list is side effect free if all elements of the list are side
-- effect free.
function Side_Effect_Free (L : List_Id) return Boolean is
N : Node_Id;
begin
if L = No_List or else L = Error_List then
return True;
else
N := First (L);
while Present (N) loop
if not Side_Effect_Free (N) then
return False;
else
Next (N);
end if;
end loop;
return True;
end if;
end Side_Effect_Free;
-------------------------
-- Within_In_Parameter --
-------------------------
function Within_In_Parameter (N : Node_Id) return Boolean is
begin
if not Comes_From_Source (N) then
return False;
elsif Is_Entity_Name (N) then
return Ekind (Entity (N)) = E_In_Parameter;
elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
return Within_In_Parameter (Prefix (N));
else
return False;
end if;
end Within_In_Parameter;
-- Start of processing for Remove_Side_Effects
begin
-- Handle cases in which there is nothing to do. In GNATprove mode,
-- removal of side effects is useful for the light expansion of
@ -7085,7 +6656,7 @@ package body Exp_Util is
-- No action needed for side-effect free expressions
elsif Side_Effect_Free (Exp) then
elsif Side_Effect_Free (Exp, Name_Req, Variable_Ref) then
return;
end if;
@ -7099,7 +6670,7 @@ package body Exp_Util is
-- If it is a scalar type and we need to capture the value, just make
-- a copy. Likewise for a function call, an attribute reference, a
-- conditional expression, an allocator, or an operator. And if we have
-- a volatile reference and Name_Req is not set (see comments above for
-- a volatile reference and Name_Req is not set (see comments for
-- Side_Effect_Free).
if Is_Elementary_Type (Exp_Type)
@ -7223,7 +6794,7 @@ package body Exp_Util is
-- approach would generate an illegal access value (an access value
-- cannot designate such an object - see Analyze_Reference). We skip
-- using this scheme if we have an object of a volatile type and we do
-- not have Name_Req set true (see comments above for Side_Effect_Free).
-- not have Name_Req set true (see comments for Side_Effect_Free).
-- In Ada 2012 a qualified expression is an object, but for purposes of
-- removing side effects it still need to be transformed into a separate
@ -8095,6 +7666,441 @@ package body Exp_Util is
end if;
end Set_Renamed_Subprogram;
----------------------
-- Side_Effect_Free --
----------------------
function Side_Effect_Free
(N : Node_Id;
Name_Req : Boolean := False;
Variable_Ref : Boolean := False) return Boolean
is
function Safe_Prefixed_Reference (N : Node_Id) return Boolean;
-- The argument N is a construct where the Prefix is dereferenced if it
-- is an access type and the result is a variable. The call returns True
-- if the construct is side effect free (not considering side effects in
-- other than the prefix which are to be tested by the caller).
function Within_In_Parameter (N : Node_Id) return Boolean;
-- Determines if N is a subcomponent of a composite in-parameter. If so,
-- N is not side-effect free when the actual is global and modifiable
-- indirectly from within a subprogram, because it may be passed by
-- reference. The front-end must be conservative here and assume that
-- this may happen with any array or record type. On the other hand, we
-- cannot create temporaries for all expressions for which this
-- condition is true, for various reasons that might require clearing up
-- ??? For example, discriminant references that appear out of place, or
-- spurious type errors with class-wide expressions. As a result, we
-- limit the transformation to loop bounds, which is so far the only
-- case that requires it.
-----------------------------
-- Safe_Prefixed_Reference --
-----------------------------
function Safe_Prefixed_Reference (N : Node_Id) return Boolean is
begin
-- If prefix is not side effect free, definitely not safe
if not Side_Effect_Free (Prefix (N), Name_Req, Variable_Ref) then
return False;
-- If the prefix is of an access type that is not access-to-constant,
-- then this construct is a variable reference, which means it is to
-- be considered to have side effects if Variable_Ref is set True.
elsif Is_Access_Type (Etype (Prefix (N)))
and then not Is_Access_Constant (Etype (Prefix (N)))
and then Variable_Ref
then
-- Exception is a prefix that is the result of a previous removal
-- of side-effects.
return Is_Entity_Name (Prefix (N))
and then not Comes_From_Source (Prefix (N))
and then Ekind (Entity (Prefix (N))) = E_Constant
and then Is_Internal_Name (Chars (Entity (Prefix (N))));
-- If the prefix is an explicit dereference then this construct is a
-- variable reference, which means it is to be considered to have
-- side effects if Variable_Ref is True.
-- We do NOT exclude dereferences of access-to-constant types because
-- we handle them as constant view of variables.
elsif Nkind (Prefix (N)) = N_Explicit_Dereference
and then Variable_Ref
then
return False;
-- Note: The following test is the simplest way of solving a complex
-- problem uncovered by the following test (Side effect on loop bound
-- that is a subcomponent of a global variable:
-- with Text_Io; use Text_Io;
-- procedure Tloop is
-- type X is
-- record
-- V : Natural := 4;
-- S : String (1..5) := (others => 'a');
-- end record;
-- X1 : X;
-- procedure Modi;
-- generic
-- with procedure Action;
-- procedure Loop_G (Arg : X; Msg : String)
-- procedure Loop_G (Arg : X; Msg : String) is
-- begin
-- Put_Line ("begin loop_g " & Msg & " will loop till: "
-- & Natural'Image (Arg.V));
-- for Index in 1 .. Arg.V loop
-- Text_Io.Put_Line
-- (Natural'Image (Index) & " " & Arg.S (Index));
-- if Index > 2 then
-- Modi;
-- end if;
-- end loop;
-- Put_Line ("end loop_g " & Msg);
-- end;
-- procedure Loop1 is new Loop_G (Modi);
-- procedure Modi is
-- begin
-- X1.V := 1;
-- Loop1 (X1, "from modi");
-- end;
--
-- begin
-- Loop1 (X1, "initial");
-- end;
-- The output of the above program should be:
-- begin loop_g initial will loop till: 4
-- 1 a
-- 2 a
-- 3 a
-- begin loop_g from modi will loop till: 1
-- 1 a
-- end loop_g from modi
-- 4 a
-- begin loop_g from modi will loop till: 1
-- 1 a
-- end loop_g from modi
-- end loop_g initial
-- If a loop bound is a subcomponent of a global variable, a
-- modification of that variable within the loop may incorrectly
-- affect the execution of the loop.
elsif Nkind (Parent (Parent (N))) = N_Loop_Parameter_Specification
and then Within_In_Parameter (Prefix (N))
and then Variable_Ref
then
return False;
-- All other cases are side effect free
else
return True;
end if;
end Safe_Prefixed_Reference;
-------------------------
-- Within_In_Parameter --
-------------------------
function Within_In_Parameter (N : Node_Id) return Boolean is
begin
if not Comes_From_Source (N) then
return False;
elsif Is_Entity_Name (N) then
return Ekind (Entity (N)) = E_In_Parameter;
elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
return Within_In_Parameter (Prefix (N));
else
return False;
end if;
end Within_In_Parameter;
-- Start of processing for Side_Effect_Free
begin
-- Note on checks that could raise Constraint_Error. Strictly, if we
-- take advantage of 11.6, these checks do not count as side effects.
-- However, we would prefer to consider that they are side effects,
-- since the backend CSE does not work very well on expressions which
-- can raise Constraint_Error. On the other hand if we don't consider
-- them to be side effect free, then we get some awkward expansions
-- in -gnato mode, resulting in code insertions at a point where we
-- do not have a clear model for performing the insertions.
-- Special handling for entity names
if Is_Entity_Name (N) then
-- Variables are considered to be a side effect if Variable_Ref
-- is set or if we have a volatile reference and Name_Req is off.
-- If Name_Req is True then we can't help returning a name which
-- effectively allows multiple references in any case.
if Is_Variable (N, Use_Original_Node => False) then
return not Variable_Ref
and then (not Is_Volatile_Reference (N) or else Name_Req);
-- Any other entity (e.g. a subtype name) is definitely side
-- effect free.
else
return True;
end if;
-- A value known at compile time is always side effect free
elsif Compile_Time_Known_Value (N) then
return True;
-- A variable renaming is not side-effect free, because the renaming
-- will function like a macro in the front-end in some cases, and an
-- assignment can modify the component designated by N, so we need to
-- create a temporary for it.
-- The guard testing for Entity being present is needed at least in
-- the case of rewritten predicate expressions, and may well also be
-- appropriate elsewhere. Obviously we can't go testing the entity
-- field if it does not exist, so it's reasonable to say that this is
-- not the renaming case if it does not exist.
elsif Is_Entity_Name (Original_Node (N))
and then Present (Entity (Original_Node (N)))
and then Is_Renaming_Of_Object (Entity (Original_Node (N)))
and then Ekind (Entity (Original_Node (N))) /= E_Constant
then
declare
RO : constant Node_Id :=
Renamed_Object (Entity (Original_Node (N)));
begin
-- If the renamed object is an indexed component, or an
-- explicit dereference, then the designated object could
-- be modified by an assignment.
if Nkind_In (RO, N_Indexed_Component,
N_Explicit_Dereference)
then
return False;
-- A selected component must have a safe prefix
elsif Nkind (RO) = N_Selected_Component then
return Safe_Prefixed_Reference (RO);
-- In all other cases, designated object cannot be changed so
-- we are side effect free.
else
return True;
end if;
end;
-- Remove_Side_Effects generates an object renaming declaration to
-- capture the expression of a class-wide expression. In VM targets
-- the frontend performs no expansion for dispatching calls to
-- class- wide types since they are handled by the VM. Hence, we must
-- locate here if this node corresponds to a previous invocation of
-- Remove_Side_Effects to avoid a never ending loop in the frontend.
elsif VM_Target /= No_VM
and then not Comes_From_Source (N)
and then Nkind (Parent (N)) = N_Object_Renaming_Declaration
and then Is_Class_Wide_Type (Etype (N))
then
return True;
end if;
-- For other than entity names and compile time known values,
-- check the node kind for special processing.
case Nkind (N) is
-- An attribute reference is side effect free if its expressions
-- are side effect free and its prefix is side effect free or
-- is an entity reference.
-- Is this right? what about x'first where x is a variable???
when N_Attribute_Reference =>
return Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
and then Attribute_Name (N) /= Name_Input
and then (Is_Entity_Name (Prefix (N))
or else Side_Effect_Free
(Prefix (N), Name_Req, Variable_Ref));
-- A binary operator is side effect free if and both operands are
-- side effect free. For this purpose binary operators include
-- membership tests and short circuit forms.
when N_Binary_Op | N_Membership_Test | N_Short_Circuit =>
return Side_Effect_Free (Left_Opnd (N), Name_Req, Variable_Ref)
and then
Side_Effect_Free (Right_Opnd (N), Name_Req, Variable_Ref);
-- An explicit dereference is side effect free only if it is
-- a side effect free prefixed reference.
when N_Explicit_Dereference =>
return Safe_Prefixed_Reference (N);
-- An expression with action is side effect free if its expression
-- is side effect free and it has no actions.
when N_Expression_With_Actions =>
return Is_Empty_List (Actions (N))
and then
Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
-- A call to _rep_to_pos is side effect free, since we generate
-- this pure function call ourselves. Moreover it is critically
-- important to make this exception, since otherwise we can have
-- discriminants in array components which don't look side effect
-- free in the case of an array whose index type is an enumeration
-- type with an enumeration rep clause.
-- All other function calls are not side effect free
when N_Function_Call =>
return Nkind (Name (N)) = N_Identifier
and then Is_TSS (Name (N), TSS_Rep_To_Pos)
and then
Side_Effect_Free
(First (Parameter_Associations (N)), Name_Req, Variable_Ref);
-- An indexed component is side effect free if it is a side
-- effect free prefixed reference and all the indexing
-- expressions are side effect free.
when N_Indexed_Component =>
return Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
and then Safe_Prefixed_Reference (N);
-- A type qualification is side effect free if the expression
-- is side effect free.
when N_Qualified_Expression =>
return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
-- A selected component is side effect free only if it is a side
-- effect free prefixed reference. If it designates a component
-- with a rep. clause it must be treated has having a potential
-- side effect, because it may be modified through a renaming, and
-- a subsequent use of the renaming as a macro will yield the
-- wrong value. This complex interaction between renaming and
-- removing side effects is a reminder that the latter has become
-- a headache to maintain, and that it should be removed in favor
-- of the gcc mechanism to capture values ???
when N_Selected_Component =>
if Nkind (Parent (N)) = N_Explicit_Dereference
and then Has_Non_Standard_Rep (Designated_Type (Etype (N)))
then
return False;
else
return Safe_Prefixed_Reference (N);
end if;
-- A range is side effect free if the bounds are side effect free
when N_Range =>
return Side_Effect_Free (Low_Bound (N), Name_Req, Variable_Ref)
and then
Side_Effect_Free (High_Bound (N), Name_Req, Variable_Ref);
-- A slice is side effect free if it is a side effect free
-- prefixed reference and the bounds are side effect free.
when N_Slice =>
return Side_Effect_Free
(Discrete_Range (N), Name_Req, Variable_Ref)
and then Safe_Prefixed_Reference (N);
-- A type conversion is side effect free if the expression to be
-- converted is side effect free.
when N_Type_Conversion =>
return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
-- A unary operator is side effect free if the operand
-- is side effect free.
when N_Unary_Op =>
return Side_Effect_Free (Right_Opnd (N), Name_Req, Variable_Ref);
-- An unchecked type conversion is side effect free only if it
-- is safe and its argument is side effect free.
when N_Unchecked_Type_Conversion =>
return Safe_Unchecked_Type_Conversion (N)
and then
Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
-- An unchecked expression is side effect free if its expression
-- is side effect free.
when N_Unchecked_Expression =>
return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
-- A literal is side effect free
when N_Character_Literal |
N_Integer_Literal |
N_Real_Literal |
N_String_Literal =>
return True;
-- We consider that anything else has side effects. This is a bit
-- crude, but we are pretty close for most common cases, and we
-- are certainly correct (i.e. we never return True when the
-- answer should be False).
when others =>
return False;
end case;
end Side_Effect_Free;
-- A list is side effect free if all elements of the list are side
-- effect free.
function Side_Effect_Free
(L : List_Id;
Name_Req : Boolean := False;
Variable_Ref : Boolean := False) return Boolean
is
N : Node_Id;
begin
if L = No_List or else L = Error_List then
return True;
else
N := First (L);
while Present (N) loop
if not Side_Effect_Free (N, Name_Req, Variable_Ref) then
return False;
else
Next (N);
end if;
end loop;
return True;
end if;
end Side_Effect_Free;
----------------------------------
-- Silly_Boolean_Array_Not_Test --
----------------------------------

33
gcc/ada/exp_util.ads
View File

@ -770,14 +770,14 @@ package Exp_Util is
-- Given the node for a subexpression, this function replaces the node if
-- necessary by an equivalent subexpression that is guaranteed to be side
-- effect free. This is done by extracting any actions that could cause
-- side effects, and inserting them using Insert_Actions into the tree to
-- which Exp is attached. Exp must be analyzed and resolved before the call
-- and is analyzed and resolved on return. The Name_Req may only be set to
-- side effects, and inserting them using Insert_Actions into the tree
-- to which Exp is attached. Exp must be analyzed and resolved before the
-- call and is analyzed and resolved on return. Name_Req may only be set to
-- True if Exp has the form of a name, and the effect is to guarantee that
-- any replacement maintains the form of name. If Variable_Ref is set to
-- TRUE, a variable is considered as side effect (used in implementing
-- Force_Evaluation). Note: after call to Remove_Side_Effects, it is safe
-- to call New_Copy_Tree to obtain a copy of the resulting expression.
-- Force_Evaluation). Note: after call to Remove_Side_Effects, it is
-- safe to call New_Copy_Tree to obtain a copy of the resulting expression.
function Represented_As_Scalar (T : Entity_Id) return Boolean;
-- Returns True iff the implementation of this type in code generation
@ -826,6 +826,29 @@ package Exp_Util is
-- renamed subprogram. The node is rewritten to be an identifier that
-- refers directly to the renamed subprogram, given by entity E.
function Side_Effect_Free
(N : Node_Id;
Name_Req : Boolean := False;
Variable_Ref : Boolean := False) return Boolean;
-- Determines if the tree N represents an expression that is known not
-- to have side effects. If this function returns True, then for example
-- a call to Remove_Side_Effects has no effect.
--
-- Name_Req controls the handling of volatile variable references. If
-- Name_Req is False (the normal case), then volatile references are
-- considered to be side effects. If Name_Req is True, then volatility
-- of variables is ignored.
--
-- If Variable_Ref is True, then all variable references are considered to
-- be side effects (regardless of volatility or the setting of Name_Req).
function Side_Effect_Free
(L : List_Id;
Name_Req : Boolean := False;
Variable_Ref : Boolean := False) return Boolean;
-- Determines if all elements of the list L are side effect free. Name_Req
-- and Variable_Ref are as described above.
procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id);
-- N is the node for a boolean array NOT operation, and T is the type of
-- the array. This routine deals with the silly case where the subtype of

220
gcc/ada/par-ch13.adb
View File

@ -149,9 +149,9 @@ package body Ch13 is
function Get_Aspect_Specifications
(Semicolon : Boolean := True) return List_Id
is
Aspects : List_Id;
Aspect : Node_Id;
A_Id : Aspect_Id;
Aspect : Node_Id;
Aspects : List_Id;
OK : Boolean;
begin
@ -173,9 +173,13 @@ package body Ch13 is
loop
OK := True;
-- The aspect mark is not an identifier
if Token /= Tok_Identifier then
Error_Msg_SC ("aspect identifier expected");
-- Skip the whole aspect specification list
if Semicolon then
Resync_Past_Semicolon;
end if;
@ -183,17 +187,16 @@ package body Ch13 is
return Aspects;
end if;
-- We have an identifier (which should be an aspect identifier)
A_Id := Get_Aspect_Id (Token_Name);
Aspect :=
Make_Aspect_Specification (Token_Ptr,
Identifier => Token_Node);
-- No valid aspect identifier present
-- The aspect mark is not recognized
if A_Id = No_Aspect then
Error_Msg_SC ("aspect identifier expected");
OK := False;
-- Check bad spelling
@ -209,17 +212,23 @@ package body Ch13 is
Scan; -- past incorrect identifier
if Token = Tok_Apostrophe then
Scan; -- past '
Scan; -- past apostrophe
Scan; -- past presumably CLASS
end if;
-- Attempt to parse the aspect definition by assuming it is an
-- expression.
if Token = Tok_Arrow then
Scan; -- Past arrow
Scan; -- past arrow
Set_Expression (Aspect, P_Expression);
OK := False;
-- The aspect may behave as a boolean aspect
elsif Token = Tok_Comma then
OK := False;
null;
-- Otherwise the aspect contains a junk definition
else
if Semicolon then
@ -229,7 +238,7 @@ package body Ch13 is
return Aspects;
end if;
-- OK aspect scanned
-- Aspect mark is OK
else
Scan; -- past identifier
@ -237,60 +246,58 @@ package body Ch13 is
-- Check for 'Class present
if Token = Tok_Apostrophe then
if not Class_Aspect_OK (A_Id) then
Error_Msg_Node_1 := Identifier (Aspect);
Error_Msg_SC ("aspect& does not permit attribute here");
Scan; -- past apostrophe
Scan; -- past presumed CLASS
OK := False;
else
if Class_Aspect_OK (A_Id) then
Scan; -- past apostrophe
if Token /= Tok_Identifier
or else Token_Name /= Name_Class
if Token = Tok_Identifier
and then Token_Name = Name_Class
then
Scan; -- past CLASS
Set_Class_Present (Aspect);
else
Error_Msg_SC ("Class attribute expected here");
OK := False;
if Token = Tok_Identifier then
Scan; -- past identifier not CLASS
end if;
else
Scan; -- past CLASS
Set_Class_Present (Aspect);
end if;
-- The aspect does not allow 'Class
else
Error_Msg_Node_1 := Identifier (Aspect);
Error_Msg_SC ("aspect& does not permit attribute here");
OK := False;
Scan; -- past apostrophe
Scan; -- past presumably CLASS
end if;
end if;
-- Test case of missing aspect definition
-- Check for a missing aspect definition. Aspects with optional
-- definitions are not considered.
if Token = Tok_Comma
or else Token = Tok_Semicolon
then
if Token = Tok_Comma or else Token = Tok_Semicolon then
if Aspect_Argument (A_Id) /= Optional_Expression
and then
Aspect_Argument (A_Id) /= Optional_Name
and then Aspect_Argument (A_Id) /= Optional_Name
then
Error_Msg_Node_1 := Identifier (Aspect);
Error_Msg_AP ("aspect& requires an aspect definition");
OK := False;
end if;
-- Check for a missing arrow when the aspect has a definition
elsif not Semicolon and then Token /= Tok_Arrow then
if Aspect_Argument (A_Id) /= Optional_Expression
and then
Aspect_Argument (A_Id) /= Optional_Name
and then Aspect_Argument (A_Id) /= Optional_Name
then
-- The name or expression may be there, but the arrow is
-- missing. Skip to the end of the declaration.
T_Arrow;
Resync_To_Semicolon;
end if;
-- Here we have an aspect definition
-- Otherwise we have an aspect definition
else
if Token = Tok_Arrow then
@ -300,9 +307,107 @@ package body Ch13 is
OK := False;
end if;
-- Detect a common error where the non-null definition of
-- aspect Depends, Global, Refined_Depends or Refined_Global
-- must be enclosed in parentheses.
if Token /= Tok_Left_Paren and then Token /= Tok_Null then
-- [Refined_]Depends
if A_Id = Aspect_Depends
or else
A_Id = Aspect_Refined_Depends
then
Error_Msg_SC -- CODEFIX
("missing ""(""");
Resync_Past_Malformed_Aspect;
-- Return when the current aspect is the last in the list
-- of specifications and the list applies to a body.
if Token = Tok_Is then
return Aspects;
end if;
-- [Refined_]Global
elsif A_Id = Aspect_Global
or else
A_Id = Aspect_Refined_Global
then
declare
Scan_State : Saved_Scan_State;
begin
Save_Scan_State (Scan_State);
Scan; -- past item or mode_selector
-- Emit an error when the aspect has a mode_selector
-- as the moded_global_list must be parenthesized:
-- with Global => Output => Item
if Token = Tok_Arrow then
Restore_Scan_State (Scan_State);
Error_Msg_SC -- CODEFIX
("missing ""(""");
Resync_Past_Malformed_Aspect;
-- Return when the current aspect is the last in
-- the list of specifications and the list applies
-- to a body.
if Token = Tok_Is then
return Aspects;
end if;
elsif Token = Tok_Comma then
Scan; -- past comma
-- An item followed by a comma does not need to
-- be parenthesized if the next token is a valid
-- aspect name:
-- with Global => Item,
-- Aspect => ...
if Token = Tok_Identifier
and then Get_Aspect_Id (Token_Name) /= No_Aspect
then
Restore_Scan_State (Scan_State);
-- Otherwise this is a list of items in which case
-- the list must be parenthesized.
else
Restore_Scan_State (Scan_State);
Error_Msg_SC -- CODEFIX
("missing ""(""");
Resync_Past_Malformed_Aspect;
-- Return when the current aspect is the last
-- in the list of specifications and the list
-- applies to a body.
if Token = Tok_Is then
return Aspects;
end if;
end if;
-- The definition of [Refined_]Global does not need to
-- be parenthesized.
else
Restore_Scan_State (Scan_State);
end if;
end;
end if;
end if;
-- Parse the aspect definition depening on the expected
-- argument kind.
if Aspect_Argument (A_Id) = Name
or else
Aspect_Argument (A_Id) = Optional_Name
or else Aspect_Argument (A_Id) = Optional_Name
then
Set_Expression (Aspect, P_Name);
@ -315,18 +420,21 @@ package body Ch13 is
end if;
end if;
-- If OK clause scanned, add it to the list
-- Add the aspect to the resulting list only when it was properly
-- parsed.
if OK then
Append (Aspect, Aspects);
end if;
-- The aspect specification list contains more than one aspect
if Token = Tok_Comma then
Scan; -- past comma
goto Continue;
-- Recognize the case where a comma is missing between two
-- aspects, issue an error and proceed with next aspect.
-- Check for a missing comma between two aspects. Emit an error
-- and proceed to the next aspect.
elsif Token = Tok_Identifier
and then Get_Aspect_Id (Token_Name) /= No_Aspect
@ -338,20 +446,25 @@ package body Ch13 is
Save_Scan_State (Scan_State);
Scan; -- past identifier
if Token = Tok_Arrow then
-- Attempt to detect ' or => following a potential aspect
-- mark.
if Token = Tok_Apostrophe or else Token = Tok_Arrow then
Restore_Scan_State (Scan_State);
Error_Msg_AP -- CODEFIX
("|missing "",""");
goto Continue;
-- The construct following the current aspect is not an
-- aspect.
else
Restore_Scan_State (Scan_State);
end if;
end;
-- Recognize the case where a semicolon was mistyped for a comma
-- between two aspects, issue an error and proceed with next
-- aspect.
-- Check for a mistyped semicolon in place of a comma between two
-- aspects. Emit an error and proceed to the next aspect.
elsif Token = Tok_Semicolon then
declare
@ -366,20 +479,22 @@ package body Ch13 is
then
Scan; -- past identifier
if Token = Tok_Arrow then
-- Attempt to detect ' or => following a potential aspect
-- mark.
if Token = Tok_Apostrophe or else Token = Tok_Arrow then
Restore_Scan_State (Scan_State);
Error_Msg_SC -- CODEFIX
("|"";"" should be "",""");
Scan; -- past semicolon
goto Continue;
else
Restore_Scan_State (Scan_State);
end if;
else
Restore_Scan_State (Scan_State);
end if;
-- The construct following the current aspect is not an
-- aspect.
Restore_Scan_State (Scan_State);
end;
end if;
@ -397,7 +512,6 @@ package body Ch13 is
end loop;
return Aspects;
end Get_Aspect_Specifications;
--------------------------------------------

192
gcc/ada/par-sync.adb
View File

@ -148,6 +148,70 @@ package body Sync is
end if;
end Resync_Init;
----------------------------------
-- Resync_Past_Malformed_Aspect --
----------------------------------
procedure Resync_Past_Malformed_Aspect is
begin
Resync_Init;
loop
-- A comma may separate two aspect specifications, but it may also
-- delimit multiple arguments of a single aspect.
if Token = Tok_Comma then
declare
Scan_State : Saved_Scan_State;
begin
Save_Scan_State (Scan_State);
Scan; -- past comma
-- The identifier following the comma is a valid aspect, the
-- current malformed aspect has been successfully skipped.
if Token = Tok_Identifier
and then Get_Aspect_Id (Token_Name) /= No_Aspect
then
Restore_Scan_State (Scan_State);
exit;
-- The comma is delimiting multiple arguments of an aspect
else
Restore_Scan_State (Scan_State);
end if;
end;
-- An IS signals the last aspect specification when the related
-- context is a body.
elsif Token = Tok_Is then
exit;
-- A semicolon signals the last aspect specification
elsif Token = Tok_Semicolon then
exit;
-- In the case of a mistyped semicolon, any token which follows a
-- semicolon signals the last aspect specification.
elsif Token in Token_Class_After_SM then
exit;
end if;
-- Keep on resyncing
Scan;
end loop;
-- Fall out of loop with resynchronization complete
Resync_Resume;
end Resync_Past_Malformed_Aspect;
---------------------------
-- Resync_Past_Semicolon --
---------------------------
@ -184,41 +248,6 @@ package body Sync is
Resync_Resume;
end Resync_Past_Semicolon;
-------------------------
-- Resync_To_Semicolon --
-------------------------
procedure Resync_To_Semicolon is
begin
Resync_Init;
loop
-- Done if we are at a semicolon
if Token = Tok_Semicolon then
exit;
-- Done if we are at a token which normally appears only after
-- a semicolon. One special glitch is that the keyword private is
-- in this category only if it does NOT appear after WITH.
elsif Token in Token_Class_After_SM
and then (Token /= Tok_Private or else Prev_Token /= Tok_With)
then
exit;
-- Otherwise keep going
else
Scan;
end if;
end loop;
-- Fall out of loop with resynchronization complete
Resync_Resume;
end Resync_To_Semicolon;
----------------------------------------------
-- Resync_Past_Semicolon_Or_To_Loop_Or_Then --
----------------------------------------------
@ -275,35 +304,6 @@ package body Sync is
end if;
end Resync_Resume;
--------------------
-- Resync_To_When --
--------------------
procedure Resync_To_When is
begin
Resync_Init;
loop
-- Done if at semicolon, WHEN or IS
if Token = Tok_Semicolon
or else Token = Tok_When
or else Token = Tok_Is
then
exit;
-- Otherwise keep going
else
Scan;
end if;
end loop;
-- Fall out of loop with resynchronization complete
Resync_Resume;
end Resync_To_When;
---------------------------
-- Resync_Semicolon_List --
---------------------------
@ -340,4 +340,68 @@ package body Sync is
Resync_Resume;
end Resync_Semicolon_List;
-------------------------
-- Resync_To_Semicolon --
-------------------------
procedure Resync_To_Semicolon is
begin
Resync_Init;
loop
-- Done if we are at a semicolon
if Token = Tok_Semicolon then
exit;
-- Done if we are at a token which normally appears only after
-- a semicolon. One special glitch is that the keyword private is
-- in this category only if it does NOT appear after WITH.
elsif Token in Token_Class_After_SM
and then (Token /= Tok_Private or else Prev_Token /= Tok_With)
then
exit;
-- Otherwise keep going
else
Scan;
end if;
end loop;
-- Fall out of loop with resynchronization complete
Resync_Resume;
end Resync_To_Semicolon;
--------------------
-- Resync_To_When --
--------------------
procedure Resync_To_When is
begin
Resync_Init;
loop
-- Done if at semicolon, WHEN or IS
if Token = Tok_Semicolon
or else Token = Tok_When
or else Token = Tok_Is
then
exit;
-- Otherwise keep going
else
Scan;
end if;
end loop;
-- Fall out of loop with resynchronization complete
Resync_Resume;
end Resync_To_When;
end Sync;

31
gcc/ada/par.adb
View File

@ -1079,6 +1079,10 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
-- advanced to the next vertical bar, arrow, or semicolon, whichever
-- comes first. We also quit if we encounter an end of file.
procedure Resync_Cunit;
-- Synchronize to next token which could be the start of a compilation
-- unit, or to the end of file token.
procedure Resync_Expression;
-- Used if an error is detected during the parsing of an expression.
-- It skips past tokens until either a token which cannot be part of
@ -1087,6 +1091,11 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
-- current parenthesis level (a parenthesis level counter is maintained
-- to carry out this test).
procedure Resync_Past_Malformed_Aspect;
-- Used when parsing aspect specifications to skip a malformed aspect.
-- The scan pointer is positioned next to a comma, a semicolon or "is"
-- when the aspect applies to a body.
procedure Resync_Past_Semicolon;
-- Used if an error occurs while scanning a sequence of declarations.
-- The scan pointer is positioned past the next semicolon and the scan
@ -1094,30 +1103,26 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
-- starts a declaration (but we make sure to skip at least one token
-- in this case, to avoid getting stuck in a loop).
procedure Resync_To_Semicolon;
-- Similar to Resync_Past_Semicolon, except that the scan pointer is
-- left pointing to the semicolon rather than past it.
procedure Resync_Past_Semicolon_Or_To_Loop_Or_Then;
-- Used if an error occurs while scanning a sequence of statements. The
-- scan pointer is positioned past the next semicolon, or to the next
-- occurrence of either then or loop, and the scan resumes.
procedure Resync_To_When;
-- Used when an error occurs scanning an entry index specification. The
-- scan pointer is positioned to the next WHEN (or to IS or semicolon if
-- either of these appear before WHEN, indicating another error has
-- occurred).
procedure Resync_Semicolon_List;
-- Used if an error occurs while scanning a parenthesized list of items
-- separated by semicolons. The scan pointer is advanced to the next
-- semicolon or right parenthesis at the outer parenthesis level, or
-- to the next is or RETURN keyword occurrence, whichever comes first.
procedure Resync_Cunit;
-- Synchronize to next token which could be the start of a compilation
-- unit, or to the end of file token.
procedure Resync_To_Semicolon;
-- Similar to Resync_Past_Semicolon, except that the scan pointer is
-- left pointing to the semicolon rather than past it.
procedure Resync_To_When;
-- Used when an error occurs scanning an entry index specification. The
-- scan pointer is positioned to the next WHEN (or to IS or semicolon if
-- either of these appear before WHEN, indicating another error has
-- occurred).
end Sync;
--------------

12
gcc/ada/sinfo.ads
View File

@ -649,9 +649,8 @@ package Sinfo is
-- Mod for signed integer types is expanded into equivalent expressions
-- using Rem (which is % in C) and other C-available operators.
-- The Actions list of an Expression_With_Actions node has any object
-- declarations removed, so that it is composed only of expressions
-- (so that DO X,... Y IN Z can be represented as (X, .. Y, Z) in C).
-- The Actions list of an Expression_With_Actions node does not contain
-- any declarations,(so that DO X, .. Y IN Z becomes (X, .. Y, Z) in C).
------------------------------------
-- Description of Semantic Fields --
@ -7426,11 +7425,8 @@ package Sinfo is
-- not a proper expression), and in the long term all cases of this
-- idiom should instead use a new node kind N_Compound_Statement.
-- Note: In Modify_Tree_For_C, we eliminate declarations from the list
-- of actions, inserting them at the outer level. If we move an object
-- declaration with an initialization expression in this manner, then
-- the action is replaced by an appropriate assignment, otherwise it is
-- removed from the list of actions.
-- Note: In Modify_Tree_For_C, we never generate any declarations in
-- the action list, which can contain only non-declarative statements.
--------------------
-- Free Statement --