mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-25 05:30:25 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
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.

From-SVN: r217837
This commit is contained in:
Arnaud Charlet 2014-11-20 12:13:40 +01:00
parent 4b963531a1
commit 6c802906a3
8 changed files with 310 additions and 83 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
gcc/ada/ChangeLog
View File

@ -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

108
gcc/ada/adaint.c
View File

@ -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;
#define Unlock_Task system__soft_links__unlock_task
extern void (*Unlock_Task) (void);
static void EnterCS (void)
{
EnterCriticalSection(&ProcListCS);
}
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);
/* 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;

2
gcc/ada/adaint.h
View File

@ -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

206
gcc/ada/exp_attr.adb
View File

@ -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 : <type of Pref> := Pref;
Temp := Make_Temporary (Loc, 'T', Pref);
Temp := Make_Temporary (Loc, 'T');
-- Preserve the tag of the prefix by offering a specific view of the
-- class-wide version of the prefix.
Insert_Action (N,
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition => New_Occurrence_Of (Typ, Loc),
Expression => Relocate_Node (Pref)));
if Is_Tagged_Type (Typ) then
-- 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

20
gcc/ada/final.c
View File

@ -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
}

2
gcc/ada/g-dirope.ads
View File

@ -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.

7
gcc/ada/initialize.c
View File

@ -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. */
{

3
gcc/ada/sem_res.adb
View File

@ -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);