CbC/CbC_gcc: gcc/ada/sem_ch5.adb comparison

comparison gcc/ada/sem_ch5.adb @ 131:84e7813d76e9

gcc-8.2

author	mir3636
date	Thu, 25 Oct 2018 07:37:49 +0900
parents	04ced10e8804
children	1830386684a0

comparison

equal deleted inserted replaced

-:04ced10e8804
+:84e7813d76e9
 --                                                                          --
 --                              S E M _ C H 5                               --
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2017, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2018, 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- --
 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
 --  this count is zero, it means that control cannot fall through the IF,
 --  CASE or block statement. This is used for the generation of warning
 --  messages. This variable is recursively saved on entry to processing the
 --  construct, and restored on exit.
+function Has_Sec_Stack_Call (N : Node_Id) return Boolean;
+--  N is the node for an arbitrary construct. This function searches the
+--  construct N to see if any expressions within it contain function
+--  calls that use the secondary stack, returning True if any such call
+--  is found, and False otherwise.
 procedure Preanalyze_Range (R_Copy : Node_Id);
 --  Determine expected type of range or domain of iteration of Ada 2012
 --  loop by analyzing separate copy. Do the analysis and resolution of the
 --  copy of the bound(s) with expansion disabled, to prevent the generation
 --  of finalization actions. This prevents memory leaks when the bounds
 Rhs : Node_Id          := Expression (N);
 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.
+function Is_Protected_Part_Of_Constituent
+(Nod : Node_Id) return Boolean;
+--  Determine whether arbitrary node Nod denotes a Part_Of constituent of
+--  a single protected type.
 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
 --
 --  Similarly, for nonlimited types, aggregates and init procs generate
 --  assignment statements that are really initializations. These are
 --  marked No_Ctrl_Actions.
+function Within_Function return Boolean;
+--  Determine whether the current scope is a function or appears within
+--  one.
 -------------------------------
 -- Diagnose_Non_Variable_Lhs --
 -------------------------------
 procedure Diagnose_Non_Variable_Lhs (N : Node_Id) is
 elsif Is_Entity_Name (N) then
 declare
 Ent : constant Entity_Id := Entity (N);
 begin
-if Ekind (Ent) = E_In_Parameter then
+if Ekind (Ent) = E_Loop_Parameter
+or else Is_Loop_Parameter (Ent)
+then
+Error_Msg_N ("assignment to loop parameter not allowed", N);
+return;
+elsif Ekind (Ent) = E_In_Parameter then
 Error_Msg_N
 ("assignment to IN mode parameter not allowed", N);
 return;
 --  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)
+elsif (Is_Prival (Ent) and then Within_Function)
-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);
 return;
-elsif Ekind (Ent) = E_Loop_Parameter then
-Error_Msg_N ("assignment to loop parameter not allowed", N);
-return;
 end if;
 end;
 --  For indexed components, test prefix if it is in array. We do not
 --  want to recurse for cases where the prefix is a pointer, since we
 --  If we fall through, we have no special message to issue
 Error_Msg_N ("left hand side of assignment must be a variable", N);
 end Diagnose_Non_Variable_Lhs;
+--------------------------------------
+-- Is_Protected_Part_Of_Constituent --
+--------------------------------------
+function Is_Protected_Part_Of_Constituent
+(Nod : Node_Id) return Boolean
+is
+Encap_Id : Entity_Id;
+Var_Id   : Entity_Id;
+begin
+--  Abstract states and variables may act as Part_Of constituents of
+--  single protected types, however only variables can be modified by
+--  an assignment.
+if Is_Entity_Name (Nod) then
+Var_Id := Entity (Nod);
+if Present (Var_Id) and then Ekind (Var_Id) = E_Variable then
+Encap_Id := Encapsulating_State (Var_Id);
+--  To qualify, the node must denote a reference to a variable
+--  whose encapsulating state is a single protected object.
+return
+Present (Encap_Id)
+and then Is_Single_Protected_Object (Encap_Id);
+end if;
+end if;
+return False;
+end Is_Protected_Part_Of_Constituent;
 --------------
 -- Kill_Lhs --
 --------------
 Rhs := Expression (N);
 Insert_Action (N, Obj_Decl);
 end Transform_BIP_Assignment;
+---------------------
+-- Within_Function --
+---------------------
+function Within_Function return Boolean is
+Scop_Id : constant Entity_Id := Current_Scope;
+begin
+if Ekind (Scop_Id) = E_Function then
+return True;
+elsif Ekind (Enclosing_Dynamic_Scope (Scop_Id)) = E_Function then
+return True;
+end if;
+return False;
+end Within_Function;
 --  Local variables
 T1 : Entity_Id;
 T2 : Entity_Id;
-Save_Full_Analysis : Boolean;
+Save_Full_Analysis : Boolean := False;
+--  Force initialization to facilitate static analysis
-Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
---  Save the Ghost mode to restore on exit
+Saved_GM  : constant Ghost_Mode_Type := Ghost_Mode;
+Saved_IGR : constant Node_Id         := Ignored_Ghost_Region;
+--  Save the Ghost-related attributes to restore on exit
 --  Start of processing for Analyze_Assignment
 begin
 Mark_Coextensions (N, Rhs);
 --  Deal with build-in-place calls for nonlimited types. We don't do this
 --  later, because resolving the rhs tranforms it incorrectly for build-
 --  in-place.
 if Should_Transform_BIP_Assignment (Typ => T1) then
+--  In certain cases involving user-defined concatenation operators,
+--  we need to resolve the right-hand side before transforming the
+--  assignment.
+case Nkind (Unqual_Conv (Rhs)) is
+when N_Function_Call =>
+declare
+Actual     : Node_Id :=
+First (Parameter_Associations (Unqual_Conv (Rhs)));
+Actual_Exp : Node_Id;
+begin
+while Present (Actual) loop
+if Nkind (Actual) = N_Parameter_Association then
+Actual_Exp := Explicit_Actual_Parameter (Actual);
+else
+Actual_Exp := Actual;
+end if;
+if Nkind (Actual_Exp) = N_Op_Concat then
+Resolve (Rhs, T1);
+exit;
+end if;
+Next (Actual);
+end loop;
+end;
+when N_Attribute_Reference
+| N_Expanded_Name
+| N_Identifier
+| N_Op
+=>
+null;
+when others =>
+raise Program_Error;
+end case;
 Transform_BIP_Assignment (Typ => T1);
 end if;
 pragma Assert (not Should_Transform_BIP_Assignment (Typ => T1));
 --  in the _assign operation for an abstract type).
 elsif Is_Abstract_Type (T1) and then Comes_From_Source (N) then
 Error_Msg_N
 ("target of assignment operation must not be abstract", Lhs);
+end if;
+--  Variables which are Part_Of constituents of single protected types
+--  behave in similar fashion to protected components. Such variables
+--  cannot be modified by protected functions.
+if Is_Protected_Part_Of_Constituent (Lhs) and then Within_Function then
+Error_Msg_N
+("protected function cannot modify protected object", Lhs);
 end if;
 --  Resolution may have updated the subtype, in case the left-hand side
 --  is a private protected component. Use the correct subtype to avoid
 --  scoping issues in the back-end.
 and then (not Has_Size_Clause (T1) or else Esize (T1) > 64)
 then
 Error_Msg_CRT ("composite assignment", N);
 end if;
+--  Check elaboration warning for left side if not in elab code
+if Legacy_Elaboration_Checks
+and not In_Subprogram_Or_Concurrent_Unit
+then
+Check_Elab_Assign (Lhs);
+end if;
 --  Save the scenario for later examination by the ABE Processing phase
 Record_Elaboration_Scenario (N);
 --  Set Referenced_As_LHS if appropriate. We only set this flag if the
 end;
 Analyze_Dimension (N);
 <<Leave>>
-Restore_Ghost_Mode (Saved_GM);
+Restore_Ghost_Region (Saved_GM, Saved_IGR);
 --  If the right-hand side contains target names, expansion has been
 --  disabled to prevent expansion that might move target names out of
 --  the context of the assignment statement. Restore the expander mode
 --  now so that assignment statement can be properly expanded.
 ------------------------------------
 -- Analyze_Iterator_Specification --
 ------------------------------------
 procedure Analyze_Iterator_Specification (N : Node_Id) is
+Def_Id    : constant Node_Id    := Defining_Identifier (N);
+Iter_Name : constant Node_Id    := Name (N);
+Loc       : constant Source_Ptr := Sloc (N);
+Subt      : constant Node_Id    := Subtype_Indication (N);
+Bas : Entity_Id := Empty;  -- initialize to prevent warning
+Typ : Entity_Id;
 procedure Check_Reverse_Iteration (Typ : Entity_Id);
 --  For an iteration over a container, if the loop carries the Reverse
 --  indicator, verify that the container type has an Iterate aspect that
 --  implements the reversible iterator interface.
+procedure Check_Subtype_Indication (Comp_Type : Entity_Id);
+--  If a subtype indication is present, verify that it is consistent
+--  with the component type of the array or container name.
 function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id;
 --  For containers with Iterator and related aspects, the cursor is
 --  obtained by locating an entity with the proper name in the scope
 --  of the type.
 ("container type does not support reverse iteration", N, Typ);
 end if;
 end if;
 end Check_Reverse_Iteration;
+-------------------------------
+--  Check_Subtype_Indication --
+-------------------------------
+procedure Check_Subtype_Indication (Comp_Type : Entity_Id) is
+begin
+if Present (Subt)
+and then (not Covers (Base_Type ((Bas)), Comp_Type)
+or else not Subtypes_Statically_Match (Bas, Comp_Type))
+then
+if Is_Array_Type (Typ) then
+Error_Msg_N
+("subtype indication does not match component type", Subt);
+else
+Error_Msg_N
+("subtype indication does not match element type", Subt);
+end if;
+end if;
+end Check_Subtype_Indication;
 ---------------------
 -- Get_Cursor_Type --
 ---------------------
 function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id is
 Error_Msg_N ("cursor type cannot be limited", N);
 end if;
 return Etype (Ent);
 end Get_Cursor_Type;
---  Local variables
-Def_Id    : constant Node_Id    := Defining_Identifier (N);
-Iter_Name : constant Node_Id    := Name (N);
-Loc       : constant Source_Ptr := Sloc (N);
-Subt      : constant Node_Id    := Subtype_Indication (N);
-Bas : Entity_Id := Empty;  -- initialize to prevent warning
-Typ : Entity_Id;
 --   Start of processing for Analyze_Iterator_Specification
 begin
 Enter_Name (Def_Id);
 Bas := Entity (Subt);
 end if;
 Preanalyze_Range (Iter_Name);
+--  If the domain of iteration is a function call, make sure the function
+--  itself is frozen. This is an issue if this is a local expression
+--  function.
+if Nkind (Iter_Name) = N_Function_Call
+and then Is_Entity_Name (Name (Iter_Name))
+and then Full_Analysis
+and then (In_Assertion_Expr = 0 or else Assertions_Enabled)
+then
+Freeze_Before (N, Entity (Name (Iter_Name)));
+end if;
 --  Set the kind of the loop variable, which is not visible within the
 --  iterator name.
 Set_Ekind (Def_Id, E_Variable);
 Act_S : Node_Id;
 begin
 --  If the domain of iteration is an array component that depends
---  on a discriminant, create actual subtype for it. Pre-analysis
+--  on a discriminant, create actual subtype for it. preanalysis
 --  does not generate the actual subtype of a selected component.
 if Nkind (Iter_Name) = N_Selected_Component
 and then Is_Array_Type (Etype (Iter_Name))
 then
 Error_Msg_N
 ("iterable name cannot be a discriminant-dependent "
 & "component of a mutable object", N);
 end if;
-if Present (Subt)
+Check_Subtype_Indication (Component_Type (Typ));
-and then
-(Base_Type (Bas) /= Base_Type (Component_Type (Typ))
-or else
-not Subtypes_Statically_Match (Bas, Component_Type (Typ)))
-then
-Error_Msg_N
-("subtype indication does not match component type", Subt);
-end if;
 --  Here we have a missing Range attribute
 else
 Error_Msg_N
 Set_Etype (Def_Id, Etype (Elt));
 Check_Reverse_Iteration (Typ);
 end if;
 end;
+Check_Subtype_Indication (Etype (Def_Id));
 --  For a predefined container, The type of the loop variable is
 --  the Iterator_Element aspect of the container type.
 else
 declare
 else
 Set_Etype (Def_Id, Entity (Element));
 Cursor_Type := Get_Cursor_Type (Typ);
 pragma Assert (Present (Cursor_Type));
---  If subtype indication was given, verify that it covers
+Check_Subtype_Indication (Etype (Def_Id));
---  the element type of the container.
-if Present (Subt)
-and then (not Covers (Bas, Etype (Def_Id))
-or else not Subtypes_Statically_Match
-(Bas, Etype (Def_Id)))
-then
-Error_Msg_N
-("subtype indication does not match element type",
-Subt);
-end if;
 --  If the container has a variable indexing aspect, the
 --  element is a variable and is modifiable in the loop.
 if Has_Aspect (Typ, Aspect_Variable_Indexing) then
 --  Diagnose Attempt to iterate through non-static predicate. Note that
 --  a type with inherited predicates may have both static and dynamic
 --  forms. In this case it is not sufficent to check the static predicate
 --  function only, look for a dynamic predicate aspect as well.
-function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean;
---  N is the node for an arbitrary construct. This function searches the
---  construct N to see if any expressions within it contain function
---  calls that use the secondary stack, returning True if any such call
---  is found, and False otherwise.
 procedure Process_Bounds (R : Node_Id);
 --  If the iteration is given by a range, create temporaries and
 --  assignment statements block to capture the bounds and perform
 --  required finalization actions in case a bound includes a function
---  call that uses the temporary stack. We first pre-analyze a copy of
+--  call that uses the temporary stack. We first preanalyze a copy of
 --  the range in order to determine the expected type, and analyze and
 --  resolve the original bounds.
 --------------------------------------
 -- Check_Controlled_Array_Attribute --
 then
 Set_No_Dynamic_Predicate_On_Actual (T);
 end if;
 end Check_Predicate_Use;
-------------------------------------
--- Has_Call_Using_Secondary_Stack --
-------------------------------------
-function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean is
-function Check_Call (N : Node_Id) return Traverse_Result;
---  Check if N is a function call which uses the secondary stack
-----------------
--- Check_Call --
-----------------
-function Check_Call (N : Node_Id) return Traverse_Result is
-Nam        : Node_Id;
-Subp       : Entity_Id;
-Return_Typ : Entity_Id;
-begin
-if Nkind (N) = N_Function_Call then
-Nam := Name (N);
---  Call using access to subprogram with explicit dereference
-if Nkind (Nam) = N_Explicit_Dereference then
-Subp := Etype (Nam);
---  Call using a selected component notation or Ada 2005 object
---  operation notation
-elsif Nkind (Nam) = N_Selected_Component then
-Subp := Entity (Selector_Name (Nam));
---  Common case
-else
-Subp := Entity (Nam);
-end if;
-Return_Typ := Etype (Subp);
-if Is_Composite_Type (Return_Typ)
-and then not Is_Constrained (Return_Typ)
-then
-return Abandon;
-elsif Sec_Stack_Needed_For_Return (Subp) then
-return Abandon;
-end if;
-end if;
---  Continue traversing the tree
-return OK;
-end Check_Call;
-function Check_Calls is new Traverse_Func (Check_Call);
---  Start of processing for Has_Call_Using_Secondary_Stack
-begin
-return Check_Calls (N) = Abandon;
-end Has_Call_Using_Secondary_Stack;
 --------------------
 -- Process_Bounds --
 --------------------
 procedure Process_Bounds (R : Node_Id) is
 --  We prefer the constant declaration, since it leaves us with a
 --  proper trace of the value, useful in optimizations that get rid
 --  of junk range checks.
-if not Has_Call_Using_Secondary_Stack (Analyzed_Bound) then
+if not Has_Sec_Stack_Call (Analyzed_Bound) then
 Analyze_And_Resolve (Original_Bound, Typ);
 --  Ensure that the bound is valid. This check should not be
 --  generated when the range belongs to a quantified expression
 --  as the construct is still not expanded into its final form.
 --  Domain of iteration is not a function call, and is side-effect
 --  free.
 else
 --  A quantified expression that appears in a pre/post condition
---  is pre-analyzed several times.  If the range is given by an
+--  is preanalyzed several times.  If the range is given by an
 --  attribute reference it is rewritten as a range, and this is
 --  done even with expansion disabled. If the type is already set
 --  do not reanalyze, because a range with static bounds may be
 --  typed Integer by default.
 -- Analyze_Loop_Statement --
 ----------------------------
 procedure Analyze_Loop_Statement (N : Node_Id) is
-function Is_Container_Iterator (Iter : Node_Id) return Boolean;
+--  The following exception is raised by routine Prepare_Loop_Statement
---  Given a loop iteration scheme, determine whether it is an Ada 2012
+--  to avoid further analysis of a transformed loop.
---  container iteration.
+Skip_Analysis : exception;
-function Is_Wrapped_In_Block (N : Node_Id) return Boolean;
---  Determine whether loop statement N has been wrapped in a block to
+function Disable_Constant (N : Node_Id) return Traverse_Result;
---  capture finalization actions that may be generated for container
+--  If N represents an E_Variable entity, set Is_True_Constant To False
---  iterators. Prevents infinite recursion when block is analyzed.
---  Routine is a noop if loop is single statement within source block.
+procedure Disable_Constants is new Traverse_Proc (Disable_Constant);
+--  Helper for Analyze_Loop_Statement, to unset Is_True_Constant on
----------------------------
+--  variables referenced within an OpenACC construct.
--- Is_Container_Iterator --
----------------------------
+procedure Prepare_Loop_Statement (Iter : Node_Id);
+--  Determine whether loop statement N with iteration scheme Iter must be
-function Is_Container_Iterator (Iter : Node_Id) return Boolean is
+--  transformed prior to analysis, and if so, perform it. The routine
+--  raises Skip_Analysis to prevent further analysis of the transformed
+--  loop.
+----------------------
+-- Disable_Constant --
+----------------------
+function Disable_Constant (N : Node_Id) return Traverse_Result is
 begin
---  Infinite loop
+if Is_Entity_Name (N)
+and then Present (Entity (N))
-if No (Iter) then
+and then Ekind (Entity (N)) = E_Variable
+then
+Set_Is_True_Constant (Entity (N), False);
+end if;
+return OK;
+end Disable_Constant;
+----------------------------
+-- Prepare_Loop_Statement --
+----------------------------
+procedure Prepare_Loop_Statement (Iter : Node_Id) is
+function Has_Sec_Stack_Default_Iterator
+(Cont_Typ : Entity_Id) return Boolean;
+pragma Inline (Has_Sec_Stack_Default_Iterator);
+--  Determine whether container type Cont_Typ has a default iterator
+--  that requires secondary stack management.
+function Is_Sec_Stack_Iteration_Primitive
+(Cont_Typ      : Entity_Id;
+Iter_Prim_Nam : Name_Id) return Boolean;
+pragma Inline (Is_Sec_Stack_Iteration_Primitive);
+--  Determine whether container type Cont_Typ has an iteration routine
+--  described by its name Iter_Prim_Nam that requires secondary stack
+--  management.
+function Is_Wrapped_In_Block (Stmt : Node_Id) return Boolean;
+pragma Inline (Is_Wrapped_In_Block);
+--  Determine whether arbitrary statement Stmt is the sole statement
+--  wrapped within some block, excluding pragmas.
+procedure Prepare_Iterator_Loop (Iter_Spec : Node_Id);
+pragma Inline (Prepare_Iterator_Loop);
+--  Prepare an iterator loop with iteration specification Iter_Spec
+--  for transformation if needed.
+procedure Prepare_Param_Spec_Loop (Param_Spec : Node_Id);
+pragma Inline (Prepare_Param_Spec_Loop);
+--  Prepare a discrete loop with parameter specification Param_Spec
+--  for transformation if needed.
+procedure Wrap_Loop_Statement (Manage_Sec_Stack : Boolean);
+pragma Inline    (Wrap_Loop_Statement);
+pragma No_Return (Wrap_Loop_Statement);
+--  Wrap loop statement N within a block. Flag Manage_Sec_Stack must
+--  be set when the block must mark and release the secondary stack.
+------------------------------------
+-- Has_Sec_Stack_Default_Iterator --
+------------------------------------
+function Has_Sec_Stack_Default_Iterator
+(Cont_Typ : Entity_Id) return Boolean
+is
+Def_Iter : constant Node_Id :=
+Find_Value_Of_Aspect
+(Cont_Typ, Aspect_Default_Iterator);
+begin
+return
+Present (Def_Iter)
+and then Requires_Transient_Scope (Etype (Def_Iter));
+end Has_Sec_Stack_Default_Iterator;
+--------------------------------------
+-- Is_Sec_Stack_Iteration_Primitive --
+--------------------------------------
+function Is_Sec_Stack_Iteration_Primitive
+(Cont_Typ      : Entity_Id;
+Iter_Prim_Nam : Name_Id) return Boolean
+is
+Iter_Prim : constant Entity_Id :=
+Get_Iterable_Type_Primitive
+(Cont_Typ, Iter_Prim_Nam);
+begin
+return
+Present (Iter_Prim)
+and then Requires_Transient_Scope (Etype (Iter_Prim));
+end Is_Sec_Stack_Iteration_Primitive;
+-------------------------
+-- Is_Wrapped_In_Block --
+-------------------------
+function Is_Wrapped_In_Block (Stmt : Node_Id) return Boolean is
+Blk_HSS  : Node_Id;
+Blk_Id   : Entity_Id;
+Blk_Stmt : Node_Id;
+begin
+Blk_Id := Current_Scope;
+--  The current context is a block. Inspect the statements of the
+--  block to determine whether it wraps Stmt.
+if Ekind (Blk_Id) = E_Block
+and then Present (Block_Node (Blk_Id))
+then
+Blk_HSS :=
+Handled_Statement_Sequence (Parent (Block_Node (Blk_Id)));
+--  Skip leading pragmas introduced for invariant and predicate
+--  checks.
+Blk_Stmt := First (Statements (Blk_HSS));
+while Present (Blk_Stmt)
+and then Nkind (Blk_Stmt) = N_Pragma
+loop
+Next (Blk_Stmt);
+end loop;
+return Blk_Stmt = Stmt and then No (Next (Blk_Stmt));
+end if;
 return False;
+end Is_Wrapped_In_Block;
---  While loop
+---------------------------
-elsif Present (Condition (Iter)) then
+-- Prepare_Iterator_Loop --
-return False;
+---------------------------
---  for Def_Id in [reverse] Name loop
+procedure Prepare_Iterator_Loop (Iter_Spec : Node_Id) is
---  for Def_Id [: Subtype_Indication] of [reverse] Name loop
+Cont_Typ : Entity_Id;
+Nam      : Node_Id;
-elsif Present (Iterator_Specification (Iter)) then
+Nam_Copy : Node_Id;
-declare
-Nam : constant Node_Id := Name (Iterator_Specification (Iter));
+begin
-Nam_Copy : Node_Id;
+--  The iterator specification has syntactic errors. Transform the
+--  loop into an infinite loop in order to safely perform at least
-begin
+--  some minor analysis. This check must come first.
+if Error_Posted (Iter_Spec) then
+Set_Iteration_Scheme (N, Empty);
+Analyze (N);
+raise Skip_Analysis;
+--  Nothing to do when the loop is already wrapped in a block
+elsif Is_Wrapped_In_Block (N) then
+null;
+--  Otherwise the iterator loop traverses an array or a container
+--  and appears in the form
+--
+--    for Def_Id in [reverse] Iterator_Name loop
+--    for Def_Id [: Subtyp_Indic] of [reverse] Iterable_Name loop
+else
+--  Prepare a copy of the iterated name for preanalysis. The
+--  copy is semi inserted into the tree by setting its Parent
+--  pointer.
+Nam      := Name (Iter_Spec);
 Nam_Copy := New_Copy_Tree (Nam);
 Set_Parent (Nam_Copy, Parent (Nam));
+--  Determine what the loop is iterating on
 Preanalyze_Range (Nam_Copy);
+Cont_Typ := Etype (Nam_Copy);
---  The only two options here are iteration over a container or
---  an array.
+--  The iterator loop is traversing an array. This case does not
+--  require any transformation.
-return not Is_Array_Type (Etype (Nam_Copy));
-end;
+if Is_Array_Type (Cont_Typ) then
+null;
---  for Def_Id in [reverse] Discrete_Subtype_Definition loop
+--  Otherwise unconditionally wrap the loop statement within
-else
+--  a block. The expansion of iterator loops may relocate the
-declare
+--  iterator outside the loop, thus "leaking" its entity into
-LP : constant Node_Id := Loop_Parameter_Specification (Iter);
+--  the enclosing scope. Wrapping the loop statement allows
-DS : constant Node_Id := Discrete_Subtype_Definition (LP);
+--  for multiple iterator loops using the same iterator name
-DS_Copy : Node_Id;
+--  to coexist within the same scope.
+--
-begin
+--  The block must manage the secondary stack when the iterator
-DS_Copy := New_Copy_Tree (DS);
+--  loop is traversing a container using either
-Set_Parent (DS_Copy, Parent (DS));
+--
-Preanalyze_Range (DS_Copy);
+--    * A default iterator obtained on the secondary stack
+--
---  Check for a call to Iterate () or an expression with
+--    * Call to Iterate where the iterator is returned on the
---  an iterator type.
+--      secondary stack.
+--
-return
+--    * Combination of First, Next, and Has_Element where the
-(Nkind (DS_Copy) = N_Function_Call
+--      first two return a cursor on the secondary stack.
-and then Needs_Finalization (Etype (DS_Copy)))
-or else Is_Iterator (Etype (DS_Copy));
+else
-end;
+Wrap_Loop_Statement
-end if;
+(Manage_Sec_Stack =>
-end Is_Container_Iterator;
+Has_Sec_Stack_Default_Iterator (Cont_Typ)
+or else Has_Sec_Stack_Call (Nam_Copy)
--------------------------
+or else Is_Sec_Stack_Iteration_Primitive
--- Is_Wrapped_In_Block --
+(Cont_Typ, Name_First)
--------------------------
+or else Is_Sec_Stack_Iteration_Primitive
+(Cont_Typ, Name_Next));
-function Is_Wrapped_In_Block (N : Node_Id) return Boolean is
+end if;
-HSS  : Node_Id;
+end if;
-Stat : Node_Id;
+end Prepare_Iterator_Loop;
+-----------------------------
+-- Prepare_Param_Spec_Loop --
+-----------------------------
+procedure Prepare_Param_Spec_Loop (Param_Spec : Node_Id) is
+High     : Node_Id;
+Low      : Node_Id;
+Rng      : Node_Id;
+Rng_Copy : Node_Id;
+Rng_Typ  : Entity_Id;
+begin
+Rng := Discrete_Subtype_Definition (Param_Spec);
+--  Nothing to do when the loop is already wrapped in a block
+if Is_Wrapped_In_Block (N) then
+null;
+--  The parameter specification appears in the form
+--
+--    for Def_Id in Subtype_Mark Constraint loop
+elsif Nkind (Rng) = N_Subtype_Indication
+and then Nkind (Range_Expression (Constraint (Rng))) = N_Range
+then
+Rng := Range_Expression (Constraint (Rng));
+--  Preanalyze the bounds of the range constraint
+Low  := New_Copy_Tree (Low_Bound  (Rng));
+High := New_Copy_Tree (High_Bound (Rng));
+Preanalyze (Low);
+Preanalyze (High);
+--  The bounds contain at least one function call that returns
+--  on the secondary stack. Note that the loop must be wrapped
+--  only when such a call exists.
+if Has_Sec_Stack_Call (Low)
+or else
+Has_Sec_Stack_Call (High)
+then
+Wrap_Loop_Statement (Manage_Sec_Stack => True);
+end if;
+--  Otherwise the parameter specification appears in the form
+--
+--    for Def_Id in Range loop
+else
+--  Prepare a copy of the discrete range for preanalysis. The
+--  copy is semi inserted into the tree by setting its Parent
+--  pointer.
+Rng_Copy := New_Copy_Tree (Rng);
+Set_Parent (Rng_Copy, Parent (Rng));
+--  Determine what the loop is iterating on
+Preanalyze_Range (Rng_Copy);
+Rng_Typ := Etype (Rng_Copy);
+--  Wrap the loop statement within a block in order to manage
+--  the secondary stack when the discrete range is
+--
+--    * Either a Forward_Iterator or a Reverse_Iterator
+--
+--    * Function call whose return type requires finalization
+--      actions.
+--  ??? it is unclear why using Has_Sec_Stack_Call directly on
+--  the discrete range causes the freeze node of an itype to be
+--  in the wrong scope in complex assertion expressions.
+if Is_Iterator (Rng_Typ)
+or else (Nkind (Rng_Copy) = N_Function_Call
+and then Needs_Finalization (Rng_Typ))
+then
+Wrap_Loop_Statement (Manage_Sec_Stack => True);
+end if;
+end if;
+end Prepare_Param_Spec_Loop;
+-------------------------
+-- Wrap_Loop_Statement --
+-------------------------
+procedure Wrap_Loop_Statement (Manage_Sec_Stack : Boolean) is
+Loc : constant Source_Ptr := Sloc (N);
+Blk    : Node_Id;
+Blk_Id : Entity_Id;
+begin
+Blk :=
+Make_Block_Statement (Loc,
+Declarations               => New_List,
+Handled_Statement_Sequence =>
+Make_Handled_Sequence_Of_Statements (Loc,
+Statements => New_List (Relocate_Node (N))));
+Add_Block_Identifier (Blk, Blk_Id);
+Set_Uses_Sec_Stack (Blk_Id, Manage_Sec_Stack);
+Rewrite (N, Blk);
+Analyze (N);
+raise Skip_Analysis;
+end Wrap_Loop_Statement;
+--  Local variables
+Iter_Spec  : constant Node_Id := Iterator_Specification (Iter);
+Param_Spec : constant Node_Id := Loop_Parameter_Specification (Iter);
+--  Start of processing for Prepare_Loop_Statement
 begin
+if Present (Iter_Spec) then
---  Check if current scope is a block that is not a transient block.
+Prepare_Iterator_Loop (Iter_Spec);
-if Ekind (Current_Scope) /= E_Block
+elsif Present (Param_Spec) then
-or else No (Block_Node (Current_Scope))
+Prepare_Param_Spec_Loop (Param_Spec);
-then
+end if;
-return False;
+end Prepare_Loop_Statement;
-else
-HSS  :=
-Handled_Statement_Sequence (Parent (Block_Node (Current_Scope)));
---  Skip leading pragmas that may be introduced for invariant and
---  predicate checks.
-Stat := First (Statements (HSS));
-while Present (Stat) and then Nkind (Stat) = N_Pragma loop
-Stat := Next (Stat);
-end loop;
-return Stat = N and then No (Next (Stat));
-end if;
-end Is_Wrapped_In_Block;
 --  Local declarations
 Id   : constant Node_Id := Identifier (N);
 Iter : constant Node_Id := Iteration_Scheme (N);
 Set_Identifier (N, New_Occurrence_Of (Ent, Loc));
 Set_Parent (Ent, N);
 Set_Has_Created_Identifier (N);
 end if;
---  If the iterator specification has a syntactic error, transform
+--  Determine whether the loop statement must be transformed prior to
---  construct into an infinite loop to prevent a crash and perform
+--  analysis, and if so, perform it. This early modification is needed
---  some analysis.
+--  when:
+--
-if Present (Iter)
+--    * The loop has an erroneous iteration scheme. In this case the
-and then Present (Iterator_Specification (Iter))
+--      loop is converted into an infinite loop in order to perform
-and then Error_Posted (Iterator_Specification (Iter))
+--      minor analysis.
-then
+--
-Set_Iteration_Scheme (N, Empty);
+--    * The loop is an Ada 2012 iterator loop. In this case the loop is
-Analyze (N);
+--      wrapped within a block to provide a local scope for the iterator.
-return;
+--      If the iterator specification requires the secondary stack in any
-end if;
+--      way, the block is marked in order to manage it.
+--
---  Iteration over a container in Ada 2012 involves the creation of a
+--    * The loop is using a parameter specification where the discrete
---  controlled iterator object. Wrap the loop in a block to ensure the
+--      range requires the secondary stack. In this case the loop is
---  timely finalization of the iterator and release of container locks.
+--      wrapped within a block in order to manage the secondary stack.
---  The same applies to the use of secondary stack when obtaining an
---  iterator.
+if Present (Iter) then
+Prepare_Loop_Statement (Iter);
-if Ada_Version >= Ada_2012
-and then Is_Container_Iterator (Iter)
-and then not Is_Wrapped_In_Block (N)
-then
-declare
-Block_Nod : Node_Id;
-Block_Id  : Entity_Id;
-begin
-Block_Nod :=
-Make_Block_Statement (Loc,
-Declarations               => New_List,
-Handled_Statement_Sequence =>
-Make_Handled_Sequence_Of_Statements (Loc,
-Statements => New_List (Relocate_Node (N))));
-Add_Block_Identifier (Block_Nod, Block_Id);
---  The expansion of iterator loops generates an iterator in order
---  to traverse the elements of a container:
---    Iter : <iterator type> := Iterate (Container)'reference;
---  The iterator is controlled and returned on the secondary stack.
---  The analysis of the call to Iterate establishes a transient
---  scope to deal with the secondary stack management, but never
---  really creates a physical block as this would kill the iterator
---  too early (see Wrap_Transient_Declaration). To address this
---  case, mark the generated block as needing secondary stack
---  management.
-Set_Uses_Sec_Stack (Block_Id);
-Rewrite (N, Block_Nod);
-Analyze (N);
-return;
-end;
 end if;
 --  Kill current values on entry to loop, since statements in the body of
 --  the 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
 --  contains no EXIT statements within the body of the loop.
 if No (Iter) and then not Has_Exit (Ent) then
 Check_Unreachable_Code (Stmt);
 end if;
+--  Variables referenced within a loop subject to possible OpenACC
+--  offloading may be implicitly written to as part of the OpenACC
+--  transaction.  Clear flags possibly conveying that they are constant,
+--  set for example when the code does not explicitly assign them.
+if Is_OpenAcc_Environment (Stmt) then
+Disable_Constants (Stmt);
+end if;
+exception
+when Skip_Analysis =>
+null;
 end Analyze_Loop_Statement;
 ----------------------------
 -- Analyze_Null_Statement --
 ----------------------------
 end if;
 end;
 end if;
 end Check_Unreachable_Code;
+------------------------
+-- Has_Sec_Stack_Call --
+------------------------
+function Has_Sec_Stack_Call (N : Node_Id) return Boolean is
+function Check_Call (N : Node_Id) return Traverse_Result;
+--  Check if N is a function call which uses the secondary stack
+----------------
+-- Check_Call --
+----------------
+function Check_Call (N : Node_Id) return Traverse_Result is
+Nam  : Node_Id;
+Subp : Entity_Id;
+Typ  : Entity_Id;
+begin
+if Nkind (N) = N_Function_Call then
+Nam := Name (N);
+--  Obtain the subprogram being invoked
+loop
+if Nkind (Nam) = N_Explicit_Dereference then
+Nam := Prefix (Nam);
+elsif Nkind (Nam) = N_Selected_Component then
+Nam := Selector_Name (Nam);
+else
+exit;
+end if;
+end loop;
+Subp := Entity (Nam);
+if Present (Subp) then
+Typ := Etype (Subp);
+if Requires_Transient_Scope (Typ) then
+return Abandon;
+elsif Sec_Stack_Needed_For_Return (Subp) then
+return Abandon;
+end if;
+end if;
+end if;
+--  Continue traversing the tree
+return OK;
+end Check_Call;
+function Check_Calls is new Traverse_Func (Check_Call);
+--  Start of processing for Has_Sec_Stack_Call
+begin
+return Check_Calls (N) = Abandon;
+end Has_Sec_Stack_Call;
 ----------------------
 -- Preanalyze_Range --
 ----------------------
 procedure Preanalyze_Range (R_Copy : Node_Id) is
 Typ           : Entity_Id;
 begin
 Full_Analysis := False;
 Expander_Mode_Save_And_Set (False);
+--  In addition to the above we must explicitly suppress the generation
+--  of freeze nodes that might otherwise be generated during resolution
+--  of the range (e.g. if given by an attribute that will freeze its
+--  prefix).
+Set_Must_Not_Freeze (R_Copy);
+if Nkind (R_Copy) = N_Attribute_Reference then
+Set_Must_Not_Freeze (Prefix (R_Copy));
+end if;
 Analyze (R_Copy);
 if Nkind (R_Copy) in N_Subexpr and then Is_Overloaded (R_Copy) then

Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/sem_ch5.adb @ 131:84e7813d76e9