|
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: 36402 (0x8e32)
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_Color;
use Xlbt_Color;
with Xlbt_Exceptions;
use Xlbt_Exceptions;
with Xlbt_Misc;
use Xlbt_Misc;
with Xlbt_Reply;
use Xlbt_Reply;
with Xlbt_Request;
use Xlbt_Request;
with Xlbt_String;
use Xlbt_String;
with Xlbt_Window;
use Xlbt_Window;
with Xlbt_Visual;
use Xlbt_Visual;
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;
package body Xlbp_Color is
------------------------------------------------------------------------------
-- X Library Colors
--
-- Xlbp_Color - Used to work with colors by name.
------------------------------------------------------------------------------
-- 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_Alloc_Color (Display : X_Display;
Colormap : X_Colormap;
Color : in out X_Color;
Status : out X_Status) is
Rep : X_Reply_Contents;
Succ : X_Status;
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
Put_X_Alloc_Color_Request
(Display, (Kind => Alloc_Color,
Length => X_Alloc_Color_Request'Size / 32,
Pad => 0,
Pad2 => 0,
Colormap => Colormap,
Red => Color.Red,
Green => Color.Green,
Blue => Color.Blue));
----Get the reply.
Get_Reply (Display => Display,
Code => Alloc_Color,
Reply => Rep,
Extra => 0,
Discard => True,
Status => Succ);
Status := Succ;
if Succ /= Failed then
Color.Pixel := Rep.Alloc_Color.Pixel;
Color.Red := Rep.Alloc_Color.Red;
Color.Green := Rep.Alloc_Color.Green;
Color.Blue := Rep.Alloc_Color.Blue;
end if;
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; return.
Unlock_Display (Display);
Sync_Handle (Display);
end X_Alloc_Color;
--\f
procedure X_Alloc_Color_Cells (Display : X_Display;
Colormap : X_Colormap;
Contiguous : Boolean;
Planes : out X_Plane_Mask_Array;
Pixels : out X_Pixel_Array;
Status : out X_Status) is
Succ : X_Status;
Rep : X_Reply_Contents;
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
Put_X_Alloc_Color_Cells_Request
(Display, (Kind => Alloc_Color_Cells,
Length => X_Alloc_Color_Cells_Request'Size / 32,
Contiguous => From_Boolean (Contiguous),
Colormap => Colormap,
Colors => Pixels'Length,
Planes => Planes'Length));
----Get the reply.
Get_Reply (Display => Display,
Code => Alloc_Color_Cells,
Reply => Rep,
Extra => X_Pixel'Size / 8 * Pixels'Length +
X_Plane_Mask'Size / 8 / 8 * Planes'Length,
Discard => False,
Status => Succ);
Status := Succ;
----Return our results.
if Succ /= Failed then
Get_X_Pixel_Array (Display, Pixels);
Get_X_Plane_Mask_Array (Display, Planes);
else
Pixels := (others => None_X_Pixel);
Planes := (others => No_Planes);
end if;
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; return.
Unlock_Display (Display);
Sync_Handle (Display);
end X_Alloc_Color_Cells;
--\f
procedure X_Alloc_Color_Planes (Display : X_Display;
Colormap : X_Colormap;
Contiguous : Boolean;
Pixels : out X_Pixel_Array;
N_Reds : U_Short;
N_Greens : U_Short;
N_Blues : U_Short;
R_Mask : out X_Red_Color_Mask;
G_Mask : out X_Green_Color_Mask;
B_Mask : out X_Blue_Color_Mask;
Status : out X_Status) is
Succ : X_Status;
Rep : X_Reply_Contents;
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
Put_X_Alloc_Color_Planes_Request
(Display, (Kind => Alloc_Color_Planes,
Length => X_Alloc_Color_Planes_Request'Size / 32,
Contiguous => From_Boolean (Contiguous),
Colormap => Colormap,
Colors => Pixels'Length,
Red => N_Reds,
Green => N_Greens,
Blue => N_Blues));
----Get the reply and the results.
Get_Reply (Display => Display,
Code => Alloc_Color_Planes,
Reply => Rep,
Extra => X_Pixel'Size / 8 * Pixels'Length,
Discard => False,
Status => Succ);
Status := Succ;
if Succ /= Failed then
R_Mask := Rep.Alloc_Color_Planes.Red_Mask;
G_Mask := Rep.Alloc_Color_Planes.Green_Mask;
B_Mask := Rep.Alloc_Color_Planes.Blue_Mask;
Get_X_Pixel_Array (Display, Pixels);
else
R_Mask := None_X_Color_Mask;
G_Mask := None_X_Color_Mask;
B_Mask := None_X_Color_Mask;
end if;
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; return.
Unlock_Display (Display);
Sync_Handle (Display);
end X_Alloc_Color_Planes;
--\f
procedure X_Alloc_Named_Color (Display : X_Display;
Colormap : X_Colormap;
Colorname : X_String;
Visual_Color : out X_Color;
Exact_Color : out X_Color;
Status : out X_Status) is
N_Bytes : U_Short;
Rep : X_Reply_Contents;
Succ : X_Status;
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
N_Bytes := Colorname'Length;
Put_X_Alloc_Named_Color_Request
(Display,
(Kind => Alloc_Named_Color,
Length =>
X_Alloc_Named_Color_Request'Size / 32 + (N_Bytes + 3) / 4,
Pad => 0,
Pad1 => 0,
Pad2 => 0,
N_Bytes => N_Bytes,
Colormap => Colormap),
S_Natural (N_Bytes));
----Send the extra data.
Put_X_String (Display, Colorname);
----Get the response.
Get_Reply (Display => Display,
Code => Alloc_Named_Color,
Reply => Rep,
Extra => 0,
Discard => True,
Status => Succ);
if Succ = Failed then
Visual_Color := None_X_Color;
Exact_Color := None_X_Color;
Status := Failed;
Unlock_Display (Display);
Sync_Handle (Display);
return;
end if;
Exact_Color.Red := Rep.Alloc_Named_Color.Exact_Red;
Exact_Color.Green := Rep.Alloc_Named_Color.Exact_Green;
Exact_Color.Blue := Rep.Alloc_Named_Color.Exact_Blue;
Visual_Color.Red := Rep.Alloc_Named_Color.Screen_Red;
Visual_Color.Green := Rep.Alloc_Named_Color.Screen_Green;
Visual_Color.Blue := Rep.Alloc_Named_Color.Screen_Blue;
Visual_Color.Pixel := Rep.Alloc_Named_Color.Pixel;
Exact_Color.Pixel := Rep.Alloc_Named_Color.Pixel;
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; return.
Unlock_Display (Display);
Sync_Handle (Display);
Status := Successful;
end X_Alloc_Named_Color;
--\f
procedure X_Free_Colors (Display : X_Display;
Colormap : X_Colormap;
Pixels : X_Pixel_Array;
Planes : X_Plane_Mask) is
N_Pixels : S_Natural := Pixels'Length;
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
Put_X_Free_Colors_Request
(Display,
(Kind => Free_Colors,
Length => X_Free_Colors_Request'Size / 32 + U_Short (N_Pixels),
Pad => 0,
Colormap => Colormap,
Plane_Mask => Planes),
N_Pixels * 4);
----Send the pixels.
Put_X_Pixel_Array (Display, Pixels);
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; return.
Unlock_Display (Display);
Sync_Handle (Display);
end X_Free_Colors;
--\f
procedure X_Lookup_Color (Display : X_Display;
Colormap : X_Colormap;
Colorname : X_String;
Visual_Color : out X_Color;
Exact_Color : out X_Color;
Status : out X_Status) is
N : S_Natural;
Reply : X_Reply_Contents;
Succ : X_Status;
begin
----Lock the display.
N := Colorname'Length;
Lock_Display (Display);
begin
----Send the request.
Put_X_Lookup_Color_Request
(Display,
(Kind => Lookup_Color,
Length =>
X_Lookup_Color_Request'Size / 32 + U_Short (N + 3) / 4,
Pad => 0,
Pad1 => 0,
Pad2 => 0,
Colormap => Colormap,
N_Bytes => U_Short (N)),
N);
----Send the extra data.
Put_X_String (Display, Colorname);
----Read the response.
Get_Reply (Display => Display,
Code => Lookup_Color,
Reply => Reply,
Extra => 0,
Discard => True,
Status => Succ);
if Succ = Failed then
Visual_Color := None_X_Color;
Exact_Color := None_X_Color;
Status := Failed;
Unlock_Display (Display);
Sync_Handle (Display);
return;
end if;
Visual_Color.Red := Reply.Lookup_Color.Exact_Red;
Visual_Color.Green := Reply.Lookup_Color.Exact_Green;
Visual_Color.Blue := Reply.Lookup_Color.Exact_Blue;
Exact_Color.Red := Reply.Lookup_Color.Screen_Red;
Exact_Color.Green := Reply.Lookup_Color.Screen_Green;
Exact_Color.Blue := Reply.Lookup_Color.Screen_Blue;
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; return.
Status := Successful;
Unlock_Display (Display);
Sync_Handle (Display);
end X_Lookup_Color;
--\f
procedure X_Parse_Color (Display : X_Display;
Colormap : X_Colormap;
Colorname : X_String;
Color : out X_Color;
Status : out X_Status) is
J, N : S_Natural;
R, G, B : U_Short;
C : X_Character;
begin
if Colorname'Length = 0 then
Color := None_X_Color;
Status := Failed;
end if;
N := Colorname'Length;
if Colorname (Colorname'First) /= '#' then
declare
Reply : X_Reply_Contents;
Succ : X_Status;
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
Put_X_Lookup_Color_Request
(Display, (Kind => Lookup_Color,
Length => X_Lookup_Color_Request'Size / 32 +
U_Short (N + 3) / 4,
Pad => 0,
Pad1 => 0,
Pad2 => 0,
Colormap => Colormap,
N_Bytes => U_Short (N)),
S_Natural (N));
----Send the string.
Put_X_String (Display, Colorname);
----Read the reply.
Get_Reply (Display => Display,
Code => Lookup_Color,
Reply => Reply,
Extra => 0,
Discard => True,
Status => Succ);
if Succ = Failed then
Color := None_X_Color;
Status := Failed;
Unlock_Display (Display);
Sync_Handle (Display);
return;
end if;
Color.Red := Reply.Lookup_Color.Exact_Red;
Color.Green := Reply.Lookup_Color.Exact_Green;
Color.Blue := Reply.Lookup_Color.Exact_Blue;
Color.Flags := X_Color_Flags'
(Do_Red | Do_Green | Do_Blue => True,
others => False);
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; return.
Unlock_Display (Display);
Sync_Handle (Display);
Status := Successful;
return;
end;
end if;
----Parse the string.
N := N - 1;
if N /= 3 and then
N /= 6 and then
N /= 9 and then
N /= 12 then
Status := Failed;
return;
end if;
N := N / 3;
R := 0;
G := 0;
B := 0;
loop
R := G;
G := B;
B := 0;
J := Colorname'First + 1;
for I in reverse 1 .. N loop
C := Colorname (J);
J := J + 1;
B := B * 2 ** 4;
if (C >= '0' and then C <= '9') then
B := B + X_Character'Pos (C) - X_Character'Pos ('0');
elsif (C >= 'A' and then C <= 'F') then
B := B + X_Character'Pos (C) - (X_Character'Pos ('A') - 10);
elsif (C >= 'a' and then C <= 'f') then
B := B + X_Character'Pos (C) - (X_Character'Pos ('a') - 10);
else
Status := Failed;
return;
end if;
end loop;
if Colorname (J) = Nul then
exit;
end if;
end loop;
N := N * 2 ** 2;
N := 16 - N;
Color.Red := R * 2 ** Natural (N);
Color.Green := G * 2 ** Natural (N);
Color.Blue := B * 2 ** Natural (N);
Color.Flags := X_Color_Flags'(Do_Red | Do_Green | Do_Blue => True,
others => False);
Status := Successful;
return;
end X_Parse_Color;
--\f
procedure X_Query_Color (Display : X_Display;
Colormap : X_Colormap;
Color : in out X_Color) is
New_Color : X_Rgb;
Rep : X_Reply_Contents;
Succ : X_Status;
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
Put_X_Query_Colors_Request
(Display,
(Kind => Query_Colors,
Length => X_Query_Colors_Request'Size / 32 +
U_Short (X_Pixel'Size / 32),
Pad => 0,
Colormap => Colormap),
X_Pixel'Size / 8);
Put_X_Pixel (Display, Color.Pixel);
----Get the reply.
Get_Reply (Display => Display,
Code => Query_Colors,
Reply => Rep,
Extra => 0,
Discard => False,
Status => Succ);
if Succ /= Failed then
Get_X_Rgb (Display, New_Color);
Color.Red := New_Color.Red;
Color.Blue := New_Color.Blue;
Color.Green := New_Color.Green;
Color.Flags := X_Color_Flags'
(Do_Red | Do_Green | Do_Blue => True,
others => False);
end if;
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; return.
Unlock_Display (Display);
Sync_Handle (Display);
end X_Query_Color;
--\f
procedure X_Query_Colors (Display : X_Display;
Colormap : X_Colormap;
Colors : in out X_Color_Array) is
Rep : X_Reply_Contents;
N_Colors : S_Natural := Colors'Length;
Succ : X_Status;
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
Put_X_Query_Colors_Request
(Display,
(Kind => Query_Colors,
Length => X_Query_Colors_Request'Size / 32 +
U_Short (N_Colors * X_Pixel'Size / 32),
Pad => 0,
Colormap => Colormap),
N_Colors * X_Pixel'Size / 8);
----Put out the extra data.
for I in Colors'Range loop
Put_X_Pixel (Display, Colors (I).Pixel);
end loop;
----Get the reply.
Get_Reply (Display => Display,
Code => Query_Colors,
Reply => Rep,
Extra => N_Colors * X_Rgb'Size / 8,
Discard => False,
Status => Succ);
if Succ /= Failed then
declare
Color : X_Rgb_Array (1 .. N_Colors);
begin
Get_X_Rgb_Array (Display, Color);
for I in Color'Range loop
Colors (Colors'First - 1 + I).Red := Color (I).Red;
Colors (Colors'First - 1 + I).Green := Color (I).Green;
Colors (Colors'First - 1 + I).Blue := Color (I).Blue;
Colors (Colors'First - 1 + I).Flags :=
X_Color_Flags'(Do_Red | Do_Green | Do_Blue => True,
others => False);
end loop;
end;
end if;
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; return.
Unlock_Display (Display);
Sync_Handle (Display);
end X_Query_Colors;
--\f
procedure X_Set_Window_Colormap (Display : X_Display;
Window : X_Window;
Colormap : X_Colormap) is
------------------------------------------------------------------------------
-- X_Set_Window_Colormap
------------------------------------------------------------------------------
begin
----Lock the display.
Lock_Display (Display);
begin
----Put out 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_Colormap => True, others => False)),
4);
Put_X_Id (Display, Colormap.Id);
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; and return.
Unlock_Display (Display);
Sync_Handle (Display);
end X_Set_Window_Colormap;
--\f
procedure X_Store_Color (Display : X_Display;
Colormap : X_Colormap;
Color : X_Color) is
Citem : X_Color_Item;
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
Put_X_Store_Colors_Request
(Display,
(Kind => Store_Colors,
Length =>
X_Store_Colors_Request'Size / 32 + X_Color_Item'Size / 32,
Pad => 0,
Colormap => Colormap),
4 * S_Natural (X_Color_Item'Size / 32));
----Send the extra data.
Citem.Pixel := Color.Pixel;
Citem.Red := Color.Red;
Citem.Green := Color.Green;
Citem.Blue := Color.Blue;
Citem.Flags := Color.Flags; -- do_red, do_green, do_blue
Put_X_Color_Item (Display, Citem);
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; return.
Unlock_Display (Display);
Sync_Handle (Display);
end X_Store_Color;
--\f
procedure X_Store_Colors (Display : X_Display;
Colormap : X_Colormap;
Colors : X_Color_Array) is
N_Colors : S_Natural := Colors'Length;
Citem : X_Color_Item;
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
Put_X_Store_Colors_Request
(Display,
(Kind => Store_Colors,
Length => X_Store_Colors_Request'Size / 32 +
U_Short (N_Colors) * X_Color_Item'Size / 32,
Pad => 0,
Colormap => Colormap),
N_Colors * S_Natural (X_Color_Item'Size / 32) * 4);
----Send the extra data.
for I in Colors'Range loop
Citem.Pixel := Colors (I).Pixel;
Citem.Red := Colors (I).Red;
Citem.Green := Colors (I).Green;
Citem.Blue := Colors (I).Blue;
Citem.Flags := Colors (I).Flags;
Put_X_Color_Item (Display, Citem);
end loop;
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; return.
Unlock_Display (Display);
Sync_Handle (Display);
end X_Store_Colors;
--\f
procedure X_Store_Named_Color (Display : X_Display;
Colormap : X_Colormap;
Name : X_String;
Pixel : X_Pixel;
Flags : X_Color_Flags) is
N_Bytes : U_Short := Name'Length;
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
Put_X_Store_Named_Color_Request
(Display,
(Kind => Store_Named_Color,
Length =>
X_Store_Named_Color_Request'Size / 32 + (N_Bytes + 3) / 4,
Pad1 => 0,
Pad2 => 0,
Colormap => Colormap,
Flags => Flags,
Pixel => Pixel,
N_Bytes => N_Bytes),
S_Natural (N_Bytes));
----Send the name.
Put_X_String (Display, Name);
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; return.
Unlock_Display (Display);
Sync_Handle (Display);
end X_Store_Named_Color;
--\f
function X_Copy_Colormap_And_Free
(Display : X_Display;
Source_Colormap : X_Colormap) return X_Colormap is
Mid : X_Colormap;
begin
----Lock the display.
Lock_Display (Display);
begin
----Allocate a new ID and send the request.
Mid := (Id => Internal_X_Alloc_Id (Display));
Put_X_Copy_Colormap_And_Free_Request
(Display, (Kind => Copy_Colormap_And_Free,
Length => X_Copy_Colormap_And_Free_Request'Size / 32,
Pad => 0,
Mid => Mid,
Src_Colormap => Source_Colormap));
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; return new colormap.
Unlock_Display (Display);
Sync_Handle (Display);
return Mid;
end X_Copy_Colormap_And_Free;
--\f
function X_Create_Colormap
(Display : X_Display;
Window : X_Window;
Visual : X_Visual;
Allocate : X_Colormap_Alloc) return X_Colormap is
Mid : X_Colormap;
Vid : X_Visual_Id := Copy_From_Parent_Visual_Id;
begin
----Lock the display.
Lock_Display (Display);
begin
----Allocate a new ID and send the request.
Mid := (Id => Internal_X_Alloc_Id (Display));
if Visual /= None_X_Visual then
Vid := Visual.Visual_Id;
end if;
Put_X_Create_Colormap_Request
(Display, (Kind => Create_Colormap,
Length => X_Create_Colormap_Request'Size / 32,
Window => Window,
Mid => Mid,
Alloc => Allocate,
Visual => Vid));
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; return new colormap.
Unlock_Display (Display);
Sync_Handle (Display);
return Mid;
end X_Create_Colormap;
--\f
procedure X_Free_Colormap (Display : X_Display;
Colormap : in out X_Colormap) is
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
Put_X_Free_Colormap_Request
(Display, (Kind => Free_Colormap,
Length => X_Free_Colormap_Request'Size / 32,
Pad => 0,
Id => Colormap));
Colormap := None_X_Colormap;
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; return new colormap.
Unlock_Display (Display);
Sync_Handle (Display);
end X_Free_Colormap;
--\f
procedure X_Install_Colormap (Display : X_Display;
Colormap : X_Colormap) is
------------------------------------------------------------------------------
-- X_Install_Colormap
------------------------------------------------------------------------------
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
Put_X_Install_Colormap_Request
(Display, (Kind => Install_Colormap,
Length => X_Install_Colormap_Request'Size / 32,
Pad => 0,
Id => Colormap));
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock the display; sync up; and return.
Unlock_Display (Display);
Sync_Handle (Display);
end X_Install_Colormap;
--\f
function X_List_Installed_Colormaps
(Display : X_Display;
Win : X_Window) return X_Colormap_List is
------------------------------------------------------------------------------
-- X_List_Installed_Colormaps
------------------------------------------------------------------------------
Rep : X_Reply_Contents;
Succ : X_Status;
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
Put_X_List_Installed_Colormaps_Request
(Display,
(Kind => List_Installed_Colormaps,
Length => X_List_Installed_Colormaps_Request'Size / 32,
Pad => 0,
Id => Win));
----Read the reply header.
Get_Reply (Display => Display,
Code => List_Installed_Colormaps,
Reply => Rep,
Extra => 0,
Discard => False,
Status => Succ);
----If the request failed then equate that with no-colormaps; return null.
if Succ = Failed then
Unlock_Display (Display);
Sync_Handle (Display);
return None_X_Colormap_List;
end if;
----Read in the Colormap array. Read in the correct number of bytes and then
-- do the unchecked conversion. Yes, the dynamically created subtype is
-- crucial.
declare
Colormap : X_Colormap_List;
Length : S_Natural :=
S_Natural (Rep.List_Installed_Colormaps.N_Colormaps);
begin
begin
Colormap := new X_Colormap_Array (1 .. Length);
exception
when others =>
Eat_Raw_Data (Display, Length * (X_Colormap'Size / 8));
raise;
end;
Get_X_Colormap_Array (Display, Colormap.all);
Unlock_Display (Display);
Sync_Handle (Display);
return Colormap;
exception
when others =>
Free_X_Colormap_List (Colormap);
raise;
end;
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
end X_List_Installed_Colormaps;
--\f
procedure X_Uninstall_Colormap (Display : X_Display;
Colormap : X_Colormap) is
------------------------------------------------------------------------------
-- X_Uninstall_Colormap
------------------------------------------------------------------------------
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
Put_X_Uninstall_Colormap_Request
(Display, (Kind => Uninstall_Colormap,
Length => X_Uninstall_Colormap_Request'Size / 32,
Pad => 0,
Id => Colormap));
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock the display; sync up; and return.
Unlock_Display (Display);
Sync_Handle (Display);
end X_Uninstall_Colormap;
--\f
begin
if X_Rgb'Size rem 32 /= 0 then
raise X_Library_Confusion;
end if;
end Xlbp_Color;