|
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: 65897 (0x10169)
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_Atom_Defs;
use Xlbt_Atom_Defs;
with Xlbt_Basic;
use Xlbt_Basic;
with Xlbt_Display2;
use Xlbt_Display2;
with Xlbt_Color;
use Xlbt_Color;
with Xlbt_Event;
use Xlbt_Event;
with Xlbt_Exceptions;
use Xlbt_Exceptions;
with Xlbt_Extension;
use Xlbt_Extension;
with Xlbt_Gc;
use Xlbt_Gc;
with Xlbt_Gc2;
use Xlbt_Gc2;
with Xlbt_Graphics;
use Xlbt_Graphics;
with Xlbt_Host;
use Xlbt_Host;
with Xlbt_Image;
use Xlbt_Image;
with Xlbt_Image2;
use Xlbt_Image2;
with Xlbt_Key;
use Xlbt_Key;
with Xlbt_Misc;
use Xlbt_Misc;
with Xlbt_Proc_Var;
use Xlbt_Proc_Var;
with Xlbt_Request;
use Xlbt_Request;
with Xlbt_Rm;
use Xlbt_Rm;
with Xlbt_Rm2;
use Xlbt_Rm2;
with Xlbt_String;
use Xlbt_String;
with Xlbt_Univ_Ptr;
use Xlbt_Univ_Ptr;
with Xlbt_Visual;
use Xlbt_Visual;
with Xlbt_Visual2;
use Xlbt_Visual2;
with Xlbt_Window;
use Xlbt_Window;
with Xlbp_Display;
use Xlbp_Display;
with Xlbp_Error;
use Xlbp_Error;
with Xlbp_Font;
use Xlbp_Font;
with Xlbp_Gc;
use Xlbp_Gc;
with Xlbp_Proc_Var;
use Xlbp_Proc_Var;
with Xlbp_Rm;
use Xlbp_Rm;
with Xlbp_Sync;
use Xlbp_Sync;
with Xlbp_U_Char_Converters;
use Xlbp_U_Char_Converters;
with Xlbp_Window_Property;
use Xlbp_Window_Property;
with Xlbit_Library3;
use Xlbit_Library3;
with Xlbit_Library4;
use Xlbit_Library4;
with Xlbip_Default_Proc_Vars;
use Xlbip_Default_Proc_Vars;
with Xlbip_Get_Reply;
use Xlbip_Get_Reply;
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_Environment;
use Xlbmp_Environment;
with Xlbmp_Error_Log;
use Xlbmp_Error_Log;
with Xlbmp_Generic_Converters;
use Xlbmp_Generic_Converters;
with Xlbmp_Get;
use Xlbmp_Get;
with Xlbmp_Internal;
use Xlbmp_Internal;
with Xlbmp_Put;
use Xlbmp_Put;
package body Xlbp_Display is
------------------------------------------------------------------------------
-- X Library Display
--
-- Xlbp_Display - Obtain information about a display connection.
------------------------------------------------------------------------------
-- 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.
------------------------------------------------------------------------------
function Default_X_Alloc_Id is
new Proc_Var_X_Alloc_Id.Value (Internal_X_Alloc_Id);
procedure Free_X_Gc is
new Unchecked_Deallocation (Xlbt_Gc2.X_Gc_Rec,
X_Gc);
X_Reply_Contents_Size : constant X_Reply_S_Natural :=
----Number of Raw data bytes that are used to contain the complete
-- (non-variable portion) reply message for a given request code.
X_Reply_S_Natural'
(
Get_Window_Attributes => 44,
Get_Geometry => 32,
Query_Tree => 32,
Intern_Atom => 32,
Get_Atom_Name => 32,
Get_Property => 32,
List_Properties => 32,
Get_Selection_Owner => 32,
Grab_Pointer => 32,
Grab_Keyboard => 32,
Query_Pointer => 32,
Get_Motion_Events => 32,
Translate_Coords => 32,
Get_Input_Focus => 32,
Query_Keymap => 40,
Query_Font => 60,
Query_Text_Extents => 32,
List_Fonts => 32,
List_Fonts_With_Info => 60,
Get_Font_Path => 32,
Get_Image => 32,
List_Installed_Colormaps => 32,
Alloc_Color => 32,
Alloc_Named_Color => 32,
Alloc_Color_Cells => 32,
Alloc_Color_Planes => 32,
Query_Colors => 32,
Lookup_Color => 32,
Query_Best_Size => 32,
Query_Extension => 32,
List_Extensions => 32,
Get_Keyboard_Mapping => 32,
Get_Keyboard_Control => 52,
Get_Pointer_Control => 32,
Get_Screen_Saver => 32,
List_Hosts => 32,
Set_Pointer_Mapping => 32,
Get_Pointer_Mapping => 32,
Set_Modifier_Mapping => 32,
Get_Modifier_Mapping => 32,
others => 0
----Should not happen. Means we have a new Reply type and
-- we were not told. Since we are the one and only entity
-- that allows replies to be created from bytes this means that
-- somebody has slipped up; or else we're working with
-- a malfunctioning or a too-new version server.
);
--\f
------------------------------------------------------------------------------
-- Initial Connection Burst Sent
------------------------------------------------------------------------------
type X_Conn_Client_Prefix is
record
Byte_Order : U_Char;
Pad : U_Char;
Major_Version : U_Short;
Minor_Version : U_Short;
N_Bytes_Auth_Proto : U_Short; -- Authorization protocol name
N_Bytes_Auth_String : U_Short; -- Authorization data string
Pad2 : U_Short;
end record;
--/ if Length_Clauses then
for X_Conn_Client_Prefix'Size use 32 * 3;
--/ end if;
--/ if Record_Rep_Clauses then
--// for X_Conn_Client_Prefix use
--// record
--// Byte_Order at 0 * X_Word range X_Byte0a .. X_Byte0b;
--// Pad at 0 * X_Word range X_Byte1a .. X_Byte1b;
--// Major_Version at 0 * X_Word range X_Half1a .. X_Half1b;
--// Minor_Version at 1 * X_Word range X_Half0a .. X_Half0b;
--// N_Bytes_Auth_Proto at 1 * X_Word range X_Half1a .. X_Half1b;
--// N_Bytes_Auth_String at 2 * X_Word range X_Half0a .. X_Half0b;
--// Pad2 at 2 * X_Word range X_Half1a .. X_Half1b;
--// end record;
--/ end if;
procedure To_Raw is new Convert_Private_To_Raw (X_Conn_Client_Prefix);
procedure Put_X_Conn_Client_Prefix is
new Put_Data_Private (X_Conn_Client_Prefix,
To_Raw);
------------------------------------------------------------------------------
-- Connection setup structure. This is followed by:
-- Num_Formats X_Pixmap_Format structures.
-- Num_Roots X_Window_Root structures.
------------------------------------------------------------------------------
type X_Conn_Setup is
record
Release : S_Long;
Rid_Base : X_Id;
Rid_Mask : X_Id;
Motion_Buffer_Size : S_Long;
N_Bytes_Vendor : U_Short; -- Vendor string length
Max_Request_Size : U_Short;
Num_Roots : X_Screen_Number; -- # Root structs
Num_Formats : U_Char; -- Pixmap format count
Image_Byte_Order : X_Byte_Bit_Order;
Bitmap_Bit_Order : X_Byte_Bit_Order;
Bitmap_Scanline_Unit : U_Char; -- 8, 16, 32
Bitmap_Scanline_Pad : U_Char; -- 8, 16, 32
Min_Keycode : X_Key_Code;
Max_Keycode : X_Key_Code;
Pad2 : S_Long;
end record;
--/ if Length_Clauses then
for X_Conn_Setup'Size use 32 * 8;
--/ end if;
--/ if Record_Rep_Clauses then
--// for X_Conn_Setup use
--// record
--// Release at 0 * X_Word range X_Word0a .. X_Word0b;
--// Rid_Base at 1 * X_Word range X_Word0a .. X_Word0b;
--// Rid_Mask at 2 * X_Word range X_Word0a .. X_Word0b;
--// Motion_Buffer_Size at 3 * X_Word range X_Word0a .. X_Word0b;
--// N_Bytes_Vendor at 4 * X_Word range X_Half0a .. X_Half0b;
--// Max_Request_Size at 4 * X_Word range X_Half1a .. X_Half1b;
--// Num_Roots at 5 * X_Word range X_Byte0a .. X_Byte0b;
--// Num_Formats at 5 * X_Word range X_Byte1a .. X_Byte1b;
--// Image_Byte_Order at 5 * X_Word range X_Byte2a .. X_Byte2b;
--// Bitmap_Bit_Order at 5 * X_Word range X_Byte3a .. X_Byte3b;
--// Bitmap_Scanline_Unit at 6 * X_Word range X_Byte0a .. X_Byte0b;
--// Bitmap_Scanline_Pad at 6 * X_Word range X_Byte1a .. X_Byte1b;
--// Min_Keycode at 6 * X_Word range X_Byte2a .. X_Byte2b;
--// Max_Keycode at 6 * X_Word range X_Byte3a .. X_Byte3b;
--// Pad2 at 7 * X_Word range X_Word0a .. X_Word0b;
--// end record;
--/ end if;
procedure From_Raw is new Convert_Raw_To_Private (X_Conn_Setup);
procedure Get_X_Conn_Setup is
new Get_Data_Private (X_Conn_Setup,
From_Raw);
------------------------------------------------------------------------------
-- Initial Connection Burst Received
------------------------------------------------------------------------------
type X_Conn_Setup_Prefix is
record
Success : X_Boolean_Char;
Length_Reason : U_Char; -- reason str length if failure
Major_Version : U_Short;
Minor_Version : U_Short;
Length : U_Short; -- word count of setup info
end record;
--/ if Length_Clauses then
for X_Conn_Setup_Prefix'Size use 32 * 2;
--/ end if;
--/ if Record_Rep_Clauses then
--// for X_Conn_Setup_Prefix use
--// record
--// Success at 0 * X_Word range X_Byte0a .. X_Byte0b;
--// Length_Reason at 0 * X_Word range X_Byte1a .. X_Byte1b;
--// Major_Version at 0 * X_Word range X_Half1a .. X_Half1b;
--// Minor_Version at 1 * X_Word range X_Half0a .. X_Half0b;
--// Length at 1 * X_Word range X_Half1a .. X_Half1b;
--// end record;
--/ end if;
procedure From_Raw is new Convert_Raw_To_Private (X_Conn_Setup_Prefix);
procedure Get_X_Conn_Setup_Prefix is
new Get_Data_Private (X_Conn_Setup_Prefix,
From_Raw);
------------------------------------------------------------------------------
-- X_Depths
------------------------------------------------------------------------------
type X_Depths is
record
Depth : U_Char;
Pad1 : U_Char;
N_Visuals : U_Short; -- number of X_Visual_Type's coming
Pad2 : S_Long;
end record;
--/ if Length_Clauses then
for X_Depths'Size use 32 * 2;
--/ end if;
--/ if Record_Rep_Clauses then
--// for X_Depths use
--// record
--// Depth at 0 * X_Word range X_Byte0a .. X_Byte0b;
--// Pad1 at 0 * X_Word range X_Byte1a .. X_Byte1b;
--// N_Visuals at 0 * X_Word range X_Half1a .. X_Half1b;
--// Pad2 at 1 * X_Word range X_Word0a .. X_Word0b;
--// end record;
--/ end if;
procedure From_Raw is new Convert_Raw_To_Private (X_Depths);
procedure Get_X_Depths is
new Get_Data_Private (X_Depths,
From_Raw);
------------------------------------------------------------------------------
-- X_Pixmap_Format
------------------------------------------------------------------------------
type X_Pixmap_Format is
record
Depth : U_Char;
Bits_Per_Pixel : U_Char;
Scan_Line_Pad : U_Char;
Pad1 : U_Char;
Pad2 : S_Long;
end record;
--/ if Length_Clauses then
for X_Pixmap_Format'Size use 32 * 2;
--/ end if;
--/ if Record_Rep_Clauses then
--// for X_Pixmap_Format use
--// record
--// Depth at 0 * X_Word range X_Byte0a .. X_Byte0b;
--// Bits_Per_Pixel at 0 * X_Word range X_Byte1a .. X_Byte1b;
--// Scan_Line_Pad at 0 * X_Word range X_Byte2a .. X_Byte2b;
--// Pad1 at 0 * X_Word range X_Byte3a .. X_Byte3b;
--// Pad2 at 1 * X_Word range X_Word0a .. X_Word0b;
--// end record;
--/ end if;
procedure From_Raw is new Convert_Raw_To_Private (X_Pixmap_Format);
procedure Get_X_Pixmap_Format is
new Get_Data_Private (X_Pixmap_Format,
From_Raw);
------------------------------------------------------------------------------
-- X_Visual_Type - Describes each visual type available at each depth
------------------------------------------------------------------------------
type X_Visual_Type is
record
Vis_Id : X_Visual_Id;
Class : X_Display_Class;
Bits_Per_Rgb : U_Char;
Colormap_Entries : U_Short;
Red_Mask : X_Red_Color_Mask;
Green_Mask : X_Green_Color_Mask;
Blue_Mask : X_Blue_Color_Mask;
Pad : S_Long;
end record;
--/ if Length_Clauses then
for X_Visual_Type'Size use 32 * 6;
--/ end if;
--/ if Record_Rep_Clauses then
--// for X_Visual_Type use
--// record
--// Vis_Id at 0 * X_Word range X_Word0a .. X_Word0b;
--// Class at 1 * X_Word range X_Byte0a .. X_Byte0b;
--// Bits_Per_Rgb at 1 * X_Word range X_Byte1a .. X_Byte1b;
--// Colormap_Entries at 1 * X_Word range X_Half1a .. X_Half1b;
--// Red_Mask at 2 * X_Word range X_Word0a .. X_Word0b;
--// Green_Mask at 3 * X_Word range X_Word0a .. X_Word0b;
--// Blue_Mask at 4 * X_Word range X_Word0a .. X_Word0b;
--// Pad at 5 * X_Word range X_Word0a .. X_Word0b;
--// end record;
--/ end if;
procedure From_Raw is new Convert_Raw_To_Private (X_Visual_Type);
procedure Get_X_Visual_Type is
new Get_Data_Private (X_Visual_Type,
From_Raw);
------------------------------------------------------------------------------
-- X_Window_Root
------------------------------------------------------------------------------
type X_Window_Root is
record
Wind_Id : X_Window;
Default_Colormap : X_Colormap;
White_Pixel : X_Pixel;
Black_Pixel : X_Pixel;
Current_Input_Mask : X_Event_Mask;
Pix_Width : U_Short;
Pix_Height : U_Short;
Mm_Width : U_Short;
Mm_Height : U_Short;
Min_Installed_Maps : U_Short;
Max_Installed_Maps : U_Short;
Root_Visual_Id : X_Visual_Id;
Backing_Store : X_Backing_Store_Hint;
Save_Unders : X_Boolean_Char;
Root_Depth : U_Char;
N_Depths : U_Char; -- # X_Depths's following
end record;
--/ if Length_Clauses then
for X_Window_Root'Size use 32 * 10;
--/ end if;
--/ if Record_Rep_Clauses then
--// for X_Window_Root use
--// record
--// Wind_Id at 0 * X_Word range X_Word0a .. X_Word0b;
--// Default_Colormap at 1 * X_Word range X_Word0a .. X_Word0b;
--// White_Pixel at 2 * X_Word range X_Word0a .. X_Word0b;
--// Black_Pixel at 3 * X_Word range X_Word0a .. X_Word0b;
--// Current_Input_Mask at 4 * X_Word range X_Word0a .. X_Word0b;
--// Pix_Width at 5 * X_Word range X_Half0a .. X_Half0b;
--// Pix_Height at 5 * X_Word range X_Half1a .. X_Half1b;
--// Mm_Width at 6 * X_Word range X_Half0a .. X_Half0b;
--// Mm_Height at 6 * X_Word range X_Half1a .. X_Half1b;
--// Min_Installed_Maps at 7 * X_Word range X_Half0a .. X_Half0b;
--// Max_Installed_Maps at 7 * X_Word range X_Half1a .. X_Half1b;
--// Root_Visual_Id at 8 * X_Word range X_Word0a .. X_Word0b;
--// Backing_Store at 9 * X_Word range X_Byte0a .. X_Byte0b;
--// Save_Unders at 9 * X_Word range X_Byte1a .. X_Byte1b;
--// Root_Depth at 9 * X_Word range X_Byte2a .. X_Byte2b;
--// N_Depths at 9 * X_Word range X_Byte3a .. X_Byte3b;
--// end record;
--/ end if;
procedure From_Raw is new Convert_Raw_To_Private (X_Window_Root);
procedure Get_X_Window_Root is
new Get_Data_Private (X_Window_Root,
From_Raw);
------------------------------------------------------------------------------
--\f
procedure X_Open_Display (Name : X_String;
Display : out X_Display;
Error : in out X_Error_String) is
------------------------------------------------------------------------------
-- Open a connection to the display whose name is contained in Disp, e.g.
-- "Thumper:0". If Display /= Null upon return then the connection has been set
-- up and is ready to go. If Display = Null upon return then Error contains a
-- textual representation of what went wrong. The new X_Display is attached
-- to the X_Lib parameter; X_Lib supplies the "global context" for the
-- X_Display.
------------------------------------------------------------------------------
Ldisplay : X_Display := None_X_Display;
Client : X_Conn_Client_Prefix; -- client information
Prefix : X_Conn_Setup_Prefix; -- prefix information
Display_Num : U_Char;
Screen_Num : X_Screen_Number; -- screen number
Family : X_Host_Protocol_Family;
Server_Addr : X_Network_Host_Address;
Root_Visual_Id : X_Visual_Id;
Void : Proc_Var_X_Synchandler.Pv;
Succ : X_Status;
Conn_Auth_Name : U_Char_List;
Conn_Auth_Data : U_Char_List;
Short_Reply : exception;
Connection_Io_Error : exception;
------------------------------------------------------------------------------
procedure Abandon_Connection (Displayi : in out X_Display) is
------------------------------------------------------------------------------
-- Abandon_Connection is called if we get I/O, storage, or other fatal
-- errors. X_Open_Display returns NULL for the Display after this
-- returns.
------------------------------------------------------------------------------
begin
Internal_X_Disconnect_Display (Displayi.Network);
Lock_Display (Displayi); -- Free will unlock it.
Internal_X_Free_Display_Structure (Displayi);
-- Xau_Dispose_Auth (Auth_Ptr);
Displayi := null;
end Abandon_Connection;
------------------------------------------------------------------------------
procedure Convert_Visuals (Root_Visual : in out X_Visual;
Visuals : in out X_Visual_List;
Length : U_Short) is
-----------------------------------------------------------------------
-- Called by Convert_Depths to read N_Visuals worth of X_Visual_Types
-- for an X_Depths record that is being read for an X_Window_Root record
-- that is being read for a new connection.
-----------------------------------------------------------------------
V : X_Visual_Type;
begin
----Allocate a new visual array.
Visuals := new X_Visual_Array (1 .. Length);
Ldisplay.Total_Visuals :=
Ldisplay.Total_Visuals + S_Natural (Length);
----Convert the Visuals one record at a time. Put each new visual
-- into the Visuals array.
for K in Visuals'Range loop
Get_X_Visual_Type (Ldisplay, V);
Visuals (K) :=
new X_Visual_Rec'((Class => V.Class,
Bits_Per_Rgb => V.Bits_Per_Rgb,
Map_Entries => V.Colormap_Entries,
Red_Mask => V.Red_Mask,
Green_Mask => V.Green_Mask,
Blue_Mask => V.Blue_Mask,
Ext_Data => null,
Visual_Id => V.Vis_Id));
----If we happen upon the Root Visual then return it.
if V.Vis_Id = Root_Visual_Id then
Root_Visual := Visuals (K);
end if;
end loop;
end Convert_Visuals;
------------------------------------------------------------------------------
procedure Convert_Depths (Root_Visual : in out X_Visual;
Depths : in out X_Depth_List;
Length : U_Char) is
-----------------------------------------------------------------------
-- Called below to read N_Depths worth of X_Depths for an
-- X_Window_Root record that is being read for a new connection.
-----------------------------------------------------------------------
D : X_Depths;
begin
----Allocate the new Depths array and then fill it.
Depths := new X_Depth_Array (1 .. Length);
----Convert each Depth and read the Visuals that follow each one.
for J in Depths'Range loop
Get_X_Depths (Ldisplay, D);
----Create the new Depth and read it's Visuals.
Depths (J) := (Depth => D.Depth,
Visuals => null);
Convert_Visuals (Root_Visual,
Depths (J).Visuals,
D.N_Visuals);
end loop;
end Convert_Depths;
------------------------------------------------------------------------------
----Continue the body of X_Open_Display
begin
----Init our OUT parameters that might not otherwise be set if we get an error.
Display := None_X_Display;
----Get the display name to use. X_Display_Name takes care of looking at
-- environment variables if Name is empty.
declare
Dname : constant X_String := X_Display_Name (Name);
begin
if Dname = "" then
Err (Error,
X_Get_Error_String ("XlibError", "NoHost",
"No host or display name was given."));
return;
end if;
----Set the default error handlers. This allows the global variables to
-- default to NULL for use with shared libraries.
----Attempt to allocate a display structure.
Ldisplay := new X_Display_Rec;
Ldisplay.Lock := new X_Mutex_Rec;
----Call the Connect routine to get the network socket. The Succ status
-- indicates whether or not the connection failed. The connect routine will
-- return the expanded display name in displaybuf. Error are reported in
-- the Error string so we don't have to worry about doing that.
Internal_X_Connect_Display (Display_Name => Dname,
Expanded_Name => Ldisplay.Display_Name,
Display_Num => Display_Num,
Screen_Num => Screen_Num,
Family => Family,
Server_Addr => Server_Addr,
Connection => Ldisplay.Network,
Status => Succ,
Error => Error);
if Succ = Failed then
Lock_Display (Ldisplay); -- Free will unlock it.
Internal_X_Free_Display_Structure (Ldisplay);
return;
end if;
end;
----Look up the authorization protocol name and data if necessary.
X_Lib.Get_Authorization (Conn_Auth_Name, Conn_Auth_Data);
if Conn_Auth_Name = None_U_Char_List or else
Conn_Auth_Data = None_U_Char_List then
declare
Num : constant X_String := To_X_String
(U_Char'Image (Display_Num));
begin
-- Auth_Ptr := Xau_Get_Auth_By_Addr
-- (Family => Family,
-- Server_Addr => Server_Addr,
-- Display_Num => Num (Num'First + 1 .. Num'Last),
-- Auth_Name => conn_Auth_Name);
-- if Auth_Ptr /= None_X_Auth then
-- Conn_Auth_Name := Auth_Ptr.Name;
-- Conn_Auth_Data := Auth_Ptr.Data;
-- else
Conn_Auth_Name := None_U_Char_List;
Conn_Auth_Data := None_U_Char_List;
-- end if;
end;
end if;
----Free the Server_Addr data. We won't need it further.
Free_X_Network_Host_Address (Server_Addr);
----Send the Hello message. The first byte of the Hello message is the byte
-- order code. The authentication key is normally sent right after the
-- connection. This (in MIT's case) will be Kerberos.
Client.Byte_Order := Character'Pos (X_Lib_Indian);
Client.Major_Version := Xlbmt_Parameters.X_Protocol;
Client.Minor_Version := Xlbmt_Parameters.X_Protocol_Revision;
if Conn_Auth_Name /= None_U_Char_List then
Client.N_Bytes_Auth_Proto := Conn_Auth_Name'Length;
else
Client.N_Bytes_Auth_Proto := 0;
end if;
if Conn_Auth_Data /= None_U_Char_List then
Client.N_Bytes_Auth_String := Conn_Auth_Data'Length;
else
Client.N_Bytes_Auth_String := 0;
end if;
----Put the X_Conn_Client_Prefix record in the buffer.
Put_X_Conn_Client_Prefix (Ldisplay, Client);
----Put the Conn_Auth_Name in the buffer.
if Conn_Auth_Name /= None_U_Char_List then
Put_U_Char_Array (Ldisplay, Conn_Auth_Data.all);
end if;
----Put the Conn_Auth_Data in the buffer;
if Conn_Auth_Data /= None_U_Char_List then
Put_U_Char_Array (Ldisplay, Conn_Auth_Data.all);
end if;
----Get rid of the authorization information.
-- Xau_Dispose_Auth (Auth_Ptr);
----Transmit our information and check for errors.
Internal_X_Flush_Display (Ldisplay);
----Now see if connection was accepted...
Get_X_Conn_Setup_Prefix (Ldisplay, Prefix);
----Check the Major/Minor version numbers to see if they match.
if Prefix.Major_Version < Xlbmt_Parameters.X_Protocol then
X_Report_Warning
("XlibMessage", "OldMajor",
"Xlib; Mismatch on major version. Client built for major" &
Lf &
"version %1 and server is version %2.",
To_X_String (S_Natural'Image (Xlbmt_Parameters.X_Protocol)),
To_X_String
(S_Natural'Image (S_Natural (Prefix.Major_Version))) & '.');
end if;
if Prefix.Minor_Version /= Xlbmt_Parameters.X_Protocol_Revision then
X_Report_Warning
("XlibMessage", "OldMinor",
"Xlib; Mismatch on minor version. Client built for minor" &
Lf &
"version %1 and server is version %2.",
To_X_String
(S_Natural'Image (Xlbmt_Parameters.X_Protocol_Revision)),
To_X_String
(S_Natural'Image (S_Natural (Prefix.Minor_Version))) & '.');
end if;
----If the connection is refused then grab the reason and return.
if Prefix.Success = False then
declare
Reason : X_String (1 .. S_Natural (Prefix.Length) * 4);
Last : S_Natural := Reason'Last;
begin
Get_X_String (Ldisplay, Reason);
for I in reverse Reason'Last - 2 .. Reason'Last loop
if Reason (I) = Nul then
Last := I;
exit;
end if;
end loop;
Err (Error,
X_Get_Error_String ("XlibError", "ConnectRefused",
"X server connection refused:") &
' ' & Reason (1 .. Last));
Abandon_Connection (Ldisplay);
return;
end;
end if;
----The connection was accepted. Read the rest of the setup information.
declare
Setup : X_Conn_Setup;
begin
Get_X_Conn_Setup (Ldisplay, Setup);
----We succeeded at authorization, so let us move the data into the display
-- structure.
Ldisplay.Proto_Major_Version := Prefix.Major_Version;
Ldisplay.Proto_Minor_Version := Prefix.Minor_Version;
Ldisplay.Release := Setup.Release;
Ldisplay.Resource_Base := Setup.Rid_Base; -- base of all ID's
Ldisplay.Resource_Id := (Number => 0);
Ldisplay.Resource_Mask := Setup.Rid_Mask;
Ldisplay.Resource_Incr := -- Just 1 bit at bottom of mask
(Shift (Ldisplay.Resource_Mask.Number, 1) xor
Ldisplay.Resource_Mask.Number) and
Ldisplay.Resource_Mask.Number;
Ldisplay.Min_Keycode := Setup.Min_Keycode;
Ldisplay.Max_Keycode := Setup.Max_Keycode;
Ldisplay.Motion_Buffer := Setup.Motion_Buffer_Size;
Ldisplay.Byte_Order := Setup.Image_Byte_Order;
Ldisplay.Bitmap_Unit := Setup.Bitmap_Scanline_Unit;
Ldisplay.Bitmap_Pad := Setup.Bitmap_Scanline_Pad;
Ldisplay.Bitmap_Bit_Order := Setup.Bitmap_Bit_Order;
Ldisplay.Max_Request_Size := Setup.Max_Request_Size;
Ldisplay.Event_Vec :=
X_Wire_Event_Array'(others =>
X_Lib_Default_X_Unknown_Wire_Event);
Ldisplay.Wire_Vec :=
X_Event_Wire_Array'(others =>
X_Lib_Default_X_Unknown_Native_Event);
Ldisplay.Reply_Size := X_Reply_Contents_Size;
----Compute maximum sizes for the various Poly-whatever graphics requests
-- that we are willing to generate.
Ldisplay.Poly_Arc_Limit :=
(S_Natural (Ldisplay.Max_Request_Size) - 8) /
(X_Arc'Size / 32);
Ldisplay.Poly_Point_Limit :=
(S_Natural (Ldisplay.Max_Request_Size) - 8) /
(X_Point'Size / 32);
Ldisplay.Poly_Rectangle_Limit :=
(S_Natural (Ldisplay.Max_Request_Size) - 8) /
(X_Rectangle'Size / 32);
Ldisplay.Poly_Segment_Limit :=
(S_Natural (Ldisplay.Max_Request_Size) - 8) /
(X_Segment'Size / 32);
----Now init event_Vec/Wire_Vec the way we really want it. Ada is too stupid
-- to realize that "Key_Press..Last_Event-1" is a "static" expression so we
-- can't use an aggregate.
for I in Key_Press .. X_Event_Code'Pred (Last_Event) loop
Ldisplay.Event_Vec (I) := X_Lib_Default_X_Wire_To_Event;
Ldisplay.Wire_Vec (I) := None_X_Procedure_Variable;
end loop;
----Now extract the vendor str... String must be null terminated, padded to
-- multiple of 4 bytes.
Ldisplay.Vendor := new X_String
(1 .. S_Natural (Setup.N_Bytes_Vendor));
Get_X_String (Ldisplay, Ldisplay.Vendor.all);
----Now iterate down setup information.....
-- First decode the Z axis Screen format information.
declare
Pm : X_Pixmap_Format;
Length : S_Natural := S_Natural (Setup.Num_Formats);
begin
Ldisplay.Pixmap_Format :=
new X_Screen_Format_Array (0 .. U_Char (Length - 1));
for I in Ldisplay.Pixmap_Format'Range loop
Get_X_Pixmap_Format (Ldisplay, Pm);
Ldisplay.Pixmap_Format (I) :=
new X_Screen_Format_Rec'
((Depth => Pm.Depth,
Bits_Per_Pixel => Pm.Bits_Per_Pixel,
Scan_Line_Pad => Pm.Scan_Line_Pad,
Ext_Data => null));
end loop;
end;
----Next the Screen structures. Deal with each one in turn.
declare
Wr : X_Window_Root;
Length : S_Natural := S_Natural (Setup.Num_Roots);
begin
Ldisplay.Screens :=
new X_Screen_Array (0 .. X_Screen_Number (Length - 1));
for I in Ldisplay.Screens'Range loop
Get_X_Window_Root (Ldisplay, Wr);
Ldisplay.Screens (I) :=
new X_Screen_Rec'
((Display => Ldisplay,
Root => Wr.Wind_Id,
Default_Colormap => Wr.Default_Colormap,
White_Pixel => Wr.White_Pixel,
Black_Pixel => Wr.Black_Pixel,
Root_Input_Mask => Wr.Current_Input_Mask,
Width => Wr.Pix_Width,
Height => Wr.Pix_Height,
Mm_Width => Wr.Mm_Width,
Mm_Height => Wr.Mm_Height,
Min_Maps => Wr.Min_Installed_Maps,
Max_Maps => Wr.Max_Installed_Maps,
Root_Visual => null,
-- filled in later, when we alloc Visuals
Backing_Store => Wr.Backing_Store,
Save_Unders => Wr.Save_Unders =
True,
Root_Depth => Wr.Root_Depth,
Depths => null,
Default_Gc => null,
Ext_Data => null));
Root_Visual_Id := Wr.Root_Visual_Id;
----Let's set up the depth structures for this screen.
Convert_Depths (Ldisplay.Screens (I).Root_Visual,
Ldisplay.Screens (I).Depths,
Wr.N_Depths);
end loop;
end;
----Setup other information in this display structure.
Ldisplay.Vnumber := Xlbmt_Parameters.X_Protocol;
Ldisplay.Resource_Alloc := X_Lib_Default_X_Alloc_Id;
Ldisplay.Default_Screen :=
Screen_Num; -- Value returned by Connect_Display
Ldisplay.Last_Request.Kind := Invalid_Request;
----Now start talking to the server to setup all other information...
end;
----Call into synchronization routine to make sure that we are synchronized.
declare
Flag : Boolean;
begin
X_Lib.Get_Debug (Flag);
Void := X_Synchronize (Ldisplay, Flag);
end;
----Chain this stucture onto global list.
X_Lib.Add_Display (Ldisplay);
----Make sure default screen is legal.
if Screen_Num not in Ldisplay.Screens'Range then
Err (Error, X_Get_Error_String
("XlibError", "BadScrNum",
"Screen number is out of server-defined range."));
Abandon_Connection (Ldisplay);
return;
end if;
----Set up other stuff clients are always going to use.
for I in Ldisplay.Screens'Range loop
declare
Values : X_Gc_Values;
begin
Values.Foreground := Ldisplay.Screens (I).Black_Pixel;
Values.Background := Ldisplay.Screens (I).White_Pixel;
Ldisplay.Screens (I).Default_Gc :=
X_Create_Gc
(Ldisplay, Ldisplay.Screens (I).Root.Drawable,
(Gc_Foreground | Gc_Background => True, others => False),
Values);
end;
end loop;
----Get the resource manager database off the root window.
declare
Actual_Type : X_Atom;
Actual_Format : U_Char;
N_Items : S_Natural;
Leftover : S_Natural;
Data : U_Char_List;
begin
X_Get_Window_Property
(Display => Ldisplay,
Window => X_Root_Window (Ldisplay, 0),
Property => Xa_Resource_Manager,
Offset => 0,
Maximum_Length => S_Long'Last / 4, --100_000_000,
Delete => False,
Representation => Xa_String,
Actual_Type => Actual_Type,
Actual_Format => Actual_Format,
N_Items => N_Items,
Bytes_After => Leftover,
Data => Data,
Status => Succ);
if Succ /= Failed then
if Actual_Type /= Xa_String or else
Actual_Format /= 8 then
Free_X_String_Pointer (Ldisplay.X_Defaults);
end if;
end if;
if Data /= None_U_Char_List then
Ldisplay.X_Defaults := new X_String (1 .. Data'Length);
From_Uca (Ldisplay.X_Defaults.all, Data.all);
else
Ldisplay.X_Defaults := None_X_String_Pointer;
end if;
exception
when others =>
Free_U_Char_List (Data);
raise;
end;
Ldisplay.Database := Univ_X_Rm_Database.To_X_Universal_Pointer
(new X_Rm_Database_Rec);
----What do you know? We made it. Return the Display and go.
Display := Ldisplay;
return;
----Handle the more onerous exceptions here.
exception
when Connection_Io_Error =>
Error := Ldisplay.Last_Error;
Abandon_Connection (Ldisplay);
return;
when Short_Reply =>
Err (Error, X_Get_Error_String
("XlibError", "ShortHello",
"Initial X server response too short."));
Abandon_Connection (Ldisplay);
return;
when Storage_Error =>
Err (Error, X_Get_Error_String ("XlibError", "NoMemory",
"No free memory available."));
Abandon_Connection (Ldisplay);
return;
when others =>
Abandon_Connection (Ldisplay);
raise;
end X_Open_Display;
--\f
procedure X_Close_Display (Display : in out X_Display) is
------------------------------------------------------------------------------
-- X_Sync the connection to the X server; close a connection that was
-- previously opened via X_Open_Display; free all associated storage.
------------------------------------------------------------------------------
Ext : X_Extension;
Dp : X_Display;
Cp : X_Display;
Gc : X_Gc;
begin
----Sync up with the server and discard all pending input events.
Display.Flags (Xlib_Display_Closing) := True;
X_Sync (Display, Discard => True);
----Tell all of the extensions that this display is going away.
Ext := Display.Ext_Procs;
while Ext /= null loop
if Ext.Close_Display /=
None_X_Procedure_Variable then
Proc_Var_X_Close_Display_Extension.Call
(Proc_Var_X_Close_Display_Extension.To_Pv
(Ext.Close_Display), Display, Ext.Codes);
end if;
Ext := Ext.Next;
end loop;
----Free the GC's for all of the screens.
for I in Display.Screens'Range loop
Gc := Display.Screens (I).Default_Gc;
if Gc.Ext_Data /= null then
Free_X_Ext_Data_List (Gc.Ext_Data);
end if;
Free_X_Gc (Display.Screens (I).Default_Gc);
end loop;
----Free the cursor font, if any.
if Display.Cursor_Font /= None_X_Font then
X_Unload_Font (Display, Display.Cursor_Font);
end if;
----Begin the actual disconnection.
Lock_Display (Display); -- Prevent other use
Internal_X_Disconnect_Display (Display.Network); -- Actually disconnect
----Remove the display from the list of open displays and free the storage.
X_Lib.Remove_Display (Display);
Internal_X_Free_Display_Structure (Display);
end X_Close_Display;
--\f
procedure X_No_Op (Display : X_Display) is
------------------------------------------------------------------------------
-- Send a No-Operation request to the server.
------------------------------------------------------------------------------
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
Put_X_No_Operation_Request
(Display, (Kind => No_Operation,
Length => X_No_Operation_Request'Size / 32,
Pad => 0));
----Catch unexpected exceptions and unlock the display before passing them on.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock the display and return.
Unlock_Display (Display);
Sync_Handle (Display);
end X_No_Op;
--\f
------------------------------------------------------------------------------
-- Display functions
------------------------------------------------------------------------------
function X_All_Planes return X_Plane_Mask is
begin
return All_Planes;
end X_All_Planes;
------------------------------------------------------------------------------
function X_Bitmap_Bit_Order (Display : X_Display) return X_Byte_Bit_Order is
begin
return Display.Bitmap_Bit_Order;
end X_Bitmap_Bit_Order;
------------------------------------------------------------------------------
function X_Bitmap_Pad (Display : X_Display) return U_Char is
begin
return Display.Bitmap_Pad;
end X_Bitmap_Pad;
------------------------------------------------------------------------------
function X_Bitmap_Unit (Display : X_Display) return U_Char is
begin
return Display.Bitmap_Unit;
end X_Bitmap_Unit;
------------------------------------------------------------------------------
function X_Connection_Number (Display : X_Display)
return X_Network_Connection is
begin
return Display.Network;
end X_Connection_Number;
------------------------------------------------------------------------------
function X_Default_Root_Window (Display : X_Display) return X_Window is
begin
return Display.Screens (Display.Default_Screen).Root;
end X_Default_Root_Window;
------------------------------------------------------------------------------
function X_Default_Screen (Display : X_Display) return X_Screen_Number is
begin
return Display.Default_Screen;
end X_Default_Screen;
------------------------------------------------------------------------------
function X_Default_Screen_Of_Display
(Display : X_Display) return X_Screen is
begin
return Display.Screens (Display.Default_Screen);
end X_Default_Screen_Of_Display;
------------------------------------------------------------------------------
function X_Display_Name (Display : X_String) return X_String is
------------------------------------------------------------------------------
-- If the parameter is "" then we query the Environment to determine the
-- name of the default display to be used. If the parameter is not "" then
-- we simply return it.
------------------------------------------------------------------------------
Ptr : X_String_Pointer;
begin
if Display /= "" and then
Display (Display'First) /= Nul then
return Display;
end if;
Ptr := X_Env_Get_Environment_Variable ("DISPLAY");
if Ptr = None_X_String_Pointer then
return "";
end if;
declare
Str : constant X_String := Ptr.all;
begin
Free_X_String_Pointer (Ptr);
return Str;
end;
end X_Display_Name;
------------------------------------------------------------------------------
function X_Display_String (Display : X_Display) return X_String is
begin
return Display.Display_Name.all;
end X_Display_String;
------------------------------------------------------------------------------
function X_Image_Byte_Order (Display : X_Display) return X_Byte_Bit_Order is
begin
return Display.Byte_Order;
end X_Image_Byte_Order;
------------------------------------------------------------------------------
function X_Last_Known_Request_Processed
(Display : X_Display) return S_Long is
begin
return Display.Last_Request_Read;
end X_Last_Known_Request_Processed;
------------------------------------------------------------------------------
function X_List_Pixmap_Formats (Display : X_Display)
return X_Pixmap_Format_Values_List is
------------------------------------------------------------------------------
-- Display - Specifies the display to use.
--
-- Returns an array of X_Pixmap_Format_Values that describe the types of Z
-- format images that are supported by the specified display.
------------------------------------------------------------------------------
Formats : X_Pixmap_Format_Values_List :=
new X_Pixmap_Format_Values_Array
(S_Natural (Display.Pixmap_Format'First) ..
S_Natural (Display.Pixmap_Format'Last));
begin
for I in Display.Pixmap_Format'Range loop
Formats (S_Natural (I)).Depth := Display.Pixmap_Format (I).Depth;
Formats (S_Natural (I)).Bits_Per_Pixel :=
Display.Pixmap_Format (I).Bits_Per_Pixel;
Formats (S_Natural (I)).Scan_Line_Pad :=
Display.Pixmap_Format (I).Scan_Line_Pad;
end loop;
return Formats;
end X_List_Pixmap_Formats;
------------------------------------------------------------------------------
function X_Max_Request_Size (Display : X_Display) return U_Short is
begin
return Display.Max_Request_Size;
end X_Max_Request_Size;
------------------------------------------------------------------------------
function X_Next_Request (Display : X_Display) return S_Long is
begin
return Display.Request + 1;
end X_Next_Request;
------------------------------------------------------------------------------
function X_Protocol_Revision (Display : X_Display) return U_Short is
begin
return Display.Proto_Minor_Version;
end X_Protocol_Revision;
------------------------------------------------------------------------------
function X_Protocol_Version (Display : X_Display) return U_Short is
begin
return Display.Proto_Major_Version;
end X_Protocol_Version;
------------------------------------------------------------------------------
function X_Q_Length (Display : X_Display) return S_Long is
begin
return Display.Q_Len;
end X_Q_Length;
------------------------------------------------------------------------------
function X_Resource_Database (Display : X_Display) return X_Rm_Database is
Db : X_Rm_Database := None_X_Rm_Database;
begin
----Lock the display.
Lock_Display (Display);
----Get the database; if there is one.
if Display.Database /= None_X_Universal_Pointer then
Db := Univ_X_Rm_Database.From_X_Universal_Pointer
(Display.Database);
end if;
----Unlock and return the database.
Unlock_Display (Display);
return Db;
exception
when others =>
Unlock_Display (Display);
raise;
end X_Resource_Database;
------------------------------------------------------------------------------
function X_Resource_Manager_String
(Display : X_Display) return X_String_Pointer is
begin
return Display.X_Defaults;
end X_Resource_Manager_String;
------------------------------------------------------------------------------
procedure X_Set_Resource_Database (Display : X_Display;
Database : X_Rm_Database) is
New_Uv : X_Universal_Pointer := None_X_Universal_Pointer;
begin
----Lock the display.
Lock_Display (Display);
----If we have a new database then get a universal pointer for it; this may
-- fail with storage error and such so do it before we zap the old database.
if Database /= None_X_Rm_Database then
New_Uv := Univ_X_Rm_Database.To_X_Universal_Pointer (Database);
end if;
----If there is an old database then free the universal pointer; never the
-- database.
if Display.Database /= None_X_Universal_Pointer then
Univ_X_Rm_Database.Free_X_Universal_Pointer (Display.Database);
end if;
----Set the new database and unlock the display.
Display.Database := New_Uv;
Unlock_Display (Display);
exception
when others =>
Unlock_Display (Display);
raise;
end X_Set_Resource_Database;
------------------------------------------------------------------------------
function X_Screen_Count (Display : X_Display) return X_Screen_Number is
begin
return Display.Screens'Length;
end X_Screen_Count;
------------------------------------------------------------------------------
function X_Server_Vendor (Display : X_Display) return X_String is
begin
return Display.Vendor.all;
end X_Server_Vendor;
------------------------------------------------------------------------------
function X_Vendor_Release (Display : X_Display) return S_Long is
begin
return Display.Release;
end X_Vendor_Release;
------------------------------------------------------------------------------
--\f
------------------------------------------------------------------------------
-- Screen N of Display functions
------------------------------------------------------------------------------
function X_Black_Pixel (Display : X_Display;
Screen : X_Screen_Number) return X_Pixel is
begin
return Display.Screens (Screen).Black_Pixel;
end X_Black_Pixel;
------------------------------------------------------------------------------
function X_Default_Colormap (Display : X_Display;
Screen : X_Screen_Number) return X_Colormap is
begin
return Display.Screens (Screen).Default_Colormap;
end X_Default_Colormap;
------------------------------------------------------------------------------
function X_Default_Depth (Display : X_Display;
Screen : X_Screen_Number) return U_Char is
begin
return Display.Screens (Screen).Root_Depth;
end X_Default_Depth;
------------------------------------------------------------------------------
function X_Default_Gc (Display : X_Display;
Screen : X_Screen_Number) return X_Gc is
begin
return Display.Screens (Screen).Default_Gc;
end X_Default_Gc;
------------------------------------------------------------------------------
function X_Default_Visual (Display : X_Display;
Screen : X_Screen_Number) return X_Visual is
begin
return Display.Screens (Screen).Root_Visual;
end X_Default_Visual;
------------------------------------------------------------------------------
function X_Display_Cells (Display : X_Display;
Screen : X_Screen_Number) return U_Short is
begin
return X_Default_Visual (Display, Screen).Map_Entries;
end X_Display_Cells;
------------------------------------------------------------------------------
function X_Display_Height (Display : X_Display;
Screen : X_Screen_Number) return U_Short is
begin
return Display.Screens (Screen).Height;
end X_Display_Height;
------------------------------------------------------------------------------
function X_Display_Height_Mm (Display : X_Display;
Screen : X_Screen_Number) return U_Short is
begin
return Display.Screens (Screen).Mm_Height;
end X_Display_Height_Mm;
------------------------------------------------------------------------------
function X_Display_Planes (Display : X_Display;
Screen : X_Screen_Number) return U_Char is
begin
return Display.Screens (Screen).Root_Depth;
end X_Display_Planes;
------------------------------------------------------------------------------
function X_Display_Width (Display : X_Display;
Screen : X_Screen_Number) return U_Short is
begin
return Display.Screens (Screen).Width;
end X_Display_Width;
------------------------------------------------------------------------------
function X_Display_Width_Mm (Display : X_Display;
Screen : X_Screen_Number) return U_Short is
begin
return Display.Screens (Screen).Mm_Width;
end X_Display_Width_Mm;
------------------------------------------------------------------------------
function X_List_Depths (Display : X_Display;
Screen : X_Screen_Number) return U_Char_List is
------------------------------------------------------------------------------
-- Display - Specifies the display to use.
-- Screen - Specifies the number of the screen connected to the display.
--
-- Returns an array of the supported depths for this screen.
------------------------------------------------------------------------------
Scr : X_Screen;
Result : U_Char_List;
begin
if Screen not in Display.Screens'Range then
return None_U_Char_List;
end if;
Scr := Display.Screens (Screen);
Result := new U_Char_Array (S_Natural (Scr.Depths'First) ..
S_Natural (Scr.Depths'Last));
for I in Scr.Depths'Range loop
Result (S_Natural (I)) := Scr.Depths (I).Depth;
end loop;
return Result;
end X_List_Depths;
------------------------------------------------------------------------------
function X_Root_Window (Display : X_Display;
Screen : X_Screen_Number) return X_Window is
begin
return Display.Screens (Screen).Root;
end X_Root_Window;
------------------------------------------------------------------------------
function X_Screen_Of_Display (Display : X_Display;
Screen : X_Screen_Number) return X_Screen is
begin
return Display.Screens (Screen);
end X_Screen_Of_Display;
------------------------------------------------------------------------------
function X_White_Pixel (Display : X_Display; Screen : X_Screen_Number)
return X_Pixel is
begin
return Display.Screens (Screen).White_Pixel;
end X_White_Pixel;
------------------------------------------------------------------------------
--\f
------------------------------------------------------------------------------
-- Screen oriented functions (toolkit)
------------------------------------------------------------------------------
function X_Black_Pixel_Of_Screen (Screen : X_Screen) return X_Pixel is
begin
return Screen.Black_Pixel;
end X_Black_Pixel_Of_Screen;
------------------------------------------------------------------------------
function X_Cells_Of_Screen (Screen : X_Screen) return U_Short is
begin
return X_Default_Visual_Of_Screen (Screen).Map_Entries;
end X_Cells_Of_Screen;
------------------------------------------------------------------------------
function X_Default_Colormap_Of_Screen
(Screen : X_Screen) return X_Colormap is
begin
return Screen.Default_Colormap;
end X_Default_Colormap_Of_Screen;
------------------------------------------------------------------------------
function X_Default_Depth_Of_Screen (Screen : X_Screen) return U_Char is
begin
return Screen.Root_Depth;
end X_Default_Depth_Of_Screen;
------------------------------------------------------------------------------
function X_Default_Gc_Of_Screen (Screen : X_Screen) return X_Gc is
begin
return Screen.Default_Gc;
end X_Default_Gc_Of_Screen;
------------------------------------------------------------------------------
function X_Default_Visual_Of_Screen (Screen : X_Screen) return X_Visual is
begin
return Screen.Root_Visual;
end X_Default_Visual_Of_Screen;
------------------------------------------------------------------------------
function X_Display_Of_Screen (Screen : X_Screen) return X_Display is
begin
return Screen.Display;
end X_Display_Of_Screen;
------------------------------------------------------------------------------
function X_Does_Backing_Store (Screen : X_Screen)
return X_Backing_Store_Hint is
begin
return Screen.Backing_Store;
end X_Does_Backing_Store;
------------------------------------------------------------------------------
function X_Does_Save_Unders (Screen : X_Screen) return Boolean is
begin
return Screen.Save_Unders;
end X_Does_Save_Unders;
------------------------------------------------------------------------------
function X_Event_Mask_Of_Screen (Screen : X_Screen) return X_Event_Mask is
begin
return Screen.Root_Input_Mask;
end X_Event_Mask_Of_Screen;
------------------------------------------------------------------------------
function X_Height_Of_Screen (Screen : X_Screen) return U_Short is
begin
return Screen.Height;
end X_Height_Of_Screen;
------------------------------------------------------------------------------
function X_Height_Mm_Of_Screen (Screen : X_Screen) return U_Short is
begin
return Screen.Mm_Height;
end X_Height_Mm_Of_Screen;
------------------------------------------------------------------------------
function X_Max_Cmaps_Of_Screen (Screen : X_Screen) return U_Short is
begin
return Screen.Max_Maps;
end X_Max_Cmaps_Of_Screen;
------------------------------------------------------------------------------
function X_Min_Cmaps_Of_Screen (Screen : X_Screen) return U_Short is
begin
return Screen.Min_Maps;
end X_Min_Cmaps_Of_Screen;
------------------------------------------------------------------------------
function X_Planes_Of_Screen (Screen : X_Screen) return U_Char is
begin
return Screen.Root_Depth;
end X_Planes_Of_Screen;
------------------------------------------------------------------------------
function X_Root_Window_Of_Screen (Screen : X_Screen) return X_Window is
begin
return Screen.Root;
end X_Root_Window_Of_Screen;
------------------------------------------------------------------------------
function X_Screen_Number_Of_Screen
(Screen : X_Screen) return X_Screen_Number is
begin
for I in Screen.Display.Screens'Range loop
if Screen = Screen.Display.Screens (I) then
return I;
end if;
end loop;
end X_Screen_Number_Of_Screen;
------------------------------------------------------------------------------
function X_White_Pixel_Of_Screen (Screen : X_Screen) return X_Pixel is
begin
return Screen.White_Pixel;
end X_White_Pixel_Of_Screen;
------------------------------------------------------------------------------
function X_Width_Of_Screen (Screen : X_Screen) return U_Short is
begin
return Screen.Width;
end X_Width_Of_Screen;
------------------------------------------------------------------------------
function X_Width_Mm_Of_Screen (Screen : X_Screen) return U_Short is
begin
return Screen.Mm_Width;
end X_Width_Mm_Of_Screen;
------------------------------------------------------------------------------
function X_Visual_Id_From_Visual (Visual : X_Visual) return X_Visual_Id is
begin
return Visual.Visual_Id;
end X_Visual_Id_From_Visual;
------------------------------------------------------------------------------
--\f
begin
X_Lib_Default_X_Alloc_Id :=
Proc_Var_X_Alloc_Id.From_Pv (Default_X_Alloc_Id);
if X_Conn_Client_Prefix'Size /= 8 * 4 * 3 then
raise X_Library_Confusion;
end if;
if X_Conn_Setup'Size /= 8 * 4 * 8 then
raise X_Library_Confusion;
end if;
if X_Conn_Setup_Prefix'Size /= 8 * 4 * 2 then
raise X_Library_Confusion;
end if;
if X_Depths'Size /= 8 * 4 * 2 then
raise X_Library_Confusion;
end if;
if X_Pixmap_Format'Size /= 8 * 4 * 2 then
raise X_Library_Confusion;
end if;
if X_Visual_Type'Size /= 8 * 4 * 6 then
raise X_Library_Confusion;
end if;
if X_Window_Root'Size /= 8 * 4 * 10 then
raise X_Library_Confusion;
end if;
end Xlbp_Display;