[multiple changes]

2011-08-29  Yannick Moy  <moy@adacore.com>

	* sem_ch13.adb (Analyze_Aspect_Specifications): Reject test-case on
	library-level subprogram.
	* sem_prag.adb (Check_Test_Case): Stricter rules for test-case
	placement.
	(Analyze_Pragma): Change name "Normal" for "Nominal" in test-case
	component.
	* snames.ads-tmpl: Change name "Normal" for "Nominal" in test-case
	component.
	* gnat_rm.texi: Update doc for Test_Case pragma.

2011-08-29  Tristan Gingold  <gingold@adacore.com>

	* a-exexpr-gcc.adb (Unwind_Exception): Remove default value, made it
	convention C.
	(GCC_Exception_Access): New type.
	(Unwind_DeleteException): New imported procedure
	(Foreign_Exception): Import it.
	(GNAT_GCC_Exception): Simply have the occurrence inside.
	(To_GCC_Exception): New function.
	(To_GNAT_GCC_Exception): New function.
	(GNAT_GCC_Exception_Cleanup): New procedure..
	(Propagate_GCC_Exception): New procedure.
	(Reraise_GCC_Exception): New procedure.
	(Setup_Current_Excep): New procedure.
	(CleanupUnwind_Handler): Change type of UW_Exception parameter.
	(Unwind_RaiseException): Ditto.
	(Unwind_ForcedUnwind): Ditto.
	(Remove): Removed.
	(Begin_Handler): Change type of parameter.
	(End_Handler): Ditto. Now delete the exception if still present.
	(Setup_Key): Removed.
	(Is_Setup_And_Not_Propagated): Removed.
	(Set_Setup_And_Not_Propagated): Ditto.
	(Clear_Setup_And_Not_Propagated): Ditto.
	(Save_Occurrence_And_Private): Ditto.
	(EID_For): Add 'not null' constraint on parameter.
	(Setup_Exception): Does nothing.
	(Propagate_Exception): Simplified.
	* exp_ch11.adb (Expand_N_Raise_Statement): In back-end exception model,
	re-raise is not expanded anymore.
	* s-except.ads (Foreign_Exception): New exception - placeholder for
	non Ada exceptions.
	* raise-gcc.c (__gnat_setup_current_excep): Declare
	(CXX_EXCEPTION_CLASS): Define (not yet used)
	(GNAT_EXCEPTION_CLASS): Define.
	(is_handled_by): Handle foreign exceptions.
	(PERSONALITY_FUNCTION): Call __gnat_setup_current_excep.

2011-08-29  Jose Ruiz  <ruiz@adacore.com>

	* a-synbar.adb (Synchronous_Barrier): Some additional clarification.

From-SVN: r178204

gcc/ada/ChangeLog

+2011-08-29  Yannick Moy  <moy@adacore.com>
+
+	* sem_ch13.adb (Analyze_Aspect_Specifications): Reject test-case on
+	library-level subprogram.
+	* sem_prag.adb (Check_Test_Case): Stricter rules for test-case
+	placement.
+	(Analyze_Pragma): Change name "Normal" for "Nominal" in test-case
+	component.
+	* snames.ads-tmpl: Change name "Normal" for "Nominal" in test-case
+	component.
+	* gnat_rm.texi: Update doc for Test_Case pragma.
+
+2011-08-29  Tristan Gingold  <gingold@adacore.com>
+
+	* a-exexpr-gcc.adb (Unwind_Exception): Remove default value, made it
+	convention C.
+	(GCC_Exception_Access): New type.
+	(Unwind_DeleteException): New imported procedure
+	(Foreign_Exception): Import it.
+	(GNAT_GCC_Exception): Simply have the occurrence inside.
+	(To_GCC_Exception): New function.
+	(To_GNAT_GCC_Exception): New function.
+	(GNAT_GCC_Exception_Cleanup): New procedure..
+	(Propagate_GCC_Exception): New procedure.
+	(Reraise_GCC_Exception): New procedure.
+	(Setup_Current_Excep): New procedure.
+	(CleanupUnwind_Handler): Change type of UW_Exception parameter.
+	(Unwind_RaiseException): Ditto.
+	(Unwind_ForcedUnwind): Ditto.
+	(Remove): Removed.
+	(Begin_Handler): Change type of parameter.
+	(End_Handler): Ditto. Now delete the exception if still present.
+	(Setup_Key): Removed.
+	(Is_Setup_And_Not_Propagated): Removed.
+	(Set_Setup_And_Not_Propagated): Ditto.
+	(Clear_Setup_And_Not_Propagated): Ditto.
+	(Save_Occurrence_And_Private): Ditto.
+	(EID_For): Add 'not null' constraint on parameter.
+	(Setup_Exception): Does nothing.
+	(Propagate_Exception): Simplified.
+	* exp_ch11.adb (Expand_N_Raise_Statement): In back-end exception model,
+	re-raise is not expanded anymore.
+	* s-except.ads (Foreign_Exception): New exception - placeholder for
+	non Ada exceptions.
+	* raise-gcc.c (__gnat_setup_current_excep): Declare
+	(CXX_EXCEPTION_CLASS): Define (not yet used)
+	(GNAT_EXCEPTION_CLASS): Define.
+	(is_handled_by): Handle foreign exceptions.
+	(PERSONALITY_FUNCTION): Call __gnat_setup_current_excep.
+
+2011-08-29  Jose Ruiz  <ruiz@adacore.com>
+
+	* a-synbar.adb (Synchronous_Barrier): Some additional clarification.
+
 2011-08-29  Thomas Quinot  <quinot@adacore.com>
 
 	* a-synbar-posix.adb: Minor reformatting.

gcc/ada/a-synbar.adb

@@ -40,8 +40,11 @@ package body Ada.Synchronous_Barriers is
       --  The condition "Wait'Count = Release_Threshold" opens the barrier when
       --  the required number of tasks is reached. The condition "Keep_Open"
       --  leaves the barrier open while there are queued tasks. While there are
-      --  tasks in the queue no new task will be queued, guaranteeing that the
-      --  barrier will remain open only for those tasks already inside.
+      --  tasks in the queue no new task will be queued (no new protected
+      --  action can be started on a protected object while another protected
+      --  action on the same protected object is underway, RM 9.5.1 (4)),
+      --  guaranteeing that the barrier will remain open only for those tasks
+      --  already inside the queue when the barrier was open.
 
       entry Wait (Notified : out Boolean)
         when Keep_Open or else Wait'Count = Release_Threshold

gcc/ada/exp_ch11.adb

@@ -1665,6 +1665,15 @@ package body Exp_Ch11 is
       --  does not have a choice parameter specification, then we provide one.
 
       else
+
+         --  Don't expand if back end exception handling active
+
+         if VM_Target = No_VM
+           and then Exception_Mechanism = Back_End_Exceptions
+         then
+            return;
+         end if;
+
          --  Find innermost enclosing exception handler (there must be one,
          --  since the semantics has already verified that this raise statement
          --  is valid, and a raise with no arguments is only permitted in the

gcc/ada/gnat_rm.texi

@@ -5074,23 +5074,23 @@ Syntax:
 @smallexample @c ada
 pragma Test_Case (
    [Name     =>] static_string_Expression
-  ,[Mode     =>] (Normal | Robustness)
+  ,[Mode     =>] (Nominal | Robustness)
  [, Requires =>  Boolean_Expression]
  [, Ensures  =>  Boolean_Expression]);
 @end smallexample
 
 @noindent
 The @code{Test_Case} pragma allows defining fine-grain specifications
-for use by testing and verification tools. The compiler only checks its
+for use by testing and verification tools. The compiler checks its
 validity but the presence of pragma @code{Test_Case} does not lead to
 any modification of the code generated by the compiler.
 
 @code{Test_Case} pragmas may only appear immediately following the
-(separate) declaration of a subprogram. Only other pragmas may intervene
-(that is appear between the subprogram declaration and its
-postconditions).
+(separate) declaration of a subprogram in a package declaration, inside
+a package spec unit. Only other pragmas may intervene (that is appear
+between the subprogram declaration and a test case).
 
-The compiler checks that boolean expression given in @code{Requires} and
+The compiler checks that boolean expressions given in @code{Requires} and
 @code{Ensures} are valid, where the rules for @code{Requires} are the
 same as the rule for an expression in @code{Precondition} and the rules
 for @code{Ensures} are the same as the rule for an expression in
@@ -5103,7 +5103,7 @@ package Math_Functions is
    ...
    function Sqrt (Arg : Float) return Float;
    pragma Test_Case (Name     => "Test 1",
-                     Mode     => Normal,
+                     Mode     => Nominal,
                      Requires => Arg < 100,
                      Ensures  => Sqrt'Result < 10);
    ...
@@ -5113,10 +5113,10 @@ end Math_Functions;
 @noindent
 The meaning of a test case is that, if the associated subprogram is
 executed in a context where @code{Requires} holds, then @code{Ensures}
-should hold when the subprogram returns. Mode @code{Normal} indicates
-that the input context should satisfy the normal precondition of the
+should hold when the subprogram returns. Mode @code{Nominal} indicates
+that the input context should satisfy the precondition of the
 subprogram, and the output context should then satisfy its
-postcondition. More @code{Robustness} indicates that the normal pre- and
+postcondition. More @code{Robustness} indicates that the pre- and
 postcondition of the subprogram should be ignored for this test case.
 
 @node Pragma Thread_Local_Storage

gcc/ada/raise-gcc.c

@@ -101,6 +101,7 @@ __gnat_Unwind_RaiseException (_Unwind_Exception *);
 _Unwind_Reason_Code
 __gnat_Unwind_ForcedUnwind (_Unwind_Exception *, void *, void *);
 
+extern void __gnat_setup_current_excep (_Unwind_Exception *);
 
 #ifdef IN_RTS   /* For eh personality routine */
 
@@ -108,6 +109,10 @@ __gnat_Unwind_ForcedUnwind (_Unwind_Exception *, void *, void *);
 #include "unwind-dw2-fde.h"
 #include "unwind-pe.h"
 
+/* The known and handled exception classes.  */
+
+#define CXX_EXCEPTION_CLASS 0x474e5543432b2b00ULL
+#define GNAT_EXCEPTION_CLASS 0x474e552d41646100ULL
 
 /* --------------------------------------------------------------
    -- The DB stuff below is there for debugging purposes only. --
@@ -853,39 +858,51 @@ extern Exception_Id EID_For (_GNAT_Exception * e);
 static int
 is_handled_by (_Unwind_Ptr choice, _GNAT_Exception * propagated_exception)
 {
-  /* Pointer to the GNAT exception data corresponding to the propagated
-     occurrence.  */
-  _Unwind_Ptr E = (_Unwind_Ptr) EID_For (propagated_exception);
-
-  /* Base matching rules: An exception data (id) matches itself, "when
-     all_others" matches anything and "when others" matches anything unless
-     explicitly stated otherwise in the propagated occurrence.  */
-
-  bool is_handled =
-    choice == E
-    || choice == GNAT_ALL_OTHERS
-    || (choice == GNAT_OTHERS && Is_Handled_By_Others (E));
-
-  /* In addition, on OpenVMS, Non_Ada_Error matches VMS exceptions, and we
-     may have different exception data pointers that should match for the
-     same condition code, if both an export and an import have been
-     registered.  The import code for both the choice and the propagated
-     occurrence are expected to have been masked off regarding severity
-     bits already (at registration time for the former and from within the
-     low level exception vector for the latter).  */
+  if (propagated_exception->common.exception_class == GNAT_EXCEPTION_CLASS)
+    {
+      /* Pointer to the GNAT exception data corresponding to the propagated
+         occurrence.  */
+      _Unwind_Ptr E = (_Unwind_Ptr) EID_For (propagated_exception);
+
+      /* Base matching rules: An exception data (id) matches itself, "when
+         all_others" matches anything and "when others" matches anything
+         unless explicitly stated otherwise in the propagated occurrence.  */
+
+      bool is_handled =
+        choice == E
+        || choice == GNAT_ALL_OTHERS
+        || (choice == GNAT_OTHERS && Is_Handled_By_Others (E));
+
+      /* In addition, on OpenVMS, Non_Ada_Error matches VMS exceptions, and we
+         may have different exception data pointers that should match for the
+         same condition code, if both an export and an import have been
+         registered.  The import code for both the choice and the propagated
+         occurrence are expected to have been masked off regarding severity
+         bits already (at registration time for the former and from within the
+         low level exception vector for the latter).  */
 #ifdef VMS
-  #define Non_Ada_Error system__aux_dec__non_ada_error
-  extern struct Exception_Data Non_Ada_Error;
-
-  is_handled |=
-    (Language_For (E) == 'V'
-     && choice != GNAT_OTHERS && choice != GNAT_ALL_OTHERS
-     && ((Language_For (choice) == 'V' && Import_Code_For (choice) != 0
-	  && Import_Code_For (choice) == Import_Code_For (E))
-	 || choice == (_Unwind_Ptr)&Non_Ada_Error));
+#     define Non_Ada_Error system__aux_dec__non_ada_error
+      extern struct Exception_Data Non_Ada_Error;
+
+      is_handled |=
+        (Language_For (E) == 'V'
+         && choice != GNAT_OTHERS && choice != GNAT_ALL_OTHERS
+         && ((Language_For (choice) == 'V' && Import_Code_For (choice) != 0
+              && Import_Code_For (choice) == Import_Code_For (E))
+             || choice == (_Unwind_Ptr)&Non_Ada_Error));
 #endif
 
-  return is_handled;
+      return is_handled;
+    }
+  else
+    {
+#     define Foreign_Exception system__exceptions__foreign_exception;
+      extern struct Exception_Data Foreign_Exception;
+
+      return choice == GNAT_ALL_OTHERS
+        || choice == GNAT_OTHERS
+        || choice == (_Unwind_Ptr)&Foreign_Exception;
+    }
 }
 
 /* Fill out the ACTION to be taken from propagating UW_EXCEPTION up to
@@ -1079,9 +1096,6 @@ PERSONALITY_FUNCTION (version_arg_t version_arg,
      Condition Handling Facility.  */
   int uw_version = (int) version_arg;
   _Unwind_Action uw_phases = (_Unwind_Action) phases_arg;
-
-  _GNAT_Exception * gnat_exception = (_GNAT_Exception *) uw_exception;
-
   region_descriptor region;
   action_descriptor action;
 
@@ -1089,7 +1103,7 @@ PERSONALITY_FUNCTION (version_arg_t version_arg,
      possible variation on VMS for IA64.  */
   if (uw_version != 1)
     {
-      #if defined (VMS) && defined (__IA64)
+#if defined (VMS) && defined (__IA64)
 
       /* Assume we're called with sigargs/mechargs arguments if really
 	 unexpected bits are set in our first two formals.  Redirect to the
@@ -1103,7 +1117,7 @@ PERSONALITY_FUNCTION (version_arg_t version_arg,
       if ((unsigned int)uw_version & version_unexpected_bits_mask
 	  && (unsigned int)uw_phases & phases_unexpected_bits_mask)
 	return __gnat_handle_vms_condition (version_arg, phases_arg);
-      #endif
+#endif
 
       return _URC_FATAL_PHASE1_ERROR;
     }
@@ -1160,6 +1174,9 @@ PERSONALITY_FUNCTION (version_arg_t version_arg,
   setup_to_install
     (uw_context, uw_exception, action.landing_pad, action.ttype_filter);
 
+  /* Write current exception, so that it can be retrieved from Ada.  */
+  __gnat_setup_current_excep (uw_exception);
+
   return _URC_INSTALL_CONTEXT;
 }
 

gcc/ada/s-except.ads

@@ -81,4 +81,9 @@ package System.Exceptions is
 private
    ZCX_By_Default : constant Boolean := System.ZCX_By_Default;
 
+   Foreign_Exception : exception;
+   pragma Unreferenced (Foreign_Exception);
+   --  This hidden exception is used to represent non-Ada exception to
+   --  Ada handlers. It is in fact referenced by its linking name.
+
 end System.Exceptions;

gcc/ada/sem_ch13.adb

@@ -1365,6 +1365,12 @@ package body Sem_Ch13 is
                begin
                   Args := New_List;
 
+                  if Nkind (Parent (N)) = N_Compilation_Unit then
+                     Error_Msg_N
+                       ("incorrect placement of aspect `Test_Case`", E);
+                     goto Continue;
+                  end if;
+
                   if Nkind (Expr) /= N_Aggregate then
                      Error_Msg_NE
                        ("wrong syntax for aspect `Test_Case` for &", Id, E);

gcc/ada/sem_prag.adb

@@ -500,24 +500,13 @@ package body Sem_Prag is
 
       procedure Check_Test_Case;
       --  Called to process a test-case pragma. The treatment is similar to the
-      --  one for pre- and postcondition in Check_Precondition_Postcondition.
-      --  There are three cases:
-      --
-      --    The pragma appears after a subprogram spec
-      --
-      --      The first step is to analyze the pragma, but this is skipped if
-      --      the subprogram spec appears within a package specification
-      --      (because this is the case where we delay analysis till the end of
-      --      the spec). Then (whether or not it was analyzed), the pragma is
-      --      chained to the subprogram in question (using Spec_TC_List and
-      --      Next_Pragma).
-      --
-      --    The pragma appears at the start of subprogram body declarations
-      --
-      --      In this case an immediate return to the caller is made, and the
-      --      pragma is NOT analyzed.
-      --
-      --    In all other cases, an error message for bad placement is given
+      --  one for pre- and postcondition in Check_Precondition_Postcondition,
+      --  except the placement rules for the test-case pragma are stricter.
+      --  This pragma may only occur after a subprogram spec declared directly
+      --  in a package spec unit. In this case, the pragma is chained to the
+      --  subprogram in question (using Spec_TC_List and Next_Pragma) and
+      --  analysis of the pragma is delayed till the end of the spec. In
+      --  all other cases, an error message for bad placement is given.
 
       procedure Check_Valid_Configuration_Pragma;
       --  Legality checks for placement of a configuration pragma
@@ -1972,9 +1961,9 @@ package body Sem_Prag is
          PO : Node_Id;
 
          procedure Chain_TC (PO : Node_Id);
-         --  If PO is an entry or a [generic] subprogram declaration node, then
-         --  the test-case applies to this subprogram and the processing for
-         --  the pragma is completed. Otherwise the pragma is misplaced.
+         --  If PO is a [generic] subprogram declaration node, then the
+         --  test-case applies to this subprogram and the processing for the
+         --  pragma is completed. Otherwise the pragma is misplaced.
 
          --------------
          -- Chain_TC --
@@ -1993,20 +1982,22 @@ package body Sem_Prag is
                     ("pragma% cannot be applied to abstract subprogram");
                end if;
 
+            elsif Nkind (PO) = N_Entry_Declaration then
+               if From_Aspect_Specification (N) then
+                  Error_Pragma ("aspect% cannot be applied to entry");
+               else
+                  Error_Pragma ("pragma% cannot be applied to entry");
+               end if;
+
             elsif not Nkind_In (PO, N_Subprogram_Declaration,
-                                    N_Generic_Subprogram_Declaration,
-                                    N_Entry_Declaration)
+                                    N_Generic_Subprogram_Declaration)
             then
                Pragma_Misplaced;
             end if;
 
-            --  Here if we have [generic] subprogram or entry declaration
+            --  Here if we have [generic] subprogram declaration
 
-            if Nkind (PO) = N_Entry_Declaration then
-               S := Defining_Entity (PO);
-            else
-               S := Defining_Unit_Name (Specification (PO));
-            end if;
+            S := Defining_Unit_Name (Specification (PO));
 
             --  Note: we do not analyze the pragma at this point. Instead we
             --  delay this analysis until the end of the declarative part in
@@ -2054,6 +2045,16 @@ package body Sem_Prag is
             Pragma_Misplaced;
          end if;
 
+         --  Test cases should only appear in package spec unit
+
+         if Get_Source_Unit (N) = No_Unit
+           or else not Nkind_In (Sinfo.Unit (Cunit (Get_Source_Unit (N))),
+                                 N_Package_Declaration,
+                                 N_Generic_Package_Declaration)
+         then
+            Pragma_Misplaced;
+         end if;
+
          --  Search prior declarations
 
          P := N;
@@ -2082,7 +2083,18 @@ package body Sem_Prag is
             elsif not Comes_From_Source (PO) then
                null;
 
-            --  Only remaining possibility is subprogram declaration
+            --  Only remaining possibility is subprogram declaration. First
+            --  check that it is declared directly in a package declaration.
+            --  This may be either the package declaration for the current unit
+            --  being defined or a local package declaration.
+
+            elsif not Present (Parent (Parent (PO)))
+              or else not Present (Parent (Parent (Parent (PO))))
+              or else not Nkind_In (Parent (Parent (PO)),
+                                    N_Package_Declaration,
+                                    N_Generic_Package_Declaration)
+            then
+               Pragma_Misplaced;
 
             else
                Chain_TC (PO);
@@ -2090,14 +2102,6 @@ package body Sem_Prag is
             end if;
          end loop;
 
-         --  If we fall through loop, pragma is at start of list, so see if it
-         --  is in the pragmas after a library level subprogram.
-
-         if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
-            Chain_TC (Unit (Parent (Parent (N))));
-            return;
-         end if;
-
          --  If we fall through, pragma was misplaced
 
          Pragma_Misplaced;
@@ -13301,7 +13305,7 @@ package body Sem_Prag is
          --                  [, Requires =>  Boolean_EXPRESSION]
          --                  [, Ensures  =>  Boolean_EXPRESSION]);
 
-         --  MODE_TYPE ::= Normal | Robustness
+         --  MODE_TYPE ::= Nominal | Robustness
 
          when Pragma_Test_Case => Test_Case : declare
          begin
@@ -13314,7 +13318,7 @@ package body Sem_Prag is
             Check_Optional_Identifier (Arg1, Name_Name);
             Check_Arg_Is_Static_Expression (Arg1, Standard_String);
             Check_Optional_Identifier (Arg2, Name_Mode);
-            Check_Arg_Is_One_Of (Arg2, Name_Normal, Name_Robustness);
+            Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
 
             if Arg_Count = 4 then
                Check_Identifier (Arg3, Name_Requires);

gcc/ada/snames.ads-tmpl

@@ -661,7 +661,7 @@ package Snames is
    Name_No_Requeue_Statements          : constant Name_Id := N + $;
    Name_No_Task_Attributes             : constant Name_Id := N + $;
    Name_No_Task_Attributes_Package     : constant Name_Id := N + $;
-   Name_Normal                         : constant Name_Id := N + $;
+   Name_Nominal                        : constant Name_Id := N + $;
    Name_On                             : constant Name_Id := N + $;
    Name_Policy                         : constant Name_Id := N + $;
    Name_Parameter_Types                : constant Name_Id := N + $;