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;