/wrap_xlib.c

Large files files are truncated, but you can click here to view the full file

/* OCaml bindings for the Xlib library.
 * Copyright (C) 2008, 2009, 2010 by Florent Monnier
 * Contact: <fmonnier@linux-nantes.org>
 *
 * OCaml-Xlib is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published
 * by the Free Software Foundation, either version 3 of the License,
 * or (at your option) any later version.
 *
 * OCaml-Xlib is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with OCaml-Xlib.  If not, see:
 * <http://www.gnu.org/licenses/>
 */

// {{{ Headers 

#include <X11/Xlib.h>
#include <X11/Xutil.h>

#include <stdlib.h>
#include <stdio.h>
#include <string.h>

#define CAML_NAME_SPACE 1

#include <caml/mlvalues.h>
#include <caml/memory.h>
#include <caml/alloc.h>
#include <caml/bigarray.h>
#include <caml/custom.h>
#include <caml/fail.h>
#include <caml/callback.h>

// }}}

#include "wrap_xlib.h"

// {{{ caml allocs 

custom_ops(XEvent);
custom_ops(XColor);
custom_ops(XGCValues);
custom_ops(XSetWindowAttributes);
custom_ops(XWindowAttributes);
custom_ops(XSizeHints);
custom_ops(XVisualInfo);
custom_ops(XChar2b);
custom_ops_n(XChar2b);

// }}}
// {{{ XID's 

#define Drawable_val(v) (XID_val(Drawable,(v)))
#define Val_Drawable(xid) (Val_XID((xid)))

#define Cursor_val(v) (XID_val(Cursor,(v)))
#define Val_Cursor(xid) (Val_XID((xid)))

#define Colormap_val(v) (XID_val(Colormap,(v)))
#define Val_Colormap(xid) (Val_XID((xid)))

#define GContext_val(v) (XID_val(GContext,(v)))
#define Val_GContext(xid) (Val_XID((xid)))

//#define KeySym_val(v) (XID_val(KeySym,(v)))
//#define Val_KeySym(xid) (Val_XID((xid)))
/* Get keysyms values instead of an abstract type */
#define Val_keysym Val_int
#define Keysym_val Long_val

// }}}
// {{{ return status 

#define DO_CHECK_RETURN_STATUS 1
#if DO_CHECK_RETURN_STATUS

#define GET_STATUS  int status =
#define CHECK_STATUS(fun,st) \
    do{ if (status != st) caml_failwith(#fun ": wrong return status"); }while(0)

#else

#define GET_STATUS (void)
#define CHECK_STATUS

#endif

/* Many GET/CHECK STATUS are commented just because in
 * the source code of the Xlib implementation I use (XOrg)
 * the return status is just static and can only return one
 * value, so testing it is meaningless.
 * They are kept commented in case they are meaningfull in
 * an other implementation.
 *
 * Sometime the return value meaning a success is 1 and sometime 0,
 * even in the commented GET/CHECK_STATUS the value is the good one.
 */

// }}}
// {{{ GC 

// Handle the finalisation of GC's (other than the default one)

#define GC_val(gc_pair) ((GC) Field((gc_pair),0))

#define Display_of_GC(gc_pair) (Field((gc_pair),1))

void Finalize_GC( value gc )
{
    value dpy = Display_of_GC(gc);
    if (display_is_open(dpy)) {
        GET_STATUS  XFreeGC(     
            Display_val(dpy),
            GC_val(gc)
        );
        CHECK_STATUS(XFreeGC,1);
    }
}
CAMLprim value do_finalize_GC( value gc ) {
    Finalize_GC( gc );
    return Val_unit;
}

/*
static struct custom_operations fgc_custom_ops = {
    identifier: "GC handling",
    finalize:  Finalize_GC,
    compare:     custom_compare_default,
    hash:        custom_hash_default,
    serialize:   custom_serialize_default,
    deserialize: custom_deserialize_default
};
*/

// The finalised one
static inline value Val_GC_final(GC gc, value dpy)
{
    CAMLparam1( dpy );
    CAMLlocal1( fgc );
    //fgc = caml_alloc_custom( &fgc_custom_ops, 2 * sizeof(value), 0, 1);
      // the previous line segfaults
      // so the link is done with do_finalize_GC from the ocaml side
      fgc = caml_alloc(2, 0);
    Store_field( fgc, 0, ((value)(gc)) );
    Store_field( fgc, 1, dpy );
    CAMLreturn( fgc );
}

// Not finalised (for default gc)
static inline value Val_GC(GC gc, value dpy)
{
    CAMLparam1( dpy );
    CAMLlocal1( gcp );
    gcp = caml_alloc(2, 0);
    Store_field( gcp, 0, ((value)(gc)) );
    Store_field( gcp, 1, dpy );
    CAMLreturn( gcp );
}

// }}}
// {{{ Event-Masks 

static const long event_mask_table[] = {
    KeyPressMask,
    KeyReleaseMask,
    ButtonPressMask,
    ButtonReleaseMask,
    EnterWindowMask,
    LeaveWindowMask,
    PointerMotionMask,
    PointerMotionHintMask,
    Button1MotionMask,
    Button2MotionMask,
    Button3MotionMask,
    Button4MotionMask,
    Button5MotionMask,
    ButtonMotionMask,
    KeymapStateMask,
    ExposureMask,
    VisibilityChangeMask,
    StructureNotifyMask,
    ResizeRedirectMask,
    SubstructureNotifyMask,
    SubstructureRedirectMask,
    FocusChangeMask,
    PropertyChangeMask,
    ColormapChangeMask,
    OwnerGrabButtonMask,
};

static inline long
Eventmask_val( value em_list )
{
    long event_mask = 0;
    while ( em_list != Val_emptylist )
    {
        value head = Field(em_list, 0);
        long mask = event_mask_table[Long_val(head)];
        event_mask |= mask;
        em_list = Field(em_list, 1);
    }
    return event_mask;
}

// }}}
// {{{ macro/funcs 

/* switch this to use the macros or the functions */
//#define XMP(f) X##f  // use the functions
#define XMP(f) f   // use the macros


#define _xConnectionNumber  XMP(ConnectionNumber)
#define _xRootWindow        XMP(RootWindow)
#define _xDefaultScreen     XMP(DefaultScreen)
#define _xDefaultRootWindow XMP(DefaultRootWindow)
#define _xDefaultVisual     XMP(DefaultVisual)
#define _xDefaultGC         XMP(DefaultGC)
#define _xBlackPixel        XMP(BlackPixel)
#define _xWhitePixel        XMP(WhitePixel)

#define _xDisplayWidth      XMP(DisplayWidth)
#define _xDisplayHeight     XMP(DisplayHeight)

#define _xDisplayPlanes     XMP(DisplayPlanes)
#define _xDisplayCells      XMP(DisplayCells)
#define _xScreenCount       XMP(ScreenCount)
#define _xServerVendor      XMP(ServerVendor)
#define _xProtocolVersion   XMP(ProtocolVersion)
#define _xProtocolRevision  XMP(ProtocolRevision)
#define _xVendorRelease     XMP(VendorRelease)
#define _xDisplayString     XMP(DisplayString)
#define _xDefaultDepth      XMP(DefaultDepth)
#define _xDefaultColormap   XMP(DefaultColormap)
#define _xBitmapUnit        XMP(BitmapUnit)
#define _xBitmapBitOrder    XMP(BitmapBitOrder)
#define _xBitmapPad         XMP(BitmapPad)
#define _xImageByteOrder    XMP(ImageByteOrder)

#define _xBitmapUnit        XMP(BitmapUnit)


#define _xScreenOfDisplay         XMP(ScreenOfDisplay)
#define _xDefaultScreenOfDisplay  XMP(DefaultScreenOfDisplay)
#define _xDisplayOfScreen         XMP(DisplayOfScreen)
#define _xRootWindowOfScreen      XMP(RootWindowOfScreen)
#define _xBlackPixelOfScreen      XMP(BlackPixelOfScreen)
#define _xWhitePixelOfScreen      XMP(WhitePixelOfScreen)
#define _xDefaultColormapOfScreen XMP(DefaultColormapOfScreen)
#define _xDefaultDepthOfScreen    XMP(DefaultDepthOfScreen)
#define _xDefaultGCOfScreen       XMP(DefaultGCOfScreen)
#define _xDefaultVisualOfScreen   XMP(DefaultVisualOfScreen)
#define _xWidthOfScreen           XMP(WidthOfScreen)
#define _xHeightOfScreen          XMP(HeightOfScreen)
#define _xWidthMMOfScreen         XMP(WidthMMOfScreen)
#define _xHeightMMOfScreen        XMP(HeightMMOfScreen)
#define _xPlanesOfScreen          XMP(PlanesOfScreen)
#define _xCellsOfScreen           XMP(CellsOfScreen)
#define _xMinCmapsOfScreen        XMP(MinCmapsOfScreen)
#define _xMaxCmapsOfScreen        XMP(MaxCmapsOfScreen)
#define _xDoesSaveUnders          XMP(DoesSaveUnders)
#define _xDoesBackingStore        XMP(DoesBackingStore)
#define _xEventMaskOfScreen       XMP(EventMaskOfScreen)


// }}}
// {{{ ints 

// wraps unsigned long
#define Pixel_color_val  Unsigned_long_val
#define Val_pixel_color  Val_long

// type 'Time' defined in X.h (unsigned long / CARD32)
// use int64 instead of int32 because the max value of unsigned is twice
// (ocaml int32 is signed)
#define Val_time  caml_copy_int64
#define Time_val(t)  ((Time)Int64_val(t))

// same value than Int64.max_int (used to check Time overflow)
// (not used anymore, while CARD32 can not overflow a signed int64)
#define MAX_INT64  9223372036854775807L

// }}}
// {{{ Atom 

#define Val_Atom(v) ((value)(v))
#define Atom_val(v) ((Atom)(v))
#define Atom_val_addr(v) ((Atom *)(&v))

// }}}
// {{{ KeyCode 

/* There's no real uniformity about the type keycode,
   - in structures it is most often (int) and sometimes (unsigned int)
   - in functions sometimes there is the NeedWidePrototypes switch
     which switches between (unsigned int) and (unsigned char)
   - in functions sometimes it is just (int) as parameter 
     or (int *) if it's a returned value

   However as it handles a code for each key of the keyboard, and that generally
   keyboards have about 105 keys, it seems that it does not really matter.
*/

#define Val_KeyCode Val_long
#define KeyCode_val Long_val

// }}}
// {{{ caml_copy_string_array_n() 

// The list provided to caml_copy_string_array() needs to be NULL terminated
static value caml_copy_string_array_n(char **strl, int n)
{
    CAMLlocal1(ret);
    char const **param;
    int i;
    param = malloc((n+1) * sizeof(char *));
    for (i=0; i<n; i++) {
        param[i] = strl[i];
    }
    param[n] = NULL;  // here the point
    ret = caml_copy_string_array(param);
    free(param);
    return ret;
}
// }}}


// TODO: XGetErrorText()
#if 0
int ErrorHandler( Display *dpy, XErrorEvent *event )
{   
    char buffer[BUFSIZ];
    XGetErrorText(dpy, event->error_code, buffer, BUFSIZ);
    /*
    event->request_code;
    event->minor_code;
    event->resourceid;
    event->serial;
    */
    printf("ERROR: %s\n", buffer);
    return 0;
} 

CAMLprim value
ml_XSetErrorHandler( value unit )
{
    XSetErrorHandler( ErrorHandler );
    return Val_unit;
}
#endif


int ErrorHandler_closure( Display *dpy, XErrorEvent *event )
{
    CAMLlocal1( ml_event );
    static value * closure_f = NULL;
    if (closure_f == NULL) {
        closure_f = caml_named_value("Error Handler Callback");
    }
    copy_XEvent( event, ml_event );
    caml_callback2( *closure_f, Val_Display(dpy), ml_event );
    return 0;
}
CAMLprim value
ml_XSetErrorHandler( value unit ) {
    XSetErrorHandler(ErrorHandler_closure);
    return Val_unit;
}




CAMLprim value
ml_XlibSpecificationRelease( value unit )
{
    return Val_int(XlibSpecificationRelease);
}

CAMLprim value
ml_XOpenDisplay( value display_name )
{
    Display *dpy;
    dpy = XOpenDisplay( String_val(display_name) );
    if (dpy == NULL) {
        caml_failwith("Cannot open display");
    }
    return Val_Display(dpy);
}

CAMLprim value
ml_XCloseDisplay( value dpy )
{
    XCloseDisplay( Display_val(dpy) );
    display_record_closed(dpy);
    return Val_unit;
}

CAMLprim value
ml_XFlush( value dpy )
{
    GET_STATUS  XFlush( Display_val(dpy) );
    CHECK_STATUS(XFlush, 1);
    return Val_unit;
}

CAMLprim value
ml_XBell( value dpy, value percent )
{
    //GET_STATUS
    XBell(
        Display_val(dpy),
        Int_val(percent)
    );
    //CHECK_STATUS(XBell,1);
    return Val_unit;
}

static const int close_mode_table[] = {
    DestroyAll,
    RetainPermanent,
    RetainTemporary,
};
#define Close_mode_val(i) (close_mode_table[Long_val(i)])

CAMLprim value
ml_XSetCloseDownMode( value dpy, value close_mode )
{
    //GET_STATUS
    XSetCloseDownMode(
        Display_val(dpy),
        Close_mode_val(close_mode)
    );
    //CHECK_STATUS(XSetCloseDownMode,1);
    return Val_unit;
}

CAMLprim value
ml_XSync( value dpy, value discard )
{
    //GET_STATUS
    XSync(
        Display_val(dpy),
        Bool_val(discard)
    );
    //CHECK_STATUS(XSync,1);
    return Val_unit;
}


CAMLprim value
ml_XGrabServer( value dpy )
{
    //GET_STATUS
    XGrabServer( 
        Display_val(dpy)
    );
    //CHECK_STATUS(XGrabServer,1);
    return Val_unit;
}

CAMLprim value
ml_XUngrabServer( value dpy )
{
    //GET_STATUS
    XUngrabServer( 
        Display_val(dpy)
    );
    //CHECK_STATUS(XUngrabServer,1);
    return Val_unit;
}

CAMLprim value
ml_XUngrabPointer( value dpy, value time )
{
    //GET_STATUS
    XUngrabPointer(
        Display_val(dpy),
        Time_val(time)
    );
    //CHECK_STATUS(XUngrabPointer,1);
    return Val_unit;
}

CAMLprim value
ml_XUngrabKeyboard( value dpy, value time )
{
    //GET_STATUS
    XUngrabKeyboard(
        Display_val(dpy),
        Time_val(time)
    );
    //CHECK_STATUS(XUngrabKeyboard,1);
    return Val_unit;
}

CAMLprim value
ml_XConnectionNumber( value dpy )
{
    return Val_int( XConnectionNumber( Display_val(dpy) ));
}

CAMLprim value
ml_XDefaultScreen( value dpy )
{
    int screen_number = _xDefaultScreen( Display_val(dpy) );
    return Val_screenNB(screen_number);
}

CAMLprim value
ml_XScreenCount( value dpy )
{
    return Val_int( _xScreenCount( Display_val(dpy) ));
}

CAMLprim value
ml_XDefaultRootWindow( value dpy )
{
    return Val_Window( _xDefaultRootWindow( Display_val(dpy) ));
}

CAMLprim value
ml_XDefaultVisual( value dpy, value screen_number )
{
    Visual * vis = _xDefaultVisual(
        Display_val(dpy),
        ScreenNB_val(screen_number) );
    return Val_Visual(vis);
}

CAMLprim value ml_Visual_visualid( value visual ) {
    return Val_VisualID( Visual_val(visual)->visualid );
}

CAMLprim value ml_Visual_map_entries( value visual ) {
    return Val_int( Visual_val(visual)->map_entries );
}

CAMLprim value ml_Visual_bits_per_rgb( value visual ) {
    return Val_int( Visual_val(visual)->bits_per_rgb );
}

CAMLprim value ml_Visual_red_mask( value visual ) {
    return Val_long( Visual_val(visual)->red_mask );
}

CAMLprim value ml_Visual_green_mask( value visual ) {
    return Val_long( Visual_val(visual)->green_mask );
}

CAMLprim value ml_Visual_blue_mask( value visual ) {
    return Val_long( Visual_val(visual)->blue_mask );
}


CAMLprim value
ml_XDefaultDepth( value dpy, value screen_number )
{
    int depth = _xDefaultDepth(
        Display_val(dpy),
        ScreenNB_val(screen_number) );
    return Val_int(depth);
}

CAMLprim value
ml_XListDepths( value dpy, value screen_number )
{
    CAMLparam2(dpy, screen_number);
    CAMLlocal1(ml_depths);

    int i, count;
    int *depths = XListDepths(
        Display_val(dpy),
        ScreenNB_val(screen_number),
        &count
    );

    ml_depths = caml_alloc(count, 0);
    for (i=0; i<count; ++i) {
        Store_field( ml_depths, i, Val_int(depths[i]) );
    }
    XFree(depths);

    CAMLreturn(ml_depths);
}

CAMLprim value
ml_XDisplayPlanes( value dpy, value screen_number )
{
    int depth = _xDisplayPlanes(
        Display_val(dpy),
        ScreenNB_val(screen_number) );
    return Val_int(depth);
}

CAMLprim value
ml_XDefaultColormap( value dpy, value screen_number )
{
    Colormap colormap = _xDefaultColormap(
        Display_val(dpy),
        ScreenNB_val(screen_number) );
    return Val_Colormap(colormap);
}

CAMLprim value
ml_XDisplayCells( value dpy, value screen_number )
{
    int cells = _xDisplayCells(
        Display_val(dpy),
        ScreenNB_val(screen_number) );
    return Val_int(cells);
}

CAMLprim value
ml_XBitmapUnit( value dpy )
{
    return Val_int( _xBitmapUnit( Display_val(dpy) ));
}

CAMLprim value
ml_XBitmapPad( value dpy )
{
    return Val_int( _xBitmapPad( Display_val(dpy) ));
}

CAMLprim value
ml_XProtocolVersion( value dpy )
{
    return Val_int( _xProtocolVersion( Display_val(dpy) ));
}

CAMLprim value
ml_XProtocolRevision( value dpy )
{
    return Val_int( _xProtocolRevision( Display_val(dpy) ));
}

CAMLprim value
ml_XVendorRelease( value dpy )
{
    return Val_int( _xVendorRelease( Display_val(dpy) ));
}

CAMLprim value
ml_XServerVendor( value dpy )
{
    char * vendor = _xServerVendor( Display_val(dpy) );
    return caml_copy_string(vendor);
}

CAMLprim value
ml_XBlackPixel( value dpy, value screen_number )
{
    unsigned long color = _xBlackPixel(
        Display_val(dpy),
        ScreenNB_val(screen_number) );
    return Val_pixel_color(color);
}

CAMLprim value
ml_XWhitePixel( value dpy, value screen_number )
{
    unsigned long color = _xWhitePixel(
        Display_val(dpy),
        ScreenNB_val(screen_number) );
    return Val_pixel_color(color);
}

CAMLprim value
ml_XDisplayWidth( value dpy, value screen_number )
{
    int width = _xDisplayWidth(
        Display_val(dpy),
        ScreenNB_val(screen_number) );
    return Val_int(width);
}

CAMLprim value
ml_XDisplayHeight( value dpy, value screen_number )
{
    int height = _xDisplayHeight(
        Display_val(dpy),
        ScreenNB_val(screen_number) );
    return Val_int(height);
}

CAMLprim value
ml_XRootWindow( value dpy, value screen_number )
{
    Window win = _xRootWindow(
        Display_val(dpy),
        ScreenNB_val(screen_number) );
    return Val_Window(win);
}

CAMLprim value
ml_XDefaultGC( value dpy, value screen_number )
{
    GC gc = _xDefaultGC(
        Display_val(dpy),
        ScreenNB_val(screen_number) );
    return Val_GC(gc,dpy);
}

/* {{{ XColor */

CAMLprim value
ml_alloc_XColor( value unit )
{
    CAMLparam0();
    CAMLlocal1(x_color);
    alloc_XColor(x_color);
    memset(XColor_val(x_color), 0, sizeof(XColor));
    CAMLreturn(x_color);
}

CAMLprim value
ml_XAllocNamedColor( value dpy, value colormap, value color_name )
{
    CAMLparam3(dpy, colormap, color_name);
    CAMLlocal3(xcolor_pair, screen_def, exact_def);

    alloc_XColor(screen_def);
    alloc_XColor(exact_def);

    //GET_STATUS
    XAllocNamedColor(
        Display_val(dpy),
        Colormap_val(colormap),
        String_val(color_name),
        XColor_val(screen_def),
        XColor_val(exact_def)
    );
    //CHECK_STATUS(XAllocNamedColor,1);

    xcolor_pair = caml_alloc(2, 0);
    Store_field( xcolor_pair, 0, screen_def );
    Store_field( xcolor_pair, 1, exact_def );
    CAMLreturn(xcolor_pair);
}

CAMLprim value
ml_XColor_set_red( value x_color, value v )
{
    XColor * xcolor = XColor_val(x_color);
    xcolor->red = Long_val(v);
    return Val_unit;
}

CAMLprim value
ml_XColor_set_green( value x_color, value v )
{
    XColor * xcolor = XColor_val(x_color);
    xcolor->green = Long_val(v);
    return Val_unit;
}

CAMLprim value
ml_XColor_set_blue( value x_color, value v )
{
    XColor * xcolor = XColor_val(x_color);
    xcolor->blue = Long_val(v);
    return Val_unit;
}

CAMLprim value
ml_XColor_set_rgb( value x_color, value r, value g, value b )
{
    XColor * xcolor = XColor_val(x_color);
    xcolor->red = Long_val(r);
    xcolor->green = Long_val(g);
    xcolor->blue = Long_val(b);
    return Val_unit;
}


static const char color_flags_table[] = {
    DoRed,
    DoGreen,
    DoBlue,
};

CAMLprim value
ml_XColor_set_flags( value x_color, value mask_list )
{
    XColor * xcolor = XColor_val(x_color);

    while ( mask_list != Val_emptylist )
    {
        value head = Field(mask_list, 0);
        xcolor->flags |= color_flags_table[Long_val(head)];
        mask_list = Field(mask_list, 1);
    }
    return Val_unit;
}

CAMLprim value
ml_XAllocColor( value dpy, value colormap, value x_color )
{
    XColor * xcolor = XColor_val(x_color);
    XAllocColor( Display_val(dpy), Colormap_val(colormap), xcolor );
    return Val_unit;
}

CAMLprim value
ml_XAllocColorCells(
        value dpy,
        value colormap,
        value contig,
        value nplanes,
        value npixels )
{
    CAMLparam5(dpy, colormap, contig, nplanes, npixels);
    CAMLlocal3(ret, pixels_arr, plnmsk_arr);
    unsigned long *pixels = NULL;
    unsigned long *plane_masks = NULL;
    long i;

    pixels = malloc(UInt_val(npixels) * sizeof(unsigned long));
    if (pixels == NULL) {
      caml_failwith("xAllocColorCells: out of memory");
    }

    plane_masks = malloc(UInt_val(nplanes) * sizeof(unsigned long));
    if (plane_masks == NULL) {
      free(pixels);
      caml_failwith("xAllocColorCells: out of memory");
    }

    Status status = XAllocColorCells(
        Display_val(dpy),
        Colormap_val(colormap),
        Bool_val(contig),
        plane_masks,
        UInt_val(nplanes),
        pixels,
        UInt_val(npixels)
    );
    if (!status) {
      free(pixels);
      free(plane_masks);
      caml_failwith("xAllocColorCells: "
                    "can't alloc enough colors in the current color map");
    }

    pixels_arr = caml_alloc(UInt_val(npixels), 0);
    for (i=0; i < UInt_val(npixels); ++i)
    {
        Store_field( pixels_arr, i, Val_ulong(pixels[i]) );
    }
    free(pixels);

    plnmsk_arr = caml_alloc(UInt_val(nplanes), 0);
    for (i=0; i < UInt_val(nplanes); ++i)
    {
        Store_field( plnmsk_arr, i, Val_ulong(plane_masks[i]) );
    }
    free(plane_masks);

    ret = caml_alloc(2, 0);
    Store_field(ret, 0, pixels_arr );
    Store_field(ret, 1, plnmsk_arr );
    CAMLreturn(ret);
}

CAMLprim value
ml_XAllocColorCellsPixels(
        value dpy,
        value colormap,
        value contig,
        value npixels )
{
    CAMLparam4(dpy, colormap, contig, npixels);
    CAMLlocal1(pixels_arr);
    unsigned long *pixels = NULL;
    long i;
    pixels = malloc(UInt_val(npixels) * sizeof(unsigned long));
    if (pixels == NULL) caml_failwith("xAllocColorCells: out of memory");

    Status status = XAllocColorCells(
        Display_val(dpy),
        Colormap_val(colormap),
        Bool_val(contig),
        NULL, 0,
        pixels,
        UInt_val(npixels)
    );
    if (!status) {
      free(pixels);
      caml_failwith("xAllocColorCells: "
                    "can't alloc enough colors in the current color map");
    }

    pixels_arr = caml_alloc(UInt_val(npixels), 0);
    for (i=0; i < UInt_val(npixels); ++i)
    {
        Store_field( pixels_arr, i, Val_ulong(pixels[i]) );
    }
    free(pixels);

    CAMLreturn(pixels_arr);
}

CAMLprim value
ml_XColor_pixel( value x_color )
{
    XColor * xcolor = XColor_val(x_color);
    return Val_pixel_color(xcolor->pixel);
}

CAMLprim value
ml_XColor_set_pixel( value x_color, value pixel_color )
{
    XColor * xcolor = XColor_val(x_color);
    xcolor->pixel = Pixel_color_val(pixel_color);
    return Val_unit;
}

CAMLprim value
ml_XQueryColor( value dpy, value colormap, value x_color )
{
    XQueryColor(
        Display_val(dpy),
        Colormap_val(colormap),
        XColor_val(x_color)
    );
    return Val_unit;
}

CAMLprim value
ml_XColor_get_red( value x_color )
{
    XColor * xcolor = XColor_val(x_color);
    return Val_long(xcolor->red);
}

CAMLprim value
ml_XColor_get_green( value x_color )
{
    XColor * xcolor = XColor_val(x_color);
    return Val_long(xcolor->green);
}

CAMLprim value
ml_XColor_get_blue( value x_color )
{
    XColor * xcolor = XColor_val(x_color);
    return Val_long(xcolor->blue);
}

CAMLprim value
ml_XColor_get_rgb( value x_color )
{
    CAMLparam1(x_color);
    CAMLlocal1(rgb);
    XColor * xcolor = XColor_val(x_color);
    rgb = caml_alloc(3, 0);
    Store_field( rgb, 0, Val_long(xcolor->red) );
    Store_field( rgb, 1, Val_long(xcolor->green) );
    Store_field( rgb, 2, Val_long(xcolor->blue) );
    CAMLreturn(rgb);
}

/* }}} */

CAMLprim value
ml_XCreateSimpleWindow( value dpy, value parent, value x, value y,
                        value width, value height, value border_width,
                        value border, value background)
{
    Window win = XCreateSimpleWindow(
        Display_val(dpy),
        Window_val(parent),
        Int_val(x),
        Int_val(y),
        UInt_val(width),
        UInt_val(height),
        UInt_val(border_width),
        Pixel_color_val(border),
        Pixel_color_val(background) );
    return Val_Window(win);
}
CAMLprim value
ml_XCreateSimpleWindow_bytecode( value * argv, int argn )
{
    return ml_XCreateSimpleWindow( argv[0], argv[1], argv[2], argv[3],
                                   argv[4], argv[5], argv[6], argv[7], argv[8] );
}

CAMLprim value
ml_XDestroyWindow( value dpy, value win )
{
    GET_STATUS  XDestroyWindow(
        Display_val(dpy),
        Window_val(win) );
    CHECK_STATUS(XDestroyWindow, 1);
    return Val_unit;
}

CAMLprim value
caml_get_xid(value xid)
{
    return Val_XID(Long_val(xid));
}


CAMLprim value
ml_alloc_XVisualInfo( value unit )
{
    CAMLparam0();
    CAMLlocal1(visInfo);
    alloc_XVisualInfo(visInfo);
    memset(XVisualInfo_val(visInfo), 0, sizeof(XVisualInfo));
    CAMLreturn(visInfo);
}

static const long vinfo_mask_table[] = {
    VisualNoMask,
    VisualIDMask,
    VisualScreenMask,
    VisualDepthMask,
    VisualClassMask,
    VisualRedMaskMask,
    VisualGreenMaskMask,
    VisualBlueMaskMask,
    VisualColormapSizeMask,
    VisualBitsPerRGBMask,
    VisualAllMask,
};

static inline long
vinfo_mask_val( value mask_list )
{
    long c_mask = 0; 
    while ( mask_list != Val_emptylist )
    {
        value head = Field(mask_list, 0);
        c_mask |= vinfo_mask_table[Long_val(head)];
        mask_list = Field(mask_list, 1);
    }
    return c_mask;
}

CAMLprim value
ml_XGetVisualInfo( value dpy, value vinfo_mask, value vinfo_template )
{
    CAMLparam3(dpy, vinfo_mask, vinfo_template);
    CAMLlocal2(via, visual_info);
    int i, nitems;
    XVisualInfo *visInfo = XGetVisualInfo(
        Display_val(dpy),
        vinfo_mask_val(vinfo_mask),
        XVisualInfo_val(vinfo_template),
        &nitems
    );
    if (!visInfo) caml_failwith("xGetVisualInfo: can't get visual");
    via = caml_alloc(nitems, 0);
    for (i=0; i<nitems; i++) {
        alloc_XVisualInfo(visual_info);
        memcpy(XVisualInfo_val(visual_info), &(visInfo[i]), sizeof(XVisualInfo));
        //XFree(visInfo[i]);
        Store_field(via, i, visual_info);
    }
    XFree(visInfo);
    CAMLreturn(via);
}


static const int color_class_table[] = {
    StaticGray,
    GrayScale,
    StaticColor,
    PseudoColor,
    TrueColor,
    DirectColor,
};
#define Color_class_val(v) (color_class_table[Long_val(v)])

#define XVisualInfo_set_field(Conv_val, field) \
CAMLprim value ml_XVisualInfo_set_##field( value visinfo, value v ) { \
    XVisualInfo *vi = XVisualInfo_val(visinfo); \
    vi->field = Conv_val(v); \
    return Val_unit; \
}

XVisualInfo_set_field( Visual_val,      visual )
XVisualInfo_set_field( VisualID_val,    visualid )
XVisualInfo_set_field( ScreenNB_val,    screen )
XVisualInfo_set_field( Long_val,        depth )
XVisualInfo_set_field( Color_class_val, class )
XVisualInfo_set_field( ULong_val,       red_mask )
XVisualInfo_set_field( ULong_val,       green_mask )
XVisualInfo_set_field( ULong_val,       blue_mask )
XVisualInfo_set_field( Long_val,        colormap_size )
XVisualInfo_set_field( Long_val,        bits_per_rgb )


CAMLprim value
ml_XMatchVisualInfo( value dpy, value screen, value depth, value color_class )
{
    CAMLparam4(dpy, screen, depth, color_class);
    CAMLlocal1(visual_info);
    alloc_XVisualInfo(visual_info);
    Status st = XMatchVisualInfo(
        Display_val(dpy),
        ScreenNB_val(screen),
        Int_val(depth),
        Color_class_val(color_class),
        XVisualInfo_val(visual_info)
    );
    if (st == False) caml_failwith("xMatchVisualInfo: no visual found");
    CAMLreturn(visual_info);
}

CAMLprim value
ml_XVisualInfo_contents( value visual_info )
{
    CAMLparam1(visual_info);
    CAMLlocal1(dat);

    XVisualInfo * vi = XVisualInfo_val(visual_info);

    dat = caml_alloc(9, 0);
    Store_field( dat, 0, Val_Visual(vi->visual) );
    Store_field( dat, 1, Val_VisualID(vi->visualid) );
    Store_field( dat, 2, Val_screenNB(vi->screen) );
    Store_field( dat, 3, Val_int(vi->depth) );
    Store_field( dat, 4, Val_long(vi->red_mask) );
    Store_field( dat, 5, Val_long(vi->green_mask) );
    Store_field( dat, 6, Val_long(vi->blue_mask) );
    Store_field( dat, 7, Val_int(vi->colormap_size) );
    Store_field( dat, 8, Val_int(vi->bits_per_rgb) );
    CAMLreturn(dat);
}

CAMLprim value
ml_XFree_XVisualInfo( value visual_info )
{
    XVisualInfo * vi = XVisualInfo_val(visual_info);
    if (vi == NULL) {
        caml_invalid_argument("xFree_xVisualInfo: xVisualInfo NULL pointer");
    } else {
        XFree( vi );
        vi = NULL;
    }
    return Val_unit;
}

CAMLprim value
ml_XCreateColormap( value dpy, value win, value visual, value alloc )
{
    Colormap colormap = XCreateColormap(
        Display_val(dpy),
        Window_val(win),
        Visual_val(visual),
        ( Int_val(alloc) ? AllocAll : AllocNone)
    );
    return Val_Colormap(colormap);
}

CAMLprim value
ml_XFreeColormap( value dpy, value colormap )
{
    GET_STATUS  XFreeColormap(
        Display_val(dpy),
        Colormap_val(colormap) );
    CHECK_STATUS(XFreeColormap,1);
    return Val_unit;
}

CAMLprim value
ml_XCopyColormapAndFree( value dpy, value colormap )
{
    Colormap new_colormap = XCopyColormapAndFree(
        Display_val(dpy),
        Colormap_val(colormap) );
    /*
    if ((new_colormap=XCopyColormapAndFree(Display_val(dpy),
                                           Colormap_val(colormap))) == BadAlloc)
        caml_failwith("Can't Create new colormap");
    */
    return Val_Colormap(new_colormap);
}

CAMLprim value
ml_XSetWindowColormap( value dpy, value win, value colormap )
{
    GET_STATUS  XSetWindowColormap(
        Display_val(dpy),
        Window_val(win),
        Colormap_val(colormap) );
    CHECK_STATUS(XSetWindowColormap,1);
    return Val_unit;
}

CAMLprim value
_ml_XSetWindowAttributes_alloc( value unit )
{
    CAMLparam0();
    CAMLlocal2(ret, wattr);
    alloc_XSetWindowAttributes(wattr);
    ret = caml_alloc(2, 0);
    Store_field(ret, 0, wattr );
    Store_field(ret, 1, (value) 0 );
    CAMLreturn(ret);
}

CAMLprim value
ml_XSetWindowAttributes_alloc( value unit )
{
    CAMLparam0();
    CAMLlocal1(wattr);
    alloc_XSetWindowAttributes(wattr);
    CAMLreturn(wattr);
}


#define WATTR_SET(field_c_type, attr_field, field_mask, Conv_val, ml_type) \
\
CAMLprim value \
ml_xSetWindowAttributes_set_##attr_field( value ml_wattr, value _##attr_field ) \
{ \
    XSetWindowAttributes * wattr; \
    wattr = XSetWindowAttributes_val(ml_wattr); \
    wattr->attr_field = Conv_val(_##attr_field); \
    return Val_unit; \
}

/* setting the fields of the struct XSetWindowAttributes and the associated mask */

WATTR_SET( Pixmap,        background_pixmap,     CWBackPixmap,       Pixmap_val,    pixmap          )
WATTR_SET( unsigned long, background_pixel,      CWBackPixel,        Pixel_color_val, uint          )
WATTR_SET( Pixmap,        border_pixmap,         CWBorderPixmap,     Pixmap_val,    pixmap          )
WATTR_SET( unsigned long, border_pixel,          CWBorderPixel,      Pixel_color_val, uint          )
WATTR_SET( int,           bit_gravity,           CWBitGravity,       Int_val,       int             )
WATTR_SET( int,           win_gravity,           CWWinGravity,       Int_val,       int             )
WATTR_SET( int,           backing_store,         CWBackingStore,     Int_val,       int             )
WATTR_SET( unsigned long, backing_planes,        CWBackingPlanes,    ULong_val,     uint            )//XXX
WATTR_SET( unsigned long, backing_pixel,         CWBackingPixel,     ULong_val,     uint            )//pixel_color?
WATTR_SET( Bool,          save_under,            CWSaveUnder,        Bool_val,      bool            )
WATTR_SET( long,          event_mask,            CWEventMask,        Eventmask_val, event_mask_list )
WATTR_SET( long,          do_not_propagate_mask, CWDontPropagate,    Long_val,      int             )
WATTR_SET( Bool,          override_redirect,     CWOverrideRedirect, Bool_val,      bool            )
WATTR_SET( Colormap,      colormap,              CWColormap,         Colormap_val,  colormap        )
WATTR_SET( Cursor,        cursor,                CWCursor,           Cursor_val,    cursor          )

static const unsigned int window_class_table[] = {
    CopyFromParent,
    InputOutput,
    InputOnly,
};


static const unsigned long winattr_valuemask_table[] = {
    CWBackPixmap,
    CWBackPixel,
    CWBorderPixmap,
    CWBorderPixel,
    CWBitGravity,
    CWWinGravity,
    CWBackingStore,
    CWBackingPlanes,
    CWBackingPixel,
    CWOverrideRedirect,
    CWSaveUnder,
    CWEventMask,
    CWDontPropagate,
    CWColormap,
    CWCursor,
};

static inline unsigned long
winattr_valuemask_val( value mask_list )
{
    unsigned long c_mask = 0; 
    while ( mask_list != Val_emptylist )
    {
        value head = Field(mask_list, 0);
        c_mask |= winattr_valuemask_table[Long_val(head)];
        mask_list = Field(mask_list, 1);
    }
    return c_mask;
}


CAMLprim value
ml_XGetWindowAttributes( value dpy, value win )
{
    CAMLparam2(dpy, win);
    CAMLlocal1(wattr);
    alloc_XWindowAttributes(wattr);
    //GET_STATUS
    XGetWindowAttributes(
        Display_val(dpy),
        Window_val(win),
        XWindowAttributes_val(wattr)
    );
    //CHECK_STATUS(XGetWindowAttributes,1);
    CAMLreturn(wattr);
}


#define quote(s) #s

#define WATTR_GET( Val_conv, field_name, ml_type ) \
\
CAMLprim value \
ml_XWindowAttributes_##field_name( value wattr ) { \
    return Val_conv( XWindowAttributes_val(wattr)->field_name ); \
}
#define WATTR_GML( Val_conv, field_name, ml_type ) \
external xWindowAttributes_##field_name: xWindowAttributes -> ml_type = quote(ml_XWindowAttributes_##field_name)

WATTR_GET( Val_int,      x,             int )
WATTR_GET( Val_int,      y,             int )
WATTR_GET( Val_int,      width,         int )
WATTR_GET( Val_int,      height,        int )
WATTR_GET( Val_int,      depth,         int )
WATTR_GET( Val_XScreen,  screen,        xScreen )
WATTR_GET( Val_int,      border_width,  int )
WATTR_GET( Val_Colormap, colormap,      colormap )
WATTR_GET( Val_bool,     map_installed, bool )

CAMLprim value
ml_XWindowAttributes_all( value dpy, value win )
{
    CAMLparam2(dpy, win);
    CAMLlocal1(wattrs);
    XWindowAttributes c_wattr;
    //GET_STATUS
    XGetWindowAttributes(
        Display_val(dpy),
        Window_val(win),
        &c_wattr
    );
    //CHECK_STATUS(XGetWindowAttributes,1);
    wattrs = caml_alloc(5, 0);
    Store_field( wattrs, 0, Val_int( c_wattr.x ) );
    Store_field( wattrs, 1, Val_int( c_wattr.y ) );
    Store_field( wattrs, 2, Val_int( c_wattr.width ) );
    Store_field( wattrs, 3, Val_int( c_wattr.height ) );
    Store_field( wattrs, 4, Val_int( c_wattr.depth ) );
    CAMLreturn(wattrs);
}

#if 0
typedef struct {
    int x, y;                   /* location of window */
    int width, height;          /* width and height of window */
    int border_width;           /* border width of window */
    int depth;                  /* depth of window */
    Visual *visual;             /* the associated visual structure */
    Window root;                /* root of screen containing window */
#if defined(__cplusplus) || defined(c_plusplus)
    int c_class;                /* C++ InputOutput, InputOnly*/
#else
    int class;                  /* InputOutput, InputOnly*/
#endif
    int bit_gravity;            /* one of bit gravity values */
    int win_gravity;            /* one of the window gravity values */
    int backing_store;          /* NotUseful, WhenMapped, Always */
    unsigned long backing_planes;/* planes to be preserved if possible */
    unsigned long backing_pixel;/* value to be used when restoring planes */
    Bool save_under;            /* boolean, should bits under be saved? */
    Colormap colormap;          /* color map to be associated with window */
    Bool map_installed;         /* boolean, is color map currently installed*/
    int map_state;              /* IsUnmapped, IsUnviewable, IsViewable */
    long all_event_masks;       /* set of events all people have interest in*/
    long your_event_mask;       /* my event mask */
    long do_not_propagate_mask; /* set of events that should not propagate */
    Bool override_redirect;     /* boolean value for override-redirect */
    Screen *screen;             /* back pointer to correct screen */
} XWindowAttributes;
#endif


CAMLprim value
ml_XCreateWindow(
        value dpy, value parent,
        value x, value y,
        value width, value height,
        value border_width,
        value depth, value class, value visual,
        value valuemask, value attributes )
{
    Window win = XCreateWindow(
        Display_val(dpy),
        Window_val(parent),
        Int_val(x),
        Int_val(y),
        UInt_val(width),
        UInt_val(height),
        UInt_val(border_width),
        Int_val(depth),
        window_class_table[Long_val(class)],
        Visual_val(visual),
        winattr_valuemask_val(valuemask),
        XSetWindowAttributes_val(attributes)
    );
    if (!win) caml_failwith("XCreateWindow");
    return Val_Window(win);
}
CAMLprim value
ml_XCreateWindow_bytecode( value * argv, int argn )
{
    return ml_XCreateWindow( argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
                             argv[6], argv[7], argv[8], argv[9], argv[10], argv[11] );
}

CAMLprim value
ml_XResizeWindow( value dpy, value win, value width, value height )
{
    GET_STATUS  XResizeWindow(
        Display_val(dpy),
        Window_val(win),
        UInt_val(width),
        UInt_val(height)
    );
    CHECK_STATUS(XResizeWindow,1);
    return Val_unit;
}

CAMLprim value
ml_XMoveWindow( value dpy, value win, value x, value y )
{
    GET_STATUS  XMoveWindow(
        Display_val(dpy),
        Window_val(win),
        Int_val(x),
        Int_val(y)
    );
    CHECK_STATUS(XMoveWindow,1);
    return Val_unit;
}

CAMLprim value
ml_XMoveResizeWindow( value dpy, value win, value x, value y, value width, value height )
{
    GET_STATUS  XMoveResizeWindow(
        Display_val(dpy),
        Window_val(win),
        Int_val(x),
        Int_val(y),
        UInt_val(width),
        UInt_val(height)
    );
    CHECK_STATUS(XMoveResizeWindow,1);
    return Val_unit;
}
CAMLprim value
ml_XMoveResizeWindow_bytecode( value * argv, int argn )
{
    return ml_XMoveResizeWindow( argv[0], argv[1], argv[2],
                                 argv[3], argv[4], argv[5] );
}

CAMLprim value
ml_XLowerWindow( value dpy, value win )
{
    GET_STATUS  XLowerWindow(
        Display_val(dpy),
        Window_val(win) );
    CHECK_STATUS(XLowerWindow,1);
    return Val_unit;
}

CAMLprim value
ml_XRaiseWindow( value dpy, value win )
{
    GET_STATUS  XRaiseWindow(
        Display_val(dpy),
        Window_val(win) );
    CHECK_STATUS(XRaiseWindow,1);
    return Val_unit;
}

CAMLprim value
ml_XStoreName( value dpy, value win, value name )
{
    GET_STATUS XStoreName(  
        Display_val(dpy),
        Window_val(win),
        String_val(name) );
    CHECK_STATUS(XStoreName, 1);
    return Val_unit;
}

CAMLprim value
ml_XFetchName( value dpy, value win )
{
    CAMLlocal1( ml_window_name );
    char * window_name = NULL;
    //GET_STATUS
    XFetchName(
        Display_val(dpy),
        Window_val(win),
        &window_name
    );
    //CHECK_STATUS(XFetchName,1);
    if (window_name != NULL) {
        ml_window_name = caml_copy_string(window_name);
        XFree(window_name);
    } else {
        caml_failwith("xFetchName");
    }
    return ml_window_name;
}

CAMLprim value
ml_XSelectInput( value dpy, value win, value ml_event_mask )
{
    long event_mask = Eventmask_val( ml_event_mask );
    GET_STATUS  XSelectInput(
        Display_val(dpy),
        Window_val(win),
        event_mask );
    CHECK_STATUS(XSelectInput, 1);
    return Val_unit;
}

CAMLprim value
ml_XMapWindow( value dpy, value win )
{
    GET_STATUS  XMapWindow(
        Display_val(dpy),
        Window_val(win) );
    CHECK_STATUS(XMapWindow, 1);
    return Val_unit;
}

CAMLprim value
ml_XMapSubwindows( value dpy, value win )
{
    GET_STATUS  XMapSubwindows(
        Display_val(dpy),
        Window_val(win) );
    CHECK_STATUS(XMapSubwindows, 1);
    return Val_unit;
}

CAMLprim value
ml_XMapRaised( value dpy, value win )
{
    //GET_STATUS
    XMapRaised(
        Display_val(dpy),
        Window_val(win) );
    //CHECK_STATUS(XMapRaised, 1);
    return Val_unit;
}

CAMLprim value
ml_XUnmapWindow( value dpy, value win )
{
    //GET_STATUS
    XUnmapWindow(
        Display_val(dpy),
        Window_val(win) );
    //CHECK_STATUS(XUnmapWindow,1);
    return Val_unit;
}

CAMLprim value
ml_XReparentWindow( value dpy, value win, value parent, value x, value y )
{
    GET_STATUS  XReparentWindow(
        Display_val(dpy),
        Window_val(win),
        Window_val(parent),
        Int_val(x),
        Int_val(y)
    );
    CHECK_STATUS(XReparentWindow,1);
    return Val_unit;
}

CAMLprim value
ml_XChangeSaveSet( value dpy, value win, value change_mode )
{
    //GET_STATUS
    XChangeSaveSet(
        Display_val(dpy),
        Window_val(win),
        (Int_val(change_mode) ? SetModeDelete : SetModeInsert)
    );
    //CHECK_STATUS(XChangeSaveSet,1);
    return Val_unit;
}

CAMLprim value
ml_XAddToSaveSet( value dpy, value win )
{
    //GET_STATUS
    XAddToSaveSet(
        Display_val(dpy),
        Window_val(win)
    );
    //CHECK_STATUS(XAddToSaveSet,1);
    return Val_unit;
}

CAMLprim value
ml_XRemoveFromSaveSet( value dpy, value win )
{
    //GET_STATUS
    XRemoveFromSaveSet(
        Display_val(dpy),
        Window_val(win)
    );
    //CHECK_STATUS(XRemoveFromSaveSet,1);
    return Val_unit;
}


CAMLprim value
ml_XQueryTree( value dpy, value win )
{
    CAMLparam2( dpy, win );
    CAMLlocal2( ret, children_arr );

    Window root_win, parent_win, *children;
    unsigned int nchildren, i;

    children = NULL;
    Status status = XQueryTree(
        Display_val(dpy),
        Window_val(win),
        &root_win,
        &parent_win,
        &children,
        &nchildren
    );
    if (status != 1) {
        if (children != NULL) XFree(children);
        caml_failwith("xQueryTree");
    }

    children_arr = caml_alloc(nchildren, 0);
    for (i=0; i < nchildren; i++) {
        Store_field( children_arr, i, Val_Window(children[i]) );
    }
    XFree(children);

    ret = caml_alloc(3, 0);
    Store_field( ret, 0, Val_Window(root_win) );
    Store_field( ret, 1, Val_Window(parent_win) );
    Store_field( ret, 2, children_arr );

    CAMLreturn( ret );
}

CAMLprim value
ml_XRestackWindows( value dpy, value ml_wins )
{
    int nwindows, i;
    Window* windows;
    nwindows = Wosize_val(ml_wins);
    windows = malloc(nwindows * sizeof(Window*));
    for (i=0; i < nwindows; i++) {
       windows[i] = Window_val(Field(ml_wins, i));
    }
    //GET_STATUS
    XRestackWindows(
        Display_val(dpy),
        windows,
        nwindows
    );
    free(windows);
    //CHECK_STATUS(XRestackWindows,1);
    return Val_unit;
}


static const int circulateSubwinsDir_table[] = {
    RaiseLowest,
    LowerHighest
};
#define CirculateSubwinsDir_val(i) (circulateSubwinsDir_table[Long_val(i)])

CAMLprim value
ml_XCirculateSubwindows( value dpy, value win, value dir )
{
    //GET_STATUS
    XCirculateSubwindows(
        Display_val(dpy),
        Window_val(win),
        CirculateSubwinsDir_val(dir)
    );
    //CHECK_STATUS(XCirculateSubwindows,1);
    return Val_unit;
}

CAMLprim value
ml_XCirculateSubwindowsDown( value dpy, value win )
{
    //GET_STATUS
    XCirculateSubwindowsDown(
        Display_val(dpy),
        Window_val(win)
    );
    //CHECK_STATUS(XCirculateSubwindowsDown,1);
    return Val_unit;
}

CAMLprim value
ml_XCirculateSubwindowsUp( value dpy, value win )
{
    //GET_STATUS
    XCirculateSubwindowsUp(
        Display_val(dpy),
        Window_val(win)
    );
    //CHECK_STATUS(XCirculateSubwindowsUp,1);
    return Val_unit;
}


CAMLprim value
ml_XGetWindowProperty_string(
        value dpy,
        value win,
        value property,
        value long_offset,
        value long_length,
        value delete,
        value req_type
        )
{
    CAMLparam5(dpy, win, property, long_offset, long_length);
    CAMLxparam2(delete, req_type);
    CAMLlocal1(ret);

    Atom actual_type;
    int actual_format;
    unsigned long nitems, bytes_after;
    /*unsigned*/ char* prop;

    (void) XGetWindowProperty(
        Display_val(dpy),
        Window_val(win),
        Atom_val(property),
        Long_val(long_offset),
        Long_val(long_length),
        Bool_val(delete),
        AnyPropertyType,  // Atom req_type,  TODO
        &actual_type,
        &actual_format,
        &nitems,
        &bytes_after,
        (unsigned char**)&prop
    );
    ret = caml_alloc(5, 0);
    Store_field(ret, 0, Val_Atom(actual_type) );
    Store_field(ret, 1, Val_int(actual_format) );
    Store_field(ret, 2, Val_long(nitems) );
    Store_field(ret, 3, Val_long(bytes_after) );
    Store_field(ret, 4, caml_copy_string(prop) );
    XFree(prop);
    CAMLreturn(ret);
}
CAMLprim value
ml_XGetWindowProperty_string_bytecode( value * argv, int argn )
{
    return ml_XGetWindowProperty_string( argv[0], argv[1], argv[2],
                                         argv[3], argv[4], argv[5], argv[6] );
}

CAMLprim value
ml_XGetWindowProperty_window(
        value dpy,
        value win,
        value property,
        value long_offset,
        value long_length,
        value delete,
        value req_type
        )
{
    CAMLparam5(dpy, win, property, long_offset, long_length);
    CAMLxparam2(delete, req_type);
    CAMLlocal1(ret);

    Atom actual_type;
    int actual_format;
    unsigned long nitems, bytes_after;
    Window *prop;

    (void) XGetWindowProperty(
        Display_val(dpy),
        Window_val(win),
        Atom_val(property),
        Long_val(long_offset),
        Long_val(long_length),
        Bool_val(delete),
        AnyPropertyType,  // Atom req_type,   TODO
        &actual_type,
        &actual_format,
        &nitems,
        &bytes_after,
        (unsigned char**)&prop
    );
    ret = caml_alloc(5, 0);
    Store_field(ret, 0, Val_Atom(actual_type) );
    Store_field(ret, 1, Val_int(actual_format) );
    Store_field(ret, 2, Val_long(nitems) );
    Store_field(ret, 3, Val_long(bytes_after) );
    Store_field(ret, 4, Val_Window(prop[0]) );
    XFree(prop);
    CAMLreturn(ret);
}
CAMLprim value
ml_XGetWindowProperty_window_bytecode( value * argv, int argn )
{
    return ml_XGetWindowProperty_window( argv[0], argv[1], argv[2],
                                         argv[3], argv[4], argv[5], argv[6] );
}


/* Managing Installed Colormaps */

CAMLprim value
ml_XInstallColormap( value dpy, value colormap )
{
    //GET_STATUS
    XInstallColormap(
        Display_val(dpy),
        Colormap_val(colormap)
    );
    //CHECK_STATUS(XInstallColormap,1);
    return Val_unit;
}

CAMLprim value
ml_XUninstallColormap( value dpy, value colormap )
{
    //GET_STATUS
    XUninstallColormap(
        Display_val(dpy),
        Colormap_val(colormap)
    );
    //CHECK_STATUS(XUninstallColormap,1);
    return Val_unit;
}

CAMLprim value
ml_XListInstalledColormaps( value dpy, value win )
{
    CAMLparam2(dpy, win);
    CAMLlocal1(ret);
    int i, num;
    Colormap *colormaps =
        XListInstalledColormaps(
            Display_val(dpy),
            Window_val(win),
            &num
        );
    ret = caml_alloc(num, 0);
    for (i=0; i<num; ++i) {
        Store_field(ret, i, Val_Colormap(colormaps[i]) );
    }
    XFree(colormaps);
    CAMLreturn(ret);
}


CAMLprim value
ml_XKillClient( value dpy, value resource )
{
    //GET_STATUS
    XKillClient(
        Display_val(dpy),
        (XID) resource
    );
    //CHECK_STATUS(XKillClient,1);
    return Val_unit;
}

/* Threads */

CAMLprim value
ml_XInitThreads( value unit )
{
    GET_STATUS XInitThreads();
    CHECK_STATUS(XInitThreads,1);
    return Val_unit;
}

CAMLprim value
ml_XLockDisplay( value dpy )
{
    XLockDisplay( Display_val(dpy) );
    return Val_unit;
}

CAMLprim value
ml_XUnlockDisplay( value dpy )
{
    XUnlockDisplay( Display_val(dpy) );
    return Val_unit;
}



CAMLprim value
ml_XSetWMProtocols( value dpy, value win, value protocols, value count )
{
    Status status = XSetWMProtocols(
        Display_val(dpy),
        Window_val(win),
        Atom_val_addr(protocols),
        Int_val(count) );
    CHECK_STATUS(XSetWMProtocols, 1);
    return Val_unit;
}

CAMLprim value
ml_XInternAtom( value dpy, value atom_name, value only_if_exists )
{
    Atom a = XInternAtom(
        Display_val(dpy),
        String_val(atom_name),
        Bool_val(only_if_exists) );
    if (a == None)
        caml_raise_not_found();
    // XInternAtom() can generate BadAlloc and BadValue errors.
    return Val_Atom(a);
}

CAMLprim value
ml_XInternAtoms( value dpy, value ml_names, value only_if_exists )
{
    CAMLparam3(dpy, ml_names, only_if_exists);
    CAMLlocal1(ret);
    int count, i;
    char** names;
    Atom* atoms_return;
    count = Wosize_val(ml_names);
    atoms_return = malloc(count * sizeof(Atom));
    names = malloc(count * sizeof(char *));
    for (i=0; i<count; ++i) {
        names[i] = String_val(Field(ml_names,i));
    }
    Status st = XInternAtoms(
        Display_val(dpy),
        names,
        count,
        Bool_val(only_if_exists),
        atoms_return
    );
    if (st == 0)
        caml_failwith("xInternAtoms: atoms were not returned for all of the names");

    ret = caml_alloc(count, 0);
    for (i=0; i<count; ++i) {
        Store_field( ret, i, Val_Atom(atoms_return[i]) );
    }
    free(atoms_return);
    free(names);
    CAMLreturn(ret);
}

CAMLprim value
ml_XGetAtomName( value dpy, value atom )
{
    CAMLparam2(dpy, atom);
    CAMLlocal1(ml_atom_name);
    char * atom_name = XGetAtomName(
        Display_val(dpy),
        Atom_val(atom)
    );
    if (atom_name == NULL)
        caml_failwith("xGetAtomName");
    ml_atom_name = caml_copy_string(atom_name);
    XFree((void *)atom_name);
    CAMLreturn(ml_atom_name);
}


/* XSizeHints, from <X11/Xutil.h> */

CAMLprim value
ml_alloc_XSizeHints( value unit )
{
    CAMLparam0();
    CAMLlocal1(size_hints);
    alloc_XSizeHints(size_hints);
    memset(XSizeHints_val(size_hints), 0, sizeof(XSizeHints));
    CAMLreturn(size_hints);
}

CAMLprim value
ml_XSizeHints_set_USPosition( value size_hints, value _x, value _y )
{
    XSizeHints *sh…