|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - downloadIndex: ┃ B T ┃
Length: 40180 (0x9cf4)
Types: TextFile
Names: »B«
└─⟦85b835f43⟧ Bits:30000549 8mm tape, Rational 1000, Xlib rev 6.00
└─ ⟦0c20f784e⟧ »DATA«
└─⟦1abbe589f⟧
└─⟦059497ac5⟧
└─⟦this⟧
with Xlbt_Arithmetic;
use Xlbt_Arithmetic;
with Xlbt_Basic;
use Xlbt_Basic;
with Xlbt_Display2;
use Xlbt_Display2;
with Xlbt_Event;
use Xlbt_Event;
with Xlbt_Misc;
use Xlbt_Misc;
with Xlbt_Proc_Var;
use Xlbt_Proc_Var;
with Xlbt_Request;
use Xlbt_Request;
with Xlbt_Window;
use Xlbt_Window;
with Xlbp_Proc_Var;
use Xlbp_Proc_Var;
with Xlbit_Library4;
use Xlbit_Library4;
with Xlbip_Default_Proc_Vars;
use Xlbip_Default_Proc_Vars;
with Xlbip_Internal;
use Xlbip_Internal;
with Xlbip_Put_Request;
use Xlbip_Put_Request;
with Xlbmt_Network_Types;
use Xlbmt_Network_Types;
with Xlbmt_Parameters;
use Xlbmt_Parameters;
with Xlbmp_Internal;
use Xlbmp_Internal;
package body Xlbp_Event is
------------------------------------------------------------------------------
-- X Library Event Handling
--
-- Xlbp_Event - Routines for reading, writing, and handling X events.
------------------------------------------------------------------------------
-- Copyright 1989 - 1991 by Rational, Santa Clara, California.
-- Copyright 1985 - 1989 by the Massachusetts Institute of Technology
--
-- All Rights Reserved.
--
-- Permission to use, copy, modify, and distribute this software and its
-- documentation for any purpose and without fee is hereby granted,
-- provided that the above copyright notice(s) appear in all copies and that
-- both that copyright notice(s) and this permission notice appear in
-- supporting documentation, and that the names of MIT or Rational not be
-- used in advertising or publicity pertaining to distribution of the software
-- without specific, written prior permission.
--
-- MIT and Rational disclaim all warranties with regard to this software,
-- including all implied warranties of merchantability and fitness, in no
-- event shall MIT or Rational be liable for any special, indirect or
-- consequential damages or any damages whatsoever resulting from loss of use,
-- data or profits, whether in an action of contract, negligence or other
-- tortious action, arising out of or in connection with the use or performance
-- of this software.
------------------------------------------------------------------------------
--\f
procedure X_Flush (Display : X_Display) is
------------------------------------------------------------------------------
-- Force any buffered server requests to be transmitted immediately.
------------------------------------------------------------------------------
begin
Lock_Display (Display);
Internal_X_Flush_Display (Display);
Unlock_Display (Display);
end X_Flush;
--\f
procedure X_Put_Back_Event (Display : X_Display;
Event : X_Event) is
Qelt : X_Queued_Event;
begin
----Lock the display.
Lock_Display (Display);
begin
----Get a new event record.
Qelt := Display.Q_Free;
if Qelt = None_X_Queued_Event then
Qelt := new X_Queued_Event_Rec;
else
Display.Q_Free := Qelt.Next;
end if;
----Put the new event onto the queue of events.
Qelt.Next := Display.Head;
Qelt.Event := Event;
Display.Head := Qelt;
if Display.Tail = null then
Display.Tail := Qelt;
end if;
Display.Q_Len := Display.Q_Len + 1;
----Catch exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; return.
Unlock_Display (Display);
end X_Put_Back_Event;
--\f
procedure X_Select_Input (Display : X_Display;
Window : X_Window;
Event_Mask : X_Event_Mask) is
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
Put_X_Change_Window_Attributes_Request
(Display,
(Kind => Change_Window_Attributes,
Length => X_Change_Window_Attributes_Request'Size / 32 + 1,
Pad => 0,
Window => Window,
Value_Mask => (Cw_Event_Mask => True, others => False)),
4);
Put_X_Event_Mask (Display, Event_Mask);
----Catch exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; return.
Unlock_Display (Display);
Sync_Handle (Display);
end X_Select_Input;
--\f
procedure X_Send_Event (Display : X_Display;
Window : X_Window;
Propagate : Boolean;
Event_Mask : X_Event_Mask;
Event : X_Event;
Status : out X_Status) is
------------------------------------------------------------------------------
-- In order to avoid all images requiring private_X_Event_To_Wire, we install the
-- Event converter here if it has never been installed.
------------------------------------------------------------------------------
Ev : X_Raw_Data_Array (1 .. 32);
Fp : X_Procedure_Variable;
Succ : X_Status;
begin
----Lock the display.
Lock_Display (Display);
begin
-- call through disp to find proper conversion routine
Fp := Display.Wire_Vec (Event.Kind);
if Fp = None_X_Procedure_Variable then
Fp := X_Lib_Default_X_Event_To_Wire;
Display.Wire_Vec (Event.Kind) := Fp;
end if;
Proc_Var_X_Event_Wire.Call
(Proc_Var_X_Event_Wire.To_Pv (Fp), Display, Event, Ev, Succ);
if Succ = Failed then
Status := Failed;
else
Status := Successful;
Put_X_Send_Event_Request
(Display, (Kind => Send_Event,
Length => X_Send_Event_Request'Size / 32,
Destination => Window,
Propagate => From_Boolean (Propagate),
Event_Mask => Event_Mask,
Event => Ev));
end if;
----Catch exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; return.
Unlock_Display (Display);
Sync_Handle (Display);
end X_Send_Event;
--\f
function X_Events_Queued (Display : X_Display;
Mode : X_Event_Queuing) return S_Long is
Ret_Val : S_Long;
begin
Lock_Display (Display);
begin
if Display.Q_Len > 0 or else Mode = Queued_Already then
Ret_Val := Display.Q_Len;
else
Ret_Val := Internal_X_Events_Queued (Display, Mode);
end if;
exception
when others =>
Unlock_Display (Display);
raise;
end;
Unlock_Display (Display);
return Ret_Val;
end X_Events_Queued;
--\f
function X_Pending (Display : X_Display) return S_Long is
Ret_Val : S_Long;
begin
Lock_Display (Display);
begin
if Display.Q_Len > 0 then
Ret_Val := Display.Q_Len;
else
Ret_Val := Internal_X_Events_Queued
(Display, Queued_After_Flush);
end if;
exception
when others =>
Unlock_Display (Display);
raise;
end;
Unlock_Display (Display);
return Ret_Val;
end X_Pending;
--\f
procedure X_Check_If_Event (Display : X_Display;
Event : in out X_Event;
Args : in out Predicate_Argument_Type;
Status : out X_Status) is
------------------------------------------------------------------------------
-- Check existing events in queue to see if any match. Return the first match
-- found. If no match is found then flush output buffer and return the next
-- event in the queue matching the predicate. Return whether such an event was
-- found. Events earlier in the queue are not discarded.
------------------------------------------------------------------------------
Prev : X_Queued_Event;
Qelt : X_Queued_Event;
Void : S_Long;
Succ : X_Status;
begin
----Lock the display; catch any exceptions.
Lock_Display (Display);
begin
----The first time through we start at the head of the event list for the
-- display. Run down the full list until we reach the end or until we find
-- a match.
Prev := null;
Qelt := Display.Head;
for N in reverse 0 .. 2 loop
while Qelt /= null loop
----Check for and return any matches.
Predicate (Display, Qelt.Event, Args, Succ);
if Succ = Successful then
Event := Qelt.Event; -- Return the match
if Prev /= null then -- Unlink the match
Prev.Next := Qelt.Next;
if Prev.Next = null then
Display.Tail := Prev;
end if;
else
Display.Head := Qelt.Next;
if Display.Head = null then
Display.Tail := null;
end if;
end if;
if Display.Q_Free_Len >= X_Max_Q_Free then
Free_X_Queued_Event (Qelt);
else
Qelt.Next := Display.Q_Free;
Display.Q_Free := Qelt;
Display.Q_Free_Len := Display.Q_Free_Len + 1;
end if;
Display.Q_Len := Display.Q_Len - 1;
Unlock_Display (Display);
Status := Successful;
return;
end if;
----Loop for next event.
Prev := Qelt;
Qelt := Prev.Next;
end loop;
----No existing events match. If this is the first or second time then try to
-- get more events. If not then exit and return failure.
if N = 0 then
exit;
elsif N = 1 then
Internal_X_Flush_Display (Display);
elsif N = 2 then
Void := Internal_X_Events_Queued
(Display, Queued_After_Reading);
end if;
if Prev = null then-- Start at head of new events.
Qelt := Display.Head;
else
Qelt := Prev.Next;
end if;
end loop;
----Catch exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; return.
Status := Failed;
Unlock_Display (Display);
end X_Check_If_Event;
--\f
procedure X_Check_Mask_Event (Display : X_Display;
Event_Mask : X_Event_Mask;
Event : in out X_Event;
Status : out X_Status) is
------------------------------------------------------------------------------
-- Check existing events in queue to find any that match the Event_mask. Return the
-- first one that matches. If none match then flush output buffer and attempt
-- to read new events. If one of these matches then return it. If this fails
-- then return that status to the caller.
------------------------------------------------------------------------------
Prev : X_Queued_Event;
Qelt : X_Queued_Event;
Void : S_Long;
begin
----Lock the display.
Lock_Display (Display);
begin
----The first time through the loop we start with the existing event queue.
Prev := null;
Qelt := Display.Head;
for N in reverse 0 .. 2 loop
while Qelt /= null loop
----If this event matches the event Event_mask then return it.
if (X_Event_To_Mask (Qelt.Event.Kind) and Event_Mask) /=
None_X_Event_Mask
and then
(Qelt.Event.Kind /= Motion_Notify
or else
(Event_Mask and All_Pointers) /= None_X_Event_Mask
or else
(Event_Mask and All_Buttons) /= None_X_Event_Mask) then
Event := Qelt.Event; -- Return event
if Prev /= null then -- Unlink event
Prev.Next := Qelt.Next;
if Prev.Next = null then
Display.Tail := Prev;
end if;
else
Display.Head := Qelt.Next;
if Display.Head = null then
Display.Tail := null;
end if;
end if;
if Display.Q_Free_Len >= X_Max_Q_Free then
Free_X_Queued_Event (Qelt);
else
Qelt.Next := Display.Q_Free;
Display.Q_Free := Qelt;
Display.Q_Free_Len := Display.Q_Free_Len + 1;
end if;
Display.Q_Len := Display.Q_Len - 1;
Status := Successful;
Unlock_Display (Display);
return;
end if;
----Loop for next event on list.
Prev := Qelt;
Qelt := Qelt.Next;
end loop;
----No existing events match. If this is the first or second time then try to
-- get more events. If not then exit and return failure.
if N = 0 then
exit;
elsif N = 1 then
Internal_X_Flush_Display (Display);
elsif N = 2 then
Void := Internal_X_Events_Queued
(Display, Queued_After_Reading);
end if;
if Prev = null then -- Start search where we left off.
Qelt := Display.Head;
else
Qelt := Prev.Next;
end if;
end loop;
----Catch exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; return.
Status := Failed;
Unlock_Display (Display);
end X_Check_Mask_Event;
--\f
procedure X_Check_Typed_Event (Display : X_Display;
Kind : X_Event_Code;
Event : in out X_Event;
Status : out X_Status) is
------------------------------------------------------------------------------
-- Check existing events in queue to find any that match the type. Return the
-- first one that matches. If none match then flush the output queue and
-- attempt to read some more events. If one matches then return it. Otherwise
-- return failure to the caller.
------------------------------------------------------------------------------
Prev : X_Queued_Event;
Qelt : X_Queued_Event;
Void : S_Long;
begin
----Lock the display.
Lock_Display (Display);
begin
----The first time through the loop we start at the head of the existing list.
Prev := null;
Qelt := Display.Head;
for N in reverse 0 .. 2 loop
while Qelt /= null loop
----If this event is the right type then return it.
if Qelt.Event.Kind = Kind then
Event := Qelt.Event; -- Return event
if Prev /= null then -- Unlink event
Prev.Next := Qelt.Next;
if Prev.Next = null then
Display.Tail := Prev;
end if;
else
Display.Head := Qelt.Next;
if Display.Head = null then
Display.Tail := null;
end if;
end if;
if Display.Q_Free_Len >= X_Max_Q_Free then
Free_X_Queued_Event (Qelt);
else
Qelt.Next := Display.Q_Free;
Display.Q_Free := Qelt;
Display.Q_Free_Len := Display.Q_Free_Len + 1;
end if;
Display.Q_Len := Display.Q_Len - 1;
Status := Successful;
Unlock_Display (Display);
return;
end if;
----Loop for the next event.
Prev := Qelt;
Qelt := Qelt.Next;
end loop;
----No existing events match. If this is the first or second time then try to
-- get more events. If not then exit and return failure.
if N = 0 then
Status := Failed;
exit;
elsif N = 1 then
Internal_X_Flush_Display (Display);
elsif N = 2 then
Void := Internal_X_Events_Queued
(Display, Queued_After_Reading);
end if;
if Prev = null then -- Start search where we left off.
Qelt := Display.Head;
else
Qelt := Prev.Next;
end if;
end loop;
----Catch exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; return.
Unlock_Display (Display);
end X_Check_Typed_Event;
--\f
procedure X_Check_Typed_Window_Event
(Display : X_Display;
Window : X_Window;
Kind : X_Event_Code;
Event : in out X_Event;
Status : out X_Status) is
------------------------------------------------------------------------------
-- Run through the event queue looking for an event that matches the type
-- and window. Return the first one found. If none are found then
-- flush the output buffer and try reading some more events. If that does
-- not produce and event that matches then return failure.
------------------------------------------------------------------------------
Prev : X_Queued_Event;
Qelt : X_Queued_Event;
Void : S_Long;
begin
----Lock the display.
Lock_Display (Display);
begin
----The first time we go through the loop we start at the head of the list.
Prev := null;
Qelt := Display.Head;
for N in reverse 0 .. 2 loop
while Qelt /= null loop
----If this event has the right type and window then return it.
if Qelt.Event.Kind = Kind and then
Qelt.Event.Window = Window then
Event := Qelt.Event; -- Return event
if Prev /= null then -- Unlink event
Prev.Next := Qelt.Next;
if Prev.Next = null then
Display.Tail := Prev;
end if;
else
Display.Head := Qelt.Next;
if Display.Head = null then
Display.Tail := null;
end if;
end if;
if Display.Q_Free_Len >= X_Max_Q_Free then
Free_X_Queued_Event (Qelt);
else
Qelt.Next := Display.Q_Free;
Display.Q_Free := Qelt;
Display.Q_Free_Len := Display.Q_Free_Len + 1;
end if;
Display.Q_Len := Display.Q_Len - 1;
Status := Successful;
Unlock_Display (Display);
return;
end if;
----Loop for the next event.
Prev := Qelt;
Qelt := Qelt.Next;
end loop;
----No existing events match. If this is the first or second time then try to
-- get more events. If not then exit and return failure.
if N = 0 then
Status := Failed;
exit;
elsif N = 1 then
Internal_X_Flush_Display (Display);
elsif N = 2 then
Void := Internal_X_Events_Queued
(Display, Queued_After_Reading);
end if;
if Prev = null then -- Start search where we left off.
Qelt := Display.Head;
else
Qelt := Prev.Next;
end if;
end loop;
----Catch exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; return.
Unlock_Display (Display);
end X_Check_Typed_Window_Event;
--\f
procedure X_Check_Window_Event (Display : X_Display;
Window : X_Window;
Event_Mask : X_Event_Mask;
Event : in out X_Event;
Status : out X_Status) is
------------------------------------------------------------------------------
-- Run through the event queue looking for an event that matches the event
-- Event_mask and window. Return the first one found. If none are found then
-- flush the output buffer and try reading some more events. If that does
-- not produce and event that matches then return failure.
------------------------------------------------------------------------------
Prev : X_Queued_Event;
Qelt : X_Queued_Event;
Void : S_Long;
begin
----Lock the display.
Lock_Display (Display);
begin
----The first time through the loop we start at the head of the event queue.
Prev := null;
Qelt := Display.Head;
for N in reverse 0 .. 2 loop
while Qelt /= null loop
----If this event matches the event Event_mask and has the right window then return.
if Qelt.Event.Window /= Window and then
(X_Event_To_Mask (Qelt.Event.Kind) and Event_Mask) /=
None_X_Event_Mask
and then
(Qelt.Event.Kind /= Motion_Notify
or else
(Event_Mask and All_Pointers) /= None_X_Event_Mask
or else
(Event_Mask and All_Buttons) /= None_X_Event_Mask) then
Event := Qelt.Event;
if Prev /= null then
Prev.Next := Qelt.Next;
if Prev.Next = null then
Display.Tail := Prev;
end if;
else
Display.Head := Qelt.Next;
if Display.Head = null then
Display.Tail := null;
end if;
end if;
if Display.Q_Free_Len >= X_Max_Q_Free then
Free_X_Queued_Event (Qelt);
else
Qelt.Next := Display.Q_Free;
Display.Q_Free := Qelt;
Display.Q_Free_Len := Display.Q_Free_Len + 1;
end if;
Display.Q_Len := Display.Q_Len - 1;
Status := Successful;
Unlock_Display (Display);
return;
end if;
----Loop for the next event.
Prev := Qelt;
Qelt := Qelt.Next;
end loop;
----No existing events match. If this is the first or second time then try to
-- get more events. If not then exit and return failure.
if N = 0 then
Status := Failed;
exit;
elsif N = 1 then
Internal_X_Flush_Display (Display);
elsif N = 2 then
Void := Internal_X_Events_Queued
(Display, Queued_After_Reading);
end if;
if Prev = null then -- Start search where we left off.
Qelt := Display.Head;
else
Qelt := Prev.Next;
end if;
end loop;
----Catch exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; return.
Unlock_Display (Display);
end X_Check_Window_Event;
--\f
procedure X_If_Event (Display : X_Display;
Event : out X_Event;
Args : in out Predicate_Argument_Type) is
------------------------------------------------------------------------------
-- Flush output and (wait for and) return the next Event matching the
-- predicate in the queue.
------------------------------------------------------------------------------
Qelt : X_Queued_Event;
Prev : X_Queued_Event;
Succ : X_Status;
begin
----Lock the display.
Lock_Display (Display);
begin
----First must search queue to find if any events match. If so, then remove
-- from queue.
Prev := null;
Qelt := Display.Head;
loop
while Qelt /= null loop
Predicate (Display, Qelt.Event, Args, Succ);
if Succ = Successful then
Event := Qelt.Event;
if Prev /= null then
Prev.Next := Qelt.Next;
if Qelt.Next = null then
Display.Tail := Prev;
end if;
else
Display.Head := Qelt.Next;
if Qelt.Next = null then
Display.Tail := null;
end if;
end if;
if Display.Q_Free_Len >= X_Max_Q_Free then
Free_X_Queued_Event (Qelt);
else
Qelt.Next := Display.Q_Free;
Display.Q_Free := Qelt;
Display.Q_Free_Len := Display.Q_Free_Len + 1;
end if;
Display.Q_Len := Display.Q_Len - 1;
Unlock_Display (Display);
return;
end if;
Prev := Qelt;
Qelt := Qelt.Next;
end loop;
----If the queue is empty, read as many events as possible and enqueue them.
Internal_X_Read_Events (Display);
if Prev = null then
Qelt := Display.Head;
elsif Prev.Next /= null then
Qelt := Prev.Next;
end if;
end loop;
----Catch exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
end X_If_Event;
--\f
procedure X_Mask_Event (Display : X_Display;
Event_Mask : X_Event_Mask;
Event : out X_Event) is
------------------------------------------------------------------------------
-- Flush output and (wait for and) return the next Event in the queue
-- matching one of the events in the Event_mask.
-- Events earlier in the queue are not discarded.
------------------------------------------------------------------------------
Prev : X_Queued_Event;
Qelt : X_Queued_Event;
begin
----Lock the display.
Lock_Display (Display);
begin
Prev := null;
Qelt := Display.Head;
loop
while Qelt /= null loop
if (X_Event_To_Mask (Qelt.Event.Kind) and Event_Mask) /=
None_X_Event_Mask
and then
(Qelt.Event.Kind /= Motion_Notify
or else
(Event_Mask and All_Pointers) /= None_X_Event_Mask
or else
(Event_Mask and All_Pointers) /= None_X_Event_Mask) then
Event := Qelt.Event;
if Prev /= null then
Prev.Next := Qelt.Next;
if Prev.Next = null then
Display.Tail := Prev;
end if;
else
Display.Head := Qelt.Next;
if Display.Head = null then
Display.Tail := null;
end if;
end if;
if Display.Q_Free_Len >= X_Max_Q_Free then
Free_X_Queued_Event (Qelt);
else
Qelt.Next := Display.Q_Free;
Display.Q_Free := Qelt;
Display.Q_Free_Len := Display.Q_Free_Len + 1;
end if;
Display.Q_Len := Display.Q_Len - 1;
Unlock_Display (Display);
return;
end if;
Prev := Qelt;
Qelt := Qelt.Next;
end loop;
----If the queue is empty, read as many events as possible and enqueue them.
Internal_X_Read_Events (Display);
if Prev = null then
Qelt := Display.Head;
elsif Prev.Next /= null then
Qelt := Prev.Next;
end if;
end loop;
----Catch exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
end X_Mask_Event;
--\f
procedure X_Next_Event (Display : X_Display;
Event : out X_Event) is
------------------------------------------------------------------------------
-- Return the next event in the queue. If there are none then read at least
-- one and return the first one.
------------------------------------------------------------------------------
Qelt : X_Queued_Event;
begin
----Lock the display.
Lock_Display (Display);
begin
----If the queue is empty, read as many events as possible and enqueue them.
if Display.Head = null then
Internal_X_Read_Events (Display);
end if;
Qelt := Display.Head;
Event := Qelt.Event;
----Move the head of the queue to the free list.
Display.Head := Qelt.Next;
if Display.Head = null then
Display.Tail := null;
end if;
if Display.Q_Free_Len >= X_Max_Q_Free then
Free_X_Queued_Event (Qelt);
else
Qelt.Next := Display.Q_Free;
Display.Q_Free := Qelt;
Display.Q_Free_Len := Display.Q_Free_Len + 1;
end if;
Display.Q_Len := Display.Q_Len - 1;
----Catch exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; return.
Unlock_Display (Display);
end X_Next_Event;
--\f
procedure X_Peek_Event (Display : X_Display;
Event : out X_Event) is
------------------------------------------------------------------------------
-- Return the next event in the queue but do not remove it from the queue.
-- If the queue is empty then flush the output buffer and wait for an event
-- to arrive.
------------------------------------------------------------------------------
begin
----Lock the display.
Lock_Display (Display);
begin
if Display.Head = null then
Internal_X_Read_Events (Display);
end if;
Event := Display.Head.Event;
----Catch exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
Unlock_Display (Display);
end X_Peek_Event;
--\f
procedure X_Peek_If_Event (Display : X_Display;
Event : out X_Event;
Args : in out Predicate_Argument_Type) is
------------------------------------------------------------------------------
-- Flush output and (wait for and) return the next Event in the queue
-- that satisfies the predicate.
-- BUT do not remove it from the queue.
------------------------------------------------------------------------------
Qelt : X_Queued_Event;
Succ : X_Status;
begin
----Lock the display.
Lock_Display (Display);
begin
if Display.Head = null then
Internal_X_Read_Events (Display);
end if;
Predicate (Display, Display.Head.Event, Args, Succ);
if Succ = Successful then
Event := Display.Head.Event;
else
Qelt := Display.Head;
loop
while Qelt.Next /= null loop
Predicate (Display, Qelt.Next.Event, Args, Succ);
if Succ = Successful then
Event := Qelt.Next.Event;
Unlock_Display (Display);
return;
end if;
Qelt := Qelt.Next;
end loop;
Internal_X_Read_Events (Display);
end loop;
end if;
----Catch exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
Unlock_Display (Display);
end X_Peek_If_Event;
--\f
procedure X_Window_Event (Display : X_Display;
Window : X_Window; -- Selected window
Event_Mask : X_Event_Mask; -- Selected events
Event : out X_Event) is
------------------------------------------------------------------------------
-- Flush output and (wait for and) return the next Event in the queue
-- for the given window matching one of the events in the mask.
-- Events earlier in the queue are not discarded.
------------------------------------------------------------------------------
Prev : X_Queued_Event;
Qelt : X_Queued_Event;
begin
----Lock the display.
Lock_Display (Display);
begin
Prev := null;
Qelt := Display.Head;
loop
while Qelt /= null loop
if Qelt.Event.Window = Window and then
(X_Event_To_Mask (Qelt.Event.Kind) and Event_Mask) /=
None_X_Event_Mask
and then
(Qelt.Event.Kind /= Motion_Notify
or else
(Event_Mask and All_Pointers) /= None_X_Event_Mask
or else
(Event_Mask and All_Buttons) /= None_X_Event_Mask) then
Event := Qelt.Event;
if Prev /= null then
Prev.Next := Qelt.Next;
if Prev.Next = null then
Display.Tail := Prev;
end if;
else
Display.Head := Qelt.Next;
if Display.Head = null then
Display.Tail := null;
end if;
end if;
if Display.Q_Free_Len >= X_Max_Q_Free then
Free_X_Queued_Event (Qelt);
else
Qelt.Next := Display.Q_Free;
Display.Q_Free := Qelt;
Display.Q_Free_Len := Display.Q_Free_Len + 1;
end if;
Display.Q_Len := Display.Q_Len - 1;
Unlock_Display (Display);
return;
end if;
Prev := Qelt;
Qelt := Qelt.Next;
end loop;
Internal_X_Read_Events (Display);
if Prev = null then
Qelt := Display.Head;
else
Qelt := Prev.Next;
end if;
end loop;
----Catch exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
end X_Window_Event;
end Xlbp_Event;