gnat_rm.texi: Document new mechanism Short_Descriptor.

2008-08-01  Doug Rupp  <rupp@adacore.com>

	* gnat_rm.texi: Document new mechanism Short_Descriptor.
	
	* types.ads (Mechanism_Type): Modify range for new Short_Descriptor
	mechanism values.

	* sem_prag.adb (Set_Mechanism_Value): Enhance for Short_Descriptor
	mechanism and Short_Descriptor mechanism values.

	* snames.adb (preset_names): Add short_descriptor entry.

	* snames.ads: Add Name_Short_Descriptor.

	* types.h: Add new By_Short_Descriptor mechanism values.

	* sem_mech.adb (Set_Mechanism_Value): Enhance for Short_Descriptor
	mechanism and Short_Descriptor mechanism values.

	* sem_mech.ads (Mechanism_Type): Add new By_Short_Descriptor mechanism
	values.
	(Descriptor_Codes): Modify range for new mechanism values.

	* treepr.adb (Print_Entity_Enfo): Handle new By_Short_Descriptor
	mechanism values.

	* gcc-interface/decl.c (gnat_to_gnu_entity): Handle By_Short_Descriptor.
	(gnat_to_gnu_param): Handle By_Short_Descriptor.

	* gcc-interface/gigi.h (build_vms_descriptor64): Remove prototype.
	(build_vms_descriptor32): New prototype.
	(fill_vms_descriptor): Remove unneeded gnat_actual parameter.

	* gcc-interface/trans.c (call_to_gnu): Removed unneeded gnat_actual
	argument in call fill_vms_descriptor.

	* gcc-interface/utils.c (build_vms_descriptor32): Renamed from
	build_vms_descriptor and enhanced to hande Short_Descriptor mechanism.
	(build_vms_descriptor): Renamed from build_vms_descriptor64. 
	(convert_vms_descriptor32): New function.
	(convert_vms_descriptor64): New function.
	(convert_vms_descriptor): Rewrite to handle both 32bit and 64bit
	descriptors.

	* gcc-interface/utils2.c (fill_vms_descriptor): Revert previous changes,
	no longer needed.

From-SVN: r138473

gcc/ada/gcc-interface/decl.c

@@ -3872,6 +3872,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 	      ;
 	    else if (By_Descriptor_Last <= mech && mech <= By_Descriptor)
 	      mech = By_Descriptor;
+
+	    else if (By_Short_Descriptor_Last <= mech &&
+                     mech <= By_Short_Descriptor)
+	      mech = By_Short_Descriptor;
+
 	    else if (mech > 0)
 	      {
 		if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE
@@ -3913,7 +3918,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 		      = chainon (gnu_param, gnu_stub_param_list);
 		    /* Change By_Descriptor parameter to By_Reference for
 		       the internal version of an exported subprogram.  */
-		    if (mech == By_Descriptor)
+		    if (mech == By_Descriptor || mech == By_Short_Descriptor)
 		      {
 			gnu_param
 			  = gnat_to_gnu_param (gnat_param, By_Reference,
@@ -4828,11 +4833,11 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
 
   /* VMS descriptors are themselves passed by reference.
      Build both a 32bit and 64bit descriptor, one of which will be chosen
-     in fill_vms_descriptor based on the allocator size */
+     in fill_vms_descriptor. */
   if (mech == By_Descriptor)
     {
       gnu_param_type_alt
-        = build_pointer_type (build_vms_descriptor64 (gnu_param_type,
+        = build_pointer_type (build_vms_descriptor32 (gnu_param_type,
 						      Mechanism (gnat_param),
 						      gnat_subprog));
       gnu_param_type
@@ -4840,6 +4845,15 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
 						    Mechanism (gnat_param),
 						    gnat_subprog));
     }
+  else if (mech == By_Short_Descriptor)
+    {
+      gnu_param_type_alt = NULL_TREE;
+
+      gnu_param_type
+        = build_pointer_type (build_vms_descriptor32 (gnu_param_type,
+						    Mechanism (gnat_param),
+						    gnat_subprog));
+    }
 
   /* Arrays are passed as pointers to element type for foreign conventions.  */
   else if (foreign
@@ -4920,6 +4934,7 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
       && !by_ref
       && (by_return
 	  || (mech != By_Descriptor
+              && mech != By_Short_Descriptor
 	      && !POINTER_TYPE_P (gnu_param_type)
 	      && !AGGREGATE_TYPE_P (gnu_param_type)))
       && !(Is_Array_Type (Etype (gnat_param))
@@ -4931,11 +4946,12 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
 				 ro_param || by_ref || by_component_ptr);
   DECL_BY_REF_P (gnu_param) = by_ref;
   DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr;
-  DECL_BY_DESCRIPTOR_P (gnu_param) = (mech == By_Descriptor);
+  DECL_BY_DESCRIPTOR_P (gnu_param) = (mech == By_Descriptor ||
+                                      mech == By_Short_Descriptor);
   DECL_POINTS_TO_READONLY_P (gnu_param)
     = (ro_param && (by_ref || by_component_ptr));
 
-  /* Save the 64bit descriptor for later. */
+  /* Save the alternate descriptor for later. */
   SET_DECL_PARM_ALT (gnu_param, gnu_param_type_alt);
 
   /* If no Mechanism was specified, indicate what we're using, then

gcc/ada/gcc-interface/gigi.h

@@ -683,7 +683,7 @@ extern void end_subprog_body (tree body, bool elab_p);
    Return a constructor for the template.  */
 extern tree build_template (tree template_type, tree array_type, tree expr);
 
-/* Build a 32bit VMS descriptor from a Mechanism_Type, which must specify
+/* Build a 64bit VMS descriptor from a Mechanism_Type, which must specify
    a descriptor type, and the GCC type of an object.  Each FIELD_DECL
    in the type contains in its DECL_INITIAL the expression to use when
    a constructor is made for the type.  GNAT_ENTITY is a gnat node used
@@ -692,8 +692,8 @@ extern tree build_template (tree template_type, tree array_type, tree expr);
 extern tree build_vms_descriptor (tree type, Mechanism_Type mech,
                                   Entity_Id gnat_entity);
 
-/* Build a 64bit VMS descriptor from a Mechanism_Type. See above. */
-extern tree build_vms_descriptor64 (tree type, Mechanism_Type mech,
+/* Build a 32bit VMS descriptor from a Mechanism_Type. See above. */
+extern tree build_vms_descriptor32 (tree type, Mechanism_Type mech,
                                   Entity_Id gnat_entity);
 
 /* Build a stub for the subprogram specified by the GCC tree GNU_SUBPROG
@@ -853,9 +853,8 @@ extern tree build_allocator (tree type, tree init, tree result_type,
                              Node_Id gnat_node, bool);
 
 /* Fill in a VMS descriptor for EXPR and return a constructor for it.
-   GNAT_FORMAL is how we find the descriptor record. GNAT_ACTUAL is how we
-   find the size of the allocator. */
-extern tree fill_vms_descriptor (tree expr, Entity_Id gnat_formal, Node_Id gnat_actual);
+   GNAT_FORMAL is how we find the descriptor record. */
+extern tree fill_vms_descriptor (tree expr, Entity_Id gnat_formal);
 
 /* Indicate that we need to make the address of EXPR_NODE and it therefore
    should not be allocated in a register.  Return true if successful.  */

gcc/ada/gcc-interface/trans.c

@@ -2392,8 +2392,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target)
 	  else
 	    gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE,
 					 fill_vms_descriptor (gnu_actual,
-							      gnat_formal,
-							      gnat_actual));
+							      gnat_formal));
 	}
       else
 	{
@@ -5910,7 +5909,7 @@ build_unary_op_trapv (enum tree_code code,
 {
   gcc_assert ((code == NEGATE_EXPR) || (code == ABS_EXPR));
 
-  operand = save_expr (operand);
+  operand = protect_multiple_eval (operand);
 
   return emit_check (build_binary_op (EQ_EXPR, integer_type_node,
 				      operand, TYPE_MIN_VALUE (gnu_type)),
@@ -5929,8 +5928,8 @@ build_binary_op_trapv (enum tree_code code,
 		       tree left,
 		       tree right)
 {
-  tree lhs = save_expr (left);
-  tree rhs = save_expr (right);
+  tree lhs = protect_multiple_eval (left);
+  tree rhs = protect_multiple_eval (right);
   tree type_max = TYPE_MAX_VALUE (gnu_type);
   tree type_min = TYPE_MIN_VALUE (gnu_type);
   tree gnu_expr;

gcc/ada/gcc-interface/utils2.c

@@ -2156,37 +2156,13 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
    alternate 64bit descriptor. */
 
 tree
-fill_vms_descriptor (tree expr, Entity_Id gnat_formal, Node_Id gnat_actual)
+fill_vms_descriptor (tree expr, Entity_Id gnat_formal)
 {
   tree field;
   tree parm_decl = get_gnu_tree (gnat_formal);
   tree const_list = NULL_TREE;
-  int size;
   tree record_type;
 
-  /* A string literal will always be in 32bit space on VMS. Where
-     will it be on other 64bit systems???
-     An identifier's allocation may be unknown at compile time.
-     An explicit dereference could be either in 32bit or 64bit space.
-     Don't know about other possibilities, so assume unknown which
-     will result in fetching the 64bit descriptor. ??? */
-  if (Nkind (gnat_actual) == N_String_Literal)
-    size = 32;
-  else if (Nkind (gnat_actual) == N_Identifier)
-    size = UI_To_Int (Esize (Etype (gnat_actual)));
-  else if (Nkind (gnat_actual) == N_Explicit_Dereference)
-    size = UI_To_Int (Esize (Etype (Prefix (gnat_actual))));
-  else
-    size = 0;
-
-  /* If size is unknown, make it POINTER_SIZE */
-  if (size == 0)
-    size = POINTER_SIZE;
-
-  /* If size is 64bits grab the alternate 64bit descriptor. */
-  if (size == 64)
-    TREE_TYPE (parm_decl) = DECL_PARM_ALT (parm_decl);
-
   record_type = TREE_TYPE (TREE_TYPE (parm_decl));
   expr = maybe_unconstrained_array (expr);
   gnat_mark_addressable (expr);

gcc/ada/gnat_rm.texi

@@ -1852,6 +1852,7 @@ MECHANISM_NAME ::=
   Value
 | Reference
 | Descriptor [([Class =>] CLASS_NAME)]
+| Short_Descriptor [([Class =>] CLASS_NAME)]
 
 CLASS_NAME ::= ubs | ubsb | uba | s | sb | a
 @end smallexample
@@ -1884,6 +1885,9 @@ anonymous access parameter.
 @cindex OpenVMS
 @cindex Passing by descriptor
 Passing by descriptor is supported only on the OpenVMS ports of GNAT@.
+The default behavior for Export_Function is to accept either 64bit or
+32bit descriptors unless short_descriptor is specified, then only 32bit
+descriptors are accepted.
 
 @cindex Suppressing external name
 Special treatment is given if the EXTERNAL is an explicit null
@@ -1953,6 +1957,7 @@ MECHANISM_NAME ::=
   Value
 | Reference
 | Descriptor [([Class =>] CLASS_NAME)]
+| Short_Descriptor [([Class =>] CLASS_NAME)]
 
 CLASS_NAME ::= ubs | ubsb | uba | s | sb | a
 @end smallexample
@@ -1970,6 +1975,9 @@ pragma that specifies the desired foreign convention.
 @cindex OpenVMS
 @cindex Passing by descriptor
 Passing by descriptor is supported only on the OpenVMS ports of GNAT@.
+The default behavior for Export_Procedure is to accept either 64bit or
+32bit descriptors unless short_descriptor is specified, then only 32bit
+descriptors are accepted.
 
 @cindex Suppressing external name
 Special treatment is given if the EXTERNAL is an explicit null
@@ -2035,6 +2043,7 @@ MECHANISM_NAME ::=
   Value
 | Reference
 | Descriptor [([Class =>] CLASS_NAME)]
+| Short_Descriptor [([Class =>] CLASS_NAME)]
 
 CLASS_NAME ::= ubs | ubsb | uba | s | sb | a
 @end smallexample
@@ -2057,6 +2066,9 @@ pragma that specifies the desired foreign convention.
 @cindex OpenVMS
 @cindex Passing by descriptor
 Passing by descriptor is supported only on the OpenVMS ports of GNAT@.
+The default behavior for Export_Valued_Procedure is to accept either 64bit or
+32bit descriptors unless short_descriptor is specified, then only 32bit
+descriptors are accepted.
 
 @cindex Suppressing external name
 Special treatment is given if the EXTERNAL is an explicit null
@@ -2483,6 +2495,7 @@ MECHANISM_NAME ::=
   Value
 | Reference
 | Descriptor [([Class =>] CLASS_NAME)]
+| Short_Descriptor [([Class =>] CLASS_NAME)]
 
 CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
 @end smallexample
@@ -2516,6 +2529,8 @@ is used.
 @cindex OpenVMS
 @cindex Passing by descriptor
 Passing by descriptor is supported only on the OpenVMS ports of GNAT@.
+The default behavior for Import_Function is to pass a 64bit descriptor
+unless short_descriptor is specified, then a 32bit descriptor is passed.
 
 @code{First_Optional_Parameter} applies only to OpenVMS ports of GNAT@.
 It specifies that the designated parameter and all following parameters
@@ -2589,6 +2604,7 @@ MECHANISM_NAME ::=
   Value
 | Reference
 | Descriptor [([Class =>] CLASS_NAME)]
+| Short_Descriptor [([Class =>] CLASS_NAME)]
 
 CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
 @end smallexample
@@ -2635,6 +2651,7 @@ MECHANISM_NAME ::=
   Value
 | Reference
 | Descriptor [([Class =>] CLASS_NAME)]
+| Short_Descriptor [([Class =>] CLASS_NAME)]
 
 CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
 @end smallexample

gcc/ada/sem_mech.adb

@@ -69,7 +69,7 @@ package body Sem_Mech is
            ("mechanism for & has already been set", Mech_Name, Ent);
       end if;
 
-      --  MECHANISM_NAME ::= value | reference | descriptor
+      --  MECHANISM_NAME ::= value | reference | descriptor | short_descriptor
 
       if Nkind (Mech_Name) = N_Identifier then
          if Chars (Mech_Name) = Name_Value then
@@ -85,6 +85,11 @@ package body Sem_Mech is
             Set_Mechanism_With_Checks (Ent, By_Descriptor, Mech_Name);
             return;
 
+         elsif Chars (Mech_Name) = Name_Short_Descriptor then
+            Check_VMS (Mech_Name);
+            Set_Mechanism_With_Checks (Ent, By_Short_Descriptor, Mech_Name);
+            return;
+
          elsif Chars (Mech_Name) = Name_Copy then
             Error_Msg_N
               ("bad mechanism name, Value assumed", Mech_Name);
@@ -95,7 +100,8 @@ package body Sem_Mech is
             return;
          end if;
 
-      --  MECHANISM_NAME ::= descriptor (CLASS_NAME)
+      --  MECHANISM_NAME ::= descriptor (CLASS_NAME) |
+      --                     short_descriptor (CLASS_NAME)
       --  CLASS_NAME     ::= ubs | ubsb | uba | s | sb | a | nca
 
       --  Note: this form is parsed as an indexed component
@@ -104,14 +110,16 @@ package body Sem_Mech is
          Class := First (Expressions (Mech_Name));
 
          if Nkind (Prefix (Mech_Name)) /= N_Identifier
-           or else Chars (Prefix (Mech_Name)) /= Name_Descriptor
+           or else not (Chars (Prefix (Mech_Name)) = Name_Descriptor or else
+                        Chars (Prefix (Mech_Name)) = Name_Short_Descriptor)
            or else Present (Next (Class))
          then
             Bad_Mechanism;
             return;
          end if;
 
-      --  MECHANISM_NAME ::= descriptor (Class => CLASS_NAME)
+      --  MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) |
+      --                     short_descriptor (Class => CLASS_NAME)
       --  CLASS_NAME     ::= ubs | ubsb | uba | s | sb | a | nca
 
       --  Note: this form is parsed as a function call
@@ -121,7 +129,8 @@ package body Sem_Mech is
          Param := First (Parameter_Associations (Mech_Name));
 
          if Nkind (Name (Mech_Name)) /= N_Identifier
-           or else Chars (Name (Mech_Name)) /= Name_Descriptor
+           or else not (Chars (Name (Mech_Name)) = Name_Descriptor or else
+                        Chars (Name (Mech_Name)) = Name_Short_Descriptor)
            or else Present (Next (Param))
            or else No (Selector_Name (Param))
            or else Chars (Selector_Name (Param)) /= Name_Class
@@ -145,27 +154,76 @@ package body Sem_Mech is
          Bad_Class;
          return;
 
-      elsif Chars (Class) = Name_UBS then
+      elsif Chars (Name (Mech_Name)) = Name_Descriptor
+        and then Chars (Class) = Name_UBS
+      then
          Set_Mechanism_With_Checks (Ent, By_Descriptor_UBS,  Mech_Name);
 
-      elsif Chars (Class) = Name_UBSB then
+      elsif Chars (Name (Mech_Name)) = Name_Descriptor
+        and then Chars (Class) = Name_UBSB
+      then
          Set_Mechanism_With_Checks (Ent, By_Descriptor_UBSB, Mech_Name);
 
-      elsif Chars (Class) = Name_UBA then
+      elsif Chars (Name (Mech_Name)) = Name_Descriptor
+        and then Chars (Class) = Name_UBA
+      then
          Set_Mechanism_With_Checks (Ent, By_Descriptor_UBA,  Mech_Name);
 
-      elsif Chars (Class) = Name_S then
+      elsif Chars (Name (Mech_Name)) = Name_Descriptor
+        and then Chars (Class) = Name_S
+      then
          Set_Mechanism_With_Checks (Ent, By_Descriptor_S,    Mech_Name);
 
-      elsif Chars (Class) = Name_SB then
+      elsif Chars (Name (Mech_Name)) = Name_Descriptor
+        and then Chars (Class) = Name_SB
+      then
          Set_Mechanism_With_Checks (Ent, By_Descriptor_SB,   Mech_Name);
 
-      elsif Chars (Class) = Name_A then
+      elsif Chars (Name (Mech_Name)) = Name_Descriptor
+        and then Chars (Class) = Name_A
+      then
          Set_Mechanism_With_Checks (Ent, By_Descriptor_A,    Mech_Name);
 
-      elsif Chars (Class) = Name_NCA then
+      elsif Chars (Name (Mech_Name)) = Name_Descriptor
+        and then Chars (Class) = Name_NCA
+      then
          Set_Mechanism_With_Checks (Ent, By_Descriptor_NCA,  Mech_Name);
 
+      elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor
+        and then Chars (Class) = Name_UBS
+      then
+         Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_UBS,  Mech_Name);
+
+      elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor
+        and then Chars (Class) = Name_UBSB
+      then
+         Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_UBSB, Mech_Name);
+
+      elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor
+        and then Chars (Class) = Name_UBA
+      then
+         Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_UBA,  Mech_Name);
+
+      elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor
+        and then Chars (Class) = Name_S
+      then
+         Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_S,    Mech_Name);
+
+      elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor
+        and then Chars (Class) = Name_SB
+      then
+         Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_SB,   Mech_Name);
+
+      elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor
+        and then Chars (Class) = Name_A
+      then
+         Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_A,    Mech_Name);
+
+      elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor
+        and then Chars (Class) = Name_NCA
+      then
+         Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_NCA,  Mech_Name);
+
       else
          Bad_Class;
          return;

gcc/ada/sem_mech.ads

@@ -95,6 +95,14 @@ package Sem_Mech is
    By_Descriptor_SB   : constant Mechanism_Type := -8;
    By_Descriptor_A    : constant Mechanism_Type := -9;
    By_Descriptor_NCA  : constant Mechanism_Type := -10;
+   By_Short_Descriptor      : constant Mechanism_Type := -11;
+   By_Short_Descriptor_UBS  : constant Mechanism_Type := -12;
+   By_Short_Descriptor_UBSB : constant Mechanism_Type := -13;
+   By_Short_Descriptor_UBA  : constant Mechanism_Type := -14;
+   By_Short_Descriptor_S    : constant Mechanism_Type := -15;
+   By_Short_Descriptor_SB   : constant Mechanism_Type := -16;
+   By_Short_Descriptor_A    : constant Mechanism_Type := -17;
+   By_Short_Descriptor_NCA  : constant Mechanism_Type := -18;
    --  These values are used only in OpenVMS ports of GNAT. Pass by descriptor
    --  is forced, as described in the OpenVMS ABI. The suffix indicates the
    --  descriptor type:
@@ -113,7 +121,7 @@ package Sem_Mech is
    --  type based on the Ada type in accordance with the OpenVMS ABI.
 
    subtype Descriptor_Codes is Mechanism_Type
-     range By_Descriptor_NCA .. By_Descriptor;
+     range By_Short_Descriptor_NCA .. By_Descriptor;
    --  Subtype including all descriptor mechanisms
 
    --  All the above special values are non-positive. Positive values for

gcc/ada/sem_prag.adb

@@ -4622,6 +4622,7 @@ package body Sem_Prag is
       procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
          Class : Node_Id;
          Param : Node_Id;
+         Mech_Name_Id : Name_Id;
 
          procedure Bad_Class;
          --  Signal bad descriptor class name
@@ -4655,7 +4656,8 @@ package body Sem_Prag is
               ("mechanism for & has already been set", Mech_Name, Ent);
          end if;
 
-         --  MECHANISM_NAME ::= value | reference | descriptor
+         --  MECHANISM_NAME ::= value | reference | descriptor |
+         --                     short_descriptor
 
          if Nkind (Mech_Name) = N_Identifier then
             if Chars (Mech_Name) = Name_Value then
@@ -4671,6 +4673,11 @@ package body Sem_Prag is
                Set_Mechanism (Ent, By_Descriptor);
                return;
 
+            elsif Chars (Mech_Name) = Name_Short_Descriptor then
+               Check_VMS (Mech_Name);
+               Set_Mechanism (Ent, By_Short_Descriptor);
+               return;
+
             elsif Chars (Mech_Name) = Name_Copy then
                Error_Pragma_Arg
                  ("bad mechanism name, Value assumed", Mech_Name);
@@ -4679,22 +4686,28 @@ package body Sem_Prag is
                Bad_Mechanism;
             end if;
 
-         --  MECHANISM_NAME ::= descriptor (CLASS_NAME)
+         --  MECHANISM_NAME ::= descriptor (CLASS_NAME) |
+         --                     short_descriptor (CLASS_NAME)
          --  CLASS_NAME     ::= ubs | ubsb | uba | s | sb | a | nca
 
          --  Note: this form is parsed as an indexed component
 
          elsif Nkind (Mech_Name) = N_Indexed_Component then
+
             Class := First (Expressions (Mech_Name));
 
             if Nkind (Prefix (Mech_Name)) /= N_Identifier
-              or else Chars (Prefix (Mech_Name)) /= Name_Descriptor
-              or else Present (Next (Class))
+             or else not (Chars (Prefix (Mech_Name)) = Name_Descriptor or else
+                          Chars (Prefix (Mech_Name)) = Name_Short_Descriptor)
+             or else Present (Next (Class))
             then
                Bad_Mechanism;
+            else
+               Mech_Name_Id := Chars (Prefix (Mech_Name));
             end if;
 
-         --  MECHANISM_NAME ::= descriptor (Class => CLASS_NAME)
+         --  MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) |
+         --                     short_descriptor (Class => CLASS_NAME)
          --  CLASS_NAME     ::= ubs | ubsb | uba | s | sb | a | nca
 
          --  Note: this form is parsed as a function call
@@ -4704,7 +4717,8 @@ package body Sem_Prag is
             Param := First (Parameter_Associations (Mech_Name));
 
             if Nkind (Name (Mech_Name)) /= N_Identifier
-              or else Chars (Name (Mech_Name)) /= Name_Descriptor
+              or else not (Chars (Name (Mech_Name)) = Name_Descriptor or else
+                           Chars (Name (Mech_Name)) = Name_Short_Descriptor)
               or else Present (Next (Param))
               or else No (Selector_Name (Param))
               or else Chars (Selector_Name (Param)) /= Name_Class
@@ -4712,6 +4726,7 @@ package body Sem_Prag is
                Bad_Mechanism;
             else
                Class := Explicit_Actual_Parameter (Param);
+               Mech_Name_Id := Chars (Name (Mech_Name));
             end if;
 
          else
@@ -4725,27 +4740,76 @@ package body Sem_Prag is
          if Nkind (Class) /= N_Identifier then
             Bad_Class;
 
-         elsif Chars (Class) = Name_UBS then
+         elsif Mech_Name_Id = Name_Descriptor
+               and then Chars (Class) = Name_UBS
+         then
             Set_Mechanism (Ent, By_Descriptor_UBS);
 
-         elsif Chars (Class) = Name_UBSB then
+         elsif Mech_Name_Id = Name_Descriptor
+               and then Chars (Class) = Name_UBSB
+         then
             Set_Mechanism (Ent, By_Descriptor_UBSB);
 
-         elsif Chars (Class) = Name_UBA then
+         elsif Mech_Name_Id = Name_Descriptor
+               and then Chars (Class) = Name_UBA
+         then
             Set_Mechanism (Ent, By_Descriptor_UBA);
 
-         elsif Chars (Class) = Name_S then
+         elsif Mech_Name_Id = Name_Descriptor
+               and then Chars (Class) = Name_S
+         then
             Set_Mechanism (Ent, By_Descriptor_S);
 
-         elsif Chars (Class) = Name_SB then
+         elsif Mech_Name_Id = Name_Descriptor
+               and then Chars (Class) = Name_SB
+         then
             Set_Mechanism (Ent, By_Descriptor_SB);
 
-         elsif Chars (Class) = Name_A then
+         elsif Mech_Name_Id = Name_Descriptor
+               and then Chars (Class) = Name_A
+         then
             Set_Mechanism (Ent, By_Descriptor_A);
 
-         elsif Chars (Class) = Name_NCA then
+         elsif Mech_Name_Id = Name_Descriptor
+               and then Chars (Class) = Name_NCA
+         then
             Set_Mechanism (Ent, By_Descriptor_NCA);
 
+         elsif Mech_Name_Id = Name_Short_Descriptor
+               and then Chars (Class) = Name_UBS
+         then
+            Set_Mechanism (Ent, By_Short_Descriptor_UBS);
+
+         elsif Mech_Name_Id = Name_Short_Descriptor
+               and then Chars (Class) = Name_UBSB
+         then
+            Set_Mechanism (Ent, By_Short_Descriptor_UBSB);
+
+         elsif Mech_Name_Id = Name_Short_Descriptor
+               and then Chars (Class) = Name_UBA
+         then
+            Set_Mechanism (Ent, By_Short_Descriptor_UBA);
+
+         elsif Mech_Name_Id = Name_Short_Descriptor
+               and then Chars (Class) = Name_S
+         then
+            Set_Mechanism (Ent, By_Short_Descriptor_S);
+
+         elsif Mech_Name_Id = Name_Short_Descriptor
+               and then Chars (Class) = Name_SB
+         then
+            Set_Mechanism (Ent, By_Short_Descriptor_SB);
+
+         elsif Mech_Name_Id = Name_Short_Descriptor
+               and then Chars (Class) = Name_A
+         then
+            Set_Mechanism (Ent, By_Short_Descriptor_A);
+
+         elsif Mech_Name_Id = Name_Short_Descriptor
+               and then Chars (Class) = Name_NCA
+         then
+            Set_Mechanism (Ent, By_Short_Descriptor_NCA);
+
          else
             Bad_Class;
          end if;

gcc/ada/snames.adb

@@ -415,6 +415,7 @@ package body Snames is
      "secondary_stack_size#" &
      "section#" &
      "semaphore#" &
+     "short_descriptor#" &
      "simple_barriers#" &
      "spec_file_name#" &
      "state#" &

gcc/ada/treepr.adb

@@ -531,17 +531,44 @@ package body Treepr is
 
             begin
                case M is
-                  when Default_Mechanism  => Write_Str ("Default");
-                  when By_Copy            => Write_Str ("By_Copy");
-                  when By_Reference       => Write_Str ("By_Reference");
-                  when By_Descriptor      => Write_Str ("By_Descriptor");
-                  when By_Descriptor_UBS  => Write_Str ("By_Descriptor_UBS");
-                  when By_Descriptor_UBSB => Write_Str ("By_Descriptor_UBSB");
-                  when By_Descriptor_UBA  => Write_Str ("By_Descriptor_UBA");
-                  when By_Descriptor_S    => Write_Str ("By_Descriptor_S");
-                  when By_Descriptor_SB   => Write_Str ("By_Descriptor_SB");
-                  when By_Descriptor_A    => Write_Str ("By_Descriptor_A");
-                  when By_Descriptor_NCA  => Write_Str ("By_Descriptor_NCA");
+                  when Default_Mechanism
+                                    => Write_Str ("Default");
+                  when By_Copy
+                                    => Write_Str ("By_Copy");
+                  when By_Reference
+                                    => Write_Str ("By_Reference");
+                  when By_Descriptor
+                                    => Write_Str ("By_Descriptor");
+                  when By_Descriptor_UBS
+                                    => Write_Str ("By_Descriptor_UBS");
+                  when By_Descriptor_UBSB
+                                    => Write_Str ("By_Descriptor_UBSB");
+                  when By_Descriptor_UBA
+                                    => Write_Str ("By_Descriptor_UBA");
+                  when By_Descriptor_S
+                                    => Write_Str ("By_Descriptor_S");
+                  when By_Descriptor_SB
+                                    => Write_Str ("By_Descriptor_SB");
+                  when By_Descriptor_A
+                                    => Write_Str ("By_Descriptor_A");
+                  when By_Descriptor_NCA
+                                    => Write_Str ("By_Descriptor_NCA");
+                  when By_Short_Descriptor
+                                    => Write_Str ("By_Short_Descriptor");
+                  when By_Short_Descriptor_UBS
+                                    => Write_Str ("By_Short_Descriptor_UBS");
+                  when By_Short_Descriptor_UBSB
+                                    => Write_Str ("By_Short_Descriptor_UBSB");
+                  when By_Short_Descriptor_UBA
+                                    => Write_Str ("By_Short_Descriptor_UBA");
+                  when By_Short_Descriptor_S
+                                    => Write_Str ("By_Short_Descriptor_S");
+                  when By_Short_Descriptor_SB
+                                    => Write_Str ("By_Short_Descriptor_SB");
+                  when By_Short_Descriptor_A
+                                    => Write_Str ("By_Short_Descriptor_A");
+                  when By_Short_Descriptor_NCA
+                                    => Write_Str ("By_Short_Descriptor_NCA");
 
                   when 1 .. Mechanism_Type'Last =>
                      Write_Str ("By_Copy if size <= ");

gcc/ada/types.ads

@@ -736,7 +736,7 @@ package Types is
    --  passing mechanism. See specification of Sem_Mech for full details.
    --  The following subtype is used to represent values of this type:
 
-   subtype Mechanism_Type is Int range -10 .. Int'Last;
+   subtype Mechanism_Type is Int range -18 .. Int'Last;
    --  Type used to represent a mechanism value. This is a subtype rather
    --  than a type to avoid some annoying processing problems with certain
    --  routines in Einfo (processing them to create the corresponding C).

gcc/ada/types.h

@@ -328,6 +328,15 @@ typedef Int Mechanism_Type;
 #define By_Descriptor_A    (-9)
 #define By_Descriptor_NCA  (-10)
 #define By_Descriptor_Last (-10)
+#define By_Short_Descriptor      (-11)
+#define By_Short_Descriptor_UBS  (-12)
+#define By_Short_Descriptor_UBSB (-13)
+#define By_Short_Descriptor_UBA  (-14)
+#define By_Short_Descriptor_S    (-15)
+#define By_Short_Descriptor_SB   (-16)
+#define By_Short_Descriptor_A    (-17)
+#define By_Short_Descriptor_NCA  (-18)
+#define By_Short_Descriptor_Last (-18)
 
 /* Internal to Gigi.  */
 #define By_Copy_Return     (-128)