* gnat_rm.texi: Fix minor typos. Found while reading the section

	regarding "Bit_Order Clauses" that was sent to a customer.
	Very interesting documentation!

	* sem_case.adb (Choice_Image): Avoid creating improper character
	literal names by using the routine Set_Character_Literal_Name. This
	fixes bombs in certain error message cases.

	* a-reatim.adb: Minor reformatting.

	* sem_ch12.adb (Validate_Derived_Type_Instance): Handle properly the
	case where the formal is an extension of another formal in the current
	unit or in a parent generic unit.

	* s-tposen.adb: Update comments.  Minor reformatting.
	Minor code clean up.

	* s-tarest.adb: Update comments.  Minor code reorganization.

	* exp_attr.adb (Attribute_Tag): Suppress expansion of <type_name>'Tag
	when Java_VM.

	* exp_attr.adb: Minor reformatting

	* sem_ch3.adb (Build_Derived_Private_Type): Refine check to handle
	derivations nested within a child unit: verify that the parent
	type is declared in an outer scope.

	* sem_ch12.adb: Minor reformatting

	* sem_warn.adb (Check_One_Unit): In No_Run_Time mode, do not post
	warning if current unit is a predefined one, from which bodies may
	have been deleted.

	* eval_fat.ads: Add comment that Round_Even is referenced in Ada code
	Fix header format. Add 2001 to copyright date.

	* exp_dbug.adb (Get_Encoded_Name): Fix out of bounds reference,
	which caused CE during compilation if checks were enabled.


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

12 files changed, 152 insertions, 69 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 69ad3d71611..78e89807b23 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,65 @@
+2001-12-17  Joel Brobecker <brobecke@gnat.com>
+
+	* gnat_rm.texi: Fix minor typos. Found while reading the section 
+	regarding "Bit_Order Clauses" that was sent to a customer.
+	Very interesting documentation!
+	
+2001-12-17  Robert Dewar <dewar@gnat.com>
+
+	* sem_case.adb (Choice_Image): Avoid creating improper character 
+	literal names by using the routine Set_Character_Literal_Name. This 
+	fixes bombs in certain error message cases.
+	
+2001-12-17  Arnaud Charlet <charlet@gnat.com>
+
+	* a-reatim.adb: Minor reformatting.
+	
+2001-12-17  Ed Schonberg <schonber@gnat.com>
+
+	* sem_ch12.adb (Validate_Derived_Type_Instance): Handle properly the 
+	case where the formal is an extension of another formal in the current 
+	unit or in a parent generic unit.
+	
+2001-12-17  Arnaud Charlet <charlet@gnat.com>
+
+	* s-tposen.adb: Update comments.  Minor reformatting. 
+	Minor code clean up.
+	
+	* s-tarest.adb: Update comments.  Minor code reorganization.
+	
+2001-12-17  Gary Dismukes <dismukes@gnat.com>
+
+	* exp_attr.adb (Attribute_Tag): Suppress expansion of <type_name>'Tag 
+	when Java_VM.
+	
+2001-12-17  Robert Dewar <dewar@gnat.com>
+
+	* exp_attr.adb: Minor reformatting
+	
+2001-12-17  Ed Schonberg <schonber@gnat.com>
+
+	* sem_ch3.adb (Build_Derived_Private_Type): Refine check to handle 
+	derivations nested within a child unit: verify that the parent
+	type is declared in an outer scope.
+	
+2001-12-17  Robert Dewar <dewar@gnat.com>
+
+	* sem_ch12.adb: Minor reformatting
+	
+2001-12-17  Ed Schonberg <schonber@gnat.com>
+
+	* sem_warn.adb (Check_One_Unit): In No_Run_Time mode, do not post 
+	warning if current unit is a predefined one, from which bodies may 
+	have been deleted.
+	
+2001-12-17  Robert Dewar <dewar@gnat.com>
+
+	* eval_fat.ads: Add comment that Round_Even is referenced in Ada code
+	Fix header format. Add 2001 to copyright date.
+	
+	* exp_dbug.adb (Get_Encoded_Name): Fix out of bounds reference, 
+	which caused CE during compilation if checks were enabled.
+
 2001-12-17  Vincent Celier <celier@gnat.com>
 
 	* make.adb:
diff --git a/gcc/ada/a-reatim.adb b/gcc/ada/a-reatim.adb
index 4ed7ce7791b..1d9048951c3 100644
--- a/gcc/ada/a-reatim.adb
+++ b/gcc/ada/a-reatim.adb
@@ -174,8 +174,7 @@ package body Ada.Real_Time is
       --  Extract the integer part of T, truncating towards zero.
 
       if T_Val < 0.5 then
-            SC := 0;
-
+         SC := 0;
       else
          SC := Seconds_Count (Time_Span' (T_Val - 0.5));
       end if;
diff --git a/gcc/ada/eval_fat.ads b/gcc/ada/eval_fat.ads
index b3e398ab208..889308a0126 100644
--- a/gcc/ada/eval_fat.ads
+++ b/gcc/ada/eval_fat.ads
@@ -6,9 +6,9 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---                            $Revision: 1.4 $                              --
+--                            $Revision$
 --                                                                          --
---          Copyright (C) 1992-2000 Free Software Foundation, Inc.          --
+--          Copyright (C) 1992-2001 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- --
@@ -49,7 +49,9 @@ package Eval_Fat is
    --  The compile time representation of the floating-point root type
 
    type Rounding_Mode is (Floor, Ceiling, Round, Round_Even);
+   for Rounding_Mode use (0, 1, 2, 3);
    --  Used to indicate rounding mode for Machine attribute
+   --  Note that C code in gigi knows that Round_Even is 3
 
    Rounding_Was_Biased : Boolean;
    --  Set if last use of Machine rounded a halfway case away from zero
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 2fada3e36a5..90aec3afe8d 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---                            $Revision: 1.304 $
+--                            $Revision$
 --                                                                          --
 --          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
 --                                                                          --
@@ -3083,9 +3083,16 @@ package body Exp_Attr is
          Ttyp := Underlying_Type (Ttyp);
 
          if Prefix_Is_Type then
-            Rewrite (N,
-              Unchecked_Convert_To (RTE (RE_Tag),
-                New_Reference_To (Access_Disp_Table (Ttyp), Loc)));
+
+            --  For JGNAT we leave the type attribute unexpanded because
+            --  there's not a dispatching table to reference.
+
+            if not Java_VM then
+               Rewrite (N,
+                 Unchecked_Convert_To (RTE (RE_Tag),
+                   New_Reference_To (Access_Disp_Table (Ttyp), Loc)));
+               Analyze_And_Resolve (N, RTE (RE_Tag));
+            end if;
 
          else
             Rewrite (N,
@@ -3093,9 +3100,8 @@ package body Exp_Attr is
                 Prefix => Relocate_Node (Pref),
                 Selector_Name =>
                   New_Reference_To (Tag_Component (Ttyp), Loc)));
+            Analyze_And_Resolve (N, RTE (RE_Tag));
          end if;
-
-         Analyze_And_Resolve (N, RTE (RE_Tag));
       end Tag;
 
       ----------------
diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb
index 871b0c56c64..c5f362b83c1 100644
--- a/gcc/ada/exp_dbug.adb
+++ b/gcc/ada/exp_dbug.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---                            $Revision: 1.56 $
+--                            $Revision$
 --                                                                          --
 --          Copyright (C) 1996-2001 Free Software Foundation, Inc.          --
 --                                                                          --
@@ -705,9 +705,13 @@ package body Exp_Dbug is
 
       --  Or if this is a dummy type for a renaming
 
-        or else Name_Buffer (Name_Len - 2 .. Name_Len) = "_XR"
-        or else Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRE"
-        or else Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRP"
+        or else (Name_Len >= 3 and then
+                   Name_Buffer (Name_Len - 2 .. Name_Len) = "_XR")
+
+        or else (Name_Len >= 4 and then
+                   (Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRE"
+                      or else
+                    Name_Buffer (Name_Len - 3 .. Name_Len) = "_XRP"))
 
       --  For all these cases, just return the name unchanged
 
diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
index 5aedc4d5537..4c2f116318f 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -9,7 +9,7 @@
 @c                                                                            o
 @c                              G N A T _ RM                                  o
 @c                                                                            o
-@c                            $Revision: 1.1 $
+@c                            $Revision$
 @c                                                                            o
 @c          Copyright (C) 1992-2001 Ada Core Technologies, Inc.               o
 @c                                                                            o
@@ -39,8 +39,8 @@
 @title GNAT Reference Manual
 @subtitle GNAT, The GNU Ada 95 Compiler
 @subtitle Version 3.15w
-@subtitle Document revision level $Revision: 1.1 $
-@subtitle Date: $Date: 2001/10/26 13:55:51 $
+@subtitle Document revision level $Revision$
+@subtitle Date: $Date$
 @author Ada Core Technologies, Inc.
 
 @page
@@ -84,7 +84,7 @@ GNAT, The GNU Ada 95 Compiler
 
 Version 3.14a
 
-Date: $Date: 2001/10/26 13:55:51 $
+Date: $Date$
 
 Ada Core Technologies, Inc.
 
@@ -7830,7 +7830,7 @@ will be flagged as illegal by GNAT@.
 Since the misconception that Bit_Order automatically deals with all
 endian-related incompatibilities is a common one, the specification of
 a component field that is an integral number of bytes will always
-generate a warning This warning may be suppressed using
+generate a warning. This warning may be suppressed using
 @code{pragma Suppress} if desired. The following section contains additional
 details regarding the issue of byte ordering.
 
@@ -7840,7 +7840,7 @@ details regarding the issue of byte ordering.
 @cindex ordering, of bytes
 
 @noindent
-In this section we will review the effec of the @code{Bit_Order} attribute
+In this section we will review the effect of the @code{Bit_Order} attribute
 definition clause on byte ordering. Briefly, it has no effect at all, but
 a detailed example will be helpful. Before giving this
 example, let us review the precise
diff --git a/gcc/ada/s-tarest.adb b/gcc/ada/s-tarest.adb
index a6cf274c8ef..83d184e3fa4 100644
--- a/gcc/ada/s-tarest.adb
+++ b/gcc/ada/s-tarest.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                  B o d y                                 --
 --                                                                          --
---                             $Revision: 1.13 $
+--                             $Revision$
 --                                                                          --
 --              Copyright (C) 1999-2001 Ada Core Technologies               --
 --                                                                          --
@@ -253,9 +253,9 @@ package body System.Tasking.Restricted.Stages is
          Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg);
          Terminate_Task (Self_ID);
 
-      exception                         --  not needed in no exc mode
-         when others =>                 --  not needed in no exc mode
-            Terminate_Task (Self_ID);   --  not needed in no exc mode
+      exception
+         when others =>
+            Terminate_Task (Self_ID);
       end;
    end Task_Wrapper;
 
@@ -285,10 +285,10 @@ package body System.Tasking.Restricted.Stages is
    procedure Activate_Restricted_Tasks
      (Chain_Access : Activation_Chain_Access)
    is
-      Self_ID        : constant Task_ID := STPO.Self;
-      C              : Task_ID;
-      Activate_Prio  : System.Any_Priority;
-      Success        : Boolean;
+      Self_ID       : constant Task_ID := STPO.Self;
+      C             : Task_ID;
+      Activate_Prio : System.Any_Priority;
+      Success       : Boolean;
 
    begin
       pragma Assert (Self_ID = Environment_Task);
@@ -525,22 +525,25 @@ package body System.Tasking.Restricted.Stages is
 
       SSL.Lock_Task              := Task_Lock'Access;
       SSL.Unlock_Task            := Task_Unlock'Access;
+
       SSL.Get_Jmpbuf_Address     := Get_Jmpbuf_Address'Access;
       SSL.Set_Jmpbuf_Address     := Set_Jmpbuf_Address'Access;
-      SSL.Get_Sec_Stack_Addr     := Get_Sec_Stack_Addr'Access;
-      SSL.Set_Sec_Stack_Addr     := Set_Sec_Stack_Addr'Access;
       SSL.Get_Machine_State_Addr := Get_Machine_State_Addr'Access;
       SSL.Set_Machine_State_Addr := Set_Machine_State_Addr'Access;
       SSL.Get_Current_Excep      := Get_Current_Excep'Access;
-      SSL.Timed_Delay            := Timed_Delay_T'Access;
-      SSL.Adafinal               := Finalize_Global_Tasks'Access;
+      SSL.Set_Jmpbuf_Address     (SSL.Get_Jmpbuf_Address_NT);
+      SSL.Set_Machine_State_Addr (SSL.Get_Machine_State_Addr_NT);
+
+      SSL.Get_Sec_Stack_Addr     := Get_Sec_Stack_Addr'Access;
+      SSL.Set_Sec_Stack_Addr     := Set_Sec_Stack_Addr'Access;
 
       --  No need to create a new Secondary Stack, since we will use the
       --  default one created in s-secsta.adb
 
-      SSL.Set_Sec_Stack_Addr     (SSL.Get_Sec_Stack_Addr_NT);
-      SSL.Set_Jmpbuf_Address     (SSL.Get_Jmpbuf_Address_NT);
-      SSL.Set_Machine_State_Addr (SSL.Get_Machine_State_Addr_NT);
+      Set_Sec_Stack_Addr (SSL.Get_Sec_Stack_Addr_NT);
+
+      SSL.Timed_Delay            := Timed_Delay_T'Access;
+      SSL.Adafinal               := Finalize_Global_Tasks'Access;
    end Init_RTS;
 
 begin
diff --git a/gcc/ada/s-tposen.adb b/gcc/ada/s-tposen.adb
index dcecc3163d9..7b2005da9b3 100644
--- a/gcc/ada/s-tposen.adb
+++ b/gcc/ada/s-tposen.adb
@@ -7,7 +7,7 @@
 --                                                                          --
 --                                  B o d y                                 --
 --                                                                          --
---                             $Revision: 1.14 $
+--                             $Revision$
 --                                                                          --
 --              Copyright (C) 1998-2001 Ada Core Technologies               --
 --                                                                          --
@@ -141,6 +141,9 @@ package body System.Tasking.Protected_Objects.Single_Entry is
      (Self_Id    : Task_ID;
       Object     : Protection_Entry_Access;
       Entry_Call : Entry_Call_Link);
+   --  This procedure executes or queues an entry call, depending
+   --  on the status of the corresponding barrier. It assumes that the
+   --  specified object is locked.
 
    ---------------------
    -- Check_Exception --
@@ -150,11 +153,11 @@ package body System.Tasking.Protected_Objects.Single_Entry is
      (Self_ID    : Task_ID;
       Entry_Call : Entry_Call_Link)
    is
-      use type Ada.Exceptions.Exception_Id;
-
       procedure Internal_Raise (X : Ada.Exceptions.Exception_Id);
       pragma Import (C, Internal_Raise, "__gnat_raise_with_msg");
 
+      use type Ada.Exceptions.Exception_Id;
+
       E : constant Ada.Exceptions.Exception_Id :=
         Entry_Call.Exception_To_Raise;
 
@@ -188,8 +191,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is
 
    procedure Wait_For_Completion
      (Self_ID    : Task_ID;
-      Entry_Call : Entry_Call_Link)
-   is
+      Entry_Call : Entry_Call_Link) is
    begin
       pragma Assert (Self_ID = Entry_Call.Self);
       Self_ID.Common.State := Entry_Caller_Sleep;
@@ -416,18 +418,17 @@ package body System.Tasking.Protected_Objects.Single_Entry is
          STPO.Unlock (Entry_Call.Self);
       end if;
 
-   exception                       --  not needed in no exc mode
-      when others =>               --  not needed in no exc mode
-         Send_Program_Error        --  not needed in no exc mode
-           (Self_Id, Entry_Call);  --  not needed in no exc mode
+   exception
+      when others =>
+         Send_Program_Error
+           (Self_Id, Entry_Call);
    end PO_Do_Or_Queue;
 
    ----------------------------
    -- Protected_Single_Count --
    ----------------------------
 
-   function Protected_Count_Entry
-     (Object : Protection_Entry) return Natural is
+   function Protected_Count_Entry (Object : Protection_Entry) return Natural is
    begin
       if Object.Call_In_Progress /= null then
          return 1;
@@ -469,14 +470,12 @@ package body System.Tasking.Protected_Objects.Single_Entry is
 
       pragma Assert (Entry_Call.State /= Cancelled);
 
-      if Entry_Call.State = Done then
-         Check_Exception (Self_Id, Entry_Call'Access);
-         return;
+      if Entry_Call.State /= Done then
+         STPO.Write_Lock (Self_Id);
+         Wait_For_Completion (Self_Id, Entry_Call'Access);
+         STPO.Unlock (Self_Id);
       end if;
 
-      STPO.Write_Lock (Self_Id);
-      Wait_For_Completion (Self_Id, Entry_Call'Access);
-      STPO.Unlock (Self_Id);
       Check_Exception (Self_Id, Entry_Call'Access);
    end Protected_Single_Entry_Call;
 
@@ -496,20 +495,16 @@ package body System.Tasking.Protected_Objects.Single_Entry is
 
    procedure Service_Entry (Object : Protection_Entry_Access) is
       Self_Id       : constant Task_ID := STPO.Self;
-      Entry_Call    : Entry_Call_Link;
+      Entry_Call    : constant Entry_Call_Link := Object.Entry_Queue;
       Caller        : Task_ID;
       Barrier_Value : Boolean;
 
    begin
-      Entry_Call := Object.Entry_Queue;
-
       if Entry_Call /= null then
-         Barrier_Value :=
-           Object.Entry_Body.Barrier (Object.Compiler_Info, 1);
+         Barrier_Value := Object.Entry_Body.Barrier (Object.Compiler_Info, 1);
 
          if Barrier_Value then
             if Object.Call_In_Progress /= null then
-
                --  This violates the No_Entry_Queue restriction, send
                --  Program_Error to the caller.
 
@@ -528,10 +523,9 @@ package body System.Tasking.Protected_Objects.Single_Entry is
          end if;
       end if;
 
-   exception                       --  not needed in no exc mode
-      when others =>               --  not needed in no exc mode
-         Send_Program_Error        --  not needed in no exc mode
-           (Self_Id, Entry_Call);  --  not needed in no exc mode
+   exception
+      when others =>
+         Send_Program_Error (Self_Id, Entry_Call);
    end Service_Entry;
 
    ---------------------------------------
diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb
index a9326c36384..8b5f6a4ff49 100644
--- a/gcc/ada/sem_case.adb
+++ b/gcc/ada/sem_case.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---                            $Revision: 1.13 $
+--                            $Revision$
 --                                                                          --
 --          Copyright (C) 1996-2001 Free Software Foundation, Inc.          --
 --                                                                          --
@@ -264,10 +264,7 @@ package body Sem_Case is
          C := UI_To_Int (Value);
 
          if C in 16#20# .. 16#7E# then
-            Name_Buffer (1) := ''';
-            Name_Buffer (2) := Character'Val (C);
-            Name_Buffer (3) := ''';
-            Name_Len := 3;
+            Set_Character_Literal_Name (Char_Code (UI_To_Int (Value)));
             return Name_Find;
          end if;
 
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index 13e46238cf6..1222ee522fa 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---                            $Revision: 1.14 $
+--                            $Revision$
 --                                                                          --
 --          Copyright (C) 1992-2001, Free Software Foundation, Inc.         --
 --                                                                          --
@@ -7212,7 +7212,13 @@ package body Sem_Ch12 is
             Ancestor :=
               Get_Instance_Of (Base_Type (Etype (A_Gen_T)));
 
-         elsif Is_Derived_Type (Get_Instance_Of (A_Gen_T)) then
+         --  The type may be a local derivation, or a type extension of
+         --  a previous formal, or of a formal of a parent package.
+
+         elsif Is_Derived_Type (Get_Instance_Of (A_Gen_T))
+          or else
+            Ekind (Get_Instance_Of (A_Gen_T)) = E_Record_Type_With_Private
+         then
             Ancestor :=
               Get_Instance_Of (Base_Type (Get_Instance_Of (A_Gen_T)));
 
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index d1076c85ef9..1a43f9ee7f3 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -3856,6 +3856,7 @@ package body Sem_Ch3 is
          if Is_Child_Unit (Scope (Current_Scope))
            and then Is_Completion
            and then In_Private_Part (Current_Scope)
+           and then Scope (Parent_Type) /= Current_Scope
          then
             --  This is the unusual case where a type completed by a private
             --  derivation occurs within a package nested in a child unit,
diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb
index 7ec5201c039..f6f5020118a 100644
--- a/gcc/ada/sem_warn.adb
+++ b/gcc/ada/sem_warn.adb
@@ -674,6 +674,15 @@ package body Sem_Warn is
                      if Unit = Spec_Unit then
                         Set_Unreferenced_In_Spec (Item);
 
+                     --  In No_Run_Time_Mode, we remove the bodies of non-
+                     --  inlined subprograms, which may lead to spurious
+                     --  warnings, clearly undesirable.
+
+                     elsif No_Run_Time
+                       and then Is_Predefined_File_Name (Unit_File_Name (Unit))
+                     then
+                        null;
+
                      --  Otherwise simple unreferenced message
 
                      else