|
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 - metrics - downloadIndex: B T
Length: 21278 (0x531e)
Types: TextFile
Names: »B«
└─⟦85b835f43⟧ Bits:30000549 8mm tape, Rational 1000, Xlib rev 6.00
└─⟦0c20f784e⟧ »DATA«
└─⟦1abbe589f⟧
└─⟦059497ac5⟧
└─⟦this⟧
with Unchecked_Deallocation;
with Xlbt_Arithmetic;
use Xlbt_Arithmetic;
with Xlbt_Basic;
use Xlbt_Basic;
with Xlbt_Context_Manager2;
use Xlbt_Context_Manager2;
with Xlbt_Display2;
use Xlbt_Display2;
with Xlbt_Event;
use Xlbt_Event;
with Xlbt_Event3;
with Xlbt_Exceptions;
use Xlbt_Exceptions;
with Xlbt_Extension;
use Xlbt_Extension;
with Xlbt_Graphics;
use Xlbt_Graphics;
with Xlbt_Key;
use Xlbt_Key;
with Xlbt_Key2;
use Xlbt_Key2;
with Xlbt_Proc_Var;
use Xlbt_Proc_Var;
with Xlbt_Request3;
use Xlbt_Request3;
with Xlbt_Rm;
use Xlbt_Rm;
with Xlbt_String;
use Xlbt_String;
with Xlbt_Univ_Ptr;
use Xlbt_Univ_Ptr;
with Xlbt_Visual;
use Xlbt_Visual;
with Xlbp_Display;
use Xlbp_Display;
with Xlbp_Error;
use Xlbp_Error;
with Xlbp_Proc_Var;
use Xlbp_Proc_Var;
with Xlbp_Rm;
use Xlbp_Rm;
with Xlbp_Window_Information;
use Xlbp_Window_Information;
with Xlbit_Library3;
use Xlbit_Library3;
with Xlbip_Put_Request;
use Xlbip_Put_Request;
with Xlbmt_Network_Types;
use Xlbmt_Network_Types;
with Xlbmp_Error_Log;
use Xlbmp_Error_Log;
package body Xlbip_Internal is
------------------------------------------------------------------------------
-- X Library Machine Independent Internal Routines
--
-- Xlbip_Internal - Internal-to-X-Library routines - not for general users
------------------------------------------------------------------------------
-- 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 Heap_Free_X_Display is
new Unchecked_Deallocation (X_Display_Rec,
X_Display);
--\f
------------------------------------------------------------------------------
-- Non-functional mutual exclusion functions.
------------------------------------------------------------------------------
procedure Lock_Display (Display : X_Display) is
begin
--/ if not Multitask_Locking then
--// if Display.Lock.flop = 0 then
--// Display.Lock.Flop := 1;
--// else
--// raise X_Library_Confusion;
--// end if;
--/ else
Display.Lock.Lock;
--/ end if;
end Lock_Display;
--\f
procedure Unlock_Display (Display : X_Display) is
begin
--/ if not Multitask_Locking then
--// if Display.Lock.Flop = 1 then
--// Display.Lock.Flop := 0;
--// else
--// raise X_Library_Confusion;
--// end if;
--/ else
Display.Lock.Unlock;
--/ end if;
end Unlock_Display;
--\f
function Internal_X_Alloc_Id (Display : X_Display) return X_Id is
------------------------------------------------------------------------------
-- Default X_Alloc_Id implementation. A user can roll his own and
-- instantiate it if he wants, but he must follow the rules.
------------------------------------------------------------------------------
New_Id : X_Id;
begin
----See if we have any more ID's available.
if Display.Resource_Mask.Number < Display.Resource_Id.Number then
raise Constraint_Error; -- No, we don't.
end if;
----This is the new ID.
New_Id.Number := Display.Resource_Base.Number +
Display.Resource_Id.Number;
----This is the next new ID; we don't check for overflow until the next ID
-- is required.
Display.Resource_Id.Number :=
Display.Resource_Id.Number + Display.Resource_Incr;
return New_Id;
end Internal_X_Alloc_Id;
--\f
function Internal_X_Screen_Of_Window (Display : X_Display;
Window : X_Window) return X_Screen is
------------------------------------------------------------------------------
-- Called to attempt to figure out what screen a window is drawn upon.
------------------------------------------------------------------------------
Root : X_Window;
X : S_Short;
Y : S_Short;
Width : U_Short;
Height : U_Short;
Bw : U_Short;
Depth : U_Char;
Status : X_Status;
begin
X_Get_Geometry (Display, Window.Drawable, Root, X, Y,
Width, Height, Bw, Depth, Status);
if Status = Failed then
return None_X_Screen;
end if;
for I in Display.Screens'Range loop -- find root from list
if Root = X_Root_Window (Display, I) then
return X_Screen_Of_Display (Display, I);
end if;
end loop;
return None_X_Screen;
end Internal_X_Screen_Of_Window;
--\f
procedure Internal_X_Flush_Last_Request (Display : X_Display) is
------------------------------------------------------------------------------
-- Called to flush out the Display.Last_Request. Some requests, e.g. Poly_Arc, are
-- cumulative; successive Poly_Arc requests will merge together in the display
-- buffer before being sent to the server for action. This routine is called
-- to force any of the mergeable requests to be transmitted.
------------------------------------------------------------------------------
begin
case Display.Last_Request.Kind is
when Invalid_Request =>
return; -- Nothing needs to be done.
when Fill_Poly =>
Put_X_Fill_Poly_Request
(Display => Display,
Req => Display.Last_Request.Fill_Poly_Req,
Reservation => Display.Last_Request.Request_Position);
when Poly_Fill_Arc =>
Put_X_Poly_Fill_Arc_Request
(Display => Display,
Req => Display.Last_Request.Poly_Fill_Arc_Req,
Reservation => Display.Last_Request.Request_Position);
when Poly_Line =>
Put_X_Poly_Line_Request
(Display => Display,
Req => Display.Last_Request.Poly_Line_Req,
Reservation => Display.Last_Request.Request_Position);
when Poly_Point =>
Put_X_Poly_Point_Request
(Display => Display,
Req => Display.Last_Request.Poly_Point_Req,
Reservation => Display.Last_Request.Request_Position);
when Poly_Rectangle =>
Put_X_Poly_Rectangle_Request
(Display => Display,
Req => Display.Last_Request.Poly_Rectangle_Req,
Reservation => Display.Last_Request.Request_Position);
when Poly_Fill_Rectangle =>
Put_X_Poly_Fill_Rectangle_Request
(Display => Display,
Req => Display.Last_Request.Poly_Fill_Rectangle_Req,
Reservation => Display.Last_Request.Request_Position);
when Poly_Segment =>
Put_X_Poly_Segment_Request
(Display => Display,
Req => Display.Last_Request.Poly_Segment_Req,
Reservation => Display.Last_Request.Request_Position);
when Xr128 .. Xr255 =>
declare
use Proc_Var_X_Flush_Extension_Graphics;
begin
if Display.Last_Request.Ext_Flush =
None_X_Procedure_Variable then
raise X_Library_Confusion; -- The extension forgot.
end if;
Call (To_Pv (Display.Last_Request.Ext_Flush), Display);
end;
when others =>
raise X_Library_Confusion;
----There is a new type being cached in the X_Last_Request type and
-- nobody told us. How to they expect it to get to the server?
-- This routine must be modified every time X_Last_Request is changed.
end case;
Display.Last_Request.Kind := Invalid_Request;
end Internal_X_Flush_Last_Request;
--\f
procedure Internal_X_Free_Display_Structure (Display : in out X_Display) is
------------------------------------------------------------------------------
-- X_Free_Display_Structure frees all the storage associated with a
-- Display. It is used by X_Open_Display if it runs out of memory,
-- and also by X_Close_Display. It needs to check whether all pointers
-- are non-NULL before dereferencing them, since it may be called
-- by X_Open_Display before the Display structure is fully formed.
-- X_Open_Display must be sure to initialize all the pointers to NULL
-- before the first possible call on this.
------------------------------------------------------------------------------
Sp : X_Screen;
begin
if Display = None_X_Display then
return;
end if;
if Display.Display_Name /= null then
Free_X_String_Pointer (Display.Display_Name);
end if;
if Display.Vendor /= null then
Free_X_String_Pointer (Display.Vendor);
end if;
if Display.Screens /= null then
for I in Display.Screens'Range loop
Sp := Display.Screens (I);
if Sp.Depths /= null then
for J in Display.Screens (I).Depths'Range loop
declare
Dp : X_Depth_Rec renames Sp.Depths (J);
begin
if Dp.Visuals /= null then
for K in Dp.Visuals'Range loop
declare
Vp : X_Visual renames Dp.Visuals (K);
begin
Free_X_Ext_Data_List (Vp.Ext_Data);
end;
end loop;
Free_X_Visual_List (Dp.Visuals);
end if;
end;
end loop;
Free_X_Depth_List (Sp.Depths);
end if;
Free_X_Ext_Data_List (Sp.Ext_Data);
Free_X_Screen (Sp);
end loop;
Free_X_Screen_List (Display.Screens);
end if;
if Display.Pixmap_Format /= null then
for I in Display.Pixmap_Format'Range loop
Free_X_Ext_Data_List (Display.Pixmap_Format (I).Ext_Data);
Free_X_Screen_Format (Display.Pixmap_Format (I));
end loop;
Free_X_Screen_Format_List (Display.Pixmap_Format);
end if;
if Display.Head /= null then
declare
This : X_Queued_Event;
That : X_Queued_Event;
begin
This := Display.Head;
while This /= null loop
That := This.Next;
Free_X_Queued_Event (This);
This := That;
end loop;
end;
end if;
if Display.Database /= None_X_Universal_Pointer then
Univ_X_Rm_Database.Free_Both_X_Universal_Pointer (Display.Database);
end if;
if Display.Key_Syms /= null then
Free_X_Key_Sym_List_2d (Display.Key_Syms);
end if;
if Display.Modifier_Map /= null then
if Display.Modifier_Map.Modifiermap /= null then
Free_X_Modifier_Key_Code_List
(Display.Modifier_Map.Modifiermap);
end if;
Free_X_Modifier_Keymap (Display.Modifier_Map);
end if;
if Display.Key_Bindings /= null then
Free_X_Key_Trans (Display.Key_Bindings);
end if;
if Display.X_Defaults /= None_X_String_Pointer then
Free_X_String_Pointer (Display.X_Defaults);
end if;
Free_X_Ext_Data_List (Display.Ext_Data);
--/ if OLD_CONTEXT_MANAGER then
--// if Display.Contexts /= None_X_Universal_Pointer then
--// Univ_X_Context_Hash_List.Free_Both_X_Universal_Pointer
--// (Display.Contexts);
--// end if;
--/ end if;
Display.Lock.Unlock;
Free_X_Mutex (Display.Lock);
Heap_Free_X_Display (Display);
end Internal_X_Free_Display_Structure;
--\f
procedure Internal_X_Vid_To_Visual (Display : X_Display;
Id : X_Visual_Id;
Visual : in out X_Visual;
Status : out X_Status) is
------------------------------------------------------------------------------
-- Given a visual id, find the X_Visual structure. We walk over the various
-- visual info for a given display until we find the Visual whose Id matches
-- the one sent in. This is used to translate Id's into X_Visuals when an
-- Id is returned by an incoming event.
------------------------------------------------------------------------------
Sp : X_Screen;
begin
begin
----Loop over all Screens in the display.
for I in Display.Screens'Range loop
Sp := Display.Screens (I);
----Loop over all Depths in the screen.
for J in Sp.Depths'Range loop
declare
Dp : X_Depth_Rec renames Sp.Depths (J);
begin
----Loop over all Visuals in the depth.
for K in Dp.Visuals'Range loop
declare
Vp : X_Visual renames Dp.Visuals (K);
begin
----If this is the Visual we're looking for then return it.
if Vp.Visual_Id = Id then
Visual := Vp;
Status := Successful;
return;
end if;
end;
end loop;
end;
end loop;
end loop;
----Visual not found.
Status := Failed;
end;
end Internal_X_Vid_To_Visual;
--\f
procedure Report_Io_Error (Display : X_Display;
Facility : X_String) is
------------------------------------------------------------------------------
-- Called when we have had an I/O error. We convert Display.Fd_Error to a string
-- and stuff it into Display.Error and then we call the X_Lib.IO_Error
-- routine.
------------------------------------------------------------------------------
Proc : X_Procedure_Variable;
begin
X_Lib.Get_Io_Error (Display, Proc);
Err (Display.Last_Error,
X_Get_Error_String ("XlibError", "TError",
"Transport package error:") &
" (" & Facility & " ) " &
To_X_String (Image (Display.Network.Fd_Error)));
Proc_Var_X_Io_Error_Function.Call
(Proc_Var_X_Io_Error_Function.To_Pv (Proc), Display);
raise X_Network_Io_Error;
end Report_Io_Error;
--\f
procedure Sync_Handle (Display : X_Display) is
------------------------------------------------------------------------------
-- Call the Synchandler routine associated with a display.
--#define Sync_Handle() \
-- if (Display->synchandler) (*Display->synchandler)(Display)
------------------------------------------------------------------------------
begin
if Display.Synchandler /= None_X_Procedure_Variable then
Proc_Var_X_Synchandler.Call
(Proc_Var_X_Synchandler.To_Pv (Display.Synchandler), Display);
end if;
end Sync_Handle;
--\f
function Number_To_String (Num : S_Long) return X_String is
Buf : String (1 .. 13);
begin
S_Long_Io.Put (Buf, Num, Base => 16);
return To_X_String (Buf);
end Number_To_String;
--\f
function Internal_X_Set_Last_Request_Read
(Display : X_Display;
Kind : X_Event_Code;
Sequence : U_Short) return S_Long is
------------------------------------------------------------------------------
-- The hard part about this is that we only get 16 bits from a reply. Well,
-- then, we have three values that will march along, with the following
-- invariant:
-- Display.last_request_read <= rep.sequence_Number <= Display.Request
-- The right choice for rep.sequence_Number is the largest that
-- still meets these constraints.
------------------------------------------------------------------------------
New_Seq : S_Long;
Last_Seq : S_Long;
begin
----KeymapNotify has no sequence number, but is always guaranteed
-- to immediately follow another event; except when generated via
-- SendEvent (hmmmm).
if Kind = Keymap_Notify then
return Display.Last_Request_Read;
end if;
New_Seq := (Display.Last_Request_Read and not 16#FFFF#) or
S_Long (Sequence);
Last_Seq := Display.Last_Request_Read;
while New_Seq < Last_Seq loop
New_Seq := New_Seq + 16#10000#;
if New_Seq > Display.Request then
New_Seq := New_Seq - 16#10000#;
X_Report_Error
("XlibError", "SequenceLost",
"Xlib; Sequence lost (new) %1 < %2 (old) in reply type %2.",
Number_To_String (New_Seq),
Number_To_String (Display.Request),
To_X_String (X_Event_Code'Image (Kind)));
exit;
end if;
end loop;
Display.Last_Request_Read := New_Seq;
return New_Seq;
end Internal_X_Set_Last_Request_Read;
--\f
procedure Internal_X_Enq (Display : X_Display;
Event : X_Event) is
------------------------------------------------------------------------------
-- Take a newly received event and place it into the queue of the display that
-- generated it.
------------------------------------------------------------------------------
Qelt : X_Queued_Event;
begin
----Try to reuse an old queue element.
----Get a new event record.
Qelt := Display.Q_Free;
if Qelt = None_X_Queued_Event then
begin
Qelt := new X_Queued_Event_Rec;
exception
when others =>
declare
Proc : X_Procedure_Variable;
begin
X_Lib.Get_Io_Error (Display, Proc);
Display.Network.Fd_Error := No_Free_Memory;
Err (Display.Last_Error,
X_Get_Error_String ("XlibError", "NoMemory",
"No free memory available."));
Proc_Var_X_Io_Error_Function.Call
(Proc_Var_X_Io_Error_Function.To_Pv (Proc), Display);
raise X_Network_Io_Error;
end;
end;
else
Display.Q_Free := Qelt.Next;
Qelt.Next := None_X_Queued_Event;
end if;
Qelt.Event := Event;
----Queue the old/new event at the tail of the existing queue, if any.
Qelt.Next := None_X_Queued_Event;
if Display.Tail /= null then
Display.Tail.Next := Qelt;
else
Display.Head := Qelt;
end if;
Display.Tail := Qelt;
Display.Q_Len := Display.Q_Len + 1;
end Internal_X_Enq;
--\f
end Xlbip_Internal;