From f6820c2d0eb622884ac873db8d0e360c2ff4480e Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 22 Apr 2013 12:44:46 +0200 Subject: [PATCH] [multiple changes] 2013-04-22 Pascal Obry * gnat_ugn.texi, prj-nmsc.adb, projects.texi: Add check for Library_Standalone and Library_Kind. 2013-04-22 Ed Schonberg * exp_ch6.adb (Expand_Actuals): If the call is to an inherited operation and the actual is a by-reference type with predicates, add predicate call to post-call actions. * sem_util.adb (Is_Inherited_Operation_For_Type): Fix coding error: a type declaration has a defining identifier, not an Etype. * sem_res.adb: Restore code removed because of above error. 2013-04-22 Doug Rupp * init.c (__gnat_handle_vms_condition): Also match C$_SIGINT. From-SVN: r198130 --- gcc/ada/ChangeLog | 18 ++++++++++++++++++ gcc/ada/exp_ch6.adb | 32 ++++++++++++++++++++++++++++---- gcc/ada/gnat_ugn.texi | 1 + gcc/ada/init.c | 9 +++++++-- gcc/ada/prj-nmsc.adb | 15 +++++++++++++++ gcc/ada/projects.texi | 16 +++++++++++++--- gcc/ada/sem_res.adb | 21 ++++++++------------- gcc/ada/sem_util.adb | 5 ++++- 8 files changed, 94 insertions(+), 23 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1b2d967de29..18dd3b1ecae 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,21 @@ +2013-04-22 Pascal Obry + + * gnat_ugn.texi, prj-nmsc.adb, projects.texi: Add check for + Library_Standalone and Library_Kind. + +2013-04-22 Ed Schonberg + + * exp_ch6.adb (Expand_Actuals): If the call is to an + inherited operation and the actual is a by-reference type with + predicates, add predicate call to post-call actions. + * sem_util.adb (Is_Inherited_Operation_For_Type): Fix coding + error: a type declaration has a defining identifier, not an Etype. + * sem_res.adb: Restore code removed because of above error. + +2013-04-22 Doug Rupp + + * init.c (__gnat_handle_vms_condition): Also match C$_SIGINT. + 2013-04-22 Yannick Moy * gnat_rm.texi, exp_util.adb, sem_prag.adb, sem_prag.ads, par-ch2.adb, diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 5c5c809e880..35060e714b2 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -942,6 +942,7 @@ package body Exp_Ch6 is Formal : Entity_Id; N_Node : Node_Id; Post_Call : List_Id; + E_Actual : Entity_Id; E_Formal : Entity_Id; procedure Add_Call_By_Copy_Code; @@ -1508,6 +1509,7 @@ package body Exp_Ch6 is Actual := First_Actual (N); while Present (Formal) loop E_Formal := Etype (Formal); + E_Actual := Etype (Actual); if Is_Scalar_Type (E_Formal) or else Nkind (Actual) = N_Slice @@ -1645,7 +1647,7 @@ package body Exp_Ch6 is -- conversion" errors. elsif Is_Access_Type (E_Formal) - and then not Same_Type (E_Formal, Etype (Actual)) + and then not Same_Type (E_Formal, E_Actual) and then not Is_Tagged_Type (Designated_Type (E_Formal)) then Add_Call_By_Copy_Code; @@ -1661,7 +1663,7 @@ package body Exp_Ch6 is elsif Is_Entity_Name (Actual) and then Is_Volatile (Entity (Actual)) - and then not Is_By_Reference_Type (Etype (Actual)) + and then not Is_By_Reference_Type (E_Actual) and then not Is_Scalar_Type (Etype (Entity (Actual))) and then not Is_Volatile (E_Formal) then @@ -1682,10 +1684,10 @@ package body Exp_Ch6 is elsif Is_Scalar_Type (E_Formal) and then - (not In_Subrange_Of (E_Formal, Etype (Actual)) + (not In_Subrange_Of (E_Formal, E_Actual) or else (Ekind (Formal) = E_In_Out_Parameter - and then not In_Subrange_Of (Etype (Actual), E_Formal))) + and then not In_Subrange_Of (E_Actual, E_Formal))) then -- Perhaps the setting back to False should be done within -- Add_Call_By_Copy_Code, since it could get set on other @@ -1698,6 +1700,28 @@ package body Exp_Ch6 is Add_Call_By_Copy_Code; end if; + -- RM 3.2.4 (23/3) : A predicate is checked on in-out and out + -- by-reference parameters on exit from the call. If the actual + -- is a derived type and the operation is inherited, the body + -- of the operation will not contain a call to the predicate + -- function, so it must be done explicitly after the call. Ditto + -- if the actual is an entity of a predicated subtype. + + if Is_By_Reference_Type (E_Formal) + and then Has_Predicates (E_Actual) + then + if Is_Derived_Type (E_Actual) + and then Is_Inherited_Operation_For_Type (Subp, E_Actual) + then + Append_To + (Post_Call, Make_Predicate_Check (E_Actual, Actual)); + + elsif Is_Entity_Name (Actual) then + Append_To + (Post_Call, Make_Predicate_Check (E_Actual, Actual)); + end if; + end if; + -- Processing for IN parameters else diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 17f0f843748..2a8610b28c8 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -17083,6 +17083,7 @@ build an encapsulated library the attribute @group for Library_Dir use "lib_dir"; for Library_Name use "dummy"; + for Library_Kind use "dynamic"; for Library_Interface use ("int1", "int1.child"); for Library_Standalone use "encapsulated"; @end group diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 8408225dd7b..030cb5c3f82 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -833,6 +833,7 @@ void (*__gnat_ctrl_c_handler) (void) = 0; /* These codes are in standard message libraries. */ extern int C$_SIGKILL; +extern int C$_SIGINT; extern int SS$_DEBUG; extern int LIB$_KEYNOTFOU; extern int LIB$_ACTIMAGE; @@ -1221,14 +1222,18 @@ __gnat_handle_vms_condition (int *sigargs, void *mechargs) system_cond_except_table, 0}; unsigned int ctrlc = SS$_CONTROLC; + unsigned int *sigint = &C$_SIGINT; int ctrlc_match = LIB$MATCH_COND (&sigargs [1], &ctrlc); + int sigint_match = LIB$MATCH_COND (&sigargs [1], &sigint); extern int SYS$DCLAST (void (*astadr)(), unsigned long long astprm, unsigned int acmode); /* If SS$_CONTROLC has been imported as an exception, it will take - priority over a a Ctrl/C handler. See above. */ - if (ctrlc_match && __gnat_ctrl_c_handler) + priority over a a Ctrl/C handler. See above. SIGINT has a + different condition value due to it's DECCCRTL roots and it's + the condition that gets raised for a "kill -INT". */ + if ((ctrlc_match || sigint_match) && __gnat_ctrl_c_handler) { SYS$DCLAST (__gnat_ctrl_c_handler, 0, 0); return SS$_CONTINUE; diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 1ead9365e5b..f1538de9922 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -3659,6 +3659,21 @@ package body Prj.Nmsc is end loop; end if; + if not Lib_Standalone.Default + and then Project.Library_Kind = Static + then + -- An standalone library must be a shared library + + Error_Msg_Name_1 := Project.Name; + + Error_Msg + (Data.Flags, + Continuation.all & + "standalone library project %% must be a shared library", + Project.Location, Project); + Continuation := Continuation_String'Access; + end if; + if Project.Library and not Data.In_Aggregate_Lib then -- Record the library name diff --git a/gcc/ada/projects.texi b/gcc/ada/projects.texi index ca477369b13..2c334686b54 100644 --- a/gcc/ada/projects.texi +++ b/gcc/ada/projects.texi @@ -1890,12 +1890,15 @@ language and takes a list of sources as parameter. library can furthermore only depends on static libraries (including the GNAT runtime). This attribute can be set to @code{no} to make it clear that the library should not be standalone in which case the - @code{Library_Interface} should not defined. + @code{Library_Interface} should not defined. Note that this attribute + only applies to shared libraries, so @code{Library_Kind} must be set + to @code{dynamic}. @smallexample @c projectfile @group for Library_Dir use "lib"; for Library_Name use "loggin"; + for Library_Kind use "dynamic"; for Library_Interface use ("lib1", "lib2"); -- unit names for Library_Standalone use "encapsulated"; @end group @@ -3772,8 +3775,15 @@ The list of languages of the sources of the project. @item @b{Roots}: list, indexed, file name index -The index is the file name of an executable source. Indicates the list of -units that need to be bound and linked with their closures with the executable. +The index is the file name of an executable source. Indicates the list of units +from the main project that need to be bound and linked with their closures +with the executable. The index is either a file name, a language name or "*". +The roots for an executable source are those in @b{Roots} with an index that +is the executable source file name, if declared. Otherwise, they are those in +@b{Roots} with an index that is the language name of the executable source, +if present. Otherwise, they are those in @b{Roots ("*")}, if declared. If none +of these three possibilities are declared, then there are no roots for the +executable source. @item @b{Externally_Built}: single diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index f78f2ae2d48..63bbef6645b 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -5896,19 +5896,14 @@ package body Sem_Res is -- In formal mode, the primitive operations of a tagged type or type -- extension do not include functions that return the tagged type. - -- Commented out as the call to Is_Inherited_Operation_For_Type may - -- cause an error because the type entity of the parent node of - -- Entity (Name (N) may not be set. ??? - -- So why not just add a guard ??? - --- if Nkind (N) = N_Function_Call --- and then Is_Tagged_Type (Etype (N)) --- and then Is_Entity_Name (Name (N)) --- and then Is_Inherited_Operation_For_Type --- (Entity (Name (N)), Etype (N)) --- then --- Check_SPARK_Restriction ("function not inherited", N); --- end if; + if Nkind (N) = N_Function_Call + and then Is_Tagged_Type (Etype (N)) + and then Is_Entity_Name (Name (N)) + and then Is_Inherited_Operation_For_Type + (Entity (Name (N)), Etype (N)) + then + Check_SPARK_Restriction ("function not inherited", N); + end if; -- Implement rule in 12.5.1 (23.3/2): In an instance, if the actual is -- class-wide and the call dispatches on result in a context that does diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 00db63d6f9c..fb4512914da 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -8462,8 +8462,11 @@ package body Sem_Util is Typ : Entity_Id) return Boolean is begin + -- Check that the operation has been created by the declaration for + -- the type. + return Is_Inherited_Operation (E) - and then Etype (Parent (E)) = Typ; + and then Defining_Identifier (Parent (E)) = Typ; end Is_Inherited_Operation_For_Type; ----------------- -- 2.30.2