[multiple changes]

2009-04-10  Sergey Rybin  <rybin@adacore.com>

	* vms_data.ads:
	Add qualifier for new gnatstub option '--no-exception'

	* gnat_ugn.texi:
	Add the description of the new gnatstub option '--no-exception'

2009-04-10  Robert Dewar  <dewar@adacore.com>

	* rtsfind.adb: Minor reformatting

2009-04-10  Thomas Quinot  <quinot@adacore.com>

	* sem_disp.adb: Minor reformatting.
	Add comment pointing to RM clause for the case of warning against a
	(failed) attempt at declaring a primitive operation elsewhere than in a
	package spec.

2009-04-10  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch12.adb (Denotes_Formal_Package): Check whether the package is
	an actual for a previous formal package of the current instance.

From-SVN: r145917

6 files changed, 101 insertions, 17 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index d50db6c..1a645a1 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,27 @@
+2009-04-10  Sergey Rybin  <rybin@adacore.com>
+
+	* vms_data.ads:
+	Add qualifier for new gnatstub option '--no-exception'
+
+	* gnat_ugn.texi:
+	Add the description of the new gnatstub option '--no-exception'
+
+2009-04-10  Robert Dewar  <dewar@adacore.com>
+
+	* rtsfind.adb: Minor reformatting
+
+2009-04-10  Thomas Quinot  <quinot@adacore.com>
+
+	* sem_disp.adb: Minor reformatting.
+	Add comment pointing to RM clause for the case of warning against a
+	(failed) attempt at declaring a primitive operation elsewhere than in a
+	package spec.
+
+2009-04-10  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch12.adb (Denotes_Formal_Package): Check whether the package is
+	an actual for a previous formal package of the current instance.
+
 2009-04-10  Bob Duff  <duff@adacore.com>
 
 	* rtsfind.adb (RTE): Put implicit with_clauses on whatever unit needs
diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi
index f210953..f48a55f 100644
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -22066,6 +22066,11 @@ units located outside the current directory, you have to provide
 the source search path when calling @command{gnatstub}, see the description
 of @command{gnatstub} switches below.
 
+By default, all the program unit body stubs generated by @code{gnatstub}
+raise the predefined @code{Program_Error} exception, which will catch
+accidental calls of generated stubs. This behavior can be changed with
+option @option{^--no-exception^/NO_EXCEPTION^} (see below).
+
 @menu
 * Running gnatstub::
 * Switches for gnatstub::
@@ -22191,7 +22196,12 @@ structures used by @command{gnatstub}) after creating the body stub.
 @cindex @option{^-l^/LINE_LENGTH^} (@command{gnatstub})
 Same as @option{^-gnatyM^/MAX_LINE_LENGTH=^@var{n}}
 
-@item ^-o^/BODY=^@var{body-name}
+@item ^--no-exception^/NO_EXCEPTION^
+@cindex @option{^--no-exception^/NO_EXCEPTION^} (@command{gnatstub})
+Avoind raising PROGRAM_ERROR in the generated bodies of program unit stubs.
+This is not always possible for function stubs.
+
+@item ^-o ^/BODY=^@var{body-name}
 @cindex @option{^-o^/BODY^} (@command{gnatstub})
 Body file name.  This should be set if the argument file name does not
 follow
diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb
index 1ad8932..ebd8501 100644
--- a/gcc/ada/rtsfind.adb
+++ b/gcc/ada/rtsfind.adb
@@ -1069,7 +1069,7 @@ package body Rtsfind is
       --  for a call issued from RTE_Available.
 
    <<Found>>
-      if (not U.Withed) and then not RTE_Available_Call then
+      if not U.Withed and then not RTE_Available_Call then
          U.Withed := True;
 
          declare
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index 24d6b4d..739cbaf 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -424,15 +424,19 @@ package body Sem_Ch12 is
    --  illegal circular instantiation.
 
    function Denotes_Formal_Package
-     (Pack    : Entity_Id;
-      On_Exit : Boolean := False) return Boolean;
+     (Pack     : Entity_Id;
+      On_Exit  : Boolean := False;
+      Instance : Entity_Id := Empty) return Boolean;
    --  Returns True if E is a formal package of an enclosing generic, or
    --  the actual for such a formal in an enclosing instantiation. If such
    --  a package is used as a formal in an nested generic, or as an actual
    --  in a nested instantiation, the visibility of ITS formals should not
    --  be modified. When called from within Restore_Private_Views, the flag
    --  On_Exit is true, to indicate that the search for a possible enclosing
-   --  instance should ignore the current one.
+   --  instance should ignore the current one. In that case Instance denotes
+   --  the declaration for which this is an actual. This declaration may be
+   --  an instantiation in the source, or the internal instantiation that
+   --  corresponds to the actual for a formal package.
 
    function Find_Actual_Type
      (Typ       : Entity_Id;
@@ -6130,13 +6134,46 @@ package body Sem_Ch12 is
    ----------------------------
 
    function Denotes_Formal_Package
-     (Pack    : Entity_Id;
-      On_Exit : Boolean := False) return Boolean
+     (Pack     : Entity_Id;
+      On_Exit  : Boolean := False;
+      Instance : Entity_Id := Empty) return Boolean
    is
       Par  : Entity_Id;
       Scop : constant Entity_Id := Scope (Pack);
       E    : Entity_Id;
 
+      function Is_Actual_Of_Previous_Formal (P : Entity_Id) return Boolean;
+      --  The package in question may be an actual for a previous formal
+      --  package P of the current instance, so examine its actuals as well.
+
+      ----------------------------------
+      -- Is_Actual_Of_Previous_Formal --
+      ----------------------------------
+
+      function Is_Actual_Of_Previous_Formal (P : Entity_Id) return Boolean is
+         E1 : Entity_Id;
+
+      begin
+         E1 := First_Entity (E);
+         while Present (E1) and then  E1 /= Instance loop
+            if Ekind (E1) = E_Package
+              and then Nkind (Parent (E1)) = N_Package_Renaming_Declaration
+              and then Renamed_Object (E1) = Pack
+            then
+               return True;
+
+            elsif Renamed_Object (E1) = P then
+               return False;
+            end if;
+
+            Next_Entity (E1);
+         end loop;
+
+         return False;
+      end Is_Actual_Of_Previous_Formal;
+
+   --  Start processing of Denotes_Formal_Package
+
    begin
       if On_Exit then
          Par :=
@@ -6176,6 +6213,10 @@ package body Sem_Ch12 is
 
             elsif Renamed_Object (E) = Pack then
                return True;
+
+            elsif Is_Actual_Of_Previous_Formal (E) then
+               return True;
+
             end if;
 
             Next_Entity (E);
@@ -11142,7 +11183,9 @@ package body Sem_Ch12 is
             elsif Nkind (Parent (E)) /= N_Package_Renaming_Declaration then
                null;
 
-            elsif Denotes_Formal_Package (Renamed_Object (E), True) then
+            elsif
+              Denotes_Formal_Package (Renamed_Object (E), True, Pack_Id)
+            then
                Set_Is_Hidden (E, False);
 
             else
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index 40778dd..a1faa3f 100644
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -764,11 +764,10 @@ package body Sem_Disp is
                   --  be delayed until after the spec is seen, but that's
                   --  a tricky change to the delicate freezing code.
 
-                  --  Look at each declaration following the type up
-                  --  until the new subprogram body. If any of the
-                  --  declarations is a body then the type has been
-                  --  frozen already so the overriding primitive is
-                  --  illegal.
+                  --  Look at each declaration following the type up until the
+                  --  new subprogram body. If any of the declarations is a body
+                  --  then the type has been frozen already so the overriding
+                  --  primitive is illegal.
 
                   while Present (Decl_Item)
                     and then (Decl_Item /= Subp_Body)
@@ -788,9 +787,8 @@ package body Sem_Disp is
                   end loop;
 
                   --  If the subprogram doesn't follow in the list of
-                  --  declarations including the type then the type
-                  --  has definitely been frozen already and the body
-                  --  is illegal.
+                  --  declarations including the type then the type has
+                  --  definitely been frozen already and the body is illegal.
 
                   if No (Decl_Item) then
                      Error_Msg_N ("overriding of& is too late!", Subp);
@@ -852,7 +850,8 @@ package body Sem_Disp is
 
          --  If the type is not frozen yet and we are not in the overriding
          --  case it looks suspiciously like an attempt to define a primitive
-         --  operation.
+         --  operation, which requires the declaration to be in a package spec
+         --  (3.2.3(6)).
 
          elsif not Is_Frozen (Tagged_Type) then
             Error_Msg_N
diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads
index 595fa5e..21529e0 100644
--- a/gcc/ada/vms_data.ads
+++ b/gcc/ada/vms_data.ads
@@ -6511,6 +6511,13 @@ package VMS_Data is
    --      HIGH         A great number of messages are output, most of them not
    --                   being useful for the user.
 
+   S_Stub_No_Exc  : aliased constant S := "/NO_EXCEPTION "                 &
+                                          "--no-exception";
+   --        /NONO_EXCEPTION (D)
+   --        /NO_EXCEPTION
+   --
+   --  Avoid raising PROGRAM_ERROR in the generated program unit stubs.
+
    S_Stub_Output  : aliased constant S := "/OUTPUT=@"                      &
                                             "-o@";
    --        /OUTPUT=filespec
@@ -6607,6 +6614,7 @@ package VMS_Data is
                       S_Stub_Mess       'Access,
                       S_Stub_Output     'Access,
                       S_Stub_Project    'Access,
+                      S_Stub_No_Exc     'Access,
                       S_Stub_Quiet      'Access,
                       S_Stub_Search     'Access,
                       S_Stub_Subdirs    'Access,