PreviousUpNext

15.4.1496  src/lib/x-kit/xclient/pkg/wire/value-to-wire-pith.pkg

## value-to-wire.pkg
#
# Generate binary-bytestring format
# X11 protocol requests suitable for
# writing to the X server socket.
#
# The X11R6 wire protocol is documented here:
#     http:://mythryl.org/pub/exene/X-protocol.pdf
#
# The converse transformation is done by:
#     src/lib/x-kit/xclient/pkg/wire/wire-to-value.pkg
#
# The work of actually sending and recieving
# these bytestrings via socket is handled by
#     src/lib/x-kit/xclient/pkg/wire/xsocket.pkg
#
# See also:
#     src/lib/x-kit/xclient/pkg/wire/sendevent-to-wire.pkg

# Compiled by:
#     src/lib/x-kit/xclient/xclient-internals.sublib



###        "To be on the wire is life.
###         The rest is waiting."
###
###           -- Karl Wallenda, highwire walker



# TODO
#   - encodeAllocColorCells
#   - encodeAllocColorPlanes
#   - encodeChangeKeyboardMapping
#   - encodeSetPointerMapping
#   - encodeGetPointerMapping
#   - encodeSetModifierMapping  XXX BUGGO FIXME

# Used in:
#     src/lib/x-kit/xclient/pkg/wire/display.pkg
#     src/lib/x-kit/xclient/pkg/wire/xsocket.pkg 
#     src/lib/x-kit/xclient/pkg/wire/sendevent-to-wire.pkg
#
#     src/lib/x-kit/xclient/pkg/window/color-spec.pkg
#     src/lib/x-kit/xclient/pkg/window/cursors.pkg
#     src/lib/x-kit/xclient/pkg/window/xsession.pkg
#     src/lib/x-kit/xclient/pkg/window/draw-imp.pkg
#     src/lib/x-kit/xclient/pkg/window/font-imp.pkg
#     src/lib/x-kit/xclient/pkg/window/pen-to-gcontext-imp.pkg
#     src/lib/x-kit/xclient/pkg/window/cs-pixmap.pkg
#     src/lib/x-kit/xclient/pkg/window/keymap-imp.pkg
#     src/lib/x-kit/xclient/pkg/window/rw-pixmap.pkg
#     src/lib/x-kit/xclient/pkg/window/selection-imp.pkg
#     src/lib/x-kit/xclient/pkg/window/window.pkg
#
#     src/lib/x-kit/xclient/pkg/iccc/atom-imp.pkg
#     src/lib/x-kit/xclient/pkg/iccc/window-property.pkg
#     src/lib/x-kit/xclient/pkg/iccc/atom.pkg

stipulate
    package xg  =  xgeometry;                   # xgeometry             is from   src/lib/std/2d/xgeometry.pkg
    package xt  =  xtypes;                      # xtypes                is from   src/lib/x-kit/xclient/pkg/wire/xtypes.pkg
    package ts  =  xserver_timestamp;           # xserver_timestamp     is from   src/lib/x-kit/xclient/pkg/wire/xserver-timestamp.pkg
    package kb  =  keys_and_buttons;            # keys_and_buttons      is from   src/lib/x-kit/xclient/pkg/wire/keys-and-buttons.pkg
    package w8a =  rw_vector_of_one_byte_unts;          # rw_vector_of_one_byte_unts    is from   src/lib/std/src/rw-vector-of-one-byte-unts.pkg
    package w8v =  vector_of_one_byte_unts;                     # vector_of_one_byte_unts               is from   src/lib/std/src/vector-of-one-byte-unts.pkg
herein

    package   value_to_wire_pith
    :         Value_To_Wire                     # Value_To_Wire         is from   src/lib/x-kit/xclient/pkg/wire/value-to-wire.api
    {

        # Used (only) in:
        #
        #     src/lib/x-kit/xclient/pkg/window/pen.pkg
        #
        fun graph_op_to_wire xt::OP_CLR                 => 0u0;
            graph_op_to_wire xt::OP_AND                 => 0u1;
            graph_op_to_wire xt::OP_AND_NOT             => 0u2;
            graph_op_to_wire xt::OP_COPY                => 0u3;
            graph_op_to_wire xt::OP_AND_INVERTED        => 0u4;
            graph_op_to_wire xt::OP_NOP                 => 0u5;
            graph_op_to_wire xt::OP_XOR                 => 0u6;
            graph_op_to_wire xt::OP_OR                  => 0u7;
            graph_op_to_wire xt::OP_NOR                 => 0u8;
            graph_op_to_wire xt::OP_EQUIV               => 0u9;
            graph_op_to_wire xt::OP_NOT                 => 0u10;
            graph_op_to_wire xt::OP_OR_NOT              => 0u11;
            graph_op_to_wire xt::OP_COPY_NOT            => 0u12;
            graph_op_to_wire xt::OP_OR_INVERTED         => 0u13;
            graph_op_to_wire xt::OP_NAND                => 0u14;
            graph_op_to_wire xt::OP_SET                 => 0u15;
        end;

        # Used (only) in:
        #
        #     src/lib/x-kit/xclient/pkg/wire/value-to-wire.pkg
        #     src/lib/x-kit/xclient/pkg/iccc/iccc-property.pkg
        #
        fun gravity_to_wire xt::FORGET_GRAVITY  => 0u0; #  Bit gravity only 
            gravity_to_wire xt::UNMAP_GRAVITY   => 0u0; #  window gravity only 
            gravity_to_wire xt::NORTHWEST_GRAVITY       => 0u1;
            gravity_to_wire xt::NORTH_GRAVITY   => 0u2;
            gravity_to_wire xt::NORTHEAST_GRAVITY       => 0u3;
            gravity_to_wire xt::WEST_GRAVITY    => 0u4;
            gravity_to_wire xt::CENTER_GRAVITY  => 0u5;
            gravity_to_wire xt::EAST_GRAVITY    => 0u6;
            gravity_to_wire xt::SOUTHWEST_GRAVITY       => 0u7;
            gravity_to_wire xt::SOUTH_GRAVITY   => 0u8;
            gravity_to_wire xt::SOUTHEAST_GRAVITY       => 0u9;
            gravity_to_wire xt::STATIC_GRAVITY  => 0u10;
        end;

        # Used (only) in:
        #
        #     src/lib/x-kit/xclient/pkg/wire/value-to-wire.pkg
        #
        fun bool_to_wire  FALSE =>   0u0;
            bool_to_wire  TRUE  =>   0u1;
        end;

        # Used (only) in:
        #
        #     src/lib/x-kit/xclient/pkg/window/window.pkg
        #
        fun stack_mode_to_wire  xt::ABOVE         =>  0u0;
            stack_mode_to_wire  xt::BELOW         =>  0u1;
            stack_mode_to_wire  xt::TOP_IF        =>  0u2;
            stack_mode_to_wire  xt::BOTTOM_IF =>  0u3;
            stack_mode_to_wire  xt::OPPOSITE  =>  0u4;
        end;


        # Process a configuration value list,
        # producing a value_list. 
        #
        fun do_val_list n f lst
            =
            {   v = rw_vector::make_rw_vector (n, NULL);

                list::apply  (f v)  lst;

                xt::VALUE_LIST  v;
            };

        # This encodes the attribute "lists" (vectors) needed by:
        #
        #     encode_create_window
        #     encode_change_window_attributes
        #
        my  make_window_attribute_list:   List( xt::a::Window_Attribute ) -> xt::Value_List
            =
            do_val_list  15  set_window_attribute
            where
                fun set_window_attribute  rw_vec
                    =
                    {   fun update (i, x)
                            =
                            rw_vector::set (rw_vec, i, THE x);

                        fn xt::a::BACKGROUND_PIXMAP_NONE                        => update (0, 0u0);
                           xt::a::BACKGROUND_PIXMAP_PARENT_RELATIVE             => update (0, 0u1);
                           xt::a::BACKGROUND_PIXMAP (xt::XID p)                 => update (0, p);

                           xt::a::BACKGROUND_PIXEL  rgb8                        => update (1, unt::from_int (rgb8::rgb8_to_int rgb8));

                           xt::a::BORDER_PIXMAP_COPY_FROM_PARENT                => update (2, 0u0);
                           xt::a::BORDER_PIXMAP (xt::XID p)                     => update (2, p);

                           xt::a::BORDER_PIXEL  rgb8                            => update (3, unt::from_int (rgb8::rgb8_to_int rgb8));
                           xt::a::BIT_GRAVITY g                                 => update (4, gravity_to_wire g);
                           xt::a::WINDOW_GRAVITY g                              => update (5, gravity_to_wire g);

                           xt::a::BACKING_STORE xt::BS_NOT_USEFUL               => update (6, 0u0);
                           xt::a::BACKING_STORE xt::BS_WHEN_MAPPED              => update (6, 0u1);
                           xt::a::BACKING_STORE xt::BS_ALWAYS                   => update (6, 0u2);

                           xt::a::BACKING_PLANES (xt::PLANEMASK m)              => update (7, m);
                           xt::a::BACKING_PIXEL   rgb8                          => update (8, unt::from_int (rgb8::rgb8_to_int  rgb8));

                           xt::a::OVERRIDE_REDIRECT b                           => update ( 9, bool_to_wire b);
                           xt::a::SAVE_UNDER b                                  => update (10, bool_to_wire b);

                           xt::a::EVENT_MASK            (xt::EVENT_MASK m)      => update (11, m);
                           xt::a::DO_NOT_PROPAGATE_MASK (xt::EVENT_MASK m)      => update (12, m);

                           xt::a::COLOR_MAP_COPY_FROM_PARENT                    => update (13, 0u0);
                           xt::a::COLOR_MAP (xt::XID x)                         => update (13, x);

                           xt::a::CURSOR_NONE                                   => update (14, 0u0);
                           xt::a::CURSOR (xt::XID x)                            => update (14, x);
                        end;
                    };
            end;

        stipulate

            # We need to treat requests as arrays for initialization purposes,
            # but we don't want them to be modifiable afterwords.
            #
            my ro2rw:  vector_of_one_byte_unts::Vector -> rw_vector_of_one_byte_unts::Rw_Vector
                =
                unsafe::cast;

            fun pad n
                =
                unt::bitwise_and (unt::from_int n, 0u3) != 0u0
                  ?? pad (n+1)
                  :: n;

            fun make_request_buf size
                =
                unsafe::vector_of_one_byte_unts::make  size;

            fun put8 (buf, i, w)
                =
                w8a::set (ro2rw buf, i, w);

            fun put_word8 (buf, i, x)
                =
                put8 (buf, i, one_byte_unt::from_large_unt (unt::to_large_unt x));

            fun put_signed8  (buf, i, x) =  put8 (buf, i, one_byte_unt::from_int x);

            fun put16        (buf, i, x) =  pack_big_endian_unt16::set (ro2rw buf, i / 2, x);
            fun put_word16   (buf, i, x) =  put16 (buf, i, unt::to_large_unt x);
            fun put_signed16 (buf, i, x) =  put16 (buf, i, large_unt::from_int x);

            fun put32        (buf, i, x) =  pack_big_endian_unt1::set (ro2rw buf, i / 4, x);
            fun put_word32   (buf, i, x) =  put32 (buf, i, unt::to_large_unt x);
            fun put_signed32 (buf, i, x) =  put32 (buf, i, large_unt::from_int x);

            fun put_string (buf, i, s)
                =
                byte::pack_string (ro2rw buf, i, substring::from_string s);

            fun put_data (buf, i, bv)
                =
                w8a::copy_vec {
                    to   => ro2rw buf,
                    di   => i,
                    from => bv
                  };

            fun put_bool (buf, i, FALSE) =>  put8 (buf, i, 0u0);
                put_bool (buf, i, TRUE ) =>  put8 (buf, i, 0u1);
            end;

            fun put_xid (buf, i, xt::XID n)
                =
                put_word32 (buf, i, n);

            fun put_xid_option (buf, i, NULL)            =>  put_word32 (buf, i, 0u0);
                put_xid_option (buf, i, THE (xt::XID n)) =>  put_word32 (buf, i, n  );
            end;

            fun put_atom (buf, i, xt::XATOM n)
                =
                put_word32 (buf, i, n);

            fun put_atom_option (buf, i, THE (xt::XATOM n)) =>  put_word32 (buf, i, n  );
                put_atom_option (buf, i, NULL             ) =>  put_word32 (buf, i, 0u0);
            end;

            fun put_rgb8           (buf, i, rgb8             ) =  put_signed32 (buf, i, (rgb8::rgb8_to_int  rgb8));
            fun put_plane_mask     (buf, i, xt::PLANEMASK   n) =  put_word32   (buf, i, n);
            fun put_event_mask     (buf, i, xt::EVENT_MASK  m) =  put_word32   (buf, i, m);
            fun put_ptr_event_mask (buf, i, xt::EVENT_MASK  m) =  put_word16   (buf, i, m);

            fun put_point (buf, i, xg::POINT { col, row } )
                =
                {   put_signed16 (buf, i,   col);
                    put_signed16 (buf, i+2, row);
                };

            fun put_size (buf, i, xg::SIZE { wide, high } )
               =
               {   put_signed16 (buf, i,   wide);
                   put_signed16 (buf, i+2, high);
               };

            fun put_box (buf, i, xg::BOX { col, row, wide, high } )
                =
                {   put_signed16 (buf, i,   col );
                    put_signed16 (buf, i+2, row );
                    put_signed16 (buf, i+4, wide);
                    put_signed16 (buf, i+6, high);
                };

            fun put_arc (buf, i, xg::ARC { col, row, wide, high, angle1, angle2 } )
                =
                {   put_signed16 (buf, i,    col   );
                    put_signed16 (buf, i+2,  row   );
                    put_signed16 (buf, i+4,  wide  );
                    put_signed16 (buf, i+6,  high  );
                    put_signed16 (buf, i+8,  angle1);
                    put_signed16 (buf, i+10, angle2);
                };

            fun put_wgeom (buf, i, xg::WINDOW_SITE { upperleft, size, border_thickness } )
                =
                {   put_point    (buf, i,   upperleft   );
                    put_size     (buf, i+4, size        );
                    put_signed16 (buf, i+8, border_thickness);
                };


            fun put_timestamp (buf, i, xt::CURRENT_TIME)                         =>  put32 (buf, i, 0u0);
                put_timestamp (buf, i, xt::TIMESTAMP (ts::XSERVER_TIMESTAMP t)) =>  put32 (buf, i, t);
            end;


            fun put_rgb (buf, i, rgb)
                =
                {   (rgb::rgb_to_unts rgb)
                        ->
                        (red, green, blue);

                    put_word16 (buf, i,   red  );
                    put_word16 (buf, i+2, green);
                    put_word16 (buf, i+4, blue );
                };

            fun put_grab_mode (buf, i, xt::SYNCHRONOUS_GRAB ) => put8 (buf, i, 0u0);
                put_grab_mode (buf, i, xt::ASYNCHRONOUS_GRAB) => put8 (buf, i, 0u1);
            end;

            fun put_list (f, size:  Int) (buf, base, list)
                =
                put (base, list)
                where
                    fun put (_, []) => ();
                        put (i, x ! r) => { f (buf, i, x); put (i+size, r);};
                    end;
                 end;

            put_points =  put_list (put_point, 4);
            put_boxes  =  put_list (put_box,   8);
            put_rgb8s  =  put_list (put_rgb8,  4);

            # Build a value list and mask from a value option rw_vector 
            #
            fun make_value_list (xt::VALUE_LIST rw_vec)
                =
                f ((rw_vector::length rw_vec) - 1, 0, 0u0, [])
                where
                    fun f (-1, n, m, l)
                            =>
                            (n, xt::VALUE_MASK m, l);

                        f (i, n, m, l)
                            =>
                            case (rw_vector::get (rw_vec, i))
                                #
                                THE x =>  f (i - 1, n+1, unt::bitwise_or (m, unt::(<<) (0u1, unt::from_int i)), x ! l);
                                NULL  =>  f (i - 1, n, m, l);
                            esac;
                    end;
                end;

            # Put value masks and lists 
            #
            stipulate

                put_vals
                    =
                    put_list (put_word32, 4);

            herein

                fun put_val_list (buf, i, xt::VALUE_MASK m, vals)
                    =
                    {   put_word32 (buf, i,   m   );
                        put_vals   (buf, i+4, vals);
                    };

                fun put_val_list16 (buf, i, xt::VALUE_MASK m, vals)
                    =
                    {   put_word16 (buf, i,   m   );
                        put_vals   (buf, i+4, vals);
                    };
            end;



            ########################################################################
            # X11 protocol request codes and sizes (from "Xproto::h")

            Reqinfo = { code:  one_byte_unt::Unt,
                        size:  Int
                      };

            req_create_window                   = { code =>   0u1, size => 8 }: Reqinfo;
            req_change_window_attributes        = { code =>   0u2, size => 3 }: Reqinfo;
            req_get_window_attributes           = { code =>   0u3, size => 2 }: Reqinfo;

            req_destroy_window                  = { code =>   0u4, size => 2 }: Reqinfo;
            req_destroy_subwindows              = { code =>   0u5, size => 2 }: Reqinfo;
            req_change_save_set                 = { code =>   0u6, size => 2 }: Reqinfo;

            req_reparent_window                 = { code =>   0u7, size => 4 }: Reqinfo;
            req_map_window                      = { code =>   0u8, size => 2 }: Reqinfo;
            req_map_subwindows                  = { code =>   0u9, size => 2 }: Reqinfo;

            req_unmap_window                    = { code =>  0u10, size => 2 }: Reqinfo;
            req_unmap_subwindows                = { code =>  0u11, size => 2 }: Reqinfo;
            req_configure_window                = { code =>  0u12, size => 3 }: Reqinfo;

            req_circulate_window                = { code =>  0u13, size => 2 }: Reqinfo;
            req_get_geometry                    = { code =>  0u14, size => 2 }: Reqinfo;
            req_query_tree                      = { code =>  0u15, size => 2 }: Reqinfo;

            req_intern_atom                     = { code =>  0u16, size => 2 }: Reqinfo;
            req_get_atom_name                   = { code =>  0u17, size => 2 }: Reqinfo;
            req_change_property                 = { code =>  0u18, size => 6 }: Reqinfo;

            req_delete_property                 = { code =>  0u19, size => 3 }: Reqinfo;
            req_get_property                    = { code =>  0u20, size => 6 }: Reqinfo;
            req_list_properties                 = { code =>  0u21, size => 2 }: Reqinfo;

            req_set_selection_owner             = { code =>  0u22, size => 4 }: Reqinfo;
            req_get_selection_owner             = { code =>  0u23, size => 2 }: Reqinfo;
            req_convert_selection               = { code =>  0u24, size => 6 }: Reqinfo;

            req_push_event                      = { code =>  0u25, size => 11}: Reqinfo;
            req_grab_pointer                    = { code =>  0u26, size => 6 }: Reqinfo;
            req_ungrab_pointer                  = { code =>  0u27, size => 2 }: Reqinfo;

            req_grab_button                     = { code =>  0u28, size => 6 }: Reqinfo;
            req_ungrab_button                   = { code =>  0u29, size => 3 }: Reqinfo;
            req_change_active_pointer_grab      = { code =>  0u30, size => 4 }: Reqinfo;

            req_grab_keyboard                   = { code =>  0u31, size => 4 }: Reqinfo;
            req_ungrab_keyboard                 = { code =>  0u32, size => 2 }: Reqinfo;
            req_grab_key                        = { code =>  0u33, size => 4 }: Reqinfo;

            req_ungrab_key                      = { code =>  0u34, size => 3 }: Reqinfo;
            req_allow_events                    = { code =>  0u35, size => 2 }: Reqinfo;
            req_grab_server                     = { code =>  0u36, size => 1 }: Reqinfo;

            req_ungrab_server                   = { code =>  0u37, size => 1 }: Reqinfo;
            req_query_pointer                   = { code =>  0u38, size => 2 }: Reqinfo;
            req_get_motion_events               = { code =>  0u39, size => 4 }: Reqinfo;

            req_translate_coordinates           = { code =>  0u40, size => 4 }: Reqinfo;
            req_warp_pointer                    = { code =>  0u41, size => 6 }: Reqinfo;
            req_set_input_focus                 = { code =>  0u42, size => 3 }: Reqinfo;

            req_get_input_focus                 = { code =>  0u43, size => 1 }: Reqinfo;
            req_query_keymap                    = { code =>  0u44, size => 1 }: Reqinfo;
            req_open_font                       = { code =>  0u45, size => 3 }: Reqinfo;

            req_close_font                      = { code =>  0u46, size => 2 }: Reqinfo;
            req_query_font                      = { code =>  0u47, size => 2 }: Reqinfo;
            req_query_text_extents              = { code =>  0u48, size => 2 }: Reqinfo;

            req_list_fonts                      = { code =>  0u49, size => 2 }: Reqinfo;
            req_list_fonts_with_info            = { code =>  0u50, size => 2 }: Reqinfo;
            req_set_font_path                   = { code =>  0u51, size => 2 }: Reqinfo;

            req_get_font_path                   = { code =>  0u52, size => 1 }: Reqinfo;
            req_create_pixmap                   = { code =>  0u53, size => 4 }: Reqinfo;
            req_free_pixmap                     = { code =>  0u54, size => 2 }: Reqinfo;

            req_create_gc                       = { code =>  0u55, size => 4 }: Reqinfo;
            req_change_gc                       = { code =>  0u56, size => 3 }: Reqinfo;
            req_copy_gc                         = { code =>  0u57, size => 4 }: Reqinfo;

            req_set_dashes                      = { code =>  0u58, size => 3 }: Reqinfo;
            req_set_clip_boxes                  = { code =>  0u59, size => 3 }: Reqinfo;
            req_free_gc                         = { code =>  0u60, size => 2 }: Reqinfo;

            req_clear_area                      = { code =>  0u61, size => 4 }: Reqinfo;
            req_copy_area                       = { code =>  0u62, size => 7 }: Reqinfo;
            req_copy_plane                      = { code =>  0u63, size => 8 }: Reqinfo;

            req_poly_point                      = { code =>  0u64, size => 3 }: Reqinfo;
            req_poly_line                       = { code =>  0u65, size => 3 }: Reqinfo;
            req_poly_segment                    = { code =>  0u66, size => 3 }: Reqinfo;

            req_poly_rectangle                  = { code =>  0u67, size => 3 }: Reqinfo;
            req_poly_arc                        = { code =>  0u68, size => 3 }: Reqinfo;
            req_fill_poly                       = { code =>  0u69, size => 4 }: Reqinfo;

            req_poly_fill_box                   = { code =>  0u70, size => 3 }: Reqinfo;
            req_poly_fill_arc                   = { code =>  0u71, size => 3 }: Reqinfo;
            req_put_image                       = { code =>  0u72, size => 6 }: Reqinfo;

            req_get_image                       = { code =>  0u73, size => 5 }: Reqinfo;
            req_poly_text8                      = { code =>  0u74, size => 4 }: Reqinfo;
            req_poly_text16                     = { code =>  0u75, size => 4 }: Reqinfo;

            req_image_text8                     = { code =>  0u76, size => 4 }: Reqinfo;
            req_image_text16                    = { code =>  0u77, size => 4 }: Reqinfo;
            req_create_colormap                 = { code =>  0u78, size => 4 }: Reqinfo;

            req_free_colormap                   = { code =>  0u79, size => 2 }: Reqinfo;
            req_copy_colormap_and_free          = { code =>  0u80, size => 3 }: Reqinfo;
            req_install_colormap                = { code =>  0u81, size => 2 }: Reqinfo;

            req_uninstall_colormap              = { code =>  0u82, size => 2 }: Reqinfo;
            req_list_installed_colormaps        = { code =>  0u83, size => 2 }: Reqinfo;
            req_alloc_color                     = { code =>  0u84, size => 4 }: Reqinfo;

            req_alloc_named_color               = { code =>  0u85, size => 3 }: Reqinfo;
            req_alloc_color_cells               = { code =>  0u86, size => 3 }: Reqinfo;
            req_alloc_color_planes              = { code =>  0u87, size => 4 }: Reqinfo;

            req_free_colors                     = { code =>  0u88, size => 3 }: Reqinfo;
            req_store_colors                    = { code =>  0u89, size => 2 }: Reqinfo;
            req_store_named_color               = { code =>  0u90, size => 4 }: Reqinfo;

            req_query_colors                    = { code =>  0u91, size => 2 }: Reqinfo;
            req_lookup_color                    = { code =>  0u92, size => 3 }: Reqinfo;
            req_create_cursor                   = { code =>  0u93, size => 8 }: Reqinfo;

            req_create_glyph_cursor             = { code =>  0u94, size => 8 }: Reqinfo;
            req_free_cursor                     = { code =>  0u95, size => 2 }: Reqinfo;
            req_recolor_cursor                  = { code =>  0u96, size => 5 }: Reqinfo;

            req_query_best_size                 = { code =>  0u97, size => 3 }: Reqinfo;
            req_query_extension                 = { code =>  0u98, size => 2 }: Reqinfo;
            req_list_extensions                 = { code =>  0u99, size => 1 }: Reqinfo;

            req_change_keyboard_mapping         = { code => 0u100, size => 2 }: Reqinfo;
            req_get_keyboard_mapping            = { code => 0u101, size => 2 }: Reqinfo;
            req_change_keyboard_control         = { code => 0u102, size => 2 }: Reqinfo;

            req_get_keyboard_control            = { code => 0u103, size => 1 }: Reqinfo;
            req_bell                            = { code => 0u104, size => 1 }: Reqinfo;
            req_change_pointer_control          = { code => 0u105, size => 3 }: Reqinfo;

            req_get_pointer_control             = { code => 0u106, size => 1 }: Reqinfo;
            req_set_screen_saver                = { code => 0u107, size => 3 }: Reqinfo;
            req_get_screen_saver                = { code => 0u108, size => 1 }: Reqinfo;

            req_change_hosts                    = { code => 0u109, size => 2 }: Reqinfo;
            req_list_hosts                      = { code => 0u110, size => 1 }: Reqinfo;
            req_set_access_control              = { code => 0u111, size => 1 }: Reqinfo;

            req_set_close_down_mode             = { code => 0u112, size => 1 }: Reqinfo;
            req_kill_client                     = { code => 0u113, size => 2 }: Reqinfo;
            req_rotate_properties               = { code => 0u114, size => 3 }: Reqinfo;

            req_force_screen_saver              = { code => 0u115, size => 1 }: Reqinfo;
            req_set_pointer_mapping             = { code => 0u116, size => 1 }: Reqinfo;
            req_get_pointer_mapping             = { code => 0u117, size => 1 }: Reqinfo;

            req_set_modifier_mapping            = { code => 0u118, size => 1 }: Reqinfo;
            req_get_modifier_mapping            = { code => 0u119, size => 1 }: Reqinfo;
            req_no_operation                    = { code => 0u127, size => 1 }: Reqinfo;

            # Allocate a buffer for a fixed-sized message and initialize the
            # code and size fields.  Return the buffer.
            #
            fun make_request ( { code, size } : Reqinfo)
                =
                {   buf = make_request_buf (4*size);

                    put8         (buf, 0, code);                # Request opcode.
                    put_signed16 (buf, 2, size);                # Request size (in words).

                    buf;
                };

            # Allocate a buffer for a fixed-sized message that contains an xid
            # in its first field, and initialize the code and size fields.  Return
            # the buffer.
            #
            fun make_resource_request (info, xid)
                =
                {   buf = make_request info;

                    put_xid (buf, 4, xid);                      # Resource id.

                    buf;
                };

            # Allocate and initialize a buffer for a variable-sized request.
            # Return the new buffer.
            #
            fun make_extra_request ( { code, size }, extra)
                =
                {   size = size+extra;

                    buf = make_request_buf (4*size);

                    put8         (buf, 0, code);                # Request opcode.
                    put_signed16 (buf, 2, size);                # Request size (in words).

                    buf;
                };

            # Allocate and initialize a buffer for a variable-sized request.
            # Only allocate space for the header.  Return the new buffer.
            #
            fun make_var_request ( { code, size }, extra)                       # THIS FUNCTION APPEARS TO BE ENTIRELY UNUSED.
                =
                {   size = size+extra;

                    buf = make_request_buf (4*size);

                    put8         (buf, 0, code);                # Request opcode.
                    put_signed16 (buf, 2, size+extra);  # Request size (in words).

                    buf;
                };

        herein

            # Encode the connection request message.
            #
            # This consists of the byte-order,
            # protocol version, and optional authentication data.
            #
            fun encode_xserver_connection_request { minor_version, xauthentication }
                =
                {
                    fun set_prefix size
                        =
                        {   buf = w8v::tabulate (size, fn _ = 0u0);

                            put8 (buf, 0, byte::char_to_byte 'B');              #  Byte order: MSB 
                            put8 (buf, 3, 0u11);                                #  major version: 11 
                            put8 (buf, 5, one_byte_unt::from_int minor_version);

                            buf;
                        };

                    case xauthentication
                        #
                        NULL => set_prefix 12;
                        #
                        THE (xt::XAUTHENTICATION { name, data, ... } )
                            =>
                            {   auth_name_len =  pad (size name);
                                auth_data_len =  pad (vector_of_one_byte_unts::length data);

                                prefix = set_prefix (12 + auth_name_len + auth_data_len);

                                put_signed16 (prefix,  6, size name);
                                put_signed16 (prefix,  8, vector_of_one_byte_unts::length data);
                                put_string   (prefix, 12, name);
                                put_data     (prefix, 12 + auth_name_len, data);

                                prefix;
                            };
                    esac;

                };

            fun encode_create_window
                { window_id:            xt::Xid,
                  parent_window_id:     xt::Xid,
                  #
                  visual_id:    xt::Visual_Id_Choice,
                  io_class:     xt::Io_Class,
                  depth:        Int,
                  site:         xg::Window_Site,
                  attributes:   List( xt::a::Window_Attribute )
                }
                =
                {   my (attribute_count, mask, attributes)
                        =
                        make_value_list  (make_window_attribute_list  attributes);

                    io  = case io_class
                              #
                              xt::SAME_IO_AS_PARENT =>  0u0;
                              xt::INPUT_OUTPUT      =>  0u1;
                              xt::INPUT_ONLY        =>  0u2;
                          esac;

                    visual_id
                        =
                        case visual_id
                            #
                            xt::SAME_VISUAL_AS_PARENT                     =>  0u0;      /* X calls this CopyFromParent  */
                            xt::OVERRIDE_PARENT_VISUAL (xt::VISUAL_ID id) =>   id;
                        esac;

                    msg = make_extra_request (req_create_window, attribute_count);

                    put_signed8  (msg,  1, depth           );
                    put_xid      (msg,  4, window_id       );
                    put_xid      (msg,  8, parent_window_id);
                    put_wgeom    (msg, 12, site            );
                    put16        (msg, 22, io              );
                    put_word32   (msg, 24, visual_id       );
                    put_val_list (msg, 28, mask, attributes);

                    msg;
                };


            fun encode_change_window_attributes
                {
                  window_id:   xt::Xid,
                  attributes:  List( xt::a::Window_Attribute )
                }
                =
                {   my (attribute_count, mask, attributes)
                        =
                        make_value_list  (make_window_attribute_list  attributes);

                    msg = make_extra_request (req_change_window_attributes, attribute_count);

                    put_xid      (msg, 4, window_id       );
                    put_val_list (msg, 8, mask, attributes);

                    msg;
                };

            fun encode_get_window_attributes { window_id }
                =
                make_resource_request (req_get_window_attributes, window_id);

            fun encode_destroy_window     { window_id } =  make_resource_request (req_destroy_window,     window_id);
            fun encode_destroy_subwindows { window_id } =  make_resource_request (req_destroy_subwindows, window_id);

            fun encode_change_save_set { window_id, insert }
                =
                {   msg = make_request (req_change_save_set);

                    put_bool (msg, 1, insert   );
                    put_xid  (msg, 4, window_id);

                    msg;
                };


            fun encode_reparent_window { window_id, parent_id, pos }
                =
                {   msg = make_resource_request (req_reparent_window, window_id);

                    put_xid   (msg,  8, parent_id);
                    put_point (msg, 12, pos      );

                    msg;
                };


            fun encode_map_window       { window_id } = make_resource_request (req_map_window,       window_id);
            fun encode_map_subwindows   { window_id } = make_resource_request (req_map_subwindows,   window_id);
            fun encode_unmap_window     { window_id } = make_resource_request (req_unmap_window,     window_id);
            fun encode_unmap_subwindows { window_id } = make_resource_request (req_unmap_subwindows, window_id);


            fun encode_configure_window { window_id, vals }
                =
                {   my (nvals, mask, vals)
                        =
                        make_value_list vals;

                    msg = make_extra_request (req_configure_window, nvals);

                    put_xid        (msg, 4, window_id );
                    put_val_list16 (msg, 8, mask, vals);

                    msg;
                };

            fun encode_circulate_window { window_id, parent_id, place }
                =
                {   place =
                        case place
                            #
                            xt::PLACE_ON_TOP    => 0u0;
                            xt::PLACE_ON_BOTTOM => 0u1;
                        esac;

                    msg =  make_request  req_circulate_window;

                    put_xid (msg,  4, parent_id);
                    put_xid (msg,  8, window_id);
                    put8    (msg, 12, place   );

                    msg;
                };

            fun encode_get_geometry { drawable }
                =
                make_resource_request (req_get_geometry, drawable);


            fun encode_query_tree { window_id }
                =
                make_resource_request (req_query_tree, window_id);


            fun encode_intern_atom { name, only_if_exists }
                =
                {   n = string::length name;
                    msg = make_extra_request (req_intern_atom, (pad n) / 4);

                    put_bool     (msg, 1, only_if_exists);
                    put_signed16 (msg, 4, n             );
                    put_string   (msg, 8, name          );

                    msg;
                };


            fun encode_get_atom_name { atom => (xt::XATOM id) }
                =
                make_resource_request (req_get_atom_name, xt::XID id);


            fun encode_change_property { window_id, name, property, mode }
                =
                {   property ->  xt::PROPERTY_VALUE { type, value => xt::RAW_DATA { format, data } };

                    nbytes = vector_of_one_byte_unts::length data;

                    my (nitems, fmt)
                        =
                        case format
                            #
                            xt::RAW8 => (nbytes, 0u8);
                            xt::RAW16 => (nbytes / 2, 0u16);
                            xt::RAW32 => (nbytes / 4, 0u32);
                        esac;

                    mode = case mode
                               #
                               xt::REPLACE_PROPERTY => 0u0;
                               xt::PREPEND_PROPERTY => 0u1;
                               xt::APPEND_PROPERTY  => 0u2;
                           esac;

                    msg = make_extra_request (req_change_property, (pad nbytes) / 4);

                    put8         (msg,  1, mode     );
                    put_xid      (msg,  4, window_id);
                    put_atom     (msg,  8, name     );
                    put_atom     (msg, 12, type     );
                    put8         (msg, 16, fmt      );
                    put_signed32 (msg, 20, nitems   );
                    put_data     (msg, 24, data     );

                    msg;
                };

            fun encode_delete_property { window_id, property }
                =
                {   msg = make_request  req_delete_property;

                    put_xid  (msg, 4, window_id);
                    put_atom (msg, 8, property );

                    msg;
                };

            fun encode_get_property { window_id, property, type, offset, len, delete }
                =
                {   msg = make_request  req_get_property;

                    put_bool        (msg,  1, delete   );
                    put_xid         (msg,  4, window_id);
                    put_atom        (msg,  8, property );
                    put_atom_option (msg, 12, type     );
                    put_signed32    (msg, 16, offset   );
                    put_signed32    (msg, 20, len      );

                    msg;
                };

            fun encode_list_properties { window_id }
                =
                make_resource_request (req_list_properties, window_id);


            fun encode_set_selection_owner { window_id, selection, timestamp }
                =
                {   msg =  make_request  req_set_selection_owner;

                    put_xid_option (msg,  4, window_id);
                    put_atom       (msg,  8, selection);
                    put_timestamp  (msg, 12, timestamp);

                    msg;
                };

            fun encode_get_selection_owner { selection => (xt::XATOM x) }
                =
                make_resource_request (req_get_selection_owner, xt::XID x);

            fun encode_convert_selection
                { selection, target, property, requestor, timestamp }
                =
                {   msg =  make_request  req_convert_selection;

                    put_xid         (msg,  4, requestor);
                    put_atom        (msg,  8, selection);
                    put_atom        (msg, 12, target   );
                    put_atom_option (msg, 16, property );
                    put_timestamp   (msg, 20, timestamp);

                    msg;
                };

            # This just encodes the header info;
            # encoding of the event proper is done in:
            # 
            #     src/lib/x-kit/xclient/pkg/wire/sendevent-to-wire.pkg
            #
            fun encode_push_event { send_event_to, propagate, event_mask }
                =
                {   msg =  make_request  req_push_event;
                    #
                    put_bool (msg, 1, propagate);

                    case send_event_to
                        #
                        xt::SEND_EVENT_TO_POINTER_WINDOW => put32   (msg, 4, 0u0);
                        xt::SEND_EVENT_TO_INPUT_FOCUS    => put32   (msg, 4, 0u1);
                        xt::SEND_EVENT_TO_WINDOW wide    => put_xid (msg, 4, wide);
                    esac;

                    put_event_mask (msg, 8, event_mask);

                    msg;
                };

            fun encode_grab_pointer
                { window_id, owner_events, event_mask, ptr_mode, kbd_mode, confine_to, cursor, time }
                =
                {   msg =  make_request  req_grab_pointer;

                    put_bool           (msg,  1, owner_events);
                    put_xid            (msg,  4, window_id   );
                    put_ptr_event_mask (msg,  8, event_mask  );
                    put_grab_mode      (msg, 10, ptr_mode    );
                    put_grab_mode      (msg, 11, kbd_mode    );
                    put_xid_option     (msg, 12, confine_to  );
                    put_xid_option     (msg, 16, cursor      );
                    put_timestamp      (msg, 20, time        );

                    msg;
                };

            fun encode_grab_keyboard
                { window_id, owner_events, ptr_mode, kbd_mode, time }
                =
                {   msg =  make_request  req_grab_keyboard;

                    put_bool      (msg,  1, owner_events);
                    put_xid       (msg,  4, window_id   );
                    put_timestamp (msg,  8, time        );
                    put_grab_mode (msg, 12, ptr_mode    );
                    put_grab_mode (msg, 13, kbd_mode    );

                    msg;
                };

            stipulate

                fun ungrab info { time }
                    =
                    {   msg = make_request (info);

                        put_timestamp (msg, 4, time);

                        msg;
                    };
            herein
                encode_ungrab_pointer  =  ungrab  req_ungrab_pointer;
                encode_ungrab_keyboard =  ungrab  req_ungrab_keyboard;
            end;

            fun encode_change_active_pointer_grab { event_mask, cursor, time }
                =
                {   msg =  make_request  req_change_active_pointer_grab;

                    put_xid_option     (msg,  4, cursor);
                    put_timestamp      (msg,  8, time);
                    put_ptr_event_mask (msg, 12, event_mask);

                    msg;
                };

            stipulate

                fun put_modifiers (buf, i, mset)
                    =
                    {   m = case (kb::make_modifier_keys_state mset)
                                #
                                xt::ANY_MOD_KEY => 0ux8000;
                                xt::MKSTATE m   => m;
                            esac;

                        put_word16 (buf, i, m);
                    };

                fun put_button (buf, i, THE (xt::MOUSEBUTTON b)) => put_signed8 (buf, i, b);
                    put_button (buf, i, NULL) => put8 (buf, i, 0u0);
                end;

                fun put_key_code (buf, i, xt::KEYCODE k)
                    =
                    put_signed8 (buf, i, k);
            herein

                fun encode_grab_button
                    { button, modifiers, window_id, owner_events, event_mask, ptr_mode, kbd_mode,
                      confine_to, cursor
                    }
                    =
                    {   msg =  make_request  req_grab_button;

                        put_bool           (msg,  1, owner_events);
                        put_xid            (msg,  4, window_id   );
                        put_ptr_event_mask (msg,  8, event_mask  );
                        put_grab_mode      (msg, 10, ptr_mode    );
                        put_grab_mode      (msg, 11, kbd_mode    );
                        put_xid_option     (msg, 12, confine_to  );
                        put_xid_option     (msg, 16, cursor      );
                        put_button         (msg, 18, button      );
                        put_modifiers      (msg, 20, modifiers   );

                        msg;
                    };

                fun encode_grab_key { key, modifiers, window_id, owner_events, ptr_mode, kbd_mode }
                    =
                    {   msg =  make_request  req_grab_key;

                        put_bool      (msg,  1, owner_events);
                        put_xid       (msg,  4, window_id   );
                        put_modifiers (msg,  8, modifiers   );
                        put_key_code  (msg, 10, key         );
                        put_grab_mode (msg, 11, ptr_mode    );
                        put_grab_mode (msg, 12, kbd_mode    );

                        msg;
                    };

                fun encode_ungrab_button { button, modifiers, window_id }
                    =
                    {   msg =  make_request  req_ungrab_button;

                        put_button    (msg, 1, button   );
                        put_xid       (msg, 4, window_id);
                        put_modifiers (msg, 8, modifiers);

                        msg;
                    };

                fun encode_ungrab_key { key, modifiers, window_id }
                    =
                    {   msg =  make_request  req_ungrab_key;

                        put_key_code  (msg, 1, key      );
                        put_xid       (msg, 4, window_id);
                        put_modifiers (msg, 8, modifiers);

                        msg;
                    };
            end;                                                # stipulate 

            fun encode_allow_events { mode, time }
                =
                {   msg =  make_request  req_allow_events;

                    mode = case mode
                               #
                               xt::ASYNC_POINTER   => 0u0;
                               xt::SYNC_POINTER    => 0u1;
                               xt::REPLAY_POINTER  => 0u2;
                               xt::ASYNC_KEYBOARD  => 0u3;
                               xt::SYNC_KEYBOARD   => 0u4;
                               xt::REPLAY_KEYBOARD => 0u5;
                               xt::ASYNC_BOTH      => 0u6;
                               xt::SYNC_BOTH       => 0u7;
                           esac;

                    put8          (msg,  1, mode);
                    put_timestamp (msg,  4, time);

                    msg;
                };


            fun encode_query_pointer { window_id }
                =
                make_resource_request (req_query_pointer, window_id);


            fun encode_get_motion_events { window_id, start, stop }
                =
                {   msg =  make_request  req_get_motion_events;

                    put_xid       (msg,  4, window_id);
                    put_timestamp (msg,  8, start    );
                    put_timestamp (msg, 12, stop     );

                    msg;
                };

            fun encode_translate_coordinates { from_window, to_window, from_point }
                =
                {   msg =  make_resource_request  (req_translate_coordinates,  from_window);

                    put_xid   (msg,  8, to_window );
                    put_point (msg, 12, from_point);

                    msg;
                };

            # See    p 35:  http://mythryl.org/pub/exene/X-protocol-R7.pdf
            #        p130:  http://mythryl.org/pub/exene/X-protocol-R7.pdf
            #
            fun encode_warp_pointer { from, to, from_box, to_point }
                =
                {   msg =  make_request  req_warp_pointer;

                    put_xid_option (msg,  4, from    );
                    put_xid_option (msg,  8, to      );
                    put_box        (msg, 12, from_box);
                    put_point      (msg, 20, to_point);

                    msg;
                };

            fun encode_set_input_focus { focus, revert_to, timestamp }
                =
                {   msg =  make_request  req_set_input_focus;

                    revert_to
                        =
                        case revert_to
                            #
                            xt::REVERT_TO_NONE         => 0u0;
                            xt::REVERT_TO_POINTER_ROOT => 0u1;
                            xt::REVERT_TO_PARENT       => 0u2;
                        esac;

                    focus
                        =
                        case focus
                            #
                            xt::INPUT_FOCUS_NONE => (xt::XID 0u0);
                            xt::INPUT_FOCUS_POINTER_ROOT => (xt::XID 0u1);
                            xt::INPUT_FOCUS_WINDOW w => w;
                        esac;


                    put8          (msg,  1, revert_to);
                    put_xid       (msg,  4, focus    );
                    put_timestamp (msg,  8, timestamp);

                    msg;
                  };

            fun encode_open_font { font, name }
                =
                {   n = string::length name;

                    msg = make_extra_request (req_open_font, (pad n) / 4);

                    put_xid      (msg,  4, font);
                    put_signed16 (msg,  8, n   );
                    put_string   (msg, 12, name);

                    msg;
                };

            fun encode_close_font { font } = make_resource_request (req_close_font, font);
            fun encode_query_font { font } = make_resource_request (req_query_font, font);

            fun encode_query_text_extents { font, string }
                =
                {   len =  string::length  string;
                    p   =  pad len;

                    msg = make_extra_request (req_query_text_extents, p / 4);

                    put_bool   (msg,  1, ((len - p) == 2));
                    put_xid    (msg,  4, font);
                    put_string (msg,  8, string);

                    msg;
                };

            stipulate
                fun encode info { pattern, max }
                    =
                    {   len = string::length pattern;

                        msg = make_extra_request (info, (pad len) / 4);

                        put_signed16 (msg, 4, max);
                        put_signed16 (msg, 6, len);
                        put_string   (msg, 8, pattern);

                        msg;
                    };
            herein
                encode_list_fonts = encode req_list_fonts;
                encode_list_fonts_with_info = encode req_list_fonts_with_info;
            end;

            fun encode_set_font_path { path }
                =
                {   fun f ([], n, l)
                            =>
                            (n, string::cat (list::reverse l));

                        f (s ! r, n, l)
                            =>
                            {   len = string::length s;

                                # Should check that len <= 255   XXX BUGGO FIXME

                                f (r, n+1, s ! string::from_char (char::from_int len) ! l);
                            };
                    end;

                    my (nstrs, data) = f (path, 0, []);
                    len = string::length data;
                    msg = make_extra_request (req_set_font_path, (pad len) / 4);

                    put_signed16 (msg, 4, nstrs);
                    put_string (msg, 8, data);
                    msg;
                };

            fun encode_create_pixmap { pixmap_id, drawable_id, depth, size }
                =
                {   msg = make_resource_request (req_create_pixmap, pixmap_id);

                    put_signed8 (msg,  1, depth         );
                    put_xid     (msg,  8, drawable_id   );
                    put_size    (msg, 12, size          );

                    msg;
                };

            fun encode_free_pixmap { pixmap }
                =
                make_resource_request (req_free_pixmap, pixmap);

            fun encode_create_gc { gc_id, drawable, vals }
                =
                {   my (nvals, mask, vals)
                        =
                        make_value_list vals;

                    msg = make_extra_request (req_create_gc, nvals);

                    put_xid      (msg,  4, gc_id     );
                    put_xid      (msg,  8, drawable  );
                    put_val_list (msg, 12, mask, vals);

                    msg;
                };

            fun encode_change_gc { gc_id, vals }
                =
                {   my (nvals, mask, vals)
                        =
                        make_value_list vals;

                    msg = make_extra_request (req_change_gc, nvals);

                    put_xid       (msg, 4, gc_id     );
                    put_val_list  (msg, 8, mask, vals);

                    msg;
                };

            fun encode_copy_gc { from, to, mask => xt::VALUE_MASK m }
                =
                {   msg = make_request (req_copy_gc);

                    put_xid    (msg,  4, from);
                    put_xid    (msg,  8, to  );
                    put_word32 (msg, 12, m   );

                    msg;
                };

            fun encode_set_dashes { gc_id, dash_offset, dashes }
                =
                {   n = list::length dashes;

                    msg = make_extra_request (req_set_dashes, (pad n) / 4);

                    put_xid                   (msg,  4, gc_id      );
                    put_signed16              (msg,  8, dash_offset);
                    put_signed16              (msg, 10, n          );
                    put_list (put_signed8, 1) (msg, 12, dashes     );

                    msg;
                };

            fun encode_set_clip_boxes { gc_id, clip_origin, ordering, boxes }
                =
                {   ordering
                        =
                        case ordering
                            #
                            xt::UNSORTED_ORDER => 0u0;
                            xt::YSORTED_ORDER  => 0u1;
                            xt::YXSORTED_ORDER => 0u2;
                            xt::YXBANDED_ORDER => 0u3;
                        esac;

                    msg = make_extra_request (req_set_clip_boxes, 2 * (list::length boxes));

                    put8      (msg,  1, ordering   );
                    put_xid   (msg,  4, gc_id      );
                    put_point (msg,  8, clip_origin);
                    put_boxes (msg, 12, boxes      );

                    msg;
                };

            fun encode_free_gc { gc_id }
                =
                make_resource_request (req_free_gc, gc_id);

            fun encode_clear_area { window_id, box, exposures }
                =
                {   msg = make_resource_request (req_clear_area, window_id);

                    put_bool (msg, 1, exposures);
                    put_box  (msg, 8, box      );

                    msg;
                };

            fun encode_copy_area { gc_id, from, to, from_point, size, to_point }
                =
                {   msg = make_resource_request (req_copy_area, from);

                    put_xid   (msg,  8, to        );
                    put_xid   (msg, 12, gc_id     );
                    put_point (msg, 16, from_point);
                    put_point (msg, 20, to_point  );
                    put_size  (msg, 24, size      );

                    msg;
                };

            fun encode_copy_plane { gc_id, from, to, from_point, size, to_point, plane }
                =
                {   msg = make_resource_request (req_copy_plane, from);

                    put_xid    (msg,  8, to                                        );
                    put_xid    (msg, 12, gc_id                                     );
                    put_point  (msg, 16, from_point                                );
                    put_point  (msg, 20, to_point                                  );
                    put_size   (msg, 24, size                                      );
                    put32      (msg, 28, large_unt::(<<) (0u1, unt::from_int plane));

                    msg;
                };


            stipulate

                fun encode_poly  req_info  { drawable, gc_id, relative, items }
                    =
                    {   msg = make_extra_request (req_info, list::length items);

                        put_bool   (msg,  1, relative);
                        put_xid    (msg,  4, drawable);
                        put_xid    (msg,  8, gc_id   );
                        put_points (msg, 12, items   );

                        msg;
                    };
            herein
                encode_poly_point =  encode_poly  req_poly_point;
                encode_poly_line  =  encode_poly  req_poly_line;
            end;


            stipulate

                fun encode (info, put_items, size) { drawable, gc_id, items }
                    =
                    {   msg = make_extra_request (info, size*(list::length items));

                        put_xid   (msg,  4, drawable);
                        put_xid   (msg,  8, gc_id   );
                        put_items (msg, 12, items   );

                        msg;
                    };

                put_segs
                    =
                    put_list
                        (  fn (buf, i, xg::LINE (p1, p2))
                               =
                               {   put_point (buf, i,   p1);
                                   put_point (buf, i+4, p2);
                               },
                           8
                        );

                put_arcs = put_list (put_arc, 12);

            herein
                encode_poly_segment   = encode (req_poly_segment,   put_segs,  2);
                encode_poly_box       = encode (req_poly_rectangle, put_boxes, 2);
                encode_poly_fill_box  = encode (req_poly_fill_box,  put_boxes, 2);
                encode_poly_arc       = encode (req_poly_arc,       put_arcs,  3);
                encode_poly_fill_arc  = encode (req_poly_fill_arc,  put_arcs,  3);
            end;

            fun encode_fill_poly { drawable, gc_id, shape, relative, points }
                =
                {   shape =  case shape
                                 #
                                 xt::COMPLEX_SHAPE   => 0u0;
                                 xt::NONCONVEX_SHAPE => 0u1;
                                 xt::CONVEX_SHAPE    => 0u2;
                             esac;

                    msg = make_extra_request (req_fill_poly, list::length points);

                    put_xid    (msg,  4, drawable);
                    put_xid    (msg,  8, gc_id   );
                    put8       (msg, 12, shape   );
                    put_bool   (msg, 13, relative);
                    put_points (msg, 16, points  );

                    msg;
                };

            stipulate
                fun put_image_format (buf, i, xt::XYBITMAP) =>  put8 (buf, i, 0u0);
                    put_image_format (buf, i, xt::XYPIXMAP) =>  put8 (buf, i, 0u1);
                    put_image_format (buf, i, xt::ZPIXMAP ) =>  put8 (buf, i, 0u2);
                end;
            herein
                fun encode_put_image { drawable, gc_id, depth, size, to, lpad, format, data }
                    =
                    {   n = w8v::length data;

                        msg = make_extra_request (req_put_image, (pad n) / 4);

                        put_image_format (msg,  1, format  );
                        put_xid          (msg,  4, drawable);
                        put_xid          (msg,  8, gc_id   );
                        put_size         (msg, 12, size    );
                        put_point        (msg, 16, to      );
                        put_signed8      (msg, 20, lpad    );
                        put_signed8      (msg, 21, depth   );
                        put_data         (msg, 24, data    );

                        msg;
                    };

                fun encode_get_image { drawable, box, plane_mask, format }
                    =
                    {   msg = make_resource_request (req_get_image, drawable);

                        put_image_format (msg,  1, format    );
                        put_box          (msg,  8, box       );
                        put_plane_mask   (msg, 16, plane_mask);

                        msg;
                    };
            end;

            stipulate
                fun textlen (                      NIL, n) =>  n;
                    textlen ((xt::FONT_ITEM _)     ! r, n) =>  textlen (r, n+5);
                    textlen ((xt::TEXT_ITEM(_, s)) ! r, n) =>  textlen (r, n+2+(string::length s));
                end;

                fun encode (itemlen, req_info) { drawable, gc_id, point, items }
                    =
                    {   fun put (msg, i, [])
                                =>
                                ();

                            put (msg, i, (xt::FONT_ITEM (xt::XID fid)) ! r)
                                =>
                                {   put8 (msg, i, 0u255);

                                    #  NOTE: unaligned(  is(  this ) ), so we have to do it byte-by-byte 

                                    put_word8 (msg, i+1, unt::(>>) (fid, 0u24));
                                    put_word8 (msg, i+2, unt::(>>) (fid, 0u16));
                                    put_word8 (msg, i+3, unt::(>>) (fid, 0u8));
                                    put_word8 (msg, i+4, fid);
                                    put (msg, i+5, r);
                                };

                            put (msg, i, (xt::TEXT_ITEM (delta, s)) ! r)
                                =>
                                {   n = itemlen s;

                                    if (n > 254)
                                       xgripe::impossible "excessive string in PolyText";

                                    fi;
                                    put_signed8 (msg, i, n);
                                    put_signed8 (msg, i+1, delta);
                                    put_string (msg, i+2, s);
                                    put (msg, i+2+(string::length s), r);
                                };
                        end;

                        l = textlen (items, 0);
                        p = pad l;

                        msg = make_extra_request (req_info, p / 4);

                        if (p != l)   put8 (msg, 16+l, 0u0);   fi;  /* Xlib does this */ 

                        put_xid   (msg,  4, drawable);
                        put_xid   (msg,  8, gc_id   );
                        put_point (msg, 12, point   );
                        put       (msg, 16, items   );

                        msg;
                    };
            herein
                encode_poly_text8  = encode (string::length, req_poly_text8);
                encode_poly_text16 = encode (fn s => ((string::length s) / 2); end, req_poly_text16);
            end;

            stipulate
                fun encode (textlen, req_info) { drawable, gc_id, point, string }
                    =
                    {   len =  string::length  string;

                        msg = make_extra_request (req_info, (pad len) / 4);

                        put_signed8 (msg,  1, textlen string);
                        put_xid     (msg,  4, drawable      );
                        put_xid     (msg,  8, gc_id         );
                        put_point   (msg, 12, point         );
                        put_string  (msg, 16, string        );

                        msg;
                    };
            herein
                encode_image_text8  =  encode (string::length, req_image_text8);
                encode_image_text16 =  encode (fn s = ((string::length s) / 2), req_image_text16);
            end;

            fun encode_create_colormap { cmap, window_id, visual, all_writable }
                =
                {   msg =  make_request  req_create_colormap;

                    put_bool (msg,  1, all_writable);
                    put_xid  (msg,  4, cmap        );
                    put_xid  (msg,  8, window_id   );
                    put_xid  (msg, 12, visual      );

                    msg;
                };

            fun encode_free_colormap { cmap }
                =
                make_resource_request (req_free_colormap, cmap);

            fun encode_copy_colormap_and_free { from, to }
                =
                {   msg = make_request  req_copy_colormap_and_free;

                    put_xid (msg, 4, to  );
                    put_xid (msg, 8, from);

                    msg;
                };

            fun encode_install_colormap   { cmap } =  make_resource_request (req_install_colormap,   cmap);
            fun encode_uninstall_colormap { cmap } =  make_resource_request (req_uninstall_colormap, cmap);

            fun encode_list_installed_colormaps { window_id }
                =
                make_resource_request (req_list_installed_colormaps, window_id);

            fun encode_alloc_color { cmap, color }
                =
                {   msg = make_request (req_alloc_color);

                    put_xid (msg, 4, cmap);
                    put_rgb (msg, 8, color);

                    msg;
                };

            fun encode_alloc_named_color { cmap, name }
                =
                {   n = string::length name;

                    msg = make_extra_request (req_alloc_named_color, (pad n) / 4);

                    put_xid      (msg,  4, cmap);
                    put_signed16 (msg,  8, n   );
                    put_string   (msg, 12, name);

                    msg;
                };

        /**************************************************************************************
            fun encodeAllocColorCells = let
                  msg = mkReq (reqAllocColorCells)
                  in
                    raise exception XERROR "unimplemented" # ** FIX **
                  end
            fun encodeAllocColorPlanes = let
                  msg = mkReq (reqAllocColorPlanes)
                  in
                    raise exception XERROR "unimplemented" # ** FIX **
                  end
        **************************************************************************************/

            fun encode_free_colors { cmap, plane_mask, pixels }
                =
                {   msg = make_extra_request (req_free_colors, list::length pixels);

                    put_xid        (msg,  4, cmap      );
                    put_plane_mask (msg,  8, plane_mask);
                    put_rgb8s      (msg, 12, pixels    );

                    msg;
                };

            stipulate

                fun put_color_item (buf, i, xt::COLORITEM { rgb8, red, green, blue } )
                    =
                    {   rmask = case red    NULL  => 0u0;  THE x => { put_word16 (buf, i+4, x); 0u1;};  esac;
                        gmask = case green  NULL  => 0u0;  THE x => { put_word16 (buf, i+6, x); 0u2;};  esac;
                        bmask = case blue   NULL  => 0u0;  THE x => { put_word16 (buf, i+8, x); 0u4;};  esac;

                        put_rgb8 (buf, i,    rgb8);
                        put8     (buf, i+10, one_byte_unt::bitwise_or (rmask, one_byte_unt::bitwise_or (gmask, bmask)));
                    };

                put_color_item_list
                    =
                    put_list (put_color_item, 12);

            herein

                fun encode_store_colors { cmap, items }
                    =
                    {   msg = make_extra_request (req_store_colors, 3*(list::length items));

                        put_xid             (msg, 4, cmap );
                        put_color_item_list (msg, 8, items);

                        msg;
                    };
            end;

            fun encode_store_named_color
                { cmap, name, pixel, do_red, do_green, do_blue }
                =
                {   n = string::length name;

                    mask =
                        one_byte_unt::bitwise_or
                          (
                            do_red       ?? 0u1
                                         :: 0u0,

                            one_byte_unt::bitwise_or
                              (
                                do_green ?? 0u2
                                         :: 0u0,

                                do_blue  ?? 0u4
                                         :: 0u0
                              )
                          );

                    msg = make_extra_request (req_store_named_color, (pad n) / 4);


                    put8       (msg,  1, mask );
                    put_xid    (msg,  4, cmap );
                    put_rgb8   (msg,  8, pixel);
                    put_string (msg, 12, name );

                    msg;
                };

            fun encode_query_colors { cmap, pixels }
                =
                {   msg = make_extra_request (req_query_colors, list::length pixels);

                    put_xid    (msg, 4, cmap  );
                    put_rgb8s (msg, 8, pixels);

                    msg;
                };

            fun encode_lookup_color { cmap, name }
                =
                {   n = string::length name;

                    msg = make_extra_request (req_lookup_color, (pad n) / 4);

                    put_xid      (msg,  4, cmap);
                    put_signed16 (msg,  8, n   );
                    put_string   (msg, 12, name);

                    msg;
                };

            fun encode_create_cursor { cursor, from, mask, foreground_rgb, background_rgb, hot_spot }
                =
                {   msg = make_request (req_create_cursor);

                    put_xid        (msg,  4, cursor        );
                    put_xid        (msg,  8, from          );
                    put_xid_option (msg, 12, mask          );
                    put_rgb        (msg, 16, foreground_rgb);
                    put_rgb        (msg, 22, background_rgb);
                    put_point      (msg, 24, hot_spot      );

                    msg;
                };

            fun encode_create_glyph_cursor
                { cursor, src_font, mask_font, src_chr, mask_chr, foreground_rgb, background_rgb }
                =
                {   msg = make_request (req_create_glyph_cursor);

                    put_xid        (msg,  4, cursor        );
                    put_xid        (msg,  8, src_font      );
                    put_xid_option (msg, 12, mask_font     );
                    put_signed16   (msg, 16, src_chr       );
                    put_signed16   (msg, 18, mask_chr      );
                    put_rgb        (msg, 20, foreground_rgb);
                    put_rgb        (msg, 26, background_rgb);

                    msg;
                };

            fun encode_free_cursor { cursor }
                =
                make_resource_request (req_free_cursor, cursor);

            fun encode_recolor_cursor { cursor, foreground_color, background_color }
                =
                {   msg = make_request req_recolor_cursor;

                    put_xid (msg,  4, cursor          );
                    put_rgb (msg,  8, foreground_color);
                    put_rgb (msg, 14, background_color);

                    msg;
                };

            fun encode_query_best_size { ilk, drawable, size }
                =
                {   ilk =  case ilk
                               #
                               xt::CURSOR_SHAPE  =>  0u0;
                               xt::TILE_SHAPE    =>  0u1;
                               xt::STIPPLE_SHAPE =>  0u2;
                           esac;


                    msg =  make_request  req_query_best_size;

                    put8     (msg, 1, ilk     );
                    put_xid  (msg, 4, drawable);
                    put_size (msg, 8, size    );

                    msg;
                };

            fun encode_query_extension name
                =
                {   n = string::length name;

                    msg = make_extra_request (req_query_extension, (pad n) / 4);

                    put_signed16 (msg, 4, n   );
                    put_string   (msg, 8, name);

                    msg;
                };

        /**************************************************************************************
            fun encodeChangeKeyboardMapping = let
                  msg = mkReq (reqChangeKeyboardMapping)
                  in
                    raise exception XERROR "unimplemented" # ** FIX **
                  end
        **************************************************************************************/

            fun encode_get_keyboard_mapping { first=>(xt::KEYCODE k), count }
                =
                {   msg = make_request req_get_keyboard_mapping;

                    put_signed8 (msg, 4, k    );
                    put_signed8 (msg, 5, count);

                    msg;
                };

            fun encode_change_keyboard_control { vals }
                =
                {   my (nvals, mask, vals)
                        =
                        make_value_list  vals;

                    msg = make_extra_request (req_change_keyboard_control, nvals);

                    put_val_list (msg, 4, mask, vals);

                    msg;
                };

            fun encode_bell { percent }
                =
                {   msg =  make_request  req_bell;

                    put_signed8 (msg, 1, percent);

                    msg;
                };

            fun encode_change_pointer_control { acceleration, threshold }
                =
                {   msg =  make_request  req_change_pointer_control;

                    case acceleration
                        #
                        NULL =>
                            put_bool (msg, 10, FALSE);
                        #
                        THE { numerator, denominator }
                            =>
                            {   put_bool (msg, 10, TRUE);
                                put_signed16 (msg, 4, numerator);
                                put_signed16 (msg, 6, denominator);
                            };
                    esac;

                    case threshold
                        #
                        NULL =>
                            put_bool (msg, 11, FALSE);
                        #
                        THE threshold
                            =>
                            {   put_bool     (msg, 11, FALSE);
                                put_signed16 (msg, 8, threshold);
                            };
                    esac;

                    msg;
                };

            fun encode_set_screen_saver
                { timeout, interval, prefer_blanking, allow_exposures }
                =
                {   msg =  make_request  req_set_screen_saver;

                    fun put (msg, i, NULL ) =>  put8     (msg, i, 0u2);
                        put (msg, i, THE b) =>  put_bool (msg, i, b  );
                    end;

                    put_signed16 (msg, 4, timeout        );
                    put_signed16 (msg, 6, interval       );
                    put          (msg, 8, prefer_blanking);
                    put          (msg, 9, allow_exposures);

                    msg;
                };

            fun encode_change_hosts { host, remove }
                =
                {   my (family, address)
                        =
                        case host
                            (xt::INTERNET_HOST s) => (0u0, s);
                            (xt::DECNET_HOST   s) => (0u1, s);
                            (xt::CHAOS_HOST    s) => (0u2, s);
                        esac;

                    len = string::length address;

                    msg = make_extra_request (req_change_hosts, (pad len) / 4);

                    put_bool     (msg, 1, remove );
                    put8         (msg, 4, family );
                    put_signed16 (msg, 6, len    );
                    put_string   (msg, 8, address);

                    msg;
                };

            fun encode_set_access_control { enable }
                =
                {   msg = make_request (req_set_access_control);

                    put_bool (msg, 1, enable);
                    msg;
                };

            fun encode_set_close_down_mode { mode }
                =
                {   mode = case mode
                               #
                               xt::DESTROY_ALL      => 0u0;
                               xt::RETAIN_PERMANENT => 0u1;
                               xt::RETAIN_TEMPORARY => 0u2;
                           esac;

                    msg = make_request (req_set_close_down_mode);

                    put8 (msg, 1, mode);

                    msg;
                };

            fun encode_kill_client { resource }
                =
                {   rid = case resource    NULL  =>  xt::XID 0u0;
                                           THE x =>  x;
                          esac;

                    make_resource_request (req_kill_client, rid);
                };

            fun encode_rotate_properties { window_id, delta, properties }
                =
                {   n = list::length properties;

                    msg = make_extra_request (req_rotate_properties, n);

                    put_xid                (msg,  4, window_id );
                    put_signed16           (msg,  8, n         );
                    put_signed16           (msg, 10, delta     );
                    put_list (put_atom, 4) (msg, 12, properties);

                    msg;
                };

            fun encode_force_screen_saver { activate }
                =
                {   msg =  make_request  req_force_screen_saver;

                    put_bool (msg, 1, activate);

                    msg;
                };

        /**************************************************************************************
            fun encodeSetPointerMapping = let
                  msg = mkReq (reqSetPointerMapping)
                  in
                    raise exception XERROR "unimplemented" # ** FIX **
                  end
            fun encodeGetPointerMapping = let
                  msg = mkReq (reqGetPointerMapping)
                  in
                    raise exception XERROR "unimplemented" # ** FIX **
                  end
            fun encodeSetModifierMapping = let
                  msg = mkExtraReq (reqSetModifierMapping, ?)
                  in
                    raise exception XERROR "unimplemented" # ** FIX **
                  end
        **************************************************************************************/

            # Fixed requests 
            #
            request_no_operation         =  make_request  req_no_operation;
            request_get_input_focus      =  make_request  req_get_input_focus;
            request_query_keymap         =  make_request  req_query_keymap;
            request_grab_server          =  make_request  req_grab_server;
            request_ungrab_server        =  make_request  req_ungrab_server;
            request_get_font_path        =  make_request  req_get_font_path;
            request_list_extensions      =  make_request  req_list_extensions;
            request_get_keyboard_control =  make_request  req_get_keyboard_control;
            request_get_pointer_control  =  make_request  req_get_pointer_control;
            request_get_screen_saver     =  make_request  req_get_screen_saver;
            request_list_hosts           =  make_request  req_list_hosts;
            request_get_modifier_mapping =  make_request  req_get_modifier_mapping;

        end;                            # stipulate
    };                                  # package xrequest
end;






Comments and suggestions to: bugs@mythryl.org

PreviousUpNext