DataMuseum.dk

Presents historical artifacts from the history of:

Rational R1000/400 Tapes

This is an automatic "excavation" of a thematic subset of
artifacts from Datamuseum.dk's BitArchive.

See our Wiki for more about Rational R1000/400 Tapes

Excavated with: AutoArchaeologist - Free & Open Source Software.


top - download
Index: ┃ B T

⟦76e11e284⟧ TextFile

    Length: 21278 (0x531e)
    Types: TextFile
    Names: »B«

Derivation

└─⟦85b835f43⟧ Bits:30000549 8mm tape, Rational 1000, Xlib rev 6.00
    └─ ⟦0c20f784e⟧ »DATA« 
        └─⟦1abbe589f⟧ 
            └─⟦059497ac5⟧ 
                └─⟦this⟧ 

TextFile

with Unchecked_Deallocation;

with Xlbt_Arithmetic;  
use Xlbt_Arithmetic;  
with Xlbt_Basic;  
use Xlbt_Basic;  
with Xlbt_Context_Manager2;  
use Xlbt_Context_Manager2;  
with Xlbt_Display2;  
use Xlbt_Display2;  
with Xlbt_Event;  
use Xlbt_Event;  
with Xlbt_Event3;  
with Xlbt_Exceptions;  
use Xlbt_Exceptions;  
with Xlbt_Extension;  
use Xlbt_Extension;  
with Xlbt_Graphics;  
use Xlbt_Graphics;  
with Xlbt_Key;  
use Xlbt_Key;  
with Xlbt_Key2;  
use Xlbt_Key2;  
with Xlbt_Proc_Var;  
use Xlbt_Proc_Var;  
with Xlbt_Request3;  
use Xlbt_Request3;  
with Xlbt_Rm;  
use Xlbt_Rm;  
with Xlbt_String;  
use Xlbt_String;  
with Xlbt_Univ_Ptr;  
use Xlbt_Univ_Ptr;  
with Xlbt_Visual;  
use Xlbt_Visual;

with Xlbp_Display;  
use Xlbp_Display;  
with Xlbp_Error;  
use Xlbp_Error;  
with Xlbp_Proc_Var;  
use Xlbp_Proc_Var;  
with Xlbp_Rm;  
use Xlbp_Rm;  
with Xlbp_Window_Information;  
use Xlbp_Window_Information;

with Xlbit_Library3;  
use Xlbit_Library3;

with Xlbip_Put_Request;  
use Xlbip_Put_Request;

with Xlbmt_Network_Types;  
use Xlbmt_Network_Types;

with Xlbmp_Error_Log;  
use Xlbmp_Error_Log;

package body Xlbip_Internal is
------------------------------------------------------------------------------
-- X Library Machine Independent Internal Routines
--
-- Xlbip_Internal - Internal-to-X-Library routines - not for general users
------------------------------------------------------------------------------
-- 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 Heap_Free_X_Display is  
       new Unchecked_Deallocation (X_Display_Rec,  
                                   X_Display);

--\f

------------------------------------------------------------------------------
-- Non-functional mutual exclusion functions.
------------------------------------------------------------------------------

    procedure Lock_Display (Display : X_Display) is  
    begin

--/ if not Multitask_Locking then
--//        if Display.Lock.flop = 0 then
--//            Display.Lock.Flop := 1;
--//        else
--//            raise X_Library_Confusion;
--//        end if;
--/ else
        Display.Lock.Lock;
--/ end if;

    end Lock_Display;

--\f

    procedure Unlock_Display (Display : X_Display) is  
    begin

--/ if not Multitask_Locking then
--//        if Display.Lock.Flop = 1 then
--//            Display.Lock.Flop := 0;
--//        else
--//            raise X_Library_Confusion;
--//        end if;
--/ else
        Display.Lock.Unlock;
--/ end if;

    end Unlock_Display;

--\f

    function Internal_X_Alloc_Id (Display : X_Display) return X_Id is
------------------------------------------------------------------------------
-- Default X_Alloc_Id implementation.  A user can roll his own and
-- instantiate it if he wants, but he must follow the rules.
------------------------------------------------------------------------------
        New_Id : X_Id;  
    begin

----See if we have any more ID's available.

        if Display.Resource_Mask.Number < Display.Resource_Id.Number then  
            raise Constraint_Error;     -- No, we don't.
        end if;

----This is the new ID.

        New_Id.Number := Display.Resource_Base.Number +  
                            Display.Resource_Id.Number;

----This is the next new ID; we don't check for overflow until the next ID
--  is required.

        Display.Resource_Id.Number :=  
           Display.Resource_Id.Number + Display.Resource_Incr;  
        return New_Id;

    end Internal_X_Alloc_Id;

--\f

    function Internal_X_Screen_Of_Window (Display : X_Display;  
                                          Window  : X_Window) return X_Screen is
------------------------------------------------------------------------------
--  Called to attempt to figure out what screen a window is drawn upon.
------------------------------------------------------------------------------
        Root   : X_Window;  
        X      : S_Short;  
        Y      : S_Short;  
        Width  : U_Short;  
        Height : U_Short;  
        Bw     : U_Short;  
        Depth  : U_Char;  
        Status : X_Status;  
    begin

        X_Get_Geometry (Display, Window.Drawable, Root, X, Y,  
                        Width, Height, Bw, Depth, Status);  
        if Status = Failed then  
            return None_X_Screen;  
        end if;  
        for I in Display.Screens'Range loop         -- find root from list
            if Root = X_Root_Window (Display, I) then  
                return X_Screen_Of_Display (Display, I);  
            end if;  
        end loop;  
        return None_X_Screen;

    end Internal_X_Screen_Of_Window;

--\f

    procedure Internal_X_Flush_Last_Request (Display : X_Display) is
------------------------------------------------------------------------------
-- Called to flush out the Display.Last_Request.  Some requests, e.g. Poly_Arc, are
-- cumulative; successive Poly_Arc requests will merge together in the display
-- buffer before being sent to the server for action.  This routine is called
-- to force any of the mergeable requests to be transmitted.
------------------------------------------------------------------------------
    begin

        case Display.Last_Request.Kind is

            when Invalid_Request =>  
                return;     -- Nothing needs to be done.

            when Fill_Poly =>  
                Put_X_Fill_Poly_Request  
                   (Display     => Display,  
                    Req         => Display.Last_Request.Fill_Poly_Req,  
                    Reservation => Display.Last_Request.Request_Position);

            when Poly_Fill_Arc =>  
                Put_X_Poly_Fill_Arc_Request  
                   (Display     => Display,  
                    Req         => Display.Last_Request.Poly_Fill_Arc_Req,  
                    Reservation => Display.Last_Request.Request_Position);

            when Poly_Line =>  
                Put_X_Poly_Line_Request  
                   (Display     => Display,  
                    Req         => Display.Last_Request.Poly_Line_Req,  
                    Reservation => Display.Last_Request.Request_Position);

            when Poly_Point =>  
                Put_X_Poly_Point_Request
                   (Display     => Display,  
                    Req         => Display.Last_Request.Poly_Point_Req,  
                    Reservation => Display.Last_Request.Request_Position);

            when Poly_Rectangle =>  
                Put_X_Poly_Rectangle_Request
                   (Display     => Display,  
                    Req         => Display.Last_Request.Poly_Rectangle_Req,  
                    Reservation => Display.Last_Request.Request_Position);

            when Poly_Fill_Rectangle =>  
                Put_X_Poly_Fill_Rectangle_Request
                   (Display     => Display,  
                    Req         => Display.Last_Request.Poly_Fill_Rectangle_Req,  
                    Reservation => Display.Last_Request.Request_Position);

            when Poly_Segment =>  
                Put_X_Poly_Segment_Request
                   (Display     => Display,  
                    Req         => Display.Last_Request.Poly_Segment_Req,  
                    Reservation => Display.Last_Request.Request_Position);

            when Xr128 .. Xr255 =>  
                declare  
                    use Proc_Var_X_Flush_Extension_Graphics;  
                begin  
                    if Display.Last_Request.Ext_Flush =  
                       None_X_Procedure_Variable then  
                        raise X_Library_Confusion;  -- The extension forgot.
                    end if;  
                    Call (To_Pv (Display.Last_Request.Ext_Flush), Display);  
                end;

            when others =>  
                raise X_Library_Confusion;
                ----There is a new type being cached in the X_Last_Request type and
                --  nobody told us.  How to they expect it to get to the server?
                --  This routine must be modified every time X_Last_Request is changed.

        end case;  
        Display.Last_Request.Kind := Invalid_Request;

    end Internal_X_Flush_Last_Request;

--\f

    procedure Internal_X_Free_Display_Structure (Display : in out X_Display) is
------------------------------------------------------------------------------
-- X_Free_Display_Structure frees all the storage associated with a
-- Display.  It is used by X_Open_Display if it runs out of memory,
-- and also by X_Close_Display.   It needs to check whether all pointers
-- are non-NULL before dereferencing them, since it may be called
-- by X_Open_Display before the Display structure is fully formed.
-- X_Open_Display must be sure to initialize all the pointers to NULL
-- before the first possible call on this.
------------------------------------------------------------------------------
        Sp : X_Screen;  
    begin

        if Display = None_X_Display then  
            return;  
        end if;

        if Display.Display_Name /= null then  
            Free_X_String_Pointer (Display.Display_Name);  
        end if;

        if Display.Vendor /= null then  
            Free_X_String_Pointer (Display.Vendor);  
        end if;

        if Display.Screens /= null then  
            for I in Display.Screens'Range loop  
                Sp := Display.Screens (I);  
                if Sp.Depths /= null then  
                    for J in Display.Screens (I).Depths'Range loop  
                        declare  
                            Dp : X_Depth_Rec renames Sp.Depths (J);  
                        begin  
                            if Dp.Visuals /= null then  
                                for K in Dp.Visuals'Range loop  
                                    declare  
                                        Vp : X_Visual renames Dp.Visuals (K);  
                                    begin  
                                        Free_X_Ext_Data_List (Vp.Ext_Data);  
                                    end;  
                                end loop;  
                                Free_X_Visual_List (Dp.Visuals);  
                            end if;  
                        end;  
                    end loop;  
                    Free_X_Depth_List (Sp.Depths);  
                end if;  
                Free_X_Ext_Data_List (Sp.Ext_Data);  
                Free_X_Screen (Sp);  
            end loop;  
            Free_X_Screen_List (Display.Screens);  
        end if;

        if Display.Pixmap_Format /= null then  
            for I in Display.Pixmap_Format'Range loop  
                Free_X_Ext_Data_List (Display.Pixmap_Format (I).Ext_Data);  
                Free_X_Screen_Format (Display.Pixmap_Format (I));  
            end loop;  
            Free_X_Screen_Format_List (Display.Pixmap_Format);  
        end if;

        if Display.Head /= null then  
            declare  
                This : X_Queued_Event;  
                That : X_Queued_Event;  
            begin  
                This := Display.Head;  
                while This /= null loop  
                    That := This.Next;  
                    Free_X_Queued_Event (This);  
                    This := That;  
                end loop;  
            end;  
        end if;

        if Display.Database /= None_X_Universal_Pointer then  
            Univ_X_Rm_Database.Free_Both_X_Universal_Pointer (Display.Database);  
        end if;

        if Display.Key_Syms /= null then  
            Free_X_Key_Sym_List_2d (Display.Key_Syms);  
        end if;

        if Display.Modifier_Map /= null then  
            if Display.Modifier_Map.Modifiermap /= null then  
                Free_X_Modifier_Key_Code_List  
                   (Display.Modifier_Map.Modifiermap);  
            end if;  
            Free_X_Modifier_Keymap (Display.Modifier_Map);  
        end if;

        if Display.Key_Bindings /= null then  
            Free_X_Key_Trans (Display.Key_Bindings);  
        end if;

        if Display.X_Defaults /= None_X_String_Pointer then  
            Free_X_String_Pointer (Display.X_Defaults);  
        end if;

        Free_X_Ext_Data_List (Display.Ext_Data);

--/ if OLD_CONTEXT_MANAGER then
--//         if Display.Contexts /= None_X_Universal_Pointer then
--//             Univ_X_Context_Hash_List.Free_Both_X_Universal_Pointer
--//                (Display.Contexts);
--//         end if;
--/ end if;

        Display.Lock.Unlock;  
        Free_X_Mutex (Display.Lock);

        Heap_Free_X_Display (Display);

    end Internal_X_Free_Display_Structure;

--\f

    procedure Internal_X_Vid_To_Visual (Display :        X_Display;  
                                        Id      :        X_Visual_Id;  
                                        Visual  : in out X_Visual;  
                                        Status  : out    X_Status) is
------------------------------------------------------------------------------
-- Given a visual id, find the X_Visual structure.  We walk over the various
-- visual info for a given display until we find the Visual whose Id matches
-- the one sent in.  This is used to translate Id's into X_Visuals when an
-- Id is returned by an incoming event.
------------------------------------------------------------------------------
        Sp : X_Screen;  
    begin  
        begin

----Loop over all Screens in the display.

            for I in Display.Screens'Range loop  
                Sp := Display.Screens (I);

----Loop over all Depths in the screen.

                for J in Sp.Depths'Range loop  
                    declare  
                        Dp : X_Depth_Rec renames Sp.Depths (J);  
                    begin

----Loop over all Visuals in the depth.

                        for K in Dp.Visuals'Range loop  
                            declare  
                                Vp : X_Visual renames Dp.Visuals (K);  
                            begin

----If this is the Visual we're looking for then return it.

                                if Vp.Visual_Id = Id then  
                                    Visual := Vp;  
                                    Status := Successful;  
                                    return;  
                                end if;  
                            end;  
                        end loop;  
                    end;  
                end loop;  
            end loop;

----Visual not found.

            Status := Failed;

        end;  
    end Internal_X_Vid_To_Visual;

--\f

    procedure Report_Io_Error (Display  : X_Display;  
                               Facility : X_String) is
------------------------------------------------------------------------------
-- Called when we have had an I/O error.  We convert Display.Fd_Error to a string
-- and stuff it into Display.Error and then we call the X_Lib.IO_Error
-- routine.
------------------------------------------------------------------------------
        Proc : X_Procedure_Variable;  
    begin

        X_Lib.Get_Io_Error (Display, Proc);  
        Err (Display.Last_Error,  
             X_Get_Error_String ("XlibError", "TError",  
                                 "Transport package error:") &  
             " (" & Facility & " ) " &  
             To_X_String (Image (Display.Network.Fd_Error)));  
        Proc_Var_X_Io_Error_Function.Call  
           (Proc_Var_X_Io_Error_Function.To_Pv (Proc), Display);  
        raise X_Network_Io_Error;

    end Report_Io_Error;

--\f

    procedure Sync_Handle (Display : X_Display) is
------------------------------------------------------------------------------
-- Call the Synchandler routine associated with a display.
--#define Sync_Handle() \
--    if (Display->synchandler) (*Display->synchandler)(Display)
------------------------------------------------------------------------------
    begin

        if Display.Synchandler /= None_X_Procedure_Variable then  
            Proc_Var_X_Synchandler.Call  
               (Proc_Var_X_Synchandler.To_Pv (Display.Synchandler), Display);  
        end if;

    end Sync_Handle;

--\f

    function Number_To_String (Num : S_Long) return X_String is  
        Buf : String (1 .. 13);  
    begin  
        S_Long_Io.Put (Buf, Num, Base => 16);  
        return To_X_String (Buf);  
    end Number_To_String;

--\f

    function Internal_X_Set_Last_Request_Read  
                (Display  : X_Display;  
                 Kind     : X_Event_Code;  
                 Sequence : U_Short) return S_Long is
------------------------------------------------------------------------------
-- The hard part about this is that we only get 16 bits from a reply.  Well,
-- then, we have three values that will march along, with the following
-- invariant:
--    Display.last_request_read <= rep.sequence_Number <= Display.Request
-- The right choice for rep.sequence_Number is the largest that
-- still meets these constraints.
------------------------------------------------------------------------------
        New_Seq  : S_Long;  
        Last_Seq : S_Long;  
    begin

----KeymapNotify has no sequence number, but is always guaranteed
--  to immediately follow another event; except when generated via
--  SendEvent (hmmmm).

        if Kind = Keymap_Notify then  
            return Display.Last_Request_Read;  
        end if;

        New_Seq  := (Display.Last_Request_Read and not 16#FFFF#) or  
                       S_Long (Sequence);  
        Last_Seq := Display.Last_Request_Read;  
        while New_Seq < Last_Seq loop  
            New_Seq := New_Seq + 16#10000#;  
            if New_Seq > Display.Request then  
                New_Seq := New_Seq - 16#10000#;  
                X_Report_Error  
                   ("XlibError", "SequenceLost",  
                    "Xlib; Sequence lost (new) %1 < %2 (old) in reply type %2.",  
                    Number_To_String (New_Seq),  
                    Number_To_String (Display.Request),  
                    To_X_String (X_Event_Code'Image (Kind)));  
                exit;  
            end if;  
        end loop;

        Display.Last_Request_Read := New_Seq;  
        return New_Seq;

    end Internal_X_Set_Last_Request_Read;

--\f

    procedure Internal_X_Enq (Display : X_Display;  
                              Event   : X_Event) is
------------------------------------------------------------------------------
-- Take a newly received event and place it into the queue of the display that
-- generated it.
------------------------------------------------------------------------------
        Qelt : X_Queued_Event;  
    begin

----Try to reuse an old queue element.

----Get a new event record.

        Qelt := Display.Q_Free;  
        if Qelt = None_X_Queued_Event then  
            begin  
                Qelt := new X_Queued_Event_Rec;  
            exception  
                when others =>  
                    declare  
                        Proc : X_Procedure_Variable;  
                    begin  
                        X_Lib.Get_Io_Error (Display, Proc);  
                        Display.Network.Fd_Error := No_Free_Memory;  
                        Err (Display.Last_Error,  
                             X_Get_Error_String ("XlibError", "NoMemory",  
                                                 "No free memory available."));  
                        Proc_Var_X_Io_Error_Function.Call  
                           (Proc_Var_X_Io_Error_Function.To_Pv (Proc), Display);  
                        raise X_Network_Io_Error;
                    end;  
            end;  
        else  
            Display.Q_Free := Qelt.Next;  
            Qelt.Next      := None_X_Queued_Event;  
        end if;  
        Qelt.Event := Event;

----Queue the old/new event at the tail of the existing queue, if any.

        Qelt.Next := None_X_Queued_Event;  
        if Display.Tail /= null then  
            Display.Tail.Next := Qelt;  
        else  
            Display.Head := Qelt;  
        end if;  
        Display.Tail  := Qelt;  
        Display.Q_Len := Display.Q_Len + 1;

    end Internal_X_Enq;

--\f

end Xlbip_Internal;