lib-xref.adb (Is_On_LHS): Remove dead code

2008-04-08  Ed Schonberg  <schonberg@adacore.com>
	    Robert Dewar  <dewar@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>

	* lib-xref.adb (Is_On_LHS): Remove dead code
	(Output_Overriden_Op): If the overridden operation is itself inherited,
	list the ancestor operation, which is the one whose body or absstract
	specification is actually being overridden.

	* sem_ch7.adb (Is_Primitive_Of): use base type to determine whether
	operation is primitive for the type.
	(Declare_Inherited_Private_Subprograms): If the new operation overrides
	an inherited private subprogram, set properly the Overridden_Operation
	attribute, for better cross-reference information.
	(Analyze_Package_Specification): Do late analysis of spec PPCs
	(Install_Private_Declaration, Uninstall_Declarations): Save/restore
	properly the full view and underlying full views of a private type in a
	child unit, whose full view is derived from a private type in a parent
	unit, and whose own full view becomes visible in the child body.

	* sem_disp.adb (Check_Dispatching_Operation): When a body declares a
	primitive operation after the type has been frozen, add an explicit
	reference to the type and the operation, because other primitive
	references have been emitted already.
	(Expand_Call, Propagate_Tag): Call Kill_Current_Values when processing a
	dispatching call on VM targets.

From-SVN: r134038

gcc/ada/lib-xref.adb

@@ -309,10 +309,6 @@ package body Lib.Xref is
                return False;
             end if;
          end loop;
-
-         --  Parent (N) is assignment statement, check whether N is its name
-
-         return Name (Parent (N)) = N;
       end Is_On_LHS;
 
       ---------------------------
@@ -1579,14 +1575,34 @@ package body Lib.Xref is
                --------------------------
 
                procedure Output_Overridden_Op (Old_E : Entity_Id) is
+                  Op : Entity_Id;
+
                begin
-                  if Present (Old_E)
-                    and then Sloc (Old_E) /= Standard_Location
+                  --  The overridden operation has an implicit declaration
+                  --  at the point of derivation. What we want to display
+                  --  is the original operation, which has the actual body
+                  --  (or abstract declaration) that is being overridden.
+                  --  The overridden operation is not always set, e.g. when
+                  --  it is a predefined operator.
+
+                  if No (Old_E) then
+                     return;
+
+                  elsif Present (Alias (Old_E)) then
+                     Op := Alias (Old_E);
+
+                  else
+                     Op := Old_E;
+                  end if;
+
+                  if Present (Op)
+                    and then Sloc (Op) /= Standard_Location
                   then
                      declare
-                        Loc      : constant Source_Ptr := Sloc (Old_E);
+                        Loc      : constant Source_Ptr := Sloc (Op);
                         Par_Unit : constant Unit_Number_Type :=
                                      Get_Source_Unit (Loc);
+
                      begin
                         Write_Info_Char ('<');
 

gcc/ada/sem_ch7.adb

@@ -51,6 +51,7 @@ with Sem_Ch8;  use Sem_Ch8;
 with Sem_Ch10; use Sem_Ch10;
 with Sem_Ch12; use Sem_Ch12;
 with Sem_Disp; use Sem_Disp;
+with Sem_Prag; use Sem_Prag;
 with Sem_Util; use Sem_Util;
 with Sem_Warn; use Sem_Warn;
 with Snames;   use Snames;
@@ -757,6 +758,12 @@ package body Sem_Ch7 is
       --  private_with_clauses, and remove them at the end of the nested
       --  package.
 
+      procedure Analyze_PPCs (Decls : List_Id);
+      --  Given a list of declarations, go through looking for subprogram
+      --  specs, and for each one found, analyze any pre/postconditions that
+      --  are chained to the spec. This is the implementation of the late
+      --  visibility analysis for preconditions and postconditions in specs.
+
       procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id);
       --  Clears constant indications (Never_Set_In_Source, Constant_Value,
       --  and Is_True_Constant) on all variables that are entities of Id,
@@ -785,6 +792,33 @@ package body Sem_Ch7 is
       --  private part rather than being done in Sem_Ch12.Install_Parent
       --  (which is where the parents' visible declarations are installed).
 
+      ------------------
+      -- Analyze_PPCs --
+      ------------------
+
+      procedure Analyze_PPCs (Decls : List_Id) is
+         Decl : Node_Id;
+         Spec : Node_Id;
+         Sent : Entity_Id;
+         Prag : Node_Id;
+
+      begin
+         Decl := First (Decls);
+         while Present (Decl) loop
+            if Nkind (Original_Node (Decl)) = N_Subprogram_Declaration then
+               Spec := Specification (Original_Node (Decl));
+               Sent := Defining_Unit_Name (Spec);
+               Prag := Spec_PPC_List (Sent);
+               while Present (Prag) loop
+                  Analyze_PPC_In_Decl_Part (Prag, Sent);
+                  Prag := Next_Pragma (Prag);
+               end loop;
+            end if;
+
+            Next (Decl);
+         end loop;
+      end Analyze_PPCs;
+
       ---------------------
       -- Clear_Constants --
       ---------------------
@@ -937,9 +971,9 @@ package body Sem_Ch7 is
 
       begin
          Inst_Par := Inst_Id;
+
          Gen_Par :=
            Generic_Parent (Specification (Unit_Declaration_Node (Inst_Par)));
-
          while Present (Gen_Par) and then Is_Child_Unit (Gen_Par) loop
             Inst_Node := Get_Package_Instantiation_Node (Inst_Par);
 
@@ -1017,6 +1051,7 @@ package body Sem_Ch7 is
    begin
       if Present (Vis_Decls) then
          Analyze_Declarations (Vis_Decls);
+         Analyze_PPCs (Vis_Decls);
       end if;
 
       --  Verify that incomplete types have received full declarations
@@ -1152,6 +1187,7 @@ package body Sem_Ch7 is
          end if;
 
          Analyze_Declarations (Priv_Decls);
+         Analyze_PPCs (Priv_Decls);
 
          --  Check the private declarations for incomplete deferred constants
 
@@ -1345,13 +1381,17 @@ package body Sem_Ch7 is
          Formal : Entity_Id;
 
       begin
-         if Etype (S) = T then
+         --  If the full view is a scalar type, the type is the anonymous
+         --  base type, but the operation mentions the first subtype, so
+         --  check the signature againt the base type.
+
+         if Base_Type (Etype (S)) = Base_Type (T) then
             return True;
 
          else
             Formal := First_Formal (S);
             while Present (Formal) loop
-               if Etype (Formal) = T then
+               if Base_Type (Etype (Formal)) = Base_Type (T) then
                   return True;
                end if;
 
@@ -1427,6 +1467,7 @@ package body Sem_Ch7 is
                            Replace_Elmt (Op_Elmt, New_Op);
                            Remove_Elmt  (Op_List, Op_Elmt_2);
                            Set_Is_Overriding_Operation (New_Op);
+                           Set_Overridden_Operation (New_Op, Parent_Subp);
 
                            --  We don't need to inherit its dispatching slot.
                            --  Set_All_DT_Position has previously ensured that
@@ -1664,11 +1705,18 @@ package body Sem_Ch7 is
                --  when the parent type is defined in the parent unit. At this
                --  point the current type is not private either, and we have to
                --  install the underlying full view, which is now visible.
+               --  Save the current full view as well, so that all views can
+               --  be restored on exit. It may seem that after compiling the
+               --  child body there are not environments to restore, but the
+               --  back-end expects those links to be valid, and freeze nodes
+               --  depend on them.
 
                if No (Full_View (Full))
                  and then Present (Underlying_Full_View (Full))
                then
                   Set_Full_View (Id, Underlying_Full_View (Full));
+                  Set_Underlying_Full_View (Id, Full);
+
                   Set_Underlying_Full_View (Full, Empty);
                   Set_Is_Frozen (Full_View (Id));
                end if;
@@ -2153,7 +2201,8 @@ package body Sem_Ch7 is
       end if;
 
       --  Make private entities invisible and exchange full and private
-      --  declarations for private types.
+      --  declarations for private types. Id is now the first private
+      --  entity in the package.
 
       while Present (Id) loop
          if Debug_Flag_E then
@@ -2240,6 +2289,22 @@ package body Sem_Ch7 is
 
             Exchange_Declarations (Id);
 
+            --  If we have installed an underlying full view for a type
+            --  derived from a private type in a child unit, restore the
+            --  proper views of private and full view. See corresponding
+            --  code in Install_Private_Declarations.
+            --  After the exchange, Full denotes the private type in the
+            --  visible part of the package.
+
+            if Is_Private_Base_Type (Full)
+              and then Present (Full_View (Full))
+              and then Present (Underlying_Full_View (Full))
+              and then In_Package_Body (Current_Scope)
+            then
+               Set_Full_View (Full, Underlying_Full_View (Full));
+               Set_Underlying_Full_View (Full, Empty);
+            end if;
+
          elsif Ekind (Id) = E_Incomplete_Type
            and then No (Full_View (Id))
          then

gcc/ada/sem_disp.adb

@@ -31,6 +31,7 @@ with Exp_Disp; use Exp_Disp;
 with Exp_Ch7;  use Exp_Ch7;
 with Exp_Tss;  use Exp_Tss;
 with Errout;   use Errout;
+with Lib.Xref; use Lib.Xref;
 with Namet;    use Namet;
 with Nlists;   use Nlists;
 with Nmake;    use Nmake;
@@ -790,6 +791,9 @@ package body Sem_Disp is
                      --  if the subprogram is already frozen, we must update
                      --  its dispatching information explicitly here. The
                      --  information is taken from the overridden subprogram.
+                     --  We must also generate a cross-reference entry because
+                     --  references to other primitives were already created
+                     --  when type was frozen.
 
                      Body_Is_Last_Primitive := True;
 
@@ -819,6 +823,8 @@ package body Sem_Disp is
                                 Prim    => Subp,
                                 Ins_Nod => Subp_Body);
                            end if;
+
+                           Generate_Reference (Tagged_Type, Subp, 'p', False);
                         end if;
                      end if;
                   end if;
@@ -1543,6 +1549,14 @@ package body Sem_Disp is
 
       if VM_Target = No_VM then
          Expand_Dispatching_Call (Call_Node);
+
+      --  Expansion of a dispatching call results in an indirect call, which in
+      --  turn causes current values to be killed (see Resolve_Call), so on VM
+      --  targets we do the call here to ensure consistent warnings between VM
+      --  and non-VM targets.
+
+      else
+         Kill_Current_Values;
       end if;
    end Propagate_Tag;