exp_ch6.adb (Expand_Call): If an actual is a function call rewritten from object notation...

2005-09-01  Ed Schonberg  <schonberg@adacore.com>
	    Hristian Kirtchev  <kirtchev@adacore.com>
	    Javier Miranda  <miranda@adacore.com>

	* exp_ch6.adb (Expand_Call): If an actual is a function call rewritten
	from object notation, the original node is unanalyzed and carries no
	semantic information, so that accessiblity checks must be performed on
	the type of the actual itself.
	(Expand_N_Subprogram_Declaration): Change last actual parameter for
	compatibility with Build_Protected_Sub_Specification.
	(Check_Overriding_Inherited_Interfaces): Add suport to handle
	overloaded primitives.
	(Register_Interface_DT_Entry): Use the new name of the formal
	the the calls to Expand_Interface_Thunk

	* exp_dbug.ads: Augment comments on encoding of protected types to
	include the generation of dispatching subprograms when the type
	implements at least one interface.

	* lib.ads: Extend information in Load_Stack to include whether a given
	load comes from a Limited_With_Clause.

	* lib-load.adb (From_Limited_With_Chain): New predicate to determine
	whether a potential circularity is harmless, because it includes units
	loaded through a limited_with clause. Extends previous treatment which
	did not handle properly arbitrary combinations of limited and
	non-limited clauses.

From-SVN: r103861

gcc/ada/exp_dbug.ads

@@ -89,7 +89,7 @@ package Exp_Dbug is
    --    x
    --    y.z
 
-   --  The separating dots are translated into double underscores.
+   --  The separating dots are translated into double underscores
 
       -----------------------------
       -- Handling of Overloading --
@@ -385,6 +385,28 @@ package Exp_Dbug is
       --    lock_update1sE
       --    lock_udpate2sB
 
+      --  If the protected type implements at least one interface, the
+      --  following additional operations are created:
+
+      --    lock_get
+
+      --    lock_set
+
+      --  These operations are used to ensure overriding of interface level
+      --  subprograms and proper dispatching on interface class-wide objects.
+      --  The bodies of these operations contain calls to their respective
+      --  protected versions:
+
+      --    function lock_get return Integer is
+      --    begin
+      --       return lock_getP;
+      --    end lock_get;
+
+      --    procedure lock_set (X : Integer) is
+      --    begin
+      --       lock_setP (X);
+      --    end lock_set;
+
    ----------------------------------------------------
    -- Conversion between Entities and External Names --
    ----------------------------------------------------
@@ -686,9 +708,9 @@ package Exp_Dbug is
       --  follows. In this description, let P represent the current
       --  bit position in the record.
 
-      --    1. Initialize P to 0.
+      --    1. Initialize P to 0
 
-      --    2. For each field in the record,
+      --    2. For each field in the record:
 
       --       2a. If an alignment is given (see below), then round P
       --       up, if needed, to the next multiple of that alignment.
@@ -697,7 +719,7 @@ package Exp_Dbug is
       --       amount (that is, treat it as an offset from the end of the
       --       preceding record).
 
-      --       2c. Assign P as the actual position of the field.
+      --       2c. Assign P as the actual position of the field
 
       --       2d. Compute the length, L, of the represented field (see below)
       --       and compute P'=P+L. Unless the field represents a variant part
@@ -963,7 +985,7 @@ package Exp_Dbug is
    --  name of the parent unit, to disambiguate child units with the same
    --  simple name and (of necessity) different parents.
 
-   --  Note: subprogram renamings are not encoded at the present time.
+   --  Note: subprogram renamings are not encoded at the present time
 
    --  The type is an enumeration type with a single enumeration literal
    --  that is an identifier which describes the renamed variable.

gcc/ada/lib-load.adb

@@ -53,6 +53,11 @@ package body Lib.Load is
    -- Local Subprograms --
    -----------------------
 
+   function From_Limited_With_Chain (Lim : Boolean) return Boolean;
+   --  Check whether a possible circular dependence includes units that
+   --  have been loaded through limited_with clauses, in which case there
+   --  is no real circularity.
+
    function Spec_Is_Irrelevant
      (Spec_Unit : Unit_Number_Type;
       Body_Unit : Unit_Number_Type) return Boolean;
@@ -165,6 +170,30 @@ package body Lib.Load is
       return Unum;
    end Create_Dummy_Package_Unit;
 
+   -----------------------------
+   -- From_Limited_With_Chain --
+   -----------------------------
+
+   function From_Limited_With_Chain (Lim : Boolean) return Boolean is
+   begin
+      --  True if the current load operation is through a limited_with clause
+
+      if Lim then
+         return True;
+
+      --  Examine the Load_Stack to locate any previous Limited_with clause
+
+      elsif Load_Stack.Last - 1 > Load_Stack.First then
+         for U in Load_Stack.First .. Load_Stack.Last - 1 loop
+            if Load_Stack.Table (U).From_Limited_With then
+               return True;
+            end if;
+         end loop;
+      end if;
+
+      return False;
+   end From_Limited_With_Chain;
+
    ----------------
    -- Initialize --
    ----------------
@@ -193,7 +222,7 @@ package body Lib.Load is
 
    begin
       Load_Stack.Increment_Last;
-      Load_Stack.Table (Load_Stack.Last) := Main_Unit;
+      Load_Stack.Table (Load_Stack.Last) := (Main_Unit, False);
 
       --  Initialize unit table entry for Main_Unit. Note that we don't know
       --  the unit name yet, that gets filled in when the parser parses the
@@ -465,10 +494,11 @@ package body Lib.Load is
          end loop;
       end if;
 
-      --  If we are proceeding with load, then make load stack entry
+      --  If we are proceeding with load, then make load stack entry,
+      --  and indicate the kind of with_clause responsible for the load.
 
       Load_Stack.Increment_Last;
-      Load_Stack.Table (Load_Stack.Last) := Unum;
+      Load_Stack.Table (Load_Stack.Last) := (Unum, From_Limited_With);
 
       --  Case of entry already in table
 
@@ -489,7 +519,7 @@ package body Lib.Load is
                        or else Acts_As_Spec (Units.Table (Unum).Cunit))
            and then (Nkind (Error_Node) /= N_With_Clause
                        or else not Limited_Present (Error_Node))
-           and then not From_Limited_With
+           and then not From_Limited_With_Chain (From_Limited_With)
          then
             if Debug_Flag_L then
                Write_Str ("  circular dependency encountered");
@@ -733,8 +763,10 @@ package body Lib.Load is
 
       if Load_Stack.Last - 1 > Load_Stack.First then
          for U in Load_Stack.First .. Load_Stack.Last - 1 loop
-            Error_Msg_Unit_1 := Unit_Name (Load_Stack.Table (U));
-            Error_Msg_Unit_2 := Unit_Name (Load_Stack.Table (U + 1));
+            Error_Msg_Unit_1 :=
+              Unit_Name (Load_Stack.Table (U).Unit_Number);
+            Error_Msg_Unit_2 :=
+              Unit_Name (Load_Stack.Table (U + 1).Unit_Number);
             Error_Msg ("$ depends on $!", Load_Msg_Sloc);
          end loop;
       end if;

gcc/ada/lib.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2004 Free Software Foundation, Inc.          --
+--          Copyright (C) 1992-2005 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- --
@@ -239,11 +239,6 @@ package Lib is
    --  Main_Unit is a body with a separate spec, in which case it is the
    --  entity for the spec.
 
-   Unit_Exception_Table_Present : Boolean;
-   --  Set true if a unit exception table is present for the unit (i.e.
-   --  zero cost exception handling is active and there is at least one
-   --  subprogram in the extended unit).
-
    -----------------
    -- Units Table --
    -----------------
@@ -623,7 +618,7 @@ package Lib is
 
    function Generic_Separately_Compiled
      (Sfile : File_Name_Type) return  Boolean;
-   --  Same as the previous function, but works directly on a unit file name.
+   --  Same as the previous function, but works directly on a unit file name
 
 private
    pragma Inline (Cunit);
@@ -722,16 +717,23 @@ private
    type Unit_Ref_Table is array (Pos range <>) of Unit_Number_Type;
    --  Type to hold list of indirect references to unit number table
 
-   --  The Load_Stack table contains a list of unit numbers (indexes into the
-   --  unit table) of units being loaded on a single dependency chain. The
-   --  First entry is the main unit. The second entry, if present is a unit
-   --  on which the first unit depends, etc. This stack is used to generate
-   --  error messages showing the dependency chain if a file is not found.
-   --  The Load function makes an entry in this table when it is called, and
-   --  removes the entry just before it returns.
+   type Load_Stack_Entry is record
+      Unit_Number       : Unit_Number_Type;
+      From_Limited_With : Boolean;
+   end record;
+
+   --  The Load_Stack table contains a list of unit numbers (indices into the
+   --  unit table) of units being loaded on a single dependency chain, and a
+   --  flag to indicate whether this unit is loaded through a limited_with
+   --  clause. The First entry is the main unit. The second entry, if present
+   --  is a unit on which the first unit depends, etc. This stack is used to
+   --  generate error messages showing the dependency chain if a file is not
+   --  found, or whether a true circular dependency exists.  The Load_Unit
+   --  function makes an entry in this table when it is called, and removes
+   --  the entry just before it returns.
 
    package Load_Stack is new Table.Table (
-     Table_Component_Type => Unit_Number_Type,
+     Table_Component_Type => Load_Stack_Entry,
      Table_Index_Type     => Nat,
      Table_Low_Bound      => 0,
      Table_Initial        => Alloc.Load_Stack_Initial,