2004-07-15 Robert Dewar <dewar@gnat.com>

	* makegpr.adb, s-secsta.ads, sem_ch3.adb, sem_case.adb: Minor
	reformatting

	* gnat_ugn.texi: Add instantiation of direct_io or sequential_io with
	access values as an example of a warning.

	* gnat_rm.texi: Document new attribute Has_Access_Values

	* gnat-style.texi: Document that box comments belong on nested
	subprograms

	* sem_util.ads (Has_Access_Values): Improved documentation

	* s-finimp.ads, s-finimp.adb: Fix spelling error in comment

	* sem_prag.adb (Check_Duplicated_Export_Name): New procedure
	(Process_Interface_Name): Call to this new procedure
	(Set_Extended_Import_Export_External_Name): Call to this new procedure

	* s-mastop-x86.adb, 9drpc.adb: Fix spelling error in comment

	* a-direio.ads, a-sequio.ads: Warn if Element_Type has access values

	* einfo.ads: Minor comment typo fixed

2004-07-15  Jose Ruiz  <ruiz@act-europe.fr>

	* snames.adb: Add _atcb.

	* snames.ads: Add Name_uATCB.

	* s-tarest.adb (Create_Restricted_Task): ATCBs are always preallocated
	(in the expanded code) when using the restricted run time.

	* s-tarest.ads (Create_Restricted_Task): Created_Task transformed into
	a in parameter in order to allow ATCBs to be preallocated (in the
	expanded code).

	* s-taskin.adb (Initialize_ATCB): T converted into a in parameter in
	order to allow ATCBs to be preallocated. In case of error, the ATCB is
	deallocated in System.Tasking.Stages.

	* s-taskin.ads (Initialize_ATCB): T converted into a in parameter in
	order to allow ATCBs to be preallocated.

	* s-tassta.adb (Create_Task): In case of error the ATCB is deallocated
	here. It was previously done in Initialize_ATCB.

	* rtsfind.ads: Make the Ada_Task_Control_Block visible.

	* exp_ch9.adb: Preallocate the Ada_Task_Control_Block when using the
	Restricted run time.

	* exp_ch3.adb: When using the Restricted run time, pass the
	preallocated Ada_Task_Control_Block when creating a task.

2004-07-15  Ed Schonberg  <schonberg@gnat.com>

	* sem_util.adb (Normalize_Actuals): If there are no actuals on a
	function call that is itself an actual in an enclosing call, diagnose
	problem here rather than assuming that resolution will catch it.

	* sem_ch7.adb (Analyze_Package_Specification): If the specification is
	the local copy of a generic unit for a formal package, and the generic
	is a child unit, install private part of ancestors before compiling
	private part of spec.

	* sem_cat.adb (Validate_Categorization_Dependency): Simplify code to
	use scope entities rather than tree structures, to handle properly
	parent units that are instances rewritten as bodies for inlining
	purposes.

	* sem_ch10.adb (Get_Parent_Entity, Implicit_With_On_Parent,
	Remove_Parents): Handle properly a parent unit that is an
	instantiation, when the unit has been rewritten as a body for inlining
	purposes.

	* par.adb (Goto_List): Global variable to collect goto statements in a
	given unit, for use in detecting natural loops.

	* par-ch5.adb (P_Goto_Statement): Add goto to global Goto_List, for
	use in detecting natural loops.

	* par-labl.adb (Find_Natural_Loops): Recognize loops create by
	backwards goto's, and rewrite as a infinite loop, to improve locality
	of temporaries.

	* exp_util.adb (Force_Evaluation): Recognize a left-hand side
	subcomponent that includes an indexed reference, to prevent the
	generation of copies that would miscompile the desired assignment
	statement.
	(Build_Task_Image_Decls): Add a numeric suffix to
	generated name for string variable, to avoid spurious conflicts with
	the name of the type of a single protected object.

	* exp_ch4.adb (Expand_Array_Equality): If indices are distinct, use a
	loop with an explicit exit statement, to avoid generating an
	out-of-range value with 'Succ leading to spurious constraint_errors
	when compiling with -gnatVo.

2004-07-15  Thomas Quinot  <quinot@act-europe.fr>

	* sem_ch4.adb (Analyze_Slice): Always call Analyze on the prefix: it
	might not be analyzed yet, even if its Etype is already set (case of an
	unchecked conversion built using Unchecked_Convert_To, for example).
	If the prefix has already been analyzed, this will be a nop anyway.

	* exp_ch5.adb (Make_Tag_Ctrl_Assignment): For an assignment of a
	controller type, or an assignment of a record type with controlled
	components, copy only user data, and leave the finalization chain
	pointers untouched.

2004-07-15  Vincent Celier  <celier@gnat.com>

	* make.adb (Collect_Arguments): Improve error message when attempting
	to compile a source not part of any project, when -x is not used.

	* prj.ads: (Defined_Variable_Kind): New subtype

	* prj-attr.adb (Register_New_Package): Two new procedures to register
	a package with or without its attributes.
	(Register_New_Attribute): Mew procedure to register a new attribute in a
	package.
	New attribute oriented subprograms: Attribute_Node_Id_Of,
	Attribute_Kind_Of, Set_Attribute_Kind_Of, Attribute_Name_Of,
	Variable_Kind_Of, Set_Variable_Kind_Of, Optional_Index_Of,
	Next_Attribute.
	New package oriented subprograms: Package_Node_Id_Of,
	Add_Unknown_Package, First_Attribute_Of, Add_Attribute.

	* prj-attr.ads (Attribute_Node_Id): Now a private, self initialized
	type.
	(Package_Node_Id): Now a private, self initialized type
	(Register_New_Package): New procedure to register a package with its
	attributes.
	New attribute oriented subprograms: Attribute_Node_Id_Of,
	Attribute_Kind_Of, Set_Attribute_Kind_Of, Attribute_Name_Of,
	Variable_Kind_Of, Set_Variable_Kind_Of, Optional_Index_Of,
	Next_Attribute.
	New package oriented subprograms: Package_Node_Id_Of,
	Add_Unknown_Package, First_Attribute_Of, Add_Attribute.

	* prj-dect.adb (Parse_Attribute_Declaration,
	Parse_Package_Declaration): Adapt to new spec of Prj.Attr.

	* prj-makr.adb (Make): Parse existing project file before creating
	other files. Fail if there was an error during parsing.

	* prj-proc.adb (Add_Attributes, Process_Declarative_Items): Adapt to
	new spec of Prj.Attr.

	* prj-strt.adb (Attribute_Reference, Parse_Variable_Reference): Adapt
	to new spec of Prj.Attr.

2004-07-15  Richard Kenner  <kenner@vlsi1.ultra.nyu.edu>

	* utils2.c: Fix typo in comment.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@84774 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 331 insertions, 1 deletions

diff --git a/gcc/ada/par-labl.adb b/gcc/ada/par-labl.adb
index 835be36e337..2fd70e5c09c 100644
--- a/gcc/ada/par-labl.adb
+++ b/gcc/ada/par-labl.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2003, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2004, 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- --
@@ -51,6 +51,11 @@ procedure Labl is
    --  Checks the rule in RM-5.1(11), which requires distinct identifiers
    --  for all the labels in a given body.
 
+   procedure Find_Natural_Loops;
+   --  Recognizes loops created by backward gotos, and rewrites the
+   --  corresponding statements into a proper loop, for optimization
+   --  purposes (for example, to control reclaiming local storage).
+
    ---------------------------
    -- Check_Distinct_Labels --
    ---------------------------
@@ -145,6 +150,329 @@ procedure Labl is
       return Result;
    end Find_Enclosing_Body_Or_Block;
 
+   ------------------------
+   -- Find_Natural_Loops --
+   ------------------------
+
+   procedure Find_Natural_Loops is
+      Node_List : constant Elist_Id := New_Elmt_List;
+      N         : Elmt_Id;
+      Succ      : Elmt_Id;
+
+      function Goto_Id (Goto_Node : Node_Id) return Name_Id;
+      --  Find Name_Id of goto statement, which may be an expanded name.
+
+      function Matches
+        (Label_Node : Node_Id;
+         Goto_Node  : Node_Id) return Boolean;
+      --  A label and a goto are candidates for a loop if the names match,
+      --  and both nodes appear in the same body. In addition, both must
+      --  appear in the same statement list. If they are not in the same
+      --  statement list, the goto is from within an nested structure, and
+      --  the label is not a header. We ignore the case where the goto is
+      --  within a conditional structure, and capture only infinite loops.
+
+      procedure Merge;
+      --  Merge labels and goto statements in order of increasing sloc value.
+      --  Discard labels of loop and block statements.
+
+      procedure No_Header (N : Elmt_Id);
+      --  The label N is known not to be a loop header. Scan forward and
+      --  remove all subsequent goto's that may have this node as a target.
+
+      procedure Process_Goto (N : Elmt_Id);
+      --  N is a forward jump. Scan forward and remove all subsequent goto's
+      --  that may have the same target, to preclude spurious loops.
+
+      procedure Rewrite_As_Loop
+        (Loop_Header : Node_Id;
+         Loop_End    : Node_Id);
+      --  Given a label and a backwards goto, rewrite intervening statements
+      --  as a loop. Remove the label from the node list, and rewrite the
+      --  goto with the body of the new loop.
+
+      procedure Try_Loop (N : Elmt_Id);
+      --  N is a label that may be a loop header. Scan forward to find some
+      --  backwards goto with which to make a loop. Do nothing if there is
+      --  an intervening label that is not part of a loop, or more than one
+      --  goto with this target.
+
+      -------------
+      -- Goto_Id --
+      -------------
+
+      function Goto_Id (Goto_Node : Node_Id) return Name_Id is
+      begin
+         if Nkind (Name (Goto_Node)) = N_Identifier then
+            return Chars (Name (Goto_Node));
+
+         elsif Nkind (Name (Goto_Node)) = N_Selected_Component then
+            return Chars (Selector_Name (Name (Goto_Node)));
+         else
+
+            --  In case of error, return Id that can't match anything
+
+            return Name_Null;
+         end if;
+      end Goto_Id;
+
+      -------------
+      -- Matches --
+      -------------
+
+      function Matches
+        (Label_Node : Node_Id;
+         Goto_Node  :  Node_Id) return Boolean
+      is
+      begin
+         return Chars (Identifier (Label_Node)) = Goto_Id (Goto_Node)
+           and then Find_Enclosing_Body (Label_Node) =
+                    Find_Enclosing_Body (Goto_Node);
+      end Matches;
+
+      -----------
+      -- Merge --
+      -----------
+
+      procedure Merge is
+         L1 : Elmt_Id;
+         G1 : Elmt_Id;
+
+      begin
+         L1 := First_Elmt (Label_List);
+         G1 := First_Elmt (Goto_List);
+
+         while Present (L1)
+           and then Present (G1)
+         loop
+            if Sloc (Node (L1)) < Sloc (Node (G1)) then
+
+               --  Optimization: remove labels of loops and blocks, which
+               --  play no role in what follows.
+
+               if Nkind (Node (L1)) /= N_Loop_Statement
+                 and then Nkind (Node (L1)) /= N_Block_Statement
+               then
+                  Append_Elmt (Node (L1), Node_List);
+               end if;
+
+               Next_Elmt (L1);
+
+            else
+               Append_Elmt (Node (G1), Node_List);
+               Next_Elmt (G1);
+            end if;
+         end loop;
+
+         while Present (L1) loop
+            Append_Elmt (Node (L1), Node_List);
+            Next_Elmt (L1);
+         end loop;
+
+         while Present (G1) loop
+            Append_Elmt (Node (G1), Node_List);
+            Next_Elmt (G1);
+         end loop;
+      end Merge;
+
+      ---------------
+      -- No_Header --
+      ---------------
+
+      procedure No_Header (N : Elmt_Id) is
+         S1, S2 : Elmt_Id;
+
+      begin
+         S1 := Next_Elmt (N);
+         while Present (S1) loop
+            S2 := Next_Elmt (S1);
+            if Nkind (Node (S1)) = N_Goto_Statement
+              and then Matches (Node (N), Node (S1))
+            then
+               Remove_Elmt (Node_List, S1);
+            end if;
+
+            S1 := S2;
+         end loop;
+      end No_Header;
+
+      ------------------
+      -- Process_Goto --
+      ------------------
+
+      procedure Process_Goto (N : Elmt_Id) is
+         Goto1 : constant Node_Id := Node (N);
+         Goto2 : Node_Id;
+         S, S1 : Elmt_Id;
+
+      begin
+         S := Next_Elmt (N);
+
+         while Present (S) loop
+            S1 := Next_Elmt (S);
+            Goto2 := Node (S);
+
+            if Nkind (Goto2) = N_Goto_Statement
+              and then Goto_Id (Goto1) = Goto_Id (Goto2)
+              and then Find_Enclosing_Body (Goto1) =
+                       Find_Enclosing_Body (Goto2)
+            then
+
+               --  Goto2 may have the same target, remove it from
+               --  consideration.
+
+               Remove_Elmt (Node_List, S);
+            end if;
+
+            S := S1;
+         end loop;
+      end Process_Goto;
+
+      ---------------------
+      -- Rewrite_As_Loop --
+      ---------------------
+
+      procedure Rewrite_As_Loop
+        (Loop_Header : Node_Id;
+         Loop_End    : Node_Id)
+      is
+         Loop_Body : constant List_Id := New_List;
+         Loop_Stmt : constant Node_Id :=
+                       New_Node (N_Loop_Statement, Sloc (Loop_Header));
+         Stat      : Node_Id;
+         Next_Stat : Node_Id;
+      begin
+         Stat := Next (Loop_Header);
+         while Stat /= Loop_End loop
+            Next_Stat := Next (Stat);
+            Remove (Stat);
+            Append (Stat, Loop_Body);
+            Stat := Next_Stat;
+         end loop;
+
+         Set_Statements (Loop_Stmt, Loop_Body);
+         Set_Identifier (Loop_Stmt, Identifier (Loop_Header));
+
+         Remove (Loop_Header);
+         Rewrite (Loop_End, Loop_Stmt);
+         Error_Msg_N
+           ("code between label and backwards goto rewritten as loop?",
+             Loop_End);
+      end Rewrite_As_Loop;
+
+      --------------
+      -- Try_Loop --
+      --------------
+
+      procedure Try_Loop (N : Elmt_Id) is
+         Source : Elmt_Id;
+         Found  : Boolean := False;
+         S1     : Elmt_Id;
+
+      begin
+         S1 := Next_Elmt (N);
+         while Present (S1) loop
+            if Nkind (Node (S1)) = N_Goto_Statement
+              and then Matches (Node (N), Node (S1))
+            then
+               if not Found then
+                  if Parent (Node (N)) = Parent (Node (S1)) then
+                     Source := S1;
+                     Found  := True;
+
+                  else
+                     --  The goto is within some nested structure
+
+                     No_Header (N);
+                     return;
+                  end if;
+
+               else
+                  --  More than one goto with the same target
+
+                  No_Header (N);
+                  return;
+               end if;
+
+            elsif Nkind (Node (S1)) = N_Label
+              and then not Found
+            then
+               --  Intervening label before possible end of loop. Current
+               --  label is not a candidate. This is conservative, because
+               --  the label might not be the target of any jumps, but not
+               --  worth dealing with useless labels!
+
+               No_Header (N);
+               return;
+
+            else
+               --  If the node is a loop_statement, it corresponds to a
+               --  label-goto pair rewritten as a loop. Continue forward scan.
+
+               null;
+            end if;
+
+            Next_Elmt (S1);
+         end loop;
+
+         if Found then
+            Rewrite_As_Loop (Node (N), Node (Source));
+            Remove_Elmt (Node_List, N);
+            Remove_Elmt (Node_List, Source);
+         end if;
+      end Try_Loop;
+
+   begin
+      --  Start of processing for Find_Natural_Loops
+
+      Merge;
+
+      N := First_Elmt (Node_List);
+      while Present (N) loop
+         Succ := Next_Elmt (N);
+
+         if Nkind (Node (N)) = N_Label then
+            if No (Succ) then
+               exit;
+
+            elsif Nkind (Node (Succ)) = N_Label then
+               Try_Loop (Succ);
+
+               --  If a loop was found, the label has been removed, and
+               --  the following goto rewritten as the loop body.
+
+               Succ := Next_Elmt (N);
+
+               if Nkind (Node (Succ)) = N_Label then
+
+                  --  Following label was not removed, so current label
+                  --  is not a candidate header.
+
+                  No_Header (N);
+
+               else
+
+                  --  Following label was part of inner loop. Current
+                  --  label is still a candidate.
+
+                  Try_Loop (N);
+                  Succ := Next_Elmt (N);
+               end if;
+
+            elsif Nkind (Node (Succ)) = N_Goto_Statement then
+               Try_Loop (N);
+               Succ := Next_Elmt (N);
+            end if;
+
+         elsif Nkind (Node (N)) = N_Goto_Statement then
+            Process_Goto (N);
+            Succ := Next_Elmt (N);
+         end if;
+
+         N := Succ;
+      end loop;
+   end Find_Natural_Loops;
+
 --  Start of processing for Par.Labl
 
 begin
@@ -204,4 +532,6 @@ begin
          Next_Elmt (Next_Label_Elmt);
    end loop;
 
+   Find_Natural_Loops;
+
 end Labl;