|
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: 47632 (0xba10)
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_Extension;
use Xlbt_Extension;
with Xlbt_Gc2;
use Xlbt_Gc2;
with Xlbt_Graphics;
use Xlbt_Graphics;
with Xlbt_Proc_Var;
use Xlbt_Proc_Var;
with Xlbt_Reply;
use Xlbt_Reply;
with Xlbt_Request;
use Xlbt_Request;
with Xlbp_Extension;
use Xlbp_Extension;
with Xlbp_Proc_Var;
use Xlbp_Proc_Var;
with Xlbip_Get_Reply;
use Xlbip_Get_Reply;
with Xlbip_Internal;
use Xlbip_Internal;
with Xlbip_Put_Request;
use Xlbip_Put_Request;
package body Xlbp_Gc is
------------------------------------------------------------------------------
-- X Library Graphic Context
--
-- Xlbp_Gc - Create and maintain Graphic Contexts
------------------------------------------------------------------------------
-- 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
Initial_Gc : constant X_Gc_Values :=
(Funct => Gx_Copy,
Plane_Mask => All_Planes,
Foreground => 0,
Background => 1,
Line_Width => 0,
Line_Style => Line_Solid,
Cap_Style => Cap_Butt,
Join_Style => Join_Miter,
Fill_Style => Fill_Solid,
Fill_Rule => Even_Odd_Rule,
Arc_Mode => Arc_Pie_Slice,
Tile => (Drawable => (Id => (Number => -1))),
Stipple => (Drawable => (Id => (Number => -1))),
Ts_X_Origin => 0,
Ts_Y_Origin => 0,
Font => (Id => (Number => -1)),
Subwindow_Mode => Clip_By_Children,
Graphics_Exposures => True,
Clip_X_Origin => 0,
Clip_Y_Origin => 0,
Clip_Mask => None_X_Pixmap,
Dash_Offset => 0,
Dashes => 4 -- dashes (list [4,4])
);
Valid_Gc_Values_Bits : constant X_Gc_Components :=
X_Gc_Components'
(Gc_Function | Gc_Plane_Mask | Gc_Foreground | Gc_Background |
Gc_Line_Width | Gc_Line_Style | Gc_Cap_Style | Gc_Join_Style |
Gc_Fill_Style | Gc_Fill_Rule | Gc_Tile | Gc_Stipple |
Gc_Tile_Stip_X_Origin | Gc_Tile_Stip_Y_Origin | Gc_Font |
Gc_Subwindow_Mode | Gc_Graphics_Exposures | Gc_Clip_X_Origin |
Gc_Clip_Y_Origin | Gc_Dash_Offset | Gc_Arc_Mode => True,
others => False);
procedure Free_X_Gc is
new Unchecked_Deallocation (X_Gc_Rec,
X_Gc);
--\f
procedure Private_X_Update_Gc_Cache (Gc : X_Gc;
Mask : X_Gc_Components;
Att : X_Gc_Values) is
Gv : X_Gc_Values renames Gc.Values;
begin
if Mask (Gc_Function) then
if Gv.Funct /= Att.Funct then
Gv.Funct := Att.Funct;
Gc.Dirty (Gc_Function) := True;
end if;
end if;
if Mask (Gc_Plane_Mask) then
if Gv.Plane_Mask /= Att.Plane_Mask then
Gv.Plane_Mask := Att.Plane_Mask;
Gc.Dirty (Gc_Plane_Mask) := True;
end if;
end if;
if Mask (Gc_Foreground) then
if Gv.Foreground /= Att.Foreground then
Gv.Foreground := Att.Foreground;
Gc.Dirty (Gc_Foreground) := True;
end if;
end if;
if Mask (Gc_Background) then
if Gv.Background /= Att.Background then
Gv.Background := Att.Background;
Gc.Dirty (Gc_Background) := True;
end if;
end if;
if Mask (Gc_Line_Width) then
if (Gv.Line_Width /= Att.Line_Width) then
Gv.Line_Width := Att.Line_Width;
Gc.Dirty (Gc_Line_Width) := True;
end if;
end if;
if Mask (Gc_Line_Style) then
if Gv.Line_Style /= Att.Line_Style then
Gv.Line_Style := Att.Line_Style;
Gc.Dirty (Gc_Line_Style) := True;
end if;
end if;
if Mask (Gc_Cap_Style) then
if Gv.Cap_Style /= Att.Cap_Style then
Gv.Cap_Style := Att.Cap_Style;
Gc.Dirty (Gc_Cap_Style) := True;
end if;
end if;
if Mask (Gc_Join_Style) then
if Gv.Join_Style /= Att.Join_Style then
Gv.Join_Style := Att.Join_Style;
Gc.Dirty (Gc_Join_Style) := True;
end if;
end if;
if Mask (Gc_Fill_Style) then
if Gv.Fill_Style /= Att.Fill_Style then
Gv.Fill_Style := Att.Fill_Style;
Gc.Dirty (Gc_Fill_Style) := True;
end if;
end if;
if Mask (Gc_Fill_Rule) then
if Gv.Fill_Rule /= Att.Fill_Rule then
Gv.Fill_Rule := Att.Fill_Rule;
Gc.Dirty (Gc_Fill_Rule) := True;
end if;
end if;
if Mask (Gc_Arc_Mode) then
if Gv.Arc_Mode /= Att.Arc_Mode then
Gv.Arc_Mode := Att.Arc_Mode;
Gc.Dirty (Gc_Arc_Mode) := True;
end if;
end if;
-- always write through tile change; client may have changed the pixmap
-- and the server may have copied it the last time
if Mask (Gc_Tile) then
Gv.Tile := Att.Tile;
Gc.Dirty (Gc_Tile) := True;
end if;
-- always write through stipple change; client may have changed the
-- pixmap and the server may have copied it the last time
if Mask (Gc_Stipple) then
Gv.Stipple := Att.Stipple;
Gc.Dirty (Gc_Stipple) := True;
end if;
if Mask (Gc_Tile_Stip_X_Origin) then
if (Gv.Ts_X_Origin /= Att.Ts_X_Origin) then
Gv.Ts_X_Origin := Att.Ts_X_Origin;
Gc.Dirty (Gc_Tile_Stip_X_Origin) := True;
end if;
end if;
if Mask (Gc_Tile_Stip_Y_Origin) then
if (Gv.Ts_Y_Origin /= Att.Ts_Y_Origin) then
Gv.Ts_Y_Origin := Att.Ts_Y_Origin;
Gc.Dirty (Gc_Tile_Stip_Y_Origin) := True;
end if;
end if;
if Mask (Gc_Font) and then
Gv.Font /= Att.Font then
Gv.Font := Att.Font;
Gc.Dirty (Gc_Font) := True;
end if;
if Mask (Gc_Subwindow_Mode) then
if Gv.Subwindow_Mode /= Att.Subwindow_Mode then
Gv.Subwindow_Mode := Att.Subwindow_Mode;
Gc.Dirty (Gc_Subwindow_Mode) := True;
end if;
end if;
if Mask (Gc_Graphics_Exposures) then
if (Gv.Graphics_Exposures /= Att.Graphics_Exposures) then
Gv.Graphics_Exposures := Att.Graphics_Exposures;
Gc.Dirty (Gc_Graphics_Exposures) := True;
end if;
end if;
if Mask (Gc_Clip_X_Origin) then
if (Gv.Clip_X_Origin /= Att.Clip_X_Origin) then
Gv.Clip_X_Origin := Att.Clip_X_Origin;
Gc.Dirty (Gc_Clip_X_Origin) := True;
end if;
end if;
if Mask (Gc_Clip_Y_Origin) then
if (Gv.Clip_Y_Origin /= Att.Clip_Y_Origin) then
Gv.Clip_Y_Origin := Att.Clip_Y_Origin;
Gc.Dirty (Gc_Clip_Y_Origin) := True;
end if;
end if;
-- always write through mask change; somebody may have changed the
-- pixmap contents and the server may have made a copy of old one
if Mask (Gc_Clip_Mask) then
Gv.Clip_Mask := Att.Clip_Mask;
Gc.Dirty (Gc_Clip_Mask) := True;
Gc.Rects := False;
end if;
if Mask (Gc_Dash_Offset) then
if (Gv.Dash_Offset /= Att.Dash_Offset) then
Gv.Dash_Offset := Att.Dash_Offset;
Gc.Dirty (Gc_Dash_Offset) := True;
end if;
end if;
if Mask (Gc_Dash_List) then
if ((Gv.Dashes /= Att.Dashes) or else
(Gc.Dashes = True)) then
Gv.Dashes := Att.Dashes;
Gc.Dirty (Gc_Dash_List) := True;
Gc.Dashes := False;
end if;
end if;
return;
end Private_X_Update_Gc_Cache;
--\f
procedure X_Change_Gc (Display : X_Display;
Gc : X_Gc;
Values_Mask : X_Gc_Components;
Values : X_Gc_Values) is
Lvalues_Mask : X_Gc_Components := Values_Mask and All_Gc_Components;
begin
if Lvalues_Mask /= None_X_Gc_Components then
Lock_Display (Display);
begin
Private_X_Update_Gc_Cache (Gc, Lvalues_Mask, Values);
-- if any Resource ID changed, must flush
if (Gc.Dirty and X_Gc_Components'
(Gc_Font | Gc_Tile | Gc_Stipple => True,
others => False)) /=
None_X_Gc_Components then
Private_X_Flush_Gc_Cache (Display, Gc);
end if;
Unlock_Display (Display);
Sync_Handle (Display);
exception
when others =>
Unlock_Display (Display);
raise;
end;
end if;
end X_Change_Gc;
--\f
procedure X_Copy_Gc (Display : X_Display;
Source_Gc : X_Gc;
Values_Mask : X_Gc_Components;
Destination_Gc : X_Gc) is
Dest_Gv : X_Gc_Values renames Destination_Gc.Values;
Src_Gv : X_Gc_Values renames Source_Gc.Values;
Ext : X_Extension;
Lmask : X_Gc_Components := Values_Mask and All_Gc_Components;
begin
Lock_Display (Display);
begin
----If some of the source values to be copied are "dirty" then flush them out
-- before sending the CopyGC request.
if (Source_Gc.Dirty and Lmask) /= None_X_Gc_Components then
Private_X_Flush_Gc_Cache (Display, Source_Gc);
end if;
----Mark the copied values "not dirty" in the destination.
Destination_Gc.Dirty := Destination_Gc.Dirty and not Lmask;
Put_X_Copy_Gc_Request
(Display, (Kind => Copy_Gc,
Length => X_Copy_Gc_Request'Size / 32,
Pad => 0,
Src_Gc => Source_Gc.Gid,
Dst_Gc => Destination_Gc.Gid,
Mask => Lmask));
if Lmask (Gc_Function) then
Dest_Gv.Funct := Src_Gv.Funct;
end if;
if Lmask (Gc_Plane_Mask) then
Dest_Gv.Plane_Mask := Src_Gv.Plane_Mask;
end if;
if Lmask (Gc_Foreground) then
Dest_Gv.Foreground := Src_Gv.Foreground;
end if;
if Lmask (Gc_Background) then
Dest_Gv.Background := Src_Gv.Background;
end if;
if Lmask (Gc_Line_Width) then
Dest_Gv.Line_Width := Src_Gv.Line_Width;
end if;
if Lmask (Gc_Line_Style) then
Dest_Gv.Line_Style := Src_Gv.Line_Style;
end if;
if Lmask (Gc_Cap_Style) then
Dest_Gv.Cap_Style := Src_Gv.Cap_Style;
end if;
if Lmask (Gc_Join_Style) then
Dest_Gv.Join_Style := Src_Gv.Join_Style;
end if;
if Lmask (Gc_Fill_Style) then
Dest_Gv.Fill_Style := Src_Gv.Fill_Style;
end if;
if Lmask (Gc_Fill_Rule) then
Dest_Gv.Fill_Rule := Src_Gv.Fill_Rule;
end if;
if Lmask (Gc_Arc_Mode) then
Dest_Gv.Arc_Mode := Src_Gv.Arc_Mode;
end if;
if Lmask (Gc_Tile) then
Dest_Gv.Tile := Src_Gv.Tile;
end if;
if Lmask (Gc_Stipple) then
Dest_Gv.Stipple := Src_Gv.Stipple;
end if;
if Lmask (Gc_Tile_Stip_X_Origin) then
Dest_Gv.Ts_X_Origin := Src_Gv.Ts_X_Origin;
end if;
if Lmask (Gc_Tile_Stip_Y_Origin) then
Dest_Gv.Ts_Y_Origin := Src_Gv.Ts_Y_Origin;
end if;
if Lmask (Gc_Font) then
Dest_Gv.Font := Src_Gv.Font;
end if;
if Lmask (Gc_Subwindow_Mode) then
Dest_Gv.Subwindow_Mode := Src_Gv.Subwindow_Mode;
end if;
if Lmask (Gc_Graphics_Exposures) then
Dest_Gv.Graphics_Exposures := Src_Gv.Graphics_Exposures;
end if;
if Lmask (Gc_Clip_X_Origin) then
Dest_Gv.Clip_X_Origin := Src_Gv.Clip_X_Origin;
end if;
if Lmask (Gc_Clip_Y_Origin) then
Dest_Gv.Clip_Y_Origin := Src_Gv.Clip_Y_Origin;
end if;
if Lmask (Gc_Clip_Mask) then
Destination_Gc.Rects := Source_Gc.Rects;
Dest_Gv.Clip_Mask := Src_Gv.Clip_Mask;
end if;
if Lmask (Gc_Dash_Offset) then
Dest_Gv.Dash_Offset := Src_Gv.Dash_Offset;
end if;
if Lmask (Gc_Dash_List) then
Destination_Gc.Dashes := Source_Gc.Dashes;
Dest_Gv.Dashes := Src_Gv.Dashes;
end if;
Ext := Display.Ext_Procs;
while Ext /= null loop
if Ext.Copy_Gc /= None_X_Procedure_Variable then
Proc_Var_X_Display_Gc_Extension.Call
(Proc_Var_X_Display_Gc_Extension.To_Pv (Ext.Copy_Gc),
Display, Destination_Gc, Ext.Codes);
end if;
Ext := Ext.Next;
end loop;
Unlock_Display (Display);
Sync_Handle (Display);
exception
when others =>
Unlock_Display (Display);
raise;
end;
end X_Copy_Gc;
--\f
procedure Process_X_Gc_Components (Display : X_Display;
Dirty : X_Gc_Components;
Gv : X_Gc_Values) is
------------------------------------------------------------------------------
-- Append the various "dirty" fields in a GC's cache to a request that is
-- creating or updating a GC.
------------------------------------------------------------------------------
begin
----Note: The order of these tests are critical; the order must be the same as
-- the GC mask bits in the word.
if Dirty (Gc_Function) then
Put_S_Long (Display,
S_Long (X_Graphic_Function'Pos (Gv.Funct)));
end if;
if Dirty (Gc_Plane_Mask) then
Put_X_Plane_Mask (Display,
Gv.Plane_Mask);
end if;
if Dirty (Gc_Foreground) then
Put_X_Pixel (Display,
Gv.Foreground);
end if;
if Dirty (Gc_Background) then
Put_X_Pixel (Display,
Gv.Background);
end if;
if Dirty (Gc_Line_Width) then
Put_S_Long (Display,
S_Long (Gv.Line_Width));
end if;
if Dirty (Gc_Line_Style) then
Put_S_Long (Display,
S_Long (X_Line_Style'Pos (Gv.Line_Style)));
end if;
if Dirty (Gc_Cap_Style) then
Put_S_Long (Display,
S_Long (X_Cap_Style'Pos (Gv.Cap_Style)));
end if;
if Dirty (Gc_Join_Style) then
Put_S_Long (Display,
S_Long (X_Join_Style'Pos (Gv.Join_Style)));
end if;
if Dirty (Gc_Fill_Style) then
Put_S_Long (Display,
S_Long (X_Fill_Style'Pos (Gv.Fill_Style)));
end if;
if Dirty (Gc_Fill_Rule) then
Put_S_Long (Display,
S_Long (X_Fill_Rule'Pos (Gv.Fill_Rule)));
end if;
if Dirty (Gc_Tile) then
Put_X_Id (Display,
Gv.Tile.Drawable.Id);
end if;
if Dirty (Gc_Stipple) then
Put_X_Id (Display,
Gv.Stipple.Drawable.Id);
end if;
if Dirty (Gc_Tile_Stip_X_Origin) then
Put_S_Long (Display,
S_Long (Gv.Ts_X_Origin));
end if;
if Dirty (Gc_Tile_Stip_Y_Origin) then
Put_S_Long (Display,
S_Long (Gv.Ts_Y_Origin));
end if;
if Dirty (Gc_Font) then
Put_X_Id (Display,
Gv.Font.Id);
end if;
if Dirty (Gc_Subwindow_Mode) then
Put_S_Long (Display, S_Long
(X_Subwindow_Mode'Pos (Gv.Subwindow_Mode)));
end if;
if Dirty (Gc_Graphics_Exposures) then
Put_S_Long (Display,
S_Long (Boolean'Pos (Gv.Graphics_Exposures)));
end if;
if Dirty (Gc_Clip_X_Origin) then
Put_S_Long (Display,
S_Long (Gv.Clip_X_Origin));
end if;
if Dirty (Gc_Clip_Y_Origin) then
Put_S_Long (Display,
S_Long (Gv.Clip_Y_Origin));
end if;
if Dirty (Gc_Clip_Mask) then
Put_X_Id (Display,
Gv.Clip_Mask.Drawable.Id);
end if;
if Dirty (Gc_Dash_Offset) then
Put_S_Long (Display,
S_Long (Gv.Dash_Offset));
end if;
if Dirty (Gc_Dash_List) then
Put_S_Long (Display,
S_Long (Gv.Dashes));
end if;
if Dirty (Gc_Arc_Mode) then
Put_S_Long (Display,
S_Long (X_Arc_Mode'Pos (Gv.Arc_Mode)));
end if;
end Process_X_Gc_Components;
--\f
function X_Create_Gc
(Display : X_Display;
Drawable : X_Drawable;
Values_Mask : X_Gc_Components;
Values : X_Gc_Values) return X_Gc is
Gc : X_Gc;
Ext : X_Extension;
Extra_Words : S_Natural;
Lvalues_Mask : X_Gc_Components := Values_Mask and All_Gc_Components;
begin
Lock_Display (Display);
begin
Gc := new X_Gc_Rec;
Gc.Rects := False;
Gc.Dashes := False;
Gc.Ext_Data := null;
Gc.Values := Initial_Gc;
Gc.Dirty := (others => False);
if Lvalues_Mask /= None_X_Gc_Components then
Private_X_Update_Gc_Cache (Gc, Lvalues_Mask, Values);
end if;
Gc.Gid := (Id => Xlbp_Extension.X_Alloc_Id (Display));
Extra_Words := 0;
for I in Gc.Dirty'Range loop
if Gc.Dirty (I) then
Extra_Words := Extra_Words + 1;
end if;
end loop;
Put_X_Create_Gc_Request
(Display, (Kind => Create_Gc,
Length => X_Create_Gc_Request'Size / 32
+ U_Short (Extra_Words),
Pad => 0,
Drawable => Drawable.Id,
Gc => Gc.Gid,
Create_Mask => Gc.Dirty),
Extra_Words * 4);
if Extra_Words > 0 then
Process_X_Gc_Components (Display, Gc.Dirty, Gc.Values);
Gc.Dirty := None_X_Gc_Components;
end if;
Ext := Display.Ext_Procs;
while Ext /=
null loop -- call out to any extensions interested
if Ext.Create_Gc /= None_X_Procedure_Variable then
Proc_Var_X_Display_Gc_Extension.Call
(Proc_Var_X_Display_Gc_Extension.To_Pv (Ext.Create_Gc),
Display, Gc, Ext.Codes);
end if;
Ext := Ext.Next;
end loop;
Unlock_Display (Display);
Sync_Handle (Display);
return Gc;
exception
when others =>
Unlock_Display (Display);
raise;
end;
end X_Create_Gc;
--\f
procedure X_Free_Gc (Display : X_Display;
Gc : in out X_Gc) is
Ext : X_Extension;
begin
if Gc = None_X_Gc then
return;
end if;
Lock_Display (Display);
begin
Put_X_Free_Gc_Request
(Display, (Kind => Free_Gc,
Length => X_Free_Gc_Request'Size / 32,
Pad => 0,
Id => Gc.Gid));
Free_X_Ext_Data (Gc.Ext_Data);
Free_X_Gc (Gc);
Gc := None_X_Gc;
Ext := Display.Ext_Procs;
while Ext /=
null loop -- call out to any extensions interested
if Ext.Free_Gc /= None_X_Procedure_Variable then
Proc_Var_X_Display_Gc_Extension.Call
(Proc_Var_X_Display_Gc_Extension.To_Pv (Ext.Free_Gc),
Display, Gc, Ext.Codes);
end if;
Ext := Ext.Next;
end loop;
Unlock_Display (Display);
Sync_Handle (Display);
exception
when others =>
Unlock_Display (Display);
raise;
end;
end X_Free_Gc;
--\f
function X_G_Context_From_Gc (Gc : X_Gc) return X_G_Context is
begin
return Gc.Gid;
end X_G_Context_From_Gc;
--\f
procedure X_Get_Gc_Values (Display : X_Display;
Gc : X_Gc;
Values_Mask : X_Gc_Components;
Values : out X_Gc_Values;
Status : out X_Status) is
------------------------------------------------------------------------------
-- Display - Specifies the display to use.
-- Gc - Specifies the graphics context to use.
-- Values_Mask - Specifies what values to return
-- Values - Receives the values returned
-- Status - Receives Successful if all values were returned, Failed if
-- some values were not returned
--
-- Called to obtain some values from those that make up a GC. Can return all
-- GC fields except Gc_Clip_Mask and Gc_Dash_List.
------------------------------------------------------------------------------
begin
if (Values_Mask and Valid_Gc_Values_Bits) /= Values_Mask then
Status := Failed;
end if;
if Values_Mask (Gc_Function) then
Values.Funct := Gc.Values.Funct;
end if;
if Values_Mask (Gc_Plane_Mask) then
Values.Plane_Mask := Gc.Values.Plane_Mask;
end if;
if Values_Mask (Gc_Foreground) then
Values.Foreground := Gc.Values.Foreground;
end if;
if Values_Mask (Gc_Background) then
Values.Background := Gc.Values.Background;
end if;
if Values_Mask (Gc_Line_Width) then
Values.Line_Width := Gc.Values.Line_Width;
end if;
if Values_Mask (Gc_Line_Style) then
Values.Line_Style := Gc.Values.Line_Style;
end if;
if Values_Mask (Gc_Cap_Style) then
Values.Cap_Style := Gc.Values.Cap_Style;
end if;
if Values_Mask (Gc_Join_Style) then
Values.Join_Style := Gc.Values.Join_Style;
end if;
if Values_Mask (Gc_Fill_Style) then
Values.Fill_Style := Gc.Values.Fill_Style;
end if;
if Values_Mask (Gc_Fill_Rule) then
Values.Fill_Rule := Gc.Values.Fill_Rule;
end if;
if Values_Mask (Gc_Tile) then
Values.Tile := Gc.Values.Tile;
end if;
if Values_Mask (Gc_Stipple) then
Values.Stipple := Gc.Values.Stipple;
end if;
if Values_Mask (Gc_Tile_Stip_X_Origin) then
Values.Ts_X_Origin := Gc.Values.Ts_X_Origin;
end if;
if Values_Mask (Gc_Tile_Stip_Y_Origin) then
Values.Ts_Y_Origin := Gc.Values.Ts_Y_Origin;
end if;
if Values_Mask (Gc_Font) then
Values.Font := Gc.Values.Font;
end if;
if Values_Mask (Gc_Subwindow_Mode) then
Values.Subwindow_Mode := Gc.Values.Subwindow_Mode;
end if;
if Values_Mask (Gc_Graphics_Exposures) then
Values.Graphics_Exposures := Gc.Values.Graphics_Exposures;
end if;
if Values_Mask (Gc_Clip_X_Origin) then
Values.Clip_X_Origin := Gc.Values.Clip_X_Origin;
end if;
if Values_Mask (Gc_Clip_Y_Origin) then
Values.Clip_Y_Origin := Gc.Values.Clip_Y_Origin;
end if;
if Values_Mask (Gc_Dash_Offset) then
Values.Dash_Offset := Gc.Values.Dash_Offset;
end if;
if Values_Mask (Gc_Arc_Mode) then
Values.Arc_Mode := Gc.Values.Arc_Mode;
end if;
Status := Successful;
end X_Get_Gc_Values;
--\f
procedure X_Query_Best_Size (Display : X_Display;
Class : X_Best_Size_Class;
Drawable : X_Drawable;
Width : U_Short;
Height : U_Short;
Best_Width : out U_Short;
Best_Height : out U_Short;
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_Query_Best_Size_Request
(Display, (Kind => Query_Best_Size,
Length => X_Query_Best_Size_Request'Size / 32,
Class => Class,
Drawable => Drawable,
Width => Width,
Height => Height));
----Read the reply.
Get_Reply (Display => Display,
Code => Query_Best_Size,
Reply => Rep,
Extra => 0,
Discard => True,
Status => Succ);
----If we failed then return that.
if Succ = Failed then
Best_Width := 0;
Best_Height := 0;
Status := Failed;
Unlock_Display (Display);
Sync_Handle (Display);
return;
end if;
----Return our results.
Best_Width := Rep.Query_Best_Size.Width;
Best_Height := Rep.Query_Best_Size.Height;
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; and return.
Status := Successful;
Unlock_Display (Display);
Sync_Handle (Display);
end X_Query_Best_Size;
--\f
procedure X_Query_Best_Stipple (Display : X_Display;
Drawable : X_Drawable;
Width : U_Short;
Height : U_Short;
Best_Width : out U_Short;
Best_Height : out U_Short;
Status : out X_Status) is
begin
X_Query_Best_Size (Display, Stipple_Shape, Drawable, Width,
Height, Best_Width, Best_Height, Status);
end X_Query_Best_Stipple;
--\f
procedure X_Query_Best_Tile (Display : X_Display;
Drawable : X_Drawable;
Width : U_Short;
Height : U_Short;
Best_Width : out U_Short;
Best_Height : out U_Short;
Status : out X_Status) is
begin
X_Query_Best_Size (Display, Tile_Shape, Drawable, Width,
Height, Best_Width, Best_Height, Status);
end X_Query_Best_Tile;
--\f
procedure X_Set_Arc_Mode (Display : X_Display;
Gc : X_Gc;
Arc_Mode : X_Arc_Mode) is
begin
Lock_Display (Display);
if Gc.Values.Arc_Mode /= Arc_Mode then
Gc.Values.Arc_Mode := Arc_Mode;
Gc.Dirty (Gc_Arc_Mode) := True;
end if;
Unlock_Display (Display);
Sync_Handle (Display);
end X_Set_Arc_Mode;
--\f
procedure X_Set_Background (Display : X_Display;
Gc : X_Gc;
Background : X_Pixel) is
begin
Lock_Display (Display);
if Gc.Values.Background /= Background then
Gc.Values.Background := Background;
Gc.Dirty (Gc_Background) := True;
end if;
Unlock_Display (Display);
Sync_Handle (Display);
end X_Set_Background;
--\f
procedure X_Set_Clip_Mask (Display : X_Display;
Gc : X_Gc;
Mask : X_Pixmap) is
begin
Lock_Display (Display);
----Always update the Mask in the GC, even if it is the same mask as
-- last time we did this; since the server *may* copy the pixmap
-- and since the application *may* have changed the pixmap since the
-- last time, we have no way of detecting whether this 'change' is
-- in fact a no-op or not; so just do it.
Gc.Values.Clip_Mask := Mask;
Gc.Dirty (Gc_Clip_Mask) := True;
Gc.Rects := False;
Private_X_Flush_Gc_Cache (Display, Gc);
Unlock_Display (Display);
Sync_Handle (Display);
end X_Set_Clip_Mask;
--\f
procedure X_Set_Clip_Origin (Display : X_Display;
Gc : X_Gc;
X : S_Short;
Y : S_Short) is
Gv : X_Gc_Values renames Gc.Values;
begin
Lock_Display (Display);
if X /= Gv.Clip_X_Origin then
Gv.Clip_X_Origin := X;
Gc.Dirty (Gc_Clip_X_Origin) := True;
end if;
if Y /= Gv.Clip_Y_Origin then
Gv.Clip_Y_Origin := Y;
Gc.Dirty (Gc_Clip_Y_Origin) := True;
end if;
Unlock_Display (Display);
Sync_Handle (Display);
end X_Set_Clip_Origin;
--\f
procedure X_Set_Clip_Rectangles (Display : X_Display;
Gc : X_Gc;
X : S_Short;
Y : S_Short;
Rectangles : X_Rectangle_Array;
Ordering : X_Clip_Ordering) is
begin
Lock_Display (Display);
begin
Put_X_Set_Clip_Rectangles_Request
(Display, (Kind => Set_Clip_Rectangles,
Length => X_Set_Clip_Rectangles_Request'Size / 32 +
Rectangles'Length *
X_Rectangle'Size / 32,
Gc => Gc.Gid,
X_Origin => X,
Y_Origin => Y,
Ordering => Ordering));
Gc.Values.Clip_X_Origin := X;
Gc.Values.Clip_Y_Origin := Y;
Gc.Rects := True;
Put_X_Rectangle_Array (Display, Rectangles);
Gc.Dirty := Gc.Dirty and
not X_Gc_Components'(Gc_Clip_Mask |
Gc_Clip_X_Origin |
Gc_Clip_Y_Origin => True,
others => False);
Unlock_Display (Display);
Sync_Handle (Display);
exception
when others =>
Unlock_Display (Display);
raise;
end;
end X_Set_Clip_Rectangles;
--\f
procedure X_Set_Dashes (Display : X_Display;
Gc : X_Gc;
Dash_Offset : U_Short;
Dash_List : U_Char_Array) is
begin
Lock_Display (Display);
begin
Put_X_Set_Dashes_Request
(Display,
(Kind => Set_Dashes,
Length =>
X_Set_Dashes_Request'Size / 32 + (Dash_List'Length + 3) / 4,
Pad => 0,
Gc => Gc.Gid,
Dash_Offset => Dash_Offset,
N_Dashes => Dash_List'Length),
Dash_List'Length);
Gc.Values.Dash_Offset := Dash_Offset;
Gc.Dashes := True;
Gc.Dirty := Gc.Dirty and not X_Gc_Components'
(Gc_Dash_List | Gc_Dash_Offset => True,
others => False);
Put_U_Char_Array (Display, Dash_List);
Unlock_Display (Display);
Sync_Handle (Display);
exception
when others =>
Unlock_Display (Display);
raise;
end;
end X_Set_Dashes;
--\f
procedure X_Set_Fill_Rule (Display : X_Display;
Gc : X_Gc;
Fill_Rule : X_Fill_Rule) is
begin
Lock_Display (Display);
if Gc.Values.Fill_Rule /= Fill_Rule then
Gc.Values.Fill_Rule := Fill_Rule;
Gc.Dirty (Gc_Fill_Rule) := True;
end if;
Unlock_Display (Display);
Sync_Handle (Display);
end X_Set_Fill_Rule;
--\f
procedure X_Set_Fill_Style (Display : X_Display;
Gc : X_Gc;
Fill_Style : X_Fill_Style) is
begin
Lock_Display (Display);
if Gc.Values.Fill_Style /= Fill_Style then
Gc.Values.Fill_Style := Fill_Style;
Gc.Dirty (Gc_Fill_Style) := True;
end if;
Unlock_Display (Display);
Sync_Handle (Display);
end X_Set_Fill_Style;
--\f
procedure X_Set_Font (Display : X_Display;
Gc : X_Gc;
Font : X_Font) is
begin
Lock_Display (Display);
if Gc.Values.Font /= Font then
Gc.Values.Font := Font;
Gc.Dirty (Gc_Font) := True;
Private_X_Flush_Gc_Cache (Display, Gc);
end if;
Unlock_Display (Display);
Sync_Handle (Display);
end X_Set_Font;
--\f
procedure X_Set_Foreground (Display : X_Display;
Gc : X_Gc;
Foreground : X_Pixel) is
begin
Lock_Display (Display);
if Gc.Values.Foreground /= Foreground then
Gc.Values.Foreground := Foreground;
Gc.Dirty (Gc_Foreground) := True;
end if;
Unlock_Display (Display);
Sync_Handle (Display);
end X_Set_Foreground;
--\f
procedure X_Set_Function (Display : X_Display;
Gc : X_Gc;
Funct : X_Graphic_Function) is
begin
Lock_Display (Display);
if Gc.Values.Funct /= Funct then
Gc.Values.Funct := Funct;
Gc.Dirty (Gc_Function) := True;
end if;
Unlock_Display (Display);
Sync_Handle (Display);
end X_Set_Function;
--\f
procedure X_Set_Graphics_Exposures
(Display : X_Display;
Gc : X_Gc;
Graphics_Exposures : Boolean) is
begin
Lock_Display (Display);
if Gc.Values.Graphics_Exposures /= Graphics_Exposures then
Gc.Values.Graphics_Exposures := Graphics_Exposures;
Gc.Dirty (Gc_Graphics_Exposures) := True;
end if;
Unlock_Display (Display);
Sync_Handle (Display);
end X_Set_Graphics_Exposures;
--\f
procedure X_Set_Line_Attributes (Display : X_Display;
Gc : X_Gc;
Line_Width : U_Short;
Line_Style : X_Line_Style;
Cap_Style : X_Cap_Style;
Join_Style : X_Join_Style) is
Gv : X_Gc_Values renames Gc.Values;
begin
Lock_Display (Display);
if Line_Width /= Gv.Line_Width then
Gv.Line_Width := Line_Width;
Gc.Dirty (Gc_Line_Width) := True;
end if;
if Line_Style /= Gv.Line_Style then
Gv.Line_Style := Line_Style;
Gc.Dirty (Gc_Line_Style) := True;
end if;
if Cap_Style /= Gv.Cap_Style then
Gv.Cap_Style := Cap_Style;
Gc.Dirty (Gc_Cap_Style) := True;
end if;
if Join_Style /= Gv.Join_Style then
Gv.Join_Style := Join_Style;
Gc.Dirty (Gc_Join_Style) := True;
end if;
Unlock_Display (Display);
Sync_Handle (Display);
end X_Set_Line_Attributes;
--\f
procedure X_Set_Plane_Mask (Display : X_Display;
Gc : X_Gc;
Plane_Mask : X_Plane_Mask) is
begin
Lock_Display (Display);
if Gc.Values.Plane_Mask /= Plane_Mask then
Gc.Values.Plane_Mask := Plane_Mask;
Gc.Dirty (Gc_Plane_Mask) := True;
end if;
Unlock_Display (Display);
Sync_Handle (Display);
end X_Set_Plane_Mask;
--\f
procedure X_Set_State (Display : X_Display;
Gc : X_Gc;
Foreground : X_Pixel;
Background : X_Pixel;
Funct : X_Graphic_Function;
Plane_Mask : X_Plane_Mask) is
Gv : X_Gc_Values renames Gc.Values;
begin
Lock_Display (Display);
if Funct /= Gv.Funct then
Gv.Funct := Funct;
Gc.Dirty (Gc_Function) := True;
end if;
if Plane_Mask /= Gv.Plane_Mask then
Gv.Plane_Mask := Plane_Mask;
Gc.Dirty (Gc_Plane_Mask) := True;
end if;
if Foreground /= Gv.Foreground then
Gv.Foreground := Foreground;
Gc.Dirty (Gc_Foreground) := True;
end if;
if Background /= Gv.Background then
Gv.Background := Background;
Gc.Dirty (Gc_Background) := True;
end if;
Unlock_Display (Display);
Sync_Handle (Display);
end X_Set_State;
--\f
procedure X_Set_Stipple (Display : X_Display;
Gc : X_Gc;
Stipple : X_Pixmap) is
begin
Lock_Display (Display);
begin
----Always update the Stipple in the GC, even if it is the same stipple
-- as last time we did this; since the server *may* copy the pixmap
-- and since the application *may* have changed the pixmap since the
-- last time, we have no way of detecting whether this 'change' is
-- in fact a no-op or not; so just do it.
Gc.Values.Stipple := Stipple;
Gc.Dirty (Gc_Stipple) := True;
Private_X_Flush_Gc_Cache (Display, Gc);
Unlock_Display (Display);
Sync_Handle (Display);
exception
when others =>
Unlock_Display (Display);
raise;
end;
end X_Set_Stipple;
--\f
procedure X_Set_Subwindow_Mode (Display : X_Display;
Gc : X_Gc;
Subwindow_Mode : X_Subwindow_Mode) is
begin
Lock_Display (Display);
if Gc.Values.Subwindow_Mode /= Subwindow_Mode then
Gc.Values.Subwindow_Mode := Subwindow_Mode;
Gc.Dirty (Gc_Subwindow_Mode) := True;
end if;
Unlock_Display (Display);
Sync_Handle (Display);
end X_Set_Subwindow_Mode;
--\f
procedure X_Set_Tile (Display : X_Display;
Gc : X_Gc;
Tile : X_Pixmap) is
begin
Lock_Display (Display);
----Always update the Tile in the GC, even if it is the same tile as
-- last time we did this; since the server *may* copy the pixmap
-- and since the application *may* have changed the pixmap since the
-- last time, we have no way of detecting whether this 'change' is
-- in fact a no-op or not; so just do it.
Gc.Values.Tile := Tile;
Gc.Dirty (Gc_Tile) := True;
Private_X_Flush_Gc_Cache (Display, Gc);
Unlock_Display (Display);
Sync_Handle (Display);
end X_Set_Tile;
--\f
procedure X_Set_Ts_Origin (Display : X_Display;
Gc : X_Gc;
X : S_Short;
Y : S_Short) is
Gv : X_Gc_Values renames Gc.Values;
begin
Lock_Display (Display);
if X /= Gv.Ts_X_Origin then
Gv.Ts_X_Origin := X;
Gc.Dirty (Gc_Tile_Stip_X_Origin) := True;
end if;
if Y /= Gv.Ts_Y_Origin then
Gv.Ts_Y_Origin := Y;
Gc.Dirty (Gc_Tile_Stip_Y_Origin) := True;
end if;
Unlock_Display (Display);
Sync_Handle (Display);
end X_Set_Ts_Origin;
--\f
procedure Private_X_Flush_Gc (Display : X_Display;
Gc : X_Gc) is
----May only call this when the display is already locked.
A_Gc : X_Gc := Gc;
Ext : X_Extension;
Extra_Words : S_Natural := 0;
Dirty : X_Gc_Components := A_Gc.Dirty;
begin
----Do nothing if there is nothing to flush.
if Dirty = None_X_Gc_Components then
return;
end if;
A_Gc.Dirty := None_X_Gc_Components;
----Count the number of extra words that must go into the request
for I in Dirty'Range loop
if Dirty (I) then
Extra_Words := Extra_Words + 1;
end if;
end loop;
----We assume that our caller is taking care of locking and unlocking the
-- display.
Put_X_Change_Gc_Request
(Display, (Kind => Change_Gc,
Length => X_Change_Gc_Request'Size / 32
+ U_Short (Extra_Words),
Pad => 0,
Gc => A_Gc.Gid,
Change_Mask => Dirty),
Extra_Words * 4);
----Now put out all of the affected fields.
Process_X_Gc_Components (Display, Dirty, A_Gc.Values);
----Our change to the GC is done. Call out to any extensions that might be
-- interested in flushing GC extension data.
Ext := Display.Ext_Procs;
while Ext /= null loop
if Ext.Flush_Gc /= None_X_Procedure_Variable then
Proc_Var_X_Display_Gc_Extension.Call
(Proc_Var_X_Display_Gc_Extension.To_Pv (Ext.Flush_Gc),
Display, A_Gc, Ext.Codes);
end if;
Ext := Ext.Next;
end loop;
end Private_X_Flush_Gc;
--\f
end Xlbp_Gc;