|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - downloadIndex: ┃ B T ┃
Length: 29270 (0x7256)
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_Display2;
use Xlbt_Display2;
with Xlbt_Error;
use Xlbt_Error;
with Xlbt_Extension;
use Xlbt_Extension;
with Xlbt_Extension2;
use Xlbt_Extension2;
with Xlbt_Event;
use Xlbt_Event;
with Xlbt_Font;
use Xlbt_Font;
with Xlbt_Misc;
use Xlbt_Misc;
with Xlbt_Proc_Var;
use Xlbt_Proc_Var;
with Xlbt_Reply;
use Xlbt_Reply;
with Xlbt_Request;
use Xlbt_Request;
with Xlbt_String;
use Xlbt_String;
with Xlbt_Visual;
use Xlbt_Visual;
with Xlbp_Proc_Var;
use Xlbp_Proc_Var;
with Xlbit_Library4;
use Xlbit_Library4;
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_Extension is
------------------------------------------------------------------------------
-- X Library Extensions
--
-- Xlbp_Extension - Used to establish and control extensions to the X Library
-- and to the X protocol.
------------------------------------------------------------------------------
-- 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_Query_Extension (Display : X_Display;
Name : X_String;
Major_Opcode : out X_Request_Code;
First_Event : out X_Event_Code;
First_Error : out X_Error_Code;
Present : out Boolean;
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_Extension_Request
(Display,
(Kind => Query_Extension,
Length =>
X_Query_Extension_Request'Size / 32 + (Name'Length + 3) / 4,
Pad => 0,
Pad1 => 0,
Pad2 => 0,
N_Bytes => Name'Length),
Name'Length);
Put_X_String (Display, Name);
----Read the reply.
Get_Reply (Display => Display,
Code => Query_Extension,
Reply => Rep,
Extra => 0,
Discard => True,
Status => Succ);
Status := Succ;
if Succ = Failed then
Major_Opcode := None_X_Request_Code;
First_Event := X_Event_Code'Val (0);
First_Error := X_Error_Code'Val (0);
Present := False;
Unlock_Display (Display);
Sync_Handle (Display);
return;
end if;
Major_Opcode := Rep.Query_Extension.Major_Opcode;
First_Event := Rep.Query_Extension.First_Event;
First_Error := Rep.Query_Extension.First_Error;
----Catch exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; return our result.
Present := To_Boolean (Rep.Query_Extension.Present);
Unlock_Display (Display);
Sync_Handle (Display);
end X_Query_Extension;
--\f
function X_List_Extensions (Display : X_Display)
return X_String_Pointer_List is
Rep : X_Reply_Contents;
Length : S_Natural;
Succ : X_Status;
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
Put_X_List_Extensions_Request
(Display, (Kind => List_Extensions,
Length => X_List_Extensions_Request'Size / 32,
Pad => 0));
----Read the reply.
Get_Reply (Display => Display,
Code => List_Extensions,
Reply => Rep,
Extra => 0,
Discard => False,
Status => Succ);
if Succ = Failed or else
Rep.List_Extensions.N_Extensions = 0 then
Unlock_Display (Display);
Sync_Handle (Display);
return None_X_String_Pointer_List;
----Read the extra data.
else
declare
Actual : S_Natural;
The_List : X_String_Pointer_List;
Ch : X_String
(1 .. S_Natural (Rep.List_Extensions.Length) * 4);
begin
begin
The_List := new X_String_Pointer_Array
(1 .. S_Natural (Rep.List_Extensions.
N_Extensions));
exception
when others =>
Eat_Raw_Data
(Display, S_Natural (Rep.List_Extensions.Length *
(32 / 8)));
raise;
end;
Get_X_String (Display, Ch);
----unpack into null terminated strings.
Length := Ch'First;
for I in The_List'Range loop
for J in Length .. Ch'Last loop
if Ch (J) = Nul then
Actual := J - Length;
----Chop strings if they are too long for this
-- Ada implementation.
The_List (I) := new X_String (1 .. Actual);
The_List (I).all :=
Ch (Length .. Length + Actual - 1);
Length := J + 1;
exit;
end if;
end loop;
end loop;
Unlock_Display (Display);
Sync_Handle (Display);
return The_List;
exception
when others =>
Free_X_String_Pointer_List (The_List);
raise;
end;
end if;
----Catch exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
end X_List_Extensions;
--\f
function X_Init_Extension (Display : X_Display;
Name : X_String) return X_Ext_Codes is
------------------------------------------------------------------------------
-- This routine is used to link a extension in so it will be called
-- at appropriate times.
------------------------------------------------------------------------------
The_Codes : X_Ext_Codes_Rec;
Extension : X_Extension;
Present : Boolean;
Succ : X_Status;
begin
----See if the extension exists.
X_Query_Extension (Display, Name, The_Codes.Major_Opcode,
The_Codes.First_Event,
The_Codes.First_Error, Present, Succ);
if Succ = Failed then
return None_X_Ext_Codes;
end if;
if not Present then
return None_X_Ext_Codes;
end if;
----Create the X_Ext_Codes for the extension.
Lock_Display (Display);
begin
Extension := new X_Extension_Rec;
The_Codes.Extension := Display.Ext_Number;
Extension.Codes := new X_Ext_Codes_Rec'(The_Codes);
Display.Ext_Number := "+" (Display.Ext_Number, 1);
-- chain it onto the disp list
Extension.Next := Display.Ext_Procs;
Display.Ext_Procs := Extension;
exception
when others =>
Unlock_Display (Display);
if Extension /= null then
if Extension.Codes /= null then
Free_X_Ext_Codes (Extension.Codes);
end if;
Free_X_Extension (Extension);
end if;
raise;
end;
Unlock_Display (Display);
return Extension.Codes; -- tell him which extension
end X_Init_Extension;
--\f
function X_Add_Extension (Display : X_Display) return X_Ext_Codes is
------------------------------------------------------------------------------
-- This routine is used to link a extension in so it will be called
-- at appropriate times.
------------------------------------------------------------------------------
Extension : X_Extension;
begin
Lock_Display (Display);
begin
Extension := new X_Extension_Rec;
Extension.Codes := new X_Ext_Codes_Rec;
Extension.Codes.Extension := Display.Ext_Number;
Display.Ext_Number := "+" (Display.Ext_Number, 1);
-- chain it onto the disp list
Extension.Next := Display.Ext_Procs;
Display.Ext_Procs := Extension;
exception
when others =>
Unlock_Display (Display);
if Extension /= null then
if Extension.Codes /= null then
Free_X_Ext_Codes (Extension.Codes);
end if;
Free_X_Extension (Extension);
end if;
raise;
end;
Unlock_Display (Display);
return Extension.Codes; -- tell him which extension
end X_Add_Extension;
--\f
function Lookup_Extension
(Display : X_Display;
Extension : X_Extension_Number) return X_Extension is
Ext : X_Extension := Display.Ext_Procs;
begin
while Ext /= null loop
if Ext.Codes.Extension = Extension then
return Ext;
end if;
Ext := Ext.Next;
end loop;
return null;
end Lookup_Extension;
--\f
function X_E_Set_Close_Display
(Display : X_Display;
Extension : X_Extension_Number;
Proc : Proc_Var_X_Close_Display_Extension.Pv)
return Proc_Var_X_Close_Display_Extension.Pv is
-- routine to call when disp closed
E : X_Extension; -- for lookup of extension
Old_Proc : X_Procedure_Variable;
begin
E := Lookup_Extension (Display, Extension);
if E = null then
return Proc_Var_X_Close_Display_Extension.None;
end if;
Lock_Display (Display);
Old_Proc := E.Close_Display;
E.Close_Display := Proc_Var_X_Close_Display_Extension.From_Pv (Proc);
Unlock_Display (Display);
return Proc_Var_X_Close_Display_Extension.To_Pv (Old_Proc);
end X_E_Set_Close_Display;
--\f
function X_E_Set_Create_Font (Display : X_Display;
Extension : X_Extension_Number;
Proc : Proc_Var_X_Display_Font_Extension.Pv)
return Proc_Var_X_Display_Font_Extension.Pv is
-- routine to call when font created
E : X_Extension; -- for lookup of extension
Old_Proc : X_Procedure_Variable;
begin
E := Lookup_Extension (Display, Extension);
if E = null then
return Proc_Var_X_Display_Font_Extension.None;
end if;
Lock_Display (Display);
Old_Proc := E.Create_Font;
E.Create_Font := Proc_Var_X_Display_Font_Extension.From_Pv (Proc);
Unlock_Display (Display);
return Proc_Var_X_Display_Font_Extension.To_Pv (Old_Proc);
end X_E_Set_Create_Font;
--\f
function X_E_Set_Free_Font (Display : X_Display;
Extension : X_Extension_Number;
Proc : Proc_Var_X_Display_Font_Extension.Pv)
return Proc_Var_X_Display_Font_Extension.Pv is
-- routine to call when font freed
E : X_Extension; -- for lookup of extension
Old_Proc : X_Procedure_Variable;
begin
E := Lookup_Extension (Display, Extension);
if E = null then
return Proc_Var_X_Display_Font_Extension.None;
end if;
Lock_Display (Display);
Old_Proc := E.Free_Font;
E.Free_Font := Proc_Var_X_Display_Font_Extension.From_Pv (Proc);
Unlock_Display (Display);
return Proc_Var_X_Display_Font_Extension.To_Pv (Old_Proc);
end X_E_Set_Free_Font;
--\f
function X_E_Set_Copy_Gc (Display : X_Display;
Extension : X_Extension_Number;
Proc : Proc_Var_X_Display_Gc_Extension.Pv)
return Proc_Var_X_Display_Gc_Extension.Pv is
-- routine to call when GC copied
E : X_Extension; -- for lookup of extension
Old_Proc : X_Procedure_Variable;
begin
E := Lookup_Extension (Display, Extension);
if E = null then
return Proc_Var_X_Display_Gc_Extension.None;
end if;
Lock_Display (Display);
Old_Proc := E.Copy_Gc;
E.Copy_Gc := Proc_Var_X_Display_Gc_Extension.From_Pv (Proc);
Unlock_Display (Display);
return Proc_Var_X_Display_Gc_Extension.To_Pv (Old_Proc);
end X_E_Set_Copy_Gc;
--\f
function X_E_Set_Create_Gc (Display : X_Display;
Extension : X_Extension_Number;
Proc : Proc_Var_X_Display_Gc_Extension.Pv)
return Proc_Var_X_Display_Gc_Extension.Pv is
-- routine to call when GC created
E : X_Extension; -- for lookup of extension
Old_Proc : X_Procedure_Variable;
begin
E := Lookup_Extension (Display, Extension);
if E = null then
return Proc_Var_X_Display_Gc_Extension.None;
end if;
Lock_Display (Display);
Old_Proc := E.Create_Gc;
E.Create_Gc := Proc_Var_X_Display_Gc_Extension.From_Pv (Proc);
Unlock_Display (Display);
return Proc_Var_X_Display_Gc_Extension.To_Pv (Old_Proc);
end X_E_Set_Create_Gc;
--\f
function X_E_Set_Flush_Gc (Display : X_Display;
Extension : X_Extension_Number;
Proc : Proc_Var_X_Display_Gc_Extension.Pv)
return Proc_Var_X_Display_Gc_Extension.Pv is
-- routine to call when GC copied
E : X_Extension; -- for lookup of extension
Old_Proc : X_Procedure_Variable;
begin
E := Lookup_Extension (Display, Extension);
if E = null then
return Proc_Var_X_Display_Gc_Extension.None;
end if;
Lock_Display (Display);
Old_Proc := E.Flush_Gc;
E.Flush_Gc := Proc_Var_X_Display_Gc_Extension.From_Pv (Proc);
Unlock_Display (Display);
return Proc_Var_X_Display_Gc_Extension.To_Pv (Old_Proc);
end X_E_Set_Flush_Gc;
--\f
function X_E_Set_Free_Gc (Display : X_Display;
Extension : X_Extension_Number;
Proc : Proc_Var_X_Display_Gc_Extension.Pv)
return Proc_Var_X_Display_Gc_Extension.Pv is
-- routine to call when GC freed
E : X_Extension; -- for lookup of extension
Old_Proc : X_Procedure_Variable;
begin
E := Lookup_Extension (Display, Extension);
if E = null then
return Proc_Var_X_Display_Gc_Extension.None;
end if;
Lock_Display (Display);
Old_Proc := E.Free_Gc;
E.Free_Gc := Proc_Var_X_Display_Gc_Extension.From_Pv (Proc);
Unlock_Display (Display);
return Proc_Var_X_Display_Gc_Extension.To_Pv (Old_Proc);
end X_E_Set_Free_Gc;
--\f
function X_E_Set_Wire_To_Event (Display : X_Display;
Event : X_Event_Code;
Proc : Proc_Var_X_Wire_Event.Pv)
return Proc_Var_X_Wire_Event.Pv is
-- Event routine to replace
use Proc_Var_X_Wire_Event;
Old_Proc : X_Procedure_Variable;
begin
Lock_Display (Display);
begin
Old_Proc := Display.Event_Vec (Event);
if Proc = Proc_Var_X_Wire_Event.None then
Display.Event_Vec (Event) := X_Lib_Default_X_Unknown_Wire_Event;
else
Display.Event_Vec (Event) :=
Proc_Var_X_Wire_Event.From_Pv (Proc);
end if;
exception
when others =>
Unlock_Display (Display);
raise;
end;
Unlock_Display (Display);
return Proc_Var_X_Wire_Event.To_Pv (Old_Proc);
end X_E_Set_Wire_To_Event;
--\f
function X_E_Set_Event_To_Wire (Display : X_Display;
Event : X_Event_Code;
Proc : Proc_Var_X_Event_Wire.Pv)
return Proc_Var_X_Event_Wire.Pv is
-- Event routine to replace
use Proc_Var_X_Event_Wire;
Old_Proc : X_Procedure_Variable;
begin
Lock_Display (Display);
begin
Old_Proc := Display.Wire_Vec (Event);
if Proc = Proc_Var_X_Event_Wire.None then
Display.Wire_Vec (Event) :=
X_Lib_Default_X_Unknown_Native_Event;
else
Display.Wire_Vec (Event) :=
Proc_Var_X_Event_Wire.From_Pv (Proc);
end if;
exception
when others =>
Unlock_Display (Display);
raise;
end;
Unlock_Display (Display);
return Proc_Var_X_Event_Wire.To_Pv (Old_Proc);
end X_E_Set_Event_To_Wire;
--\f
function X_E_Set_Error (Display : X_Display;
Extension : X_Extension_Number;
Proc : Proc_Var_X_Error_Extension.Pv)
return Proc_Var_X_Error_Extension.Pv is
-- routine to call when X error happens
E : X_Extension; -- for lookup of extension
Old_Proc : X_Procedure_Variable;
begin
E := Lookup_Extension (Display, Extension);
if E = null then
return Proc_Var_X_Error_Extension.None;
end if;
Lock_Display (Display);
Old_Proc := E.Error;
E.Error := Proc_Var_X_Error_Extension.From_Pv (Proc);
Unlock_Display (Display);
return Proc_Var_X_Error_Extension.To_Pv (Old_Proc);
end X_E_Set_Error;
--\f
function X_E_Set_Error_String
(Display : X_Display;
Extension : X_Extension_Number;
Proc : Proc_Var_X_Error_String_Extension.Pv)
return Proc_Var_X_Error_String_Extension.Pv is
-- routine to call when I/O error happens
E : X_Extension; -- for lookup of extension
Old_Proc : X_Procedure_Variable;
begin
E := Lookup_Extension (Display, Extension);
if E = null then
return Proc_Var_X_Error_String_Extension.None;
end if;
Lock_Display (Display);
Old_Proc := E.Error_String;
E.Error_String := Proc_Var_X_Error_String_Extension.From_Pv (Proc);
Unlock_Display (Display);
return Proc_Var_X_Error_String_Extension.To_Pv (Old_Proc);
end X_E_Set_Error_String;
--\f
procedure X_Add_To_Extension_List (Structure : X_Display;
Ext_Data : X_Ext_Data) is
P : X_Ext_Data := Structure.Ext_Data;
begin
while P /= null loop
if P.Number = Ext_Data.Number then
P.Private_Data := Ext_Data.Private_Data;
P.Free_Private := Ext_Data.Free_Private;
return;
end if;
P := P.Next;
end loop;
P := new X_Ext_Data_Rec'((Ext_Data.Number, Ext_Data.Free_Private,
Ext_Data.Private_Data, Structure.Ext_Data));
Structure.Ext_Data := P;
end X_Add_To_Extension_List;
--\f
procedure X_Add_To_Extension_List (Structure : X_Font_Struct;
Ext_Data : X_Ext_Data) is
P : X_Ext_Data := Structure.Ext_Data;
begin
while P /= null loop
if P.Number = Ext_Data.Number then
P.Free_Private := Ext_Data.Free_Private;
P.Private_Data := Ext_Data.Private_Data;
return;
end if;
P := P.Next;
end loop;
P := new X_Ext_Data_Rec'((Ext_Data.Number, Ext_Data.Free_Private,
Ext_Data.Private_Data, Structure.Ext_Data));
Structure.Ext_Data := P;
end X_Add_To_Extension_List;
--\f
procedure X_Add_To_Extension_List (Structure : X_Gc;
Ext_Data : X_Ext_Data) is
P : X_Ext_Data := Structure.Ext_Data;
begin
while P /= null loop
if P.Number = Ext_Data.Number then
P.Private_Data := Ext_Data.Private_Data;
P.Free_Private := Ext_Data.Free_Private;
return;
end if;
P := P.Next;
end loop;
P := new X_Ext_Data_Rec'((Ext_Data.Number, Ext_Data.Free_Private,
Ext_Data.Private_Data, Structure.Ext_Data));
Structure.Ext_Data := P;
end X_Add_To_Extension_List;
--\f
procedure X_Add_To_Extension_List (Structure : X_Screen;
Ext_Data : X_Ext_Data) is
P : X_Ext_Data := Structure.Ext_Data;
begin
while P /= null loop
if P.Number = Ext_Data.Number then
P.Private_Data := Ext_Data.Private_Data;
P.Free_Private := Ext_Data.Free_Private;
return;
end if;
P := P.Next;
end loop;
P := new X_Ext_Data_Rec'((Ext_Data.Number, Ext_Data.Free_Private,
Ext_Data.Private_Data, Structure.Ext_Data));
Structure.Ext_Data := P;
end X_Add_To_Extension_List;
--\f
procedure X_Add_To_Extension_List (Structure : X_Screen_Format;
Ext_Data : X_Ext_Data) is
P : X_Ext_Data := Structure.Ext_Data;
begin
while P /= null loop
if P.Number = Ext_Data.Number then
P.Private_Data := Ext_Data.Private_Data;
P.Free_Private := Ext_Data.Free_Private;
return;
end if;
P := P.Next;
end loop;
P := new X_Ext_Data_Rec'((Ext_Data.Number, Ext_Data.Free_Private,
Ext_Data.Private_Data, Structure.Ext_Data));
Structure.Ext_Data := P;
end X_Add_To_Extension_List;
--\f
procedure X_Add_To_Extension_List (Structure : X_Visual;
Ext_Data : X_Ext_Data) is
P : X_Ext_Data := Structure.Ext_Data;
begin
while P /= null loop
if P.Number = Ext_Data.Number then
P.Private_Data := Ext_Data.Private_Data;
P.Free_Private := Ext_Data.Free_Private;
return;
end if;
P := P.Next;
end loop;
P := new X_Ext_Data_Rec'((Ext_Data.Number, Ext_Data.Free_Private,
Ext_Data.Private_Data, Structure.Ext_Data));
Structure.Ext_Data := P;
end X_Add_To_Extension_List;
--\f
function X_Find_On_Extension_List
(Structure : X_Display;
Extension : X_Extension_Number) return X_Ext_Data is
P : X_Ext_Data := Structure.Ext_Data;
begin
while P /= null loop
if P.Number = Extension then
return P;
end if;
P := P.Next;
end loop;
return None_X_Ext_Data;
end X_Find_On_Extension_List;
--\f
function X_Find_On_Extension_List
(Structure : X_Font_Struct;
Extension : X_Extension_Number) return X_Ext_Data is
P : X_Ext_Data := Structure.Ext_Data;
begin
while P /= null loop
if P.Number = Extension then
return P;
end if;
P := P.Next;
end loop;
return None_X_Ext_Data;
end X_Find_On_Extension_List;
--\f
function X_Find_On_Extension_List
(Structure : X_Gc;
Extension : X_Extension_Number) return X_Ext_Data is
P : X_Ext_Data := Structure.Ext_Data;
begin
while P /= null loop
if P.Number = Extension then
return P;
end if;
P := P.Next;
end loop;
return None_X_Ext_Data;
end X_Find_On_Extension_List;
--\f
function X_Find_On_Extension_List
(Structure : X_Screen;
Extension : X_Extension_Number) return X_Ext_Data is
P : X_Ext_Data := Structure.Ext_Data;
begin
while P /= null loop
if P.Number = Extension then
return P;
end if;
P := P.Next;
end loop;
return None_X_Ext_Data;
end X_Find_On_Extension_List;
--\f
function X_Find_On_Extension_List
(Structure : X_Screen_Format;
Extension : X_Extension_Number) return X_Ext_Data is
P : X_Ext_Data := Structure.Ext_Data;
begin
while P /= null loop
if P.Number = Extension then
return P;
end if;
P := P.Next;
end loop;
return None_X_Ext_Data;
end X_Find_On_Extension_List;
--\f
function X_Find_On_Extension_List
(Structure : X_Visual;
Extension : X_Extension_Number) return X_Ext_Data is
P : X_Ext_Data := Structure.Ext_Data;
begin
while P /= null loop
if P.Number = Extension then
return P;
end if;
P := P.Next;
end loop;
return None_X_Ext_Data;
end X_Find_On_Extension_List;
--\f
function X_Alloc_Id (Display : X_Display) return X_Id is
------------------------------------------------------------------------------
-- Request and allocate an X_Id for a new resource on a given display.
-- #define X_Alloc_ID(Display) ((*(Display)->resource_alloc)((Display)))
------------------------------------------------------------------------------
begin
return Proc_Var_X_Alloc_Id.Call
(Proc_Var_X_Alloc_Id.To_Pv (Display.Resource_Alloc),
Display);
end X_Alloc_Id;
--\f
end Xlbp_Extension;