+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
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
add_handle (HANDLE h, int pid)
{
/* -------------------- critical section -------------------- */
- (*Lock_Task) ();
+ EnterCS();
if (plist_length == plist_max_length)
{
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++)
{
--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
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;
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;
-- 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
-- the declaration of the constant.
else
+ if Present (CW_Decl) then
+ Analyze (CW_Decl);
+ end if;
+
Analyze (Temp_Decl);
end if;
---------
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;
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
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
-- 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
projects / gcc.git / commitdiff