From 80c2c20282aae97e232df885461b828d5d6573b0 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 25 Feb 2014 16:35:36 +0100 Subject: [PATCH] [multiple changes] 2014-02-25 Robert Dewar * 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 * sigtramp-ppcvxw.c, sigtramp.h, sigtramp-armvxw.c: Comment enhancements and corrections. 2014-02-25 Robert Dewar * gnat_rm.texi: New section "Conventions and Anonymous Access Types" From-SVN: r208143 --- gcc/ada/ChangeLog | 23 +++++++++++++++ gcc/ada/errout.adb | 55 ++++++++++++++--------------------- gcc/ada/erroutc.adb | 19 +++++++++--- gcc/ada/erroutc.ads | 10 +++++-- gcc/ada/gnat_rm.texi | 73 +++++++++++++++++++++++++++++++++++++++++++++++ gcc/ada/sem_attr.adb | 9 +++--- gcc/ada/sem_prag.adb | 28 ++++++++++++++++++ gcc/ada/sem_util.adb | 46 +++++++++++++++++++++++++++++ gcc/ada/sem_util.ads | 2 ++ gcc/ada/sigtramp-armvxw.c | 18 ++++-------- gcc/ada/sigtramp-ppcvxw.c | 1 + gcc/ada/sigtramp.h | 22 ++++++++++++-- 12 files changed, 248 insertions(+), 58 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a7d5dd3..d401ee5 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,28 @@ 2014-02-25 Robert Dewar + * 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 + + * sigtramp-ppcvxw.c, sigtramp.h, sigtramp-armvxw.c: Comment + enhancements and corrections. + +2014-02-25 Robert Dewar + + * gnat_rm.texi: New section "Conventions and Anonymous Access Types" + +2014-02-25 Robert Dewar + * gnat_rm.texi: First set of documentation additions for predefined RM units. * checks.adb: Minor reformatting. diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 74538e8..99f100b 100644 --- a/gcc/ada/errout.adb +++ b/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; diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index 53b80b1..e44d5f6 100644 --- a/gcc/ada/erroutc.adb +++ b/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 diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index f938e9b..75bc208 100644 --- a/gcc/ada/erroutc.ads +++ b/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 diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 88d3ce1..a815b3b 100644 --- a/gcc/ada/gnat_rm.texi +++ b/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 diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index a18a669..4924878 100644 --- a/gcc/ada/sem_attr.adb +++ b/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); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 96bd85b..ad6167b 100644 --- a/gcc/ada/sem_prag.adb +++ b/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 diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index ad42534..791bc2e 100644 --- a/gcc/ada/sem_util.adb +++ b/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; ------------------------ diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 8392681..0578ca3 100644 --- a/gcc/ada/sem_util.ads +++ b/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); diff --git a/gcc/ada/sigtramp-armvxw.c b/gcc/ada/sigtramp-armvxw.c index 095c9ca..fbd58b7 100644 --- a/gcc/ada/sigtramp-armvxw.c +++ b/gcc/ada/sigtramp-armvxw.c @@ -34,6 +34,7 @@ ******************************************************/ #include "sigtramp.h" +/* See sigtramp.h for a general explanation of functionality. */ #include #include @@ -125,7 +126,7 @@ void __gnat_sigtramp (int signo, void *si, void *sc, #define REGNO_G_REG_OFFSET(N) (N) -#define REGNO_PC_OFFSET 15 /* ARG_POINTER_REGNUM */ +#define REGNO_PC_OFFSET 15 /* PC_REGNUM */ /* asm string construction helpers. */ @@ -153,10 +154,8 @@ void __gnat_sigtramp (int signo, void *si, void *sc, Only non-volatile registers are suitable for a CFA base. These are the only ones we can expect to be able retrieve from the unwinding context while walking up the chain, saved by at least the bottom-most exception - propagation services. We use r15 here and set it to the value we need - in stub body that follows. Note that r14 is inappropriate here, even - though it is non-volatile according to the ABI, because GCC uses it as - an extra SCRATCH on SPE targets. */ + propagation services. We use r8 here and set it to the value we need + in stub body that follows. Any of r4-r8 should work. */ #define CFA_REG 8 @@ -168,13 +167,8 @@ CR(".cfi_def_cfa " S(CFA_REG) ", 0") Rules to find registers of interest from the CFA. This should comprise all the non-volatile registers relevant to the interrupted context. - Note that we include r1 in this set, unlike the libgcc unwinding - fallbacks. This is useful for fallbacks to allow the use of r1 in CFI - expressions and the absence of rule for r1 gets compensated by using the - target CFA instead. We don't need the expression facility here and - setup a fake CFA to allow very simple offset expressions, so having a - rule for r1 is the proper thing to do. We for sure have observed - crashes in some cases without it. */ + ??? Note that r0 was excluded for consistency with the PPC version of + this file, not sure if that's right. */ #define COMMON_CFI(REG) \ ".cfi_offset " S(REGNO_##REG) "," S(REG_SET_##REG) diff --git a/gcc/ada/sigtramp-ppcvxw.c b/gcc/ada/sigtramp-ppcvxw.c index e7b318f..1a9ba6a 100644 --- a/gcc/ada/sigtramp-ppcvxw.c +++ b/gcc/ada/sigtramp-ppcvxw.c @@ -34,6 +34,7 @@ **********************************************************/ #include "sigtramp.h" +/* See sigtramp.h for a general explanation of functionality. */ #include #include diff --git a/gcc/ada/sigtramp.h b/gcc/ada/sigtramp.h index ef93e3f..59287f1 100644 --- a/gcc/ada/sigtramp.h +++ b/gcc/ada/sigtramp.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 2011, Free Software Foundation, Inc. * + * Copyright (C) 2011-2013, 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- * @@ -49,7 +49,25 @@ extern "C" { /* To be called from an established signal handler. Setup the DWARF CFI bits letting unwinders walk through the signal frame up into the interrupted application code, and then call HANDLER (SIGNO, SIGINFO, - SIGCONTEXT). */ + SIGCONTEXT). + + The sigtramp construct makes it so that the unwinder jumps over it + the + signal handler + the kernel frame. For a typical backtrace from the raise + function: + + #0 __gnat_Unwind_RaiseException + #1 Raise_From_Signal_Handler + #2 __gnat_map_signal + #3 __gnat_sigtramp + #4 __gnat_error_handler + #5 + #6 interrupted function + + The unwinder will unwind frames 0, 1 and 2 as usual. But the CFI of frame + 3 is set up as if the caller of frame 3 was frame 6 so, when frame 3 is + unwound, the unwinder ends up in frame 6 directly. It's possible to do so + since the kernel has saved the context of frame 3 and passed it on to + __gnat_sigtramp. */ #ifdef __cplusplus } -- 2.7.4