2014-02-25 Robert Dewar <dewar@adacore.com>

	* errout.adb: Various changes for better msgs for anonmous access
	subprogram types.
	* erroutc.ads, erroutc.adb (Buffer_Ends_With): Version with character
	argument.
	(Buffer_Remove): Version with character argument.
	* sem_attr.adb (Resolve_Attribute, case Access): Better handling
	of mismatching conventions for access-to-subprogram case.
	* sem_prag.adb (Set_Convention_From_Pragma): Deal with anonymous
	access types in record.
	* sem_util.ads, sem_util.adb (Set_Convention): Handle anonymous access
	types, including in records.

2014-02-25  Doug Rupp  <rupp@adacore.com>

	* sigtramp-ppcvxw.c, sigtramp.h, sigtramp-armvxw.c: Comment
	enhancements and corrections.

2014-02-25  Robert Dewar  <dewar@adacore.com>

	* gnat_rm.texi: New section "Conventions and Anonymous Access Types"



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@208143 138bc75d-0d04-0410-961f-82ee72b054a4

gcc/ada/ChangeLog

@@ -1,3 +1,26 @@
+2014-02-25  Robert Dewar  <dewar@adacore.com>
+
+	* errout.adb: Various changes for better msgs for anonmous access
+	subprogram types.
+	* erroutc.ads, erroutc.adb (Buffer_Ends_With): Version with character
+	argument.
+	(Buffer_Remove): Version with character argument.
+	* sem_attr.adb (Resolve_Attribute, case Access): Better handling
+	of mismatching conventions for access-to-subprogram case.
+	* sem_prag.adb (Set_Convention_From_Pragma): Deal with anonymous
+	access types in record.
+	* sem_util.ads, sem_util.adb (Set_Convention): Handle anonymous access
+	types, including in records.
+
+2014-02-25  Doug Rupp  <rupp@adacore.com>
+
+	* sigtramp-ppcvxw.c, sigtramp.h, sigtramp-armvxw.c: Comment
+	enhancements and corrections.
+
+2014-02-25  Robert Dewar  <dewar@adacore.com>
+
+	* gnat_rm.texi: New section "Conventions and Anonymous Access Types"
+
 2014-02-25  Robert Dewar  <dewar@adacore.com>
 
 	* gnat_rm.texi: First set of documentation additions for

gcc/ada/errout.adb

@@ -642,9 +642,6 @@ package body Errout is
 
    procedure Error_Msg_PT (Typ : Node_Id; Subp : Node_Id) is
    begin
-      --  Error message below needs rewording (remember comma in -gnatj
-      --  mode) ???
-
       Error_Msg_NE
         ("first formal of & must be of mode `OUT`, `IN OUT` or " &
          "access-to-variable", Typ, Subp);
@@ -2318,6 +2315,12 @@ package body Errout is
          Set_Msg_Blank;
          Set_Msg_Str ("procedure name");
 
+      elsif Nkind (Error_Msg_Node_1) in N_Entity
+        and then Ekind (Error_Msg_Node_1) = E_Anonymous_Access_Subprogram_Type
+      then
+         Set_Msg_Blank;
+         Set_Msg_Str ("access to subprogram");
+
       else
          Set_Msg_Blank_Conditional;
 
@@ -2334,7 +2337,7 @@ package body Errout is
            or else K = N_Operator_Symbol
            or else K = N_Defining_Operator_Symbol
            or else ((K = N_Identifier or else K = N_Defining_Identifier)
-                       and then Is_Operator_Name (Chars (Error_Msg_Node_1)))
+                      and then Is_Operator_Name (Chars (Error_Msg_Node_1)))
          then
             Set_Msg_Node (Error_Msg_Node_1);
 
@@ -2456,6 +2459,7 @@ package body Errout is
          Get_Unqualified_Decoded_Name_String
            (Unit_Name (Get_Source_Unit (Ent)));
          Name_Len := Name_Len - 2;
+         Set_Msg_Blank_Conditional;
          Set_Msg_Quote;
          Set_Casing (Mixed_Case);
          Set_Msg_Name_Buffer;
@@ -2474,11 +2478,11 @@ package body Errout is
          Set_Msg_Node (Ent);
          Add_Class;
 
-         --  If Ent is an anonymous subprogram type, there is no name to print,
-         --  so remove enclosing quotes.
+         --  If we did not print a name (e.g. in the case of an anonymous
+         --  subprogram type), there is no name to print, so remove quotes.
 
-         if Buffer_Ends_With ("""") then
-            Buffer_Remove ("""");
+         if Buffer_Ends_With ('"') then
+            Buffer_Remove ('"');
          else
             Set_Msg_Quote;
          end if;
@@ -2607,10 +2611,13 @@ package body Errout is
          end if;
 
          --  If the type is the designated type of an access_to_subprogram,
-         --  there is no name to provide in the call.
+         --  then there is no name to provide in the call.
 
          if Ekind (Ent) = E_Subprogram_Type then
             return;
+
+         --  Otherwise, we will be able to find some kind of name to output
+
          else
             Unwind_Internal_Type (Ent);
             Nam := Chars (Ent);
@@ -3053,34 +3060,14 @@ package body Errout is
                   if Buffer_Ends_With ("type ") then
                      Buffer_Remove ("type ");
                   end if;
+               end if;
 
-                  if Is_Itype (Ent) then
-                     declare
-                        Assoc : constant Node_Id :=
-                          Associated_Node_For_Itype (Ent);
-
-                     begin
-                        if Nkind (Assoc) in N_Subprogram_Specification then
-
-                           --  Anonymous access to subprogram in a signature.
-                           --  Indicate the enclosing subprogram.
-
-                           Ent :=
-                             Defining_Unit_Name
-                               (Associated_Node_For_Itype (Ent));
-                           Set_Msg_Str
-                             ("access to subprogram declared in profile of ");
-
-                        else
-                           Set_Msg_Str ("access to subprogram with profile ");
-                        end if;
-                     end;
-                  end if;
-
-               elsif Ekind (Ent) = E_Function then
+               if Ekind (Ent) = E_Function then
                   Set_Msg_Str ("access to function ");
-               else
+               elsif Ekind (Ent) = E_Procedure then
                   Set_Msg_Str ("access to procedure ");
+               else
+                  Set_Msg_Str ("access to subprogram");
                end if;
 
                exit Find;

gcc/ada/erroutc.adb

@@ -64,19 +64,30 @@ package body Erroutc is
    -- Buffer_Ends_With --
    ----------------------
 
+   function Buffer_Ends_With (C : Character) return Boolean is
+   begin
+      return Msglen > 0 and then Msg_Buffer (Msglen) = C;
+   end Buffer_Ends_With;
+
    function Buffer_Ends_With (S : String) return Boolean is
       Len : constant Natural := S'Length;
    begin
-      return
-        Msglen > Len
-          and then Msg_Buffer (Msglen - Len) = ' '
-          and then Msg_Buffer (Msglen - Len + 1 .. Msglen) = S;
+      return Msglen > Len
+        and then Msg_Buffer (Msglen - Len) = ' '
+        and then Msg_Buffer (Msglen - Len + 1 .. Msglen) = S;
    end Buffer_Ends_With;
 
    -------------------
    -- Buffer_Remove --
    -------------------
 
+   procedure Buffer_Remove (C : Character) is
+   begin
+      if Buffer_Ends_With (C) then
+         Msglen := Msglen - 1;
+      end if;
+   end Buffer_Remove;
+
    procedure Buffer_Remove (S : String) is
    begin
       if Buffer_Ends_With (S) then

gcc/ada/erroutc.ads

@@ -344,12 +344,18 @@ package Erroutc is
    procedure Add_Class;
    --  Add 'Class to buffer for class wide type case (Class_Flag set)
 
+   function Buffer_Ends_With (C : Character) return Boolean;
+   --  Tests if message buffer ends with given character
+
    function Buffer_Ends_With (S : String) return Boolean;
    --  Tests if message buffer ends with given string preceded by a space
 
+   procedure Buffer_Remove (C : Character);
+   --  Remove given character fron end of buffer if it is present
+
    procedure Buffer_Remove (S : String);
-   --  Removes given string from end of buffer if it is present
-   --  at end of buffer, and preceded by a space.
+   --  Removes given string from end of buffer if it is present at end of
+   --  buffer, and preceded by a space.
 
    function Compilation_Errors return Boolean;
    --  Returns true if errors have been detected, or warnings in -gnatwe

gcc/ada/gnat_rm.texi

@@ -13865,6 +13865,7 @@ source file location.
 * Enumeration Clauses::
 * Address Clauses::
 * Effect of Convention on Representation::
+* Conventions and Anonymous Access Types::
 * Determining the Representations chosen by GNAT::
 @end menu
 
@@ -15635,6 +15636,78 @@ code. size clause specifying 64-bits must be used to obtain a 64-bit pointer.
 
 @end itemize
 
+@node Conventions and Anonymous Access Types
+@section Conventions and Anonymous Access Types
+@cindex Anonymous access types
+@cindex Convention for anonymous access types
+
+The RM is not entirely clear on convention handling in a number of cases,
+and in particular, it is not clear on the convention to be given to
+anonymous access types in general, and in particular what is to be
+done for the case of anonymous access-to-subprogram.
+
+In GNAT, we decide that if an explicit Convention is applied
+to an object or component, and its type is such an anonymous type,
+then the convention will apply to this anonymous type as well. This
+seems to make sense since it is anomolous in any case to have a
+different convention for an object and its type, and there is clearly
+no way to explicitly specify a convention for an anonymous type, since
+it doesn't have a name to specify!
+
+Furthermore, we decide that if a convention is applied to a record type,
+then this convention is inherited by any of its components that are of an
+anonymous access type which do not have an explicitly specified convention.
+
+The following program shows these conventions in action:
+
+@smallexample @c ada
+package ConvComp is
+   type Foo is range 1 .. 10;
+   type T1 is record
+      A : access function (X : Foo) return Integer;
+      B : Integer;
+   end record;
+   pragma Convention (C, T1);
+
+   type T2 is record
+      A : access function (X : Foo) return Integer;
+      pragma Convention  (C, A);
+      B : Integer;
+   end record;
+   pragma Convention (COBOL, T2);
+
+   type T3 is record
+      A : access function (X : Foo) return Integer;
+      pragma Convention  (COBOL, A);
+      B : Integer;
+   end record;
+   pragma Convention (C, T3);
+
+   type T4 is record
+      A : access function (X : Foo) return Integer;
+      B : Integer;
+   end record;
+   pragma Convention (COBOL, T4);
+
+   function F (X : Foo) return Integer;
+   pragma Convention (C, F);
+
+   function F (X : Foo) return Integer is (13);
+
+   TV1 : T1 := (F'Access, 12);  -- OK
+   TV2 : T2 := (F'Access, 13);  -- OK
+
+   TV3 : T3 := (F'Access, 13);  -- ERROR
+                |
+>>> subprogram "F" has wrong convention
+>>> does not match access to subprogram declared at line 17
+     38.    TV4 : T4 := (F'Access, 13);  -- ERROR
+                |
+>>> subprogram "F" has wrong convention
+>>> does not match access to subprogram declared at line 24
+     39. end ConvComp;
+@end smallexample
+
 @node Determining the Representations chosen by GNAT
 @section Determining the Representations chosen by GNAT
 @cindex Representation, determination of

gcc/ada/sem_attr.adb

@@ -9755,11 +9755,12 @@ package body Sem_Attr is
                   then
                      Error_Msg_FE
                        ("subprogram & has wrong convention", P, Entity (P));
-                     Error_Msg_FE
-                       ("\does not match convention of access type &",
-                        P, Btyp);
+                     Error_Msg_Sloc := Sloc (Btyp);
+                     Error_Msg_FE ("\does not match & declared#", P, Btyp);
 
-                     if not Has_Convention_Pragma (Btyp) then
+                     if not Is_Itype (Btyp)
+                       and then not Has_Convention_Pragma (Btyp)
+                     then
                         Error_Msg_FE
                           ("\probable missing pragma Convention for &",
                            P, Btyp);

gcc/ada/sem_prag.adb

@@ -6749,6 +6749,34 @@ package body Sem_Prag is
             Set_Convention (E, C);
             Set_Has_Convention_Pragma (E);
 
+            --  For the case of a record base type, also set the convention of
+            --  any anonymous access types declared in the record which do not
+            --  currently have a specified convention.
+
+            if Is_Record_Type (E) and then Is_Base_Type (E) then
+               declare
+                  Comp : Node_Id;
+
+               begin
+                  Comp := First_Component (E);
+                  while Present (Comp) loop
+                     if Present (Etype (Comp))
+                       and then Ekind_In (Etype (Comp),
+                                          E_Anonymous_Access_Type,
+                                          E_Anonymous_Access_Subprogram_Type)
+                       and then not Has_Convention_Pragma (Comp)
+                     then
+                        Set_Convention (Comp, C);
+                     end if;
+
+                     Next_Component (Comp);
+                  end loop;
+               end;
+            end if;
+
+            --  Deal with incomplete/private type case, where underlying type
+            --  is available, so set convention of that underlying type.
+
             if Is_Incomplete_Or_Private_Type (E)
               and then Present (Underlying_Type (E))
             then

gcc/ada/sem_util.adb

@@ -15631,6 +15631,52 @@ package body Sem_Util is
       then
          Set_Can_Use_Internal_Rep (E, False);
       end if;
+
+      --  If E is an object or component, and the type of E is an anonymous
+      --  access type with no convention set, then also set the convention of
+      --  the anonymous access type. We do not do this for anonymous protected
+      --  types, since protected types always have the default convention.
+
+      if Present (Etype (E))
+        and then (Is_Object (E)
+                   or else Ekind (E) = E_Component
+
+                   --  Allow E_Void (happens for pragma Convention appearing
+                   --  in the middle of a record applying to a component)
+
+                   or else Ekind (E) = E_Void)
+      then
+         declare
+            Typ : constant Entity_Id := Etype (E);
+
+         begin
+            if Ekind_In (Typ, E_Anonymous_Access_Type,
+                              E_Anonymous_Access_Subprogram_Type)
+              and then not Has_Convention_Pragma (Typ)
+            then
+               Basic_Set_Convention (Typ, Val);
+               Set_Has_Convention_Pragma (Typ);
+
+               --  And for the access subprogram type, deal similarly with the
+               --  designated E_Subprogram_Type if it is also internal (which
+               --  it always is?)
+
+               if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then
+                  declare
+                     Dtype : constant Entity_Id := Designated_Type (Typ);
+                  begin
+                     if Ekind (Dtype) = E_Subprogram_Type
+                       and then Is_Itype (Dtype)
+                       and then not Has_Convention_Pragma (Dtype)
+                     then
+                        Basic_Set_Convention (Dtype, Val);
+                        Set_Has_Convention_Pragma (Dtype);
+                     end if;
+                  end;
+               end if;
+            end if;
+         end;
+      end if;
    end Set_Convention;
 
    ------------------------

gcc/ada/sem_util.ads

@@ -1749,6 +1749,8 @@ package Sem_Util is
    --  Same as Basic_Set_Convention, but with an extra check for access types.
    --  In particular, if E is an access-to-subprogram type, and Val is a
    --  foreign convention, then we set Can_Use_Internal_Rep to False on E.
+   --  Also, if the Etype of E is set and is an anonymous access type with
+   --  no convention set, this anonymous type inherits the convention of E.
 
    procedure Set_Current_Entity (E : Entity_Id);
    pragma Inline (Set_Current_Entity);