From d436b30d99371fec40a60e617f86e3ede5701ac2 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 24 Apr 2013 16:18:30 +0200 Subject: [multiple changes] 2013-04-24 Thomas Quinot * g-socket.adb (Host_Entry): Introduce intermediate copy of memory location pointed to by Hostent_H_Addr, as it might not have sufficient alignment. 2013-04-24 Yannick Moy * repinfo.adb (List_Rep_Info): Set the value of Unit_Casing before calling subprograms which may read it. 2013-04-24 Hristian Kirtchev * einfo.adb: Remove Loop_Entry_Attributes from the usage of nodes. Flag 260 is now used. (Has_Loop_Entry_Attributes): New routine. (Loop_Entry_Attributes): Removed. (Set_Has_Loop_Entry_Attributes): New routine. (Set_Loop_Entry_Attributes): Removed. (Write_Entity_Flags): Write out Flag 260. (Write_Field10_Name): Remove the output for Loop_Entry_Attributes. * einfo.ads: Remove attribute Loop_Entry_Attributes, its related comment and uses in nodes. Add new attribute Has_Loop_Entry_Attributes, related comment and uses in loop nodes. (Has_Loop_Entry_Attributes): New routine and pragma Inline. (Loop_Entry_Attributes): Removed along with pragma Inline. (Set_Has_Loop_Entry_Attributes): New routine and pragma Inline. (Set_Loop_Entry_Attributes): Removed along with pragma Inline. * exp_attr.adb (Expand_Loop_Entry_Attribute): New routine. (Expand_N_Attribute_Reference): Expand attribute 'Loop_Entry. * exp_ch5.adb: Remove with and use clause for Elists. (Expand_Loop_Entry_Attributes): Removed. (Expand_N_Loop_Statement): Add local variable Stmt. Rename local constant Isc to Scheme. When a loop is subject to attribute 'Loop_Entry, retrieve the nested loop from the conditional block. Move the processing of controlled object at the end of loop expansion. * sem_attr.adb (Analyze_Attribute): Do not chain attribute 'Loop_Entry to its related loop. * sem_ch5.adb (Analyze_Loop_Statement): Add local variable Stmt. When the iteration scheme mentions attribute 'Loop_Entry, the entire loop is rewritten into a block. Retrieve the nested loop in such cases to complete the analysis. * sem_util.ads, sem_util.adb (Find_Loop_In_Conditional_Block): New routine. (Subject_To_Loop_Entry_Attributes): New routine. 2013-04-24 Robert Dewar * exp_prag.adb (Expand_Loop_Variant): Generate pragma Check (Loop_Variant, xxx) rather than Assert (xxx). * gnat_rm.texi: Document pragma Loop_Variant. * sem_prag.adb (Analyze_Pragma, case Loop_Variant): Remove call to S14_Pragma. From-SVN: r198235 --- gcc/ada/ChangeLog | 55 +++++++ gcc/ada/einfo.adb | 32 ++--- gcc/ada/einfo.ads | 19 +-- gcc/ada/exp_attr.adb | 384 ++++++++++++++++++++++++++++++++++++++++++++++++- gcc/ada/exp_ch5.adb | 396 ++++----------------------------------------------- gcc/ada/exp_prag.adb | 10 +- gcc/ada/g-socket.adb | 24 +++- gcc/ada/gnat_rm.texi | 41 ++++++ gcc/ada/repinfo.adb | 5 +- gcc/ada/sem_attr.adb | 14 +- gcc/ada/sem_ch5.adb | 18 ++- gcc/ada/sem_prag.adb | 1 - gcc/ada/sem_util.adb | 62 ++++++++ gcc/ada/sem_util.ads | 9 ++ 14 files changed, 641 insertions(+), 429 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 4f8e025..4b39d70 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,58 @@ +2013-04-24 Thomas Quinot + + * g-socket.adb (Host_Entry): Introduce intermediate copy of + memory location pointed to by Hostent_H_Addr, as it might not + have sufficient alignment. + +2013-04-24 Yannick Moy + + * repinfo.adb (List_Rep_Info): Set the value of Unit_Casing before + calling subprograms which may read it. + +2013-04-24 Hristian Kirtchev + + * einfo.adb: Remove Loop_Entry_Attributes from the usage of + nodes. Flag 260 is now used. + (Has_Loop_Entry_Attributes): New routine. + (Loop_Entry_Attributes): Removed. + (Set_Has_Loop_Entry_Attributes): New routine. + (Set_Loop_Entry_Attributes): Removed. + (Write_Entity_Flags): Write out Flag 260. + (Write_Field10_Name): Remove the output for Loop_Entry_Attributes. + * einfo.ads: Remove attribute Loop_Entry_Attributes, + its related comment and uses in nodes. Add new attribute + Has_Loop_Entry_Attributes, related comment and uses in loop nodes. + (Has_Loop_Entry_Attributes): New routine and pragma Inline. + (Loop_Entry_Attributes): Removed along with pragma Inline. + (Set_Has_Loop_Entry_Attributes): New routine and pragma Inline. + (Set_Loop_Entry_Attributes): Removed along with pragma Inline. + * exp_attr.adb (Expand_Loop_Entry_Attribute): New routine. + (Expand_N_Attribute_Reference): Expand attribute 'Loop_Entry. + * exp_ch5.adb: Remove with and use clause for Elists. + (Expand_Loop_Entry_Attributes): Removed. + (Expand_N_Loop_Statement): Add local variable Stmt. Rename local + constant Isc to Scheme. When a loop is subject to attribute + 'Loop_Entry, retrieve the nested loop from the conditional + block. Move the processing of controlled object at the end of + loop expansion. + * sem_attr.adb (Analyze_Attribute): Do not chain attribute + 'Loop_Entry to its related loop. + * sem_ch5.adb (Analyze_Loop_Statement): Add local variable + Stmt. When the iteration scheme mentions attribute 'Loop_Entry, + the entire loop is rewritten into a block. Retrieve the nested + loop in such cases to complete the analysis. + * sem_util.ads, sem_util.adb (Find_Loop_In_Conditional_Block): New + routine. + (Subject_To_Loop_Entry_Attributes): New routine. + +2013-04-24 Robert Dewar + + * exp_prag.adb (Expand_Loop_Variant): Generate pragma Check + (Loop_Variant, xxx) rather than Assert (xxx). + * gnat_rm.texi: Document pragma Loop_Variant. + * sem_prag.adb (Analyze_Pragma, case Loop_Variant): Remove call + to S14_Pragma. + 2013-04-24 Yannick Moy * adabkend.adb, ali-util.adb, ali.adb, debug.adb, diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 0c85d51..96e875e 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -93,7 +93,6 @@ package body Einfo is -- Discriminal_Link Node10 -- Float_Rep Uint10 (but returns Float_Rep_Kind) -- Handler_Records List10 - -- Loop_Entry_Attributes Elist10 -- Normalized_Position_Max Uint10 -- Component_Bit_Offset Uint11 @@ -548,8 +547,7 @@ package body Einfo is -- Is_Invariant_Procedure Flag257 -- Has_Dynamic_Predicate_Aspect Flag258 -- Has_Static_Predicate_Aspect Flag259 - - -- (unused) Flag260 + -- Has_Loop_Entry_Attributes Flag260 -- (unused) Flag261 -- (unused) Flag262 @@ -1467,6 +1465,12 @@ package body Einfo is return Flag232 (Id); end Has_Invariants; + function Has_Loop_Entry_Attributes (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Loop); + return Flag260 (Id); + end Has_Loop_Entry_Attributes; + function Has_Machine_Radix_Clause (Id : E) return B is begin pragma Assert (Is_Decimal_Fixed_Point_Type (Id)); @@ -2396,12 +2400,6 @@ package body Einfo is return Node16 (Id); end Lit_Strings; - function Loop_Entry_Attributes (Id : E) return L is - begin - pragma Assert (Ekind (Id) = E_Loop); - return Elist10 (Id); - end Loop_Entry_Attributes; - function Low_Bound_Tested (Id : E) return B is begin return Flag205 (Id); @@ -4051,6 +4049,12 @@ package body Einfo is Set_Flag232 (Id, V); end Set_Has_Invariants; + procedure Set_Has_Loop_Entry_Attributes (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Loop); + Set_Flag260 (Id, V); + end Set_Has_Loop_Entry_Attributes; + procedure Set_Has_Machine_Radix_Clause (Id : E; V : B := True) is begin pragma Assert (Is_Decimal_Fixed_Point_Type (Id)); @@ -5022,12 +5026,6 @@ package body Einfo is Set_Node16 (Id, V); end Set_Lit_Strings; - procedure Set_Loop_Entry_Attributes (Id : E; V : L) is - begin - pragma Assert (Ekind (Id) = E_Loop); - Set_Elist10 (Id, V); - end Set_Loop_Entry_Attributes; - procedure Set_Low_Bound_Tested (Id : E; V : B := True) is begin pragma Assert (Is_Formal (Id)); @@ -7816,6 +7814,7 @@ package body Einfo is W ("Has_Inheritable_Invariants", Flag248 (Id)); W ("Has_Initial_Value", Flag219 (Id)); W ("Has_Invariants", Flag232 (Id)); + W ("Has_Loop_Entry_Attributes", Flag260 (Id)); W ("Has_Machine_Radix_Clause", Flag83 (Id)); W ("Has_Master_Entity", Flag21 (Id)); W ("Has_Missing_Return", Flag142 (Id)); @@ -8268,9 +8267,6 @@ package body Einfo is E_Procedure => Write_Str ("Handler_Records"); - when E_Loop => - Write_Str ("Loop_Entry_Attributes"); - when E_Component | E_Discriminant => Write_Str ("Normalized_Position_Max"); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 16624d2..62cdb8e 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1598,6 +1598,11 @@ package Einfo is -- Note that it might be the full type which has inheritable invariants, -- and then the flag will also be set in the private type. +-- Has_Loop_Entry_Attributes (Flag260) +-- Defined in E_Loop entities. Set when the loop is subject to at least +-- one attribute 'Loop_Entry. The flag also implies that the loop has +-- already been transformed. See Expand_Loop_Entry_Attribute for details. + -- Has_Machine_Radix_Clause (Flag83) -- Defined in decimal types and subtypes, set if a Machine_Radix -- representation clause is present. This flag is used to detect @@ -3033,10 +3038,6 @@ package Einfo is -- the nature and use of this entity for implementing the Image and -- Value attributes for the enumeration type in question. --- Loop_Entry_Attributes (Elist10) --- Defined for loop statement scopes. The list contains all Loop_Entry --- attribute references related to the target loop. - -- Low_Bound_Tested (Flag205) -- Defined in all entities. Currently this can only be set True for -- formal parameter entries of a standard unconstrained one-dimensional @@ -5507,8 +5508,8 @@ package Einfo is -- E_Loop -- First_Exit_Statement (Node8) - -- Loop_Entry_Attributes (Elist10) -- Has_Exit (Flag47) + -- Has_Loop_Entry_Attributes (Flag260) -- Has_Master_Entity (Flag21) -- Has_Nested_Block_With_Handler (Flag101) @@ -6280,6 +6281,7 @@ package Einfo is function Has_Initial_Value (Id : E) return B; function Has_Interrupt_Handler (Id : E) return B; function Has_Invariants (Id : E) return B; + function Has_Loop_Entry_Attributes (Id : E) return B; function Has_Machine_Radix_Clause (Id : E) return B; function Has_Master_Entity (Id : E) return B; function Has_Missing_Return (Id : E) return B; @@ -6444,7 +6446,6 @@ package Einfo is function Limited_View (Id : E) return E; function Lit_Indexes (Id : E) return E; function Lit_Strings (Id : E) return E; - function Loop_Entry_Attributes (Id : E) return L; function Low_Bound_Tested (Id : E) return B; function Machine_Radix_10 (Id : E) return B; function Master_Id (Id : E) return E; @@ -6887,6 +6888,7 @@ package Einfo is procedure Set_Has_Inheritable_Invariants (Id : E; V : B := True); procedure Set_Has_Initial_Value (Id : E; V : B := True); procedure Set_Has_Invariants (Id : E; V : B := True); + procedure Set_Has_Loop_Entry_Attributes (Id : E; V : B := True); procedure Set_Has_Machine_Radix_Clause (Id : E; V : B := True); procedure Set_Has_Master_Entity (Id : E; V : B := True); procedure Set_Has_Missing_Return (Id : E; V : B := True); @@ -7057,7 +7059,6 @@ package Einfo is procedure Set_Limited_View (Id : E; V : E); procedure Set_Lit_Indexes (Id : E; V : E); procedure Set_Lit_Strings (Id : E; V : E); - procedure Set_Loop_Entry_Attributes (Id : E; V : L); procedure Set_Low_Bound_Tested (Id : E; V : B := True); procedure Set_Machine_Radix_10 (Id : E; V : B := True); procedure Set_Master_Id (Id : E; V : E); @@ -7586,6 +7587,7 @@ package Einfo is pragma Inline (Has_Inheritable_Invariants); pragma Inline (Has_Initial_Value); pragma Inline (Has_Invariants); + pragma Inline (Has_Loop_Entry_Attributes); pragma Inline (Has_Machine_Radix_Clause); pragma Inline (Has_Master_Entity); pragma Inline (Has_Missing_Return); @@ -7795,7 +7797,6 @@ package Einfo is pragma Inline (Limited_View); pragma Inline (Lit_Indexes); pragma Inline (Lit_Strings); - pragma Inline (Loop_Entry_Attributes); pragma Inline (Low_Bound_Tested); pragma Inline (Machine_Radix_10); pragma Inline (Master_Id); @@ -8043,6 +8044,7 @@ package Einfo is pragma Inline (Set_Has_Inheritable_Invariants); pragma Inline (Set_Has_Initial_Value); pragma Inline (Set_Has_Invariants); + pragma Inline (Set_Has_Loop_Entry_Attributes); pragma Inline (Set_Has_Machine_Radix_Clause); pragma Inline (Set_Has_Master_Entity); pragma Inline (Set_Has_Missing_Return); @@ -8212,7 +8214,6 @@ package Einfo is pragma Inline (Set_Limited_View); pragma Inline (Set_Lit_Indexes); pragma Inline (Set_Lit_Strings); - pragma Inline (Set_Loop_Entry_Attributes); pragma Inline (Set_Low_Bound_Tested); pragma Inline (Set_Machine_Radix_10); pragma Inline (Set_Master_Id); diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 832d182..fc44324 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -136,6 +136,10 @@ package body Exp_Attr is -- that takes two floating-point arguments. The function to be called -- is always the same as the attribute name. + procedure Expand_Loop_Entry_Attribute (Attr : Node_Id); + -- Handle the expansion of attribute 'Loop_Entry. As a result, the related + -- loop may be converted into a conditional block. See body for details. + procedure Expand_Pred_Succ (N : Node_Id); -- Handles expansion of Pred or Succ attributes for case of non-real -- operand with overflow checking required. @@ -635,10 +639,11 @@ package body Exp_Attr is -- by Expand_Fpt_Attribute procedure Expand_Fpt_Attribute_RR (N : Node_Id) is - E1 : constant Node_Id := First (Expressions (N)); + E1 : constant Node_Id := First (Expressions (N)); + E2 : constant Node_Id := Next (E1); Ftp : Entity_Id; Pkg : RE_Id; - E2 : constant Node_Id := Next (E1); + begin Find_Fat_Info (Etype (E1), Ftp, Pkg); Expand_Fpt_Attribute @@ -648,6 +653,374 @@ package body Exp_Attr is Unchecked_Convert_To (Ftp, Relocate_Node (E2)))); end Expand_Fpt_Attribute_RR; + --------------------------------- + -- Expand_Loop_Entry_Attribute -- + --------------------------------- + + procedure Expand_Loop_Entry_Attribute (Attr : Node_Id) is + procedure Build_Conditional_Block + (Loc : Source_Ptr; + Cond : Node_Id; + Loop_Stmt : Node_Id; + If_Stmt : out Node_Id; + Blk_Stmt : out Node_Id); + -- Create a block Blk_Stmt with an empty declarative list and a single + -- loop Loop_Stmt. The block is encased in an if statement If_Stmt with + -- condition Cond. If_Stmt is Empty when there is no condition provided. + + function Is_Array_Iteration (N : Node_Id) return Boolean; + -- Determine whether loop statement N denotes an Ada 2012 iteration over + -- an array object. + + ----------------------------- + -- Build_Conditional_Block -- + ----------------------------- + + procedure Build_Conditional_Block + (Loc : Source_Ptr; + Cond : Node_Id; + Loop_Stmt : Node_Id; + If_Stmt : out Node_Id; + Blk_Stmt : out Node_Id) + is + begin + -- Do not reanalyze the original loop statement because it is simply + -- being relocated. + + Set_Analyzed (Loop_Stmt); + + Blk_Stmt := + Make_Block_Statement (Loc, + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Loop_Stmt))); + + if Present (Cond) then + If_Stmt := + Make_If_Statement (Loc, + Condition => Cond, + Then_Statements => New_List (Blk_Stmt)); + else + If_Stmt := Empty; + end if; + end Build_Conditional_Block; + + ------------------------ + -- Is_Array_Iteration -- + ------------------------ + + function Is_Array_Iteration (N : Node_Id) return Boolean is + Stmt : constant Node_Id := Original_Node (N); + Iter : Node_Id; + + begin + if Nkind (Stmt) = N_Loop_Statement + and then Present (Iteration_Scheme (Stmt)) + and then Present (Iterator_Specification (Iteration_Scheme (Stmt))) + then + Iter := Iterator_Specification (Iteration_Scheme (Stmt)); + + return + Of_Present (Iter) and then Is_Array_Type (Etype (Name (Iter))); + end if; + + return False; + end Is_Array_Iteration; + + -- Local variables + + Exprs : constant List_Id := Expressions (Attr); + Pref : constant Node_Id := Prefix (Attr); + Typ : constant Entity_Id := Etype (Pref); + Blk : Node_Id; + Decls : List_Id; + Installed : Boolean; + Loc : Source_Ptr; + Loop_Id : Entity_Id; + Loop_Stmt : Node_Id; + Result : Node_Id; + Scheme : Node_Id; + Temp_Decl : Node_Id; + Temp_Id : Entity_Id; + + -- Start of processing for Expand_Loop_Entry_Attribute + + begin + -- Step 1: Find the related loop + + -- The loop label variant of attribute 'Loop_Entry already has all the + -- information in its expression. + + if Present (Exprs) then + Loop_Id := Entity (First (Exprs)); + Loop_Stmt := Label_Construct (Parent (Loop_Id)); + + -- Climb the parent chain to find the nearest enclosing loop. Skip all + -- internally generated loops for quantified expressions. + + else + Loop_Stmt := Attr; + while Present (Loop_Stmt) loop + if Nkind (Loop_Stmt) = N_Loop_Statement + and then Present (Identifier (Loop_Stmt)) + then + exit; + end if; + + Loop_Stmt := Parent (Loop_Stmt); + end loop; + + Loop_Id := Entity (Identifier (Loop_Stmt)); + end if; + + Loc := Sloc (Loop_Stmt); + + -- Step 2: Transform the loop + + -- The loop has already been transformed during the expansion of a prior + -- 'Loop_Entry attribute. Retrieve the declarative list of the block. + + if Has_Loop_Entry_Attributes (Loop_Id) then + Decls := Declarations (Parent (Parent (Loop_Stmt))); + Result := Empty; + + -- Transform the loop into a conditional block + + else + Set_Has_Loop_Entry_Attributes (Loop_Id); + Scheme := Iteration_Scheme (Loop_Stmt); + + -- While loops are transformed into: + + -- if then + -- declare + -- Temp1 : constant := ; + -- . . . + -- TempN : constant := ; + -- begin + -- loop + -- + -- exit when not ; + -- end loop; + -- end; + -- end if; + + -- Note that loops over iterators and containers are already + -- converted into while loops. + + if Present (Condition (Scheme)) then + declare + Cond : constant Node_Id := Condition (Scheme); + + begin + -- Transform the original while loop into an infinite loop + -- where the last statement checks the negated condition. This + -- placement ensures that the condition will not be evaluated + -- twice on the first iteration. + + -- Generate: + -- exit when not : + + Append_To (Statements (Loop_Stmt), + Make_Exit_Statement (Loc, + Condition => Make_Op_Not (Loc, New_Copy_Tree (Cond)))); + + Build_Conditional_Block (Loc, + Cond => Relocate_Node (Cond), + Loop_Stmt => Relocate_Node (Loop_Stmt), + If_Stmt => Result, + Blk_Stmt => Blk); + end; + + -- Ada 2012 iteration over an array is transformed into: + + -- if 'Length (1) > 0 + -- and then 'Length (N) > 0 + -- then + -- declare + -- Temp1 : constant := ; + -- . . . + -- TempN : constant := ; + -- begin + -- for X in ... loop -- multiple loops depending on dims + -- + -- end loop; + -- end; + -- end if; + + elsif Is_Array_Iteration (Loop_Stmt) then + declare + Array_Nam : constant Entity_Id := + Entity (Name (Iterator_Specification + (Iteration_Scheme (Original_Node (Loop_Stmt))))); + Num_Dims : constant Pos := + Number_Dimensions (Etype (Array_Nam)); + Cond : Node_Id := Empty; + Check : Node_Id; + + begin + -- Generate a check which determines whether all dimensions of + -- the array are non-null. + + for Dim in 1 .. Num_Dims loop + Check := + Make_Op_Gt (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Array_Nam, Loc), + Attribute_Name => Name_Length, + Expressions => New_List ( + Make_Integer_Literal (Loc, Dim))), + Right_Opnd => + Make_Integer_Literal (Loc, 0)); + + if No (Cond) then + Cond := Check; + else + Cond := + Make_And_Then (Loc, + Left_Opnd => Cond, + Right_Opnd => Check); + end if; + end loop; + + Build_Conditional_Block (Loc, + Cond => Cond, + Loop_Stmt => Relocate_Node (Loop_Stmt), + If_Stmt => Result, + Blk_Stmt => Blk); + end; + + -- For loops are transformed into: + + -- if <= then + -- declare + -- Temp1 : constant := ; + -- . . . + -- TempN : constant := ; + -- begin + -- for in .. loop + -- + -- end loop; + -- end; + -- end if; + + elsif Present (Loop_Parameter_Specification (Scheme)) then + declare + Loop_Spec : constant Node_Id := + Loop_Parameter_Specification (Scheme); + Cond : Node_Id; + Subt_Def : Node_Id; + + begin + Subt_Def := Discrete_Subtype_Definition (Loop_Spec); + + -- When the loop iterates over a subtype indication with a + -- range, use the low and high bounds of the subtype itself. + + if Nkind (Subt_Def) = N_Subtype_Indication then + Subt_Def := Scalar_Range (Etype (Subt_Def)); + end if; + + pragma Assert (Nkind (Subt_Def) = N_Range); + + -- Generate + -- Low <= High + + Cond := + Make_Op_Le (Loc, + Left_Opnd => New_Copy_Tree (Low_Bound (Subt_Def)), + Right_Opnd => New_Copy_Tree (High_Bound (Subt_Def))); + + Build_Conditional_Block (Loc, + Cond => Cond, + Loop_Stmt => Relocate_Node (Loop_Stmt), + If_Stmt => Result, + Blk_Stmt => Blk); + end; + + -- Infinite loops are transformed into: + + -- declare + -- Temp1 : constant := ; + -- . . . + -- TempN : constant := ; + -- begin + -- loop + -- + -- end loop; + -- end; + + else + Build_Conditional_Block (Loc, + Cond => Empty, + Loop_Stmt => Relocate_Node (Loop_Stmt), + If_Stmt => Result, + Blk_Stmt => Blk); + + Result := Blk; + end if; + + Decls := Declarations (Blk); + end if; + + -- Step 3: Create a constant to capture the value of the prefix at the + -- entry point into the loop. + + -- Generate: + -- Temp : constant := ; + + Temp_Id := Make_Temporary (Loc, 'P'); + + Temp_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp_Id, + Constant_Present => True, + Object_Definition => New_Reference_To (Typ, Loc), + Expression => Relocate_Node (Pref)); + Append_To (Decls, Temp_Decl); + + -- Step 4: Analyze all bits + + Rewrite (Attr, New_Reference_To (Temp_Id, Loc)); + + -- The analysis of the conditional block takes care of the constant + -- declaration. + + Installed := Current_Scope = Loop_Id; + + if not Installed then + Push_Scope (Scope (Loop_Id)); + end if; + + if Present (Result) then + Rewrite (Loop_Stmt, Result); + Analyze (Loop_Stmt); + else + Analyze (Temp_Decl); + end if; + + Analyze (Attr); + + -- Patch up a renaming of a 'Loop_Entry attribute. This case may arise + -- when the attribute is used as the name in an Ada 2012 iterator loop. + + if Nkind (Parent (Attr)) = N_Object_Renaming_Declaration then + declare + Mark : constant Node_Id := Subtype_Mark (Parent (Attr)); + + begin + Rewrite (Mark, New_Reference_To (Etype (Temp_Id), Sloc (Mark))); + Analyze (Mark); + end; + end if; + + if not Installed then + Pop_Scope; + end if; + end Expand_Loop_Entry_Attribute; + ---------------------------------- -- Expand_N_Attribute_Reference -- ---------------------------------- @@ -3138,11 +3511,12 @@ package body Exp_Attr is end if; end Length; - -- The expansion of this attribute is carried out when the target loop - -- is processed. See Expand_Loop_Entry_Attributes for details. + -- Attribute Loop_Entry is replaced with a reference to a constant value + -- which captures the prefix at the entry point of the related loop. The + -- loop itself may be transformed into a conditional block. when Attribute_Loop_Entry => - null; + Expand_Loop_Entry_Attribute (N); ------------- -- Machine -- diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 999ded7..95e649a 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -28,7 +28,6 @@ with Atree; use Atree; with Checks; use Checks; with Debug; use Debug; with Einfo; use Einfo; -with Elists; use Elists; with Errout; use Errout; with Exp_Aggr; use Exp_Aggr; with Exp_Ch6; use Exp_Ch6; @@ -111,10 +110,6 @@ package body Exp_Ch5 is procedure Expand_Iterator_Loop_Over_Array (N : Node_Id); -- Expand loop over arrays that uses the form "for X of C" - procedure Expand_Loop_Entry_Attributes (N : Node_Id); - -- Given a loop statement subject to at least one Loop_Entry attribute, - -- expand both the loop and all related Loop_Entry references. - procedure Expand_Predicated_Loop (N : Node_Id); -- Expand for loop over predicated subtype @@ -1527,347 +1522,6 @@ package body Exp_Ch5 is end; end Expand_Assign_Record; - ---------------------------------- - -- Expand_Loop_Entry_Attributes -- - ---------------------------------- - - procedure Expand_Loop_Entry_Attributes (N : Node_Id) is - procedure Build_Conditional_Block - (Loc : Source_Ptr; - Cond : Node_Id; - Stmt : Node_Id; - If_Stmt : out Node_Id; - Blk_Stmt : out Node_Id); - -- Create a block Blk_Stmt with an empty declarative list and a single - -- statement Stmt. The block is encased in an if statement If_Stmt with - -- condition Cond. If_Stmt is Empty when there is no condition provided. - - function Is_Array_Iteration (N : Node_Id) return Boolean; - -- Determine whether loop statement N denotes an Ada 2012 iteration over - -- an array object. - - ----------------------------- - -- Build_Conditional_Block -- - ----------------------------- - - procedure Build_Conditional_Block - (Loc : Source_Ptr; - Cond : Node_Id; - Stmt : Node_Id; - If_Stmt : out Node_Id; - Blk_Stmt : out Node_Id) - is - begin - Blk_Stmt := - Make_Block_Statement (Loc, - Declarations => New_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Stmt))); - - if Present (Cond) then - If_Stmt := - Make_If_Statement (Loc, - Condition => Cond, - Then_Statements => New_List (Blk_Stmt)); - else - If_Stmt := Empty; - end if; - end Build_Conditional_Block; - - ------------------------ - -- Is_Array_Iteration -- - ------------------------ - - function Is_Array_Iteration (N : Node_Id) return Boolean is - Stmt : constant Node_Id := Original_Node (N); - Iter : Node_Id; - - begin - if Nkind (Stmt) = N_Loop_Statement - and then Present (Iteration_Scheme (Stmt)) - and then Present (Iterator_Specification (Iteration_Scheme (Stmt))) - then - Iter := Iterator_Specification (Iteration_Scheme (Stmt)); - - return - Of_Present (Iter) - and then Is_Array_Type (Etype (Name (Iter))); - end if; - - return False; - end Is_Array_Iteration; - - -- Local variables - - Loc : constant Source_Ptr := Sloc (N); - Loop_Id : constant Entity_Id := Identifier (N); - Scheme : constant Node_Id := Iteration_Scheme (N); - Blk : Node_Id; - LE : Node_Id; - LE_Elmt : Elmt_Id; - Result : Node_Id; - Temp : Entity_Id; - Typ : Entity_Id; - - -- Start of processing for Expand_Loop_Entry_Attributes - - begin - -- The loop will never execute after it has been expanded, no point in - -- processing it. - - if Is_Null_Loop (N) then - return; - - -- A loop without an identifier cannot be referenced in 'Loop_Entry - - elsif No (Loop_Id) then - return; - - -- The loop is not subject to 'Loop_Entry - - elsif No (Loop_Entry_Attributes (Entity (Loop_Id))) then - return; - - -- Step 1: Loop transformations - - -- While loops are transformed into: - - -- if then - -- declare - -- Temp1 : constant := ; - -- . . . - -- TempN : constant := ; - -- begin - -- loop - -- - -- exit when not ; - -- end loop; - -- end; - -- end if; - - -- Note that loops over iterators and containers are already converted - -- into while loops. - - elsif Present (Condition (Scheme)) then - declare - Cond : constant Node_Id := Condition (Scheme); - - begin - -- Transform the original while loop into an infinite loop where - -- the last statement checks the negated condition. This placement - -- ensures that the condition will not be evaluated twice on the - -- first iteration. - - -- Generate: - -- exit when not : - - Append_To (Statements (N), - Make_Exit_Statement (Loc, - Condition => Make_Op_Not (Loc, New_Copy_Tree (Cond)))); - - Build_Conditional_Block (Loc, - Cond => Relocate_Node (Cond), - Stmt => Relocate_Node (N), - If_Stmt => Result, - Blk_Stmt => Blk); - end; - - -- Ada 2012 iteration over an array is transformed into: - - -- if 'Length (1) > 0 - -- and then 'Length (N) > 0 - -- then - -- declare - -- Temp1 : constant := ; - -- . . . - -- TempN : constant := ; - -- begin - -- for X in ... loop -- multiple loops depending on dims - -- - -- end loop; - -- end; - -- end if; - - elsif Is_Array_Iteration (N) then - declare - Array_Nam : constant Entity_Id := - Entity (Name (Iterator_Specification - (Iteration_Scheme (Original_Node (N))))); - Num_Dims : constant Pos := - Number_Dimensions (Etype (Array_Nam)); - Cond : Node_Id := Empty; - Check : Node_Id; - Top_Loop : Node_Id; - - begin - -- Generate a check which determines whether all dimensions of - -- the array are non-null. - - for Dim in 1 .. Num_Dims loop - Check := - Make_Op_Gt (Loc, - Left_Opnd => - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Array_Nam, Loc), - Attribute_Name => Name_Length, - Expressions => New_List ( - Make_Integer_Literal (Loc, Dim))), - Right_Opnd => - Make_Integer_Literal (Loc, 0)); - - if No (Cond) then - Cond := Check; - else - Cond := - Make_And_Then (Loc, - Left_Opnd => Cond, - Right_Opnd => Check); - end if; - end loop; - - Top_Loop := Relocate_Node (N); - Set_Analyzed (Top_Loop); - - Build_Conditional_Block (Loc, - Cond => Cond, - Stmt => Top_Loop, - If_Stmt => Result, - Blk_Stmt => Blk); - end; - - -- For loops are transformed into: - - -- if <= then - -- declare - -- Temp1 : constant := ; - -- . . . - -- TempN : constant := ; - -- begin - -- for in .. loop - -- - -- end loop; - -- end; - -- end if; - - elsif Present (Loop_Parameter_Specification (Scheme)) then - declare - Loop_Spec : constant Node_Id := - Loop_Parameter_Specification (Scheme); - Cond : Node_Id; - Subt_Def : Node_Id; - - begin - Subt_Def := Discrete_Subtype_Definition (Loop_Spec); - - -- When the loop iterates over a subtype indication with a range, - -- use the low and high bounds of the subtype itself. - - if Nkind (Subt_Def) = N_Subtype_Indication then - Subt_Def := Scalar_Range (Etype (Subt_Def)); - end if; - - pragma Assert (Nkind (Subt_Def) = N_Range); - - -- Generate - -- Low <= High - - Cond := - Make_Op_Le (Loc, - Left_Opnd => New_Copy_Tree (Low_Bound (Subt_Def)), - Right_Opnd => New_Copy_Tree (High_Bound (Subt_Def))); - - Build_Conditional_Block (Loc, - Cond => Cond, - Stmt => Relocate_Node (N), - If_Stmt => Result, - Blk_Stmt => Blk); - end; - - -- Infinite loops are transformed into: - - -- declare - -- Temp1 : constant := ; - -- . . . - -- TempN : constant := ; - -- begin - -- loop - -- - -- end loop; - -- end; - - else - Build_Conditional_Block (Loc, - Cond => Empty, - Stmt => Relocate_Node (N), - If_Stmt => Result, - Blk_Stmt => Blk); - - Result := Blk; - end if; - - -- Step 2: Loop_Entry attribute transformations - - -- At this point the various loops have been augmented to contain a - -- block. Populate the declarative list of the block with constants - -- which store the value of their relative prefixes at the point of - -- entry in the loop. - - LE_Elmt := First_Elmt (Loop_Entry_Attributes (Entity (Loop_Id))); - while Present (LE_Elmt) loop - LE := Node (LE_Elmt); - Typ := Etype (Prefix (LE)); - - -- Declare a constant to capture the value of the prefix of each - -- Loop_Entry attribute. - - -- Generate: - -- Temp : constant := ; - - Temp := Make_Temporary (Loc, 'P'); - - Append_To (Declarations (Blk), - Make_Object_Declaration (Loc, - Defining_Identifier => Temp, - Constant_Present => True, - Object_Definition => New_Reference_To (Typ, Loc), - Expression => Relocate_Node (Prefix (LE)))); - - -- Perform minor decoration as this information will be needed for - -- the creation of index checks (if applicable). - - Set_Ekind (Temp, E_Constant); - Set_Etype (Temp, Typ); - - -- Replace the original attribute with a reference to the constant - - Rewrite (LE, New_Reference_To (Temp, Loc)); - Set_Etype (LE, Typ); - - -- Analysis converts attribute references of the following form - - -- Prefix'Loop_Entry (Expr) - -- Prefix'Loop_Entry (Expr1, Expr2, ... ExprN) - - -- into indexed components for error detection purposes. Generate - -- index checks now that 'Loop_Entry has been properly expanded. - - if Nkind (Parent (LE)) = N_Indexed_Component then - Generate_Index_Checks (Parent (LE)); - end if; - - Next_Elmt (LE_Elmt); - end loop; - - -- Destroy the list of Loop_Entry attributes to prevent the infinite - -- expansion when analyzing and expanding the newly generated loops. - - Set_Loop_Entry_Attributes (Entity (Loop_Id), No_Elist); - - Rewrite (N, Result); - Analyze (N); - end Expand_Loop_Entry_Attributes; - ----------------------------------- -- Expand_N_Assignment_Statement -- ----------------------------------- @@ -3777,8 +3431,9 @@ package body Exp_Ch5 is -- 7. Insert polling call if required procedure Expand_N_Loop_Statement (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Isc : constant Node_Id := Iteration_Scheme (N); + Loc : constant Source_Ptr := Sloc (N); + Scheme : constant Node_Id := Iteration_Scheme (N); + Stmt : Node_Id; begin -- Delete null loop @@ -3788,12 +3443,10 @@ package body Exp_Ch5 is return; end if; - Process_Statements_For_Controlled_Objects (N); - -- Deal with condition for C/Fortran Boolean - if Present (Isc) then - Adjust_Condition (Condition (Isc)); + if Present (Scheme) then + Adjust_Condition (Condition (Scheme)); end if; -- Generate polling call @@ -3804,7 +3457,7 @@ package body Exp_Ch5 is -- Nothing more to do for plain loop with no iteration scheme - if No (Isc) then + if No (Scheme) then null; -- Case of for loop (Loop_Parameter_Specification present) @@ -3813,9 +3466,10 @@ package body Exp_Ch5 is -- range bounds here, since they were frozen with constant declarations -- and it is during that process that the validity checking is done. - elsif Present (Loop_Parameter_Specification (Isc)) then + elsif Present (Loop_Parameter_Specification (Scheme)) then declare - LPS : constant Node_Id := Loop_Parameter_Specification (Isc); + LPS : constant Node_Id := + Loop_Parameter_Specification (Scheme); Loop_Id : constant Entity_Id := Defining_Identifier (LPS); Ltype : constant Entity_Id := Etype (Loop_Id); Btype : constant Entity_Id := Base_Type (Ltype); @@ -3990,22 +3644,22 @@ package body Exp_Ch5 is -- ... -- end loop - elsif Present (Isc) - and then Present (Condition_Actions (Isc)) - and then Present (Condition (Isc)) + elsif Present (Scheme) + and then Present (Condition_Actions (Scheme)) + and then Present (Condition (Scheme)) then declare ES : Node_Id; begin ES := - Make_Exit_Statement (Sloc (Condition (Isc)), + Make_Exit_Statement (Sloc (Condition (Scheme)), Condition => - Make_Op_Not (Sloc (Condition (Isc)), - Right_Opnd => Condition (Isc))); + Make_Op_Not (Sloc (Condition (Scheme)), + Right_Opnd => Condition (Scheme))); Prepend (ES, Statements (N)); - Insert_List_Before (ES, Condition_Actions (Isc)); + Insert_List_Before (ES, Condition_Actions (Scheme)); -- This is not an implicit loop, since it is generated in response -- to the loop statement being processed. If this is itself @@ -4023,18 +3677,24 @@ package body Exp_Ch5 is -- Here to deal with iterator case - elsif Present (Isc) - and then Present (Iterator_Specification (Isc)) + elsif Present (Scheme) + and then Present (Iterator_Specification (Scheme)) then Expand_Iterator_Loop (N); end if; - -- If the loop is subject to at least one Loop_Entry attribute, it - -- requires additional processing. + -- When the iteration scheme mentiones attribute 'Loop_Entry, the loop + -- is transformed into a conditional block where the original loop is + -- the sole statement. Inspect the statements of the nested loop for + -- controlled objects. + + Stmt := N; - if Nkind (N) = N_Loop_Statement then - Expand_Loop_Entry_Attributes (N); + if Subject_To_Loop_Entry_Attributes (Stmt) then + Stmt := Find_Loop_In_Conditional_Block (Stmt); end if; + + Process_Statements_For_Controlled_Objects (Stmt); end Expand_N_Loop_Statement; ---------------------------- diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index 36191fb..fba371e 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -830,9 +830,9 @@ package body Exp_Prag is -- if Flag then -- if Curr_1 /= Old_1 then - -- pragma Assert (Curr_1 > Old_1); + -- pragma Check (Loop_Variant, Curr_1 > Old_1); -- else - -- pragma Assert (Curr_2 < Old_2); + -- pragma Check (Loop_Variant, Curr_2 < Old_2); -- end if; -- else -- Flag := True; @@ -999,13 +999,15 @@ package body Exp_Prag is -- Step 5: Create corresponding assertion to verify change of value -- Generate: - -- pragma Assert (Curr <|> Old); + -- pragma Check (Loop_Variant, Curr <|> Old); Prag := Make_Pragma (Loc, - Chars => Name_Assert, + Chars => Name_Check, Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Name_Loop_Variant)), + Make_Pragma_Argument_Association (Loc, Expression => Make_Op (Loc, Curr_Val => New_Reference_To (Curr_Id, Loc), diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index 87493d2..bafd224 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.adb @@ -2485,8 +2485,8 @@ package body GNAT.Sockets is Aliases_Count, Addresses_Count : Natural; - -- H_Length is not used because it is currently only set to 4 - -- H_Addrtype is always AF_INET + -- H_Length is not used because it is currently only ever set to 4, as + -- H_Addrtype is always AF_INET. begin Aliases_Count := 0; @@ -2514,10 +2514,24 @@ package body GNAT.Sockets is for J in Result.Addresses'Range loop declare Addr : In_Addr; - for Addr'Address use - Hostent_H_Addr (E, C.int (J - Result.Addresses'First)); - pragma Import (Ada, Addr); + + -- Hostent_H_Addr (E, ) may return an address that is + -- not correctly aligned for In_Addr, so we need to use + -- an intermediate copy operation on a type with an alignemnt + -- of 1 to recover the value. + + subtype Addr_Buf_T is C.char_array (1 .. Addr'Size / 8); + Unaligned_Addr : Addr_Buf_T; + for Unaligned_Addr'Address + use Hostent_H_Addr (E, C.int (J - Result.Addresses'First)); + pragma Import (Ada, Unaligned_Addr); + + Aligned_Addr : Addr_Buf_T; + for Aligned_Addr'Address use Addr'Address; + pragma Import (Ada, Aligned_Addr); + begin + Aligned_Addr := Unaligned_Addr; To_Inet_Addr (Addr, Result.Addresses (J)); end; end loop; diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 7a8b855..edad793 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -180,6 +180,7 @@ Implementation Defined Pragmas * Pragma Linker_Section:: * Pragma Long_Float:: * Pragma Loop_Optimize:: +* Pragma Loop_Variant:: * Pragma Machine_Attribute:: * Pragma Main:: * Pragma Main_Storage:: @@ -937,6 +938,7 @@ consideration, the use of these pragmas should be minimized. * Pragma Linker_Section:: * Pragma Long_Float:: * Pragma Loop_Optimize:: +* Pragma Loop_Variant:: * Pragma Machine_Attribute:: * Pragma Main:: * Pragma Main_Storage:: @@ -4040,6 +4042,45 @@ compiler in order to enable the relevant optimizations, that is to say @option{-funroll-loops} for unrolling and @option{-ftree-vectorize} for vectorization. +@node Pragma Loop_Variant +@unnumberedsec Pragma Loop_Variant +@findex Loop_Variant +@noindent +Syntax: + +@smallexample @c ada +pragma Loop_Variant ( LOOP_VARIANT_ITEM @{, LOOP_VARIANT_ITEM @} ); +LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION +CHANGE_DIRECTION ::= Increases | Decreases +@end smallexample + +@noindent +This pragma must appear immediately within the sequence of statements of a +loop statement. It allows the specification of quantities which must always +decrease or increase in successive iterations of the loop. In its simplest +form, just one expression is specified, whose value must increase or decrease +on each iteration of the loop. + +In a more complex form, multiple arguments can be given which are intepreted +in a nesting lexicographic manner. For example: + +@smallexample @c ada +pragma Loop_Variant (Increases => X, Decreases => Y); +@end smallexample + +@noindent +specifies that each time through the loop either X increases, or X stays +the same and Y decreases. A @code{Loop_Variant} pragma ensures that the +loop is making progress. It can be useful in helping to show informally +or prove formally that the loop always terminates. + +@code{Loop_Variant} is an assertion whose effect can be controlled using +an @code{Assertion_Policy} with a check name of @code{Loop_Variant}. The +policy can be @code{Check} to enable the loop variant check, @code{Ignore} +to ignore the check (in which case the pragma has no effect on the program), +or @code{Disable} in which case the pragma is not even checked for correct +syntax. + @node Pragma Machine_Attribute @unnumberedsec Pragma Machine_Attribute @findex Machine_Attribute diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb index 37dd5e4..9f13f32 100644 --- a/gcc/ada/repinfo.adb +++ b/gcc/ada/repinfo.adb @@ -114,7 +114,8 @@ package body Repinfo is Table_Name => "FE_Rep_Table"); Unit_Casing : Casing_Type; - -- Identifier casing for current unit + -- Identifier casing for current unit. This is set by List_Rep_Info for + -- each unit, before calling subprograms which may read it. Need_Blank_Line : Boolean; -- Set True if a blank line is needed before outputting any information for @@ -988,11 +989,11 @@ package body Repinfo is then for U in Main_Unit .. Last_Unit loop if In_Extended_Main_Source_Unit (Cunit_Entity (U)) then + Unit_Casing := Identifier_Casing (Source_Index (U)); -- Normal case, list to standard output if not List_Representation_Info_To_File then - Unit_Casing := Identifier_Casing (Source_Index (U)); Write_Eol; Write_Str ("Representation information for unit "); Write_Unit_Name (Unit_Name (U)); diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index e5a5b05..fc1ace2 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -3891,19 +3891,7 @@ package body Sem_Attr is Error_Attr_P ("prefix of attribute % must denote an entity"); end if; - Set_Etype (N, Etype (P)); - - -- Associate the attribute with its related loop - - if No (Loop_Entry_Attributes (Loop_Id)) then - Set_Loop_Entry_Attributes (Loop_Id, New_Elmt_List); - end if; - - -- A Loop_Entry may be [pre]analyzed several times, depending on the - -- context. Ensure that it appears only once in the attributes list - -- of the related loop. - - Append_Unique_Elmt (N, Loop_Entry_Attributes (Loop_Id)); + Set_Etype (N, P_Type); end Loop_Entry; ------------- diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index fbeffd8..c2023cd 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -2545,6 +2545,7 @@ package body Sem_Ch5 is Iter : constant Node_Id := Iteration_Scheme (N); Loc : constant Source_Ptr := Sloc (N); Ent : Entity_Id; + Stmt : Node_Id; -- Start of processing for Analyze_Loop_Statement @@ -2707,13 +2708,22 @@ package body Sem_Ch5 is Analyze_Statements (Statements (N)); end if; + -- When the iteration scheme of a loop contains attribute 'Loop_Entry, + -- the loop is transformed into a conditional block. Retrieve the loop. + + Stmt := N; + + if Subject_To_Loop_Entry_Attributes (Stmt) then + Stmt := Find_Loop_In_Conditional_Block (Stmt); + end if; + -- Finish up processing for the loop. We kill all current values, since -- in general we don't know if the statements in the loop have been -- executed. We could do a bit better than this with a loop that we -- know will execute at least once, but it's not worth the trouble and -- the front end is not in the business of flow tracing. - Process_End_Label (N, 'e', Ent); + Process_End_Label (Stmt, 'e', Ent); End_Scope; Kill_Current_Values; @@ -2724,15 +2734,15 @@ package body Sem_Ch5 is -- before making this call, since Check_Infinite_Loop_Warning relies on -- being able to use semantic visibility information to find references. - if Comes_From_Source (N) then - Check_Infinite_Loop_Warning (N); + if Comes_From_Source (Stmt) then + Check_Infinite_Loop_Warning (Stmt); end if; -- Code after loop is unreachable if the loop has no WHILE or FOR and -- contains no EXIT statements within the body of the loop. if No (Iter) and then not Has_Exit (Ent) then - Check_Unreachable_Code (N); + Check_Unreachable_Code (Stmt); end if; end Analyze_Loop_Statement; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index f6ee332..c421b5a 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -13962,7 +13962,6 @@ package body Sem_Prag is begin GNAT_Pragma; - S14_Pragma; Check_At_Least_N_Arguments (1); Check_Loop_Pragma_Placement; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index aca6ac2..5cf86f9 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -4740,6 +4740,41 @@ package body Sem_Util is raise Program_Error; end Find_Corresponding_Discriminant; + ------------------------------------ + -- Find_Loop_In_Conditional_Block -- + ------------------------------------ + + function Find_Loop_In_Conditional_Block (N : Node_Id) return Node_Id is + Stmt : Node_Id; + + begin + Stmt := N; + + if Nkind (Stmt) = N_If_Statement then + Stmt := First (Then_Statements (Stmt)); + end if; + + pragma Assert (Nkind (Stmt) = N_Block_Statement); + + -- Inspect the statements of the conditional block. In general the loop + -- should be the first statement in the statement sequence of the block, + -- but the finalization machinery may have introduced extra object + -- declarations. + + Stmt := First (Statements (Handled_Statement_Sequence (Stmt))); + while Present (Stmt) loop + if Nkind (Stmt) = N_Loop_Statement then + return Stmt; + end if; + + Next (Stmt); + end loop; + + -- The expansion of attribute 'Loop_Entry produced a malformed block + + raise Program_Error; + end Find_Loop_In_Conditional_Block; + -------------------------- -- Find_Overlaid_Entity -- -------------------------- @@ -13870,6 +13905,33 @@ package body Sem_Util is and then not Is_Formal (Entity (R2)); end Statically_Different; + -------------------------------------- + -- Subject_To_Loop_Entry_Attributes -- + -------------------------------------- + + function Subject_To_Loop_Entry_Attributes (N : Node_Id) return Boolean is + Stmt : Node_Id; + + begin + Stmt := N; + + -- The expansion mechanism transform a loop subject to at least one + -- 'Loop_Entry attribute into a conditional block. Infinite loops lack + -- the conditional part. + + if Nkind_In (Stmt, N_Block_Statement, N_If_Statement) + and then Nkind (Original_Node (N)) = N_Loop_Statement + then + Stmt := Original_Node (N); + end if; + + return + Nkind (Stmt) = N_Loop_Statement + and then Present (Identifier (Stmt)) + and then Present (Entity (Identifier (Stmt))) + and then Has_Loop_Entry_Attributes (Entity (Identifier (Stmt))); + end Subject_To_Loop_Entry_Attributes; + ----------------------------- -- Subprogram_Access_Level -- ----------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 66c31c9..6fe1abe 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -474,6 +474,11 @@ package Sem_Util is -- analyzed. Subsequent uses of this id on a different type denotes the -- discriminant at the same position in this new type. + function Find_Loop_In_Conditional_Block (N : Node_Id) return Node_Id; + -- Find the nested loop statement in a conditional block. Loops subject to + -- attribute 'Loop_Entry are transformed into blocks. Parts of the original + -- loop are nested within the block. + procedure Find_Overlaid_Entity (N : Node_Id; Ent : out Entity_Id; @@ -1524,6 +1529,10 @@ package Sem_Util is -- Return True if it can be statically determined that the Expressions -- E1 and E2 refer to different objects + function Subject_To_Loop_Entry_Attributes (N : Node_Id) return Boolean; + -- Determine whether node N is a loop statement subject to at least one + -- 'Loop_Entry attribute. + function Subprogram_Access_Level (Subp : Entity_Id) return Uint; -- Return the accessibility level of the view denoted by Subp -- cgit v1.1