* einfo.ads: Minor reformatting

	* exp_ch5.adb: Add comment for previous.change

	* ali.adb: New interface for extended typeref stuff.

	* ali.ads: New interface for typeref stuff.

	* checks.adb (Apply_Alignment_Check): New procedure.

	* debug.adb: Add -gnatdM for modified ALI output

	* exp_pakd.adb (Known_Aligned_Enough): Replaces Known_Aligned_Enough.

	* lib-xref.adb: Extend generation of <..> notation to cover
	subtype/object types. Note that this is a complete rewrite,
	getting rid of the very nasty quadratic algorithm previously
	used for derived type output.

	* lib-xref.ads: Extend description of <..> notation to cover
	subtype/object types. Uses {..} for these other cases.
	Also use (..) for pointer types.

	* sem_util.adb (Check_Potentially_Blocking_Operation): Slight cleanup.

	* exp_pakd.adb: Minor reformatting.  Note that prevous RH should say:
	(Known_Aligned_Enough): Replaces Must_Be_Aligned.


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

10 files changed, 449 insertions, 117 deletions

diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb
index db6a0f25831..c3c566bac56 100644
--- a/gcc/ada/ali.adb
+++ b/gcc/ada/ali.adb
@@ -133,7 +133,8 @@ package body ALI is
       --  If Lower is set to true then the Name_Buffer will be converted to
       --  all lower case. This only happends for systems where file names are
       --  not case sensitive, and ensures that gnatbind works correctly on
-      --  such systems, regardless of the case of the file name.
+      --  such systems, regardless of the case of the file name. Note that
+      --  a name can be terminated by a right typeref bracket.
 
       function Get_Nat return Nat;
       --  Skip blanks, then scan out an unsigned integer value in Nat range
@@ -305,6 +306,7 @@ package body ALI is
             Name_Len := Name_Len + 1;
             Name_Buffer (Name_Len) := Getc;
             exit when At_End_Of_Field;
+            exit when Nextc = ')' or else Nextc = '}' or else Nextc = '>';
          end loop;
 
          --  Convert file name to all lower case if file names are not case
@@ -1253,30 +1255,55 @@ package body ALI is
 
                   Skip_Space;
 
-                  if Nextc = '<' then
-                     P := P + 1;
-                     N := Get_Nat;
+                  case Nextc is
+                     when '<'    => XE.Tref := Tref_Derived;
+                     when '('    => XE.Tref := Tref_Access;
+                     when '{'    => XE.Tref := Tref_Type;
+                     when others => XE.Tref := Tref_None;
+                  end case;
 
-                     if Nextc = '|' then
-                        XE.Ptype_File_Num :=
-                          Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
-                        Current_File_Num := XE.Ptype_File_Num;
-                        P := P + 1;
-                        N := Get_Nat;
+                  --  Case of typeref field present
+
+                  if XE.Tref /= Tref_None then
+                     P := P + 1; -- skip opening bracket
+
+                     if Nextc in 'a' .. 'z' then
+                        XE.Tref_File_Num        := No_Sdep_Id;
+                        XE.Tref_Line            := 0;
+                        XE.Tref_Type            := ' ';
+                        XE.Tref_Col             := 0;
+                        XE.Tref_Standard_Entity := Get_Name;
 
                      else
-                        XE.Ptype_File_Num := Current_File_Num;
+                        N := Get_Nat;
+
+                        if Nextc = '|' then
+                           XE.Tref_File_Num :=
+                             Sdep_Id (N + Nat (First_Sdep_Entry) - 1);
+                           Current_File_Num := XE.Tref_File_Num;
+                           P := P + 1;
+                           N := Get_Nat;
+
+                        else
+                           XE.Tref_File_Num := Current_File_Num;
+                        end if;
+
+                        XE.Tref_Line            := N;
+                        XE.Tref_Type            := Getc;
+                        XE.Tref_Col             := Get_Nat;
+                        XE.Tref_Standard_Entity := No_Name;
                      end if;
 
-                     XE.Ptype_Line := N;
-                     XE.Ptype_Type := Getc;
-                     XE.Ptype_Col  := Get_Nat;
+                     P := P + 1; -- skip closing bracket
+
+                  --  No typeref entry present
 
                   else
-                     XE.Ptype_File_Num := No_Sdep_Id;
-                     XE.Ptype_Line     := 0;
-                     XE.Ptype_Type     := ' ';
-                     XE.Ptype_Col      := 0;
+                     XE.Tref_File_Num        := No_Sdep_Id;
+                     XE.Tref_Line            := 0;
+                     XE.Tref_Type            := ' ';
+                     XE.Tref_Col             := 0;
+                     XE.Tref_Standard_Entity := No_Name;
                   end if;
 
                   XE.First_Xref := Xref.Last + 1;
diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads
index 6924919cfc3..2079d78a47f 100644
--- a/gcc/ada/ali.ads
+++ b/gcc/ada/ali.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---                            $Revision: 1.71 $
+--                            $Revision$
 --                                                                          --
 --          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
 --                                                                          --
@@ -588,6 +588,15 @@ package ALI is
      Table_Increment      => 300,
      Table_Name           => "Xref_Section");
 
+   --  The following is used to indicate whether a typeref field is present
+   --  for the entity, and if so what kind of typeref field.
+
+   type Tref_Kind is (
+     Tref_None,    --  No typeref present
+     Tref_Access,  --  Access type typeref (points to designated type)
+     Tref_Derived, --  Derived type typeref (points to parent type)
+     Tref_Type);   --  All other cases
+
    --  The following table records entities for which xrefs are recorded
 
    type Xref_Entity_Record is record
@@ -607,24 +616,39 @@ package ALI is
       Entity : Name_Id;
       --  Name of entity
 
-      Ptype_File_Num : Sdep_Id;
-      --  This field is set to No_Sdep_Id if no ptype (parent type) entry
-      --  is present, otherwise it is the file dependency reference for
-      --  the parent type declaration.
-
-      Ptype_Line : Nat;
-      --  Set to zero if no ptype (parent type) entry, otherwise this is
-      --  the line number of the declaration of the parent type.
-
-      Ptype_Type : Character;
-      --  Set to blank if no ptype (parent type) entry, otherwise this is
-      --  the identification character for the parent type. See section
+      Tref : Tref_Kind;
+      --  Indicates if a typeref is present, and if so what kind. Set to
+      --  Tref_None if no typeref field is present.
+
+      Tref_File_Num : Sdep_Id;
+      --  This field is set to No_Sdep_Id if no typeref is present, or
+      --  if the typeref refers to an entity in standard. Otherwise it
+      --  it is the dependency reference for the file containing the
+      --  declaration of the typeref entity.
+
+      Tref_Line : Nat;
+      --  This field is set to zero if no typeref is present, or if the
+      --  typeref refers to an entity in standard. Otherwise it contains
+      --  the line number of the declaration of the typeref entity.
+
+      Tref_Type : Character;
+      --  This field is set to blank if no typeref is present, or if the
+      --  typeref refers to an entity in standard. Otherwise it contains
+      --  the identification character for the typeref entity. See section
       --  "Cross-Reference Entity Indentifiers in lib-xref.ads for details.
 
-      Ptype_Col : Nat;
-      --  Set to zero if no ptype (parent type) entry, otherwise this is
+      Tref_Col : Nat;
+      --  This field is set to zero if no typeref is present, or if the
+      --  typeref refers to an entity in standard. Otherwise it contains
       --  the column number of the declaration of the parent type.
 
+      Tref_Standard_Entity : Name_Id;
+      --  This field is set to No_Name if no typeref is present or if the
+      --  typeref refers to a declared entity rather than an entity in
+      --  package Standard. If there is a typeref that references an
+      --  entity in package Standard, then this field is a Name_Id
+      --  reference for the entity name.
+
       First_Xref : Nat;
       --  Index into Xref table of first cross-reference
 
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index bf806417558..896481e86d6 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -37,6 +37,7 @@ with Freeze;   use Freeze;
 with Nlists;   use Nlists;
 with Nmake;    use Nmake;
 with Opt;      use Opt;
+with Restrict; use Restrict;
 with Rtsfind;  use Rtsfind;
 with Sem;      use Sem;
 with Sem_Eval; use Sem_Eval;
@@ -277,6 +278,79 @@ package body Checks is
       end if;
    end Apply_Accessibility_Check;
 
+   ---------------------------
+   -- Apply_Alignment_Check --
+   ---------------------------
+
+   procedure Apply_Alignment_Check (E : Entity_Id; N : Node_Id) is
+      AC   : constant Node_Id := Address_Clause (E);
+      Expr : Node_Id;
+      Loc  : Source_Ptr;
+
+   begin
+      if No (AC) or else Range_Checks_Suppressed (E) then
+         return;
+      end if;
+
+      Loc  := Sloc (AC);
+      Expr := Expression (AC);
+
+      if Nkind (Expr) = N_Unchecked_Type_Conversion then
+         Expr := Expression (Expr);
+
+      elsif Nkind (Expr) = N_Function_Call
+        and then Is_RTE (Entity (Name (Expr)), RE_To_Address)
+      then
+         Expr := First (Parameter_Associations (Expr));
+
+         if Nkind (Expr) = N_Parameter_Association then
+            Expr := Explicit_Actual_Parameter (Expr);
+         end if;
+      end if;
+
+      --  Here Expr is the address value. See if we know that the
+      --  value is unacceptable at compile time.
+
+      if Compile_Time_Known_Value (Expr)
+        and then Known_Alignment (E)
+      then
+         if Expr_Value (Expr) mod Alignment (E) /= 0 then
+               Insert_Action (N,
+                  Make_Raise_Program_Error (Loc));
+               Error_Msg_NE
+                 ("?specified address for& not " &
+                  "consistent with alignment", Expr, E);
+         end if;
+
+      --  Here we do not know if the value is acceptable, generate
+      --  code to raise PE if alignment is inappropriate.
+
+      else
+         --  Skip generation of this code if we don't want elab code
+
+         if not Restrictions (No_Elaboration_Code) then
+            Insert_After_And_Analyze (N,
+              Make_Raise_Program_Error (Loc,
+                Condition =>
+                  Make_Op_Ne (Loc,
+                    Left_Opnd =>
+                      Make_Op_Mod (Loc,
+                        Left_Opnd =>
+                          Unchecked_Convert_To
+                           (RTE (RE_Integer_Address),
+                            Duplicate_Subexpr (Expr)),
+                        Right_Opnd =>
+                          Make_Attribute_Reference (Loc,
+                            Prefix => New_Occurrence_Of (E, Loc),
+                            Attribute_Name => Name_Alignment)),
+                    Right_Opnd => Make_Integer_Literal (Loc, Uint_0))),
+              Suppress => All_Checks);
+         end if;
+      end if;
+
+      return;
+   end Apply_Alignment_Check;
+
    -------------------------------------
    -- Apply_Arithmetic_Overflow_Check --
    -------------------------------------
diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb
index 27c934bd99c..d80c8e6aa71 100644
--- a/gcc/ada/debug.adb
+++ b/gcc/ada/debug.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---                            $Revision: 1.88 $
+--                            $Revision$
 --                                                                          --
 --          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
 --                                                                          --
@@ -80,7 +80,7 @@ package body Debug is
    --  dJ   Output debugging trace info for JGNAT (Java VM version of GNAT)
    --  dK   Kill all error messages
    --  dL   Output trace information on elaboration checking
-   --  dM
+   --  dM   Modified ali file output
    --  dN   Do not generate file/line exception messages
    --  dO   Output immediate error messages
    --  dP   Do not check for controlled objects in preelaborable packages
@@ -284,6 +284,11 @@ package body Debug is
    --       attempting to generate code with this flag set may blow up.
    --       The flag also forces the use of 64-bits for Long_Integer.
 
+   --  dM   Generate modified ALI output. Several ALI extensions are being
+   --       developed for version 3.15w, and this switch is used to enable
+   --       these extensions. This switch will disappear when this work is
+   --       completed.
+
    --  dn   Generate messages for node/list allocation. Each time a node or
    --       list header is allocated, a line of output is generated. Certain
    --       other basic tree operations also cause a line of output to be
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index f480458f548..ad8b437f219 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -302,6 +302,7 @@ package Einfo is
 --       only if the actual subtype differs from the nominal subtype. If the
 --       actual and nominal subtypes are the same, then the Actual_Subtype
 --       field is Empty, and Etype indicates both types.
+--
 --       For objects, the Actual_Subtype is set only if this is a discriminated
 --       type. For arrays, the bounds of the expression are obtained and the
 --       Etype of the object is directly the constrained subtype. This is
diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index b6b23d0d18f..3f5a73b8a1b 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -1895,6 +1895,11 @@ package body Exp_Ch5 is
          --  the Then statements
 
          else
+            --  We do not delete the condition if constant condition
+            --  warnings are enabled, since otherwise we end up deleting
+            --  the desired warning. Of course the backend will get rid
+            --  of this True/False test anyway, so nothing is lost here.
+
             if not Constant_Condition_Warnings then
                Kill_Dead_Code (Condition (N));
             end if;
diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb
index 2cc4f255473..5656569669c 100644
--- a/gcc/ada/exp_pakd.adb
+++ b/gcc/ada/exp_pakd.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---                            $Revision: 1.125 $
+--                            $Revision$
 --                                                                          --
 --          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
 --                                                                          --
@@ -453,6 +453,16 @@ package body Exp_Pakd is
    --  expression whose type is the implementation type used to represent
    --  the packed array. Aexp is analyzed and resolved on entry and on exit.
 
+   function Known_Aligned_Enough (Obj : Node_Id; Csiz : Nat) return Boolean;
+   --  There are two versions of the Set routines, the ones used when the
+   --  object is known to be sufficiently well aligned given the number of
+   --  bits, and the ones used when the object is not known to be aligned.
+   --  This routine is used to determine which set to use. Obj is a reference
+   --  to the object, and Csiz is the component size of the packed array.
+   --  True is returned if the alignment of object is known to be sufficient,
+   --  defined as 1 for odd bit sizes, 4 for bit sizes divisible by 4, and
+   --  2 otherwise.
+
    function Make_Shift_Left (N : Node_Id; S : Node_Id) return Node_Id;
    --  Build a left shift node, checking for the case of a shift count of zero
 
@@ -1426,7 +1436,7 @@ package body Exp_Pakd is
             --  Acquire proper Set entity. We use the aligned or unaligned
             --  case as appropriate.
 
-            if Must_Be_Aligned (Obj) then
+            if Known_Aligned_Enough (Obj, Csiz) then
                Set_nn := RTE (Set_Id (Csiz));
             else
                Set_nn := RTE (SetU_Id (Csiz));
@@ -1816,7 +1826,7 @@ package body Exp_Pakd is
             --  Acquire proper Get entity. We use the aligned or unaligned
             --  case as appropriate.
 
-            if Must_Be_Aligned (Obj) then
+            if Known_Aligned_Enough (Obj, Csiz) then
                Get_nn := RTE (Get_Id (Csiz));
             else
                Get_nn := RTE (GetU_Id (Csiz));
@@ -2088,6 +2098,122 @@ package body Exp_Pakd is
       end if;
    end Involves_Packed_Array_Reference;
 
+   --------------------------
+   -- Known_Aligned_Enough --
+   --------------------------
+
+   function Known_Aligned_Enough (Obj : Node_Id; Csiz : Nat) return Boolean is
+      Typ : constant Entity_Id := Etype (Obj);
+
+      function In_Partially_Packed_Record (Comp : Entity_Id) return Boolean;
+      --  If the component is in a record that contains previous packed
+      --  components, consider it unaligned because the back-end might
+      --  choose to pack the rest of the record. Lead to less efficient code,
+      --  but safer vis-a-vis of back-end choices.
+
+      --------------------------------
+      -- In_Partially_Packed_Record --
+      --------------------------------
+
+      function In_Partially_Packed_Record (Comp : Entity_Id) return Boolean is
+         Rec_Type  : constant Entity_Id := Scope (Comp);
+         Prev_Comp : Entity_Id;
+
+      begin
+         Prev_Comp := First_Entity (Rec_Type);
+         while Present (Prev_Comp) loop
+            if Is_Packed (Etype (Prev_Comp)) then
+               return True;
+
+            elsif Prev_Comp = Comp then
+               return False;
+            end if;
+
+            Next_Entity (Prev_Comp);
+         end loop;
+
+         return False;
+      end  In_Partially_Packed_Record;
+
+   --  Start of processing for Known_Aligned_Enough
+
+   begin
+      --  Odd bit sizes don't need alignment anyway
+
+      if Csiz mod 2 = 1 then
+         return True;
+
+      --  If we have a specified alignment, see if it is sufficient, if not
+      --  then we can't possibly be aligned enough in any case.
+
+      elsif Is_Entity_Name (Obj)
+        and then Known_Alignment (Entity (Obj))
+      then
+         --  Alignment required is 4 if size is a multiple of 4, and
+         --  2 otherwise (e.g. 12 bits requires 4, 10 bits requires 2)
+
+         if Alignment (Entity (Obj)) < 4 - (Csiz mod 4) then
+            return False;
+         end if;
+      end if;
+
+      --  OK, alignment should be sufficient, if object is aligned
+
+      --  If object is strictly aligned, then it is definitely aligned
+
+      if Strict_Alignment (Typ) then
+         return True;
+
+      --  Case of subscripted array reference
+
+      elsif Nkind (Obj) = N_Indexed_Component then
+
+         --  If we have a pointer to an array, then this is definitely
+         --  aligned, because pointers always point to aligned versions.
+
+         if Is_Access_Type (Etype (Prefix (Obj))) then
+            return True;
+
+         --  Otherwise, go look at the prefix
+
+         else
+            return Known_Aligned_Enough (Prefix (Obj), Csiz);
+         end if;
+
+      --  Case of record field
+
+      elsif Nkind (Obj) = N_Selected_Component then
+
+         --  What is significant here is whether the record type is packed
+
+         if Is_Record_Type (Etype (Prefix (Obj)))
+           and then Is_Packed (Etype (Prefix (Obj)))
+         then
+            return False;
+
+         --  Or the component has a component clause which might cause
+         --  the component to become unaligned (we can't tell if the
+         --  backend is doing alignment computations).
+
+         elsif Present (Component_Clause (Entity (Selector_Name (Obj)))) then
+            return False;
+
+         elsif In_Partially_Packed_Record (Entity (Selector_Name (Obj))) then
+            return False;
+
+         --  In all other cases, go look at prefix
+
+         else
+            return Known_Aligned_Enough (Prefix (Obj), Csiz);
+         end if;
+
+      --  If not selected or indexed component, must be aligned
+
+      else
+         return True;
+      end if;
+   end Known_Aligned_Enough;
+
    ---------------------
    -- Make_Shift_Left --
    ---------------------
@@ -2184,6 +2310,7 @@ package body Exp_Pakd is
    --  All we have to do here is to find the subscripts that correspond
    --  to the index positions that have non-standard enumeration types
    --  and insert a Pos attribute to get the proper subscript value.
+
    --  Finally the prefix must be uncheck converted to the corresponding
    --  packed array type.
 
diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb
index f7e12ef65f1..4367eb1720b 100644
--- a/gcc/ada/lib-xref.adb
+++ b/gcc/ada/lib-xref.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---                            $Revision: 1.56 $
+--                            $Revision$
 --                                                                          --
 --          Copyright (C) 1998-2001, Free Software Foundation, Inc.         --
 --                                                                          --
@@ -28,6 +28,7 @@
 
 with Atree;    use Atree;
 with Csets;    use Csets;
+with Debug;    use Debug;
 with Lib.Util; use Lib.Util;
 with Namet;    use Namet;
 with Opt;      use Opt;
@@ -84,10 +85,6 @@ package body Lib.Xref is
      Table_Increment      => Alloc.Xrefs_Increment,
      Table_Name           => "Xrefs");
 
-   function Get_Xref_Index (E : Entity_Id) return Xref_Entry_Number;
-   --  Returns the Xref entry table index for entity E.
-   --  So : Xrefs.Table (Get_Xref_Index (E)).Ent = E
-
    -------------------------
    -- Generate_Definition --
    -------------------------
@@ -328,23 +325,6 @@ package body Lib.Xref is
       end if;
    end Generate_Reference;
 
-   --------------------
-   -- Get_Xref_Index --
-   --------------------
-
-   function Get_Xref_Index (E : Entity_Id) return Xref_Entry_Number is
-   begin
-      for K in 1 .. Xrefs.Last loop
-         if Xrefs.Table (K).Ent = E then
-            return K;
-         end if;
-      end loop;
-
-      --  not found, this happend if the entity is not in the compiled unit.
-
-      return 0;
-   end Get_Xref_Index;
-
    -----------------------
    -- Output_References --
    -----------------------
@@ -466,35 +446,18 @@ package body Lib.Xref is
          Ctyp : Character;
          --  Entity type character
 
-         Parent_Entry : Int;
-         --  entry for parent of derived type.
+         Tref : Entity_Id;
+         --  Type reference
+
+         Trunit : Unit_Number_Type;
+         --  Unit number for type reference
 
          function Name_Change (X : Entity_Id) return Boolean;
          --  Determines if entity X has a different simple name from Curent
 
-         function Get_Parent_Entry (X : Entity_Id) return Int;
-         --  For a derived type, locate entry of parent type, if defined in
-         --  in the current unit.
-
-         function Get_Parent_Entry (X : Entity_Id) return Int is
-            Parent_Type : Entity_Id;
-
-         begin
-            if not Is_Type (X)
-              or else not Is_Derived_Type (X)
-            then
-               return 0;
-            else
-               Parent_Type := First_Subtype (Etype (Base_Type (X)));
-
-               if Comes_From_Source (Parent_Type) then
-                  return Get_Xref_Index (Parent_Type);
-
-               else
-                  return 0;
-               end if;
-            end if;
-         end Get_Parent_Entry;
+         -----------------
+         -- Name_Change --
+         -----------------
 
          function Name_Change (X : Entity_Id) return Boolean is
          begin
@@ -529,6 +492,11 @@ package body Lib.Xref is
                WC  : Char_Code;
                Err : Boolean;
                Ent : Entity_Id;
+               Sav : Entity_Id;
+
+               Left  : Character;
+               Right : Character;
+               --  Used for {} or <> for type reference
 
             begin
                Ent := XE.Ent;
@@ -709,34 +677,123 @@ package body Lib.Xref is
                         end loop;
                      end if;
 
-                     --  Output derived entity name if it is available
+                     --  Output type reference if any
+
+                     Tref := XE.Ent;
+                     Left := '{';
+                     Right := '}';
+
+                     loop
+                        Sav := Tref;
+
+                        --  Processing for types
+
+                        if Is_Type (Tref) then
+
+                           --  Case of base type
+
+                           if Base_Type (Tref) = Tref then
+
+                              --  If derived, then get first subtype
+
+                              if Tref /= Etype (Tref) then
+                                 Tref := First_Subtype (Etype (Tref));
+                                 Left := '<';
+                                 Right := '>';
 
-                     Parent_Entry := Get_Parent_Entry (XE.Ent);
+                              --  If non-derived ptr, get designated type
 
-                     if Parent_Entry /= 0 then
-                        declare
-                           XD : Xref_Entry renames Xrefs.Table (Parent_Entry);
+                              elsif Is_Access_Type (Tref) then
+                                 Tref := Designated_Type (Tref);
+                                 Left := '(';
+                                 Right := ')';
 
-                        begin
-                           Write_Info_Char ('<');
+                              --  For other non-derived base types, nothing
 
-                           --  Write unit number only if different from the
-                           --  current one.
+                              else
+                                 exit;
+                              end if;
 
-                           if XE.Eun /= XD.Eun then
-                              Write_Info_Nat (Dependency_Num (XD.Eun));
+                           --  For a subtype, go to ancestor subtype
+
+                           else
+                              Tref := Ancestor_Subtype (Tref);
+
+                              --  If no ancestor subtype, go to base type
+
+                              if No (Tref) then
+                                 Tref := Base_Type (Sav);
+                              end if;
+                           end if;
+
+                        --  For objects, functions, enum literals,
+                        --  just get type from Etype field.
+
+                        elsif Is_Object (Tref)
+                          or else Ekind (Tref) = E_Enumeration_Literal
+                          or else Ekind (Tref) = E_Function
+                          or else Ekind (Tref) = E_Operator
+                        then
+                           Tref := Etype (Tref);
+
+                        --  For anything else, exit
+
+                        else
+                           exit;
+                        end if;
+
+                        --  Exit if no type reference, or we are stuck in
+                        --  some loop trying to find the type reference.
+
+                        exit when No (Tref) or else Tref = Sav;
+
+                        --  Case of standard entity, output name
+
+                        if Sloc (Tref) = Standard_Location then
+
+                           --  For now, output only if speial -gnatdM flag set
+
+                           exit when not Debug_Flag_MM;
+
+                           Write_Info_Char (Left);
+                           Write_Info_Name (Chars (Tref));
+                           Write_Info_Char (Right);
+                           exit;
+
+                        --  Case of source entity, output location
+
+                        elsif Comes_From_Source (Tref) then
+
+                           --  For now, output only derived type entries
+                           --  unless we have special debug flag -gnatdM
+
+                           exit when not (Debug_Flag_MM or else Left = '<');
+
+                           --  Output the reference
+
+                           Write_Info_Char (Left);
+                           Trunit := Get_Source_Unit (Sloc (Tref));
+
+                           if Trunit /= Curxu then
+                              Write_Info_Nat (Dependency_Num (Trunit));
                               Write_Info_Char ('|');
                            end if;
 
                            Write_Info_Nat
-                             (Int (Get_Logical_Line_Number (XD.Def)));
+                             (Int (Get_Logical_Line_Number (Sloc (Tref))));
                            Write_Info_Char
-                             (Xref_Entity_Letters (Ekind (XD.Ent)));
-                           Write_Info_Nat (Int (Get_Column_Number (XD.Def)));
+                             (Xref_Entity_Letters (Ekind (Tref)));
+                           Write_Info_Nat
+                             (Int (Get_Column_Number (Sloc (Tref))));
+                           Write_Info_Char (Right);
+                           exit;
 
-                           Write_Info_Char ('>');
-                        end;
-                     end if;
+                        --  If non-standard, non-source entity, keep looking
+
+                        else
+                           null;
+                        end if;
+                     end loop;
 
                      Curru := Curxu;
                      Crloc := No_Location;
diff --git a/gcc/ada/lib-xref.ads b/gcc/ada/lib-xref.ads
index d0d2c8ab36c..ea99c9642ca 100644
--- a/gcc/ada/lib-xref.ads
+++ b/gcc/ada/lib-xref.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---                            $Revision: 1.31 $
+--                            $Revision$
 --                                                                          --
 --          Copyright (C) 1998-2001, Free Software Foundation, Inc.         --
 --                                                                          --
@@ -56,7 +56,7 @@ package Lib.Xref is
    --
    --  The lines following the header look like
    --
-   --     line type col level  entity ptype  ref  ref  ref
+   --     line type col level  entity typeref  ref  ref  ref
    --
    --        line is the line number of the referenced entity. It starts
    --        in column one.
@@ -74,17 +74,30 @@ package Lib.Xref is
    --        entity is the name of the referenced entity, with casing in
    --        the canical casing for the source file where it is defined.
    --
-   --        ptype is the parent's entity reference. This part is optional (it
-   --        is only set for derived types) and has the following format:
-   --
-   --        < file | line type col >
-   --
-   --        file is the dependency number of the file containing the
-   --        declaration of the parent type. This number and the following
-   --        vertical bar are omitted if the parent type is defined in the
-   --        same file as the derived type. The line, type, col are defined
-   --        as previously described, and give the location of the parent
-   --        type declaration in the referenced file.
+   --        typeref is the reference for the type. This part is optional.
+   --        It is present for the following cases:
+   --
+   --          derived types (points to the parent type)   LR=<>
+   --          access types (points to designated type)    LR=()
+   --          subtypes (points to ancestor type)          LR={}
+   --          functions (points to result type)           LR={}
+   --          enumeration literals (points to enum type)  LR={}
+   --          objects and components (points to type)     LR={}
+   --
+   --        In the above list LR shows the brackets used in the output,
+   --        which has one of the two following forms:
+   --
+   --          L file | line type col R      user entity
+   --          L name-in-lower-case   R      standard entity
+   --
+   --        For the form for a user entity, file is the dependency number
+   --        of the file containing the declaration of the parent type. This
+   --        number and the following vertical bar are omitted if the relevant
+   --        type is defined in the same file as the current entity. The line,
+   --        type, col are defined as previously described, and specify the
+   --        location of the relevant type declaration in the referenced file.
+   --        For the standard entity form, the name between the brackets is
+   --        the normal name of the entity in lower case letters.
    --
    --     There may be zero or more ref entries on each line
    --
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index e53f8718de2..df9ef755e89 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -720,8 +720,7 @@ package body Sem_Util is
          if Is_Protected_Type (S) then
             if Restricted_Profile then
                Insert_Before (N,
-                  Make_Raise_Statement (Loc,
-                   Name => New_Occurrence_Of (Standard_Program_Error, Loc)));
+                  Make_Raise_Program_Error (Loc));
                Error_Msg_N ("potentially blocking operation, " &
                  " Program Error will be raised at run time?", N);