diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 45 | ||||
| -rw-r--r-- | gcc/ada/adaint.c | 108 | ||||
| -rw-r--r-- | gcc/ada/adaint.h | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_attr.adb | 206 | ||||
| -rw-r--r-- | gcc/ada/final.c | 20 | ||||
| -rw-r--r-- | gcc/ada/g-dirope.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/initialize.c | 7 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 3 |
8 files changed, 310 insertions, 83 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c904bde..39c4e09 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,48 @@ +2014-11-20 Pascal Obry <obry@adacore.com> + + * initialize.c (ProcListCS): New extern variable (critical section). + (ProcListEvt): New extern variable (handle). + (__gnat_initialize)[Win32]: Initialize the ProcListCS critical + section object and the ProcListEvt event. + * final.c (__gnat_finalize)[Win32]: Properly finalize the + ProcListCS critical section and the ProcListEvt event. + * adaint.c (ProcListEvt): New Win32 event handle. + (EnterCS): New routine to enter the critical section when dealing with + child processes chain list. + (LeaveCS): As above to exit from the critical section. + (SignalListChanged): Routine to signal that the chain process list has + been updated. + (add_handle): Use EnterCS/LeaveCS, also call SignalListChanged when the + handle has been added. + (__gnat_win32_remove_handle): Use EnterCS/LeaveCS, + also call SignalListChanged if the handle has been found and removed. + (remove_handle): Routine removed, implementation merged with the above. + (win32_wait): Use EnterCS/LeaveCS for the critical section. Properly + copy the PID list locally to ensure that even if the list is updated + the local copy remains valid. Add into the hl (handle list) the + ProcListEvt handle. This handle is used to signal that a change has + been made into the process chain list. This is to ensure that a waiting + call can be resumed to take into account new processes. We also make + sure that if the handle was not found into the list we start over + the wait call. Indeed another concurrent call to win32_wait() + could already have handled this process. + +2014-11-20 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb (Resolve_Actuals): The legality rule concerning + the use of class-wide actuals for a non-controlling formal are + not rechecked in an instance. + +2014-11-20 Pascal Obry <obry@adacore.com> + + * g-dirope.ads: Minor typo fix. + +2014-11-20 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference, + Expand_Update_Attribute): Preserve the tag of a prefix by offering + a specific view of the class-wide version of the prefix. + 2014-11-20 Javier Miranda <miranda@adacore.com> * sem_ch6.adb (Analyze_Function_Return): For functions returning diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index cd3f11a3..36a1189 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -2311,20 +2311,29 @@ __gnat_number_of_cpus (void) for locking and unlocking tasks since we do not support multiple threads on this configuration (Cert run time on native Windows). */ -static void dummy (void) -{ -} - -void (*Lock_Task) () = &dummy; -void (*Unlock_Task) () = &dummy; +static void EnterCS (void) {} +static void LeaveCS (void) {} +static void SignalListChanged (void) {} #else -#define Lock_Task system__soft_links__lock_task -extern void (*Lock_Task) (void); +CRITICAL_SECTION ProcListCS; +HANDLE ProcListEvt; + +static void EnterCS (void) +{ + EnterCriticalSection(&ProcListCS); +} -#define Unlock_Task system__soft_links__unlock_task -extern void (*Unlock_Task) (void); +static void LeaveCS (void) +{ + LeaveCriticalSection(&ProcListCS); +} + +static void SignalListChanged (void) +{ + SetEvent (ProcListEvt); +} #endif @@ -2335,7 +2344,7 @@ static void add_handle (HANDLE h, int pid) { /* -------------------- critical section -------------------- */ - (*Lock_Task) (); + EnterCS(); if (plist_length == plist_max_length) { @@ -2350,14 +2359,19 @@ add_handle (HANDLE h, int pid) PID_LIST[plist_length] = pid; ++plist_length; - (*Unlock_Task) (); + SignalListChanged(); + LeaveCS(); /* -------------------- critical section -------------------- */ } -static void -remove_handle (HANDLE h, int pid) +int +__gnat_win32_remove_handle (HANDLE h, int pid) { int j; + int found = 0; + + /* -------------------- critical section -------------------- */ + EnterCS(); for (j = 0; j < plist_length; j++) { @@ -2367,21 +2381,18 @@ remove_handle (HANDLE h, int pid) --plist_length; HANDLES_LIST[j] = HANDLES_LIST[plist_length]; PID_LIST[j] = PID_LIST[plist_length]; + found = 1; break; } } -} -void -__gnat_win32_remove_handle (HANDLE h, int pid) -{ + LeaveCS(); /* -------------------- critical section -------------------- */ - (*Lock_Task) (); - remove_handle(h, pid); + if (found) + SignalListChanged(); - (*Unlock_Task) (); - /* -------------------- critical section -------------------- */ + return found; } static void @@ -2466,35 +2477,70 @@ win32_wait (int *status) DWORD exitcode, pid; HANDLE *hl; HANDLE h; + int *pidl; DWORD res; int hl_len; + int found; - /* -------------------- critical section -------------------- */ - (*Lock_Task) (); + START_WAIT: if (plist_length == 0) { errno = ECHILD; - (*Unlock_Task) (); return -1; } + /* -------------------- critical section -------------------- */ + EnterCS(); + hl_len = plist_length; +#ifdef CERT hl = (HANDLE *) xmalloc (sizeof (HANDLE) * hl_len); - memmove (hl, HANDLES_LIST, sizeof (HANDLE) * hl_len); + pidl = (int *) xmalloc (sizeof (int) * hl_len); + memmove (pidl, PID_LIST, sizeof (int) * hl_len); +#else + /* Note that index 0 contains the event hanlde that is signaled when the + process list has changed */ + hl = (HANDLE *) xmalloc (sizeof (HANDLE) * hl_len + 1); + hl[0] = ProcListEvt; + memmove (&hl[1], HANDLES_LIST, sizeof (HANDLE) * hl_len); + pidl = (int *) xmalloc (sizeof (int) * hl_len + 1); + memmove (&pidl[1], PID_LIST, sizeof (int) * hl_len); + hl_len++; +#endif + + LeaveCS(); + /* -------------------- critical section -------------------- */ res = WaitForMultipleObjects (hl_len, hl, FALSE, INFINITE); - h = hl[res - WAIT_OBJECT_0]; + /* if the ProcListEvt has been signaled then the list of processes has been + updated to add or remove a handle, just loop over */ + + if (res - WAIT_OBJECT_0 == 0) + { + free (hl); + free (pidl); + goto START_WAIT; + } + + h = hl[res - WAIT_OBJECT_0]; GetExitCodeProcess (h, &exitcode); - pid = PID_LIST [res - WAIT_OBJECT_0]; - remove_handle (h, -1); + pid = pidl [res - WAIT_OBJECT_0]; + + found = __gnat_win32_remove_handle (h, -1); - (*Unlock_Task) (); - /* -------------------- critical section -------------------- */ free (hl); + free (pidl); + + /* if not found another process waiting has already handled this process */ + + if (!found) + { + goto START_WAIT; + } *status = (int) exitcode; return (int) pid; diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h index d2a838e..b0e66cc 100644 --- a/gcc/ada/adaint.h +++ b/gcc/ada/adaint.h @@ -299,7 +299,7 @@ extern void __gnat_cpu_set (int, size_t, cpu_set_t *); #if defined (_WIN32) /* Interface to delete a handle from internally maintained list of child process handles on Windows */ -extern void +extern int __gnat_win32_remove_handle (HANDLE h, int pid); #endif diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index d2cd8e4..eb5f28f 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -1021,6 +1021,9 @@ package body Exp_Attr is Pref : constant Node_Id := Prefix (N); Typ : constant Entity_Id := Etype (Pref); Blk : Node_Id; + CW_Decl : Node_Id; + CW_Temp : Entity_Id; + CW_Typ : Entity_Id; Decls : List_Id; Installed : Boolean; Loc : Source_Ptr; @@ -1338,18 +1341,55 @@ package body Exp_Attr is -- Step 3: Create a constant to capture the value of the prefix at the -- entry point into the loop. - -- Generate: - -- Temp : constant <type of Pref> := <Pref>; - Temp_Id := Make_Temporary (Loc, 'P'); - Temp_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Temp_Id, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (Typ, Loc), - Expression => Relocate_Node (Pref)); - Append_To (Decls, Temp_Decl); + -- Preserve the tag of the prefix by offering a specific view of the + -- class-wide version of the prefix. + + if Is_Tagged_Type (Typ) then + + -- Generate: + -- CW_Temp : constant Typ'Class := Typ'Class (Pref); + + CW_Temp := Make_Temporary (Loc, 'T'); + CW_Typ := Class_Wide_Type (Typ); + + CW_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => CW_Temp, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (CW_Typ, Loc), + Expression => + Convert_To (CW_Typ, Relocate_Node (Pref))); + Append_To (Decls, CW_Decl); + + -- Generate: + -- Temp : Typ renames Typ (CW_Temp); + + Temp_Decl := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Temp_Id, + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Name => + Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc))); + Append_To (Decls, Temp_Decl); + + -- Non-tagged case + + else + CW_Decl := Empty; + + -- Generate: + -- Temp : constant Typ := Pref; + + Temp_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp_Id, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Typ, Loc), + Expression => Relocate_Node (Pref)); + Append_To (Decls, Temp_Decl); + end if; -- Step 4: Analyze all bits @@ -1374,6 +1414,10 @@ package body Exp_Attr is -- the declaration of the constant. else + if Present (CW_Decl) then + Analyze (CW_Decl); + end if; + Analyze (Temp_Decl); end if; @@ -4358,19 +4402,13 @@ package body Exp_Attr is --------- when Attribute_Old => Old : declare - Asn_Stm : Node_Id; + Typ : constant Entity_Id := Etype (N); + CW_Temp : Entity_Id; + CW_Typ : Entity_Id; Subp : Node_Id; Temp : Entity_Id; begin - Temp := Make_Temporary (Loc, 'T', Pref); - - -- Set the entity kind now in order to mark the temporary as a - -- handler of attribute 'Old's prefix. - - Set_Ekind (Temp, E_Constant); - Set_Stores_Attribute_Old_Prefix (Temp); - -- Climb the parent chain looking for subprogram _Postconditions Subp := N; @@ -4395,15 +4433,13 @@ package body Exp_Attr is pragma Assert (Present (Subp)); - -- Generate: - -- Temp : constant <Pref type> := <Pref>; + Temp := Make_Temporary (Loc, 'T', Pref); - Asn_Stm := - Make_Object_Declaration (Loc, - Defining_Identifier => Temp, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (Etype (N), Loc), - Expression => Pref); + -- Set the entity kind now in order to mark the temporary as a + -- handler of attribute 'Old's prefix. + + Set_Ekind (Temp, E_Constant); + Set_Stores_Attribute_Old_Prefix (Temp); -- Push the scope of the related subprogram where _Postcondition -- resides as this ensures that the object will be analyzed in the @@ -4411,12 +4447,49 @@ package body Exp_Attr is Push_Scope (Scope (Defining_Entity (Subp))); - -- The object declaration is inserted before the body of subprogram - -- _Postconditions. This ensures that any precondition-like actions - -- are still executed before any parameter values are captured and - -- the multiple 'Old occurrences appear in order of declaration. + -- Preserve the tag of the prefix by offering a specific view of the + -- class-wide version of the prefix. + + if Is_Tagged_Type (Typ) then + + -- Generate: + -- CW_Temp : constant Typ'Class := Typ'Class (Pref); + + CW_Temp := Make_Temporary (Loc, 'T'); + CW_Typ := Class_Wide_Type (Typ); + + Insert_Before_And_Analyze (Subp, + Make_Object_Declaration (Loc, + Defining_Identifier => CW_Temp, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (CW_Typ, Loc), + Expression => + Convert_To (CW_Typ, Relocate_Node (Pref)))); + + -- Generate: + -- Temp : Typ renames Typ (CW_Temp); + + Insert_Before_And_Analyze (Subp, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Temp, + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Name => + Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc)))); + + -- Non-tagged case + + else + -- Generate: + -- Temp : constant Typ := Pref; + + Insert_Before_And_Analyze (Subp, + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Typ, Loc), + Expression => Relocate_Node (Pref))); + end if; - Insert_Before_And_Analyze (Subp, Asn_Stm); Pop_Scope; -- Ensure that the prefix of attribute 'Old is valid. The check must @@ -7351,30 +7424,65 @@ package body Exp_Attr is -- Local variables - Aggr : constant Node_Id := First (Expressions (N)); - Loc : constant Source_Ptr := Sloc (N); - Pref : constant Node_Id := Prefix (N); - Typ : constant Entity_Id := Etype (Pref); - Assoc : Node_Id; - Comp : Node_Id; - Expr : Node_Id; - Temp : Entity_Id; + Aggr : constant Node_Id := First (Expressions (N)); + Loc : constant Source_Ptr := Sloc (N); + Pref : constant Node_Id := Prefix (N); + Typ : constant Entity_Id := Etype (Pref); + Assoc : Node_Id; + Comp : Node_Id; + CW_Temp : Entity_Id; + CW_Typ : Entity_Id; + Expr : Node_Id; + Temp : Entity_Id; -- Start of processing for Expand_Update_Attribute begin - -- Create the anonymous object that stores the value of the prefix and - -- reflects subsequent changes in value. Generate: + -- Create the anonymous object to store the value of the prefix and + -- capture subsequent changes in value. + + Temp := Make_Temporary (Loc, 'T', Pref); - -- Temp : <type of Pref> := Pref; + -- Preserve the tag of the prefix by offering a specific view of the + -- class-wide version of the prefix. - Temp := Make_Temporary (Loc, 'T'); + if Is_Tagged_Type (Typ) then - Insert_Action (N, - Make_Object_Declaration (Loc, - Defining_Identifier => Temp, - Object_Definition => New_Occurrence_Of (Typ, Loc), - Expression => Relocate_Node (Pref))); + -- Generate: + -- CW_Temp : Typ'Class := Typ'Class (Pref); + + CW_Temp := Make_Temporary (Loc, 'T'); + CW_Typ := Class_Wide_Type (Typ); + + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => CW_Temp, + Object_Definition => New_Occurrence_Of (CW_Typ, Loc), + Expression => + Convert_To (CW_Typ, Relocate_Node (Pref)))); + + -- Generate: + -- Temp : Typ renames Typ (CW_Temp); + + Insert_Action (N, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Temp, + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Name => + Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc)))); + + -- Non-tagged case + + else + -- Generate: + -- Temp : Typ := Pref; + + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => New_Occurrence_Of (Typ, Loc), + Expression => Relocate_Node (Pref))); + end if; -- Process the update aggregate diff --git a/gcc/ada/final.c b/gcc/ada/final.c index b49b3de..dffc2b2 100644 --- a/gcc/ada/final.c +++ b/gcc/ada/final.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2011, Free Software Foundation, Inc. * + * Copyright (C) 1992-2014, 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- * @@ -40,10 +40,28 @@ extern void __gnat_finalize (void); at all, the intention is that this be replaced by system specific code where finalization is required. */ +#if defined (__MINGW32__) +#include "mingw32.h" +#include <windows.h> + +extern CRITICAL_SECTION ProcListCS; +extern HANDLE ProcListEvt; + +void +__gnat_finalize (void) +{ + /* delete critical section and event handle used for the + processes chain list */ + DeleteCriticalSection(&ProcListCS); + CloseHandle (ProcListEvt); +} + +#else void __gnat_finalize (void) { } +#endif #ifdef __cplusplus } diff --git a/gcc/ada/g-dirope.ads b/gcc/ada/g-dirope.ads index fe02d3f..c3c207f 100644 --- a/gcc/ada/g-dirope.ads +++ b/gcc/ada/g-dirope.ads @@ -175,7 +175,7 @@ package GNAT.Directory_Operations is -- Returns Path with environment variables replaced by the current -- environment variable value. For example, $HOME/mydir will be replaced -- by /home/joe/mydir if $HOME environment variable is set to /home/joe and - -- Mode is UNIX. If an environment variable does not exists the variable + -- Mode is UNIX. If an environment variable does not exist the variable -- will be replaced by the empty string. Two dollar or percent signs are -- replaced by a single dollar/percent sign. Note that a variable must -- start with a letter. diff --git a/gcc/ada/initialize.c b/gcc/ada/initialize.c index 36df501..9426c9e 100644 --- a/gcc/ada/initialize.c +++ b/gcc/ada/initialize.c @@ -74,6 +74,8 @@ extern void __gnat_install_SEH_handler (void *); extern int gnat_argc; extern char **gnat_argv; +extern CRITICAL_SECTION ProcListCS; +extern HANDLE ProcListEvt; #ifdef GNAT_UNICODE_SUPPORT @@ -138,6 +140,11 @@ __gnat_initialize (void *eh ATTRIBUTE_UNUSED) given that we have set Max_Digits etc with this in mind */ __gnat_init_float (); + /* Initialize the critical section and event handle for the win32_wait() + implementation, see adaint.c */ + InitializeCriticalSection (&ProcListCS); + ProcListEvt = CreateEvent (NULL, FALSE, FALSE, NULL); + #ifdef GNAT_UNICODE_SUPPORT /* Set current code page for filenames handling. */ { diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 24628bc..71f480f 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -4520,9 +4520,12 @@ package body Sem_Res is Validate_Remote_Access_To_Class_Wide_Type (A); end if; + -- Apply legality rule 3.9.2 (9/1) + if (Is_Class_Wide_Type (A_Typ) or else Is_Dynamically_Tagged (A)) and then not Is_Class_Wide_Type (F_Typ) and then not Is_Controlling_Formal (F) + and then not In_Instance then Error_Msg_N ("class-wide argument not allowed here!", A); |